module Heap where

data Heap a = Nil | Node Int a (Heap a) (Heap a) deriving Show

emptyHeap :: Heap a
emptyHeap = Nil

isEmpty :: Heap a -> Bool
isEmpty Nil = True
isEmpty _ = False

size Nil = 0
size (Node s _ _ _) = s

root (Node _ x _ _) = x

isHeap (Node s x hl hr) = s == 1 + sl + sr && sl >= sr &&
    (isEmpty hl || x >= root hl) &&
    (isEmpty hr || x >= root hr) &&
    isHeap hl && isHeap hr
    where (sl, sr) = (size hl, size hr)

realign :: Heap a -> Heap a
realign Nil = Nil
realign h@(Node s x hl hr)
    | size hl >= size hr = h
    | otherwise = Node s x hr hl

union :: Ord a => Heap a -> Heap a -> Heap a
union h Nil = h
union Nil h = h
union h1@(Node s1 x h1l h1r) h2@(Node s2 y h2l h2r)
    | x >= y = realign
        (Node (s1+s2) x h1l (union h1r h2))
    | otherwise = realign
        (Node (s1+s2) y h2l (union h1 h2r))

insert :: Ord a => a -> Heap a -> Heap a
insert x h = union (Node 1 x Nil Nil) h

findMax :: Heap a -> Maybe a
findMax h = if isEmpty h then Nothing
    else Just (root h)

deleteMax :: Ord a => Heap a -> (Maybe a, Heap a)
deleteMax Nil = (Nothing, Nil)
deleteMax (Node _ x hl hr) = (Just x, union hl hr)

instance Functor Heap where
    fmap f Nil = Nil
    fmap f (Node n x left right) = Node n (f x) left' right' where
        left' = fmap f left
        right' = fmap f right 

instance Foldable Heap where
    foldr _ acc Nil = acc
    foldr f base (Node _ x left right) = f x $ foldr f acc right where
        acc = foldr f base left