1{-# LANGUAGE ScopedTypeVariables, TemplateHaskell #-} 2module Main where 3 4-------------------------------------------------------------------------- 5-- imports 6 7import Test.QuickCheck 8 9import Text.Show.Functions 10import Data.List 11 ( sort 12 , group 13 , nub 14 , (\\) 15 ) 16 17import Control.Monad 18 ( liftM 19 , liftM2 20 ) 21 22import Data.Maybe 23 24--import Text.Show.Functions 25 26-------------------------------------------------------------------------- 27-- binary search trees 28 29data Set a 30 = Node a (Set a) (Set a) 31 | Empty 32 deriving ( Eq, Ord, Show ) 33 34empty :: Set a 35empty = Empty 36 37isEmpty :: Set a -> Bool 38isEmpty Empty = True 39isEmpty _ = False 40 41unit :: a -> Set a 42unit x = Node x empty empty 43 44size :: Set a -> Int 45size Empty = 0 46size (Node _ s1 s2) = 1 + size s1 + size s2 47 48insert :: Ord a => a -> Set a -> Set a 49insert x s = s `union` unit x 50 51merge :: Set a -> Set a -> Set a 52s `merge` Empty = s 53s `merge` Node x Empty s2 = Node x s s2 54s `merge` Node x (Node y s11 s12) s2 = Node y s (Node x (s11 `merge` s12) s2) 55 56delete :: Ord a => a -> Set a -> Set a 57delete x Empty = Empty 58delete x (Node x' s1 s2) = 59 case x `compare` x' of 60 LT -> Node x' (delete x s1) s2 61 EQ -> s1 `merge` s2 62 GT -> Node x' s1 (delete x s2) 63 64union :: Ord a => Set a -> Set a -> Set a 65{- 66s1 `union` Empty = s1 67Empty `union` s2 = s2 68s1@(Node x s11 s12) `union` s2@(Node y s21 s22) = 69 case x `compare` y of 70 LT -> Node x s11 (s12 `union` Node y Empty s22) `union` s21 71 EQ -> Node x (s11 `union` s21) (s12 `union` s22) 72 --GT -> s11 `union` Node y s21 (Node x Empty s12 `union` s22) 73 GT -> Node x (s11 `union` Node y s21 Empty) s12 `union` s22 74-} 75s1 `union` Empty = s1 76Empty `union` s2 = s2 77Node x s11 s12 `union` s2 = Node x (s11 `union` s21) (s12 `union` s22) 78 where 79 (s21,s22) = split x s2 80 81split :: Ord a => a -> Set a -> (Set a, Set a) 82split x Empty = (Empty, Empty) 83split x (Node y s1 s2) = 84 case x `compare` y of 85 LT -> (s11, Node y s12 s2) 86 EQ -> (s1, s2) 87 GT -> (Node y s1 s21, s22) 88 where 89 (s11,s12) = split x s1 90 (s21,s22) = split x s2 91 92mapp :: (a -> b) -> Set a -> Set b 93mapp f Empty = Empty 94mapp f (Node x s1 s2) = Node (f x) (mapp f s1) (mapp f s2) 95 96fromList :: Ord a => [a] -> Set a 97--fromList xs = build [ (empty,x) | x <- sort xs ] 98fromList xs = build [ (empty,head x) | x <- group (sort xs) ] 99 where 100 build [] = empty 101 build [(s,x)] = attach x s 102 build sxs = build (sweep sxs) 103 104 sweep [] = [] 105 sweep [sx] = [sx] 106 sweep ((s1,x1):(s2,x2):sxs) = (Node x1 s1 s2,x2) : sweep sxs 107 108 attach x Empty = unit x 109 attach x (Node y s1 s2) = Node y s1 (attach x s2) 110 111toList :: Set a -> [a] 112toList s = toSortedList s 113 114toSortedList :: Set a -> [a] 115toSortedList s = toList' s [] 116 where 117 toList' Empty xs = xs 118 toList' (Node x s1 s2) xs = toList' s1 (x : toList' s2 xs) 119 120-------------------------------------------------------------------------- 121-- generators 122 123instance (Ord a, Arbitrary a) => Arbitrary (Set a) where 124 arbitrary = sized (arbSet Nothing Nothing) 125 where 126 arbSet mx my n = 127 frequency $ 128 [ (1, return Empty) ] ++ 129 [ (7, do mz <- arbitrary `suchThatMaybe` (isOK mx my) 130 case mz of 131 Nothing -> return Empty 132 Just z -> liftM2 (Node z) (arbSet mx mz n2) 133 (arbSet mz my n2) 134 where n2 = n `div` 2) 135 | n > 0 136 ] 137 138 isOK mx my z = 139 maybe True (<z) mx && maybe True (z<) my 140 141 shrink Empty = [] 142 shrink t@(Node x s1 s2) = [ s1, s2 ] 143 ++ [ t' | x' <- shrink x, let t' = Node x' s1 s2, invariant t' ] 144 145-- instance (Ord a, ShrinkSub a) => ShrinkSub (Set a) 146 147-------------------------------------------------------------------------- 148-- properties 149 150(.<) :: Ord a => Set a -> a -> Bool 151Empty .< x = True 152Node y _ s .< x = y < x && s .< x 153 154(<.) :: Ord a => a -> Set a -> Bool 155x <. Empty = True 156x <. Node y _ s = x < y && x <. s 157 158(==?) :: Ord a => Set a -> [a] -> Bool 159s ==? xs = invariant s && sort (toList s) == nub (sort xs) 160 161invariant :: Ord a => Set a -> Bool 162invariant Empty = True 163invariant (Node x s1 s2) = s1 .< x && x <. s2 && invariant s1 && invariant s2 164 165prop_Invariant (s :: Set Int) = 166 invariant s 167 168prop_Empty = 169 empty ==? ([] :: [Int]) 170 171prop_Unit (x :: Int) = 172 unit x ==? [x] 173 174prop_Size (s :: Set Int) = 175 cover 60 (size s >= 15) "large" $ 176 size s == length (toList s) 177 178prop_Insert x (s :: Set Int) = 179 insert x s ==? (x : toList s) 180 181prop_Delete x (s :: Set Int) = 182 delete x s ==? (toList s \\ [x]) 183 184prop_Union s1 (s2 :: Set Int) = 185 (s1 `union` s2) ==? (toList s1 ++ toList s2) 186 187prop_Mapp (f :: Int -> Int) (s :: Set Int) = 188 expectFailure $ 189 whenFail (putStrLn ("Fun: " ++ show [ (x,f x) | x <- toList s])) $ 190 mapp f s ==? map f (toList s) 191 192prop_FromList (xs :: [Int]) = 193 fromList xs ==? xs 194 195prop_ToSortedList (s :: Set Int) = 196 s ==? xs && xs == sort xs 197 where 198 xs = toSortedList s 199 200-- whenFail (putStrLn ("Result: " ++ show (fromList xs))) $ 201 202prop_FromList' (xs :: [Int]) = 203 shrinking shrink xs $ \xs' -> 204 fromList xs ==? xs 205 206-------------------------------------------------------------------------- 207-- main 208 209return [] 210main = $quickCheckAll 211 212-------------------------------------------------------------------------- 213-- the end. 214