Skip to content

GitLab

Commit 961de148 authored by erwan's avatar erwan
Browse files

Update: move the functions relative to topology that were in main.ml in topology.ml 

as it is where they belong.
parent cc34e3f5
Pipeline #30296 passed with stages
in 1 minute and 46 seconds
Hide whitespace changes
Inline Side-by-side
lib/algo/algo.ml
View file @ 961de148
(* 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 *)
......
lib/algo/algo.mli
View file @ 961de148
(* 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;
......
lib/algo/dune
View file @ 961de148
;; 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)
......
lib/sasacore/dune
View file @ 961de148
;; 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)")
)
......
lib/sasacore/main.ml
View file @ 961de148
(* 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
......
lib/sasacore/main.mli
View file @ 961de148
(* 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 =
......
lib/sasacore/register.ml
View file @ 961de148
(* 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 ;
......
lib/sasacore/register.mli
View file @ 961de148
(* 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.
......
lib/sasacore/topology.ml
View file @ 961de148
(* 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
lib/sasacore/topology.mli
View file @ 961de148
(* 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
test/Makefile.inc
View file @ 961de148
# 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"
......
Supports Markdown
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