liquidhaskell-0.8.10.7: benchmarks/llrbtree-0.1.1/Data/Heap/Splay.hs
{-|
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)?
-}