Commit 41a206a2 authored by Robert Ricci's avatar Robert Ricci

Initial checkin of the DRE stuff for ipassign. Written in ocaml.

At this point, the actual DRE caclulations are not done, but I wanted
to get a snapshot into CVS.
parent a451a317
all: test-heap graph2dot test-dijk test-dijk.opt
%.cmx: %.ml
ocamlopt -c $<
%.cmo: %.ml $(if -e %.mli,%.cmi)
ocamlc -g -c $<
%.cmo: %.ml
ocamlc -g -c $<
%.cmi: %.mli
ocamlc -g -c $<
graph2dot: graph2dot.ml graph.cmo
ocamlc -g -o graph2dot graph.cmo str.cma graph2dot.ml
test-heap: test-heap.ml heap.cmo heap.cmi
ocamlc -g -o test-heap heap.cmo test-heap.ml
test-dijk: test-dijk.ml heap.cmo heap.cmi graph.cmo dijkstra.cmo
ocamlc -g -o test-dijk heap.cmo graph.cmo dijkstra.cmo /usr/local/lib/ocaml/str.cma test-dijk.ml
test-dijk.opt: heap.cmx graph.cmx dijkstra.cmx test-dijk.ml
ocamlopt -o $@ /usr/local/lib/ocaml/str.cmxa $^
test-dre: test-dre.ml heap.cmo graph.cmo dijkstra.cmo dre.cmo
ocamlc -g -o $0 $^ /usr/local/lib/ocaml/str.cma
clean:
-rm *.cmo *.cmx *.cmi graph2dot test-heap test-dijk test-dijk.opt
(*
* dijkstra.ml - Implementation of Dijkstra's shortest-path
* algorthm
*)
type ('a,'b) dijk_state = {
graph : ('a, 'b) Graph.t;
visited : bool array; (* Not yet used - ditch? *)
estimate : 'b array;
pred : ('a, 'b) Graph.node array;
heap : ('a, 'b) Graph.node Heap.heap;
updaters : (int -> unit) array;
};;
let init (graph : ('a,'b) Graph.t) (node : ('a,'b) Graph.node)
: ('a,'b) dijk_state =
let size = Graph.size graph in
let state = { graph = graph;
visited = Array.make size false;
estimate = Array.make size 32000;
(* XXX - Bad! I have to pick a type for the node contents graph *)
pred = Array.make size (Graph.empty_node 0);
heap = Heap.make_heap (Graph.empty_node 0);
updaters = Array.make size (fun (a:int) -> ()) } in
state.estimate.(node.Graph.node_contents) <- 0;
let rec fill_heap (nodes : ('a, 'b) Graph.node list) : unit =
match nodes with
[] -> ()
| x::xs ->
let node_id = x.Graph.node_contents in
state.updaters.(node_id) <-
Heap.insert state.heap state.estimate.(node_id) x;
fill_heap xs
in fill_heap graph.Graph.nodes;
state
;;
let relax (state : ('a, 'b) dijk_state) (u : ('a, 'b) Graph.node)
(v : ('a, 'b) Graph.node) (edge : ('a, 'b) Graph.edge) : unit =
let uid = u.Graph.node_contents in
let vid = v.Graph.node_contents in
let followed_weight =
(state.estimate.(uid) + edge.Graph.contents) in
(* print_endline ("relax: uid=" ^ string_of_int uid ^ " vid="
^ string_of_int vid ^ " fw=" ^ string_of_int followed_weight); *)
if state.estimate.(vid) > followed_weight then
(state.estimate.(vid) <- followed_weight;
state.updaters.(vid) followed_weight;
state.pred.(vid) <- u)
else
()
;;
let rec process_edges (state : ('a, 'b) dijk_state) (node : ('a,'b) Graph.node)
(edges : ('a, 'b) Graph.edge list) : unit =
match edges with
[] -> ()
| edge::rest -> (
let dst = if edge.Graph.src != node then edge.Graph.src
else edge.Graph.dst in
if (state.visited.(dst.Graph.node_contents)) then () else
relax state node dst edge;
process_edges state node rest)
;;
let rec process_nodes (state : ('a, 'b) dijk_state) : unit =
try (match Heap.min state.heap with (weight,node) ->
Heap.extract_min state.heap;
state.visited.(node.Graph.node_contents) <- true;
process_edges state node node.Graph.node_edges;
process_nodes state)
with Heap.EmptyHeap -> ()
;;
let run_dijkstra (graph : ('a, 'b) Graph.t) (node : ('a, 'b) Graph.node)
: ('b array * ('a, 'b) Graph.node array) =
let state = init graph node in
process_nodes state;
(state.estimate, state.pred)
;;
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;;
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 =
let hops = Array.make (Array.length pred) INoHopYet in
let out_hops = Array.make (Array.length pred) NoHop 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
INoHop -> INoHop (* The root has no first hop *)
| INodeHop(hop) -> INodeHop(hop) (* We've already found the first hop *)
| INoHopYet ->
(let parent = pred.(node.Graph.node_contents) in
let hop = if parent.Graph.node_contents = root.Graph.node_contents
then INodeHop(node) else hop_helper parent in
hops.(node.Graph.node_contents) <- hop;
hop)
in
let rec all_hops (nodes : ('a, 'b) Graph.node list) : unit =
match nodes with
[] -> ()
| x :: xs -> let _ = hop_helper x in all_hops xs
in
let rec copy_hops (i : int) : unit =
if i >= Array.length hops then () else
match hops.(i) with
INoHop -> out_hops.(i) <- NoHop
| INodeHop(h) -> out_hops.(i) <- NodeHop(h)
| INoHopYet -> raise HopInternalError
in
all_hops graph.Graph.nodes;
copy_hops 0;
out_hops
;;
(*
* Functions for computing DRE
*)
let compute_dre (graph : ('a, 'b) Graph.t) : unit =
()
(*
* graph.ml - simple graph module
* Note: tests are commented out, since this module gets included by other
* files
*)
type ('a, 'b) node = { node_contents : 'a;
mutable node_edges : ('a, 'b) edge_list }
and ('a, 'b) edge_list = ('a, 'b) edge list
and ('a, 'b) edge = { src : ('a, 'b) node;
dst : ('a, 'b) node;
contents : 'b };;
type ('a, 'b) node_list = ('a, 'b) node list;;
(* The main type exported by this module *)
type ('a, 'b) t = { mutable nodes : ('a, 'b) node_list;
mutable edges : ('a, 'b) edge_list;
mutable nodehash : ('a, ('a,'b) node) Hashtbl.t;
};;
(* empty_graph : unit -> ('a, 'b) t *)
let empty_graph () = { nodes = []; edges = []; nodehash = Hashtbl.create 127 };;
let empty_node contents =
{ node_contents = contents; node_edges = [] };;
(* Note: If this gets used a lot, speed it up by putting a hashtable
* indexed by node contents *)
exception NoSuchNode;;
(* find_node_helper: ('a, 'b) node_list -> 'a -> ('a, 'b) node *)
let rec find_node_helper nodes contents =
match nodes with
[] -> raise NoSuchNode
| x::xs -> if (x.node_contents = contents) then x
else find_node_helper xs contents
;;
(* find_node: ('a, 'b) t -> 'a -> ('a, 'b) node *)
(* let find_node graph contents =
find_node_helper graph.nodes contents
;; *)
let find_node graph contents =
try Hashtbl.find graph.nodehash contents
with Not_found -> raise NoSuchNode
;;
(* find_node { nodes = [{ node_contents = 1; node_edges = [] }];
edges = [] } 1;; *)
(* Should be: { node_contents = [1]; node_edges = [] } *)
(* Note, this probably needs to be speeded up *)
let size graph =
List.length graph.nodes
;;
(* Use the exception to detect nodes that are not in the graph *)
(* is_member: ('a, 'b) t -> 'a -> bool *)
let is_member graph contents =
try let _ = find_node graph contents in true
with NoSuchNode -> false;
;;
(* Mutates the graph *)
(* is_member: ('a, 'b) t -> 'a -> ('a, 'b) node *)
let add_node graph contents =
let new_node = { node_contents = (contents : 'a);
node_edges = [] } in
graph.nodes <- new_node :: graph.nodes;
Hashtbl.add graph.nodehash contents new_node;
new_node
;;
(* add_node (empty_graph()) 5;; *)
(* Should be: {node_contents = 5; node_edges = []} *)
(* Mutates the graph, and both nodes *)
(* add_edge: ('a, 'b) t -> ('a, 'b) node -> ('a, 'b) node -> 'b
* -> ('a, 'b) edge *)
let add_edge graph node1 node2 contents =
let new_edge = { src = node1; dst = node2; contents = contents } in
graph.edges <- new_edge :: graph.edges;
node1.node_edges <- new_edge :: node1.node_edges;
node2.node_edges <- new_edge :: node2.node_edges;
new_edge
;;
(* let g = empty_graph() in
let n1 = add_node g 5 in
let n2 = add_node g 10 in
add_edge g n1 n2 0;; *)
(* Should be: Something that can't be printed, because of how it is
* recursively defined *)
(* Some simple helper functions - even though they're simple, they hide
* the list and edge representation so that we could change them later
* if we want *)
(* iterate_nodes: ('a, 'b) t -> (('a, 'b) node -> unit) -> unit *)
let iterate_nodes graph visitor =
List.iter visitor graph.nodes
;;
(* map_nodes: ('a, 'b) t -> (('a, 'b) node -> 'c) -> 'c list *)
let map_nodes graph visitor =
List.map visitor graph.nodes
;;
(* iterate_edges: ('a, 'b) t -> (('a, 'b) edge -> unit) -> unit *)
let iterate_edges graph visitor =
List.iter visitor graph.edges
;;
(* map_edges: ('a, 'b) t -> (('a, 'b) edge -> 'c) -> 'c list *)
let map_edges graph visitor =
List.map visitor graph.edges
;;
(* More operations will be added later, of course... *)
(*
* graph2dot.ml - Convert Jon Duerig's graph files into input files for dot
* File format is a bunch of lines constisting of four ints where:
* First is edge weight (unused)
* Second is unused
* Third is source vertex number
* Fourth is destination vertex number
* ... verticies exist only implicitly, as referenced by edges.
*)
(* Hmm, this is awkward, I have to declare all of these types even though they
* are related. There's probably some better way to do this *)
type mygraph = (int, unit) Graph.t;;
type mynode = (int, unit) Graph.node;;
type myedge = (int, unit) Graph.edge;;
type edge = int * int;;
(* Get a list of edges from a channel *)
let rec (get_edges : in_channel -> edge list) = function channel ->
try
let line = input_line channel in
let parts = Str.split (Str.regexp " +") line in
(int_of_string (List.nth parts 2), int_of_string (List.nth parts 3))
:: get_edges channel
with
End_of_file -> []
;;
(* Read in one of Jon's graph files *)
let (read_graph_file : string -> edge list) = function filename ->
let channel = open_in filename in
get_edges channel
;;
(* Make a graph from and edge_list *)
let rec (make_graph_from_edges : edge list -> mygraph) = function edges ->
match edges with
[] -> Graph.empty_graph()
| x::xs -> let g = make_graph_from_edges xs in
(match x with (first, second) ->
(* Add the verticies to the graph if they are not in there
* already *)
let src =
if not (Graph.is_member g first) then Graph.add_node g first
else Graph.find_node g first in
let dst =
if not (Graph.is_member g second) then Graph.add_node g second
else Graph.find_node g second in
let edge = Graph.add_edge g src dst () in
g)
;;
let (dot_print_vertex : out_channel -> mynode -> unit) =
function channel -> function vertex ->
output_string channel ("\t" ^ (string_of_int vertex.Graph.node_contents)
^ " [color=red" ^ ",style=filled,shape=point];\n")
;;
let (dot_print_edge : out_channel -> myedge -> unit) =
function channel -> function edge ->
output_string channel ("\t" ^ (string_of_int
(edge.Graph.src.Graph.node_contents)) ^ " -> " ^ (string_of_int
(edge.Graph.dst.Graph.node_contents)) ^
" [arrowhead=none,color=black];\n")
;;
let (dot_print : mygraph -> string -> unit) = function g -> function filename ->
let channel = open_out filename in
(* Preamble *)
output_string channel "digraph foo {\n";
output_string channel "\tnodesep=0.01\n";
output_string channel "\tranksep=0.5\n";
Graph.iterate_nodes g (dot_print_vertex channel);
Graph.iterate_edges g (dot_print_edge channel);
(* Prologue *)
output_string channel "}\n";
close_out channel
;;
(* Hooray for instant gratification! *)
let show g =
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));
Sys.remove tmp;
Sys.remove tmp2
;;
let edges = read_graph_file "test.graph" in
let g = make_graph_from_edges edges in
dot_print g "graph.dot"
(*
* heap.ml - simple heap module
*)
(* Types used by this module *)
type location = int;;
type weight = int;;
type weight_update_function = weight -> unit;;
let inf_weight = 32000;;
type 'a heap_data = { mutable key : weight;
value : 'a;
mutable loc : location };;
type 'a heap = { mutable arr : 'a heap_data array;
mutable len : int;
def : 'a };;
let make_heap (default : 'a) : 'a heap =
{ arr = Array.make 1 { key = 0; value = default; loc = 0 };
len = 0;
def = default };;
let parent (i : int) : int =
(i - 1) / 2;;
let left (i : int) : int =
(i * 2) + 1;;
let right (i : int) : int =
(i * 2) + 2;;
let rec heapify_up (heap : 'a heap) (data : 'a heap_data) (i : location)
: unit =
if i <= 0 || heap.arr.(parent i).key <= data.key then
(heap.arr.(i) <- data;
heap.arr.(i).loc <- i)
else
(heap.arr.(i) <- heap.arr.(parent i);
heap.arr.(i).loc <- i;
heapify_up heap data (parent i));;
let rec heapify (heap : 'a heap) (i : location) : unit =
let l = left i in
let r = right i in
let largest =
if l <= heap.len && heap.arr.(l).key < heap.arr.(i).key
then l else i
in
let largest =
if r <= heap.len && heap.arr.(r).key < heap.arr.(largest).key
then r else largest
in
if largest != i then
(let tmp = heap.arr.(i) in
heap.arr.(i) <- heap.arr.(largest);
heap.arr.(largest) <- tmp;
heap.arr.(i).loc <- i;
heap.arr.(largest).loc <- largest;
heapify heap largest)
else
();;
let update_weight (heap : 'a heap) (data : 'a heap_data) (weight : weight)
: unit =
data.key <- weight;
heapify_up heap data data.loc;;
let insert_obj (heap : 'a heap) (key : weight) (value : 'a)
: ('a heap_data) =
if (Array.length heap.arr) = heap.len then
(let narr = Array.make ((Array.length heap.arr) * 2)
{ key = 0; value = heap.def; loc = 0 } in
Array.blit heap.arr 0 narr 0 heap.len;
heap.arr <- narr);
let newdata = { key = key; value = value; loc = heap.len } in
Array.set heap.arr heap.len newdata;
heap.len <- heap.len + 1;
update_weight heap newdata key;
newdata;;
let insert (heap : 'a heap) (key : weight) (value : 'a)
: weight_update_function =
(* Copy array to grow it if necessary *)
let newdata = insert_obj heap key value in
fun w -> update_weight heap newdata w;;
exception EmptyHeap
let extract_min (heap : 'a heap) : unit =
if heap.len < 1 then raise EmptyHeap else
heap.len <- heap.len - 1;
heap.arr.(0) <- heap.arr.(heap.len);
heapify heap 0;;
let min (heap : 'a heap) : (weight * 'a) =
if heap.len = 0 then raise EmptyHeap else
let record = Array.get heap.arr 0 in
(record.key, record.value);;
(*
* heap.mli - Interface to the Heap module
*)
(* The heap itself *)
type 'a heap
(* The infinite weight *)
val inf_weight : int
(* Make a new heap - argument is any value of type 'a *)
val make_heap : 'a -> 'a heap
(* Insert into the heap - the function returned can be used to update
* the weight of the object, while keeping the heap property *)
val insert : 'a heap -> int -> 'a -> (int -> unit)
(* Remove the smallest-weighted object from the heap *)
val extract_min : 'a heap -> unit
(* Return the smallest-weighted object, and its weight *)
val min : 'a heap -> (int * 'a)
exception EmptyHeap
(* Export a bit more stuff so that we can try a less functional approach
* to this problem. *)
type 'a heap_data
val insert_obj : 'a heap -> int -> 'a -> 'a heap_data
val update_weight : 'a heap -> 'a heap_data -> int -> unit
(*
* test-dijk.ml
* Test functions for my Dijkstra's shortest path implementation
*)
(* Hmm, this is awkward, I have to declare all of these types even though they
* are related. There's probably some better way to do this *)
type mygraph = (int, int) Graph.t;;
type mynode = (int, int) Graph.node;;
type myedge = (int, int) Graph.edge;;
type edge = int * int;;
(* Get a list of edges from a channel *)
let rec (get_edges : in_channel -> edge list) = function channel ->
try
let line = input_line channel in
let parts = Str.split (Str.regexp " +") line in
(int_of_string (List.nth parts 2), int_of_string (List.nth parts 3))
:: get_edges channel
with
End_of_file -> []
;;
(* Read in one of Jon's graph files *)
let (read_graph_file : string -> edge list) = function filename ->
let channel = open_in filename in
get_edges channel
;;
(* Make a graph from and edge_list *)
let rec (make_graph_from_edges : edge list -> mygraph) = function edges ->
match edges with
[] -> Graph.empty_graph()
| x::xs -> let g = make_graph_from_edges xs in
(match x with (first, second) ->
(* Add the verticies to the graph if they are not in there
* already *)
let src =
if not (Graph.is_member g first) then Graph.add_node g first
else Graph.find_node g first in
let dst =
if not (Graph.is_member g second) then Graph.add_node g second
else Graph.find_node g second in
let edge = Graph.add_edge g src dst 1 in
g)
;;
let rec print_weights (channel : out_channel) (weights : int array)
(index : int) : unit =
if index >= Array.length weights then ()
else (output_string channel (string_of_int index ^ ": " ^ string_of_int
weights.(index) ^ "\n");
print_weights channel weights (index + 1))
;;
let rec print_pred (channel : out_channel) (preds : (int, 'b) Graph.node array)
(index : int) : unit =
if index >= Array.length preds then ()
else (output_string channel (string_of_int index ^ ": " ^ string_of_int
preds.(index).Graph.node_contents ^ "\n");
print_pred channel preds (index + 1))
;;
let rec dijk_all_nodes (g : ('a, 'b) Graph.t) (nodes : ('a, 'b) Graph.node list)
: unit =
match nodes with
[] -> ()
| (x :: xs) ->
(* print_endline ("On " ^ string_of_int x.Graph.node_contents); *)
match Dijkstra.run_dijkstra g x with (_,pred) ->
(* XXX - return this somehow *)
let _ = Dijkstra.get_first_hops g pred x in
(*
let res = Dijkstra.run_dijkstra g x in
match res with (weights,_) -> print_weights stdout weights 0; *)
dijk_all_nodes g xs
;;
exception NeedArg;;
if Array.length Sys.argv < 2 then raise NeedArg;;
(* print_endline "Here 1"; *)
let edges = read_graph_file Sys.argv.(1) in
(* print_endline "Here 2"; *)
let g = make_graph_from_edges edges in
(* print_endline "Here 3"; *)
let node = Graph.find_node g 0 in
(* print_endline "Here 4"; *)
(* let res = Dijkstra.run_dijkstra g node in (); *)
let _ = dijk_all_nodes g g.Graph.nodes in
();
(* print_endline "Here 5"; *)
(* match res with (weights,preds) ->
print_weights stdout weights 0;
print_pred stdout preds 0;; *)
(*
* test-dijk.ml
* Test functions for my Dijkstra's shortest path implementation
*)
(* Hmm, this is awkward, I have to declare all of these types even though they
* are related. There's probably some better way to do this *)
type mygraph = (int, int) Graph.t;;
type mynode = (int, int) Graph.node;;
type myedge = (int, int) Graph.edge;;
type edge = int * int;;
(* Get a list of edges from a channel *)
let rec (get_edges : in_channel -> edge list) = function channel ->
try
let line = input_line channel in
let parts = Str.split (Str.regexp " +") line in
(int_of_string (List.nth parts 2), int_of_string (List.nth parts 3))
:: get_edges channel
with
End_of_file -> []
;;
(* Read in one of Jon's graph files *)
let (read_graph_file : string -> edge list) = function filename ->
let channel = open_in filename in
get_edges channel
;;
(* Make a graph from and edge_list *)
let rec (make_graph_from_edges : edge list -> mygraph) = function edges ->
match edges with
[] -> Graph.empty_graph()
| x::xs -> let g = make_graph_from_edges xs in
(match x with (first, second) ->
(* Add the verticies to the graph if they are not in there
* already *)
let src =
if not (Graph.is_member g first) then Graph.add_node g first
else Graph.find_node g first in
let dst =
if not (Graph.is_member g second) then Graph.add_node g second
else Graph.find_node g second in
let edge = Graph.add_edge g src dst 1 in
g)
;;
let rec print_weights (channel : out_channel) (weights : int array)
(index : int) : unit =
if index >= Array.length weights then ()
else (output_string channel (string_of_int index ^ ": " ^ string_of_int
weights.(index) ^ "\n");
print_weights channel weights (index + 1))
;;
let rec print_pred (channel : out_channel) (preds : (int, 'b) Graph.node array)
(index : int) : unit =
if index >= Array.length preds then ()
else (output_string channel (string_of_int index ^ ": " ^ string_of_int
preds.(index).Graph.node_contents ^ "\n");
print_pred channel preds (index + 1))
;;
let rec dijk_all_nodes (g : ('a, 'b) Graph.t) (nodes : ('a, 'b) Graph.node list)
: unit =
match nodes with
[] -> ()
| (x :: xs) ->
(* print_endline ("On " ^ string_of_int x.Graph.node_contents); *)
match Dijkstra.run_dijkstra g x with (_,pred) ->
(* XXX - return this somehow *)
let _ = Dijkstra.get_first_hops g pred x in
(*
let res = Dijkstra.run_dijkstra g x in
match res with (weights,_) -> print_weights stdout weights 0; *)
dijk_all_nodes g xs
;;
exception NeedArg;;
if Array.length Sys.argv < 2 then raise NeedArg;;
(* print_endline "Here 1"; *)
let edges = read_graph_file Sys.argv.(1) in
(* print_endline "Here 2"; *)
let g = make_graph_from_edges edges in
(* print_endline "Here 3"; *)
let node = Graph.find_node g 0 in
(* print_endline "Here 4"; *)
(* let res = Dijkstra.run_dijkstra g node in (); *)
let _ = dijk_all_nodes g g.Graph.nodes in
();
(* print_endline "Here 5"; *)
(* match res with (weights,preds) ->
print_weights stdout weights 0;
print_pred stdout preds 0;; *)
type h = int Heap.heap;;
let h1 = Heap.make_heap 0;;
(* Should be: int Heap.heap = <abstr> *)
Heap.insert h1 5 1;;
(* Should be: fun from int to unit *)
Heap.min h1;;
(* Should be: (5,1) *)
Heap.insert h1 10 2;;