From 961de148119ae975d3fd059bf2d5597539cdc435 Mon Sep 17 00:00:00 2001
From: Erwan Jahier <erwan.jahier@univ-grenoble-alpes.fr>
Date: Mon, 7 Oct 2019 16:41:04 +0200
Subject: [PATCH] Update: move the functions relative to topology that were in
main.ml in topology.ml as it is where they belong.
---
lib/algo/algo.ml | 2 +-
lib/algo/algo.mli | 3 +-
lib/algo/dune | 2 +-
lib/sasacore/dune | 4 +-
lib/sasacore/main.ml | 86 +++++----------------------------------
lib/sasacore/main.mli | 4 +-
lib/sasacore/register.ml | 2 +-
lib/sasacore/register.mli | 2 +-
lib/sasacore/topology.ml | 69 ++++++++++++++++++++++++++++++-
lib/sasacore/topology.mli | 12 +++++-
test/Makefile.inc | 5 ++-
11 files changed, 101 insertions(+), 90 deletions(-)
diff --git a/lib/algo/algo.ml b/lib/algo/algo.ml
index 1afde6f7..f79c668e 100644
--- a/lib/algo/algo.ml
+++ b/lib/algo/algo.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 30/09/2019 (at 16:20) by Erwan Jahier> *)
+(* Time-stamp: <modified the 07/10/2019 (at 15:02) by Erwan Jahier> *)
open Sasacore
(* Process programmer API *)
diff --git a/lib/algo/algo.mli b/lib/algo/algo.mli
index 8dc70cf6..01438a43 100644
--- a/lib/algo/algo.mli
+++ b/lib/algo/algo.mli
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 30/09/2019 (at 16:20) by Erwan Jahier> *)
+(* Time-stamp: <modified the 07/10/2019 (at 14:35) by Erwan Jahier> *)
(** The Algorithm programming Interface.
A SASA process is an instance of an algorithm defined via this
@@ -109,7 +109,6 @@ val get_graph_attribute : string -> string
let (step_f : State.t neighbor list -> State.t -> action -> State.t ) = xxx
let actions = Some ["action1";"action2"];
*)
-
type 's algo_to_register = {
algo_id : string;
init_state: int (* holds the process neigbors number *) -> 's;
diff --git a/lib/algo/dune b/lib/algo/dune
index ccb619a9..656f48b2 100644
--- a/lib/algo/dune
+++ b/lib/algo/dune
@@ -1,4 +1,4 @@
-;; Time-stamp: <modified the 06/09/2019 (at 09:56) by Erwan Jahier>
+;; Time-stamp: <modified the 07/10/2019 (at 15:01) by Erwan Jahier>
(library
(name algo)
diff --git a/lib/sasacore/dune b/lib/sasacore/dune
index 07bbbd9c..b5cbe69d 100644
--- a/lib/sasacore/dune
+++ b/lib/sasacore/dune
@@ -1,4 +1,4 @@
-;; Time-stamp: <modified the 06/09/2019 (at 10:09) by Erwan Jahier>
+;; Time-stamp: <modified the 07/10/2019 (at 15:36) by Erwan Jahier>
(library
(name sasacore)
@@ -8,7 +8,7 @@
;;
; (wrapped false)
(library_flags -linkall)
- (synopsis "The Sasa main files (shared by the sasa exec and the rdbg plugin")
+ (synopsis "The Sasa main files (shared by the sasa exec and the rdbg plugin)")
)
diff --git a/lib/sasacore/main.ml b/lib/sasacore/main.ml
index 1d1a0ecd..e0748504 100644
--- a/lib/sasacore/main.ml
+++ b/lib/sasacore/main.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 13/09/2019 (at 10:32) by Erwan Jahier> *)
+(* Time-stamp: <modified the 07/10/2019 (at 16:38) by Erwan Jahier> *)
open Register
@@ -147,73 +147,6 @@ let (env_rif_decl: SasArg.t -> 'v Process.t list -> string) =
(List.map (fun (base, tstr) -> Printf.sprintf "\"%s\":%s" base tstr) ssl)
-let (get_degree:Topology.t -> int*int) =
- fun t -> if t.nodes = [] then 0,0
- else
- let node_deg n = List.length (t.succ (n.Topology.id)) in
- let d_start = node_deg ((List.hd t.nodes)) in
- List.fold_left (fun (d_min,d_max) n ->
- (min (node_deg n) d_min, max (node_deg n) d_max)
- ) (d_start,d_start) (List.tl t.nodes)
-
-(* take a graph t and a boolean is_oriented and return the number of
- link in the graph *)
-let (get_nb_link: Topology.t -> bool -> int) =
- fun t is_oriented ->
- if not is_oriented then
- (List.fold_left
- (fun acc n -> ((List.length (t.succ n.Topology.id))) + acc) (0) (t.nodes)) / 2
- else
- (List.fold_left
- (fun acc n -> ((List.length (t.succ n.Topology.id))) + acc) (0) (t.nodes))
-
-let (get_mean_degree : Topology.t -> float) =
- fun t ->
- (float_of_int (get_nb_link t true)) /. (float_of_int (List.length t.nodes))
-
-let bfs : (Topology.t -> string -> bool * string list) =
- fun t n ->
- let q = Queue.create () in
- let discovered = ref [n] and parent = ref (function _ -> "") in
- let cyclic = ref false in
- Queue.add n q;
- while not (Queue.is_empty q) do
- let node = Queue.take q in
- parent := List.fold_left (fun parents (_,suc) ->
- if List.for_all (fun disc -> disc <> suc) !discovered
- then (
- Queue.add suc q;
- discovered := (suc)::!discovered;
- function a -> if a = suc then node else parents a
- ) else ((
- if suc <> (parents node)
- then
- cyclic := true);
- parents
- )
- ) !parent (t.succ node)
-
- done;
- (!cyclic, !discovered)
-
-let is_connected_and_cyclic : Topology.t -> bool*bool =
- fun t -> match t.nodes with
- | [] -> (false,false)
- | hd::_ ->
- let (cyclic,bfs_nodes) = (bfs t hd.Topology.id) in
- ((List.compare_lengths t.nodes bfs_nodes) = 0, cyclic)
-
-let rec height : string list -> Topology.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 : Topology.t -> string -> int =
- fun t ->
- height ([]) t
let (make : bool -> string array -> 'v t) =
fun dynlink argv ->
@@ -241,7 +174,7 @@ let (make : bool -> string array -> 'v t) =
flush stdout;
exit 0
);
- let cmxs = (Filename.chop_extension dot_file) ^ ".cmxs" in
+ let cmxs = (Filename.chop_extension dot_file) ^ ".cma" in
if args.gen_register then (
let base = Filename.chop_extension dot_file in
let base = Str.global_replace (Str.regexp "\\.") "" base in
@@ -262,11 +195,11 @@ 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 () -> get_degree g);
- Register.set_mean_deg (fun () -> get_mean_degree g);
- Register.set_is_connected_cyclic (fun () -> is_connected_and_cyclic g);
- Register.set_height (get_height g);
- Register.set_links_number (fun () -> get_nb_link g false);
+ 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 false);
Register.set_diameter (fun () -> Diameter.get g);
Register.verbose_level := args.verbose;
@@ -275,9 +208,10 @@ let (make : bool -> string array -> 'v t) =
if dynlink then (
(* Dynamically link the cmxs file (not possible from rdbg) *)
+ let cmxs = Dynlink.adapt_filename cmxs in
if !Register.verbose_level > 0 then Printf.printf "Loading %s...\n" cmxs;
- Dynlink.loadfile (Dynlink.adapt_filename cmxs);
- );
+ Dynlink.loadfile_private cmxs;
+ ) else ();
let initl = List.map (fun n ->
let algo_id = Filename.chop_suffix n.Topology.file ".ml" in
diff --git a/lib/sasacore/main.mli b/lib/sasacore/main.mli
index a55d527c..be677c32 100644
--- a/lib/sasacore/main.mli
+++ b/lib/sasacore/main.mli
@@ -1,11 +1,11 @@
-(* Time-stamp: <modified the 06/09/2019 (at 10:15) by Erwan Jahier> *)
+(* Time-stamp: <modified the 07/10/2019 (at 16:13) by Erwan Jahier> *)
(* XXX find a better name *)
type 'v layout = ('v Process.t * 'v Register.neighbor list) list
type 'v t = SasArg.t * 'v layout * 'v Env.t
-(* [make argv] *)
+(* [make dynlink_flag argv] *)
val make : bool -> string array -> 'v t
type 'v enable_processes =
diff --git a/lib/sasacore/register.ml b/lib/sasacore/register.ml
index 1b0f03a7..fcbdf4ce 100644
--- a/lib/sasacore/register.ml
+++ b/lib/sasacore/register.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 25/09/2019 (at 10:22) by Erwan Jahier> *)
+(* Time-stamp: <modified the 07/10/2019 (at 10:00) by Erwan Jahier> *)
type 's neighbor = {
state: 's ;
diff --git a/lib/sasacore/register.mli b/lib/sasacore/register.mli
index a14c13f8..c8dd828d 100644
--- a/lib/sasacore/register.mli
+++ b/lib/sasacore/register.mli
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 30/09/2019 (at 17:25) by Erwan Jahier> *)
+(* Time-stamp: <modified the 07/10/2019 (at 10:00) by Erwan Jahier> *)
(** This module duplicates and extends the Algo module with get_*
functions.
diff --git a/lib/sasacore/topology.ml b/lib/sasacore/topology.ml
index 3b7f61d4..b5678796 100644
--- a/lib/sasacore/topology.ml
+++ b/lib/sasacore/topology.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 05/07/2019 (at 16:32) by Erwan Jahier> *)
+(* Time-stamp: <modified the 07/10/2019 (at 16:32) by Erwan Jahier> *)
open Graph
open Graph.Dot_ast
@@ -140,3 +140,70 @@ let (to_adjency: t -> bool array array) =
)
t.nodes;
m
+let (get_degree:t -> int*int) =
+ fun t -> if t.nodes = [] then 0,0
+ else
+ let node_deg n = List.length (t.succ (n.id)) in
+ let d_start = node_deg ((List.hd t.nodes)) in
+ List.fold_left (fun (d_min,d_max) n ->
+ (min (node_deg n) d_min, max (node_deg n) d_max)
+ ) (d_start,d_start) (List.tl t.nodes)
+
+(* take a graph t and a boolean is_oriented and return the number of
+ link in the graph *)
+let (get_nb_link: t -> bool -> int) =
+ fun t is_oriented ->
+ if not is_oriented then
+ (List.fold_left
+ (fun acc n -> ((List.length (t.succ n.id))) + acc) (0) (t.nodes)) / 2
+ else
+ (List.fold_left
+ (fun acc n -> ((List.length (t.succ n.id))) + acc) (0) (t.nodes))
+
+let (get_mean_degree : t -> float) =
+ fun t ->
+ (float_of_int (get_nb_link t true)) /. (float_of_int (List.length t.nodes))
+
+let bfs : (t -> string -> bool * string list) =
+ fun t n ->
+ let q = Queue.create () in
+ let discovered = ref [n] and parent = ref (function _ -> "") in
+ let cyclic = ref false in
+ Queue.add n q;
+ while not (Queue.is_empty q) do
+ let node = Queue.take q in
+ parent := List.fold_left (fun parents (_,suc) ->
+ if List.for_all (fun disc -> disc <> suc) !discovered
+ then (
+ Queue.add suc q;
+ discovered := (suc)::!discovered;
+ function a -> if a = suc then node else parents a
+ ) else ((
+ if suc <> (parents node)
+ then
+ cyclic := true);
+ parents
+ )
+ ) !parent (t.succ node)
+
+ done;
+ (!cyclic, !discovered)
+
+let is_connected_and_cyclic : t -> bool*bool =
+ fun t -> match t.nodes with
+ | [] -> (false,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
diff --git a/lib/sasacore/topology.mli b/lib/sasacore/topology.mli
index c04cb057..de5f9305 100644
--- a/lib/sasacore/topology.mli
+++ b/lib/sasacore/topology.mli
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 05/07/2019 (at 16:19) by Erwan Jahier> *)
+(* Time-stamp: <modified the 07/10/2019 (at 16:30) by Erwan Jahier> *)
type node_id = string
type node = {
@@ -19,4 +19,12 @@ val read: string -> t
val to_adjency: t -> bool array array
-
+val get_degree: t -> int*int
+val get_nb_link: t -> bool -> int
+val get_mean_degree : t -> float
+val is_connected_and_cyclic : t -> bool*bool
+val height : string list -> t -> string -> int
+val get_height : t -> string -> int
+
+
+
diff --git a/test/Makefile.inc b/test/Makefile.inc
index 27bad78f..e123147b 100644
--- a/test/Makefile.inc
+++ b/test/Makefile.inc
@@ -1,4 +1,4 @@
-# Time-stamp: <modified the 13/09/2019 (at 11:09) by Erwan Jahier>
+# Time-stamp: <modified the 07/10/2019 (at 11:37) by Erwan Jahier>
DIR=../../_build/install/default
@@ -13,6 +13,9 @@ LIB=-package algo
%.cmxs: %.ml
ocamlfind ocamlopt $(LIB) -shared state.ml $(shell sasa -algo $*.dot) $< -o $@
+%.cma: %.ml
+ ocamlfind ocamlc -a $(LIB) state.ml $(shell sasa -algo $*.dot) $< -o $@
+
%.lut: %.dot %.cmxs
$(sasa) -gld $< || echo "==> ok, I'll use the existing $@ file"
--
GitLab