modified: October 15, 2017

Okasaki 5.4, Splay Heaps

module Splay
  ( T, insert, findMin, deleteMin
  , heapSort
  ) where

Splay trees are BSTs with special operations

data T a = E | T (T a) a (T a)

pretty-printing

instance Show a => Show (T a) where
  show E = "."
  show (T E v E) = show v
  show (T l v r) = wrap $ unwords [show l, show v, show r]
    where wrap s = "("++s++")"

make a left-leaning/right-leaning tree from a list

tl :: [a] -> T a
tl = foldl (\t v -> T t v E) E
tr :: [a] -> T a
tr = foldr (T E) E
-- *Splay> tl [1..7]
-- ((((((1 2 .) 3 .) 4 .) 5 .) 6 .) 7 .)
-- *Splay> tr [1..7]
-- (. 1 (. 2 (. 3 (. 4 (. 5 (. 6 7))))))

The splay operation

When you take two steps in the same direction while walking a tree, counter-rotate it:

bigger :: Ord a => a -> T a -> T a
bigger x E = E
bigger x (T _ v r) | x >= v = bigger x r
bigger x (T l v r) =
  case l of
    E -> T E v r
    (T l2 v2 r2) ->
      if x >= v2 then T (bigger x r2) v r
      else T (bigger x l2) v2 (T r2 v r)

Figure 5.4:

-- *Splay> bigger 0 $ tl [1..7]
-- (((1 2 3) 4 5) 6 7)

New elements always take root position

insert x t =
  let (a, b) = partition x t in T a x b

partition, simple version

partition' _ E = (E, E)
partition' x (T l v r) =
  if x >= v
  then let (a1, b1) = partition' x l in (a1, T b1 v r)
  else let (a2, b2) = partition' x r in (T l v a2, b2)

partition with splaying

partition :: Ord a => a -> T a -> (T a, T a)
partition _ E = (E, E)
partition x (T l v r) =
  if x >= v
  then case r of
         E -> (T l v E, E) 
         T l2 v2 r2 ->
           if x >= v2
           -- rotate
           then let (a, b) = partition x r2 in (T (T l v l2) v2 a, b)
           -- zigzag
           else let (a, b) = partition x l2 in (T l v a, T b v2 r2)
  else case l of
         E -> (E, T E v r)
         T l2 v2 r2 ->
           if x >= v2
           -- zagzig
           then let (a, b) = partition x r2 in (T l2 v2 a, T b v r)
           -- rotate
           else let (a, b) = partition x l2 in (a, T b v2 (T r2 v r))

another tree constructor

t :: Ord a => [a] -> T a
t = foldr insert E

heap operations:

findMin (T E x _) = x
findMin (T l _ _) = findMin l

deleteMin (T E x b) = b
deleteMin (T (T E x b) y c) = T b y c
-- rotate
deleteMin (T (T a x b) y c) = T (deleteMin a) x (T b y c)

example: heapsort

-- TODO: rewrite everything and count invocations of partition
heapSort :: Ord a => [a] -> [a]
heapSort = step . t
  where
    step E = []
    step h = findMin h : step (deleteMin h)
-- show the tree at each step of the sort
root t@(T _ x _) = (x, t)
chk n = mapM_ (print . root) $ take n
      $ iterate deleteMin $ t $ reverse $ [1..n]
-- *Splay> chk 12
-- (12,(((((((((((1 2 .) 3 .) 4 .) 5 .) 6 .)
--      7 .) 8 .) 9 .) 10 .) 11 .) 12 .))
-- (11,(((((2 3 4) 5 6) 7 8) 9 10) 11 12))
-- (9,(((. 3 4) 5 (6 7 8)) 9 (10 11 12)))
-- (5,(4 5 ((6 7 8) 9 (10 11 12))))
-- (5,(. 5 ((6 7 8) 9 (10 11 12))))
-- (9,((6 7 8) 9 (10 11 12)))
-- (7,(. 7 (8 9 (10 11 12))))
-- (9,(8 9 (10 11 12)))
-- (9,(. 9 (10 11 12)))
-- (11,(10 11 12))
-- (11,(. 11 12))
-- (12,12)