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
158
159
160
|
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Main where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
import Control.Monad (unless)
import Data.Semigroup
import System.Exit (exitFailure)
import Test.QuickCheck
import Text.Printf (printf)
import Data.Active
import Linear.Affine
import Linear.Vector
main :: IO ()
main = do
results <- mapM (\(s,t) -> printf "%-40s" s >> t) tests
unless (all isSuccess results) exitFailure
where
qc x = quickCheckWithResult (stdArgs { maxSuccess = 200 }) x
tests = [ ("era/start", qc prop_era_start )
, ("era/end", qc prop_era_end )
, ("duration", qc prop_duration )
, ("shiftDyn/start", qc prop_shiftDynamic_start )
, ("shiftDyn/end", qc prop_shiftDynamic_end )
, ("shiftDyn/fun", qc prop_shiftDynamic_fun )
, ("active/semi-hom", qc prop_active_semi_hom )
, ("ui/id", qc prop_ui_id )
, ("stretch/start", qc prop_stretch_start )
, ("stretch/dur", qc prop_stretch_dur )
, ("stretchTo/dur", qc prop_stretchTo_dur )
, ("during/const", qc prop_during_const )
, ("during/start", qc prop_during_start )
, ("during/end", qc prop_during_end )
, ("shift/start", qc prop_shift_start )
, ("shift/end", qc prop_shift_end )
-- , ("backwards", qc prop_backwards )
, ("atTime/start", qc prop_atTime_start )
, ("atTime/fun", qc prop_atTime_fun )
]
{-# ANN main ("HLint: ignore Eta reduce" :: String) #-}
-- eta reducing qc breaks it
instance (Fractional n) => Arbitrary (Time n) where
arbitrary = fromRational <$> arbitrary
instance (Real n) => CoArbitrary (Time n) where
coarbitrary t = coarbitrary (toRational t)
instance (Fractional n) => Arbitrary (Duration n) where
arbitrary = (fromRational . abs) <$> arbitrary
instance Arbitrary a => Arbitrary (Dynamic a) where
arbitrary = do
s <- arbitrary
d <- arbitrary
mkDynamic <$> pure s <*> pure (s .+^ d) <*> arbitrary
instance Show (Dynamic a) where
show (Dynamic e _) = "<" ++ show e ++ ">"
instance Arbitrary a => Arbitrary (Active a) where
arbitrary = oneof [ pure <$> arbitrary
, fromDynamic <$> arbitrary
]
instance Show a => Show (Active a) where
show = onActive (\c -> "<<" ++ show c ++ ">>")
show
prop_era_start :: Time Rational -> Time Rational -> Bool
prop_era_start t1 t2 = start (mkEra t1 t2) == t1
prop_era_end :: Time Rational -> Time Rational -> Bool
prop_era_end t1 t2 = end (mkEra t1 t2) == t2
prop_duration :: Time Rational -> Time Rational -> Bool
prop_duration t1 t2 = duration (mkEra t1 t2) == (t2 .-. t1)
prop_shiftDynamic_start :: Duration Rational -> Dynamic Bool -> Bool
prop_shiftDynamic_start dur dyn
= (start . era) (shiftDynamic dur dyn) == ((start . era) dyn .+^ dur)
prop_shiftDynamic_end :: Duration Rational -> Dynamic Bool -> Bool
prop_shiftDynamic_end dur dyn
= (end . era) (shiftDynamic dur dyn) == ((end . era) dyn .+^ dur)
prop_shiftDynamic_fun :: Duration Rational -> Dynamic Bool -> Time Rational -> Bool
prop_shiftDynamic_fun dur dyn t
= runDynamic dyn t == runDynamic (shiftDynamic dur dyn) (t .+^ dur)
prop_active_semi_hom :: Active Any -> Active Any -> Time Rational -> Bool
prop_active_semi_hom a1 a2 t =
runActive a1 t <> runActive a2 t == runActive (a1 <> a2) t
prop_ui_id :: Time Rational -> Bool
prop_ui_id t = runActive (ui :: Active (Time Rational)) t == t
prop_stretch_start :: Rational -> Active Bool -> Bool
prop_stretch_start r a
= (start <$> activeEra a) == (start <$> activeEra (stretch r a))
prop_stretch_dur :: Rational -> Active Bool -> Bool
prop_stretch_dur r a
= (((r *^) . duration) <$> activeEra a) == (duration <$> activeEra (stretch r a))
{-
prop_stretch_fun :: Rational -> Blind (Active Bool) -> Time -> Bool
prop_stretch_fun r (Blind a) t
= runActive a t runActive (stretch r t)
-}
prop_stretchTo_dur :: Positive (Duration Rational) -> Active Bool -> Property
prop_stretchTo_dur (Positive dur) a
= isDynamic a && ((duration <$> activeEra a) /= Just 0)
==> (duration <$> activeEra (stretchTo dur a)) == Just dur
prop_during_const :: Active Bool -> Active Bool -> Property
prop_during_const a1 a2 =
(isConstant a1 || isConstant a2) ==> (start <$> activeEra (a1 `during` a2)) == (start <$> activeEra a1)
prop_during_start :: Dynamic Bool -> Dynamic Bool -> Bool
prop_during_start d1 d2 =
(start <$> activeEra (a1 `during` a2)) == (start <$> activeEra a2)
where a1 = fromDynamic d1
a2 = fromDynamic d2
prop_during_end :: Dynamic Bool -> Dynamic Bool -> Property
prop_during_end d1 d2 =
((duration <$> activeEra a2) > Just 0) && ((duration <$> activeEra a1) > Just 0) ==>
(end <$> activeEra (a1 `during` a2)) == (end <$> activeEra a2)
where a1 = fromDynamic d1
a2 = fromDynamic d2
prop_shift_start :: Duration Rational -> Active Bool -> Bool
prop_shift_start d a =
((.+^ d) . start <$> activeEra a) == (start <$> activeEra (shift d a))
prop_shift_end :: Duration Rational -> Active Bool -> Bool
prop_shift_end d a =
((.+^ d) . end <$> activeEra a) == (end <$> activeEra (shift d a))
prop_atTime_start :: Time Rational -> Dynamic Bool -> Bool
prop_atTime_start t dyn =
(start <$> activeEra (atTime t a)) == Just t
where a = fromDynamic dyn
prop_atTime_fun :: Time Rational -> Dynamic Bool -> Duration Rational -> Bool
prop_atTime_fun t dyn d =
runActive (atTime t a) (t .+^ d) == runActive a (s .+^ d)
where a = fromDynamic dyn
s = start (era dyn)
|
