content: {-|
    Binominal Heap
  
    - the fun of programming
  -}
  
  module Data.Heap.Binominal (
    -- * Data structures
      Heap(..)
    , Tree(..)
    , Rank
    -- * Creating heaps
    , empty
    , singleton
    , insert
    , fromList
    -- * Converting to a list
    , toList
    -- * Deleting
    , deleteMin
    -- * Checking heaps
    , null
    -- * Helper functions
    , 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 =
      -- | Rank, a minimum root element, trees
      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.
  -}
  
  empty :: Heap a
  empty = Heap []
  
  {-|
  See if the heap is empty.
  
  >>> Data.Heap.Binominal.null empty
  True
  >>> Data.Heap.Binominal.null (singleton 1)
  False
  -}
  
  null :: Heap a -> Bool
  null (Heap ts) = L.null ts
  
  {-| Singleton heap.
  -}
  
  singleton :: a -> Heap a
  singleton x = Heap [Node 0 x []]
  
  ----------------------------------------------------------------
  
  {-| Insertion.
  
  >>> insert 7 (fromList [5,3]) == fromList [3,5,7]
  True
  >>> insert 5 empty            == singleton 5
  True
  -}
  
  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'
  
  ----------------------------------------------------------------
  
  {-| Creating a heap from a list.
  
  >>> empty == fromList []
  True
  >>> singleton 'a' == fromList ['a']
  True
  >>> fromList [5,3] == fromList [5,3]
  True
  -}
  
  fromList :: Ord a => [a] -> Heap a
  fromList = foldl' (flip insert) empty
  
  ----------------------------------------------------------------
  
  {-| Creating a list from a heap. O(N)
  
  >>> let xs = [5,3,5]
  >>> length (toList (fromList xs)) == length xs
  True
  >>> toList 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
  
  ----------------------------------------------------------------
  
  {-| Finding the minimum element.
  
  >>> minimum (fromList [3,5,1])
  Just 1
  >>> minimum empty
  Nothing
  -}
  
  minimum :: Ord a => Heap a -> Maybe a
  minimum (Heap ts) = root . fst <$> deleteMin' ts
  
  ----------------------------------------------------------------
  
  {-| Deleting the minimum element.
  
  >>> deleteMin (fromList [5,3,7]) == fromList [5,7]
  True
  >>> deleteMin empty == empty
  True
  -}
  
  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
  
  ----------------------------------------------------------------
  {-| Merging two heaps
  
  >>> merge (fromList [5,3]) (fromList [5,7]) == fromList [3,5,5,7]
  True
  -}
  
  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')
  
  ----------------------------------------------------------------
  -- Basic operations
  ----------------------------------------------------------------
  
  {-| Checking validity of a heap.
  -}
  
  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) -- allowing duplicated keys
  