OrdMap.hs

module OrdMap(
	OrdMap,
	empty, singleton, union, unionMany, add, (//),
	-- addKeep, union_C, unionMany_C, addMany_C, add_C,
	-- intersect, delete, deleteMany, minus, 
	-- partition, filter, foldl, foldr
	toList, fromList,
	length,
	null, isSingleton,
	-- intersecting, subset
	elems, indices,
	--(!),
	lookup, lookupWithDefault --, lookupWithContinuation
	) where
import Prelude hiding (lookup,length,null)
	
-- @@ Finite mappings with ordered keys.

-- Red-Black trees.
-- Implementation based on work by Norris Boyd, Andrew W. Appel,
-- David R. Tarditi, and Stephen J. Bevan.

data Colour = Red | Black

data OrdMap a b
    = Empty
    | Node a b Colour (OrdMap a b) (OrdMap a b)

instance (Ord a, Show a, Show b) => Show (OrdMap a b) where
{-  #ifdef __HBC__
	showsType x = showString "(OrdMap " . showsType (f x) . showString " " . showsType (g x) . showString ")"
		where f :: (Ord a) => OrdMap a b -> a
		      f _ = error "OrdMap.f"
		      g :: (Ord a) => OrdMap a b -> b
		      g _ = error "OrdMap.g"
-}
-- #else
        showsPrec _ om = showString "<OrdMap>"
-- #endif

instance (Ord a, Eq b) => Eq (OrdMap a b) where
	x == y  =  toList x == toList y

rbiR :: a -> b -> OrdMap a b -> OrdMap a b -> OrdMap a b
rbiR k v (Node sk sv Red sl@(Node _ _ Red _ _) sr) (Node lk lv Red ll lr) =
    Node k v Red (Node lk lv Black ll lr) (Node sk sv Black sl sr)

rbiR k v (Node sk sv Red sl sr@(Node _ _ Red _ _)) (Node lk lv Red ll lr) =
    Node k v Red (Node lk lv Black ll lr) (Node sk sv Black sl sr)

rbiR k v (Node sk sv Red sl@(Node slk slv Red sll slr) sr) l =
    Node slk slv Black (Node k v Red l sll) (Node sk sv Red slr sr)

rbiR k v (Node sk sv Red sl sr@(Node _ _ Red _ _)) l =
    Node sk sv Black (Node k v Red l sl) sr

rbiR k v t l = Node k v Black l t

rbiL :: a -> b -> OrdMap a b -> OrdMap a b -> OrdMap a b
rbiL k v (Node lk lv Red ll lr@(Node _ _ Red _ _)) (Node rk rv Red rl rr) =
    Node k v Red (Node lk lv Black ll lr) (Node rk rv Black rl rr)

rbiL k v (Node lk lv Red ll@(Node _ _ Red _ _) lr) (Node rk rv Red rl rr) =
    Node k v Red (Node lk lv Black ll lr) (Node rk rv Black rl rr)

rbiL k v (Node lk lv Red ll lr@(Node lrk lrv Red lrl lrr)) r =
    Node lrk lrv Black (Node lk lv Red ll lrl) (Node k v Red lrr r)

rbiL k v (Node lk lv Red ll@(Node llk llv Red lll llr) lr) r =
    Node lk lv Black ll (Node k v Red lr r)

rbiL k v t r = Node k v Black t r

rbi :: (Ord a) => a -> b -> OrdMap a b -> OrdMap a b
rbi e v Empty = Node e v Red Empty Empty
rbi e v t@(Node k w Black l r) =
	if e <= k then
	    if e == k then
		Node e v Black l r
	    else
		rbiL k w (rbi e v l) r
	else
	    rbiR k w (rbi e v r) l
rbi e v t@(Node k w Red l r) =
	if e <= k then
	    if e == k then
		Node e v Red l r
	    else
		Node k w Red (rbi e v l) r
	else
	    Node k w Red l (rbi e v r)

-- Empty table.
empty :: OrdMap a b
empty = Empty

singleton :: (Ord a) => (a, b) -> OrdMap a b
singleton (k, v) = Node k v Black Empty Empty

null :: OrdMap a b -> Bool
null Empty = True
null _ = False

length :: OrdMap a b -> Int
length Empty = 0
length (Node _ _ _ l r) = 1 + length l + length r

isSingleton :: OrdMap a b -> Bool
isSingleton (Node _ _ _ Empty Empty) = True
isSingleton _ = False

elems :: OrdMap a b -> [b]
elems Empty = []
elems (Node k v _ l r) = elems l ++ v : elems r

indices :: OrdMap a b -> [a]
indices Empty = []
indices (Node k v _ l r) = indices l ++ k : indices r

union :: (Ord a) => OrdMap a b -> OrdMap a b -> OrdMap a b
union t1 t2 = union' t1 (toList t2)
union' t [] = t
union' t (xy:xys) = union' (add xy t) xys

unionMany :: (Ord a) => [OrdMap a b] -> OrdMap a b
unionMany = foldr union empty

-- Insert an element overwriting an existing one with the same key.
add :: (Ord a) => (a,  b) -> OrdMap a b -> OrdMap a b
add (e, v) t =
    case rbi e v t of
        Node k v Red l@(Node _ _ Red _ _) r -> Node k v Black l r
        Node k v Red l r@(Node _ _ Red _ _) -> Node k v Black l r
        x                                   -> x

(//) :: (Ord a) => OrdMap a b -> [(a, b)] -> OrdMap a b
t // [] = t
t // (xy:xys) = add xy t // xys

-- Look up an element.
lookup :: (Ord a) => a -> OrdMap a b -> Maybe b
lookup _ Empty = Nothing
lookup e (Node k v _ l r) =
	if e <= k then
	    if e == k then Just v
	    else lookup e l
	else lookup e r

-- Map a function over the values.
instance (Ord a) => Functor (OrdMap a) where
    --map :: (b->c) -> OrdMap a b -> OrdMap a c
    fmap f Empty = Empty
    fmap f (Node k v c l r) = Node k (f v) c (fmap f l) (fmap f r)

lookupWithDefault :: (Ord a) => OrdMap a b -> b -> a -> b
lookupWithDefault Empty d _ = d
lookupWithDefault (Node k v _ l r) d e =
	if e <= k then 
	    if e == k then v
	    else lookupWithDefault l d e
	else lookupWithDefault r d e

fromList :: (Ord a) => [(a,b)] -> OrdMap a b
fromList l = union' empty l

toList :: OrdMap a b -> [(a, b)]
toList Empty = []
toList (Node k v _ l r) = toList l ++ (k,v) : toList r