Deletion: The curse of the red-black tree. Kimball Germane and Matthew Might. Comparison of Racket and Haskell implementations.

haskell.hs

data Color = R | B | BB deriving (Show)
data Tree elt = E | EE | T Color (Tree elt) elt (Tree elt) deriving (Show)

type Set a = Tree a

empty = E

insert x s = blacken (ins s)
  where insE=TRExE
        ins (T color a y b) | x < y = balance color (ins a) y b
                            | x == y = T colorayb
                            | x > y = balance color a y (ins b)
        blacken (T R (T R a x b) y c) = T B (T R a x b) y c
        blacken (T R a x (T R b y c)) = T B a x (T R b y c)
        blackent=t

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 BB a x (T R (T R b y c) z d) = T B (T B a x b) y (T B c z d)
balance BB (T R a x (T R b y c)) z d = T B (T B a x b) y (T B c z d)
balance coloraxb=T color a x b

delete x s = del (redden s)
  where delE=E
        del (T R E y E) | x == y = E
                        | x /= y = T R E y E
        del (T B E y E) | x == y = EE
                        | x /= y = T B E y E
        del (T B (T R E y E) z E) | x < z = T B (del (T R E y E)) z E
                                  | x == z = T B E y E
                                  | x > z = T B (T R E y E) z E
        del (T c a y b) | x < y = rotate c (del a) y b
                        | x == y = let (y’,b’) = min_del b
                                  in rotate c a y’ b’
                        | x > y = rotate c a y (del b)
        redden (T B (T B a x b) y (T B c z d)) =
          T R (T B a x b) y (T B c z d)
        redden t = t
        rotate R (T BB a x b) y (T B c z d) = balance B (T R (T B a x b) y c) z d

rotate R EE y (T B c z d) = balance B (T R E y c) z d
rotate R (T B a x b) y (T BB c z d) = balance B a x (T R b y (T B c z d))
rotate R (T B a x b) y EE = balance B a x (T R b y E)
rotate B (T BB a x b) y (T B c z d) = balance BB (T R (T B a x b) y c) z d
rotate B EE y (T B c z d) = balance BB (T R E y c) z d
rotate B (T B a x b) y (T BB c z d) = balance BB a x (T R b y (T B c z d))
rotate B (T B a x b) y EE = balance BB a x (T R b y E)
rotate B (T BB a w b) x (T R (T B c y d) z e) =
  T B (balance B (T R (T B a w b) x c) y d) z e
rotate B EE x (T R (T B c y d) z e) = T B (balance B (T R E x c) y d) z e
rotate B (T R a w (T B b x c)) y (T BB d z e) =
  TBaw (balance B b x (T R c y (T B d z e)))
rotate B (T R a w (T B b x c)) y EE = T B a w (balance B b x (T R c y E))
rotate color axb=T coloraxb

min_del (T R E x E) = (x,E)
min_del (T B E x E) = (x,EE)
min_del (T B E x (T R E y E)) = (x,T B E y E)
min_del (T c a x b) = let (x’,a’) = min_del a
                      in (x’,rotate c a’ x b)
                         

racket.rkt

#lang racket

(define-match min/delete
  [(B) (error ’min/delete "empty tree")]
  [(R (B) x (B)) (values x (B))]
  [(B (B) x (B)) (values x (BB))]
  [(B (B) x (R ayb)) (values x (B ayb))]
  [(N caxb) (let-values ([(v a∗) (min/delete a)])
              (values v (rotate (N c a∗ x b))))])

(define-match balance
  [(or (B (R (R axb) y c) z d)
       (B (R a x (R byc)) z d)
       (B a x (R (R byc) z d))
       (B a x (R b y (R czd))))
   (R (B axb) y (B czd))]
  [(or (BB (R a x (R byc)) z d)
       (BB a x (R (R byc) z d)))
   (B (B axb) y (B czd))]
  [t t])

(define-match rotate
  [(R (BB? a-x-b) y (B czd))
   (balance (B (R (-B a-x-b) y c) z d))]
  [(R (B axb) y (BB? c-z-d))
   (balance (B a x (R b y (-B c-z-d))))]
  [(B (BB? a-x-b) y (B czd))
   (balance (BB (R (-B a-x-b) y c) z d))]
  [(B (B axb) y (BB? c-z-d))
   (balance (BB a x (R b y (-B c-z-d))))]
  [(B (BB? a-w-b) x (R (B cyd) z e))
   (B (balance (B (R (-B a-w-b) x c) y d)) z e)]
  [(B (R a w (B bxc)) y (BB? d-z-e))
   (B a w (balance (B b x (R c y (-B d-z-e)))))]
  [t t])

(define-match -B
  [(BB) (B)]
  [(BB axb) (B axb)])

(define (delete t v)
  (define-match del
    [(B) (B)]
    [(R (B) (== v) (B))
     (B)]
    [(B (R axb) (== v) (B))
     (B axb)]
    [(B (B) (== v) (B))
     (BB)]
    [(N caxb)
     (switch-compare
      (v x)
      [< (rotate (N c (del a v) x b))]
      [= (let-values ([(v∗ b∗) (min/delete b)])
           (rotate (N cav∗ b∗)))]
      [> (rotate (N cax (del b v)))])])
  (del (redden t)))

(define-match redden
  [(B (B? a) x (B? b))
   (R axb)]
  [t t])