sasa.ml

(* Time-stamp: <modified the 12/06/2019 (at 09:57) by Erwan Jahier> *)

open Algo
open Sasacore


let (update_env_with_init : 'v Env.t -> 'v Process.t list -> 'v Env.t) =
  fun e pl ->
    let (aux: 'v Env.t -> 'v Process.t -> 'v Env.t) =
      fun e p ->
        Env.set e p.pid p.init   
    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 *) 
      | 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 Algo.neighbor list) =
  fun g source_id ->
    let idl = g.succ source_id in
    List.map
      (fun neighbor_id ->
         let node = g.of_id neighbor_id in
         let algo_id = Filename.chop_suffix node.file ".ml" in
         let vars = Algo.get_vars algo_id in
         {
           lenv= Algo.empty_env;
           n_vars = vars;
           (* XXX For the 2 fields above, check the graph kind (anonymous,
              identified, etc. *)
           pid = (fun () -> node.id);
           reply = (fun () -> reply g source_id neighbor_id);
          }
      )
      idl

let (dump_process: 'v Process.t * 'v Algo.neighbor list -> unit) =
  fun (p,nl) ->
    let pvars = StringOf.algo_vars p.variables in
    let neighbors = List.map StringOf.algo_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)

open Process

let _string_of_local_env p lenv =
  let value_to_string = Algo.get_value_to_string () in
  List.fold_left
    (fun acc (n,_) -> Printf.sprintf "%s %s=%s" acc n (value_to_string (lenv n)))
    ""
    p.variables 

let (update_env: 'v Env.t -> 'v Process.t * 'v Algo.local_env -> 'v Env.t) =
  fun e (p, lenv) ->
    Env.set e p.pid lenv    

open SasArg
    
let (update_neighbor_env: 'v Env.t -> 'v Algo.neighbor -> 'v Algo.neighbor) =
  fun e n ->
    { n with lenv= Env.get_copy n.Algo.n_vars e (n.Algo.pid ())}

type 'v layout = ('v Process.t * 'v Algo.neighbor list) list

type 'v enable_processes =
  ('v Process.t * 'v Algo.neighbor list * Algo.action) list list * bool list list

let (get_enable_processes: 'v layout -> 'v Env.t -> 'v enable_processes) =
  fun pl_n e ->
    let all = List.fold_left
        (fun acc (p,nl) ->
           let nl4algo = List.map (update_neighbor_env 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
           al::acc)
        [] pl_n
    in
    assert (List.length pl_n = List.length all);
    let all = List.rev all in 
    let enab_ll =
      List.map2
        (fun (p,_) al ->
           let al = List.map (fun (_,_,a) -> a) al in
           List.map (fun a_static -> List.mem a_static al) p.actions)
        pl_n
        all
    in
    all, enab_ll

let (do_step : ('v Process.t * 'v Algo.neighbor list * action) list -> 'v Env.t
     -> 'v Env.t) =
  fun pnal e -> 
    let lenv_list =
      List.map (fun (p,nl,a) ->
          let nl4algo = List.map (update_neighbor_env e) nl in
          let lenv = Env.get e p.pid in
          p, p.step nl4algo lenv a)
        pnal
    in
    (* 4: update the env *)
    let ne = List.fold_left update_env e lenv_list in
    ne
      
type 'v t = SasArg.t * 'v layout * 'v Env.t


let (get_inputs_rif_decl: SasArg.t -> 'v Process.t list -> (string * string) list) =
  fun args pl -> 
    if args.demon <> Custom then
      if args.dummy_input then ["_dummy","bool"] else []
    else 
      let f p = List.map
          (fun a -> p.pid ^(if a="" then "" else "_")^a ,"bool")
          p.actions
      in
      List.flatten (List.map f pl)

let (get_outputs_rif_decl: SasArg.t -> 'v Process.t list -> (string * string) list) =
  fun args pl -> 
    let lll = List.map 
        (fun p ->
           List.map
             (fun (n,vt) ->
                Algo.vart_to_rif_decl vt (Printf.sprintf "%s_%s" p.pid n))
             p.variables)
        pl
    in
    let algo_vars = List.flatten (List.flatten lll) in 
    let action_vars_enab = List.flatten
        (List.map 
           (fun p -> List.map
               (fun a -> (Printf.sprintf "Enab_%s_%s" p.pid a),"bool") p.actions)
           pl)
    in
    let action_vars = if args.demon = Custom then [] else
        List.flatten
          (List.map 
             (fun p -> List.map
                 (fun a -> (Printf.sprintf "%s_%s" p.pid a),"bool") p.actions)
             pl)
    in
    algo_vars @ action_vars_enab @ action_vars
    
let (env_rif_decl: SasArg.t -> 'v Process.t list -> string) =
  fun args pl ->
    let ssl = get_outputs_rif_decl args pl in
    String.concat " "
      (List.map (fun (base, tstr) -> Printf.sprintf "\"%s\":%s" base tstr) ssl)
    


let (make : bool -> string array -> 'v t) =
  fun dynlink argv ->
    let args = 
      try SasArg.parse argv;
	   with
	     Failure(e) ->
	     output_string stdout e;
	     flush stdout ;
	     exit 2
	   | e ->
	     output_string stdout (Printexc.to_string e);
	     flush stdout;
	     exit 2
    in
    try
      let dot_file = args.topo in
      let g = Topology.read dot_file in
      let nl = g.nodes in
      let pidl = List.map (fun n -> n.Topology.id) nl in
      let nstr = String.concat "," pidl in
      Algo.set_card (List.length nl);
      Algo.verbose_level := args.verbose;
      Random.init args.seed;
      if !Algo.verbose_level > 0 then Printf.eprintf "nodes: %s\nedges:\n" nstr;

      let algo_files = List.map (fun n -> n.Topology.file) nl in
      if dynlink then List.iter Process.dynlink_nodes (List.sort_uniq compare algo_files);
      let algo_neighors = List.map (get_neighors g) pidl in
      let pl = List.map2 (Process.make (args.demon=Custom)) nl algo_neighors in
      let e = Env.init () in
      let e = update_env_with_init e pl in
      let pl_n = List.combine pl algo_neighors in
      if !Algo.verbose_level > 0 then List.iter dump_process pl_n;
      if args.output_algos then (
        let fl = List.map (fun n -> Filename.chop_extension n.Topology.file) nl in
        let fl = List.sort_uniq compare fl in
        Printf.printf "%s\n" (String.concat "\n" fl);
        flush stdout;
        exit 0
      );
      if args.gen_lutin then (
        let fn = (Filename.remove_extension args.topo) ^ ".lut" in
        if Sys.file_exists fn then (
          Printf.eprintf "%s already exists: rename it to proceed.\n" fn;
          flush stderr; exit 1
        ) else 
          let oc = open_out fn in
          Printf.fprintf oc "%s" (GenLutin.f pl);
          flush oc;
          close_out oc;
          exit 0);
      if args.rif then (
        Printf.printf "%s"
          (Mypervasives.entete "#" SasaVersion.str SasaVersion.sha);
        if args.demon <> Demon.Custom then
          Printf.printf "#seed %i\n" args.seed;
        let inputs_decl = get_inputs_rif_decl args pl in
        Printf.printf "#inputs %s\n"
          (String.concat " "
             (List.map
                (fun (vn,vt) -> Printf.sprintf "\"%s\":%s" vn vt) inputs_decl));

        Printf.printf "#outputs %s\n" (env_rif_decl args pl);
        flush stdout
      ) else (
        if args.demon <> Demon.Custom then (
          Printf.printf "The pseudo-random engine is used with seed %i\n"
            args.seed;
          flush stdout
        );
      );
      if args.ifi then (
        List.iter
          (fun p -> List.iter
              (fun a -> ignore (RifRead.bool (args.verbose>1) p.pid a)) p.actions)
          pl;
        Printf.eprintf "Ignoring the first vectors of sasa inputs\n";
        flush stderr;
      );
      args, pl_n, e
    with
    | Dynlink.Error e ->
      Printf.printf "Error: %s\n" (Dynlink.error_message e); flush stdout;
      exit 2
    | e ->
      Printf.printf "Error: %s\n" (Printexc.to_string e);
	   flush stdout;
	   exit 2