mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-05-14 13:42:50 -06:00
65 lines
1.8 KiB
Haskell
65 lines
1.8 KiB
Haskell
----------------------------------------------------------------------
|
|
-- |
|
|
-- Module : RedBlack
|
|
-- Maintainer : Markus Forsberg
|
|
-- Stability : Stable
|
|
-- Portability : Haskell 98
|
|
--
|
|
-- > CVS $Date: 2005/04/21 16:22:07 $
|
|
-- > CVS $Author: bringert $
|
|
-- > CVS $Revision: 1.6 $
|
|
--
|
|
-- Modified version of Osanaki's implementation.
|
|
-----------------------------------------------------------------------------
|
|
|
|
module GF.Data.RedBlack (
|
|
emptyTree,
|
|
isEmpty,
|
|
Tree,
|
|
lookupTree,
|
|
insertTree,
|
|
flatten
|
|
) where
|
|
|
|
data Color = R | B
|
|
deriving (Show,Read)
|
|
|
|
data Tree key el = E | T Color (Tree key el) (key,el) (Tree key el)
|
|
deriving (Show,Read)
|
|
|
|
balance :: Color -> Tree a b -> (a,b) -> Tree a b -> Tree a b
|
|
balance B (T R (T R a x b) y c) z d = T R (T B a x b) y (T B c z d)
|
|
balance B (T R a x (T R b y c)) z d = T R (T B a x b) y (T B c z d)
|
|
balance B a x (T R (T R b y c) z d) = T R (T B a x b) y (T B c z d)
|
|
balance B a x (T R b y (T R c z d)) = T R (T B a x b) y (T B c z d)
|
|
balance color a x b = T color a x b
|
|
|
|
emptyTree :: Tree key el
|
|
emptyTree = E
|
|
|
|
isEmpty :: Tree key el -> Bool
|
|
isEmpty (E) = True
|
|
isEmpty _ = False
|
|
|
|
lookupTree :: Ord a => a -> Tree a b -> Maybe b
|
|
lookupTree _ E = Nothing
|
|
lookupTree x (T _ a (y,z) b)
|
|
| x < y = lookupTree x a
|
|
| x > y = lookupTree x b
|
|
| otherwise = return z
|
|
|
|
insertTree :: Ord a => (a,b) -> Tree a b -> Tree a b
|
|
insertTree (key,el) tree = T B a y b
|
|
where
|
|
T _ a y b = ins tree
|
|
ins E = T R E (key,el) E
|
|
ins (T color a y@(key',el') b)
|
|
| key < key' = balance color (ins a) y b
|
|
| key > key' = balance color a y (ins b)
|
|
| otherwise = T color a (key',el) b
|
|
|
|
flatten :: Tree a b -> [(a,b)]
|
|
flatten E = []
|
|
flatten (T _ left (key,e) right)
|
|
= (flatten left) ++ ((key,e):(flatten right))
|