{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | instances for QuickCheck Arbitrary and approximate equality module Instances where import Diagrams.Prelude import Numeric.Extras import Test.Tasty.QuickCheck (Arbitrary(..), Gen) import qualified Test.Tasty.QuickCheck as QC ------------------------------------------------------------ -- Approximate Comparison for Doubles, Points epsilon :: Double epsilon = 0.001 class Approx a where (=~) :: a -> a -> Bool infix 4 =~ --instance (Fractional a, Ord a) => Approx a where instance Approx Double where (=~) a b = abs (a - b) < epsilon instance Approx Float where (=~) a b = abs (a - b) < 0.001 instance Approx n => Approx (V2 n) where z1 =~ z2 = (z1^._x) =~ (z2^._x) && (z1^._y) =~ (z2^._y) instance Approx n => Approx (V3 n) where z1 =~ z2 = (z1^._x) =~ (z2^._x) && (z1^._y) =~ (z2^._y) && (z1^._z) =~ (z2^._z) instance Approx (v n) => Approx (Point v n) where p =~ q = view _Point p =~ view _Point q instance (Approx n, RealExtras n) => Approx (Angle n) where a =~ b = normA (a^.rad) =~ normA (b^.rad) where normA ang = let ang' = ang `fmod` pi in if ang' >= 0 then ang' else ang'+pi instance Approx n => Approx (Offset Closed V2 n) where OffsetClosed v0 =~ OffsetClosed v1 = v0 =~ v1 instance Approx n => Approx (Segment Closed V2 n) where Linear o0 =~ Linear o1 = o0 =~ o1 Cubic c0 d0 o0 =~ Cubic c1 d1 o1 = c0 =~ c1 && d0 =~ d1 && o0 =~ o1 _ =~ _ = False -- The above is conservative: -- Cubic never equals Linear even if they describe the same points instance Approx n => Approx (Trail' Line V2 n) where l0 =~ l1 = and \$ zipWith (=~) (lineSegments l0) (lineSegments l1) instance Approx n => Approx (Trail' Loop V2 n) where l0 =~ l1 = fst (loopSegments l0) =~ fst (loopSegments l1) instance (Approx n, Floating n, Ord n) => Approx (Trail V2 n) where t0 =~ t1 = and \$ zipWith (=~) (trailSegments t0) (trailSegments t1) instance (Approx a, Approx (Vn a), Num (N a), Additive (V a)) => Approx (Located a) where a0 =~ a1 = (loc a0 .-. origin) =~ (loc a1 .-. origin) && unLoc a0 =~ unLoc a1 instance Approx a => Approx (Maybe a) where Nothing =~ Nothing = True Nothing =~ Just _ = False Just _ =~ Nothing = False Just l =~ Just r = l =~ r -- These may be too general instance Approx a => Approx [a] where a =~ b = and \$ zipWith (=~) a b instance (Approx a, Approx b) => Approx (a, b) where (a0, b0) =~ (a1,b1) = (a0 =~ a1) && (b0 =~ b1) ------------------------------------------------------------ -- Arbitrary instances for Points, Paths instance Arbitrary n => Arbitrary (V2 n) where arbitrary = (^&) <\$> arbitrary <*> arbitrary shrink (coords -> x :& y) = (^&) <\$> shrink x <*> shrink y instance Arbitrary n => Arbitrary (V3 n) where arbitrary = V3 <\$> arbitrary <*> arbitrary <*> arbitrary shrink (coords -> x :& y :& z) = V3 <\$> shrink x <*> shrink y <*> shrink z instance Arbitrary (v n) => Arbitrary (Point v n) where arbitrary = P <\$> arbitrary shrink (P v) = P <\$> shrink v instance (Arbitrary n, Floating n, Ord n) => Arbitrary (Transformation V2 n) where arbitrary = QC.sized arbT where arbT 0 = return mempty arbT n = QC.oneof [ rotation <\$> arbitrary , scaling <\$> arbitrary , translation <\$> arbitrary , reflectionAbout <\$> arbitrary <*> arbitrary , (<>) <\$> arbT (n `div` 2) <*> arbT (n `div` 2) ] instance Arbitrary n => Arbitrary (Angle n) where arbitrary = review rad <\$> arbitrary instance (Arbitrary n, Floating n) => Arbitrary (Direction V2 n) where arbitrary = rotate <\$> arbitrary <*> pure xDir -- -- | Not a valid Show instance because not valid Haskell input -- instance (Show n, RealFloat n) => Show (Direction V2 n) where -- show d = "Dir" <> ( show \$ d ^. _theta . turn ) -- NOTE on shrinks: Adding definitions of 'shrink' below seems to work -- in simple tests, but test case failures hang for a very long time -- (presumably trying lots and lots of expensive shrinks). Not sure -- how to make shrinking more tractable. instance (Arbitrary a, Arbitrary (Vn a)) => Arbitrary (Located a) where arbitrary = at <\$> arbitrary <*> arbitrary -- shrink (viewLoc -> (p,a)) = uncurry at <\$> shrink (a,p) instance Arbitrary n => Arbitrary (Offset Closed V2 n) where arbitrary = OffsetClosed <\$> arbitrary -- shrink (OffsetClosed x) = OffsetClosed <\$> shrink x instance Arbitrary n => Arbitrary (Segment Closed V2 n) where arbitrary = QC.oneof [Linear <\$> arbitrary, Cubic <\$> arbitrary <*> arbitrary <*> arbitrary] -- shrink (Linear x) = Linear <\$> shrink x -- shrink (Cubic x y z) = Linear z -- : [Cubic x' y' z' | (x',y',z') <- shrink (x,y,z)] instance (Arbitrary n, Floating n, Ord n) => Arbitrary (Trail' Line V2 n) where arbitrary = lineFromSegments <\$> arbitrary -- shrink (lineSegments -> segs) = lineFromSegments <\$> shrink segs instance (Arbitrary n, Floating n, Ord n) => Arbitrary (Trail' Loop V2 n) where arbitrary = closeLine <\$> arbitrary -- shrink (cutLoop -> l) = closeLine <\$> shrink l instance (Arbitrary n, Floating n, Ord n) => Arbitrary (Trail V2 n) where arbitrary = QC.oneof [Trail <\$> (arbitrary :: Gen (Trail' Loop V2 n)), Trail <\$> (arbitrary :: Gen (Trail' Line V2 n))]