46ae416cc0ed4866b5ac0c78a699557cba080de5
[packages/containers.git] / tests / set-properties.hs
1 {-# LANGUAGE CPP #-}
2 import qualified Data.IntSet as IntSet
3 import Data.List (nub,sort)
4 import qualified Data.List as List
5 import Data.Monoid (mempty)
6 import Data.Maybe
7 import Data.Set
8 import Prelude hiding (lookup, null, map, filter, foldr, foldl, all, take, drop, splitAt)
9 import Test.Framework
10 import Test.Framework.Providers.HUnit
11 import Test.Framework.Providers.QuickCheck2
12 import Test.HUnit hiding (Test, Testable)
13 import Test.QuickCheck
14 import Test.QuickCheck.Function
15 import Test.QuickCheck.Poly
16 import Control.Monad.Trans.State.Strict
17 import Control.Monad.Trans.Class
18 import Control.Monad (liftM, liftM3)
19 import Data.Functor.Identity
20 import Data.Foldable (all)
21 #if !MIN_VERSION_base(4,8,0)
22 import Control.Applicative (Applicative (..), (<$>))
23 #endif
24 import Control.Applicative (liftA2)
25
26 main :: IO ()
27 main = defaultMain [ testCase "lookupLT" test_lookupLT
28 , testCase "lookupGT" test_lookupGT
29 , testCase "lookupLE" test_lookupLE
30 , testCase "lookupGE" test_lookupGE
31 , testCase "lookupIndex" test_lookupIndex
32 , testCase "findIndex" test_findIndex
33 , testCase "elemAt" test_elemAt
34 , testCase "deleteAt" test_deleteAt
35 , testProperty "prop_Valid" prop_Valid
36 , testProperty "prop_Single" prop_Single
37 , testProperty "prop_Member" prop_Member
38 , testProperty "prop_NotMember" prop_NotMember
39 , testProperty "prop_LookupLT" prop_LookupLT
40 , testProperty "prop_LookupGT" prop_LookupGT
41 , testProperty "prop_LookupLE" prop_LookupLE
42 , testProperty "prop_LookupGE" prop_LookupGE
43 , testProperty "prop_InsertValid" prop_InsertValid
44 , testProperty "prop_InsertDelete" prop_InsertDelete
45 , testProperty "prop_InsertBiased" prop_InsertBiased
46 , testProperty "prop_DeleteValid" prop_DeleteValid
47 , testProperty "prop_Link" prop_Link
48 , testProperty "prop_Merge" prop_Merge
49 , testProperty "prop_UnionValid" prop_UnionValid
50 , testProperty "prop_UnionInsert" prop_UnionInsert
51 , testProperty "prop_UnionAssoc" prop_UnionAssoc
52 , testProperty "prop_UnionComm" prop_UnionComm
53 , testProperty "prop_UnionBiased" prop_UnionBiased
54 , testProperty "prop_DiffValid" prop_DiffValid
55 , testProperty "prop_Diff" prop_Diff
56 , testProperty "prop_IntValid" prop_IntValid
57 , testProperty "prop_Int" prop_Int
58 , testProperty "prop_IntBiased" prop_IntBiased
59 , testProperty "prop_Ordered" prop_Ordered
60 , testProperty "prop_DescendingOrdered" prop_DescendingOrdered
61 , testProperty "prop_List" prop_List
62 , testProperty "prop_DescList" prop_DescList
63 , testProperty "prop_AscDescList" prop_AscDescList
64 , testProperty "prop_fromList" prop_fromList
65 , testProperty "prop_fromListDesc" prop_fromListDesc
66 , testProperty "prop_isProperSubsetOf" prop_isProperSubsetOf
67 , testProperty "prop_isProperSubsetOf2" prop_isProperSubsetOf2
68 , testProperty "prop_isSubsetOf" prop_isSubsetOf
69 , testProperty "prop_isSubsetOf2" prop_isSubsetOf2
70 , testProperty "prop_size" prop_size
71 , testProperty "prop_lookupMax" prop_lookupMax
72 , testProperty "prop_lookupMin" prop_lookupMin
73 , testProperty "prop_findMax" prop_findMax
74 , testProperty "prop_findMin" prop_findMin
75 , testProperty "prop_ord" prop_ord
76 , testProperty "prop_readShow" prop_readShow
77 , testProperty "prop_foldR" prop_foldR
78 , testProperty "prop_foldR'" prop_foldR'
79 , testProperty "prop_foldL" prop_foldL
80 , testProperty "prop_foldL'" prop_foldL'
81 , testProperty "prop_map" prop_map
82 , testProperty "prop_map2" prop_map2
83 , testProperty "prop_mapMonotonic" prop_mapMonotonic
84 , testProperty "prop_maxView" prop_maxView
85 , testProperty "prop_minView" prop_minView
86 , testProperty "prop_split" prop_split
87 , testProperty "prop_splitMember" prop_splitMember
88 , testProperty "prop_splitRoot" prop_splitRoot
89 , testProperty "prop_partition" prop_partition
90 , testProperty "prop_filter" prop_filter
91 , testProperty "takeWhileAntitone" prop_takeWhileAntitone
92 , testProperty "dropWhileAntitone" prop_dropWhileAntitone
93 , testProperty "spanAntitone" prop_spanAntitone
94 , testProperty "take" prop_take
95 , testProperty "drop" prop_drop
96 , testProperty "splitAt" prop_splitAt
97 , testProperty "powerSet" prop_powerSet
98 , testProperty "cartesianProduct" prop_cartesianProduct
99 , testProperty "disjointUnion" prop_disjointUnion
100 ]
101
102 -- A type with a peculiar Eq instance designed to make sure keys
103 -- come from where they're supposed to.
104 data OddEq a = OddEq a Bool deriving (Show)
105
106 getOddEq :: OddEq a -> (a, Bool)
107 getOddEq (OddEq b a) = (b, a)
108 instance Arbitrary a => Arbitrary (OddEq a) where
109 arbitrary = OddEq <$> arbitrary <*> arbitrary
110 instance Eq a => Eq (OddEq a) where
111 OddEq x _ == OddEq y _ = x == y
112 instance Ord a => Ord (OddEq a) where
113 OddEq x _ `compare` OddEq y _ = x `compare` y
114
115 ----------------------------------------------------------------
116 -- Unit tests
117 ----------------------------------------------------------------
118
119 test_lookupLT :: Assertion
120 test_lookupLT = do
121 lookupLT 3 (fromList [3, 5]) @?= Nothing
122 lookupLT 5 (fromList [3, 5]) @?= Just 3
123
124 test_lookupGT :: Assertion
125 test_lookupGT = do
126 lookupGT 4 (fromList [3, 5]) @?= Just 5
127 lookupGT 5 (fromList [3, 5]) @?= Nothing
128
129 test_lookupLE :: Assertion
130 test_lookupLE = do
131 lookupLE 2 (fromList [3, 5]) @?= Nothing
132 lookupLE 4 (fromList [3, 5]) @?= Just 3
133 lookupLE 5 (fromList [3, 5]) @?= Just 5
134
135 test_lookupGE :: Assertion
136 test_lookupGE = do
137 lookupGE 3 (fromList [3, 5]) @?= Just 3
138 lookupGE 4 (fromList [3, 5]) @?= Just 5
139 lookupGE 6 (fromList [3, 5]) @?= Nothing
140
141 {--------------------------------------------------------------------
142 Indexed
143 --------------------------------------------------------------------}
144
145 test_lookupIndex :: Assertion
146 test_lookupIndex = do
147 isJust (lookupIndex 2 (fromList [5,3])) @?= False
148 fromJust (lookupIndex 3 (fromList [5,3])) @?= 0
149 fromJust (lookupIndex 5 (fromList [5,3])) @?= 1
150 isJust (lookupIndex 6 (fromList [5,3])) @?= False
151
152 test_findIndex :: Assertion
153 test_findIndex = do
154 findIndex 3 (fromList [5,3]) @?= 0
155 findIndex 5 (fromList [5,3]) @?= 1
156
157 test_elemAt :: Assertion
158 test_elemAt = do
159 elemAt 0 (fromList [5,3]) @?= 3
160 elemAt 1 (fromList [5,3]) @?= 5
161
162 test_deleteAt :: Assertion
163 test_deleteAt = do
164 deleteAt 0 (fromList [5,3]) @?= singleton 5
165 deleteAt 1 (fromList [5,3]) @?= singleton 3
166
167 {--------------------------------------------------------------------
168 Arbitrary, reasonably balanced trees
169 --------------------------------------------------------------------}
170
171 -- | The IsInt class lets us constrain a type variable to be Int in an entirely
172 -- standard way. The constraint @ IsInt a @ is essentially equivalent to the
173 -- GHC-only constraint @ a ~ Int @, but @ IsInt @ requires manual intervention
174 -- to use. If ~ is ever standardized, we should certainly use it instead.
175 -- Earlier versions used an Enum constraint, but this is confusing because
176 -- not all Enum instances will work properly for the Arbitrary instance here.
177 class (Show a, Read a, Integral a, Arbitrary a) => IsInt a where
178 fromIntF :: f Int -> f a
179
180 instance IsInt Int where
181 fromIntF = id
182
183 -- | Convert an Int to any instance of IsInt
184 fromInt :: IsInt a => Int -> a
185 fromInt = runIdentity . fromIntF . Identity
186
187 {- We don't actually need this, but we can add it if we ever do
188 toIntF :: IsInt a => g a -> g Int
189 toIntF = unf . fromIntF . F $ id
190
191 newtype F g a b = F {unf :: g b -> a}
192
193 toInt :: IsInt a => a -> Int
194 toInt = runIdentity . toIntF . Identity -}
195
196
197 -- How much the minimum value of an arbitrary set should vary
198 positionFactor :: Int
199 positionFactor = 1
200
201 -- How much the gap between consecutive elements in an arbitrary
202 -- set should vary
203 gapRange :: Int
204 gapRange = 5
205
206 instance IsInt a => Arbitrary (Set a) where
207 arbitrary = sized (\sz0 -> do
208 sz <- choose (0, sz0)
209 middle <- choose (-positionFactor * (sz + 1), positionFactor * (sz + 1))
210 let shift = (sz * (gapRange) + 1) `quot` 2
211 start = middle - shift
212 t <- evalStateT (mkArb step sz) start
213 if valid t then pure t else error "Test generated invalid tree!")
214 where
215 step = do
216 i <- get
217 diff <- lift $ choose (1, gapRange)
218 let i' = i + diff
219 put i'
220 pure (fromInt i')
221
222 class Monad m => MonadGen m where
223 liftGen :: Gen a -> m a
224 instance MonadGen Gen where
225 liftGen = id
226 instance MonadGen m => MonadGen (StateT s m) where
227 liftGen = lift . liftGen
228
229 -- | Given an action that produces successively larger elements and
230 -- a size, produce a set of arbitrary shape with exactly that size.
231 mkArb :: MonadGen m => m a -> Int -> m (Set a)
232 mkArb step n
233 | n <= 0 = return Tip
234 | n == 1 = singleton `liftM` step
235 | n == 2 = do
236 dir <- liftGen arbitrary
237 p <- step
238 q <- step
239 if dir
240 then return (Bin 2 q (singleton p) Tip)
241 else return (Bin 2 p Tip (singleton q))
242 | otherwise = do
243 -- This assumes a balance factor of delta = 3
244 let upper = (3*(n - 1)) `quot` 4
245 let lower = (n + 2) `quot` 4
246 ln <- liftGen $ choose (lower, upper)
247 let rn = n - ln - 1
248 liftM3 (\lt x rt -> Bin n x lt rt) (mkArb step ln) step (mkArb step rn)
249
250 -- | Given a strictly increasing list of elements, produce an arbitrarily
251 -- shaped set with exactly those elements.
252 setFromList :: [a] -> Gen (Set a)
253 setFromList xs = flip evalStateT xs $ mkArb step (length xs)
254 where
255 step = do
256 x : xs <- get
257 put xs
258 pure x
259
260 data TwoSets = TwoSets (Set Int) (Set Int) deriving (Show)
261
262 data TwoLists a = TwoLists [a] [a]
263
264 data Options2 = One2 | Two2 | Both2 deriving (Bounded, Enum)
265 instance Arbitrary Options2 where
266 arbitrary = arbitraryBoundedEnum
267
268 -- We produce two lists from a simple "universe". This instance
269 -- is intended to give good results when the two lists are then
270 -- combined with each other; if other elements are used with them,
271 -- they may or may not behave particularly well.
272 instance IsInt a => Arbitrary (TwoLists a) where
273 arbitrary = sized $ \sz0 -> do
274 sz <- choose (0, sz0)
275 let universe = [0,3..3*(fromInt sz - 1)]
276 divide2Gen universe
277
278 instance Arbitrary TwoSets where
279 arbitrary = do
280 TwoLists l r <- arbitrary
281 TwoSets <$> setFromList l <*> setFromList r
282
283 divide2Gen :: [a] -> Gen (TwoLists a)
284 divide2Gen [] = pure (TwoLists [] [])
285 divide2Gen (x : xs) = do
286 way <- arbitrary
287 TwoLists ls rs <- divide2Gen xs
288 case way of
289 One2 -> pure (TwoLists (x : ls) rs)
290 Two2 -> pure (TwoLists ls (x : rs))
291 Both2 -> pure (TwoLists (x : ls) (x : rs))
292
293 {--------------------------------------------------------------------
294 Valid trees
295 --------------------------------------------------------------------}
296 forValid :: (IsInt a,Testable b) => (Set a -> b) -> Property
297 forValid f = forAll arbitrary $ \t ->
298 classify (size t == 0) "empty" $
299 classify (size t > 0 && size t <= 10) "small" $
300 classify (size t > 10 && size t <= 64) "medium" $
301 classify (size t > 64) "large" $ f t
302
303 forValidUnitTree :: Testable a => (Set Int -> a) -> Property
304 forValidUnitTree f = forValid f
305
306 prop_Valid :: Property
307 prop_Valid = forValidUnitTree $ \t -> valid t
308
309 {--------------------------------------------------------------------
310 Single, Member, Insert, Delete
311 --------------------------------------------------------------------}
312 prop_Single :: Int -> Bool
313 prop_Single x = (insert x empty == singleton x)
314
315 prop_Member :: [Int] -> Int -> Bool
316 prop_Member xs n =
317 let m = fromList xs
318 in all (\k -> k `member` m == (k `elem` xs)) (n : xs)
319
320 prop_NotMember :: [Int] -> Int -> Bool
321 prop_NotMember xs n =
322 let m = fromList xs
323 in all (\k -> k `notMember` m == (k `notElem` xs)) (n : xs)
324
325 test_LookupSomething :: (Int -> Set Int -> Maybe Int) -> (Int -> Int -> Bool) -> [Int] -> Bool
326 test_LookupSomething lookup' cmp xs =
327 let odd_sorted_xs = filter_odd $ nub $ sort xs
328 t = fromList odd_sorted_xs
329 test x = case List.filter (`cmp` x) odd_sorted_xs of
330 [] -> lookup' x t == Nothing
331 cs | 0 `cmp` 1 -> lookup' x t == Just (last cs) -- we want largest such element
332 | otherwise -> lookup' x t == Just (head cs) -- we want smallest such element
333 in all test xs
334
335 where filter_odd [] = []
336 filter_odd [_] = []
337 filter_odd (_ : o : xs) = o : filter_odd xs
338
339 prop_LookupLT :: [Int] -> Bool
340 prop_LookupLT = test_LookupSomething lookupLT (<)
341
342 prop_LookupGT :: [Int] -> Bool
343 prop_LookupGT = test_LookupSomething lookupGT (>)
344
345 prop_LookupLE :: [Int] -> Bool
346 prop_LookupLE = test_LookupSomething lookupLE (<=)
347
348 prop_LookupGE :: [Int] -> Bool
349 prop_LookupGE = test_LookupSomething lookupGE (>=)
350
351 prop_InsertValid :: Int -> Property
352 prop_InsertValid k = forValidUnitTree $ \t -> valid (insert k t)
353
354 prop_InsertDelete :: Int -> Set Int -> Property
355 prop_InsertDelete k t = not (member k t) ==> delete k (insert k t) == t
356
357 prop_InsertBiased :: Int -> Set Int -> Bool
358 prop_InsertBiased k t = (k, True) `member` kt
359 where
360 t' = mapMonotonic (`OddEq` False) t
361 kt' = insert (OddEq k True) t'
362 kt = mapMonotonic getOddEq kt'
363
364 prop_DeleteValid :: Int -> Property
365 prop_DeleteValid k = forValidUnitTree $ \t -> valid (delete k (insert k t))
366
367 {--------------------------------------------------------------------
368 Balance
369 --------------------------------------------------------------------}
370 prop_Link :: Int -> Property
371 prop_Link x = forValidUnitTree $ \t ->
372 let (l,r) = split x t
373 in valid (link x l r)
374
375 prop_Merge :: Int -> Property
376 prop_Merge x = forValidUnitTree $ \t ->
377 let (l,r) = split x t
378 in valid (merge l r)
379
380 {--------------------------------------------------------------------
381 Union
382 --------------------------------------------------------------------}
383 prop_UnionValid :: Property
384 prop_UnionValid
385 = forValidUnitTree $ \t1 ->
386 forValidUnitTree $ \t2 ->
387 valid (union t1 t2)
388
389 prop_UnionInsert :: Int -> Set Int -> Bool
390 prop_UnionInsert x t = union t (singleton x) == insert x t
391
392 prop_UnionAssoc :: Set Int -> Set Int -> Set Int -> Bool
393 prop_UnionAssoc t1 t2 t3 = union t1 (union t2 t3) == union (union t1 t2) t3
394
395 prop_UnionComm :: TwoSets -> Bool
396 prop_UnionComm (TwoSets t1 t2) = (union t1 t2 == union t2 t1)
397
398 prop_UnionBiased :: TwoSets -> Property
399 prop_UnionBiased (TwoSets l r) = union l' r' === union l' (difference r' l')
400 where
401 l' = mapMonotonic (`OddEq` False) l
402 r' = mapMonotonic (`OddEq` True) r
403
404 prop_IntBiased :: TwoSets -> Bool
405 prop_IntBiased (TwoSets l r) = all (\(OddEq _ b) -> not b) l'r'
406 where
407 l' = mapMonotonic (`OddEq` False) l
408 r' = mapMonotonic (`OddEq` True) r
409 l'r' = intersection l' r'
410
411 prop_DiffValid :: Property
412 prop_DiffValid = forValidUnitTree $ \t1 ->
413 forValidUnitTree $ \t2 ->
414 valid (difference t1 t2)
415
416 prop_Diff :: [Int] -> [Int] -> Bool
417 prop_Diff xs ys = toAscList (difference (fromList xs) (fromList ys))
418 == List.sort ((List.\\) (nub xs) (nub ys))
419
420 prop_IntValid :: Property
421 prop_IntValid = forValidUnitTree $ \t1 ->
422 forValidUnitTree $ \t2 ->
423 valid (intersection t1 t2)
424
425 prop_Int :: [Int] -> [Int] -> Bool
426 prop_Int xs ys = toAscList (intersection (fromList xs) (fromList ys))
427 == List.sort (nub ((List.intersect) (xs) (ys)))
428
429 {--------------------------------------------------------------------
430 Lists
431 --------------------------------------------------------------------}
432 prop_Ordered :: Property
433 prop_Ordered = forAll (choose (5,100)) $ \n ->
434 let xs = [0..n::Int]
435 in fromAscList xs === fromList xs
436
437 prop_DescendingOrdered :: Property
438 prop_DescendingOrdered = forAll (choose (5,100)) $ \n ->
439 let xs = [n,n-1..0::Int]
440 in fromDescList xs === fromList xs
441
442 prop_List :: [Int] -> Bool
443 prop_List xs = (sort (nub xs) == toList (fromList xs))
444
445 prop_DescList :: [Int] -> Bool
446 prop_DescList xs = (reverse (sort (nub xs)) == toDescList (fromList xs))
447
448 prop_AscDescList :: [Int] -> Bool
449 prop_AscDescList xs = toAscList s == reverse (toDescList s)
450 where s = fromList xs
451
452 prop_fromList :: [Int] -> Property
453 prop_fromList xs =
454 t === fromAscList sort_xs .&&.
455 t === fromDistinctAscList nub_sort_xs .&&.
456 t === List.foldr insert empty xs
457 where t = fromList xs
458 sort_xs = sort xs
459 nub_sort_xs = List.map List.head $ List.group sort_xs
460
461 prop_fromListDesc :: [Int] -> Property
462 prop_fromListDesc xs =
463 t === fromDescList sort_xs .&&.
464 t === fromDistinctDescList nub_sort_xs .&&.
465 t === List.foldr insert empty xs
466 where t = fromList xs
467 sort_xs = reverse (sort xs)
468 nub_sort_xs = List.map List.head $ List.group sort_xs
469
470 {--------------------------------------------------------------------
471 Set operations are like IntSet operations
472 --------------------------------------------------------------------}
473 toIntSet :: Set Int -> IntSet.IntSet
474 toIntSet = IntSet.fromList . toList
475
476 -- Check that Set Int.isProperSubsetOf is the same as Set.isProperSubsetOf.
477 prop_isProperSubsetOf :: TwoSets -> Bool
478 prop_isProperSubsetOf (TwoSets a b) = isProperSubsetOf a b == IntSet.isProperSubsetOf (toIntSet a) (toIntSet b)
479
480 -- In the above test, isProperSubsetOf almost always returns False (since a
481 -- random set is almost never a subset of another random set). So this second
482 -- test checks the True case.
483 prop_isProperSubsetOf2 :: TwoSets -> Bool
484 prop_isProperSubsetOf2 (TwoSets a b) = isProperSubsetOf a c == (a /= c) where
485 c = union a b
486
487 prop_isSubsetOf :: TwoSets -> Bool
488 prop_isSubsetOf (TwoSets a b) = isSubsetOf a b == IntSet.isSubsetOf (toIntSet a) (toIntSet b)
489
490 prop_isSubsetOf2 :: TwoSets -> Bool
491 prop_isSubsetOf2 (TwoSets a b) = isSubsetOf a (union a b)
492
493 prop_size :: Set Int -> Bool
494 prop_size s = size s == List.length (toList s)
495
496 prop_findMax :: Set Int -> Property
497 prop_findMax s = not (null s) ==> findMax s == maximum (toList s)
498
499 prop_findMin :: Set Int -> Property
500 prop_findMin s = not (null s) ==> findMin s == minimum (toList s)
501
502 prop_lookupMin :: Set Int -> Property
503 prop_lookupMin m = lookupMin m === (fst <$> minView m)
504
505 prop_lookupMax :: Set Int -> Property
506 prop_lookupMax m = lookupMax m === (fst <$> maxView m)
507
508 prop_ord :: TwoSets -> Bool
509 prop_ord (TwoSets s1 s2) = s1 `compare` s2 == toList s1 `compare` toList s2
510
511 prop_readShow :: Set Int -> Bool
512 prop_readShow s = s == read (show s)
513
514 prop_foldR :: Set Int -> Bool
515 prop_foldR s = foldr (:) [] s == toList s
516
517 prop_foldR' :: Set Int -> Bool
518 prop_foldR' s = foldr' (:) [] s == toList s
519
520 prop_foldL :: Set Int -> Bool
521 prop_foldL s = foldl (flip (:)) [] s == List.foldl (flip (:)) [] (toList s)
522
523 prop_foldL' :: Set Int -> Bool
524 prop_foldL' s = foldl' (flip (:)) [] s == List.foldl' (flip (:)) [] (toList s)
525
526 prop_map :: Set Int -> Bool
527 prop_map s = map id s == s
528
529 prop_map2 :: Fun Int Int -> Fun Int Int -> Set Int -> Property
530 prop_map2 f g s = map (apply f) (map (apply g) s) === map (apply f . apply g) s
531
532 prop_mapMonotonic :: Set Int -> Property
533 prop_mapMonotonic s = mapMonotonic id s === s
534
535 prop_maxView :: Set Int -> Bool
536 prop_maxView s = case maxView s of
537 Nothing -> null s
538 Just (m,s') -> m == maximum (toList s) && s == insert m s' && m `notMember` s'
539
540 prop_minView :: Set Int -> Bool
541 prop_minView s = case minView s of
542 Nothing -> null s
543 Just (m,s') -> m == minimum (toList s) && s == insert m s' && m `notMember` s'
544
545 prop_split :: Set Int -> Int -> Bool
546 prop_split s i = case split i s of
547 (s1,s2) -> all (<i) (toList s1) && all (>i) (toList s2) && i `delete` s == union s1 s2
548
549 prop_splitMember :: Set Int -> Int -> Bool
550 prop_splitMember s i = case splitMember i s of
551 (s1,t,s2) -> all (<i) (toList s1) && all (>i) (toList s2) && t == i `member` s && i `delete` s == union s1 s2
552
553 prop_splitRoot :: Set Int -> Bool
554 prop_splitRoot s = loop ls && (s == unions ls)
555 where
556 ls = splitRoot s
557 loop [] = True
558 loop (s1:rst) = List.null
559 [ (x,y) | x <- toList s1
560 , y <- toList (unions rst)
561 , x > y ]
562
563 prop_partition :: Set Int -> Int -> Bool
564 prop_partition s i = case partition odd s of
565 (s1,s2) -> all odd (toList s1) && all even (toList s2) && s == s1 `union` s2
566
567 prop_filter :: Set Int -> Int -> Bool
568 prop_filter s i = partition odd s == (filter odd s, filter even s)
569
570 prop_take :: Int -> Set Int -> Property
571 prop_take n xs = valid taken .&&.
572 taken === fromDistinctAscList (List.take n (toList xs))
573 where
574 taken = take n xs
575
576 prop_drop :: Int -> Set Int -> Property
577 prop_drop n xs = valid dropped .&&.
578 dropped === fromDistinctAscList (List.drop n (toList xs))
579 where
580 dropped = drop n xs
581
582 prop_splitAt :: Int -> Set Int -> Property
583 prop_splitAt n xs = valid taken .&&.
584 valid dropped .&&.
585 taken === take n xs .&&.
586 dropped === drop n xs
587 where
588 (taken, dropped) = splitAt n xs
589
590 prop_takeWhileAntitone :: [Either Int Int] -> Property
591 prop_takeWhileAntitone xs' = valid tw .&&. tw === filter isLeft xs
592 where
593 xs = fromList xs'
594 tw = takeWhileAntitone isLeft xs
595
596 prop_dropWhileAntitone :: [Either Int Int] -> Property
597 prop_dropWhileAntitone xs' = valid tw .&&. tw === filter (not . isLeft) xs
598 where
599 xs = fromList xs'
600 tw = dropWhileAntitone isLeft xs
601
602 prop_spanAntitone :: [Either Int Int] -> Property
603 prop_spanAntitone xs' = valid tw .&&. valid dw
604 .&&. tw === takeWhileAntitone isLeft xs
605 .&&. dw === dropWhileAntitone isLeft xs
606 where
607 xs = fromList xs'
608 (tw, dw) = spanAntitone isLeft xs
609
610 prop_powerSet :: Set Int -> Property
611 prop_powerSet xs = valid ps .&&. ps === ps'
612 where
613 xs' = take 10 xs
614
615 ps = powerSet xs'
616 ps' = fromList . fmap fromList $ lps (toList xs')
617
618 lps [] = [[]]
619 lps (y : ys) = fmap (y:) (lps ys) ++ lps ys
620
621 prop_cartesianProduct :: Set Int -> Set Int -> Property
622 prop_cartesianProduct xs ys =
623 valid cp .&&. toList cp === liftA2 (,) (toList xs) (toList ys)
624 where cp = cartesianProduct xs ys
625
626 prop_disjointUnion :: Set Int -> Set Int -> Property
627 prop_disjointUnion xs ys =
628 valid du .&&. du === union (mapMonotonic Left xs) (mapMonotonic Right ys)
629 where du = disjointUnion xs ys
630
631 isLeft :: Either a b -> Bool
632 isLeft (Left _) = True
633 isLeft _ = False