fitspec-0.4.3: bench/AVLTree.hs

module AVLTree
  (
  -- | * External API
    empty
  , insert
  , remove
  , find
  , preOrder
  , inOrder
  , postOrder
  , flatten
  , height
  , nElem
  , isEmpty
  , fromList

  , leaf
  , (//)
  , (\\)
  , (-/)
  , (\-)

  -- | * Internal API
  , Tree(..)
  , node
  , bf
  , v
  , l
  , r
  , rotatell
  , rotaterr
  , rotatelr
  , rotaterl
  , balance
  , same
  , removeRoot
  , removeGreatest
  )
where

-- | Tree definition
data Tree a = Empty |
              Node Int (Tree a) a (Tree a)

-- | Smart node constructor that infers height from given subtrees
node :: Tree a -> a -> Tree a -> Tree a
node lst x rst = Node (max (height lst) (height rst) + 1) lst x rst

-- | Smart node constructor for leafs
leaf :: a -> Tree a
leaf x = node empty x empty

empty :: Tree a
empty = Empty

-- | Left infix tree constructor
(//) :: Tree a -> a -> (Tree a -> Tree a)
(//) = node
infix 6 //

-- | Left infix tree constructor (leaf value)
(-/) :: a -> a -> (Tree a -> Tree a)
x -/ y = node (leaf x) y
infix 6 -/

-- | Right infix tree constructor
(\\) :: (Tree a -> Tree a) -> Tree a -> Tree a
(\\) = ($)
infix 5 \\

-- | Right infix tree constructor (leaf value)
(\-) :: (Tree a -> Tree a) -> a -> Tree a
ctx \- x = ctx (leaf x)
infix 5 \-


-- | Shows tree in format (1-/2\-3)//4\\(empty//5\-7)
instance (Show a) => Show (Tree a) where
  showsPrec _ Empty                = showString "empty"
  showsPrec d (Node _ Empty x Empty) = showParen (d>9) $ showString "leaf " . showsPrec 10 x
  showsPrec d (Node _ lst   x   rst) = showParen (d>4) $ left . showsPrec 7 x . right
    where left  | isLeaf lst  = showsPrec 7 (v lst) . showString "-/"
                | otherwise   = showsPrec 6 lst . showString "//"
          right | isLeaf rst  = showString "\\-" . showsPrec 7 (v rst)
                | otherwise   = showString "\\\\" . showsPrec 6 rst

-- | Two trees are equal if they hold the same elements.  To check for equality also on the structure of the tree, use "same"
instance (Eq a) => Eq (Tree a) where
  t == u  =  flatten t == flatten u

instance (Ord a) => Ord (Tree a) where
  t `compare` u  =  flatten t `compare` flatten u

-- | The function should map values keeping ordering, otherwise you'll get a
-- problematic AVL.  The resulting AVL can only be manipulated by 'insert' and
-- 'delete' if it follows the 'Invariants.ordered'.
instance Functor Tree where
  fmap _ Empty              = Empty
  fmap f (Node h lst x rst) = Node h (fmap f lst) (f x) (fmap f rst)


-- | Two trees are **same** if their *values* and *structure* is the same.
-- Every **same** pair of 'Tree's is '==', not every '==' pair of 'Tree's is
-- **same**
infix 4 `same`
same :: Eq a => Tree a -> Tree a -> Bool
Empty                `same` Empty = True
(Node _ tlst x trst) `same` (Node _ ulst y urst) =  x == y && tlst `same` ulst && trst `same` urst
_                    `same` _ = False


insert :: Ord a => a -> Tree a -> Tree a
insert x Empty = node Empty x Empty
insert x t@(Node _ lt y gt) = balance u
  where u = case x `compare` y of
              EQ -> t
              LT -> node (insert x lt) y gt
              GT -> node lt y (insert x gt)


remove :: Ord a => a -> Tree a -> Tree a
remove _ Empty            = Empty -- no-op
remove x t@(Node _ lst y rst) = balance $
  case x `compare` y of
    EQ -> removeRoot t
    LT -> remove x lst
    GT -> remove x rst


removeRoot :: Tree a -> Tree a
removeRoot Empty                = Empty
removeRoot (Node _ Empty _ Empty) = Empty
removeRoot (Node _ lst   _ Empty) = lst
removeRoot (Node _ Empty _ rst)   = rst
removeRoot (Node _ lst   _ rst)   = balance (node nlst y rst)
  where
    (y, nlst) = removeGreatest lst


removeGreatest :: Tree a -> (a, Tree a)
removeGreatest Empty                  = errorEmptyTree "removeGreatest"
removeGreatest (Node _ lst   x Empty) = (x, lst)
removeGreatest (Node _ lst   x rst)   = (y, balance (node lst x nrst))
  where
    (y, nrst) = removeGreatest rst


find :: Ord a => a -> Tree a -> Maybe a
find _ Empty = Nothing
find x (Node _ lt y gt) =
  case x `compare` y of
    EQ -> Just y
    LT -> find x lt
    GT -> find x gt


preOrder  :: Tree a -> [a]
preOrder  Empty             =  []
preOrder  (Node _ lst x rst)  =  [x] ++ preOrder lst ++ preOrder rst

inOrder   :: Tree a -> [a]
inOrder   Empty             =  []
inOrder   (Node _ lst x rst)  =  inOrder lst ++ [x] ++ inOrder rst

postOrder :: Tree a -> [a]
postOrder Empty             =  []
postOrder (Node _ lst x rst)  =  postOrder lst ++ postOrder rst ++ [x]

-- | Alias for inOrder
flatten :: Tree a -> [a]
flatten = inOrder

fromList :: Ord a => [a] -> Tree a
fromList = foldr insert empty


-- | Height of a Tree
height :: Tree a -> Int
height Empty          = -1
height (Node h _ _ _) = h

-- | Number of values stored in the tree.  Note: this is slow, as it actually
-- evaluates the whole "spine" of the tree.
nElem :: Tree a -> Int
nElem Empty  = 0
nElem (Node _ lt _ gt) = nElem lt + nElem gt + 1

isEmpty :: Tree a -> Bool
isEmpty Empty = True
isEmpty _     = False

isLeaf :: Tree a -> Bool
isLeaf (Node _ Empty _ Empty) = True
isLeaf _                      = False

-- | Balancing factor of a Tree
bf :: Tree a -> Int
bf Empty          = 0
bf (Node _ lt _ gt) = height lt - height gt

-- | Value of a node (root)
v :: Tree a -> a
v (Node _ _ x _) = x
v Empty = errorEmptyTree "v"

-- | Left subtree
l :: Tree a -> Tree a
l (Node _ lst _ _) = lst
l Empty = errorEmptyTree "l"

-- | Right subtree
r :: Tree a -> Tree a
r (Node _ _ _ rst) = rst
r Empty = errorEmptyTree "r"

rotatell :: Tree a -> Tree a
rotatell (Node _ (Node _ llst y lrst) x rst) = node llst y (node lrst x rst)
rotatell _ = errorEmptySubtree "rotatell"

rotaterr :: Tree a -> Tree a
rotaterr (Node _ lst x (Node _ rlst y rrst)) = node (node lst x rlst) y rrst
rotaterr _ = errorEmptySubtree "rotaterr"

rotatelr :: Tree a -> Tree a
rotatelr (Node _ lst x rst) = rotatell (node (rotaterr lst) x rst)
rotatelr _ = errorEmptySubtree "rotatelr"

rotaterl :: Tree a -> Tree a
rotaterl (Node _ lst x rst) = rotaterr (node lst x (rotatell rst))
rotaterl _ = errorEmptySubtree "rotaterl"

balance :: Tree a -> Tree a
balance t | bf t > 1   =  if bf (l t) == (-1)
                            then rotatelr t
                            else rotatell t
          | bf t < -1  =  if bf (r t) == 1
                            then rotaterl t
                            else rotaterr t
          | otherwise  =  t


errorEmptyTree :: String -> a
errorEmptyTree    fun = err fun "empty tree (trying to balance non-AVL tree?)"

errorEmptySubtree :: String -> a
errorEmptySubtree fun = err fun "empty subtree (trying to balance non-AVL tree?)"

err :: String -> String -> a
err fun msg = error ("AVLTree.Internals." ++ fun ++ ": " ++ msg)