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