sasa.ml

(* Time-stamp: <modified the 15/05/2019 (at 16:05) by Erwan Jahier> *)

open Algo
open Sasacore


let (update_env_with_init : Env.t -> Process.t list -> Algo.neighbor list list
     -> Env.t) =
  fun e pl neighbors ->
    let (aux: Env.t -> Process.t -> Algo.neighbor list -> Env.t) =
      fun e p nl ->
        List.fold_left
          (fun e (n,_t) -> Env.set e p.pid n (p.init nl n))
          e
          p.variables
    in
    List.fold_left2 aux e pl neighbors

let (reply: Topology.t -> string -> string -> int) =
  fun g source target  ->
    let rec f i = function
      | [] -> (-1) (* may happen in directed graphs *) 
      | x::t -> if x=source then i else f (i+1) t
    in
    f 0 (g.succ target)

let (get_neighors: Topology.t -> Env.t -> Process.t -> Algo.neighbor list) =
  fun g e p ->
    let source_id = p.Process.pid in
    let idl = g.succ source_id in
    List.map
      (fun id ->
         let node = g.of_id id in
         let algo_id = Filename.chop_suffix node.file ".ml" in
         {
           lenv= Env.get_copy e node.id;
           n_vars = Algo.get_vars algo_id;
           (* XXX For the 2 fields above, check the graph kind (anonymous,
              identified, etc. *)
           pid = (fun () -> node.id);
           reply = (fun () -> reply g source_id id);
          }
      )
      idl

let (dump_process: Process.t * 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)

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
open SasArg
    
let (update_neighbor_env: Env.t -> Algo.neighbor -> Algo.neighbor) =
  fun e n ->
    { n with lenv= Env.get_copy e (n.Algo.pid ())}

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

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

let (get_enable_processes: layout -> Env.t -> 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 : (Process.t * Algo.neighbor list * action) list -> Env.t -> 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 t = SasArg.t * layout * Env.t


let (get_inputs_rif_decl: SasArg.t -> 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 -> 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 -> 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 -> 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 nstrl = List.map (fun n -> n.Topology.id) nl in
      let nstr = String.concat "," nstrl in
      Algo.verbose_level := args.verbose;
      Random.init args.seed;
      if !Algo.verbose_level > 0 then Printf.eprintf "nodes: %s\nedges:\n" nstr;
      let e = Env.init () in
      let pl = List.map (Process.make dynlink (args.demon=Custom)) nl in
      let algo_neighors = List.map (get_neighors g e) pl in
      let e = update_env_with_init e pl algo_neighors 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