module Data.Heap.Binominal (
Heap(..)
, Tree(..)
, Rank
, empty
, singleton
, insert
, fromList
, toList
, deleteMin
, null
, merge
, minimum
, valid
, heapSort
) where
import Control.Applicative hiding (empty)
import Data.List (foldl', unfoldr)
import Data.Maybe
import Prelude hiding (minimum, maximum, null)
import qualified Prelude as L (null)
type Rank = Int
data Tree a =
Node Rank a [Tree a] deriving Show
newtype Heap a = Heap [Tree a] deriving Show
instance (Eq a, Ord a) => Eq (Heap a) where
h1 == h2 = heapSort h1 == heapSort h2
rank :: Tree a -> Rank
rank (Node r _ _) = r
root :: Tree a -> a
root (Node _ x _) = x
link :: Ord a => Tree a -> Tree a -> Tree a
link t1@(Node r1 x1 ts1) t2@(Node r2 x2 ts2)
| x1 <= x2 = Node (r1+1) x1 (t2:ts1)
| otherwise = Node (r2+1) x2 (t1:ts2)
empty :: Heap a
empty = Heap []
null :: Heap a -> Bool
null (Heap ts) = L.null ts
singleton :: a -> Heap a
singleton x = Heap [Node 0 x []]
insert :: Ord a => a -> Heap a -> Heap a
insert x (Heap ts) = Heap (insert' (Node 0 x []) ts)
insert' :: Ord a => Tree a -> [Tree a] -> [Tree a]
insert' t [] = [t]
insert' t ts@(t':ts')
| rank t < rank t' = t : ts
| otherwise = insert' (link t t') ts'
fromList :: Ord a => [a] -> Heap a
fromList = foldl' (flip insert) empty
toList :: Heap a -> [a]
toList (Heap ts) = concatMap toList' ts
toList' :: Tree a -> [a]
toList' (Node _ x []) = [x]
toList' (Node _ x ts) = x : concatMap toList' ts
minimum :: Ord a => Heap a -> Maybe a
minimum (Heap ts) = root . fst <$> deleteMin' ts
deleteMin :: Ord a => Heap a -> Heap a
deleteMin (Heap ts) = case deleteMin' ts of
Nothing -> empty
Just (Node _ _ ts1, ts2) -> Heap (merge' (reverse ts1) ts2)
deleteMin2 :: Ord a => Heap a -> Maybe (a, Heap a)
deleteMin2 (Heap []) = Nothing
deleteMin2 h = (\m -> (m, deleteMin h)) <$> minimum h
deleteMin' :: Ord a => [Tree a] -> Maybe (Tree a, [Tree a])
deleteMin' [] = Nothing
deleteMin' [t] = Just (t,[])
deleteMin' (t:ts)
| root t < root t' = Just (t, ts)
| otherwise = Just (t', t:ts')
where
Just (t',ts') = deleteMin' ts
merge :: Ord a => Heap a -> Heap a -> Heap a
merge (Heap ts1) (Heap ts2) = Heap (merge' ts1 ts2)
merge' :: Ord a => [Tree a] -> [Tree a] -> [Tree a]
merge' ts1 [] = ts1
merge' [] ts2 = ts2
merge' ts1@(t1:ts1') ts2@(t2:ts2')
| rank t1 < rank t2 = t1 : merge' ts1' ts2
| rank t2 < rank t1 = t2 : merge' ts1 ts2'
| otherwise = insert' (link t1 t2) (merge' ts1' ts2')
valid :: Ord a => Heap a -> Bool
valid t = isOrdered (heapSort t)
heapSort :: Ord a => Heap a -> [a]
heapSort t = unfoldr deleteMin2 t
isOrdered :: Ord a => [a] -> Bool
isOrdered [] = True
isOrdered [_] = True
isOrdered (x:y:xys) = x <= y && isOrdered (y:xys)