%.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.
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))
--- /dev/null
+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 ^ "}"
--- /dev/null
+include Tree_sig.S
--- /dev/null
+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
+
--- /dev/null
+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 ^ "}"
--- /dev/null
+include Tree_sig.S
home / code / tiger.ml.git / commitdiff
