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