1module Main (main) where
2
3import Data.Bits      ((.&.))
4import Data.Int       (Int64)
5import Data.Word      (Word64)
6import Test.Framework (defaultMain, testGroup)
7
8import qualified System.Random.SplitMix   as SM
9import qualified System.Random.SplitMix32 as SM32
10
11import MiniQC     (Arbitrary (..), Gen (..), counterexample, testMiniProperty)
12import Uniformity
13
14main :: IO ()
15main = defaultMain
16    [ testUniformity "SM64 uniformity" (arbitrary :: Gen Word64) (.&. 0xf) 16
17    , testUniformity "SM64 uniformity" (arbitrary :: Gen Word64) (.&. 0xf0) 16
18
19    , testUniformity "bitmaskWithRejection uniformity" (arbitrary :: Gen Word64mod7) id 7
20
21    , testGroup "nextInteger"
22        [ testMiniProperty "valid" $ \a b c d seed -> do
23            let lo' = fromIntegral (a :: Int64) * fromIntegral (b :: Int64)
24                hi' = fromIntegral (c :: Int64) * fromIntegral (d :: Int64)
25
26                lo = min lo' hi'
27                hi = max lo' hi'
28
29            let g = SM.mkSMGen seed
30                (x, _) = SM.nextInteger lo' hi' g
31
32            counterexample (show x) $ lo <= x && x <= hi
33
34        , testMiniProperty "valid small" $ \a b seed -> do
35            let lo' = fromIntegral (a :: Int64) `rem` 10
36                hi' = fromIntegral (b :: Int64) `rem` 10
37
38                lo = min lo' hi'
39                hi = max lo' hi'
40
41            let g = SM.mkSMGen seed
42                (x, _) = SM.nextInteger lo' hi' g
43
44            counterexample (show x) $ lo <= x && x <= hi
45
46        , testMiniProperty "I1 valid" i1valid
47        , testUniformity "I1 uniform" arbitrary (\(I1 w) -> w) 15
48
49        , testMiniProperty "I7 valid" i7valid
50        , testUniformity "I7 uniform" arbitrary (\(I7 w) -> w `mod` 7) 7
51        ]
52
53    , testGroup "SM bitmaskWithRejection"
54        [ testMiniProperty "64" $ \w' seed -> do
55            let w = w' .&. 0xff
56            let w1 = w + 1
57            let g = SM.mkSMGen seed
58            let (x, _) = SM.bitmaskWithRejection64 w1 g
59            counterexample ("64-64 " ++ show x ++ " <= " ++ show w) (x < w1)
60        , testMiniProperty "64'" $ \w' seed -> do
61            let w = w' .&. 0xff
62            let g = SM.mkSMGen seed
63            let (x, _) = SM.bitmaskWithRejection64' w g
64            counterexample ("64-64 " ++ show x ++ " < " ++ show w) (x <= w)
65        , testMiniProperty "32" $ \w' seed -> do
66            let w = w' .&. 0xff
67            let u1 = w'
68            let g = SM.mkSMGen seed
69            let (x, _) = SM.bitmaskWithRejection32 u1 g
70            counterexample ("64-32 " ++ show x ++ " <= " ++ show w) (x < u1)
71        , testMiniProperty "32'" $ \w' seed -> do
72            let w = w' .&. 0xff
73            let u = w
74            let g = SM.mkSMGen seed
75            let (x, _) = SM.bitmaskWithRejection32' u g
76            counterexample ("64-32 " ++ show x ++ " < " ++ show w) (x <= u)
77        ]
78    , testGroup "SM32 bitmaskWithRejection"
79        [ testMiniProperty "64" $ \w' seed -> do
80            let w = w' .&. 0xff
81            let w1 = w + 1
82            let g = SM32.mkSMGen seed
83            let (x, _) = SM32.bitmaskWithRejection64 w1 g
84            counterexample ("64-64 " ++ show x ++ " <= " ++ show w) (x < w1)
85        , testMiniProperty "64'" $ \w' seed -> do
86            let w = w' .&. 0xff
87            let g = SM32.mkSMGen seed
88            let (x, _) = SM32.bitmaskWithRejection64' w g
89            counterexample ("64-64 " ++ show x ++ " < " ++ show w) (x <= w)
90        , testMiniProperty "32" $ \w' seed -> do
91            let w = w' .&. 0xff
92            let u1 = w'
93            let g = SM32.mkSMGen seed
94            let (x, _) = SM32.bitmaskWithRejection32 u1 g
95            counterexample ("64-32 " ++ show x ++ " <= " ++ show w) (x < u1)
96        , testMiniProperty "32'" $ \w' seed -> do
97            let w = w' .&. 0xff
98            let u = w
99            let g = SM32.mkSMGen seed
100            let (x, _) = SM32.bitmaskWithRejection32' u g
101            counterexample ("64-32 " ++ show x ++ " < " ++ show w) (x <= u)
102        ]
103    ]
104
105newtype Word64mod7 = W7 Word64 deriving (Eq, Ord, Show)
106instance Arbitrary Word64mod7 where
107    arbitrary = Gen $ \g -> W7 $ fst $ SM.bitmaskWithRejection64' 6 g
108
109newtype Integer1 = I1 Integer deriving (Eq, Ord, Show)
110instance Arbitrary Integer1 where
111    arbitrary = Gen $ \g -> I1 $ fst $ SM.nextInteger i1min i1max g
112
113i1min :: Integer
114i1min = -7
115
116i1max :: Integer
117i1max = 7
118
119i1valid :: Integer1 -> Bool
120i1valid (I1 i) = i1min <= i && i <= i1max
121
122newtype Integer7 = I7 Integer deriving (Eq, Ord, Show)
123instance Arbitrary Integer7 where
124    arbitrary = Gen $ \g -> I7 $ fst $ SM.nextInteger i7min i7max g
125
126i7min :: Integer
127i7min = negate two64
128
129i7max :: Integer
130i7max = two64 * 6 + 7 * 1234567
131
132i7valid :: Integer7 -> Bool
133i7valid (I7 i) = i7min <= i && i <= i7max
134
135two64 :: Integer
136two64 = 2 ^ (64 :: Int)
137