(* Time-stamp: <modified the 09/05/2019 (at 21:59) 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 ".cmxs" 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: Process.t list -> (string * string) list) = fun 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 = List.flatten (List.map (fun p -> List.map (fun a -> (Printf.sprintf "Enab_%s_%s" p.pid a),"bool") p.actions) pl) in algo_vars @ action_vars let (env_rif_decl: Process.t list -> string) = fun pl -> let ssl = get_outputs_rif_decl 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.generate_rdbg_load_files then ( let fn = Printf.sprintf "load-%s.ml" args.topo in if Sys.file_exists fn then ( Printf.eprintf "%s already exists: rename it to update.\n" fn; flush stderr; exit 0 ) else let oc = open_out fn in let files = List.fold_left (fun acc n -> let f = (Filename.chop_extension n.Topology.file) ^ ".cma" in if List.mem f acc then acc else f::acc) [] nl in let loadl = List.map (fun s -> Printf.sprintf "#load \"%s\"" s) files in Printf.fprintf oc "%s" (String.concat "\n" loadl); flush oc; close_out oc; 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 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_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