sasa.ml

(* Time-stamp: <modified the 18/03/2019 (at 09:21) 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
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 (get_neighors: Process.t -> Topology.neighbor list) =
  fun p ->
    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
open SasArg
    
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 (print_step : int -> int -> SasArg.t -> Env.t -> Process.t list -> string ->
     string -> unit) =
  fun n i args e pl activate_val enable_val ->
    if args.rif then (
      if args.demon = Demon.Custom then (
        (* in custom mode, to be able to talk with lurette, this should not be 
           printed on stdout
        *)
        Printf.eprintf "\n#step %s\n" (string_of_int (n-i+1)) ;
        Printf.eprintf "%s #outs " activate_val; flush stderr
      ) else (
        Printf.printf "\n#step %s\n" (string_of_int (n-i+1)) ;
        Printf.printf "%s #outs " activate_val; flush stdout
      );
      Printf.printf "%s %s\n" (StringOf.env_rif e pl) enable_val;
      flush stdout
    )
    else (
      Printf.eprintf "step %s: %s %s\n"
        (string_of_int (n-i+1)) (StringOf.env e pl) activate_val;
      flush stderr
    )

exception Silent of int

let  (simustep: int -> int -> SasArg.t -> Process.t list -> string -> 
      (Process.t * Topology.neighbor list) list -> Env.t -> Env.t * string) =
  fun n i args pl activate_val pl_n e ->
    (* 1: Get enable processes *)
    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
           al::acc)
        [] pl_n
    in
    assert (List.length pl = 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
        all
    in
    let enable_val =
      String.concat " " (List.map (fun b -> if b then "t" else "f")
                           (List.flatten enab_ll))
    in
    if (List.flatten all = []) then (
      print_step n i args e pl activate_val enable_val; 
      raise (Silent (n-i+1))
    );
    print_step n i args e pl activate_val enable_val;
    let next_activate_val, pnal =
      Demon.f (args.verbose > 1) args.demon pl all enab_ll
    in
    (* 2: 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)
        pnal
    in
    (* 3: update the env *)
    let ne = List.fold_left update_env e lenv_list in
    ne, next_activate_val



type t = SasArg.t * Process.t list * (Process.t * Topology.neighbor list) list * Env.t

let (make : string array -> t) =
  fun 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 nl = Topology.read dot_file 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 (args.demon=Custom)) nl in
    let neighors = List.map get_neighors pl in
    let algo_neighors = List.map (List.map (to_algo_neighbor e)) neighors in
    let e = update_env_with_init e pl algo_neighors in
    let pl_n = List.combine pl neighors in
    if !Algo.verbose_level > 0 then List.iter dump_process pl_n;
    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.\n" fn; flush stderr
      ) 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;
      Printf.printf "#inputs %s\n"
        (if args.demon = Demon.Custom then (
            let f p = List.map
                (fun a -> "\""^p.pid ^(if a="" then "" else "_")^a^ "\":bool")
                p.actions
            in
            String.concat " " (List.flatten (List.map f pl))
          ) else "");
      Printf.printf "#outputs %s\n" (StringOf.env_rif_decl 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 a)) p.actions)
        pl;
      Printf.eprintf "Ignoring the first vectors of sasa inputs\n"; flush stderr;
    );
    args, pl, pl_n, e
    with
    | Dynlink.Error e ->
      Printf.printf "Error: %s\n" (Dynlink.error_message e); flush stdout;
      exit 2