content: {-|
    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
  