Leftist.hs

{-|
  Leftist Heap

  - the fun of programming
-}

module Data.Heap.Leftist (
  -- * Data structures
    Leftist(..)
  , 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)

----------------------------------------------------------------

data Leftist a = Leaf | Node Rank (Leftist a) a (Leftist a) deriving Show

instance (Eq a, Ord a) => Eq (Leftist a) where
    h1 == h2 = heapSort h1 == heapSort h2

type Rank = Int

----------------------------------------------------------------

rank :: Leftist a -> Rank
rank Leaf           = 0
rank (Node v _ _ _) = v

----------------------------------------------------------------

{-| Empty heap.
-}

empty :: Leftist a
empty = Leaf

{-|
See if the heap is empty.

>>> Data.Heap.Leftist.null empty
True
>>> Data.Heap.Leftist.null (singleton 1)
False
-}

null :: Leftist t -> Bool
null Leaf           = True
null (Node _ _ _ _) = False

{-| Singleton heap.
-}

singleton :: a -> Leftist a
singleton x = Node 1 Leaf x Leaf

----------------------------------------------------------------

{-| Insertion.

>>> insert 7 (fromList [5,3]) == fromList [3,5,7]
True
>>> insert 5 empty            == singleton 5
True
-}

insert :: Ord a => a -> Leftist a -> Leftist a
insert x t = merge (singleton x) t

----------------------------------------------------------------

{-| 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] -> Leftist 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 :: Leftist a -> [a]
toList t = inorder t []
  where
    inorder Leaf xs           = xs
    inorder (Node _ l x r) xs = inorder l (x : inorder r xs)

----------------------------------------------------------------

{-| Finding the minimum element.

>>> minimum (fromList [3,5,1])
Just 1
>>> minimum empty
Nothing
-}

minimum :: Leftist a -> Maybe a
minimum Leaf           = Nothing
minimum (Node _ _ x _) = Just x

----------------------------------------------------------------

{-| Deleting the minimum element.

>>> deleteMin (fromList [5,3,7]) == fromList [5,7]
True
>>> deleteMin empty == empty
True
-}

deleteMin :: Ord a => Leftist a -> Leftist a
deleteMin Leaf           = Leaf
deleteMin (Node _ l _ r) = merge l r

deleteMin2 :: Ord a => Leftist a -> Maybe (a, Leftist a)
deleteMin2 Leaf = Nothing
deleteMin2 h    = (\m -> (m, deleteMin h)) <$> minimum h

----------------------------------------------------------------
{-| Merging two heaps

>>> merge (fromList [5,3]) (fromList [5,7]) == fromList [3,5,5,7]
True
-}

merge :: Ord a => Leftist a -> Leftist a -> Leftist a
merge t1 Leaf = t1
merge Leaf t2 = t2
merge t1@(Node _ l1 x1 r1) t2@(Node _ l2 x2 r2)
  | x1 <= x2  = join l1 x1 (merge r1 t2)
  | otherwise = join l2 x2 (merge t1 r2)

join :: Ord a => Leftist a -> a -> Leftist a -> Leftist a
join t1 x t2
  | rank t1 >= rank t2 = Node (rank t2 + 1) t1 x t2
  | otherwise          = Node (rank t1 + 1) t2 x t1

----------------------------------------------------------------
-- Basic operations
----------------------------------------------------------------

{-| Checking validity of a heap.
-}

valid :: Ord a => Leftist a -> Bool
valid t = isOrdered (heapSort t)

heapSort :: Ord a => Leftist 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