Commit bbde28ec authored by erwan's avatar erwan
Browse files

Some work on trees

- add sub_tree_size, parent, is_in_tree, is_out_tree
- fix height (was only working for out-trees)
- a predessors to Topology.t
- refactor a lot of strange things in the code
  - in the use of hashtbl in particular
parent 40eece7c
Pipeline #64373 passed with stages
in 3 minutes and 41 seconds
PKG lutils rdbg lustre-v6 lutin
S src/
S lib/sasacore/
S lib/sasa/
S lib/algo/
B _build/default/lib/algo/.algo.objs/*
B _build/default/lib/sasa/.sasa.objs/*
B _build/default/lib/sasacore/.sasacore.objs/*
(* Time-stamp: <modified the 13/10/2020 (at 15:55) by Erwan Jahier> *)
(* Time-stamp: <modified the 09/04/2021 (at 10:04) by Erwan Jahier> *)
open Sasacore
(* Process programmer API *)
......@@ -144,11 +144,15 @@ let max_degree = Register.max_degree
let is_cyclic = Register.is_cyclic
let is_connected = Register.is_connected
let is_directed = Register.is_directed
let is_tree = Register.is_tree
let height = Register.height
let links_number = Register.links_number
let diameter = Register.diameter
let is_tree = Register.is_tree
let is_in_tree = Register.is_in_tree
let is_out_tree = Register.is_out_tree
let height = Register.height
let sub_tree_size = Register.sub_tree_size
let parent = Register.parent
(*
let pid n = n.pid
......
(* Time-stamp: <modified the 04/11/2020 (at 08:15) by Erwan Jahier> *)
(* Time-stamp: <modified the 09/04/2021 (at 10:39) by Erwan Jahier> *)
(** {1 The Algorithm programming Interface}
A SASA process is an instance of an algorithm defined via this
......@@ -22,15 +22,16 @@ type 's enable_fun = 's -> 's neighbor list -> action list
type 's step_fun = 's -> 's neighbor list -> action -> 's
(** [enable_fun] and [step_fun] have the same arguments in input:
- The first argument holds the current state of the process. As it is
polymorphic (['s]), algorithms designers can put anything they need
into this state (an integer, a structure, etc.). The only constraint
is that all algorithms should use the same type.
- The first argument holds the current state of the process. As it
is polymorphic (['s]), algorithms designers can put anything they
need into this state (an integer, a structure, etc.). The only
constraint is that all algorithms should use the same type.
- The second argument holds the process neighbors. Note that SASA
processes, that live in graph nodes, can only access to their
immediate neighbors. From each neighbor, a process can access to
various information (cf [state], [reply], and [weight] functions below).
- The second argument holds the process neighbors (its successors
in the graph). Note that SASA processes, that live in graph nodes,
can only access to their immediate neighbors. From each neighbor,
a process can access to various information (cf [state], [reply],
and [weight] functions below).
[enable_fun] returns the list of enable actions.
......@@ -82,7 +83,7 @@ val state : 's neighbor -> 's
(** Returns the neighbor channel number, that let this neighbor access
to the content of the current process, if its neighbor can access
it. The channel number is the rank,starting at 0, in the
it. The channel number is the rank, starting at 0, in the
neighbors' list. Returns -1 if the neighbor can not access to the
process, which may happen in directed graphs.
......@@ -111,11 +112,26 @@ val max_degree : unit -> int
val is_directed : unit -> bool
val is_cyclic : unit -> bool
val is_connected : unit -> bool
val is_tree : unit -> bool
val height : unit -> (string (* the node id *) -> int) option
val links_number : unit -> int
val diameter : unit -> int
(** {3 Trees} *)
val is_tree : unit -> bool
val is_in_tree : unit -> bool
val is_out_tree : unit -> bool
(** The 3 functions below work for in_tree or out_tree only. *)
(* maps each node to the size of the corresponding sub-tree *)
val sub_tree_size : string (* the node id *) -> int
(** maps each node to its height in the tree *)
val height : string (* the node id *) -> int
(** maps each node to the channel number of its parent, and to None
for the tree root. *)
val parent : string (* the node id *) -> int option
(** It is possible to set some global parameters in the dot file
using graph attributes. This function allows one the get their
values. *)
......
(* Time-stamp: <modified the 02/04/2021 (at 15:47) by Erwan Jahier> *)
(* Time-stamp: <modified the 07/04/2021 (at 11:50) by Erwan Jahier> *)
open Register
......@@ -10,17 +10,6 @@ let (update_env_with_init : 'v Env.t -> 'v Process.t list -> 'v Env.t) =
in
List.fold_left aux e pl
(** Returns the channel number that let [p_neighbor] access to the
content of [p], if [p] is a neighbor of [p_neighbor]. Returns -1 if
[p] is not a neigbhbor of [p_neigbor], which can happen in directed
graphs. *)
let (reply: Topology.t -> string -> string -> int) =
fun g p p_neighbor ->
let rec f i = function
| [] -> (-1) (* may happen in directed graphs *)
| (_w,x)::t -> if x=p then i else f (i+1) t
in
f 0 (g.succ p_neighbor)
let (get_neighors: Topology.t -> Topology.node_id -> 'v -> 'v Register.neighbor list) =
fun g source_id init ->
......@@ -32,7 +21,7 @@ let (get_neighors: Topology.t -> Topology.node_id -> 'v -> 'v Register.neighbor
state = init;
pid = node.id;
spid = source_id;
reply = (fun () -> reply g source_id neighbor_id);
reply = (fun () -> Topology.reply g source_id neighbor_id);
weight = (fun () -> w)
}
)
......@@ -208,14 +197,7 @@ let (make : bool -> string array -> 'v t) =
let nidl = List.map (fun n -> n.Topology.id) nl in
let nstr = String.concat "," nidl in
Register.set_card (fun () -> List.length nl);
Register.set_degrees (fun () -> Topology.get_degree g);
Register.set_mean_deg (fun () -> Topology.get_mean_degree g);
Register.set_is_connected_cyclic (fun () -> Topology.is_connected_and_cyclic g);
Register.set_height (Topology.get_height g);
Register.set_links_number (fun () -> Topology.get_nb_link g);
Register.set_diameter (fun () -> Diameter.get g);
Register.set_is_directed (fun () -> g.directed);
Register.set_topology g;
List.iter (fun (n,v) -> Register.set_graph_attribute n v) g.attributes;
Register.verbose_level := args.verbose;
......
(* Time-stamp: <modified the 07/04/2021 (at 10:16) by Erwan Jahier> *)
(* Time-stamp: <modified the 08/04/2021 (at 22:03) by Erwan Jahier> *)
type 's neighbor = {
state: 's ;
......@@ -38,6 +38,8 @@ type 's internal_tables = {
mutable is_cyclic : bool option;
mutable is_connected : bool option;
mutable is_tree : bool option;
mutable is_in_tree : bool option;
mutable is_out_tree : bool option;
mutable is_directed : bool option;
mutable height : (string -> int) option;
mutable sub_tree_size: (string -> int) option;
......@@ -68,6 +70,8 @@ let (tbls:'s internal_tables) = {
is_cyclic = None;
is_connected = None;
is_tree = None;
is_in_tree = None;
is_out_tree = None;
is_directed = None;
height = None;
parent = None;
......@@ -223,8 +227,7 @@ let (max_degree : unit -> int) = fun () ->
let (is_cyclic : unit -> bool) = fun () ->
match tbls.is_cyclic with
| None ->
let connect, cyclic = Topology.is_connected_and_cyclic (get_topology()) in
tbls.is_connected <- Some connect;
let cyclic = Topology.is_cyclic (get_topology()) in
tbls.is_cyclic <- Some cyclic;
cyclic
| Some b -> b
......@@ -232,54 +235,66 @@ let (is_cyclic : unit -> bool) = fun () ->
let (is_connected : unit -> bool) = fun () ->
match tbls.is_connected with
| None ->
let connect, cyclic = Topology.is_connected_and_cyclic (get_topology()) in
let connect = Topology.is_connected (get_topology()) in
tbls.is_connected <- Some connect;
tbls.is_cyclic <- Some cyclic;
connect
| Some b -> b
let (is_tree : unit -> bool) = fun () ->
match tbls.is_tree with
| None ->
let b = (not (is_cyclic ()) && (is_connected ())) in
let b = Topology.is_tree (get_topology()) in
tbls.is_tree <- Some b;
b
| Some b -> b
exception Not_a_tree
let (is_in_tree : unit -> bool) = fun () ->
match tbls.is_in_tree with
| None ->
let b = Topology.is_in_tree (get_topology()) in
tbls.is_in_tree <- Some b;
b
| Some b -> b
let height : (unit -> string -> int) =
fun () ->
let (is_out_tree : unit -> bool) = fun () ->
match tbls.is_out_tree with
| None ->
let b = Topology.is_out_tree (get_topology()) in
tbls.is_out_tree <- Some b;
b
| Some b -> b
let not_a_tree () = failwith "The graph is not a tree"
let height : (string -> int) =
fun pid ->
if is_tree () then (
match tbls.height with
| Some h -> h
| Some h -> h pid
| None ->
let h = Topology.get_height (get_topology ()) in
tbls.height <- Some h; h
tbls.height <- Some h; h pid
)
else raise Not_a_tree
else not_a_tree ()
let sub_tree_size : (unit -> string -> int) =
fun () ->
let sub_tree_size : (string -> int) =
fun pid ->
if is_tree () then (
match tbls.sub_tree_size with
| Some s -> s
| Some s -> s pid
| None ->
let s = Topology.get_sub_tree_size (get_topology ()) in
tbls.sub_tree_size <- Some s; s
tbls.sub_tree_size <- Some s; s pid
)
else raise Not_a_tree
else not_a_tree ()
let parent : (unit -> string -> int option) =
fun () ->
if is_tree () then (
let parent : (string -> int option) =
fun pid ->
match tbls.parent with
| Some p -> p
| Some p -> p pid
| None ->
let p = Topology.get_parent (get_topology ()) in
tbls.parent <- Some p; p
)
else raise Not_a_tree
tbls.parent <- Some p; p pid
let (links_number : unit -> int) =
......
(* Time-stamp: <modified the 13/10/2020 (at 15:36) by Erwan Jahier> *)
(* Time-stamp: <modified the 08/04/2021 (at 21:55) by Erwan Jahier> *)
(** This module duplicates and extends the Algo module with get_*
functions.
......@@ -43,15 +43,16 @@ val mean_degree : unit -> float
val max_degree : unit -> int
val is_cyclic : unit -> bool
val is_connected : unit -> bool
val is_tree : unit -> bool
val is_directed : unit -> bool
(** If height () = None, then the graph doesn't have a height (because it isn't a tree)
Otherwise, height () = Some h.*)
val height : unit -> (string -> int) option
val links_number : unit -> int
val diameter : unit -> int
val is_tree : unit -> bool
val is_in_tree : unit -> bool
val is_out_tree : unit -> bool
val sub_tree_size : string -> int
val parent : string -> int option
val is_directed : unit -> bool
val height : string -> int
val verbose_level: int ref
val get_graph_attribute : string -> string
......@@ -74,15 +75,8 @@ val get_copy_value : unit -> ('s -> 's)
val to_string : 's -> string
(** Those are called by sasa once the graph has been parsed *)
val set_card : (unit -> int) -> unit
val set_degrees : (unit -> int*int) -> unit
val set_mean_deg : (unit -> float) -> unit
val set_is_connected_cyclic : (unit -> bool*bool) -> unit
val set_is_directed : (unit -> bool) -> unit
val set_topology : Topology.t -> unit
type node_id = string (* cf topology.mli *)
val set_height : (node_id -> int) -> unit
val set_links_number : (unit -> int) -> unit
val set_diameter : (unit -> int) -> unit
val set_graph_attribute : string -> string -> unit
val graph_attribute_list: unit -> (string * string) list
......
(* Time-stamp: <modified the 09/11/2020 (at 21:58) by Erwan Jahier> *)
(* Time-stamp: <modified the 09/04/2021 (at 10:48) by Erwan Jahier> *)
open Graph
open Graph.Dot_ast
......@@ -14,6 +14,7 @@ type node = {
type t = {
nodes: node list;
succ: node_id -> (int * node_id) list;
pred: node_id -> node_id list;
of_id: node_id -> node;
directed:bool;
attributes: (string * string) list;
......@@ -22,12 +23,15 @@ type t = {
type node_info_t = (string, node) Hashtbl.t
let node_info:node_info_t = Hashtbl.create 100
type node_succ_t = (string, (int * node_id) list) Hashtbl.t
type node_succ_t = (string, int * node_id) Hashtbl.t
let node_succ:node_succ_t = Hashtbl.create 100
type node_pred_t = (string, node_id) Hashtbl.t
let node_pred:node_pred_t = Hashtbl.create 100
let clean_tbl () =
Hashtbl.clear node_info;
Hashtbl.clear node_succ
Hashtbl.clear node_succ;
Hashtbl.clear node_pred
let (of_id:Dot_ast.id -> string) =
function Ident str | Html str | Number str | String str -> str
......@@ -89,7 +93,7 @@ let (do_stmt: bool -> node list * attrs -> Dot_ast.stmt -> node list * attrs) =
let id = of_node_id node_id in
let inits = get_init dot_attrs in
let node = { id=id ; file = get_file node_id dot_attrs ; init = inits } in
Hashtbl.replace node_info id node;
Hashtbl.add node_info id node;
node::n, attrs
| Edge_stmt (dot_node, nodes, dot_attrs) ->
let node = of_node dot_node in
......@@ -110,12 +114,12 @@ let (do_stmt: bool -> node list * attrs -> Dot_ast.stmt -> node list * attrs) =
if n1 = n2 then failwith
(Printf.sprintf
"Bad topology: %s can not ne a neighbor of itself!" n1);
let pn1 = try Hashtbl.find node_succ n1 with Not_found -> [] in
let pn2 = try Hashtbl.find node_succ n2 with Not_found -> [] in
let pn1 = Hashtbl.find_all node_succ n1 in
let pn2 = Hashtbl.find_all node_succ n2 in
if not (List.mem (weight,n2) pn1) then
Hashtbl.replace node_succ n1 ((weight,n2)::pn1);
Hashtbl.add node_succ n1 (weight,n2);
if not directed && not (List.mem (weight,n1) pn2) then
Hashtbl.replace node_succ n2 ((weight,n1)::pn2);
Hashtbl.add node_succ n2 (weight,n1);
n2
in
ignore (List.fold_left add_edge node nodes);
......@@ -133,10 +137,20 @@ let (read: string -> t) = fun f ->
clean_tbl ();
let dot_file = Graph.Dot.parse_dot_ast f in
assert (not dot_file.strict);
let nodes, attrs = List.fold_left (do_stmt dot_file.digraph) ([], []) dot_file.stmts in
let nodes, attrs =
List.fold_left (do_stmt dot_file.digraph) ([], []) dot_file.stmts
in
Hashtbl.iter
(fun pid (_, pid_succ) ->
Hashtbl.add node_pred pid_succ pid
)
node_succ;
let succ str = Hashtbl.find_all node_succ str in
let pred str = Hashtbl.find_all node_pred str in
{
nodes = List.rev nodes;
succ = (fun str -> try Hashtbl.find node_succ str with Not_found -> []);
succ = succ;
pred = pred;
of_id = (fun str -> try Hashtbl.find node_info str with Not_found ->
failwith (str^ " unknown node id")
);
......@@ -153,7 +167,8 @@ let (to_adjacency: t -> bool array array) =
List.iteri (fun i n -> Hashtbl.add rank_node_tbl n.id i) t.nodes;
List.iteri
(fun i n ->
List.iter (fun (_,target) -> m.(i).(rank_node target) <- true) (t.succ n.id)
List.iter (fun (_,target) ->
m.(i).(rank_node target) <- true) (t.succ n.id)
)
t.nodes;
m
......@@ -163,21 +178,29 @@ let (get_degree: t -> int*int) =
match t.nodes with
| [] -> 0,0
| n::tl ->
let node_deg n = List.length (t.succ (n.id)) in
let node_deg n =
if t.directed then
List.length (t.succ (n.id)) + List.length (t.pred (n.id))
else
List.length (t.succ (n.id))
in
let d0 = node_deg n in
let dmin, dmax = List.fold_left
(fun (d_min,d_max) n ->
(min (node_deg n) d_min, max (node_deg n) d_max)
)
(d0, d0)
tl
(fun (d_min,d_max) n ->
(min (node_deg n) d_min, max (node_deg n) d_max)
)
(d0, d0)
tl
in
if t.directed then 2*dmin, 2*dmax else dmin, dmax
dmin, dmax
let (get_nb_link: t -> int) =
fun t ->
let res = List.fold_left
(fun acc n -> ((List.length (t.succ n.id))) + acc) 0 t.nodes
(fun acc n ->
let succ = String.concat "," (List.map snd (t.succ n.id)) in
Printf.printf "%s->%s\n%!" n.id succ;
((List.length (t.succ n.id))) + acc) 0 t.nodes
in
if t.directed then res else res/2
......@@ -185,6 +208,42 @@ let (get_mean_degree : t -> float) =
fun t ->
2.0 *. (float_of_int (get_nb_link t)) /. (float_of_int (List.length t.nodes))
type color = W | G | B
exception Cycle
let directed_is_cyclic : t -> bool =
fun g ->
assert (g.directed);
let t = Hashtbl.create (List.length g.nodes) in
let nodes = List.map (fun n -> n.id) g.nodes in
let color pid = match Hashtbl.find_opt t pid with
Some c -> c | None -> assert false
in
List.iter (fun n -> Hashtbl.add t n W) nodes;
let rec visit pid =
match color pid with
| G -> raise Cycle
| B -> ()
| W ->
Hashtbl.replace t pid G;
List.iter visit (g.pred pid);
Hashtbl.replace t pid B
in
try List.iter visit nodes; false
with Cycle -> true
let is_connected : t -> bool =
fun g ->
let visited = Hashtbl.create 0 in
let rec f acc pid =
if Hashtbl.mem visited pid then acc else
(Hashtbl.add visited pid pid;
List.fold_left f (pid::acc)
(List.rev_append (List.map snd (g.succ pid)) (g.pred pid))
)
in
let accessible = f [] (List.hd g.nodes).id in
List.length accessible = List.length g.nodes
let bfs : (t -> string -> bool * string list) =
fun t n ->
let q = Queue.create () in
......@@ -206,26 +265,123 @@ let bfs : (t -> string -> bool * string list) =
parents
)
) !parent (t.succ node)
done;
(!cyclic, !discovered)
let is_connected_and_cyclic : t -> bool*bool =
fun t -> match t.nodes with
| [] -> (false,false)
let non_directed_is_cyclic : t -> bool =
fun t ->
assert(not t.directed);
match t.nodes with
| [] -> false
| hd::_ ->
let (cyclic,bfs_nodes) = (bfs t hd.id) in
((List.compare_lengths t.nodes bfs_nodes) = 0, cyclic)
let rec height : string list -> t -> string -> int =
fun parents t n ->
(List.fold_left (fun h (_,succ) ->
if List.mem succ parents then
h
else
max h (height (n::parents) t succ)) (-1) (t.succ n)) + 1
let get_height : t -> string -> int =
fun t ->
height ([]) t
let (cyclic, _bfs_nodes) = (bfs t hd.id) in
cyclic
let is_cyclic : t -> bool =
fun g ->
if g.directed then directed_is_cyclic g else non_directed_is_cyclic g
let is_tree : t -> bool =
fun g ->
(not (is_cyclic g)) && (is_connected g)
(** Returns the channel number that let [p_neighbor] access to the
content of [p], if [p] is a neighbor of [p_neighbor]. Returns -1 if
[p] is not a neigbhbor of [p_neigbor], which can happen in directed
graphs. *)
let (reply: t -> string -> string -> int) =
fun g p p_neighbor ->
let rec f i = function
| [] -> (-1) (* may happen in directed graphs *)
| (_w,x)::t -> if x=p then i else f (i+1) t
in
f 0 (g.succ p_neighbor)
let (reply_pred: t -> string -> string -> int) =
fun g p p_neighbor ->
let rec f i = function
| [] -> (-1) (* may happen in directed graphs *)
| x::t -> if x=p then i else f (i+1) t
in
f 0 (g.pred p_neighbor)
let is_in_tree g =
(is_tree g) &&
(List.for_all (fun n -> List.length (g.pred n.id) <= 1) g.nodes)
let is_out_tree g =
(is_tree g) &&
(List.for_all (fun n -> List.length (g.succ n.id) <= 1) g.nodes)
let not_a_io_tree () = failwith "The graph is not an in-tree nor an out-tree"
let get_parent = fun g pid ->
let in_tree = is_in_tree g in
let out_tree = is_out_tree g in
if not in_tree && not out_tree then
not_a_io_tree ()
else
let succ,reply =
if out_tree then
(fun pid -> List.map snd (g.succ pid)), reply_pred
else
(fun pid -> g.pred pid), reply
in
match succ pid with
| [] -> None
| [par] -> Some (reply g pid par)
| l ->
Printf.printf "%s->%s\n%!" pid (String.concat "," l);
assert false
let get_sub_tree_size g pid =
let in_tree = is_in_tree g in
let out_tree = is_out_tree g in
if not in_tree && not out_tree then
not_a_io_tree ()
else
let succ =
if in_tree then
(fun pid -> List.map snd (g.succ pid))
else
(fun pid -> g.pred pid)
in
let visited = Hashtbl.create 0 in
let rec f acc pid =
if Hashtbl.mem visited pid then acc else
(Hashtbl.add visited pid pid;
List.fold_left
(fun acc pid -> f acc pid)
(acc+1)
(succ pid)
)
in
f 0 pid
let rec height : (string -> string list) -> string list -> string -> int =
fun succ parents n ->