]> Git — Sourcephile - reloto.git/blob - test/QuickCheck.hs
509bfe5becff695f7469261c9fcd95530a4f57c8
[reloto.git] / test / QuickCheck.hs
1 {-# LANGUAGE FlexibleInstances #-}
2 {-# LANGUAGE ScopedTypeVariables #-}
3 {-# OPTIONS_GHC -fno-warn-orphans #-}
4 module QuickCheck where
5
6 import Test.QuickCheck
7 import Test.Tasty
8 import Test.Tasty.QuickCheck
9
10 import qualified Data.List as List
11 import qualified Data.Set as Set
12
13 import Htirage
14
15 quickchecks :: TestTree
16 quickchecks =
17 testGroup "QuickCheck"
18 [ testProperty "rankOfCombin n (combinOfRank n k r) == r" $ \(NKR (n,k,r)) ->
19 rankOfCombin n (combinOfRank n k r) == r
20 , testProperty "combinOfRank n (length ns) (rankOfCombin n ns) == ns" $ \(SortedNNS (n,ns)) ->
21 combinOfRank n (toInteger $ length ns) (rankOfCombin n ns) == ns
22 , testProperty "rankOfSequence n (sequenceOfRank n k r) == r" $ \(NKR (n,k,r)) ->
23 rankOfSequence n (sequenceOfRank n k r) == r
24 , testProperty "sequenceOfRank n (length ns) (rankOfSequence n ns) == ns" $ \(NNS (n,ns)) ->
25 sequenceOfRank n (toInteger $ length ns) (rankOfSequence n ns) == ns
26 ]
27
28 -- * Type 'NNS'
29 newtype NNS = NNS (Integer, [Integer])
30 deriving (Eq, Show)
31 instance Arbitrary NNS where
32 arbitrary = do
33 n <- arbitrarySizedNatural
34 k <- choose (0,n)
35 ns <- List.take (fromInteger k) . nubList <$> infiniteListOf (choose (1,n))
36 return $ NNS (n,ns)
37
38 -- * Type 'SortedNNS'
39 newtype SortedNNS = SortedNNS (Integer, [Integer])
40 deriving (Eq, Show)
41 instance Arbitrary SortedNNS where
42 arbitrary = do
43 n <- arbitrarySizedNatural
44 k <- choose (0,n)
45 ns <- List.sort . List.take (fromInteger k) . nubList <$> infiniteListOf (choose (1,n))
46 return $ SortedNNS (n,ns)
47
48 -- * Type 'NKR'
49 newtype NKR = NKR (Integer, Integer, Integer)
50 deriving (Eq, Show)
51 instance Arbitrary NKR where
52 arbitrary = do
53 n <- arbitrarySizedNatural
54 k <- choose (0, n)
55 r <- choose (0, (n`nCk`k) - 1)
56 return $ NKR (n,k,r)
57
58 -- | Like 'nub', but O(n * log n).
59 nubList :: Ord a => [a] -> [a]
60 nubList = go Set.empty where
61 go _ [] = []
62 go s (x:xs) | x`Set.member`s = go s xs
63 | otherwise = x:go (Set.insert x s) xs