> module Splay                  (  splay, join
>                               )
> where

> import BinTree                (  Pretty(..), Txt, BinTree(..)  )

> data Relation a               =  Lt a | Eq a | Gt a

> splay                         :: (a -> Ordering) -> BinTree a
>                               -> (Ordering, BinTree a)
> splay cmpTo Empty             =  (undef, Empty)
> splay cmpTo (Node l a r)      =  case adjust l a r of
>     (l', Eq a', r')           -> (_EQ, Node l' a' r')
>     (l', Lt a', r')           -> (_LT, Node l' a' r')
>     (l', Gt a', r')           -> (_GT, Node l' a' r')
>     where
>     adjust l a r              =  case cmpTo a of
>         _EQ                   -> (l, Eq a, r)
>         _LT                   -> case l of
>             Empty             -> (Empty, Lt a, r)
>             Node ll la lr     -> case cmpTo la of
>                 _EQ           -> (ll, Eq la, Node lr a r)
>                 _LT           -> case ll of
>                     Empty     -> (Empty, Lt la, Node lr a r)
>                     Node lll lla llr
>                               -> let (l', v, r') = adjust lll lla llr
>                                  in  (l', v, Node r' la (Node lr a r))
>                 _GT           -> case lr of
>                     Empty     -> (ll, Gt la, Node Empty a r)
>                     Node lrl lra lrr
>                               -> let (l', v, r') = adjust lrl lra lrr
>                                  in  (Node ll la l', v, Node r' a r)
>         _GT                   -> case r of
>             Empty             -> (l, Gt a, Empty)
>             Node rl ra rr     -> case cmpTo ra of
>                 _EQ           -> (Node l a rl, Eq ra, rr)
>                 _LT           -> case rl of
>                     Empty     -> (Node l a Empty, Lt ra, rr)
>                     Node rll rla rlr
>                               -> let (l', v, r') = adjust rll rla rlr
>                                  in  (Node l a l', v, Node r' ra rr)
>                 _GT           -> case rr of
>                     Empty     -> (Node l a rl, Gt ra, Empty)
>                     Node rrl rra rrr
>                               -> let (l', v, r') = adjust rrl rra rrr
>                                  in  (Node (Node l a rl) ra l', v, r')

> join Empty Empty                      =  Empty
> join Empty u@(Node _ _ _)             =  u
> join t@(Node _ _ _) Empty             =  t
> join t@(Node l a r) u@(Node _ _ _)    =  lrotate l a r
>     where
>     lrotate l a Empty                 =  Node l a u
>     lrotate l a (Node rl ra rr)       =  lrotate (Node l a rl) ra rr

> type Ordering         =  _CMP_TAG

> undef                 =  error "undefined"