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