Commit a3e89de9 authored by Aliaume Lopez's avatar Aliaume Lopez

Booom : structure efficace, bonne abstraction et DOT

parent 278f3697
......@@ -15,6 +15,17 @@
*)
(****
*
* FIXME order reverse order nodes edges
*
* correct behavior ?
*
* TODO IMPORTANT NOTE FIXME
*
*)
let rec zip f a b = match (a,b) with
| [],[] -> []
| a :: b, c :: d -> f a c :: zip f b d ;;
......@@ -45,8 +56,12 @@ module IntegerDictionary = Map.Make (ComparableInts);;
type 'a mapping = 'a IntegerDictionary.t;;
(* node unique id *)
type nid = int;;
(* edge unique id *)
type eid = int;;
let id_empty = IntegerDictionary.empty
let id_add = IntegerDictionary.add
let id_map = IntegerDictionary.map
......@@ -143,11 +158,26 @@ type ptg = {
labels : label mapping;
(* edges in right order *)
edges : (nid list) mapping;
edges : eid list mapping;
(* edges for the dual graph *)
co_edges : (nid list) mapping;
co_edges : eid list mapping;
(* arrows : the nodes that corresponds
* to edges
*
* edge -> (node, node)
*)
arrows : (nid * nid) mapping;
};;
(***
* INVARIANTS
*
* TODO write all the invariants about
* the structure
*
*)
(**** PRETTY PRINTING ****)
......@@ -185,23 +215,31 @@ let string_of_ptg ptg =
"\tDELAYS : ";
ptg.delays |> List.map (fun x -> string_of_int x) |> String.concat ", ";
"\tEDGES";
ptg.edges |> id_bindings
|> List.map (fun (x,l) -> List.map (fun k -> (x,k)) l)
|> List.concat
|> List.map (fun (x,y) ->
"\t\t " ^ string_of_int x ^ " -> "
ptg.arrows |> id_bindings
|> List.map (fun (e,(x,y)) ->
"\t\t EDGE :" ^ string_of_int e ^ " = " ^ string_of_int x ^ " -> "
^ string_of_int y)
|> String.concat "\n";
] in
structure |> String.concat "\n";;
(* UNIQUE NODE ID PROVIDER *)
(*
* UNIQUE NODE ID PROVIDER
* and
* UNIQUE EDGE ID PROVIDER
* *)
let counter = ref 0;;
let newid () =
incr counter; !counter;;
let newids n = Utils.range n |> List.map (fun _ -> newid ());;
let e_counter = ref 0;;
let neweid () =
incr e_counter; !e_counter;;
let newids n = Utils.range n |> List.map (fun _ -> newid ());;
let neweids n = Utils.range n |> List.map (fun _ -> neweid ());;
(**** BASE OPERATIONS ****)
......@@ -231,38 +269,65 @@ let main_add ~node:n t =
nodes = n :: t.nodes
};;
(**
* Can fail with Not_found !!!
* if the edge does not exist
*)
let edge_get_nodes ~edge:e t =
IntegerDictionary.find e t.arrows;;
(* Node neighbourhood exploration *)
let edges_towards ~node:n t =
match id_find n t.co_edges with
| Some l -> l
| None -> [];;
let edges_from ~node:n t =
match id_find n t.edges with
| Some l -> l
| None -> [];;
let pre_nodes ~node:n t =
match id_find n t.co_edges with
| Some l -> l
|> List.map (fun e -> fst (edge_get_nodes ~edge:e t))
| None -> [];;
let post_nodes ~node:n t =
match id_find n t.edges with
| Some l -> l
|> List.map (fun e -> snd (edge_get_nodes ~edge:e t))
| None -> [];;
(* Edge construction and destruction
* adding an EDGE at the TOP of the list
* for both nodes ...
(* Edge construction
*
* It will use the first available output
* and the first available input
* Creates a new input and a new
* output port to connect the two
* nodes (no conflict can arise
* with this notation)
*
* *)
let edge_add ~from:n ~towards:m t =
let insert_node node = function
| None -> Some [node]
| Some l -> Some (node :: l)
let eid = neweid () in
let pre_m = edges_towards ~node:m t in
let pos_n = edges_from ~node:n t in
let insert_edge = function
| None -> Some [eid]
| Some l -> Some (eid :: l)
in
{ t with
edges = id_update n (insert_node m) t.edges;
co_edges = id_update m (insert_node n) t.co_edges;
edges = id_update n insert_edge t.edges;
co_edges = id_update m insert_edge t.co_edges;
arrows = id_add eid (n,m) t.arrows;
};;
(*
......@@ -274,14 +339,21 @@ let edge_add ~from:n ~towards:m t =
* (it could be that they share several connection
* on different ports)
*)
let edge_rem ~from:n ~towards:m t =
let update_func node = function
| Some l when List.mem node l -> Some (remove_once node l)
let edge_rem ~edge:eid t =
(* DEBUG don't check for the presence in
* production code ...
*)
let update_func x = function
| Some l when List.mem x l -> Some (remove_once x l)
| _ -> failwith "edge already removed !!! (edge_rem)"
in
let (n,m) = edge_get_nodes ~edge:eid t in
{ t with
edges = id_update n (update_func m) t.edges;
co_edges = id_update m (update_func n) t.co_edges;
edges = id_update n (update_func eid) t.edges;
co_edges = id_update m (update_func eid) t.co_edges;
arrows = id_remove eid t.arrows;
};;
(* Label updating *)
......@@ -348,20 +420,19 @@ let apply ~f ~elems:nds t = (* generic function batch *)
(** removes all the edges going in and out of a node *)
let node_edges_rem ~node:n t =
let pre = pre_nodes ~node:n t in
let post = post_nodes ~node:n t in
t |> apply ~f:(fun x -> edge_rem ~from:n ~towards:x) ~elems:post
|> apply ~f:(fun x -> edge_rem ~from:x ~towards:n) ~elems:pre;;
let pre = edges_towards ~node:n t in
let post = edges_from ~node:n t in
t |> apply ~f:(fun e -> edge_rem ~edge:e) ~elems:post
|> apply ~f:(fun e -> edge_rem ~edge:e) ~elems:pre;;
(** global pre/post disconnection *)
let pre_disconnect ~node:n t =
let p = pre_nodes ~node:n t in
apply ~f:(fun x -> edge_rem ~from:x ~towards:n) ~elems:p t;;
let p = edges_towards ~node:n t in
apply ~f:(fun e -> edge_rem ~edge:e) ~elems:p t;;
let post_disconnect ~node:n t =
let p = post_nodes ~node:n t in
apply ~f:(fun x -> edge_rem ~from:n ~towards:x) ~elems:p t;;
let p = edges_from ~node:n t in
apply ~f:(fun e -> edge_rem ~edge:e) ~elems:p t;;
(**** HIGHER LEVEL OPERATIONS ON GRAPHS *****)
......@@ -473,12 +544,13 @@ let trace_split ptg =
* constant time !!
*)
let copy_pre_conn (x,y) t =
let pre = pre_nodes ~node:x t in
let action ~node:n t =
t |> edge_rem ~from:n ~towards:x
let pre = edges_towards ~node:x t in
let action e t =
let n = fst (edge_get_nodes ~edge:e t) in
t |> edge_rem ~edge:e
|> edge_add ~from:n ~towards:y
in
batch ~f:action ~nodes:pre t
apply ~f:action ~elems:pre t
in
let new_graph = {
......@@ -507,38 +579,48 @@ let trace_split ptg =
* node of type 1->1
*
*)
let edge_remove_node ~from:a ~using:b ~towards:c t =
let a_out = post_nodes ~node:a t in
let c_in = pre_nodes ~node:a t in
let convert n x =
if x = b then
n
else
x
in
let edge_remove_node ~first:e1 ~using:b ~second:e2 t =
let (a,_) = edge_get_nodes ~edge:e1 t in
let (_,c) = edge_get_nodes ~edge:e2 t in
let a_out = edges_from ~node:a t in
let c_in = edges_towards ~node:c t in
{ t with
edges = t.edges |> id_add a (replace_once b c a_out) |> id_remove b ;
co_edges = t.co_edges |> id_add c (replace_once b a c_in) |> id_remove b ;
edges = t.edges
|> id_remove b ;
co_edges = t.co_edges
|> id_add c (replace_once e2 e1 c_in)
|> id_remove b ;
arrows = t.arrows
|> id_remove e2
|> id_add e1 (a,c) ;
};;
(***
* Does exactly the opposite construction
*
* b is supposed to be a simple connecting node
* without ANY edges prior to this function call
*
*)
let edge_insert_node ~from:a ~towards:c ~using:b t =
let a_out = post_nodes ~node:a t in
let c_in = pre_nodes ~node:c t in
let convert n x =
if x = b then
n
else
x
in
let edge_insert_node ~edge:e1 ~node:b ~using:e2 t =
let (a,c) = edge_get_nodes ~edge:e1 t in
let a_out = edges_from ~node:a t in
let c_in = edges_towards ~node:c t in
{ t with
edges = t.edges |> id_add a (replace_once c b a_out)
|> id_add b [a] ;
co_edges = t.co_edges |> id_add c (replace_once a b c_in)
|> id_add b [c];
edges = t.edges |> id_add b [e2] ;
co_edges = t.co_edges |> id_add c (replace_once e1 e2 c_in)
|> id_add b [e1];
arrows = t.arrows
|> id_add e1 (a,b)
|> id_add e2 (b,c) ;
};;
......@@ -598,6 +680,10 @@ let replicate ptg =
|> id_bindings
|> List.fold_left update_label id_empty ;
arrows = ptg.arrows
|> id_bindings
|> List.fold_left update_label id_empty ;
});;
......@@ -616,9 +702,11 @@ let ptg_merge g1 g2 =
iports = [];
oports = [];
labels = id_merge merger_v g1.labels g2.labels;
labels = id_merge merger_v g1.labels g2.labels;
edges = id_merge merger_v g1.edges g2.edges;
co_edges = id_merge merger_v g1.co_edges g2.co_edges;
arrows = id_merge merger_v g1.arrows g2.arrows;
};;
......@@ -18,8 +18,8 @@ open Ptg;;
*)
let propagate_constant ~node:n t =
try (* pattern matching failure means no modification *)
let Some (Value v) = id_find n t.labels in
let [traced_node] = post_nodes ~node:n t in
let Some (Value v) = id_find n t.labels in
let [traced_node] = post_nodes ~node:n t in
if not (List.mem traced_node t.traced) then
t
else
......@@ -36,11 +36,11 @@ let propagate_constant ~node:n t =
*)
let remove_identity ~node:n t =
try (* pattern matching failure means no modification *)
let [pre] = pre_nodes ~node:n t in
let [pos] = post_nodes ~node:n t in
let [pre] = edges_towards ~node:n t in
let [pos] = edges_from ~node:n t in
let None = id_find n t.labels in
if List.mem n t.nodes then
t |> edge_remove_node ~from:pre ~using:n ~towards:pos
t |> edge_remove_node ~first:pre ~using:n ~second:pos
|> main_rem ~node:n
else
t
......@@ -52,17 +52,23 @@ let remove_identity ~node:n t =
*)
let propagate_fork ~node:n t =
try (* pattern matching failure means no modification *)
let Some (Gate Fork) = id_find n t.labels in
let [z] = pre_nodes ~node:n t in
let Some (Value v) = id_find z t.labels in
let [x;y] = post_nodes ~node:n t in
let Some (Gate Fork) = id_find n t.labels in
let [z] = pre_nodes ~node:n t in
let Some (Value v) = id_find z t.labels in
let [e1;e2] = edges_from ~node:n t in
(* now do the update *)
let new_node = newid () in
t |> edge_insert_node ~from:n ~towards:x ~using:new_node
|> edge_rem ~from:n ~towards:new_node
let new_node = newid () in
let new_edge = neweid () in
(* fist introduce the new node *)
t |> edge_insert_node ~edge:e2 ~using:new_edge ~node:new_node
(* disconnect from the fork node *)
|> edge_rem ~edge:e2
(* remove the value node *)
|> main_rem ~node:z
(* set the new labels accordingly *)
|> label_set ~node:n ~label:(Value v)
|> label_set ~node:new_node ~label:(Value v)
with
......@@ -81,7 +87,7 @@ let bottom_join ~node:n t =
let Some (Gate Join) = id_find j t.labels in
t |> main_rem ~node:n
|> label_rem ~node:j
|> edge_rem ~from:j ~towards:n
|> post_disconnect ~node:n (* remove the edge *)
with
Match_failure _ -> t;;
......@@ -93,7 +99,7 @@ let disconnect_fork ~node:n t =
let Some (Gate Fork) = id_find f t.labels in
t |> main_rem ~node:n
|> label_rem ~node:f
|> edge_rem ~from:f ~towards:n
|> pre_disconnect ~node:n
with
Match_failure _ -> t;;
......@@ -164,9 +170,14 @@ let fun_of_gate = function
let reduce_gate ~node:n t =
if is_gate ~node:n t then
try
let pre = pre_nodes ~node:n t in
let [o] = post_nodes ~node:n t in
let pre = edges_towards ~node:n t in
let [o] = edges_from ~node:n t in
let ipt = List.map (fun x -> lazy (id_find x t.labels)) pre in
(*** TODO update this part of the code to use
* node ids
*)
match fun_of_gate (gate_of_node ~node:n t) ipt with
| Wire i ->
......@@ -174,7 +185,7 @@ let reduce_gate ~node:n t =
* through the gate (edge_remove_node)
* (bypassing the gate)
*)
t |> edge_remove_node ~from:(List.nth pre i) ~towards:o ~using:n
t |> edge_remove_node ~first:(List.nth pre i) ~second:o ~using:n
(* completely delete the gate
* with safe deletion
* *)
......@@ -184,14 +195,15 @@ let reduce_gate ~node:n t =
* insert node between the gate and the output,
* putting label l
*)
let m = newid () in
let m = newid () in
let e = neweid () in
t |> main_add ~node:n
|> label_set ~node:n ~label:(Value l)
|> edge_insert_node ~from:n ~towards:o ~using:m
|> edge_insert_node ~edge:o ~node:m ~using:e
(* remove the edge between the inserted node
* and the gate
*)
|> edge_rem ~from:n ~towards:m
|> edge_rem ~edge:o
(*
* remove the gate using safe remove
*)
......@@ -349,8 +361,6 @@ let rec mark_nodes ~seen ~nexts ptg =
*)
let mark_and_sweep t =
let reachable = mark_nodes ~seen:[] ~nexts:t.oports t in
print_string "\n REACHABLE : ";
reachable |> List.map string_of_int |> String.concat " ; " |> print_string;
let filter_func x = not (List.mem x reachable) in
let is_reachable x = List.mem x reachable in
let nodes_to_delete = List.filter filter_func t.nodes in
......@@ -370,17 +380,14 @@ let mark_and_sweep t =
let discons = newids (List.length pre ) in
t |> apply ~f:(fun (x,y) -> edge_insert_node ~from:n ~using:y ~towards:x) ~elems:(List.combine post bottoms)
|> apply ~f:(fun (x,y) -> edge_insert_node ~from:x ~using:y ~towards:n) ~elems:(List.combine pre discons)
t |> apply ~f:(fun (e,y) -> edge_insert_node ~edge:e ~node:y ~using:(neweid ())) ~elems:(List.combine post bottoms)
|> apply ~f:(fun (e,y) -> edge_insert_node ~edge:e ~node:y ~using:(neweid ())) ~elems:(List.combine pre discons)
|> batch ~f:(label_set ~label:Disconnect) ~nodes:discons
|> batch ~f:(label_set ~label:(Value Bottom)) ~nodes:bottoms
|> main_rem ~node:n
|> node_edges_rem ~node:n
in
print_string "\n TO DELETE : ";
nodes_to_delete |> List.map string_of_int |> String.concat " ; " |> print_string;
print_string "\n";
t |> batch ~f:remove_node_safely ~nodes:nodes_to_delete
......@@ -394,7 +401,7 @@ let mark_and_sweep t =
let empty_ptg =
{ iports = []; oports = []; traced = []; delays = []; nodes = []; labels = id_empty; edges = id_empty ; co_edges = id_empty };;
{ iports = []; oports = []; traced = []; delays = []; nodes = []; labels = id_empty; edges = id_empty ; co_edges = id_empty; arrows = id_empty };;
let example_ptg_2 =
......@@ -407,14 +414,31 @@ let example_ptg_2 =
|> connect ~from:[a;a;c] ~towards:[b;d;a];;
let () =
example_ptg_2 |> string_of_ptg |> print_string;
example_ptg_2 |> mark_and_sweep |> string_of_ptg |> print_string;;
let example_ptg_3 =
let [o] = newids 1 in
let bot = newids 10 in
empty_ptg |> oport_add ~node:o
|> batch ~f:main_add ~nodes:bot
|> batch ~f:(label_set ~label:(Value Bottom)) ~nodes:bot
|> join_into ~node:o ~nodes:bot;;
let example_ptg_4 =
let [i;o;t] = newids 3 in
empty_ptg |> iport_add ~node:i
|> oport_add ~node:o
|> main_add ~node:t
|> edge_add ~from:i ~towards:t
|> edge_add ~from:t ~towards:o;;
(******* DOT OUTPUT ... *******)
let rec list_index x = function
| [] -> failwith "oups"
| t :: q when t = x -> 0
| t :: q -> 1 + list_index x q;;
open Dot;;
let dot_of_ptg ptg =
let init_rank = rank_group "min" (ptg.iports @ ptg.traced @ ptg.delays) in
......@@ -424,20 +448,41 @@ let dot_of_ptg ptg =
let n = List.length (pre_nodes ~node:nid ptg) in
let m = List.length (post_nodes ~node:nid ptg) in
match id_find nid ptg.labels with
| None -> mkNode nid (emptyMod |> mod_shape "point")
| Some (Gate Join) ->
mkNode nid (emptyMod |> mod_shape "point")
| None
| Some (Gate Join)
| Some (Gate Fork) ->
mkNode nid (emptyMod |> mod_shape "point")
| Some Disconnect ->
mkNode nid (baseMod |> mod_label (string_of_label Disconnect))
| Some (Value v) ->
mkNode nid (baseMod |> mod_label (string_of_label (Value v)))
| Some l ->
mkNode nid (baseMod |> inputsOutputs (string_of_label l) n m)
in
(*
* DO SOMETHING CLEVER HERE
*
*)
let edges_from n t = () in
let node_port_from_edge nid l eid =
match id_find nid ptg.labels with
| None
| Some (Gate Join)
| Some (Gate Fork)
| Some Disconnect
| Some (Value _) -> None
| _ -> Some (1 + list_index eid l)
in
let draw_edge eid (a,b) =
let l1 = edges_from ~node:a ptg in
let l2 = edges_towards ~node:b ptg in
let i1 = node_port_from_edge a l1 eid in
let i2 = node_port_from_edge b l2 eid in
mkLink a i1 b i2
in
let edges =
ptg.arrows |> id_bindings
|> List.map (fun (x,y) -> draw_edge x y)
|> String.concat "\n"
in
let main_nodes =
......@@ -469,7 +514,15 @@ let dot_of_ptg ptg =
|> String.concat "\n"
in
[ init_rank; fin_rank; main_nodes; inputs; outputs; delays; traced ]
[ init_rank; fin_rank; main_nodes; inputs; outputs; delays; traced;edges ]
|> String.concat "\n"
|> addPrelude;;
(*******
*
* ENTRY POINT
*
*
*******)
let () =
example_ptg_4 |> remove_identity ~node:27 |> dot_of_ptg |> print_string;;
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