BUSplay.hs

{-|
  Purely functional bottom-up splay sets.

   * 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.Set.BUSplay (
  -- * Data structures
    Splay(..)
  -- * Creating sets
  , empty
  , singleton
  , insert
  , fromList
  -- * Converting a list
  , toList
  -- * Membership
  , member
  -- * Deleting
  , delete
  , deleteMin
  , deleteMax
  -- * Checking
  , null
  -- * Set operations
  , union
  , intersection
  , difference
  -- * Helper functions
  , minimum
  , maximum
  , valid
  , (===)
  , showSet
  , printSet
  ) where

import Data.List (foldl')
import Prelude hiding (minimum, maximum, null)

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

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

instance (Eq a) => Eq (Splay a) where
    t1 == t2 = toList t1 == toList t2

{-| Checking if two splay sets are exactly the same shape.
-}
(===) :: Eq a => Splay a -> Splay a -> Bool
Leaf            === Leaf            = True
(Node l1 x1 r1) === (Node l2 x2 r2) = x1 == x2 && l1 === l2 && r1 === r2
_               === _               = False

data Direction a = L a (Splay a) | R a (Splay a) deriving Show

type Path a = [Direction a]

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

search :: Ord a => a -> Splay a -> (Splay a, Path a)
search k s = go s []
  where
    go Leaf           bs = (Leaf, bs)
    go t@(Node l x r) bs = case compare k x of
        LT -> go l (L x r : bs)
        GT -> go r (R x l : bs)
        EQ -> (t,bs)

searchMin :: Splay a -> (Splay a, Path a)
searchMin s = go s []
  where
    go Leaf         bs = (Leaf, bs)
    go (Node l x r) bs = go l (L x r : bs)

searchMax :: Splay a -> (Splay a, Path a)
searchMax s = go s []
  where
    go Leaf         bs = (Leaf, bs)
    go (Node l x r) bs = go r (R x l : bs)

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

splay :: Splay a -> Path a -> Splay a
splay t []                 = t
splay Leaf (L x r : bs)    = splay (Node Leaf x r) bs
splay Leaf (R x l : bs)    = splay (Node l x Leaf) bs
splay (Node a x b) [L y c] = Node a x (Node b y c) -- zig
splay (Node b y c) [R x a] = Node (Node a x b) y c -- zig
splay (Node a x b) (L y c : L z d : bs)
    = splay (Node a x (Node b y (Node c z d))) bs  -- zig zig
splay (Node b x c) (R y a : L z d : bs)
    = splay (Node (Node a y b) x (Node c z d)) bs  -- zig zag
splay (Node c z d) (R y b : R x a : bs)
    = splay (Node (Node (Node a x b) y c) z d) bs  -- zig zig
splay (Node b x c) (L y d : R z a : bs)
    = splay (Node (Node a z b) x (Node c y d)) bs  -- zig zag

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

{-| Empty set.
-}

empty :: Splay a
empty = Leaf

{-|
See if the splay set is empty.

>>> Data.Set.BUSplay.null empty
True
>>> Data.Set.BUSplay.null (singleton 1)
False
-}

null :: Splay a -> Bool
null Leaf = True
null _ = False

{-| Singleton set.
-}

singleton :: a -> Splay a
singleton x = Node Leaf x Leaf

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

{-| Insertion.

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

insert :: Ord a => a -> Splay a -> Splay a
insert x t = Node l x r
  where
    (l,_,r) = split x t

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

{-| Creating a set from a list.

>>> empty == fromList []
True
>>> singleton 'a' == fromList ['a']
True
>>> fromList [5,3,5] == fromList [5,3]
True
-}

fromList :: Ord a => [a] -> Splay a
fromList = foldl' (flip insert) empty

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

{-| Creating a list from a set. O(N)

>>> toList (fromList [5,3])
[3,5]
>>> toList empty
[]
-}

toList :: Splay a -> [a]
toList t = inorder t []
  where
    inorder Leaf xs = xs
    inorder (Node l x r) xs = inorder l (x : inorder r xs)

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

{-| Checking if this element is a member of a set?

>>> fst $ member 5 (fromList [5,3])
True
>>> fst $ member 1 (fromList [5,3])
False
-}

-- this is 'access' in the paper
member :: Ord a => a -> Splay a -> (Bool, Splay a)
member x t = case search x t of
    (Leaf, []) -> (False, empty)
    (Leaf, ps) -> (False, splay Leaf ps)
    (s, ps)    -> (True,  splay s ps)

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

{-| Finding the minimum element.

>>> fst $ minimum (fromList [3,5,1])
1
>>> minimum empty
*** Exception: minimum
-}

minimum :: Splay a -> (a, Splay a)
minimum t = case uncurry splay $ searchMin t of
    Leaf          -> error "minimum"
    s@(Node _ x _) -> (x, s)

{-| Finding the maximum element.

>>> fst $ maximum (fromList [3,5,1])
5
>>> maximum empty
*** Exception: maximum
-}

maximum :: Splay a -> (a, Splay a)
maximum t = case uncurry splay $ searchMax t of
    Leaf           -> error "maximum"
    s@(Node _ x _) -> (x, s)

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

{-| Deleting the minimum element.

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

deleteMin :: Splay a -> Splay a
deleteMin Leaf = error "deleteMin"
deleteMin t = case minimum t of
    (_, Node Leaf _ r) -> r
    _                  -> error "deleteMin"

{-| Deleting the maximum

>>> deleteMax (fromList [(5,"a"), (3,"b"), (7,"c")]) == fromList [(3,"b"), (5,"a")]
True
>>> deleteMax empty
*** Exception: deleteMax
-}

deleteMax :: Splay a -> Splay a
deleteMax Leaf = error "deleteMax"
deleteMax t = case maximum t of
    (_, Node l _ Leaf) -> l
    _                  -> error "deleteMax"


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

{-| Deleting this element from a set.

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

delete :: Ord a => a -> Splay a -> Splay a
delete _ Leaf = Leaf
delete x t = case member x t of
    (True,  Node l _ r) -> merge l r
    (False, s)          -> s
    _                   -> error "delete"

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

{-| Creating a union set from two sets.

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

union :: Ord a => Splay a -> Splay a -> Splay a
union t1 Leaf = t1
union Leaf t2 = t2
union t1 (Node l x r) = Node (union l' l) x (union r' r)
  where
    (l',_,r') = split x t1

{-| Creating a intersection set from sets.

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

intersection :: Ord a => Splay a -> Splay a -> Splay a
intersection Leaf _ = Leaf
intersection _ Leaf = Leaf
intersection t1 (Node l x r) = case split x t1 of
    (l', True,  r') -> Node (intersection l' l) x (intersection r' r)
    (l', False, r') -> merge (intersection l' l) (intersection r' r)

{-| Creating a difference set from sets.

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

difference :: Ord a => Splay a -> Splay a -> Splay a
difference Leaf _          = Leaf
difference t1 Leaf         = t1
difference t1 (Node l x r) = union (difference l' l) (difference r' r)
  where
    (l',_,r') = split x t1

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

merge :: Splay a -> Splay a -> Splay a
merge Leaf t2 = t2
merge t1 Leaf = t1
merge t1 t2 = Node l x t2
  where
    (_, Node l x Leaf) = maximum t1

split :: Ord a => a -> Splay a -> (Splay a, Bool, Splay a)
split _ Leaf = (Leaf,False,Leaf)
split x t    = case member x t of
    (True,   Node l _ r) -> (l,True,r)
    (False,  Node l y r) -> case compare x y of
        LT -> (l, False, Node Leaf y r)
        GT -> (Node l y Leaf, False, r)
        EQ -> error "split"
    _ -> error "split"

{-| Checking validity of a set.
-}

valid :: Ord a => Splay a -> Bool
valid t = isOrdered t

isOrdered :: Ord a => Splay a -> Bool
isOrdered t = ordered $ toList t
  where
    ordered [] = True
    ordered [_] = True
    ordered (x:y:xys) = x < y && ordered (y:xys)


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

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

printSet :: Show a => Splay a -> IO ()
printSet = putStr . showSet