Skip to content

Instantly share code, notes, and snippets.

@lojic
Created October 15, 2015 14:07
Show Gist options
  • Save lojic/3ad54617c8215ea1f7fa to your computer and use it in GitHub Desktop.
Save lojic/3ad54617c8215ea1f7fa to your computer and use it in GitHub Desktop.
Deletion: The curse of the red-black tree. Kimball Germane and Matthew Might. Comparison of Racket and Haskell implementations.
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)
#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])
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment