Module Rbtrees
red-black trees. Those are modelled like the ones in
CLR90.
exception Not_Found
exception Illegal_Rotation
not visible for the outside
exception Will_Not_Happen
type color = Red | Black
type entry = int
type key = int
type (a, b) rbtree = (* 'a: key, b': elem *)
Leaf of color
| Node of (a,b) rbtree × (a ×b × color) × (a,b) rbtree
let toggle x =
match x with
(k,e, Black) ® (k,e, Red)
| (k,e, Red) ® (k,e, Black)
let rotate_r tr (b: bool) =
match tr with
Leaf c ® raise Illegal_Rotation
| Node (Leaf _, _, _) ® raise Illegal_Rotation
| Node (Node (tr_1,c_y,tr_2), c_x, tr_3) ®
if b
then Node(tr_1, toggle c_y, Node(tr_2, toggle c_x, tr_3))
else Node(tr_1, c_y, Node(tr_2, c_x, tr_3))
let rotate_l tr (b:bool) =
match tr with
Leaf c ® raise Illegal_Rotation
| Node (_,_,Leaf c) ® raise Illegal_Rotation
| Node (tr_1, c_x, Node(tr_2,c_y,tr_3)) ®
if b
then Node(Node(tr_1, toggle c_x, tr_2), toggle c_y, tr_3)
else Node(Node(tr_1, c_x, tr_2), c_y, tr_3)
let finish tr =
match tr with
| Node(Node(t1_l, (k_1, e_1, Red), t1_r),
(k_2,e_2,Red),
t3)
®
Node(Node(t1_l, (k_1, e_1, Red), t1_r),
(k_2,e_2,Black),
t3)
| Node(t1, (k_2, e_2, Red), Node(t3_l, (k_3, e_3,Red), t3_r)) (* 5' *)
®
Node(t1, (k_2, e_2, Black), Node(t3_l, (k_3, e_3,Red), t3_r))
| _ ® tr
let rec insert' tr (key, elem) = (* Insert always at the leaves *)
match tr with
Leaf c ®
Node (Leaf Black, (key, elem, Red), Leaf Black)
| Node(tr_l, (key', elem',c'), tr_r) ®
if key < key'
then
(let tr'= Node(insert' tr_l (key, elem), (key', elem', c'), tr_r)
in
match tr' with
Node (Node(t2_l, (* 1 *)
(key_2, elem_2, Red),
Node(t1_l,(key_1,elem_1,Red),t1_r)),
(key_3,elem_3,Black),
Node(t4_l,(key_4,elem_4,Red),t4_r))
®
Node (Node(t2_l,
(key_2, elem_2, Black),
Node(t1_l,(key_1,elem_1,Red),t1_r)),
(key_3,elem_3, Red),
Node(t4_l,(key_4,elem_4,Black),t4_r))
| Node (Node(Node(t1_l,(key_1,elem_1,Red),t1_r), (* 2 *)
(key_2, elem_2, Red),
t2_r),
(key_3,elem_3,Black),
Node(t4_l,(key_4,elem_4,Red),t4_r))
®
Node (Node(Node(t1_l,(key_1,elem_1,Red),t1_r),
(key_2, elem_2, Black),
t2_r),
(key_3,elem_3, Red),
Node(t4_l,(key_4,elem_4,Black),t4_r))
| Node (Node(t2_l, (* 3 *)
(key_2, elem_2, Red),
Node(t1_l,(key_1,elem_1,Red),t1_r)),
(key_3,elem_3,Black),
t4) (* t4 is black (matching): leaf or node *)
®
Node (rotate_l(Node(t2_l,
(key_2, elem_2, Red),
Node(t1_l,(key_1,elem_1,Red),t1_r))) false,
(key_3,elem_3, Black),
t4)
| Node (Node(Node(t1_l,(key_1,elem_1,Red),t1_r), (* 4 *)
(key_2, elem_2, Red),
t2_r),
(key_3,elem_3,Black),
t4) (* t4 must be black *)
®
rotate_r
(Node( Node( Node(t1_l,(key_1,elem_1,Red),t2_r),
(key_2, elem_2, Red),
t2_r),
(key_3,elem_3, Black),
t4))
true
(* we recolor! *)
| _ ® tr'
)
else (* key >=key' *)
(let tr'= Node(tr_l, (key', elem', c'), insert' tr_r (key, elem))
in
match tr' with
Node(Node(t4_l,(k4,e4,Red), t4_r), (* 1' *)
(k3,e3,Black),
Node(Node(t1_l,(k1,e1,Red),t1_r),
(k2,e2,Red),
t2_r))
®
Node(Node(t4_l,(k4,e4,Black), t4_r),
(k3,e3,Red),
Node(Node(t1_l,(k1,e1,Red),t1_r),
(k2,e2,Black),
t2_r))
| Node(Node(t4_l,(k4,e4,Red), t4_r), (* 2' *)
(k3,e3,Black),
Node(t2_l,
(k2,e2,Red),
Node(t1_l,(k1,e1,Red),t1_r)))
®
Node(Node(t4_l,(k4,e4,Black), t4_r),
(k3,e3,Red),
Node(t2_l,
(k2,e2,Black),
Node(t1_l,(k1,e1,Red),t1_r)))
| Node(t4, (* 3' *)
(k3,e3,Black),
Node(Node(t1_l,(k1,e1,Red),t1_r),
(k2,e2,Red),
t2_r))
®
Node(t4,
(k3,e3,Black),
rotate_r
(Node(Node(t1_l,(k1,e1,Red),t1_r),
(k2,e2,Red),
t2_r))
false
)
| Node(t4, (* 4' *)
(k3,e3,Black),
Node(t2_l,
(k2,e2,Red),
Node(t1_l,(k1,e1,Red),t1_r)))
®
rotate_l
(Node(t4,
(k3,e3,Black),
Node(t2_l,
(k2,e2,Red),
Node(t1_l,(k1,e1,Red),t1_r))))
true
| _ ® tr'
)
let insert tr (key, elem) =
finish (insert' tr (key, elem))
let rec search tr key =
match tr with
Leaf c ® raise Not_Found
| Node(tr_l, (key', elem', c), tr_r) ®
if (key = key') then elem'
else
if key < key'
then search tr_l key
else if key' > key
then search tr_r key
else elem' (* <= ist eine totale Ordnung *)
Delete deletes the first fitting node and gives back the the node-info, too
let rec delete' tr key =
match tr with
Leaf _ ® raise Not_Found
| Node(Leaf _, (k,e,c), Leaf _) ® (* A leaf can safely be erased *)
if key = k
then (Leaf Black, (k,e,c))
else raise Not_Found
| Node(tr_l, (k,e,c), tr_r) ® raise Will_Not_Happen
let delete tr key = tr
Pages last (re-)generated October 28, 2002 (Martin Steffen)