OrdSet.hs

module OrdSet (
	OrdSet,
	empty, singleton, union, unionMany, add, addMany,
	-- intersect, delete, deleteMany, minus, 
	-- map, partition, filter, foldl, foldr,
	toList, fromList,
	length, 
	null, isSingleton, 
	-- intersecting, isSubsetOf, 
	elem
	-- replaceMaybe, substitute
	) where

--@@ Sets of ordered items.

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

data Colour = Red | Black deriving (Eq)

data OrdSet a
    = Empty
    | Node a Colour (OrdSet a) (OrdSet a)

instance (Eq a) => Eq (OrdSet a) where -- different trees may represent equal sets (XX ?)
    s1 == s2 = toList s1 == toList s2

instance (Ord a, Show a) => Show (OrdSet a) where
	showsPrec p x = showString "OrdSet:" . showsPrec p (toList x)
	showsType x = showString "(OrdSet " . showsType (f x) . showString ")"
		where f :: (Ord a) => OrdSet a -> a
		      f _ = error "OrdSet.f"

rbiR :: a -> OrdSet a -> OrdSet a -> OrdSet a
rbiR k (Node sk Red sl@(Node _ ed _ _) sr) (Node lk Red ll lr) =
    Node k Red (Node lk Black ll lr) (Node sk Black sl sr)

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

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

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

rbiR k t l = Node k Black l t

rbiL :: a -> OrdSet a -> OrdSet a -> OrdSet a
rbiL k (Node lk Red ll lr@(Node _ Red _ _)) (Node rk Red rl rr) =
    Node k Red (Node lk Black ll lr) (Node rk Black rl rr)

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

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

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

rbiL k t r = Node k Black t r

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

-- Empty table.
empty :: OrdSet a
empty = Empty

singleton :: a -> OrdSet a
singleton k = Node k Black Empty Empty

-- XXX awful!
union :: (Ord a) => OrdSet a -> OrdSet a -> OrdSet a
union t1 t2 =
	f t2 (toList' t1 [])
	where f t [] = t
	      f t (x:xs) =
		case add x t of	-- just to force evaluation to avoid space leak
		Empty -> error "union"
		t' -> f t' xs

unionMany :: (Ord a) => [OrdSet a] -> OrdSet a
unionMany ts = foldr union empty ts

add :: (Ord a) => a -> OrdSet a -> OrdSet a
add e t =
    case rbi e t of
        Node k Red l@(Node _ Red _ _) r -> Node k Black l r
        Node k Red l r@(Node _ Red _ _) -> Node k Black l r
        x                               -> x

addMany :: (Ord a) => [a] -> OrdSet a -> OrdSet a
addMany is s = foldr add s is

-- Look up an element.
elem :: (Ord a) => a -> OrdSet a -> Bool
elem _ Empty = False
elem e (Node k _ l r) =
	if e <= k then
	    e == k || elem e l
	else elem e r

fromList :: (Ord a) => [a] -> OrdSet a
fromList l = foldr add Empty l

toList t = toList' t []
toList' Empty xs = xs
toList' (Node k _ l r) xs = toList' l (k : toList' r xs)

null Empty = True
null _ = False

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

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