1{-# LANGUAGE ScopedTypeVariables, TemplateHaskell #-}
2module Main where
3
4--------------------------------------------------------------------------
5-- imports
6
7import Test.QuickCheck
8import Test.QuickCheck.Poly
9
10import Data.List
11  ( sort
12  , (\\)
13  )
14
15import Control.Monad
16  ( liftM
17  , liftM2
18  )
19
20--------------------------------------------------------------------------
21-- skew heaps
22
23data Heap a
24  = Node a (Heap a) (Heap a)
25  | Nil
26 deriving ( Eq, Ord, Show )
27
28empty :: Heap a
29empty = Nil
30
31isEmpty :: Heap a -> Bool
32isEmpty Nil = True
33isEmpty _   = False
34
35unit :: a -> Heap a
36unit x = Node x empty empty
37
38size :: Heap a -> Int
39size Nil            = 0
40size (Node _ h1 h2) = 1 + size h1 + size h2
41
42insert :: Ord a => a -> Heap a -> Heap a
43insert x h = unit x `merge` h
44
45removeMin :: Ord a => Heap a -> Maybe (a, Heap a)
46removeMin Nil            = Nothing
47removeMin (Node x h1 h2) = Just (x, h1 `merge` h2)
48
49merge :: Ord a => Heap a -> Heap a -> Heap a
50h1  `merge` Nil = h1
51Nil `merge` h2  = h2
52h1@(Node x h11 h12) `merge` h2@(Node y h21 h22)
53  | x <= y    = Node x (h12 `merge` h2) h11
54  | otherwise = Node y (h22 `merge` h1) h21
55
56fromList :: Ord a => [a] -> Heap a
57fromList xs = merging [ unit x | x <- xs ]
58 where
59  merging []  = empty
60  merging [h] = h
61  merging hs  = merging (sweep hs)
62
63  sweep []         = []
64  sweep [h]        = [h]
65  sweep (h1:h2:hs) = (h1 `merge` h2) : sweep hs
66
67toList :: Heap a -> [a]
68toList h = toList' [h]
69 where
70  toList' []                  = []
71  toList' (Nil          : hs) = toList' hs
72  toList' (Node x h1 h2 : hs) = x : toList' (h1:h2:hs)
73
74toSortedList :: Ord a => Heap a -> [a]
75toSortedList Nil            = []
76toSortedList (Node x h1 h2) = x : toList (h1 `merge` h2)
77
78--------------------------------------------------------------------------
79-- heap programs
80
81data HeapP a
82  = Empty
83  | Unit a
84  | Insert a (HeapP a)
85  | SafeRemoveMin (HeapP a)
86  | Merge (HeapP a) (HeapP a)
87  | FromList [a]
88 deriving (Show)
89
90heap :: Ord a => HeapP a -> Heap a
91heap Empty             = empty
92heap (Unit x)          = unit x
93heap (Insert x p)      = insert x (heap p)
94heap (SafeRemoveMin p) = case removeMin (heap p) of
95                           Nothing    -> empty -- arbitrary choice
96                           Just (_,h) -> h
97heap (Merge p q)       = heap p `merge` heap q
98heap (FromList xs)     = fromList xs
99
100instance Arbitrary a => Arbitrary (HeapP a) where
101  arbitrary = sized arbHeapP
102   where
103    arbHeapP s =
104      frequency
105      [ (1, do return Empty)
106      , (1, do x <- arbitrary
107               return (Unit x))
108      , (s, do x <- arbitrary
109               p <- arbHeapP s1
110               return (Insert x p))
111      , (s, do p <- arbHeapP s1
112               return (SafeRemoveMin p))
113      , (s, do p <- arbHeapP s2
114               q <- arbHeapP s2
115               return (Merge p q))
116      , (1, do xs <- arbitrary
117               return (FromList xs))
118      ]
119     where
120      s1 = s-1
121      s2 = s`div`2
122
123
124  shrink (Unit x)          = [ Unit x' | x' <- shrink x ]
125  shrink (FromList xs)     = [ Unit x | x <- xs ]
126                          ++ [ FromList xs' | xs' <- shrink xs ]
127  shrink (Insert x p)      = [ p ]
128                          ++ [ Insert x p' | p' <- shrink p ]
129                          ++ [ Insert x' p | x' <- shrink x ]
130  shrink (SafeRemoveMin p) = [ p ]
131                          ++ [ SafeRemoveMin p' | p' <- shrink p ]
132  shrink (Merge p q)       = [ p, q ]
133                          ++ [ Merge p' q | p' <- shrink p ]
134                          ++ [ Merge p q' | q' <- shrink q ]
135  shrink _                 = []
136
137data HeapPP a = HeapPP (HeapP a) (Heap a)
138 deriving (Show)
139
140instance (Ord a, Arbitrary a) => Arbitrary (HeapPP a) where
141  arbitrary =
142    do p <- arbitrary
143       return (HeapPP p (heap p))
144
145  shrink (HeapPP p _) =
146    [ HeapPP p' (heap p') | p' <- shrink p ]
147
148--------------------------------------------------------------------------
149-- properties
150
151(==?) :: Heap OrdA -> [OrdA] -> Bool
152h ==? xs = sort (toList h) == sort xs
153
154prop_Empty =
155  empty ==? []
156
157prop_IsEmpty (HeapPP _ h) =
158  isEmpty h == null (toList h)
159
160prop_Unit x =
161  unit x ==? [x]
162
163prop_Size (HeapPP _ h) =
164  size h == length (toList h)
165
166prop_Insert x (HeapPP _ h) =
167  insert x h ==? (x : toList h)
168
169prop_RemoveMin (HeapPP _ h) =
170  cover 80 (size h > 1) "non-trivial" $
171  case removeMin h of
172    Nothing     -> h ==? []
173    Just (x,h') -> x == minimum (toList h) && h' ==? (toList h \\ [x])
174
175prop_Merge (HeapPP _ h1) (HeapPP _ h2) =
176  (h1 `merge` h2) ==? (toList h1 ++ toList h2)
177
178prop_FromList xs =
179  fromList xs ==? xs
180
181prop_ToSortedList (HeapPP _ h) =
182  h ==? xs && xs == sort xs
183 where
184  xs = toSortedList h
185
186--------------------------------------------------------------------------
187-- main
188
189return []
190main = $(quickCheckAll)
191
192--------------------------------------------------------------------------
193-- the end.
194
195-- toSortedList (Node x h1 h2) = x : toSortedList (h1 `merge` h2)
196
197
198