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
|
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
module Diagrams.Test.Trail where
import Diagrams.Prelude
import Instances
import Test.Tasty
import Test.Tasty.QuickCheck
import Data.Fixed
import Data.List
tests :: TestTree
tests = testGroup "Trail"
[ let wrap :: Trail' Line V2 Double -> Located (Trail V2 Double)
wrap = (`at` origin) . wrapLine
in
testProperty "unfixTrail . fixTrail == id for lines" $
\l -> (unfixTrail . fixTrail $ wrap l) =~ (wrap l)
, testProperty "glueLine . cutLoop == id" $
\loop -> (glueLine . cutLoop $ loop) =~ (loop :: Trail' Loop V2 Double)
, testProperty "trailOffset == sumV . trailOffsets" $
\t -> trailOffset t =~ (sumV . trailOffsets $ (t :: Trail V2 Double))
, testProperty "reverseTrail . reverseTrail == id" $
\t -> (reverseTrail . reverseTrail $ t) =~ (t :: Trail V2 Double)
, testProperty "reverseLocTrail . reverseLocTrail == id" $
\t -> (reverseLocTrail . reverseLocTrail $ t) =~
(t :: Located (Trail V2 Double))
, testProperty "reverseLine . reverseLine == id" $
\t -> (reverseLine . reverseLine $ t) =~
(t :: Trail' Line V2 Double)
, testProperty "reverseLocLine . reverseLocLine == id" $
\t -> (reverseLocLine . reverseLocLine $ t) =~
(t :: Located (Trail' Line V2 Double))
, testProperty "reverseLoop . reverseLoop == id" $
\t -> (reverseLoop . reverseLoop $ t) =~
(t :: Trail' Loop V2 Double)
, testProperty "reverseLocLoop . reverseLocLoop == id" $
\t -> (reverseLocLoop . reverseLocLoop $ t) =~
(t :: Located (Trail' Loop V2 Double))
, testProperty "section on Trail' Line endpoints match paramaters" $
\t (Param a) (Param b) ->
let s = section (t :: Located (Trail' Line V2 Double)) a b
in t `atParam` a =~ s `atParam` 0 &&
t `atParam` b =~ s `atParam` 1
, testProperty "section on Trail' Line where a paramater is 0 or 1" $
\t (Param a) ->
let l = section (t :: Located (Trail' Line V2 Double)) 0 a
r = section (t :: Located (Trail' Line V2 Double)) a 1
in t `atParam` 0 =~ l `atParam` 0 &&
t `atParam` a =~ l `atParam` 1 &&
t `atParam` a =~ r `atParam` 0 &&
t `atParam` 1 =~ r `atParam` 1
, testProperty "section on Trail' Line where a segment paramater is 0 or 1" $
\t (Param a) i ->
let st = unLoc t # \(Line st') -> st' :: SegTree V2 Double
b | (numSegs st :: Word) > 0 = (fromIntegral (i `mod` (numSegs st + 1) :: Word)) / numSegs st
| otherwise = 0
s = section (t :: Located (Trail' Line V2 Double)) a b
in t `atParam` a =~ s `atParam` 0 &&
t `atParam` b =~ s `atParam` 1
, testProperty "section on Trail' Line matches section on FixedSegment" $
\t (Param a) (Param b) -> sectionTrailSectionFixedSegment t a b
]
data Param = Param Double deriving Show
instance Arbitrary Param where
arbitrary = Param <$> choose (-0.5, 1.5)
sectionTrailSectionFixedSegment :: Located (Trail' Line V2 Double) -> Double -> Double -> Bool
sectionTrailSectionFixedSegment t k1 k2
| null segs = t == t'
| otherwise = aSecT =~ aSecFS && bSecT =~ bSecFS
where
a = min k1 k2
b = max k1 k2
t' = section t a b
segs = fixTrail $ mapLoc wrapLine t
segs' = fixTrail $ mapLoc wrapLine t'
aSecT = head segs'
bSecT = last segs'
(aSegIx, a') = splitParam a
(bSegIx, b') = splitParam b
aSecFS = section (segs !! floor aSegIx) a' x
where x = if aSegIx == bSegIx then b' else 1
bSecFS = section (segs !! floor bSegIx) x b'
where x = if aSegIx == bSegIx then a' else 0
splitParam p | p < 0 = (0 , p * n)
| p >= 1 = (n - 1, 1 + (p - 1) * n)
| otherwise = propFrac $ p * n
where
propFrac x = let m = x `mod'` 1 in (x - m, m)
n = genericLength segs
|
