{-|
  Purely functional top-down splay heaps.

   * D.D. Sleator and R.E. Rarjan,
     \"Self-Adjusting Binary Search Tree\",
     Journal of the Association for Computing Machinery,
     Vol 32, No 3, July 1985, pp 652-686.
     <http://www.cs.cmu.edu/~sleator/papers/self-adjusting.pdf>
-}

module Data.Heap.Splay (
  -- * Data structures
    Heap(..)
  , Splay(..)
  -- * Creating heaps
  , empty
  , singleton
  , insert
  , fromList
  -- * Converting to a list
  , toList
  -- * Deleting
  , deleteMin
  -- * Checking heaps
  , null
  -- * Helper functions
  , partition
  , merge
  , minimum
  , valid
  , heapSort
  , showHeap
  , printHeap
  ) where

import Control.Applicative hiding (empty)
import Data.List (foldl', unfoldr)
import Data.Maybe
import Prelude hiding (minimum, maximum, null)

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

data Heap a = None | Some a (Splay a) deriving Show

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

data Splay a = Leaf | Node (Splay a) a (Splay a) deriving Show

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

{-| Splitting smaller and bigger with splay.
    Since this is a heap implementation, members is not
    necessarily unique.
-}
partition :: Ord a => a -> Splay a -> (Splay a, Splay a)
partition _ Leaf = (Leaf, Leaf)
partition k x@(Node xl xk xr) = case compare k xk of
    LT -> case xl of
      Leaf          -> (Leaf, x)
      Node yl yk yr -> case compare k yk of
          LT -> let (lt, gt) = partition k yl        -- LL :zig zig
                in  (lt, Node gt yk (Node yr xk xr))
          _  -> let (lt, gt) = partition k yr        -- LR :zig zag
                in  (Node yl yk lt, Node gt xk xr)
    _ -> case xr of
      Leaf          -> (x, Leaf)
      Node yl yk yr -> case compare k yk of
          LT -> let (lt, gt) = partition k yl
                in  (Node xl xk lt, Node gt yk yr)   -- RL :zig zig
          _  -> let (lt, gt) = partition k yr        -- RR :zig zag
                in  (Node (Node xl xk yl) yk lt, gt)

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

{-| Empty heap.
-}

empty :: Heap a
empty = None

{-|
See if the heap is empty.

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

null :: Heap a -> Bool
null None = True
null _    = False

{-| Singleton heap.
-}

singleton :: a -> Heap a
singleton x = Some x (Node Leaf x Leaf)

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

{-| 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 None = singleton x
insert x (Some m t) = Some m' $ Node l x r
  where
    m' = min x m
    (l,r) = partition 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] -> 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 None       = []
toList (Some _ 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 :: Heap a -> Maybe a
minimum None       = Nothing
minimum (Some m _) = Just m

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

{-| Deleting the minimum element.

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

deleteMin :: Heap a -> Heap a
deleteMin None       = None
deleteMin (Some _ t) = fromMaybe None $ do
    t' <- deleteMin' t
    m  <- findMin' t'
    return $ Some m t'

deleteMin2 :: Heap a -> Maybe (a, Heap a)
deleteMin2 None       = Nothing
deleteMin2 h = (\m -> (m, deleteMin h)) <$> minimum h

-- deleteMin' and findMin' cannot be implemented together

deleteMin' :: Splay a -> Maybe (Splay a)
deleteMin' Leaf                        = Nothing
deleteMin' (Node Leaf _ r)             = Just r
deleteMin' (Node (Node Leaf _ lr) x r) = Just (Node lr x r)
deleteMin' (Node (Node ll lx lr) x r)  = let Just t = deleteMin' ll
                                         in Just (Node t lx (Node lr x r))

findMin' :: Splay a -> Maybe a
findMin' Leaf            = Nothing
findMin' (Node Leaf x _) = Just x
findMin' (Node l _ _)    = findMin' l

----------------------------------------------------------------
{-| 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 None t = t
merge t None = t
merge (Some m1 t1) (Some m2 t2) = Some m t
  where
    m = min m1 m2
    t = merge' t1 t2

merge' :: Ord a => Splay a -> Splay a -> Splay a
merge' Leaf t = t
merge' (Node a x b) t = Node (merge' ta a) x (merge' tb b)
  where
    (ta,tb) = partition x t

----------------------------------------------------------------
-- 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

showHeap :: Show a => Splay a -> String
showHeap = showHeap' ""

showHeap' :: Show a => String -> Splay a -> String
showHeap' _ Leaf = "\n"
showHeap' pref (Node l x r) = show x ++ "\n"
                        ++ pref ++ "+ " ++ showHeap' pref' l
                        ++ pref ++ "+ " ++ showHeap' pref' r
  where
    pref' = "  " ++ pref

printHeap :: Show a => Splay a -> IO ()
printHeap = putStr . showHeap

{-
Demo: http://www.link.cs.cmu.edu/splay/
Paper: http://www.cs.cmu.edu/~sleator/papers/self-adjusting.pdf
TopDown: http://www.cs.umbc.edu/courses/undergraduate/341/fall02/Lectures/Splay/TopDownSplay.ppt
Blog: http://chasen.org/~daiti-m/diary/?20061223
      http://www.geocities.jp/m_hiroi/clisp/clispb07.html


               fromList    minimum          delMin          member
Blanced Tree   N log N     log N            log N           log N
Skew Heap      N log N     1                log N(???)      N/A
Splay Heap     N           log N or A(N)?   log N or A(N)?  log N or A(N)?

-}