(* Binary search tree, each node has value and two children.
*
* For any node with value x, all the values in the left
* subtree are smaller than x, and all those in the right
* subtree are larger than x (using built-in < as comparator).
*)
type 'a tree = TNode of 'a * 'a tree * 'a tree | TLeaf
let rec contains x = function
TLeaf -> false
| TNode (y, l, r) ->
if x=y then true else if x < y then contains x l else contains x r
let rec add x = function
TLeaf -> TNode (x, TLeaf, TLeaf) (* When get to leaf, put new node there *)
| TNode (y, l, r) as t -> (* Recursively search for value *)
if x=y then t
else if x > y then TNode (y, l, add x r)
else (* x < y *) TNode (y, add x l, r)
let rec depth = function
TLeaf -> 0
| TNode(_, a, b) -> 1+max (depth a) (depth b)
let rec tree_of_list =
function
[] -> TLeaf
| x :: l ->
add x (tree_of_list l)
(* fold_inorder f acc t folds the function f over the tree t,
* going left subtree, current value, right subtree
*)
let rec fold_inorder f acc t =
match t with
TLeaf -> acc
| TNode(v,l,r) ->
let acc = fold_inorder f acc l in
let acc = f acc v in
fold_inorder f acc r
(* Check that a binary search tree is ordered: for a node
* with value x the left subtree has values < x and the
* right subtree has values > x *)
(* Returns the minimum value in t, max_int if t is empty
*)
let findmin_int t =
let f acc v =
if vacc then v else acc
in fold_inorder f min_int t
(* Check that:
1. Maximum of the left subtree is less than the current value
2. Minimum of the right subtree is greater than the current value
3. Left subtree is a valid BST
4. Right subtree is a valid BST
Note: We implicitly require uniqueness of values
Note: Empty subtrees always satisfy requirements 1 and 2
*)
let rec repOk_int t =
match t with
TLeaf -> true
| TNode(v,l,r) ->
let (lmax,rmin) = (findmax_int l, findmin_int r) in
lmax < v && v < rmin && repOk_int(l) && repOk_int(r)
let t0 = tree_of_list[3; 5];;
let t1 = tree_of_list [3; 9; 5; 7; 11];;
let t2 = tree_of_list [3; 5; 7; 9; 11];;
let t3 = tree_of_list [1;2;3;4;5;6;7;8;9;10];;
repOk_int t0;;
repOk_int t1;;
repOk_int t2;;
repOk_int t3;;
contains 5 t1;;
contains 6 t1;;
depth t3;;
(* General repOk for any ordered type not just ints *)
(* Returns Some(v), where v is the minimum value in t
If t is empty, returns None
*)
let findmin_tree t =
let f acc v =
match acc with
None -> Some(v)
| Some(x) -> if v Some(v)
| Some(x) -> if v>x then Some(v) else acc
in fold_inorder f None t
(* "Option less than"
* Returns true if either xo or yo is None
* Otherwise returns the result of comparing the values inside
*)
let olt xo yo =
match (xo,yo) with
None,_ -> true
| _,None -> true
| Some(x),Some(y) -> x < y
(* Check that:
1. Maximum of the left subtree is less than the current value
2. Minimum of the right subtree is greater than the current value
3. Left subtree is a valid BST
4. Right subtree is a valid BST
Note: We implicitly require uniqueness of values
Note: Empty subtrees always satisfy requirements 1 and 2
*)
let rec repOk t =
match t with
TLeaf -> true
| TNode(v,l,r) ->
let (lmax,rmin) = (findmax_tree l, findmin_tree r) in
(olt lmax (Some(v))) && (olt (Some(v)) rmin) && repOk(l) && repOk(r)
let ta = tree_of_list["c"; "e"];;
let tb = tree_of_list ["c"; "i"; "e"; "g"; "k"];;
let tc = tree_of_list ["c"; "e"; "g"; "i"; "k"];;
let td = tree_of_list ["a";"b";"c";"d";"e";"f";"g";"h";"i";"j"];;
repOk ta;;
repOk tb;;
repOk tc;;
repOk td;;
(* Red-Black tree. Binary search tree with properties:
* 1. Nodes are colored either red or black.
* 2. The root is black
* 3. Every leaf is black.
* 4. The children of every red node are black.
* 5. Every path from a node to a descendant leaf has the same
* number of black nodes as every other path.
*
* Longest path from root to leaf can be at most 2x longer than
* shortest path because at most every other node can be red (no
* red node with red parents) and same number of black nodes on
* each path, thus search always O(log n).
*)
type color = Red | Black
type 'a rbtree = Node of color * 'a * 'a rbtree * 'a rbtree | Leaf
let rec mem x = function
Leaf -> false
| Node (_, y, left, right) ->
x = y || (x < y && mem x left) || (x > y && mem x right)
(* Repair violations of the invariant that a red node should have no
* red children. Make this the responsibility of the grandparent of
* the red node having the red parent. There are four cases each of
* which results in a red node with two black children (which may in
* turn violate the constraint above it in the tree. *)
let balance = function
Black, z, Node (Red, y, Node (Red, x, a, b), c), d
| Black, z, Node (Red, x, a, Node (Red, y, b, c)), d
| Black, x, a, Node (Red, z, Node (Red, y, b, c), d)
| Black, x, a, Node (Red, y, b, Node (Red, z, c, d)) ->
Node (Red, y, Node (Black, x, a, b), Node (Black, z, c, d))
| a, b, c, d ->
Node (a, b, c, d)
let insert x s =
(* same as for basic binary search tree except 3 things:
* 1. initially replace a leaf with a red node with two leaves as
* children, 2. balance result of each recursive call (because
* inserting red node may have violated red has no red children
* invariant), 3. force root to be black
*
* Note considerably simpler than imperative version of insert, which
* has left and right rotations in addition to operation similar to
* balance's grandparent update. *)
let rec ins = function
Leaf -> Node (Red, x, Leaf, Leaf)
| Node (color, y, a, b) as s ->
if x < y then balance (color, y, ins a, b)
else if x > y then balance (color, y, a, ins b)
else s
in
match ins s with
Node (_, y, a, b) ->
Node (Black, y, a, b)
| Leaf -> (* guaranteed to be nonempty *)
raise (Failure "RBT insert failed with ins returning leaf")
let rec rbt_of_list = function
[] -> Leaf
| x :: l ->
insert x (rbt_of_list l);;
let rec height = function
Leaf -> 0
| Node(_, _, a, b) -> 1+max (height a) (height b)
(* Computes number of blacks along every path from root to leaf
* in RBT, and if invariant that this value is equal for all paths
* is violated then returns -1 *)
let rec path_num_blacks = function
Leaf -> 1
| Node(Black, _, a, b) ->
let ba = path_num_blacks a
and bb = path_num_blacks b in
if ba <> bb || ba = -1 || bb = -1
then -1
else 1+ba
| Node(Red, _, a, b) ->
let ba = path_num_blacks a
and bb = path_num_blacks b in
if ba <> bb || ba = -1 || bb = -1
then -1
else ba
let root_black = function
Leaf
| Node (Black, _, _, _) -> true
| _ -> false
let rec red_black_children = function
Node (Red, _, Node (Red, _, _, _), _)
| Node (Red, _, _, Node (Red, _, _, _)) -> false
| Leaf -> true
| Node (_, _, a, b) -> red_black_children a && red_black_children b
let rec fold_rbt f acc t =
match t with
Leaf -> acc
| Node(c,v,l,r) ->
let acc = fold_rbt f acc l in
let acc = f acc v in
fold_rbt f acc r
let findmin_rbt t =
let f acc v =
match acc with
None -> Some(v)
| Some(x) -> if v Some(v)
| Some(x) -> if v>x then Some(v) else acc
in fold_rbt f None t
let rec ordered t =
match t with
Leaf -> true
| Node(c,v,l,r) ->
let (lmax,rmin) = (findmax_rbt l, findmin_rbt r) in
(olt lmax (Some(v))) && (olt (Some(v)) rmin) && ordered(l) && ordered(r)
let repOK t =
ordered t && root_black t && red_black_children t
&& path_num_blacks t > -1
let r0 = rbt_of_list [3;5]
let r1 = rbt_of_list [3; 9; 5; 7; 11];;
let r2 = rbt_of_list [3; 5; 7; 9; 11];;
let r3 = rbt_of_list [1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16;17;18;19;20];;
let ra = rbt_of_list ["a"; "c"; "e"; "g"; "j"];;
repOK r0;;
repOK r1;;
repOK r2;;
repOK r3;;
repOK ra;;
mem 5 r1;;
mem 6 r1;;
height r1;;
height r2;;
height r3;;
path_num_blacks r3;;