1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
|
{-# 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 (FixedSegment V2 n) where
FLinear a0 b0 =~ FLinear a1 b1 = a0 =~ a1 && b0 =~ b1
FCubic a0 b0 c0 d0 =~ FCubic a1 b1 c1 d1 = a0 =~ a1 && b0 =~ b1 && c0 =~ c1 && d0 =~ d1
_ =~ _ = False
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))]
|
