From: Siraaj Khandkar Date: Sat, 21 Apr 2018 02:35:21 +0000 (-0400) Subject: WIP Red Black tree X-Git-Url: https://git.xandkar.net/?a=commitdiff_plain;h=88cc262a0a05de03560b35950b763f41717b79b1;p=tiger.ml.git WIP Red Black tree --- diff --git a/exercises/ch01/Makefile b/exercises/ch01/Makefile index 2912309..fa3761e 100644 --- a/exercises/ch01/Makefile +++ b/exercises/ch01/Makefile @@ -20,6 +20,18 @@ build : $(EXECUTABLES) %.cmo: %.ml %.cmi $(OCAMLC_BYTE) -c $< +tree : tree.ml tree.cmo tree_sig.cmo tree_unbalanced_vanilla.cmo tree_balanced_red_black.cmo + $(OCAMLC_BYTE) -o tree tree_sig.cmo tree_unbalanced_vanilla.cmo tree_balanced_red_black.cmo tree.cmo + +tree.cmo : tree.ml tree.cmi tree_sig.cmo tree_unbalanced_vanilla.cmo tree_balanced_red_black.cmo + $(OCAMLC_BYTE) -c $< + +tree_balanced_red_black.cmo : tree_balanced_red_black.ml tree_balanced_red_black.cmi tree_sig.cmo + ocamlc.opt -w A -warn-error A-4 -c $< + +tree_sig.cmo tree_sig.cmi: tree_sig.ml + $(OCAMLC_BYTE) -c $< + clean: rm -f $(EXECUTABLES) tree.dot # There's also tree.png, but I'm keeping it. diff --git a/exercises/ch01/okassaki_red_black_balance_code.jpeg b/exercises/ch01/okassaki_red_black_balance_code.jpeg new file mode 100644 index 0000000..38cab5a Binary files /dev/null and b/exercises/ch01/okassaki_red_black_balance_code.jpeg differ diff --git a/exercises/ch01/okassaki_red_black_balance_drawing.jpeg b/exercises/ch01/okassaki_red_black_balance_drawing.jpeg new file mode 100644 index 0000000..56af4f8 Binary files /dev/null and b/exercises/ch01/okassaki_red_black_balance_drawing.jpeg differ diff --git a/exercises/ch01/tree.ml b/exercises/ch01/tree.ml index 195a70c..04a7255 100644 --- a/exercises/ch01/tree.ml +++ b/exercises/ch01/tree.ml @@ -1,82 +1,35 @@ module Array = ArrayLabels -module List = ListLabels -module type TREE = sig - type ('k, 'v) t - - val empty : ('k, 'v) t - - val set : ('k, 'v) t -> k:'k -> v:'v -> ('k, 'v) t - - val get : ('k, 'v) t -> k:'k -> 'v option - - val member : ('k, 'v) t -> k:'k -> bool - - val to_dot : ('k, 'v) t -> k_to_string:('k -> string) -> string -end - -module BinaryTree : TREE = struct - type ('k, 'v) t = - | Node of 'k * 'v * ('k, 'v) t * ('k, 'v) t - | Leaf - - let empty = Leaf - - let rec set t ~k ~v = - match t with - | Leaf -> Node (k, v, Leaf, Leaf) - | Node (k', v', l, r) when k < k' -> Node (k', v', set l ~k ~v, r) - | Node (k', v', l, r) when k > k' -> Node (k', v', l, set r ~k ~v) - | Node (k, _, l, r) -> Node (k, v, l, r) - - let rec get t ~k = - match t with - | Leaf -> None - | Node (k', _, l, _) when k < k' -> get l ~k - | Node (k', _, _, r) when k > k' -> get r ~k - | Node (_, v, _, _) -> Some v - - let rec member t ~k = - match t with - | Leaf -> false - | Node (k', _, l, _) when k < k' -> member l ~k - | Node (k', _, _, r) when k > k' -> member r ~k - | Node _ -> true - - let to_edges t = - let rec to_edges_from k1 t = - match t with - | Leaf -> [] - | Node (k2, _, l, r) -> - (k1, k2) :: ((to_edges_from k2 l) @ (to_edges_from k2 r)) - in - match t with - | Leaf -> [] - | Node (k, _, l, r) -> (to_edges_from k l) @ (to_edges_from k r) - - let to_dot t ~k_to_string = - let (edges, _) = - List.fold_left (to_edges t) - ~init:("", "\n") - ~f:(fun (edges, sep) (k1, k2) -> - let k1, k2 = k_to_string k1, k_to_string k2 in - (Printf.sprintf "%s%s %S -> %S;\n" edges sep k1 k2, "") - ) - in - "digraph G {" ^ edges ^ "}" -end +module Tree_vanilla = Tree_unbalanced_vanilla +module Tree_redblack = Tree_balanced_red_black let () = - let tree_a = BinaryTree.empty in - let tree_a = BinaryTree.set tree_a ~k:"k1" ~v:"v1" in - let tree_a = BinaryTree.set tree_a ~k:"k2" ~v:"v2" in - assert (BinaryTree.member tree_a ~k:"k1"); - assert (BinaryTree.member tree_a ~k:"k2"); - assert (Some "v1" = BinaryTree.get tree_a ~k:"k1"); - assert (Some "v2" = BinaryTree.get tree_a ~k:"k2"); - let tree_b = + let unbalanced = Tree_vanilla.empty in + let unbalanced = Tree_vanilla.set unbalanced ~k:"k1" ~v:"v1" in + let unbalanced = Tree_vanilla.set unbalanced ~k:"k2" ~v:"v2" in + assert (Tree_vanilla.member unbalanced ~k:"k1"); + assert (Tree_vanilla.member unbalanced ~k:"k2"); + assert (Some "v1" = Tree_vanilla.get unbalanced ~k:"k1"); + assert (Some "v2" = Tree_vanilla.get unbalanced ~k:"k2"); + + let balanced = Tree_redblack.empty in + let balanced = Tree_redblack.set balanced ~k:"k1" ~v:"v1" in + let balanced = Tree_redblack.set balanced ~k:"k2" ~v:"v2" in + assert (Tree_redblack.member balanced ~k:"k1"); + assert (Tree_redblack.member balanced ~k:"k2"); + assert (Some "v1" = Tree_redblack.get balanced ~k:"k1"); + assert (Some "v2" = Tree_redblack.get balanced ~k:"k2"); + + (*let unbalanced =*) + (*Array.fold_left (Sys.argv)*) + (*~init:Tree_vanilla.empty*) + (*~f:(fun t k -> Tree_vanilla.set t ~k ~v:())*) + (*in*) + (*print_endline (Tree_vanilla.to_dot unbalanced ~k_to_string:(fun x -> x));*) + + let balanced = Array.fold_left (Sys.argv) - ~init:BinaryTree.empty - ~f:(fun t k -> BinaryTree.set t ~k ~v:()) + ~init:Tree_redblack.empty + ~f:(fun t k -> Tree_redblack.set t ~k ~v:()) in - print_endline (BinaryTree.to_dot tree_b ~k_to_string:(fun x -> x)) + print_endline (Tree_redblack.to_dot balanced ~k_to_string:(fun x -> x)) diff --git a/exercises/ch01/tree_balanced_red_black.ml b/exercises/ch01/tree_balanced_red_black.ml new file mode 100644 index 0000000..4036162 --- /dev/null +++ b/exercises/ch01/tree_balanced_red_black.ml @@ -0,0 +1,102 @@ +module List = ListLabels + +type color = R | B +type ('k, 'v) t = + | Leaf + | Node of color * ('k * 'v) * ('k, 'v) t * ('k, 'v) t + +let empty = Leaf + +let set t ~k ~v = + let balance = function + | Leaf -> assert false + (* LL *) | Node (B, x, Node (R, lx, Node (R, llx, lll, llr), lr ), r ) -> Node (R, lx , Node (B, llx, lll, llr), Node (B, x , lr , r )) + (* LR *) | Node (B, x, Node (R, lx, ll , Node (R, lrx, lrl, lrr)), r ) -> Node (R, lrx, Node (B, lx , ll , lrl), Node (B, x , lrr, r )) + (* RL *) | Node (B, x, l , Node (R, rx, Node (R, rlx, rll, rlr), rr )) -> Node (R, rlx, Node (B, x , l , rll), Node (B, rx , rlr, rr )) + (* RR *) | Node (B, x, l , Node (R, rx, rl , Node (R, rrx, rrl, rrr))) -> Node (R, rx , Node (B, x , l , rl ), Node (B, rrx, rrl, rrr)) + (* not exhaustive - reconsider *) + | node -> node + in + let rec set t k v = + match t with + (* Because we recur, we cannot at this stage know if the following Node + * with Leaf children will end-up as root (in which case it should be + * black) or as the last node before leaves (in which case it should be + * red). We begin by assuming that it is the later and at the very end, + * before returning to the caller, force the actual root node (which is + * easy to identify at that point) to be black, regardless of what it + * already is. + *) + | Leaf -> Node (R, (k, v), Leaf, Leaf) (* Maybe root or last node, so R *) + | Node (c, ((k', _) as x), l, r) when k < k' -> balance (Node (c, x, set l k v, r)) + | Node (c, ((k', _) as x), l, r) when k > k' -> balance (Node (c, x, l , set r k v)) + | Node (c, _ , l, r) -> Node (c, (k, v), l, r) + in + match set t k v with + | Leaf -> assert false (* Can we GADT this away? *) + | Node (_, (k, v), l, r) -> Node (B, (k, v), l, r) (* Root is always Black *) + +let rec get t ~k = + match t with + | Leaf -> None + | Node (_, (k', _), l, _) when k < k' -> get l ~k + | Node (_, (k', _), _, r) when k > k' -> get r ~k + | Node (_, (_ , v), _, _) -> Some v + +let rec member t ~k = + match t with + | Leaf -> false + | Node (_, (k', _), l, _) when k < k' -> member l ~k + | Node (_, (k', _), _, r) when k > k' -> member r ~k + | Node (_, (_ , _), _, _) -> true + +let to_edges t = + let rec to_edges_from node1 t = + match t with + | Leaf -> [(node1, `Leaf)] + | Node (c2, (k2, _), l, r) -> + let node2 = k2, c2 in + (node1, `Node node2) :: ((to_edges_from node2 l) @ (to_edges_from node2 r)) + in + match t with + | Leaf -> + [] + | Node (c, (k, _), l, r) -> + let node1 = k, c in + (to_edges_from node1 l) @ (to_edges_from node1 r) + +let color_to_string = function + | B -> "black" + | R -> "red" + +let to_dot t ~k_to_string = + let (dot_edges_and_nodes, _, _) = + List.fold_left + (to_edges t) + ~init:("", "\n", 0) + ~f:(fun (dot_edges_and_nodes, sep, leaves) ((k1, c1), node2_or_leaf) -> + let k1 = k_to_string k1 in + let k2, c2, leaves = + match node2_or_leaf with + | `Leaf -> + let leaves = succ leaves in + let label = Printf.sprintf "Leaf_%d" leaves in + (label, B, leaves) + | `Node (k2, c2) -> + let label = k_to_string k2 in + (label, c2, leaves) + in + let dot_edges_and_nodes = + Printf.sprintf + "%s%s %S -> %S;\n %S [color=%s,fontcolor=white,style=filled];\n %S [color=%s,fontcolor=white,style=filled];\n" + dot_edges_and_nodes + sep + k1 k2 + k1 (color_to_string c1) (* Yes, it's redundant... *) + k2 (color_to_string c2) + in + let sep = "" in + (dot_edges_and_nodes, sep, leaves) + ) + in + "digraph G {" ^ dot_edges_and_nodes ^ "}" diff --git a/exercises/ch01/tree_balanced_red_black.mli b/exercises/ch01/tree_balanced_red_black.mli new file mode 100644 index 0000000..e0e08ee --- /dev/null +++ b/exercises/ch01/tree_balanced_red_black.mli @@ -0,0 +1 @@ +include Tree_sig.S diff --git a/exercises/ch01/tree_sig.ml b/exercises/ch01/tree_sig.ml new file mode 100644 index 0000000..4133a77 --- /dev/null +++ b/exercises/ch01/tree_sig.ml @@ -0,0 +1,14 @@ +module type S = sig + type ('k, 'v) t + + val empty : ('k, 'v) t + + val set : ('k, 'v) t -> k:'k -> v:'v -> ('k, 'v) t + + val get : ('k, 'v) t -> k:'k -> 'v option + + val member : ('k, 'v) t -> k:'k -> bool + + val to_dot : ('k, 'v) t -> k_to_string:('k -> string) -> string +end + diff --git a/exercises/ch01/tree_unbalanced_vanilla.ml b/exercises/ch01/tree_unbalanced_vanilla.ml new file mode 100644 index 0000000..f73a20b --- /dev/null +++ b/exercises/ch01/tree_unbalanced_vanilla.ml @@ -0,0 +1,50 @@ +module List = ListLabels + +type ('k, 'v) t = + | Node of 'k * 'v * ('k, 'v) t * ('k, 'v) t + | Leaf + +let empty = Leaf + +let rec set t ~k ~v = + match t with + | Leaf -> Node (k, v, Leaf, Leaf) + | Node (k', v', l, r) when k < k' -> Node (k', v', set l ~k ~v, r) + | Node (k', v', l, r) when k > k' -> Node (k', v', l, set r ~k ~v) + | Node (k, _, l, r) -> Node (k, v, l, r) + +let rec get t ~k = + match t with + | Leaf -> None + | Node (k', _, l, _) when k < k' -> get l ~k + | Node (k', _, _, r) when k > k' -> get r ~k + | Node (_, v, _, _) -> Some v + +let rec member t ~k = + match t with + | Leaf -> false + | Node (k', _, l, _) when k < k' -> member l ~k + | Node (k', _, _, r) when k > k' -> member r ~k + | Node _ -> true + +let to_edges t = + let rec to_edges_from k1 t = + match t with + | Leaf -> [] + | Node (k2, _, l, r) -> + (k1, k2) :: ((to_edges_from k2 l) @ (to_edges_from k2 r)) + in + match t with + | Leaf -> [] + | Node (k, _, l, r) -> (to_edges_from k l) @ (to_edges_from k r) + +let to_dot t ~k_to_string = + let (edges, _) = + List.fold_left (to_edges t) + ~init:("", "\n") + ~f:(fun (edges, sep) (k1, k2) -> + let k1, k2 = k_to_string k1, k_to_string k2 in + (Printf.sprintf "%s%s %S -> %S;\n" edges sep k1 k2, "") + ) + in + "digraph G {" ^ edges ^ "}" diff --git a/exercises/ch01/tree_unbalanced_vanilla.mli b/exercises/ch01/tree_unbalanced_vanilla.mli new file mode 100644 index 0000000..e0e08ee --- /dev/null +++ b/exercises/ch01/tree_unbalanced_vanilla.mli @@ -0,0 +1 @@ +include Tree_sig.S