initial commit

.gitignore

+*~
+*.cm*
+_build/
+*.install
+bin/dune-project
+.merlin
\ No newline at end of file

Makefile

+
+
+install:
+	dune build @install
+
+build:
+	dune build 
+
+.PHONY:test
+test:
+	cd test; make
+
+clean:
+	rm -f *.cmxs sasa *.cmi *.o *.cmx *.pdf
+	dune clean
+	cd test; make clean

bin/Makefile

+
+
+all:
+	dune build sasa.exe
+
+
+install:
+	dune build @install
+
+clean:
+	rm -f *.cmxs sasa *.cmi *.o *.cmx *.pdf
+	dune clean

bin/demon.ml

+(* Time-stamp: <modified the 21/02/2019 (at 11:00) by Erwan Jahier> *)
+
+type t = Synchrone | Random1 | Random | Custom
+
+let (random_list : 'a list -> 'a) = fun l ->
+  assert (l <> []);
+  List.nth l (Random.int (List.length l))
+
+let (random1: 'a list list -> 'a list) =
+  fun all -> 
+   let al = List.map random_list all in
+   let a = random_list al in
+   [a]
+
+let rec (random: 'a list list -> 'a list) =
+  fun all ->
+    assert (all <> []);
+    let al = List.map random_list all in
+    let al = List.filter (fun _ -> Random.bool ()) al in
+    if al = [] then random all else al
+   
+let (synchrone: 'a list list -> 'a list) = fun all -> 
+  let al = List.map random_list all in
+  al
+      
+let (f: t -> 'a list list -> 'a list) = fun demon all ->
+  match demon with
+  | Synchrone  -> synchrone all
+  | Random1 -> random1 all
+  | Random -> random all
+  | Custom -> assert false
+
+
+      

bin/demon.mli

+(* Time-stamp: <modified the 21/02/2019 (at 11:04) by Erwan Jahier> *)
+
+type t =
+  | Synchrone (* select all actions *) 
+  | Random1 (* select 1 action *)
+  | Random (* select at least one action *)
+  | Custom
+
+(** At the inner list level, exactly one action is chosen.
+    At the outter list level, the number of chosen actions
+    depends on the kind of demons.
+  *)
+val f : t -> 'a list list -> 'a list
+

bin/dune

+;; Time-stamp: <modified the 21/02/2019 (at 16:31) by Erwan Jahier>
+
+(executable
+ (name sasa)
+ (libraries dynlink ocamlgraph algo)
+)
+
+(install
+ (section bin)
+ (files (sasa.exe as sasa)))
+

bin/env.ml

+
+(* module Dico = Map.Make(struct type t = string * string let compare = compare end) *)
+
+module Dico = Map.Make(String)
+
+open Algo
+(*
+module Dico = Map.Make(String)
+type t = value Dico.t Dico.t 
+*)
+type t = local_env Dico.t 
+
+let (get: t -> string -> string -> value) =
+  fun e pid v ->
+    try ((Dico.find pid e) v)
+    with _ -> failwith (Printf.sprintf "Unknown value: %s.%s" pid v)
+      
+let (set: t -> string -> string -> value -> t) =
+  fun e pid v value ->
+    Dico.add pid (fun x -> if x=v then value else Dico.find pid e x) e
+
+let (init:unit -> t) = fun () -> Dico.empty
+

bin/env.mli

+
+type t
+
+val init: unit -> t
+val get: t -> string -> string -> Algo.value
+val set: t -> string -> string -> Algo.value -> t
+

bin/process.ml

+(* Time-stamp: <modified the 21/02/2019 (at 11:29) by Erwan Jahier> *)
+
+type t = {
+  pid : string;
+  variables : Algo.vars;
+  init : Algo.local_env;
+  enable : Algo.enable_fun;
+  step : Algo.step_fun ;
+  (* le demon choisi quelle action activer *)
+}
+
+(** called by sasa ; not part of the process programmer API *)
+let (make: Topology.node -> t) =
+  fun n ->
+    let pid = n.Topology.id in
+    let cmxs = n.Topology.file in
+    let id = Filename.chop_suffix cmxs ".cmxs" in
+    if !Algo.verbose_level > 0 then Printf.printf "Loading %s...\n" cmxs;
+    (* TODO: should I prevent the same cmxs to be loaded twice? Not clear. *)
+    Dynlink.loadfile cmxs;
+    let vars = Algo.get_vars id in
+    let init_env = Algo.get_init_vars id vars in
+    (*     let (string_to_value: string -> Algo.value) = *)
+    let init_env v =
+      match List.assoc_opt v n.Topology.init with
+        None -> init_env v
+      | Some x -> (
+          match List.assoc_opt v vars with
+          | Some(Algo.It)
+          | Some(Algo.Nt) -> I (int_of_string x)
+          | Some(Algo.Bt) -> B (bool_of_string x)
+          | Some(Algo.Ft) -> F (float_of_string x)
+          | Some(Algo.Et _i) -> I (int_of_string x)
+          | None -> failwith (Printf.sprintf "%s is not a variable of program %s" v cmxs)
+        )
+    in 
+    let process = {
+      pid = pid; 
+      variables = vars ;
+      init = init_env ;
+      enable = Algo.get_enable id; 
+      step = Algo.get_step id;
+    }
+    in
+    process
+

bin/process.mli

+(* Time-stamp: <modified the 18/02/2019 (at 15:39) by Erwan Jahier> *)
+
+type t = {
+  pid : string; (* unique *)
+  variables : Algo.vars;
+  init : Algo.local_env;
+  enable : Algo.enable_fun; 
+  step : Algo.step_fun  ;
+}
+
+(** build a process and set its variable initial values *)
+val make: Topology.node -> t

bin/sasa.ml

+(* Time-stamp: <modified the 21/02/2019 (at 11:30) by Erwan Jahier> *)
+
+(* XXX Je pourrais utiliser Lwt pour rendre step non-bloquant, ce qui
+   permettrait d'accelerer la simu sur les machines qui ont plusieurs
+   coeurs
+
+  step : action -> (string -> value) Lwt.t ;
+*)
+
+open Algo
+
+let (to_process: Env.t -> Topology.node -> Env.t * Process.t) =
+  fun e n ->
+    let p = Process.make n in
+    let e = List.fold_left
+        (fun e (n,_t) -> Env.set e p.pid n (p.init n))
+        e
+        p.variables
+    in
+    e, p
+             
+let (to_process_list : Env.t -> Topology.node list -> Env.t * Process.t list) =
+  fun e nl ->
+    List.fold_left
+      (fun (e,pl) n -> let e,p= to_process e n in e,p::pl)
+      (e,[]) nl
+    
+
+(* Should be called after [to_process] has been called on all
+   Topology.nodes, which is ensured by the [process_are_created] ref
+*)
+let process_are_created = ref false
+let (get_neighors: Process.t -> Topology.neighbor list) =
+  fun p ->
+    assert (!process_are_created);
+    let id = p.Process.pid in
+    let idl = try Hashtbl.find Topology.node_succ id with Not_found  -> [] in
+    List.map
+      (fun id ->
+         let node =
+           try Hashtbl.find Topology.node_info id with Not_found -> assert false
+         in
+         let algo_id = Filename.chop_suffix node.file ".cmxs" in
+          {
+            Topology.n_id = node.id;
+            Topology.n_vars = Algo.get_vars algo_id;
+          }
+      )
+      idl
+
+let (dump_process: Process.t * Topology.neighbor list -> unit) =
+  fun (p,nl) ->
+    let pvars = StringOf.algo_vars p.variables in
+    let neighbors = List.map StringOf.topology_neighbor nl in
+    Printf.printf "process %s\n\tvars:%s\n\tneighors: \n\t\t%s\n" p.pid  pvars
+      (String.concat "\n\t\t" neighbors)
+
+let (update_env: Env.t -> Process.t * Algo.local_env -> Env.t) =
+  fun e (p, lenv) -> 
+    List.fold_left
+      (fun e (n,_) -> Env.set e p.pid n (lenv n))
+      e
+      p.variables
+
+open Process
+
+let (to_algo_neighbor: Env.t -> Topology.neighbor -> Algo.neighbor) =
+  fun e n ->
+    { 
+      lenv= Env.get e n.Topology.n_id;
+      n_vars = n.Topology.n_vars
+    }
+
+let rec (simu: int -> int -> Process.t list ->
+         (Process.t * Topology.neighbor list) list -> Env.t -> unit) =
+  fun n i pl pl_n e ->
+    let all = List.fold_left
+        (fun acc (p,nl) ->
+           let nl4algo = List.map (to_algo_neighbor e) nl in
+           let lenv = Env.get e p.pid in
+           let al = p.enable nl4algo lenv in
+           let al = List.map (fun a -> p,nl,a) al in
+           if al <> [] then al::acc else acc)
+        [] pl_n
+    in
+    assert (all <> []);
+    let al = Demon.f Demon.Random all in
+
+    (* Do the steps *)
+    let lenv_list =
+      List.map (fun (p,nl,a) ->
+          let nl4algo = List.map (to_algo_neighbor e) nl in
+          let lenv = Env.get e p.pid in
+          p, p.step nl4algo lenv a)
+        al
+    in
+    (* update the env *)
+    let ne = List.fold_left update_env e lenv_list in
+
+    let al_str =
+      String.concat "," (List.map (fun (p,_,_a) -> Printf.sprintf "%s" p.pid) al)
+    in
+    Printf.eprintf "step %s: %s (%s)\n" (string_of_int (n-i)) (StringOf.env e pl) al_str;
+    match all with
+    | [_] -> ()
+    | [] -> assert false
+    | _ ->  if i > 0 then simu n (i-1) pl pl_n ne else ()
+
+let () =
+  let dot_file = Sys.argv.(1) in
+  let nl = Topology.read dot_file in
+  let nstrl = List.map (fun n -> n.Topology.id) nl in
+  let nstr = String.concat "," nstrl in
+  try
+    Algo.verbose_level :=1;
+    Random.self_init();
+    Printf.printf "nodes: %s\nedges:\n" nstr;
+    let e = Env.init () in
+    let e, pl = to_process_list e nl in
+    process_are_created := true;
+    let neighors = List.map get_neighors pl in
+    let pl_n = List.combine pl neighors in
+    List.iter dump_process pl_n;
+    let n = (int_of_string Sys.argv.(2)) in
+    simu n n pl pl_n e
+  with Dynlink.Error e -> Printf.printf "E: %s\n"(Dynlink.error_message e)

bin/sasa.opam

+

bin/stringOf.ml

+
+open Algo
+let (algo_varT: Algo.varT -> string) = function
+  | It -> "int"
+  | Nt -> "pos_int"
+  | Ft -> "float"
+  | Bt -> "bool"
+  | Et i -> Printf.sprintf "enum(%d)" i
+
+let (algo_vars : Algo.vars -> string) = fun vars -> 
+  String.concat "," (List.map (fun (n,t) -> Printf.sprintf "%s:%s" n (algo_varT t)) vars)
+
+open Topology
+let (topology_neighbor :Topology.neighbor -> string) = fun n ->
+  Printf.sprintf "%s (%s)" n.n_id (algo_vars n.n_vars)
+
+open Process
+let (env: Env.t -> Process.t list -> string) =
+  fun env pl ->
+    let ll = List.map 
+        (fun p ->
+           List.map
+             (fun (n,_) ->
+                Printf.sprintf "%s.%s->%s" p.pid n
+                  (Algo.value_to_string (Env.get env p.pid n)))
+             p.variables)
+        pl
+    in
+    String.concat ", " (List.flatten ll)

bin/topology.ml

+(* Time-stamp: <modified the 21/02/2019 (at 11:31) by Erwan Jahier> *)
+
+open Graph
+open Graph.Dot_ast
+
+type node_id = string
+type node = {
+  id: node_id;
+  file: string;
+  init: (string * string) list; 
+}
+
+type edge = node_id * node_id list
+
+type t = node list
+
+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
+let node_succ:node_succ_t = Hashtbl.create 100
+        
+let (of_id:Dot_ast.id -> string) =
+  function Ident str | Html str | Number str | String str -> str
+
+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    
+
+
+let (get_file: Dot_ast.node_id  -> Dot_ast.attr list -> string) =
+  fun node_id attrs ->
+    let attrs = List.flatten attrs in (* XXX why a list of list ? *)
+    try  (
+        match List.assoc (Ident "algo") attrs with
+          None -> assert false
+        | Some id -> of_id id
+      ) 
+    with Not_found -> failwith ((of_node_id node_id)^" should have an algo attribute")
+
+let (get_init: Dot_ast.attr list -> (string * string) list ) =
+  fun attrs ->
+    let attrs = List.flatten attrs in (* XXX why a list of list ? *)
+    let init_list =
+      List.fold_left
+        (fun acc (id,idopt) ->
+           if id <> Ident "init" then acc else
+             match idopt with
+             | Some (String id) -> (
+                 try
+                   let i = String.index id '=' in
+                   let l = String.length id in
+                   (String.sub id 0 i, String.sub id (i+1) (l-i-1))::acc
+                 with
+                   Not_found -> acc
+               )
+             | _ -> acc
+        )
+        []
+        attrs
+    in
+    init_list
+      
+let (do_stmt: bool -> node list -> Dot_ast.stmt -> node list) =
+  fun directed n stmt ->
+    match stmt with
+    | Node_stmt (node_id, attrs) ->
+      let id = of_node_id node_id in
+      let inits = get_init attrs  in
+      let node = { id=id ; file = get_file node_id attrs ; init = inits } in
+      if Hashtbl.mem node_info id then
+        failwith (id ^ " defined twice")
+      else
+         Hashtbl.add node_info id node;
+      node::n
+    | Edge_stmt (node, nodes, _attrs) ->
+      let node = of_node node in
+      let nodes = List.map of_node nodes in
+        (* for egdes written "a -- b -- c -- d", which
+           is a shortcut for "
+           a -- b
+           b -- c
+           c -- d
+           "
+           Graph.Dot.parse_dot_ast returns the pair a,[b,c,d]
+           which is weird IMHO.   
+           The code below add the missing edges:
+        *)
+      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);
+        n2
+      in
+      ignore (List.fold_left add_edge node nodes);
+      n
+    | Attr_graph _attrs -> n
+    | Attr_node  _attrs -> n 
+    | Attr_edge  _attrs ->  n
+    | Equal (_id1, _id2) -> assert false
+    | Subgraph _subgraph -> assert false
+
+
+let (read: string -> t) = fun f ->
+  let dot_file = Graph.Dot.parse_dot_ast f in
+  assert (not dot_file.strict);
+  List.fold_left (do_stmt dot_file.digraph) [] dot_file.stmts
+
+type neighbor = {
+  n_id:  string;
+  n_vars: (string * Algo.varT) list;
+}

bin/topology.mli

+(* Time-stamp: <modified the 18/02/2019 (at 15:31) by Erwan Jahier> *)
+
+type node_id = string
+type node = {
+  id: node_id;
+  file: string;
+  init: (string * string) list; 
+}
+
+type edge = node_id * node_id list
+
+type t = node list
+
+(* neighbor view from the sasa: in Algo.neighbor we hide the pid and
+   compute the lenv *)
+type neighbor = { 
+  n_id:  string; 
+  n_vars: (string * Algo.varT) list;
+}
+
+type node_info_t = (string, node) Hashtbl.t
+val node_info : node_info_t 
+
+type node_succ_t = (string, string list) Hashtbl.t
+val node_succ : node_succ_t 
+
+(** Parse a dot file 
+XXX side effect: and fills the node_info and node_succ tables 
+XXX good idea ?
+*)
+val read: string -> t

dune-project

+(lang dune 1.2.1)

lib/algo/#dune#

+;; Time-stamp: <modified the 21/02/2019 (at 16:17) by Erwan Jahier>
+
+(library
+ (name     algo)
+ (public_name  algo)
+ (synopsis "The Sasa Algo API"))
+
+(install
+ (section lib)
+ (package algo)
+ (files algo.cmxa)
+)

lib/algo/Makefile

+
+
+all:
+	dune build 
+
+
+install:
+	dune build @install
+
+clean:
+	rm -f *.cmxs sasa *.cmi *.o *.cmx *.pdf
+	dune clean

lib/algo/algo.ml

+(* Time-stamp: <modified the 06/03/2019 (at 17:17) by Erwan Jahier> *)
+
+(** Process programmer API *)
+type varT = It | Nt | Ft | Bt | Et of int 
+type action = string (* juste un label *)
+type value = I of int | F of float | B of bool | S of string
+type local_env = string -> value
+
+type vars = (string * varT) list
+type neighbor = {
+  (*   n_id:  string; (* to hide? *) *)
+  lenv:  local_env;
+  n_vars: vars;
+}
+
+type enable_fun = neighbor list -> local_env -> action list
+type step_fun   = neighbor list -> local_env -> action -> local_env
+
+type int_tables = {
+  vars: (string, vars)  Hashtbl.t;
+  init_vars: (string, local_env)  Hashtbl.t;
+  enable: (string, enable_fun) Hashtbl.t;
+  step: (string, step_fun) Hashtbl.t;
+}
+
+
+
+let tbls = {
+  vars = Hashtbl.create 1;
+  init_vars = Hashtbl.create 1;
+  enable = Hashtbl.create 1;
+  step = Hashtbl.create 1;
+}
+
+let verbose_level = ref 0
+
+let value_to_string = function
+  | I i -> string_of_int i
+  | F f -> string_of_float f
+  | B true -> "t" 
+  | B false -> "f" 
+  | S str -> str
+    
+exception Unregistred of string * string
+
+let print_table lbl tbl =
+  let keys = Hashtbl.fold (fun k _ acc -> Printf.sprintf "%s,%s" k acc)  tbl "" in
+  if !verbose_level > 0 then Printf.printf "Defined keys for %s: %s\n" lbl keys;
+  flush stdout
+    
+type algo_id = string
+
+let (reg_vars : algo_id -> (string * varT) list -> unit) = fun algo_id x ->
+  if !verbose_level > 0 then Printf.printf "Registering %s vars\n" algo_id;
+  flush stdout;
+  Hashtbl.replace tbls.vars  algo_id x
+let (get_vars : string -> (string * varT) list) = fun algo_id ->  
+  try Hashtbl.find tbls.vars  algo_id
+  with Not_found ->
+    print_table "vars" tbls.vars;
+    raise (Unregistred ("variable", algo_id))
+
+let (reg_init_vars : algo_id -> local_env -> unit) = fun algo_id x ->
+  if !verbose_level > 0 then Printf.printf "Registering %s init_vars\n" algo_id;
+  flush stdout;
+  Hashtbl.replace tbls.init_vars algo_id x
+let (get_init_vars : algo_id ->  (string * varT) list -> local_env) =
+  fun algo_id vars ->  
+  try Hashtbl.find tbls.init_vars algo_id
+  with Not_found ->
+    (fun v ->
+       match List.find_opt (fun (x,_t) -> x=v) vars with
+         None -> failwith (v^" unknown var")
+       | Some(_,It)
+       | Some(_,Nt) -> I (Random.int 100000)
+       | Some(_,Bt) -> B (Random.bool ())
+       | Some(_,Ft) -> F (Random.float max_float)
+       | Some(_,Et i) -> I (Random.int i)
+    )
+
+let (reg_enable : algo_id -> enable_fun -> unit) = fun algo_id x -> 
+  if !verbose_level > 0 then Printf.printf "Registering %s enable\n" algo_id;
+  flush stdout;
+  Hashtbl.replace tbls.enable  algo_id x
+let (get_enable : algo_id -> enable_fun) = fun algo_id -> 
+  try Hashtbl.find tbls.enable  algo_id
+  with Not_found ->
+    print_table "enable" tbls.enable;
+    raise (Unregistred ("enable", algo_id))
+
+let (reg_step : algo_id -> step_fun -> unit) = fun algo_id x -> 
+  if !verbose_level > 0 then Printf.printf "Registering %s step\n" algo_id;
+  flush stdout;
+  Hashtbl.replace tbls.step  algo_id x
+let (get_step : algo_id -> step_fun) = fun algo_id -> 
+  try Hashtbl.find tbls.step  algo_id
+  with Not_found ->
+    print_table "step" tbls.step;
+    raise (Unregistred ("step", algo_id))