modified: October 3, 2018

hey you! you should check out “Purely Functional Data Structures”, by Okasaki!

# chapter 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)``````