{- 3rd Version, 2nd typed version -} {- note that the type variable b is never used anywhere, only passed on. -} type Tr t a b = (t a b,a,t a b) data Red t a b = C (t a b) | R (Tr t a b) data Black a b = E | B(Tr (Red Black) a [b]) instance Show a => Show (Black a b) where showsPrec _ E = ('E':) showsPrec _ (B(a,x,b)) = ("B("++) . showRed a . (","++) . shows x . (","++) . showRed b . (")"++) showRed (C x) = shows x showRed (R(a,x,b)) = ("R("++) . shows a . (","++) . shows x . (","++) . shows b . (")"++) type RR a b = Red (Red Black) a b inc :: Black a b -> Black a [b] inc = tickB {- tickB is the identity, but it allows us to replace that bogus type variable -} tickB :: Black a b -> Black a c tickB E = E tickB (B(a,x,b)) = B(tickR a,x,tickR b) tickR :: Red Black a b -> Red Black a c tickR (C t) = C(tickB t) tickR (R(a,x,b)) = R(tickB a,x,tickB b) newtype Tree a = forall b . ENC (Black a b) instance Show a => Show (Tree a) where show (ENC t) = show t empty :: Tree a empty = ENC E insert :: Ord a => a -> Tree a -> Tree a insert x (ENC t) = ENC(blacken (insB x t)) blacken :: Red Black a b -> Black a b blacken (C u) = u blacken (R(a,x,b)) = B(C(inc a),x,C(inc b)) insB :: Ord a => a -> Black a b -> Red Black a b insB x E = R(E,x,E) insB x t@(B(a,y,b)) | xy = balanceR a y (insR x b) | otherwise = C t insR :: Ord a => a -> Red Black a b -> RR a b insR x (C t) = C(insB x t) insR x t@(R(a,y,b)) | xy = R(C a,y,insB x b) | otherwise = C t --balanceL :: RR a [b] -> a -> Red Black a [b] -> Red Black a b balanceL (R(R(a,x,b),y,c)) z d = R(B(C a,x,C b),y,B(c,z,d)) balanceL (R(a,x,R(b,y,c))) z d = R(B(a,x,C b),y,B(C c,z,d)) balanceL (R(C a,x,C b)) z d = C(B(R(a,x,b),z,d)) balanceL (C a) x b = C(B(a,x,b)) --balanceR :: Red Black a [b] -> a -> RR a [b] -> Red Black a b balanceR a x (R(R(b,y,c),z,d)) = R(B(a,x,C b),y,B(C c,z,d)) balanceR a x (R(b,y,R(c,z,d))) = R(B(a,x,b),y,B(C c,z,C d)) balanceR a x (R(C b,y,C c)) = C(B(a,x,R(b,y,c))) balanceR a x (C b) = C(B(a,x,b)) delete :: Ord a => a -> Tree a -> Tree a delete x (ENC t) = case delB x t of R p -> ENC (B p) C(R(a,x,b)) -> ENC(B(C a,x,C b)) C(C q) -> ENC q delB :: Ord a => a -> Black a b -> RR a [b] delB x E = C(C E) delB x (B(a,y,b)) | xy = delfromR b | otherwise = appendR a b where delfromL(R t) = R(delT x t,y,b) delfromL(C E) = R(C E,y,b) delfromL(C t) = balL (delB x t) y b delfromR(R t) = R(a,y,delT x t) delfromR(C E) = R(a,y,C E) delfromR(C t) = balR a y (delB x t) delT :: Ord a => a -> Tr Black a b -> Red Black a b delT x t@(a,y,b) | xy = delfromR b | otherwise = append a b where delfromL (B _) = balLeB (delB x a) y b delfromL _ = R t delfromR (B _) = balRiB a y (delB x b) delfromR _ = R t --balLeB :: RR a [b] -> a -> Black a b -> Red Black a b balLeB bl x (B y) = balance bl x (R y) --balRiB :: Black a b -> a -> RR a [b] -> Red Black a b balRiB (B y) x t = balance (R y) x t --balL :: RR a [b] -> a -> Red Black a b -> RR a b balL (R a) y c = R(C(B a),y,c) balL (C t) x (R(B(a,y,b),z,c)) = R(C(B(t,x,a)),y,balLeB (C b) z c) balL b x (C t) = C (balLeB b x t) --balR :: Red Black a b -> a -> RR a [b] -> RR a b balR a x (R b) = R(a,x,C(B b)) balR (R(a,x,B(b,y,c))) z (C d) = R(balRiB a x (C b),y,C(B(c,z,d))) balR (C t) x b = C (balRiB t x b) balance :: RR a [b] -> a -> RR a [b] -> Red Black a b balance (R a) y (R b) = R(B a,y,B b) balance (C a) x b = balanceR a x b balance a x (C b) = balanceL a x b append :: Black a b -> Black a b -> Red Black a b append (B(a,x,b)) (B(c,y,d)) = threeformB a x (appendR b c) y d append _ _ = C E threeformB :: Red Black a [b] -> a -> RR a [b] -> a -> Red Black a [b] -> Red Black a b threeformB a x (R(b,y,c)) z d = R(B(a,x,b),y,B(c,z,d)) threeformB a x (C b) y c = balLeB (C a) x (B(b,y,c)) appendR :: Red Black a b -> Red Black a b -> RR a b appendR (C x) (C y) = C(append x y) appendR (C t) (R(a,x,b)) = R(append t a,x,C b) appendR (R(a,x,b)) (C t) = R(C a,x,append b t) appendR (R(a,x,b))(R(c,y,d)) = threeformR a x (append b c) y d threeformR:: Black a b -> a -> Red Black a b -> a -> Black a b -> RR a b threeformR a x (R(b,y,c)) z d = R(R(a,x,b),y,R(c,z,d)) threeformR a x (C b) y c = R(R(a,x,b),y,C c)