content: {-|
    Purely functional weight balanced trees, aka trees of bounded balance.
  
      * J. Nievergelt and E.M. Reingold, \"Binary search trees of
        bounded balance\", Proceedings of the fourth annual ACM symposium on
        Theory of computing, pp 137-142, 1972.
  
      * S. Adams, \"Implementing sets efficiently in a functional language\",
        Technical Report CSTR 92-10, University of Southampton, 1992.
        <http://groups.csail.mit.edu/mac/users/adams/BB/>
  
      * S. Adam, \"Efficient sets: a balancing act\",
        Journal of Functional Programming, Vol 3, Issue 4, pp 553-562.
  
      * Y. Hirai and K. Yamamoto,
        \"Balancing Weight-Balanced Trees\",
        Journal of Functional Programming. Vol 21, Issue 03, pp 287-307.
        <http://mew.org/~kazu/proj/weight-balanced-tree/>
  
      * M. Strake, \"Adams' Trees Revisited - Correct and Efficient Implementation\",
        TFP 2011.
        <http://fox.ucw.cz/papers/bbtree/>
  -}
  
  module Data.Set.WBTree (
    -- * Data structures
      WBTree(..)
    , Size
    , size
    -- * Creating sets
    , empty
    , singleton
    , insert
    , fromList
    -- * Converting to a list
    , toList
    -- * Membership
    , member
    -- * Deleting
    , delete
    , deleteMin
    , deleteMax
    -- * Checking
    , null
    -- * Set operations
    , union
    , intersection
    , difference
    -- * Helper functions
    , join
    , merge
    , split
    , minimum
    , maximum
    , valid
  --  , showTree
  --  , printTree
    ) where
  
  import Data.List (foldl')
  import Prelude hiding (minimum, maximum, null)
  
  ----------------------------------------------------------------
  
  type Size = Int
  data WBTree a = Leaf | Node Size (WBTree a) a (WBTree a) deriving (Show)
  
  
  instance (Eq a) => Eq (WBTree a) where
      t1 == t2 = toList t1 == toList t2
  
  size :: WBTree a -> Size
  size Leaf            = 0
  size (Node sz _ _ _) = sz
  
  ----------------------------------------------------------------
  
  {-|
  See if the set is empty.
  
  >>> Data.Set.WBTree.null empty
  True
  >>> Data.Set.WBTree.null (singleton 1)
  False
  -}
  
  null :: Eq a => WBTree a -> Bool
  null t = t == Leaf
  
  ----------------------------------------------------------------
  
  {-| Empty set.
  
  >>> size empty
  0
  -}
  
  empty :: WBTree a
  empty = Leaf
  
  {-| Singleton set.
  
  >>> size (singleton 'a')
  1
  -}
  
  singleton :: a -> WBTree a
  singleton x = Node 1 Leaf x Leaf
  
  ----------------------------------------------------------------
  
  node :: WBTree a -> a -> WBTree a -> WBTree a
  node l x r = Node (size l + size r + 1) l x r
  
  ----------------------------------------------------------------
  
  {-| Insertion. O(log N)
  
  >>> 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 -> WBTree a -> WBTree a
  insert k Leaf = singleton k
  insert k (Node sz l x r) = case compare k x of
      LT -> balanceR (insert k l) x r
      GT -> balanceL l x (insert k r)
      EQ -> Node sz l x r
  
  {-| Creating a set from a list. O(N log N)
  
  >>> empty == fromList []
  True
  >>> singleton 'a' == fromList ['a']
  True
  >>> fromList [5,3,5] == fromList [5,3]
  True
  -}
  
  fromList :: Ord a => [a] -> WBTree a
  fromList = foldl' (flip insert) empty
  
  ----------------------------------------------------------------
  
  {-| Creating a list from a set. O(N)
  
  >>> toList (fromList [5,3])
  [3,5]
  >>> toList empty
  []
  -}
  
  toList :: WBTree 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?
  
  >>> member 5 (fromList [5,3])
  True
  >>> member 1 (fromList [5,3])
  False
  -}
  
  member :: Ord a => a -> WBTree a -> Bool
  member _ Leaf = False
  member k (Node _ l x r) = case compare k x of
      LT -> member k l
      GT -> member k r
      EQ -> True
  
  ----------------------------------------------------------------
  
  balanceL :: WBTree a -> a -> WBTree a -> WBTree a
  balanceL l x r
    | isBalanced l r = node l x r
    | otherwise      = rotateL l x r
  
  balanceR :: WBTree a -> a -> WBTree a -> WBTree a
  balanceR l x r
    | isBalanced r l = node l x r
    | otherwise      = rotateR l x r
  
  rotateL :: WBTree a -> a -> WBTree a -> WBTree a
  rotateL l x r@(Node _ rl _ rr)
    | isSingle rl rr = singleL l x r
    | otherwise      = doubleL l x r
  rotateL _ _ _      = error "rotateL"
  
  rotateR :: WBTree a -> a -> WBTree a -> WBTree a
  rotateR l@(Node _ ll _ lr) x r
    | isSingle lr ll = singleR l x r
    | otherwise      = doubleR l x r
  rotateR _ _ _      = error "rotateR"
  
  singleL :: WBTree a -> a -> WBTree a -> WBTree a
  singleL l x (Node _ rl rx rr) = node (node l x rl) rx rr
  singleL _ _ _                 = error "singleL"
  
  singleR :: WBTree a -> a -> WBTree a -> WBTree a
  singleR (Node _ ll lx lr) x r = node ll lx (node lr x r)
  singleR _ _ _                 = error "singleR"
  
  doubleL :: WBTree a -> a -> WBTree a -> WBTree a
  doubleL l x (Node _ (Node _ rll rlx rlr) rx rr) = node (node l x rll) rlx (node rlr rx rr)
  doubleL _ _ _                                   = error "doubleL"
  
  doubleR :: WBTree a -> a -> WBTree a -> WBTree a
  doubleR (Node _ ll lx (Node _ lrl lrx lrr)) x r = node (node ll lx lrl) lrx (node lrr x r)
  doubleR _ _ _                                   = error "doubleR"
  
  ----------------------------------------------------------------
  
  {-| Deleting the minimum element. O(log N)
  
  >>> deleteMin (fromList [5,3,7]) == fromList [5,7]
  True
  >>> deleteMin empty == empty
  True
  -}
  
  deleteMin :: WBTree a -> WBTree a
  deleteMin (Node _ Leaf _ r) = r
  deleteMin (Node _ l x r)    = balanceL (deleteMin l) x r
  deleteMin Leaf              = Leaf
  
  {-| Deleting the maximum
  
  >>> deleteMax (fromList [(5,"a"), (3,"b"), (7,"c")]) == fromList [(3,"b"), (5,"a")]
  True
  >>> deleteMax empty == empty
  True
  -}
  
  deleteMax :: WBTree a -> WBTree a
  deleteMax (Node _ l _ Leaf) = l
  deleteMax (Node _ l x r)    = balanceR l x (deleteMax r)
  deleteMax Leaf              = Leaf
  
  ----------------------------------------------------------------
  
  {-| Deleting this element from a set. O(log N)
  
  >>> 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 -> WBTree a -> WBTree a
  delete k t = case t of
      Leaf -> Leaf
      Node _ l x r -> case compare k x of
          LT -> balanceL (delete k l) x r
          GT -> balanceR l x (delete k r)
          EQ -> glue l r
  
  ----------------------------------------------------------------
  
  {-| Checking validity of a set.
  -}
  
  valid :: Ord a => WBTree a -> Bool
  valid t = balanced t && ordered t && validsize t
  
  balanced :: WBTree a -> Bool
  balanced Leaf           = True
  balanced (Node _ l _ r) = isBalanced l r && isBalanced r l
                         && balanced l     && balanced r
  
  ordered :: Ord a => WBTree a -> Bool
  ordered t = bounded (const True) (const True) t
    where
      bounded lo hi t' = case t' of
          Leaf         -> True
          Node _ l x r -> lo x && hi x && bounded lo (<x) l && bounded (>x) hi r
  
  validsize :: WBTree a -> Bool
  validsize t = realsize t == Just (size t)
    where
      realsize t' = case t' of
          Leaf            -> Just 0
          Node s l _ r -> case (realsize l,realsize r) of
              (Just n,Just m)  | n+m+1 == s -> Just s
              _                             -> Nothing
  
  ----------------------------------------------------------------
  
  {-| Joining two sets with an element. O(log N)
  
      Each element of the left set must be less than the element.
      Each element of the right set must be greater than the element.
  -}
  
  join :: Ord a => WBTree a -> a -> WBTree a -> WBTree a
  join Leaf x r   = insert x r
  join l x Leaf   = insert x l
  join l@(Node _ ll lx lr) x r@(Node _ rl rx rr)
    | bal1 && bal2 = node l x r
    | bal1         = balanceL ll lx (join lr x r)
    | otherwise    = balanceR (join l x rl) rx rr
    where
      bal1 = isBalanced l r
      bal2 = isBalanced r l
  
  {-| Merging two sets. O(log N)
  
      Each element of the left set must be less than each element of
      the right set.
  -}
  
  merge :: WBTree a -> WBTree a -> WBTree a
  merge Leaf r   = r
  merge l Leaf   = l
  merge l@(Node _ ll lx lr) r@(Node _ rl rx rr)
    | bal1 && bal2 = glue l r
    | bal1         = balanceL ll lx (merge lr r)
    | otherwise    = balanceR (merge l rl) rx rr
    where
      bal1 = isBalanced l r
      bal2 = isBalanced r l
  
  glue :: WBTree a -> WBTree a -> WBTree a
  glue Leaf r = r
  glue l Leaf = l
  glue l r
    | size l > size r = balanceL (deleteMax l) (maximum l) r
    | otherwise       = balanceR l (minimum r) (deleteMin r)
  
  {-| Splitting a set. O(log N)
  
  >>> split 2 (fromList [5,3]) == (empty, fromList [3,5])
  True
  >>> split 3 (fromList [5,3]) == (empty, singleton 5)
  True
  >>> split 4 (fromList [5,3]) == (singleton 3, singleton 5)
  True
  >>> split 5 (fromList [5,3]) == (singleton 3, empty)
  True
  >>> split 6 (fromList [5,3]) == (fromList [3,5], empty)
  True
  -}
  
  split :: Ord a => a -> WBTree a -> (WBTree a, WBTree a)
  split _ Leaf           = (Leaf,Leaf)
  split k (Node _ l x r) = case compare k x of
      LT -> let (lt,gt) = split k l in (lt,join gt x r)
      GT -> let (lt,gt) = split k r in (join l x lt,gt)
      EQ -> (l,r)
  
  ----------------------------------------------------------------
  
  {-| Finding the minimum element. O(log N)
  
  >>> minimum (fromList [3,5,1])
  1
  >>> minimum empty
  *** Exception: minimum
  -}
  
  minimum :: WBTree a -> a
  minimum (Node _ Leaf x _) = x
  minimum (Node _ l _ _)    = minimum l
  minimum _                 = error "minimum"
  
  {-| Finding the maximum element. O(log N)
  
  >>> maximum (fromList [3,5,1])
  5
  >>> maximum empty
  *** Exception: maximum
  -}
  
  maximum :: WBTree a -> a
  maximum (Node _ _ x Leaf) = x
  maximum (Node _ _ _ r)    = maximum r
  maximum _                 = error "maximum"
  
  ----------------------------------------------------------------
  
  {-| Creating a union set from two sets. O(N + M)
  
  >>> union (fromList [5,3]) (fromList [5,7]) == fromList [3,5,7]
  True
  -}
  
  union :: Ord a => WBTree a -> WBTree a -> WBTree a
  union t1 Leaf = t1
  union Leaf t2 = t2
  union t1 (Node _ l x r) = join (union l' l) x (union r' r)
    where
      (l',r') = split x t1
  
  {-| Creating a intersection set from sets. O(N + N)
  
  >>> intersection (fromList [5,3]) (fromList [5,7]) == singleton 5
  True
  -}
  
  intersection :: Ord a => WBTree a -> WBTree a -> WBTree a
  intersection Leaf _ = Leaf
  intersection _ Leaf = Leaf
  intersection t1 (Node _ l x r)
    | member x t1 = join (intersection l' l) x (intersection r' r)
    | otherwise   = merge (intersection l' l) (intersection r' r)
    where
      (l',r') = split x t1
  
  {-| Creating a difference set from sets. O(N + N)
  
  >>> difference (fromList [5,3]) (fromList [5,7]) == singleton 3
  True
  -}
  
  difference :: Ord a => WBTree a -> WBTree a -> WBTree a
  difference Leaf _  = Leaf
  difference t1 Leaf = t1
  difference t1 (Node _ l x r) = merge (difference l' l) (difference r' r)
    where
      (l',r') = split x t1
  
  ----------------------------------------------------------------
  
  delta :: Int
  delta = 3
  
  gamma :: Int
  gamma = 2
  
  isBalanced :: WBTree a -> WBTree a -> Bool
  isBalanced a b = delta * (size a + 1) >= (size b + 1)
  
  isSingle :: WBTree a -> WBTree a -> Bool
  isSingle a b = (size a + 1) < gamma * (size b + 1)
  
  {- Adams's variant
  isBalanced :: WBTree a -> WBTree a -> Bool
  isBalanced a b = x + y <= 1 || delta * x >= y
    where x = size a
          y = size b
  
  isSingle :: WBTree a -> WBTree a -> Bool
  isSingle a b = size a < gamma * size b
  -}
  