sasa.ml

(* Time-stamp: <modified the 07/03/2019 (at 16:23) by Erwan> *)

(* 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
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
    }

exception Silent of int
  
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
    if  (all = []) then raise (Silent i);
    let al = Demon.f args.demon 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
    (*     | [_] -> () *)
    | [] -> raise (Silent i)
    | _ ->  if i > 0 then simu n (i-1) pl pl_n ne else ()

let () =
  ( try SasArg.parse Sys.argv;
	 with
	     Failure(e) ->
	       output_string stdout e;
	       flush stdout ;
	       exit 2
	   | e ->
	     output_string stdout (Printexc.to_string e);
	     flush stdout;
	     exit 2
  );


  let dot_file = SasArg.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
  try
    Algo.verbose_level := SasArg.args.verbose;
    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 = SasArg.args.length in
    simu n n pl pl_n e
  with
  | Dynlink.Error e -> Printf.printf "E: %s\n"(Dynlink.error_message e)
  | Silent i -> Printf.printf "This algo is silent after %i steps\n" i