From: Siraaj Khandkar <siraaj@khandkar.net>
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