Module Rbtrees2
module RBFun(Key:ORDERED) (Elem:TYPE) =
struct
exception Not_Found
type color = Red | Black
type key = Key.t
type elem = Elem.t
type (a, b) rbtree =
Leaf of color | Node of (a,b) rbtree × (a ×b × color) × (a,b) rbtree
type dict = (key, elem) rbtree (* schoener waere: 'a dict = (key, 'a) rbtree *)
let empty = Leaf Black
let balance tr = match tr with
| Node(Node(Node(ta,(k1,e1,Red),tb),(k2,e2,Red),tc),(k3,e3,Black), td)
® Node(Node(ta,(k1,e1,Black),tb),(k2,e2,Red),Node(tc,(k3,e3,Black),td))
| Node(Node(ta,(k1,e1,Red), Node(tb,(k2,e2,Red),tc)), (k3,e3,Black), td)
® Node(Node(ta,(k1,e1,Black),tb),(k2,e2,Red),Node(tc,(k3,e3,Black),td))
| Node(ta,(k1,e1,Black),Node(tb,(k2,e2,Red),Node(tc,(k3,e3,Red),td)))
® Node(Node(ta,(k1,e1,Black),tb),(k2,e2,Red),Node(tc,(k3,e3,Black),td))
| Node(ta,(k1,e1,Black),Node(Node(tb,(k2,e2,Red),tc),(k3,e3,Red),td))
® Node(Node(ta,(k1,e1,Black),tb),(k2,e2,Red),Node(tc,(k3,e3,Black),td))
| t ® t
let insert tr (key, elem) =
let rec insert_h tr =
match tr with
Leaf c ® Node(Leaf Black, (key, elem, Red), Leaf Black)
| Node(tr_l,(key',elem',c'),tr_r) ®
if (Key.lt (key, key'))
then balance (Node( (insert_h tr_l), (key',elem',c'), tr_r ))
else balance (Node( tr_l , (key',elem',c'), (insert_h tr_r)))
in
let Node(l,(k,e,_), r) = insert_h tr
in Node(l,(k,e,Black), r) (* Wurzel immer schwarz *)
let rec search tr key =
match tr with
Leaf c ® (raise Not_Found)
| Node(tr_l, (key',elem', c'), tr_r) ®
if (Key.lt(key, key')) then search tr_l key
else if (Key.gt(key, key')) then search tr_r key
else elem' (* < ist eine totale Ordnung *)
let fixup_r t ok =
if ok then (t, ok)
else
match t with
Node(Node(t1,(k,e,Red),t2),n, t3) ®
(Node(Node(t1,(k,e,Black),t2),n, t3), true)
| Node(t1,(k1,e1,c1),Node(t2,(k2,e2,Black),t3)) ®
(balance (Node(Node(t1,(k1,e1,Red),t2),(k2,e2,Black),t3)),
(c1 = Red))
| Node(t1,
(k1,e1,Black),
Node(Node(t2,(k2,e2,Black),t3),
(k3,e3,Red),
Node(t4,(k4,e4,Black),t5)))
®
(Node(balance(Node(t1,(k1,e1,Black),Node(t2,(k2,e2,Red),t3))),
(k3,e3,Black),
Node(t4,(k4,e4,Black),t5)),
true)
| Node(_,(_,_,Red), Node(_,(_,_,Red),_)) ® raise (Failure "Cannot happen 1")
| _ ® raise (Failure "cannot happen 2")
let fixup_l t ok =
if ok then (t, ok)
else
match t with
Node(t1, n, Node(t2,(k,e,Red),t3)) ® (* rechts R => einfach auf B *)
(Node(t1, n, Node(t2,(k,e,Black),t3)), true)
| Node(Node(t1,(k,e,Black),t2),(k2,e2,c2),t3) ®
(balance(Node(t1,(k,e,Black),Node(t2,(k2,e2,Red), t3))), (c2=Red))
| Node(Node(Node(t1,(k1,e1,Black),t2),
(k2,e2,Red),
Node(t3,(k3,e3,Black),t4)),
(k4,e4,Black),
t5) ®
(Node(Node(t1,(k1,e1,Black),t2),
(k2,e2,Black), (* to make it stop *)
(balance (Node(Node(t3,(k3,e3,Red),t4),
(k4,e4,Black),
t5 )))),
true)
| Node(Node(_,(_,_,Red),_),(_,_,Red), _) ® raise (Failure "cannot happen 3")
| _ ® raise (Failure "cannot happen 4")
let rec delete_succ tr =
match tr with
Leaf _ ® raise (Not_Found)
| Node(Leaf _,n,tr_r) ® (tr_r, n)
| Node(tr_l,n,tr_r) ®
match (delete_succ tr_l) with
(tr_l', (k,e,Red)) ® (Node(tr_l', n, tr_r), (k,e,Red))
| (tr_l', (k,e,Black)) ®
let (t',b) = (fixup_r (Node(tr_l', n, tr_r)) false)
in
(if b
then (t', (k,e,Red))
else (t', (k,e,Black)))
let rec delete_h tr key =
match tr with
Leaf _ ® raise (Not_Found)
| Node(Leaf _, (k,e,c), Leaf _) ®
if key = k
then let ok = (if (c = Red) then true else false) in ((Leaf Black), ok)
else raise (Not_Found)
| Node(tr_l,(k,e,c), tr_r) ®
if key < k
then match (delete_h tr_l key) with
(tr_l', ok) ® (fixup_r (Node(tr_l',(k,e,c),tr_r)) ok)
else if key > k
then match (delete_h tr_r key) with
(tr_r', ok) ® (fixup_l (Node(tr_l,(k,e,c),tr_r')) ok)
else (* Treffer *)
match (tr_l, tr_r) with (* beide koennen nicht mehr Blaetter sein *)
(Leaf _, _) ® (tr_r, (if c = Red then true else false))
| (_,Leaf _) ® (tr_l, (if c = Red then true else false))
| _ ®
match ((delete_succ tr_r),c) with
((tr_r',(k',e',Black)),Black) ®
(fixup_l (Node(tr_l,(k',e',Black),tr_r')) false)
| ((tr_r',(k',e',Black)),Red) ®
(fixup_l (Node(tr_l,(k',e',Red),tr_r')) false)
(* must be set to red! *)
| ((tr_r',(k',e', Red)),Black) ®
(Node(tr_l,(k',e',Black),tr_r'), true)
| ((tr_r',(k',e', Red)),Red) ®
(Node(tr_l,(k',e',Red),tr_r'), true)
let blacken_root t =
match t with
Leaf _ ® Leaf Black (* Blatt sollte sowieso schwarz sein *)
| Node(t1,(k,e,_),t2) ® Node(t1,(k,e,Black),t2)
let delete t key =
let (t', _) = (delete_h t key)
in blacken_root t'
------------------------------------------------------
let string_of_color c =
match c with
Red ® "R"
| Black ® "B"
let string_of_node n =
match n with
(k,e,c) ®
"(" ^ (string_of_int k) ^ "," ^ (string_of_int e) ^ "," ^ (string_of_color c) ^ ")"
let rec string_of_tree tr =
match tr with
Leaf Red ® "r"
| Leaf Black ® "b"
| Node (tl, n, tr) ®
"["^
(string_of_node n)^" "^
(string_of_tree tl)^" "^
(string_of_tree tr)^"]"
let rec string_of_inordertree tr =
match tr with
Leaf Red ® "r"
| Leaf Black ® "b"
| Node (tl, n, tr) ®
(string_of_inordertree tl)^""^
(string_of_node n)^""^
(string_of_inordertree tr)
let rec sort_ok tr =
match tr with
Leaf _ ® true
| Node(Leaf _, (k,_,_), Leaf _ ) ® true
| Node(Node(_,(k1,_,_),_) as t1, (k2,_,_), Leaf _) ®
(k1£k2) & (sort_ok t1);
| Node(Leaf _, (k2,_,_), (Node(_,(k3,e,_),_) as t3)) ®
(k2£ k3) & (sort_ok t3)
| Node((Node(_, (k1,_,_), _)) as t1,
(k2,_,_), (Node(_,(k3,e,_),_) as t3)) ®
((k1 £ k2) & (k2 £ k3) & (sort_ok t1) & (sort_ok t3))
let rec red_ok tr =
match tr with
Leaf _ ® true
| Node(((Leaf _) as t_l), (_,_,_), ((Leaf _) as t_r)) ®
red_ok(t_l) & red_ok(t_r)
| Node(((Node(_,_,_) as t_l),
(_,_,Black),
((Node(_,_,_)) as t_r))) ® (red_ok t_l) & (red_ok t_r)
| Node(_, (_,_,Red), Node(_,(_,_,Red),_)) ® false
| Node(Node(_,(_,_,Red),_), (_,_,Red), _) ® false
| Node(t_l, _, t_r) ® (red_ok t_l) & (red_ok t_r)
let rec depth_rbtree tr =
match tr with
Leaf _ ® 0
| Node(t_l, _, t_r) ® (max (depth_rbtree t_r) (depth_rbtree t_l)) + 1
let black_ok t =
let rec black_h tr =
match tr with
Leaf Black ® 0
| Leaf Red ® raise (Failure ("Black error"))
| Node(t1,(_,_,Black), t2) ®
(match ((black_h t1), (black_h t2))
with (h1, h2) ®
if (h1 = h2)
then h1 + 1
else raise (Failure ("Black error")))
| Node(t1,(_,_,Red), t2) ®
(match ((black_h t1), (black_h t2)) with
(h1, h2) ®
if (h1 = h2)
then h1
else raise (Failure ("Black error")))
in
match t with
Leaf Black ® true
| Leaf Red ® false
| t ®
try let h =(black_h t) in true
with (Failure s) ® false
let print_rbtinfo tr =
(if (red_ok tr)
then print_string("Red-OK, ")
else print_string("Red: FEHLER, ");
if (black_ok tr)
then print_string("Black-OK, ")
else print_string("Black: FEHLER, ");
if (sort_ok tr)
then print_string("Sort ok, ")
else print_string("Sort: FEHLER, ");
print_string("Tiefe = ");
print_int (depth_rbtree tr);
print_string(": ");
print_endline(string_of_tree tr))
let print_dict d = print_endline("")
end
January 31, 2002