module Data.Heap
(
Heap, MinHeap, MaxHeap
, HeapPolicy(..), MinPolicy, MaxPolicy
, null, isEmpty, size, head, tail, extractHead
, empty, singleton, insert
, union, unions
, filter, partition
, take, drop, splitAt
, takeWhile, span, break
, fromList, toList, elems
, fromAscList, toAscList
, check
) where
import Data.Foldable (Foldable(foldMap))
import Data.List (foldl')
import Data.Monoid
import Prelude hiding (break, drop, filter, head, null, tail, span, splitAt, take, takeWhile)
import Text.Read
data Heap p a
= Empty
| Tree !Int a !(Heap p a) !(Heap p a)
type MinHeap a = Heap MinPolicy a
type MaxHeap a = Heap MaxPolicy a
instance (Show a) => Show (Heap p a) where
show h = "fromList " ++ (show . toList) h
instance (HeapPolicy p a) => Eq (Heap p a) where
h1 == h2 = EQ == compare h1 h2
instance (HeapPolicy p a) => Ord (Heap p a) where
compare h1 h2 = compare' (toAscList h1) (toAscList h2)
where
compare' [] [] = EQ
compare' [] _ = LT
compare' _ [] = GT
compare' (x:xs) (y:ys) = case heapCompare (policy h1) x y of
EQ -> compare' xs ys
c -> c
instance (HeapPolicy p a) => Monoid (Heap p a) where
mempty = empty
mappend = union
mconcat = unions
instance Foldable (Heap p) where
foldMap _ Empty = mempty
foldMap f (Tree _ x l r) = foldMap f l `mappend` f x `mappend` foldMap f r
instance (HeapPolicy p a, Read a) => Read (Heap p a) where
#ifdef __GLASGOW_HASKELL__
readPrec = parens $ prec 10 $ do
Ident "fromList" <- lexP
xs <- readPrec
return (fromList xs)
readListPrec = readListPrecDefault
#else
readsPrec p = readParen (p > 10) $ \r -> do
("fromList", s) <- lex r
(xs, t) <- reads s
return (fromList xs, t)
#endif
class HeapPolicy p a where
heapCompare :: p
-> a
-> a
-> Ordering
data MinPolicy
instance (Ord a) => HeapPolicy MinPolicy a where
heapCompare = const compare
data MaxPolicy
instance (Ord a) => HeapPolicy MaxPolicy a where
heapCompare = const (flip compare)
null :: Heap p a -> Bool
null Empty = True
null _ = False
isEmpty :: Heap p a -> Bool
isEmpty = null
rank :: Heap p a -> Int
rank Empty = 0
rank (Tree r _ _ _) = r
policy :: Heap p a -> p
policy = const undefined
size :: (Num n) => Heap p a -> n
size Empty = 0
size (Tree _ _ l r) = 1 + size l + size r
head :: (HeapPolicy p a) => Heap p a -> a
head = fst . extractHead
tail :: (HeapPolicy p a) => Heap p a -> Heap p a
tail = snd . extractHead
extractHead :: (HeapPolicy p a) => Heap p a -> (a, Heap p a)
extractHead Empty = error "empty Heap"
extractHead (Tree _ x l r) = (x, union l r)
empty :: Heap p a
empty = Empty
singleton :: a -> Heap p a
singleton x = Tree 1 x empty empty
insert :: (HeapPolicy p a) => a -> Heap p a -> Heap p a
insert x h = union h (singleton x)
take :: (HeapPolicy p a) => Int -> Heap p a -> [a]
take n = fst . (splitAt n)
drop :: (HeapPolicy p a) => Int -> Heap p a -> Heap p a
drop n = snd . (splitAt n)
splitAt :: (HeapPolicy p a) => Int -> Heap p a -> ([a], Heap p a)
splitAt _ Empty = ([], empty)
splitAt n heap@(Tree _ x l r)
| n > 0 = let (xs, heap') = splitAt (n1) (union l r) in (x:xs, heap')
| otherwise = ([], heap)
takeWhile :: (HeapPolicy p a) => (a -> Bool) -> Heap p a -> [a]
takeWhile p = fst . (span p)
span :: (HeapPolicy p a) => (a -> Bool) -> Heap p a -> ([a], Heap p a)
span _ Empty = ([], empty)
span p heap@(Tree _ x l r)
| p x = let (xs, heap') = span p (union l r) in (x:xs, heap')
| otherwise = ([], heap)
break :: (HeapPolicy p a) => (a -> Bool) -> Heap p a -> ([a], Heap p a)
break p = span (not . p)
union :: (HeapPolicy p a) => Heap p a -> Heap p a -> Heap p a
union h Empty = h
union Empty h = h
union heap1@(Tree _ x l1 r1) heap2@(Tree _ y l2 r2) =
if LT == heapCompare (policy heap1) x y
then makeT x l1 (union r1 heap2)
else makeT y l2 (union r2 heap1)
makeT :: a -> Heap p a -> Heap p a -> Heap p a
makeT x a b = let
ra = rank a
rb = rank b
in if ra > rb
then Tree (rb + 1) x a b
else Tree (ra + 1) x b a
unions :: (HeapPolicy p a) => [Heap p a] -> Heap p a
unions = foldl' union empty
filter :: (HeapPolicy p a) => (a -> Bool) -> Heap p a -> Heap p a
filter p = fst . (partition p)
partition :: (HeapPolicy p a) => (a -> Bool) -> Heap p a -> (Heap p a, Heap p a)
partition _ Empty = (empty, empty)
partition p (Tree _ x l r)
| p x = (makeT x l1 r1, union l2 r2)
| otherwise = (union l1 r1, makeT x l2 r2)
where
(l1, l2) = partition p l
(r1, r2) = partition p r
fromList :: (HeapPolicy p a) => [a] -> Heap p a
fromList = unions . (map singleton)
toList :: Heap p a -> [a]
toList Empty = []
toList (Tree _ x l r) = x : toList l ++ toList r
elems :: Heap p a -> [a]
elems = toList
fromAscList :: (HeapPolicy p a) => [a] -> Heap p a
fromAscList = fromList
toAscList :: (HeapPolicy p a) => Heap p a -> [a]
toAscList Empty = []
toAscList h@(Tree _ e l r) = e : mergeLists (toAscList l) (toAscList r)
where
mergeLists [] ys = ys
mergeLists xs [] = xs
mergeLists xs@(x:xs') ys@(y:ys') = if LT == heapCompare (policy h) x y
then x : mergeLists xs' ys
else y : mergeLists xs ys'
check :: (HeapPolicy p a) => Heap p a -> Bool
check Empty = True
check h@(Tree r x left right) = let
leftRank = rank left
rightRank = rank right
in
(null left || LT /= heapCompare (policy h) (head left) x)
&& (null right || LT /= heapCompare (policy h) (head right) x)
&& r == 1 + rightRank
&& leftRank >= rightRank
&& check left
&& check right