Commit e76aa9be authored by erwan's avatar erwan
Browse files

New: Add support for transition weights

parent 21e43d9e
Pipeline #25698 passed with stages
in 9 minutes and 37 seconds
(* Time-stamp: <modified the 20/06/2019 (at 11:19) by Erwan Jahier> *)
(* Time-stamp: <modified the 21/06/2019 (at 11:35) by Erwan Jahier> *)
open Sasacore
......@@ -10,6 +10,7 @@ type 's neighbor = {
state: 's ;
pid: unit -> string;
reply: unit -> int;
weight: unit -> int option;
}
type 's enable_fun = 's neighbor list -> 's -> action list
......@@ -35,6 +36,7 @@ let (to_reg_neigbor : 's Register.neighbor -> 's neighbor) =
state = n.Register.state ;
pid = n.Register.pid;
reply = n.Register.reply;
weight = n.Register.weight;
}
let (to_reg_enable_fun : 's enable_fun ->
......
(* Time-stamp: <modified the 19/06/2019 (at 17:41) by Erwan Jahier> *)
(* Time-stamp: <modified the 21/06/2019 (at 14:00) by Erwan Jahier> *)
(** Process programmer API *)
type 's neighbor = {
......@@ -11,6 +11,7 @@ type 's neighbor = {
if the neigbor can not access to the process, which may happen in
directed graphs only. This info is not available in all simulation
modes. *)
weight: unit -> int option; (* may be available in directed graphs only *)
}
type algo_id = string
......
(* Time-stamp: <modified the 19/06/2019 (at 10:51) by Erwan Jahier> *)
(* Time-stamp: <modified the 21/06/2019 (at 11:34) by Erwan Jahier> *)
type 's neighbor = {
state: 's ;
pid: unit -> string;
reply: unit -> int;
weight: unit -> int option;
}
type algo_id = string
......
(* Time-stamp: <modified the 19/06/2019 (at 11:28) by Erwan Jahier> *)
(* Time-stamp: <modified the 21/06/2019 (at 11:34) by Erwan Jahier> *)
type 's neighbor = {
state: 's ;
pid: unit -> string;
reply: unit -> int;
weight: unit -> int option;
}
type algo_id = string
......
(* Time-stamp: <modified the 20/06/2019 (at 16:12) by Erwan Jahier> *)
(* Time-stamp: <modified the 21/06/2019 (at 11:33) by Erwan Jahier> *)
open Register
open Sasacore
......@@ -19,7 +19,7 @@ let (reply: Topology.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
| (_w,x)::t -> if x=p then i else f (i+1) t
in
f 0 (g.succ p_neighbor)
......@@ -27,7 +27,7 @@ let (get_neighors: Topology.t -> Topology.node_id -> 'v -> 'v Register.neighbor
fun g source_id init ->
let idl = g.succ source_id in
List.map
(fun neighbor_id ->
(fun (w, neighbor_id) ->
let node = g.of_id neighbor_id in
{
state = init;
......@@ -35,6 +35,7 @@ let (get_neighors: Topology.t -> Topology.node_id -> 'v -> 'v Register.neighbor
identified, etc. *)
pid = (fun () -> node.id);
reply = (fun () -> reply g source_id neighbor_id);
weight = (fun () -> w)
}
)
idl
......
(* Time-stamp: <modified the 07/06/2019 (at 16:45) by Erwan Jahier> *)
(* Time-stamp: <modified the 21/06/2019 (at 14:52) by Erwan Jahier> *)
open Graph
open Graph.Dot_ast
......@@ -13,14 +13,14 @@ type node = {
type t = {
nodes: node list;
succ: node_id -> node_id list;
succ: node_id -> (int option * node_id) list;
of_id: node_id -> node;
}
type node_info_t = (string, node) Hashtbl.t
let node_info:node_info_t = Hashtbl.create 100
type node_succ_t = (string, string list) Hashtbl.t
type node_succ_t = (string, (int option * node_id) list) Hashtbl.t
let node_succ:node_succ_t = Hashtbl.create 100
let (of_id:Dot_ast.id -> string) =
......@@ -29,7 +29,7 @@ let (of_id:Dot_ast.id -> string) =
let (of_node_id:Dot_ast.node_id -> string) = fun id -> of_id (fst id)
let (of_node:Dot_ast.node -> string) = function
| NodeId node_id -> of_node_id node_id
| NodeSub _subgraph -> assert false
| NodeSub _subgraph -> failwith "subgraphs are not supported in sasa "
let (get_file: Dot_ast.node_id -> Dot_ast.attr list -> string) =
......@@ -64,6 +64,13 @@ let (get_init: Dot_ast.attr list -> (string * string) list ) =
attrs
in
init_list
let rec (get_weight: Dot_ast.attr -> int option ) =
function
| (Ident "weight", Some Number n)::_ -> (try Some (int_of_string n) with _ -> None)
| _::tail -> get_weight tail
| [] -> None
let (do_stmt: bool -> node list -> Dot_ast.stmt -> node list) =
fun directed n stmt ->
......@@ -74,8 +81,8 @@ let (do_stmt: bool -> node list -> Dot_ast.stmt -> node list) =
let node = { id=id ; file = get_file node_id attrs ; init = inits } in
Hashtbl.replace node_info id node;
node::n
| Edge_stmt (node, nodes, _attrs) ->
let node = of_node node in
| Edge_stmt (dot_node, nodes, attrs) ->
let node = of_node dot_node in
let nodes = List.map of_node nodes in
(* for egdes written "a -- b -- c -- d", which
is a shortcut for "
......@@ -87,14 +94,16 @@ let (do_stmt: bool -> node list -> Dot_ast.stmt -> node list) =
which is weird IMHO.
The code below add the missing edges:
*)
let attrs = List.flatten attrs in (* XXX why a list of list ? *)
let weight = if directed then get_weight attrs else None in
let add_edge n1 n2 =
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
Hashtbl.replace node_succ n1 (n2::pn1);
if not directed then Hashtbl.replace node_succ n2 (n1::pn2);
Hashtbl.replace node_succ n1 ((weight,n2)::pn1);
if not directed then Hashtbl.replace node_succ n2 ((None,n1)::pn2);
n2
in
ignore (List.fold_left add_edge node nodes);
......
(* Time-stamp: <modified the 07/06/2019 (at 16:45) by Erwan Jahier> *)
(* Time-stamp: <modified the 21/06/2019 (at 11:30) by Erwan Jahier> *)
type node_id = string
type node = {
......@@ -10,7 +10,7 @@ type node = {
type t = {
nodes: node list;
succ: node_id -> node_id list;
succ: node_id -> (int option * node_id) list;
of_id: node_id -> node;
}
......
digraph ring7 {
p1 [algo="ringroot.ml" init="v=1" ]
p2 [algo="ring.ml" init="v=3" ]
p3 [algo="ring.ml" init="v=3" ]
p4 [algo="ring.ml" init="v=2" ]
p5 [algo="ring.ml" init="v=2" ]
p6 [algo="ring.ml" init="v=1" ]
p7 [algo="ring.ml" init="v=1" ]
p8 [algo="ring.ml" init="v=0" ]
p1 -> p2 [weight=10]
p2 -> p3 [weight=10]
p3-> p4
p4 -> p5 [weight=10]
p5 -> p6
p6 -> p7 -> p8 [weight=10]
p8-> p1
}
(* Time-stamp: <modified the 19/06/2019 (at 15:34) by Erwan Jahier> *)
(* Time-stamp: <modified the 21/06/2019 (at 14:49) by Erwan Jahier> *)
open Algo
......
......@@ -8,6 +8,7 @@ graph ring7 {
p6 [algo="unison.ml"]
p7 [algo="unison.ml"]
p1 -- p2 -- p3 -- p4 -- p5 -- p6 -- p7 -- p1
p1 -- p2 [weight=10]
p2 -- p3 -- p4 -- p5 -- p6 -- p7 -- p1
}
(* Time-stamp: <modified the 19/06/2019 (at 15:47) by Erwan Jahier> *)
(* Time-stamp: <modified the 21/06/2019 (at 14:47) by Erwan Jahier> *)
open Algo
......
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