import "Prelude" // Version 1, 'untyped' data Color = R | B deriving instance Show Color data RB a = E | T Color (RB a) a (RB a) rbToList :: RB a -> [a] rbToList E = [] rbToList (T _ l a r) = rbToList l + [a] + rbToList r deriving instance (Show a) => Show (RB a) // Insertion and membership test as by Okasaki insert :: Ord a => a -> RB a -> RB a insert x s = (match ins s with T _ a z b -> T B a z b) where ins E = T R E x E ins s = match s with T B a y b -> if xy then balance a y (ins b) else s T R a y b -> if xy then T R a y (ins b) else s member :: Ord a => a -> RB a -> Boolean member x E = False member x (T _ a y b) | xy = member x b | otherwise = True // balance: first equation is new, to make it work with a weaker invariant balance :: RB a -> a -> RB a -> RB a balance (T R a x b) y (T R c z d) = T R (T B a x b) y (T B c z d) balance (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 (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 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 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 a x b = T B a x b // deletion a la SMK delete :: Ord a => a -> RB a -> RB a delete x t = (match del t with T _ a y b -> T B a y b _ -> E) where del E = E del (T _ a y b) | xy = delformRight a y b | otherwise = app a b delformLeft a y b= match a with T B _ _ _ -> balleft (del a) y b _ -> T R (del a) y b delformRight a y b = match b with T B _ _ _ -> balright a y (del b) _ -> T R a y (del b) balleft :: RB a -> a -> RB a -> RB a balleft (T R a x b) y c = T R (T B a x b) y c balleft bl x (T B a y b) = balance bl x (T R a y b) balleft bl x (T R (T B a y b) z c) = T R (T B bl x a) y (balance b z (sub1 c)) balright :: RB a -> a -> RB a -> RB a balright a x (T R b y c) = T R a x (T B b y c) balright (T B a x b) y bl = balance (T R a x b) y bl balright (T R a x (T B b y c)) z bl = T R (balance (sub1 a) x b) y (T B c z bl) sub1 :: RB a -> RB a sub1 (T B a x b) = T R a x b sub1 _ = fail "invariance violation" app :: RB a -> RB a -> RB a app E x = x app x E = x app (T R a x b) (T R c y d) = match app b c with T R b' z c' -> T R(T R a x b') z (T R c' y d) bc -> T R a x (T R bc y d) app (T B a x b) (T B c y d) = match app b c with T R b' z c' -> T R(T B a x b') z (T B c' y d) bc -> balleft a x (T B bc y d) app a (T R b x c) = T R (app a b) x c app (T R a x b) c = T R a x (app b c) testList = [4,6,2,7,4,7,2,5] main = rbToList (foldl (flip insert) E testList) -- [2, 4, 5, 6, 7]