Commit eb7fccfe authored by Robert Ricci's avatar Robert Ricci

Belated checkin - checking in all ocaml code used for the July 2005

ipassign paper.
parent 5bfbe150
......@@ -80,13 +80,16 @@ let run_dijkstra (graph : ('a, 'b) Graph.t) (node : ('a, 'b) Graph.node)
;;
type ('a,'b) internal_first_hop = INoHop | INoHopYet | INodeHop of ('a,'b) Graph.node;;
type ('a,'b) first_hop = NoHop | NodeHop of ('a,'b) Graph.node;;
let string_of_fh (fh : (int, 'b) first_hop) : string =
(* type ('a,'b) first_hop = NoHop | NodeHop of ('a,'b) Graph.node;; *)
let string_of_fh (fh : int) : string =
(*
match fh with
NoHop -> "NoHop"
| NodeHop(n) -> string_of_int n.Graph.node_contents
| NodeHop(n) -> string_of_int n.Graph.node_contents*)
string_of_int fh
;;
(* XXX - there has got to be a better way to do this, I'm sure *)
(*
let fh_equal (a : ('a, 'b) first_hop) (b : ('a, 'b) first_hop) : bool =
match a with
NoHop ->
......@@ -96,13 +99,14 @@ let fh_equal (a : ('a, 'b) first_hop) (b : ('a, 'b) first_hop) : bool =
NoHop -> false
| NodeHop(y) -> x.Graph.node_contents == y.Graph.node_contents)
;;
*)
exception HopInternalError;;
let get_first_hops (graph : ('a, 'b) Graph.t)
(pred : ('a, 'b) Graph.node array)
(root : ('a, 'b) Graph.node) : ('a, 'b) first_hop array =
(root : ('a, 'b) Graph.node) : 'a array =
let hops = Array.make (Array.length pred) INoHopYet in
let out_hops = Array.make (Array.length pred) NoHop in
let out_hops = Array.make (Array.length pred) (-1) in
hops.(root.Graph.node_contents) <- INoHop;
let rec hop_helper (node : ('a, 'b) Graph.node) : ('a, 'b) internal_first_hop =
match hops.(node.Graph.node_contents) with
......@@ -124,8 +128,8 @@ let get_first_hops (graph : ('a, 'b) Graph.t)
if i >= Array.length hops then () else
begin
(match hops.(i) with
INoHop -> out_hops.(i) <- NodeHop(Graph.find_node graph i) (* NoHop *)
| INodeHop(h) -> out_hops.(i) <- NodeHop(h)
INoHop -> out_hops.(i) <- i
| INodeHop(h) -> out_hops.(i) <- h.Graph.node_contents
| INoHopYet -> raise HopInternalError);
copy_hops (i+1)
end
......@@ -136,8 +140,8 @@ let get_first_hops (graph : ('a, 'b) Graph.t)
out_hops
;;
let rec get_all_first_hops (g : ('a, 'b) Graph.t) =
let hops = Array.make_matrix (Graph.count_nodes g) (Graph.count_nodes g) NoHop in
let rec get_all_first_hops (g : ('a, 'b) Graph.t) : 'a array array =
let hops = Array.make_matrix (Graph.count_nodes g) (Graph.count_nodes g) (-1) in
let fill_array (base : unit) (node : (int, 'a) Graph.node) : unit =
let node_id = node.Graph.node_contents in
match (run_dijkstra g node) with (_,pred) ->
......@@ -162,16 +166,16 @@ let get_all_first_hops (graph : ('a, 'b) Graph.t)
all_hops
;;
*)
let score_ordering_transitions (hops : ('a,'b) first_hop array array)
let score_ordering_transitions (hops : 'a array array)
(ordering : int array) : float =
let size = Array.length hops in
let score = ref 0.0 in
for i = 0 to (size - 1) do
let current_color = ref NoHop in
let current_color = ref (-1) in
for j = 0 to (size - 1) do
let a = ordering.(i) in
let b = ordering.(j) in
if not (fh_equal !current_color hops.(a).(b)) then begin
if not (!current_color = hops.(a).(b)) then begin
score := !score +. 1.0;
current_color := hops.(a).(b)
end
......@@ -179,3 +183,26 @@ let score_ordering_transitions (hops : ('a,'b) first_hop array array)
done;
!score
;;
(* Read in one of Jon's first hop files *)
let read_fh_file (filename : string) (size : int) : int array array =
let hops = Array.make_matrix size size ~-1 in
let channel = open_in filename in
let rec get_hops (row : int) : unit =
try
let line = input_line channel in
let parts = Str.split (Str.regexp " +") line in
let rec fill_columns (col : int) (l : 'a list) =
match l with
[] -> if col < size then raise (Failure "col not long enough")
| x :: xs -> (hops.(row).(col) <- (int_of_string x); fill_columns (col + 1) xs)
in
fill_columns 0 parts;
get_hops (row + 1)
with
End_of_file -> if row < size then raise (Failure "not enough rows")
in
get_hops 0;
(* Array.iter (fun x -> Array.iter (fun y -> print_endline (string_of_int y)) x) hops; *)
hops
;;
......@@ -2,7 +2,10 @@
* Functions for computing DRE
*)
let pairwise_dre (hops : ('a, 'b) Dijkstra.first_hop array array)
module ISet = Set.Make(struct type t = int let compare = compare end);;
type nodeset = ISet.t;;
let pairwise_dre (hops : 'a array array)
(i : int) (j : int) (samples : int option) : float =
let num_equiv = ref 0 in
let samples_taken = ref 0 in
......@@ -14,7 +17,7 @@ let pairwise_dre (hops : ('a, 'b) Dijkstra.first_hop array array)
None -> k
| Some(x) -> Random.int (((Array.length hops) - 1)) in
(*if (w != i && w != j) then*) begin
if Dijkstra.fh_equal hops.(w).(i) hops.(w).(j) then
if hops.(w).(i) = hops.(w).(j) then
num_equiv := !num_equiv + 1;
samples_taken := !samples_taken + 1
end
......@@ -24,8 +27,7 @@ let pairwise_dre (hops : ('a, 'b) Dijkstra.first_hop array array)
;;
(* let compute_dre (graph : ('a, 'b) Graph.t) : float array array = *)
let compute_dre ?(samples=None)
(hops : ('a, 'b) Dijkstra.first_hop array array) : float array array =
let compute_dre ?(samples=None) (hops : 'a array array) : float array array =
(* Initialize the array of results *)
let n = Array.length hops in
let dre_matrix = Array.make_matrix n n 42.0 in
......@@ -91,3 +93,87 @@ let score_ordering (matrix : float array array) (ordering : int array)
(* print_endline ("Arrived at score " ^ (string_of_float !score)); *)
!score
;;
(* Not a great place to put this *)
type blob = ISet.t;;
(*
* Find the RES set for two nodes
*)
let pairwise_res (hops : 'a array array) (i : int) (j : int)
: nodeset =
let rec helper (k : int) : nodeset =
if k < 0 then
ISet.empty
else
if hops.(k).(i) = hops.(k).(j) then
ISet.add k (helper (k - 1))
else
helper (k - 1)
in
helper ((Array.length hops) - 1)
;;
(*
* Find the RES set for a set of nodes
*)
let setwise_res (hops : 'a array array) (s : nodeset)
: nodeset =
(* Chose a representative node from the set to compare first hops with *)
let representative = ISet.choose s in
let rec eval_node (k : int) : nodeset =
if k < 0 then
ISet.empty
else
(*
let all_hops_equal (node : int) (accum : bool) : bool =
(* TODO Could make this faster by not using fold, so that we can
* short-circuit *)
accum && (hops.(k).(node) = hops.(k).(representative)) in
if ISet.fold all_hops_equal s true then
*)
if ISet.for_all (fun node -> hops.(k).(node) =
hops.(k).(representative)) s then
(* Add this node to the set we're creating *)
ISet.add k (eval_node (k - 1))
else
(* Nope, just check the next node *)
eval_node (k - 1)
in
eval_node ((Array.length hops) - 1)
;;
(*
* Merge the RES sets for two sets of nodes
*)
let merge_res (hops : 'a array array)
(s1 : nodeset) (s2 : nodeset) (res_s1 : nodeset) (res_s2 : nodeset)
: nodeset =
(* TODO - This could be made faster by intersecting s1 and s2 first, then
* only looking at the first hop table for the intersection *)
(*
let res_s1s2 = pairwise_res hops (ISet.choose s1) (ISet.choose s2) in
ISet.inter res_s1 (ISet.inter res_s2 res_s1s2)
*)
(*
let res_inter = ISet.inter res_s1 res_s2 in
ISet.fold () res_inter ISet.empty
*)
(* For some reason I can't fathom, this is slower than setwise_res
let r1 = ISet.choose s1 in
let r2 = ISet.choose s2 in
let res_inter = ISet.inter res_s1 res_s2 in
ISet.fold (fun x sofar -> if hops.(x).(r1) = hops.(x).(r2) then ISet.add x sofar
else sofar) res_inter ISet.empty
*)
setwise_res hops (ISet.union s1 s2)
;;
(*
* Score a potential combination - bigger is better
*)
let score_res (res_s : nodeset) : int =
ISet.cardinal res_s
;;
(*
* Command-line args
*)
let use_ortc = ref false;;
let graphfile = ref None;;
let argspec =
[("-o",
Arg.Set(use_ortc),
"Use the ORTC metric (RES default)")];;
Arg.parse argspec (fun x -> graphfile := Some(x)) "Usage";;
(* Tree we're constructing *)
type tree_node = NoNode | TreeNode of (int * tree_node * tree_node);;
let rec tree_depth (tree : tree_node) : int =
match tree with
NoNode -> 0
| TreeNode(_,l,r) -> 1 + (max (tree_depth l) (tree_depth r))
;;
let debug (str : string) : unit =
(* print_endline str; *)
()
;;
type blob = RESblob of Dre.blob | ORTCblob of Ortc.blob;;
let blob_from_set hops nodes =
if !use_ortc then ORTCblob(Ortc.initial_metric hops nodes)
else RESblob(Dre.setwise_res hops nodes);;
let score_blob blob =
match blob with
ORTCblob(x) -> Ortc.get_metric x
| RESblob(x) -> Dre.score_res x;;
let combine_blob hops s1 s2 blob1 blob2 =
match blob1 with
ORTCblob(x) ->
(match blob2 with ORTCblob(y) -> ORTCblob(Ortc.combine_metric hops s1 s2 x y)
| _ -> raise (Failure "Mismatched blobs"))
| RESblob(x) ->
(match blob2 with RESblob(y) -> RESblob(Dre.merge_res hops s1 s2 x y)
| _ -> raise (Failure "Mismatched blobs"))
type 'a node_sets_entry = (Dre.nodeset * 'a * tree_node);;
type matrix_entry = (unit -> unit);;
type matrix = matrix_entry option array array;;
type 'a node_sets = 'a node_sets_entry option array;;
type nodepair = (int * int);;
let do_nothing () : unit =
raise (Failure "do_nothing called")
;;
let graph = match !graphfile with
Some(x) -> Graph.read_subgraph_file x
(* | None -> raise (Failure "No graph file given");; *)
| None -> Graph.read_subgraph_file "-"
(*
debug ("Graph size " ^ (string_of_int (List.length graph.Graph.nodes)));;
debug ("Edges " ^ (string_of_int (List.length graph.Graph.edges)));;
*)
let hops = Dijkstra.get_all_first_hops graph;;
let size = Array.length hops;;
let estimated_routes = ref (size * (size - 1));;
(* let heap = Heap.make_heap (-1,-1);; *)
(* XXX - Cut down size *)
(* let (matrix : matrix) = Array.make_matrix size size None;; *)
let initial_node_set (i : int) (_ : 'b) : 'a node_sets_entry option =
debug("Setting up node set " ^ (string_of_int i));
let node_set = Dre.ISet.singleton i in
Some(node_set,blob_from_set hops node_set,TreeNode(i,NoNode,NoNode));;
let node_sets = Array.mapi initial_node_set hops;;
let consider_combining (node_sets : 'a node_sets) (matrix : matrix)
(hops : int array array) (heap : nodepair Heap.heap)
(a : int) (b : int) : unit =
if a == b then raise (Failure "Tried to combine a node with itself");
let (s1,blob1,_) = match node_sets.(a) with
Some(x) -> x
| None -> raise (Failure "Bad a") in
let (s2,blob2,_) = match node_sets.(b) with
Some(x) -> x
| None -> raise (Failure "Bad b") in
(*
let (s1,res1,tree1) = a_entry in
let (s2,res2,tree2) = b_entry in
*)
if a == b then raise (Failure "Tried to combine a node with itself");
(* let s3 = Dre.ISet.union s1 s2 in *)
let blob3 = combine_blob hops s1 s2 blob1 blob2 in
let score = (0 - score_blob blob3) in
debug ("Adding " ^ (string_of_int score) ^ " (" ^ (string_of_int a) ^ "," ^
(string_of_int b) ^ ")");
let remove_func = Heap.insert_remove heap score (a,b) in
matrix.(a).(b) <- Some(remove_func)
;;
let initialize_heap (node_sets : 'a node_sets) (hops : int array array)
: (nodepair Heap.heap * matrix) =
let heap = Heap.make_heap (-1,-1) in
let (matrix : matrix) = Array.make_matrix size size None in
for i = 0 to size - 1 do
for j = i + 1 to size - 1 do
(*
let i_entry = match node_sets.(i) with
None -> raise (Failure "Bad node set entry")
| Some(x) -> x in
let j_entry = match node_sets.(j) with
None -> raise (Failure "Bad node set entry")
| Some(x) -> x in
*)
(* consider_combining i j i_entry j_entry *)
consider_combining node_sets matrix hops heap i j
done
done;
(heap, matrix)
;;
let remove_from_matrix (matrix : matrix) (a : int) (b : int) : unit =
for j = 0 to size - 1 do
match matrix.(a).(j) with
None -> ()
| Some(func) -> (debug ("Removing (1) " ^ (string_of_int a) ^ "," ^
(string_of_int j)); func(); matrix.(a).(j) <- None);
match matrix.(b).(j) with
None -> ()
| Some(func) -> (debug ("Removing (2) " ^ (string_of_int b) ^ "," ^
(string_of_int j)); func(); matrix.(b).(j) <- None)
done;
for i = 0 to size - 1 do
match matrix.(i).(b) with
None -> ()
| Some(func) -> (debug ("Removing (3) " ^ (string_of_int i) ^ "," ^
(string_of_int b));func(); matrix.(i).(b) <- None);
match matrix.(i).(a) with
None -> ()
| Some(func) -> (debug ("Removing (4) " ^ (string_of_int i) ^ "," ^
(string_of_int a));func(); matrix.(i).(a) <- None)
done;
;;
let remove_from_sets (node_sets : 'a node_sets) (a : int) (b : int) : unit =
node_sets.(a) <- None;
node_sets.(b) <- None
;;
let combine_with_all (node_sets : 'a node_sets) (matrix : matrix)
(hops : int array array) (heap : nodepair Heap.heap) (a : int) : unit =
let combine_with (b : int) : unit =
let (x,y) = if a < b then (a,b) else (b,a) in
consider_combining node_sets matrix hops heap x y
in
for i = 0 to a - 1 do
match node_sets.(i) with
None -> () (* Ignore nodes we've nuked *)
| Some(_) -> combine_with i
done;
for j = a + 1 to size - 1 do
match node_sets.(j) with
None -> () (* Ignore nodes we've nuked *)
| Some(_) -> combine_with j
done
;;
let combine (node_sets : 'a node_sets) (matrix : matrix)
(hops : int array array) (heap : nodepair Heap.heap) (a : int) (b: int) : unit =
debug ("Combining " ^ (string_of_int a) ^ " with " ^ (string_of_int b));
if b <= a then raise (Failure "b <= a");
let old1 = match node_sets.(a) with
None -> raise (Failure "Bad node set entry")
| Some(x) -> x in
let old2 = match node_sets.(b) with
None -> raise (Failure "Bad node set entry")
| Some(x) -> x in
let (s1,blob1,tree1) = old1 in
let (s2,blob2,tree2) = old2 in
let s3 = Dre.ISet.union s1 s2 in
let blob3 = combine_blob hops s1 s2 blob1 blob2 in
let tree3 = TreeNode(a, tree1, tree2) in
remove_from_matrix matrix a b;
(*
debug "Heap: ";
Heap.iterw heap (fun x y -> let (a,b) = y in
debug ((string_of_int x) ^ " = "
^ (string_of_int a) ^ ", " ^ (string_of_int b)));
*)
remove_from_sets node_sets a b;
node_sets.(a) <- Some(s3,blob3,tree3);
combine_with_all node_sets matrix hops heap a
;;
let rec greedy_combine (node_sets : 'a node_sets) (matrix : matrix)
(hops : int array array) (heap : nodepair Heap.heap) (remaining : int) : tree_node =
if remaining <= 0 then begin
let rec find_tree (i : int) : tree_node =
match node_sets.(i) with
None -> find_tree (i + 1)
| Some(_,_,tree) -> tree in
find_tree 0
end else begin
let (score,(a,b)) = Heap.min heap in
let (x,y) = if a < b then (a,b) else (b,a) in
estimated_routes := !estimated_routes + score;
combine node_sets matrix hops heap x y;
greedy_combine node_sets matrix hops heap (remaining - 1)
end
;;
let (heap,matrix) = initialize_heap node_sets hops in
debug "Heap initialized";
let root = greedy_combine node_sets matrix hops heap (size - 1) in
let rec print_tree (root : tree_node) =
match root with
NoNode -> ()
| TreeNode(id,left,right) -> begin
print_tree left;
output_string stdout ((string_of_int id) ^ "\n");
print_tree right
end
in
let tree_placement (howmany : int) (tree : tree_node) : (int * int32 array) =
let locations = Array.make howmany Int32.minus_one in
let rec helper (tree : tree_node) (depth : int) (sofar : int32) : int =
(*
if depth >= 32 then
raise (Failure "Tree too deep"); *)
match tree with
NoNode -> -1
| TreeNode(id,left,right) ->
if left == NoNode && right == NoNode then begin
(* Leaf node *)
locations.(id) <- sofar;
depth
end else
(* Get the children's IDs *)
let levelval = Int32.shift_left Int32.one (31 - depth) in
let left_val = sofar in
let right_val = Int32.logor sofar levelval in
let nextdepth = depth + 1 in
(* Recurse! *)
max (helper left nextdepth left_val)
(helper right nextdepth right_val)
in
let depth = (helper tree 0 Int32.zero) in
(depth, locations)
in
let (depth,placement) = tree_placement (Array.length hops) root in
print_endline ("bits " ^ (string_of_int depth));
print_endline ("routes " ^ (string_of_int !estimated_routes));
Array.iter (fun x -> Printf.printf "%0lu\n" (Int32.shift_right_logical x (32 - depth))) placement
......@@ -4,7 +4,8 @@
* files
*)
type ('a, 'b) node = { node_contents : 'a;
mutable node_edges : ('a, 'b) edge_list }
mutable node_edges : ('a, 'b) edge_list;
mutable incident_edges : int }
and ('a, 'b) edge_list = ('a, 'b) edge list
and ('a, 'b) edge = { src : ('a, 'b) node;
dst : ('a, 'b) node;
......@@ -21,7 +22,7 @@ type ('a, 'b) t = { mutable nodes : ('a, 'b) node_list;
let empty_graph () = { nodes = []; edges = []; nodehash = Hashtbl.create 127 };;
let empty_node contents =
{ node_contents = contents; node_edges = [] };;
{ node_contents = contents; node_edges = []; incident_edges = 0 };;
(* Note: If this gets used a lot, speed it up by putting a hashtable
* indexed by node contents *)
......@@ -61,7 +62,7 @@ let is_member graph contents =
(* is_member: ('a, 'b) t -> 'a -> ('a, 'b) node *)
let add_node graph contents =
let new_node = { node_contents = (contents : 'a);
node_edges = [] } in
node_edges = []; incident_edges = 0 } in
graph.nodes <- new_node :: graph.nodes;
Hashtbl.add graph.nodehash contents new_node;
new_node
......@@ -152,4 +153,107 @@ let read_graph_file (filename : string) : ('a,'b) t =
make_graph_from_edges edges
;;
let rec eat_shit channel =
let line = input_line channel in
let firsttwo = Str.first_chars line 2 in
if firsttwo = "%%" then () else eat_shit channel
;;
(* Read in one of Jon's graph files *)
let read_subgraph_file (filename : string) : ('a,'b) t =
let channel = if filename = "-" then stdin else open_in filename in
eat_shit channel;
let rec get_nodes () : int list list =
try
let line = input_line channel in
let parts = Str.split (Str.regexp " +") line in
let edges = List.tl (List.tl parts) in
let edge_ints = List.map int_of_string edges in
edge_ints :: get_nodes ()
with
End_of_file -> []
in
let make_edges (nodes : int list list) : int list list =
let (table : (int,int list) Hashtbl.t) = Hashtbl.create 100 in
let invert_edges (node : int) (edges : int list) : unit =
List.iter (fun (edge : int) ->
if Hashtbl.mem table edge then
let old_nodes = Hashtbl.find table edge in
Hashtbl.replace table edge (node :: old_nodes)
else
Hashtbl.add table edge [node]
) edges
in
let rec iter_nodes (nodes : int list list) (node : int) : unit =
match nodes with
[] -> ()
| x :: xs -> invert_edges node x; iter_nodes xs (node + 1)
in
iter_nodes nodes 0;
let (edge_list : int list list ref) = ref [] in
Hashtbl.iter (fun (edge : int) (nodes : int list) ->
edge_list := nodes :: !edge_list
) table;
!edge_list
in
let nodes = get_nodes () in
let g = empty_graph() in
let rec make_graph_from_edges (edges : int list list) : unit =
match edges with
[] -> ()
| x::xs ->
make_graph_from_edges xs;
let rec add_edges (src : int) (dsts : int list) : unit =
match dsts with
[] -> ()
| dst :: rest ->
(* Add the verticies to the graph if they are not in there
* already *)
let src_node =
if not (is_member g src) then add_node g src
else find_node g src in
let dst_node =
if not (is_member g dst) then add_node g dst
else find_node g dst in
let edge = add_edge g src_node dst_node 1 in
add_edges src rest in
let rec iter_nodes (nodes : int list) : unit =
match nodes with
x :: xs -> add_edges x xs; iter_nodes xs
| [] -> ()
in
iter_nodes x
in
let rec add_nodes (i : int) (nodes : int list list) : unit =
match nodes with
[] -> ()
| x :: xs -> ignore (add_node g i); add_nodes (i + 1) xs in
add_nodes 0 nodes;
let edges = make_edges nodes in
make_graph_from_edges edges;
(* XXX - not a great way to do this *)
(* let rec set_edge_count (which : int) (edges: int list list) : unit =
match nodes with
[] -> ()
| x :: xs ->
match x with
y :: [] -> ()
|
let node = find_node g which in
node.incident_edges <- (List.length x);
set_edge_count (which + 1) xs in *)
let rec set_edge_count (edges: int list list) : unit =
match edges with
[] -> ()
| x :: xs ->
(match x with
[] -> ()
| y :: [] -> ()
| y :: ys as yss -> List.iter (fun x -> let node = find_node g x
in node.incident_edges <- node.incident_edges + 1) yss);
set_edge_count xs in
set_edge_count edges;
g
;;
(* More operations will be added... *)
......@@ -49,8 +49,8 @@ let (dot_print_edge : out_channel -> ('a,'b) Graph.edge -> unit) =
;;
let (dot_print : ('a,'b) Graph.t -> string -> unit) = function g -> function filename ->
(* let channel = open_out filename in *)
let channel = stdout in
let channel = open_out filename in
(* let channel = stdout in *)
(* Preamble *)
output_string channel "digraph foo {\n";
output_string channel "\tnodesep=0.01\n";
......@@ -64,20 +64,29 @@ let (dot_print : ('a,'b) Graph.t -> string -> unit) = function g -> function fil
(* Hooray for instant gratification! *)
let show g =
print_endline "Showing graph";
let tmp = Filename.temp_file "graph" ".dot" in
let tmp2 = Filename.temp_file "graph" ".ps" in
(* dot_output g tmp; *)
dot_print g tmp;
ignore (Sys.command ("dot -Tps < " ^ tmp ^ " > " ^ tmp2 ^ " && gv " ^ tmp2));
ignore (Sys.command ("neato -Tps < " ^ tmp ^ " > " ^ tmp2 ^ " && gv " ^
tmp2)) (*;
Sys.remove tmp;
Sys.remove tmp2
Sys.remove tmp2 *)
;;
exception NeedArg;;
print_endline "Showing graph";