diff --git a/.merlin b/.merlin
deleted file mode 100644
index 85d3a654aab398a822e7c90a0fc7cfca3ae8a9cd..0000000000000000000000000000000000000000
--- a/.merlin
+++ /dev/null
@@ -1,10 +0,0 @@
-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/*
diff --git a/lib/algo/algo.ml b/lib/algo/algo.ml
index 91d0bed03bf7664114694c28beea997162baa880..de8f960747589e2447d429589b252089ddddbdc3 100644
--- a/lib/algo/algo.ml
+++ b/lib/algo/algo.ml
@@ -1,4 +1,4 @@
-(* 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
diff --git a/lib/algo/algo.mli b/lib/algo/algo.mli
index b2195f0cb6587155c27488b580a6b9bbcc84c3c7..4c48f6d23f7435f0c29b476d6887bdb8d3e2d353 100644
--- a/lib/algo/algo.mli
+++ b/lib/algo/algo.mli
@@ -1,4 +1,4 @@
-(* 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. *)
diff --git a/lib/sasacore/main.ml b/lib/sasacore/main.ml
index 5632ed6b0fe199720dbd3385e628f65231a0ccdd..02dbcda708a4206f45ba5281ec1c2c454bac0d49 100644
--- a/lib/sasacore/main.ml
+++ b/lib/sasacore/main.ml
@@ -1,4 +1,4 @@
-(* 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;
diff --git a/lib/sasacore/register.ml b/lib/sasacore/register.ml
index e92a5b3243642c6eef90d736f2d1a5315a5fe518..5ba3995665eafe46cace5ca0f33d07f597282a9f 100644
--- a/lib/sasacore/register.ml
+++ b/lib/sasacore/register.ml
@@ -1,4 +1,4 @@
-(* 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) =
diff --git a/lib/sasacore/register.mli b/lib/sasacore/register.mli
index e405b94d6cbb8e3020a9760482a03e6ca7446e7f..b33fed0e2bc7eeba40fd309e2d8080b897f4c6e7 100644
--- a/lib/sasacore/register.mli
+++ b/lib/sasacore/register.mli
@@ -1,4 +1,4 @@
-(* 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
diff --git a/lib/sasacore/topology.ml b/lib/sasacore/topology.ml
index d40bcbf25dd639dd30ffa014c6a5c3fc2eef1243..a59e6cb816d6935770743972db36b5d14b33032a 100644
--- a/lib/sasacore/topology.ml
+++ b/lib/sasacore/topology.ml
@@ -1,4 +1,4 @@
-(* 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 ->
+ (List.fold_left
+ (fun h pid ->
+ if List.mem pid parents then h else
+ max h (height succ (n::parents) pid)
+ )
+ (-1)
+ (succ n)
+ ) + 1
+
+let get_height : t -> string -> int =
+ fun g ->
+ 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 out_tree then
+ (fun pid -> List.map snd (g.succ pid))
+ else
+ (fun pid -> g.pred pid)
+ in
+ height succ []
diff --git a/lib/sasacore/topology.mli b/lib/sasacore/topology.mli
index a27f0e6dde7311ded6171929042e486bf8465fb5..e87887ff9e70f53f084dfdda118e352f84cdf773 100644
--- a/lib/sasacore/topology.mli
+++ b/lib/sasacore/topology.mli
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 31/08/2020 (at 16:45) by Erwan Jahier> *)
+(* Time-stamp: <modified the 09/04/2021 (at 10:48) by Erwan Jahier> *)
(** {1 Topology: internal representation of Graphs } *)
@@ -13,6 +13,7 @@ type node = {
type t = {
nodes: node list; (** *)
succ: node_id -> (int * node_id) list; (** get neighbors, with weight *)
+ pred: node_id -> node_id list;
of_id: node_id -> node; (** *)
directed:bool; (** true if the graph is directed *)
attributes: (string * string) list (** (name, value) list of graph attributes *)
@@ -22,11 +23,22 @@ type t = {
val read: string -> t
(** {1 Various eponymous util functions } *)
-
+
val to_adjacency: t -> bool array array
val get_nb_link: t -> int
val get_mean_degree : t -> float
-val is_connected_and_cyclic : t -> bool * bool
-val height : string list -> t -> string -> int
+val is_connected : t -> bool
+val is_cyclic : t -> bool
+val is_tree : t -> bool
+val is_in_tree : t -> bool
+val is_out_tree : t -> bool
val get_height : t -> string -> int
+val get_parent : t -> string -> int option
+val get_sub_tree_size : t -> string -> int
val get_degree: t -> int * int
+
+(** [reply g p p_neighbor] 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 neighbor of [p_neigbor],
+ which can happen in directed graphs. *)
+val reply: t -> string -> string -> int
diff --git a/test/Makefile.dot b/test/Makefile.dot
index 03b8593a87b9acb786a7413572cfb8d37f296aa1..e67483c7cf3f3706cf3029929444627fcfacf2e5 100644
--- a/test/Makefile.dot
+++ b/test/Makefile.dot
@@ -1,4 +1,4 @@
-# Time-stamp: <modified the 04/12/2020 (at 11:14) by Erwan Jahier>
+# Time-stamp: <modified the 09/04/2021 (at 10:48) by Erwan Jahier>
# Rules to generate various dot files.
@@ -33,8 +33,20 @@ ring%.dot:
gg ring -n $* -o $@
gg-deco $(DECO_PATTERN) $@ -o $@
-dtree%.dot:
- gg tree -dir -n $* -o $@
+tree%.dot:
+ gg tree -n $* -o $@
+ gg-deco $(DECO_PATTERN) $@ -o $@
+
+intree%.dot:
+ gg tree --in-tree -n $* -o $@
+ gg-deco $(DECO_PATTERN) $@ -o $@
+
+outtree%.dot:
+ gg tree --out-tree -n $* -o $@
+ gg-deco $(DECO_PATTERN) $@ -o $@
+
+inouttree%.dot:
+ gg tree --in-out-tree -n $* -o $@
gg-deco $(DECO_PATTERN) $@ -o $@
diff --git a/tools/gg/graphGen.ml b/tools/gg/graphGen.ml
index d01f2d1cf29636e0efe8883b0720be6c45821282..998b869559fa13a1d18e3dc2250ff04a6a145af6 100644
--- a/tools/gg/graphGen.ml
+++ b/tools/gg/graphGen.ml
@@ -10,7 +10,9 @@ open Sasacore
exception Incorrect_attribute
let min_max = ref None
-let connected_cyclic = ref None
+let connected = ref None
+let cyclic = ref None
+let tree = ref None
let height:int option ref = ref None
let generate_du_dur graph plan_udg t : unit =
@@ -103,32 +105,34 @@ let all_attr : (Topology.t -> (string * string) list) =
snd x)
| Some x -> snd x);
"is_connected", string_of_bool (
- match !connected_cyclic with
+ match !connected with
| None -> (
Printf.eprintf "Computing the connection...\n";
flush stderr;
- let x = Topology.is_connected_and_cyclic g in
- connected_cyclic := Some x;
- fst x)
- | Some x -> fst x );
+ let x = Topology.is_connected g in
+ connected := Some x;
+ x)
+ | Some x -> x );
"is_cyclic", string_of_bool
- (match !connected_cyclic with
+ (match !cyclic with
| None -> (
Printf.eprintf "Computing the cyclicity...\n";
flush stderr;
- let x = Topology.is_connected_and_cyclic g in
- connected_cyclic := Some x;
- snd x)
- | Some x -> snd x );
+ let x = Topology.is_cyclic g in
+ cyclic := Some x;
+ x)
+ | Some x -> x );
"is_tree", string_of_bool
- (match !connected_cyclic with
+ (match !tree with
| None -> (
Printf.eprintf "Computing the tree-ness...\n";
flush stderr;
- let x = Topology.is_connected_and_cyclic g in
- connected_cyclic := Some x;
- (fst x) && not (snd x))
- | Some x -> (fst x) && (snd x) );
+ let x = Topology.is_tree g in
+ tree := Some x;
+ x
+ )
+ | Some x -> x
+ );
"links_number", string_of_int (
Printf.eprintf "Computing the link_number...\n";
flush stderr;
@@ -263,7 +267,7 @@ let () = (
| _ -> (Printf.fprintf stderr "Unexpected outcome. Command line : %s\n"
(String.concat " " (Array.to_list Sys.argv)); assert false)
in
- if t.connected && not (fst (Topology.is_connected_and_cyclic g)) then
+ if t.connected && not (Topology.is_connected g) then
if !trials > max_trials then None else (incr trials;gen_graph ())
else
Some g