Commit d1ba1d8a authored by Robert Ricci's avatar Robert Ricci

Working (I think) version of bitspace capping in graph-to-tree

parent 77eeec30
...@@ -60,10 +60,12 @@ ordering-to-tree: heap.cmo graph.cmo dijkstra.cmo myset.cmo dre.cmo naming.cmo l ...@@ -60,10 +60,12 @@ ordering-to-tree: heap.cmo graph.cmo dijkstra.cmo myset.cmo dre.cmo naming.cmo l
ordering-to-tree.opt: heap.cmx graph.cmx dijkstra.cmx myset.cmx dre.cmx naming.cmx linklist.cmx ortc.cmx ordering-to-tree.ml ordering-to-tree.opt: heap.cmx graph.cmx dijkstra.cmx myset.cmx dre.cmx naming.cmx linklist.cmx ortc.cmx ordering-to-tree.ml
ocamlopt -o $@ /usr/local/lib/ocaml/str.cmxa $^ ocamlopt -o $@ /usr/local/lib/ocaml/str.cmxa $^
graph-to-tree: heap.cmo graph.cmo dijkstra.cmo myset.cmo dre.cmo ortc.cmo graph-to-tree.ml graph-to-tree: heap.cmo graph.cmo dijkstra.cmo myset.cmo dre.cmo ortc.cmo \
mintree.cmo graph-to-tree.ml
ocamlc -g -o $@ /usr/local/lib/ocaml/str.cma $^ ocamlc -g -o $@ /usr/local/lib/ocaml/str.cma $^
graph-to-tree.opt: heap.cmx graph.cmx dijkstra.cmx myset.cmx dre.cmx ortc.cmx graph-to-tree.ml graph-to-tree.opt: heap.cmx graph.cmx dijkstra.cmx myset.cmx dre.cmx ortc.cmx \
mintree.cmx graph-to-tree.ml
ocamlopt -o $@ /usr/local/lib/ocaml/str.cmxa $^ ocamlopt -o $@ /usr/local/lib/ocaml/str.cmxa $^
tree-assign: heap.cmo graph.cmo tree-assign.ml tree-assign: heap.cmo graph.cmo tree-assign.ml
......
...@@ -11,19 +11,16 @@ let argspec = ...@@ -11,19 +11,16 @@ let argspec =
Arg.parse argspec (fun x -> graphfile := Some(x)) "Usage";; Arg.parse argspec (fun x -> graphfile := Some(x)) "Usage";;
(* Tree we're constructing *) let rec tree_depth (tree : Mintree.tree_node) : int =
type tree_node = NoNode | TreeNode of (int * int * tree_node * tree_node);;
let rec tree_depth (tree : tree_node) : int =
match tree with match tree with
NoNode -> -1 Mintree.NoNode -> -1
| TreeNode(_,_,l,r) -> 1 + (max (tree_depth l) (tree_depth r)) | Mintree.TreeNode(_,_,l,r) -> 1 + (max (tree_depth l) (tree_depth r))
;; ;;
let rec tree_height (tree : tree_node) : int = let rec tree_height (tree : Mintree.tree_node) : int =
match tree with match tree with
NoNode -> -1 Mintree.NoNode -> -1
| TreeNode(_,h,_,_) -> h; | Mintree.TreeNode(_,h,_,_) -> h;
;; ;;
let debug (str : string) : unit = let debug (str : string) : unit =
...@@ -52,7 +49,7 @@ let combine_blob hops s1 s2 blob1 blob2 = ...@@ -52,7 +49,7 @@ let combine_blob hops s1 s2 blob1 blob2 =
| _ -> raise (Failure "Mismatched blobs")) | _ -> raise (Failure "Mismatched blobs"))
type 'a node_sets_entry = (Dre.nodeset * 'a * tree_node);; type 'a node_sets_entry = (Dre.nodeset * 'a * Mintree.tree_node);;
type matrix_entry = (unit -> unit);; type matrix_entry = (unit -> unit);;
type matrix = matrix_entry option array array;; type matrix = matrix_entry option array array;;
...@@ -87,7 +84,8 @@ let bins = Mintree.make total_bits;; ...@@ -87,7 +84,8 @@ let bins = Mintree.make total_bits;;
let initial_node_set (i : int) (_ : 'b) : 'a node_sets_entry option = let initial_node_set (i : int) (_ : 'b) : 'a node_sets_entry option =
debug("Setting up node set " ^ (string_of_int i)); debug("Setting up node set " ^ (string_of_int i));
let node_set = Dre.ISet.singleton i in let node_set = Dre.ISet.singleton i in
Some(node_set,blob_from_set hops node_set,TreeNode(i,0,NoNode,NoNode));; Some(node_set,blob_from_set hops node_set,
Mintree.TreeNode(i,0,Mintree.NoNode,Mintree.NoNode));;
let node_sets = Array.mapi initial_node_set hops;; let node_sets = Array.mapi initial_node_set hops;;
...@@ -191,7 +189,7 @@ let combine (node_sets : 'a node_sets) (matrix : matrix) ...@@ -191,7 +189,7 @@ let combine (node_sets : 'a node_sets) (matrix : matrix)
let s3 = Dre.ISet.union s1 s2 in let s3 = Dre.ISet.union s1 s2 in
let blob3 = combine_blob hops s1 s2 blob1 blob2 in let blob3 = combine_blob hops s1 s2 blob1 blob2 in
let d3 = (1 + max h1 h2) in let d3 = (1 + max h1 h2) in
let tree3 = TreeNode(a, d3, tree1, tree2) in let tree3 = Mintree.TreeNode(a, d3, tree1, tree2) in
remove_from_matrix matrix a b; remove_from_matrix matrix a b;
(* (*
debug "Heap: "; debug "Heap: ";
...@@ -207,9 +205,9 @@ let combine (node_sets : 'a node_sets) (matrix : matrix) ...@@ -207,9 +205,9 @@ let combine (node_sets : 'a node_sets) (matrix : matrix)
exception OutOfBits;; exception OutOfBits;;
let rec greedy_combine (node_sets : 'a node_sets) (matrix : matrix) let rec greedy_combine (node_sets : 'a node_sets) (matrix : matrix)
(hops : int array array) (heap : nodepair Heap.heap) (hops : int array array) (heap : nodepair Heap.heap)
(remaining : int) (bins: Mintree.bins_t) : tree_node = (remaining : int) (bins: Mintree.bins_t) : Mintree.tree_node =
if remaining <= 0 then begin if remaining <= 0 then begin
let rec find_tree (i : int) : tree_node = let rec find_tree (i : int) : Mintree.tree_node =
match node_sets.(i) with match node_sets.(i) with
None -> find_tree (i + 1) None -> find_tree (i + 1)
| Some(_,_,tree) -> tree in | Some(_,_,tree) -> tree in
...@@ -224,7 +222,8 @@ let rec greedy_combine (node_sets : 'a node_sets) (matrix : matrix) ...@@ -224,7 +222,8 @@ let rec greedy_combine (node_sets : 'a node_sets) (matrix : matrix)
None -> debug("X had no node_sets entry") None -> debug("X had no node_sets entry")
| Some(_,_,tree) -> ( | Some(_,_,tree) -> (
match tree with match tree with
TreeNode(_,h,_,_) -> ( Mintree.NoNode -> raise (Failure "Null Node")
| Mintree.TreeNode(_,h,_,_) -> (
debug("X had height " ^ (string_of_int h)); debug("X had height " ^ (string_of_int h));
Mintree.remove_from_bin bins h Mintree.remove_from_bin bins h
) )
...@@ -234,7 +233,8 @@ let rec greedy_combine (node_sets : 'a node_sets) (matrix : matrix) ...@@ -234,7 +233,8 @@ let rec greedy_combine (node_sets : 'a node_sets) (matrix : matrix)
None -> debug("Y had no node_sets entry") None -> debug("Y had no node_sets entry")
| Some(_,_,tree) -> ( | Some(_,_,tree) -> (
match tree with match tree with
TreeNode(_,h,_,_) -> ( Mintree.NoNode -> raise (Failure "Null Node")
| Mintree.TreeNode(_,h,_,_) -> (
debug("Y had height " ^ (string_of_int h)); debug("Y had height " ^ (string_of_int h));
Mintree.remove_from_bin bins h Mintree.remove_from_bin bins h
) )
...@@ -245,7 +245,8 @@ let rec greedy_combine (node_sets : 'a node_sets) (matrix : matrix) ...@@ -245,7 +245,8 @@ let rec greedy_combine (node_sets : 'a node_sets) (matrix : matrix)
None -> debug("X has no node_sets entry") None -> debug("X has no node_sets entry")
| Some(_,_,tree) -> ( | Some(_,_,tree) -> (
match tree with match tree with
TreeNode(_,h,_,_) -> ( Mintree.NoNode -> raise (Failure "Null Node")
| Mintree.TreeNode(_,h,_,_) -> (
debug("New x has height " ^ (string_of_int h)); debug("New x has height " ^ (string_of_int h));
Mintree.add_to_bin bins h Mintree.add_to_bin bins h
) )
...@@ -254,7 +255,7 @@ let rec greedy_combine (node_sets : 'a node_sets) (matrix : matrix) ...@@ -254,7 +255,7 @@ let rec greedy_combine (node_sets : 'a node_sets) (matrix : matrix)
let min_height = Mintree.height_of bins in let min_height = Mintree.height_of bins in
debug ("Currently uses " ^ (string_of_int min_height) ^ debug ("Currently uses " ^ (string_of_int min_height) ^
" bits (" ^ (string_of_int total_bits) ^ ") bits max"); " bits (" ^ (string_of_int total_bits) ^ ") bits max");
if min_height > total_bits then if min_height >= total_bits then
raise OutOfBits; raise OutOfBits;
greedy_combine node_sets matrix hops heap (remaining - 1) bins greedy_combine node_sets matrix hops heap (remaining - 1) bins
end end
...@@ -262,26 +263,42 @@ let rec greedy_combine (node_sets : 'a node_sets) (matrix : matrix) ...@@ -262,26 +263,42 @@ let rec greedy_combine (node_sets : 'a node_sets) (matrix : matrix)
let (heap,matrix) = initialize_heap node_sets hops bins in let (heap,matrix) = initialize_heap node_sets hops bins in
debug "Heap initialized"; debug "Heap initialized";
let root = greedy_combine node_sets matrix hops heap (size - 1) bins in let root = try greedy_combine node_sets matrix hops heap (size - 1) bins
let rec print_tree (root : tree_node) = with OutOfBits -> (
debug "Ran out of bits";
let rec make_forest index =
if index >= Array.length node_sets then
[]
else
match node_sets.(index) with
None -> make_forest (index + 1)
| Some (n) -> (match n with (_,_,tree) -> tree)
:: make_forest (index + 1)
in
let forest = make_forest 0 in
debug ("Forest has " ^ (string_of_int (List.length forest)) ^
" trees");
Mintree.min_depth_tree forest
) in
let rec print_tree (root : Mintree.tree_node) =
match root with match root with
NoNode -> () Mintree.NoNode -> ()
| TreeNode(id,heigt,left,right) -> begin | Mintree.TreeNode(id,height,left,right) -> begin
print_tree left; print_tree left;
output_string stdout ((string_of_int id) ^ "\n"); output_string stdout ((string_of_int id) ^ "\n");
print_tree right print_tree right
end end
in in
let tree_placement (howmany : int) (tree : tree_node) : (int * int32 array) = let tree_placement (howmany : int) (tree : Mintree.tree_node) : (int * int32 array) =
let locations = Array.make howmany Int32.minus_one in let locations = Array.make howmany Int32.minus_one in
let rec helper (tree : tree_node) (depth : int) (sofar : int32) : int = let rec helper (tree : Mintree.tree_node) (depth : int) (sofar : int32) : int =
(* (*
if depth >= 32 then if depth >= 32 then
raise (Failure "Tree too deep"); *) raise (Failure "Tree too deep"); *)
match tree with match tree with
NoNode -> -1 Mintree.NoNode -> -1
| TreeNode(id,height,left,right) -> | Mintree.TreeNode(id,height,left,right) ->
if left == NoNode && right == NoNode then begin if left == Mintree.NoNode && right == Mintree.NoNode then begin
(* Leaf node *) (* Leaf node *)
locations.(id) <- sofar; locations.(id) <- sofar;
depth depth
......
...@@ -3,6 +3,13 @@ ...@@ -3,6 +3,13 @@
* of trees. * of trees.
*) *)
(* Tree we're constructing *)
(* Depth, height, left, right *)
type tree_node = NoNode | TreeNode of (int * int * tree_node * tree_node);;
(* A collection of trees *)
type forest_t = tree_node list;;
(* Maximum depth of a tree *) (* Maximum depth of a tree *)
let max_depth = 32;; let max_depth = 32;;
...@@ -108,3 +115,38 @@ add_to_bin mybins 4;; ...@@ -108,3 +115,38 @@ add_to_bin mybins 4;;
add_to_bin mybins 4;; add_to_bin mybins 4;;
print_endline (string_of_int (height_of mybins)); print_endline (string_of_int (height_of mybins));
*) *)
(* Given a set of subtrees, find the minimum depth tree *)
let min_depth_tree (forest : forest_t) : tree_node =
(* Fill up a heap with the heights of the trees as they keys - smallest
* first *)
let rec init_heap (forest : forest_t) (heap : tree_node Heap.heap) : unit =
match forest with
[] -> ()
| h :: tail -> match h with
TreeNode(depth,height,left,right) -> (
let _ = Heap.insert heap height h in
init_heap tail heap
)
| NoNode -> raise (Failure "Empty node in forest")
in
let heap = Heap.make_heap NoNode in
init_heap forest heap;
while (Heap.size heap > 1) do
let (height1,tree1) = Heap.min heap in
Heap.extract_min heap;
let (height2,tree2) = Heap.min heap in
Heap.extract_min heap;
let newheight = (max height1 height2) + 1 in
(*
print_endline ("Combining h1 = " ^ (string_of_int height1) ^
" and h2 = " ^ (string_of_int height2) ^ " to get " ^ (string_of_int
newheight));*)
(* XXX Putting in a bogus ID, since it doesn't actually matter *)
let newroot = TreeNode(0,newheight,tree1,tree2) in
let _ = Heap.insert heap newheight newroot in
()
done;
let (_,root) = Heap.min heap in
root
;;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment