|
Packit |
1d8052 |
{-# LANGUAGE ScopedTypeVariables, TemplateHaskell, GADTs #-}
|
|
Packit |
1d8052 |
module Main where
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
--------------------------------------------------------------------------
|
|
Packit |
1d8052 |
-- imports
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
import Test.QuickCheck
|
|
Packit |
1d8052 |
import Test.QuickCheck.Poly
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
import Data.List
|
|
Packit |
1d8052 |
( sort
|
|
Packit |
1d8052 |
, nub
|
|
Packit |
1d8052 |
, (\\)
|
|
Packit |
1d8052 |
)
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
import Data.Maybe
|
|
Packit |
1d8052 |
( fromJust
|
|
Packit |
1d8052 |
)
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
import Control.Monad
|
|
Packit |
1d8052 |
( liftM
|
|
Packit |
1d8052 |
, liftM2
|
|
Packit |
1d8052 |
)
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
--------------------------------------------------------------------------
|
|
Packit |
1d8052 |
-- skew heaps
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
data Heap a
|
|
Packit |
1d8052 |
= Node a (Heap a) (Heap a)
|
|
Packit |
1d8052 |
| Nil
|
|
Packit |
1d8052 |
deriving ( Eq, Ord, Show )
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
empty :: Heap a
|
|
Packit |
1d8052 |
empty = Nil
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
isEmpty :: Heap a -> Bool
|
|
Packit |
1d8052 |
isEmpty Nil = True
|
|
Packit |
1d8052 |
isEmpty _ = False
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
unit :: a -> Heap a
|
|
Packit |
1d8052 |
unit x = Node x empty empty
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
size :: Heap a -> Int
|
|
Packit |
1d8052 |
size Nil = 0
|
|
Packit |
1d8052 |
size (Node _ h1 h2) = 1 + size h1 + size h2
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
insert :: Ord a => a -> Heap a -> Heap a
|
|
Packit |
1d8052 |
insert x h = unit x `merge` h
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
removeMin :: Ord a => Heap a -> Maybe (a, Heap a)
|
|
Packit |
1d8052 |
removeMin Nil = Nothing
|
|
Packit |
1d8052 |
removeMin (Node x h1 h2) = Just (x, h1 `merge` h2)
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
merge :: Ord a => Heap a -> Heap a -> Heap a
|
|
Packit |
1d8052 |
h1 `merge` Nil = h1
|
|
Packit |
1d8052 |
Nil `merge` h2 = h2
|
|
Packit |
1d8052 |
h1@(Node x h11 h12) `merge` h2@(Node y h21 h22)
|
|
Packit |
1d8052 |
| x <= y = Node x (h12 `merge` h2) h11
|
|
Packit |
1d8052 |
| otherwise = Node y (h22 `merge` h1) h21
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
fromList :: Ord a => [a] -> Heap a
|
|
Packit |
1d8052 |
fromList xs = merging [ unit x | x <- xs ] []
|
|
Packit |
1d8052 |
where
|
|
Packit |
1d8052 |
merging [] [] = empty
|
|
Packit |
1d8052 |
merging [p] [] = p
|
|
Packit |
1d8052 |
merging (p:q:ps) qs = merging ps ((p`merge`q):qs)
|
|
Packit |
1d8052 |
merging ps qs = merging (ps ++ reverse qs) []
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
toList :: Heap a -> [a]
|
|
Packit |
1d8052 |
toList h = toList' [h]
|
|
Packit |
1d8052 |
where
|
|
Packit |
1d8052 |
toList' [] = []
|
|
Packit |
1d8052 |
toList' (Nil : hs) = toList' hs
|
|
Packit |
1d8052 |
toList' (Node x h1 h2 : hs) = x : toList' (h1:h2:hs)
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
toSortedList :: Ord a => Heap a -> [a]
|
|
Packit |
1d8052 |
toSortedList Nil = []
|
|
Packit |
1d8052 |
toSortedList (Node x h1 h2) = x : toSortedList (h1 `merge` h2)
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
--------------------------------------------------------------------------
|
|
Packit |
1d8052 |
-- heap programs
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
data HeapP a
|
|
Packit |
1d8052 |
= Empty
|
|
Packit |
1d8052 |
| Unit a
|
|
Packit |
1d8052 |
| Insert a (HeapP a)
|
|
Packit |
1d8052 |
| SafeRemoveMin (HeapP a)
|
|
Packit |
1d8052 |
| Merge (HeapP a) (HeapP a)
|
|
Packit |
1d8052 |
| FromList [a]
|
|
Packit |
1d8052 |
deriving (Show)
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
safeRemoveMin :: Ord a => Heap a -> Heap a
|
|
Packit |
1d8052 |
safeRemoveMin h = case removeMin h of
|
|
Packit |
1d8052 |
Nothing -> empty -- arbitrary choice
|
|
Packit |
1d8052 |
Just (_,h) -> h
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
heap :: Ord a => HeapP a -> Heap a
|
|
Packit |
1d8052 |
heap Empty = empty
|
|
Packit |
1d8052 |
heap (Unit x) = unit x
|
|
Packit |
1d8052 |
heap (Insert x p) = insert x (heap p)
|
|
Packit |
1d8052 |
heap (SafeRemoveMin p) = safeRemoveMin (heap p)
|
|
Packit |
1d8052 |
heap (Merge p q) = heap p `merge` heap q
|
|
Packit |
1d8052 |
heap (FromList xs) = fromList xs
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
instance (Ord a, Arbitrary a) => Arbitrary (HeapP a) where
|
|
Packit |
1d8052 |
arbitrary = sized arbHeapP
|
|
Packit |
1d8052 |
where
|
|
Packit |
1d8052 |
arbHeapP s =
|
|
Packit |
1d8052 |
frequency
|
|
Packit |
1d8052 |
[ (1, do return Empty)
|
|
Packit |
1d8052 |
, (1, do x <- arbitrary
|
|
Packit |
1d8052 |
return (Unit x))
|
|
Packit |
1d8052 |
, (s, do x <- arbitrary
|
|
Packit |
1d8052 |
p <- arbHeapP s1
|
|
Packit |
1d8052 |
return (Insert x p))
|
|
Packit |
1d8052 |
, (s, do p <- arbHeapP s1
|
|
Packit |
1d8052 |
return (SafeRemoveMin p))
|
|
Packit |
1d8052 |
, (s, do p <- arbHeapP s2
|
|
Packit |
1d8052 |
q <- arbHeapP s2
|
|
Packit |
1d8052 |
return (Merge p q))
|
|
Packit |
1d8052 |
, (1, do xs <- arbitrary
|
|
Packit |
1d8052 |
return (FromList xs))
|
|
Packit |
1d8052 |
]
|
|
Packit |
1d8052 |
where
|
|
Packit |
1d8052 |
s1 = s-1
|
|
Packit |
1d8052 |
s2 = s`div`2
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
shrink Empty = []
|
|
Packit |
1d8052 |
shrink (Unit x) = [ Unit x' | x' <- shrink x ]
|
|
Packit |
1d8052 |
shrink (FromList xs) = [ Unit x | x <- xs ]
|
|
Packit |
1d8052 |
++ [ FromList xs' | xs' <- shrink xs ]
|
|
Packit |
1d8052 |
shrink p =
|
|
Packit |
1d8052 |
[ FromList (toList (heap p)) ] ++
|
|
Packit |
1d8052 |
case p of
|
|
Packit |
1d8052 |
Insert x p -> [ p ]
|
|
Packit |
1d8052 |
++ [ Insert x p' | p' <- shrink p ]
|
|
Packit |
1d8052 |
++ [ Insert x' p | x' <- shrink x ]
|
|
Packit |
1d8052 |
SafeRemoveMin p -> [ p ]
|
|
Packit |
1d8052 |
++ [ SafeRemoveMin p' | p' <- shrink p ]
|
|
Packit |
1d8052 |
Merge p q -> [ p, q ]
|
|
Packit |
1d8052 |
++ [ Merge p' q | p' <- shrink p ]
|
|
Packit |
1d8052 |
++ [ Merge p q' | q' <- shrink q ]
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
data HeapPP a = HeapPP (HeapP a) (Heap a)
|
|
Packit |
1d8052 |
deriving (Show)
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
instance (Ord a, Arbitrary a) => Arbitrary (HeapPP a) where
|
|
Packit |
1d8052 |
arbitrary =
|
|
Packit |
1d8052 |
do p <- arbitrary
|
|
Packit |
1d8052 |
return (HeapPP p (heap p))
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
shrink (HeapPP p _) =
|
|
Packit |
1d8052 |
[ HeapPP p' (heap p') | p' <- shrink p ]
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
--------------------------------------------------------------------------
|
|
Packit |
1d8052 |
-- properties
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
data Context a where
|
|
Packit |
1d8052 |
Context :: Eq b => (Heap a -> b) -> Context a
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
instance (Ord a, Arbitrary a) => Arbitrary (Context a) where
|
|
Packit |
1d8052 |
arbitrary =
|
|
Packit |
1d8052 |
do f <- sized arbContext
|
|
Packit |
1d8052 |
let vec h = (size h, toSortedList h, isEmpty h)
|
|
Packit |
1d8052 |
return (Context (vec . f))
|
|
Packit |
1d8052 |
where
|
|
Packit |
1d8052 |
arbContext s =
|
|
Packit |
1d8052 |
frequency
|
|
Packit |
1d8052 |
[ (1, do return id)
|
|
Packit |
1d8052 |
, (s, do x <- arbitrary
|
|
Packit |
1d8052 |
f <- arbContext (s-1)
|
|
Packit |
1d8052 |
return (insert x . f))
|
|
Packit |
1d8052 |
, (s, do f <- arbContext (s-1)
|
|
Packit |
1d8052 |
return (safeRemoveMin . f))
|
|
Packit |
1d8052 |
, (s, do HeapPP _ h <- arbitrary
|
|
Packit |
1d8052 |
f <- arbContext (s`div`2)
|
|
Packit |
1d8052 |
elements [ (h `merge`) . f, (`merge` h) . f ])
|
|
Packit |
1d8052 |
]
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
instance Show (Context a) where
|
|
Packit |
1d8052 |
show _ = "*"
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
(=~) :: Heap Char -> Heap Char -> Property
|
|
Packit |
1d8052 |
--h1 =~ h2 = sort (toList h1) == sort (toList h2)
|
|
Packit |
1d8052 |
--h1 =~ h2 = property (nub (sort (toList h1)) == nub (sort (toList h2))) -- bug!
|
|
Packit |
1d8052 |
h1 =~ h2 = property (\(Context c) -> c h1 == c h2)
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
{-
|
|
Packit |
1d8052 |
The normal form is:
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
insert x1 (insert x2 (... empty)...)
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
where x1 <= x2 <= ...
|
|
Packit |
1d8052 |
-}
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
-- heap creating operations
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
prop_Unit x =
|
|
Packit |
1d8052 |
unit x =~ insert x empty
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
prop_RemoveMin_Empty =
|
|
Packit |
1d8052 |
removeMin (empty :: Heap OrdA) == Nothing
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
prop_RemoveMin_Insert1 x =
|
|
Packit |
1d8052 |
removeMin (insert x empty :: Heap OrdA) == Just (x, empty)
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
prop_RemoveMin_Insert2 x y (HeapPP _ h) =
|
|
Packit |
1d8052 |
removeMin (insert x (insert y h)) ==~
|
|
Packit |
1d8052 |
(insert (max x y) `maph` removeMin (insert (min x y) h))
|
|
Packit |
1d8052 |
where
|
|
Packit |
1d8052 |
f `maph` Just (x,h) = Just (x, f h)
|
|
Packit |
1d8052 |
f `maph` Nothing = Nothing
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
Nothing ==~ Nothing = property True
|
|
Packit |
1d8052 |
Just (x,h1) ==~ Just (y,h2) = x==y .&&. h1 =~ h2
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
prop_InsertSwap x y (HeapPP _ h) =
|
|
Packit |
1d8052 |
insert x (insert y h) =~ insert y (insert x h)
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
prop_MergeInsertLeft x (HeapPP _ h1) (HeapPP _ h2) =
|
|
Packit |
1d8052 |
(insert x h1 `merge` h2) =~ insert x (h1 `merge` h2)
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
prop_MergeInsertRight x (HeapPP _ h1) (HeapPP _ h2) =
|
|
Packit |
1d8052 |
(h1 `merge` insert x h2) =~ insert x (h1 `merge` h2)
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
-- heap observing operations
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
prop_Size_Empty =
|
|
Packit |
1d8052 |
size empty == 0
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
prop_Size_Insert x (HeapPP _ (h :: Heap OrdA)) =
|
|
Packit |
1d8052 |
size (insert x h) == 1 + size h
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
prop_ToList_Empty =
|
|
Packit |
1d8052 |
toList empty == ([] :: [OrdA])
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
prop_ToList_Insert x (HeapPP _ (h :: Heap OrdA)) =
|
|
Packit |
1d8052 |
sort (toList (insert x h)) == sort (x : toList h)
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
prop_ToSortedList (HeapPP _ (h :: Heap OrdA)) =
|
|
Packit |
1d8052 |
toSortedList h == sort (toList h)
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
--------------------------------------------------------------------------
|
|
Packit |
1d8052 |
-- main
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
return []
|
|
Packit |
1d8052 |
main = $(quickCheckAll)
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
--------------------------------------------------------------------------
|
|
Packit |
1d8052 |
-- the end.
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
|
|
Packit |
1d8052 |
|