sasArg.ml

(* Time-stamp: <modified the 02/04/2019 (at 08:25) by Erwan Jahier> *)


type t = {
  mutable topo: string;
  mutable length: int;
  mutable verbose: int;
  mutable demon: Demon.t;
  mutable rif: bool;
  mutable seed: int;
  mutable ifi: bool;
  mutable gen_lutin: bool;
  mutable dummy_input: bool;
  
  mutable _args : (string * Arg.spec * string) list;
  mutable _user_man  : (string * string list) list; 
  mutable _hidden_man: (string * string list) list; 

  mutable _others : string list;
  mutable _margin : int;
}

let usage_msg tool = ("usage: " ^ tool ^ " [<option>]* <topology>.dot 
use -h to see the available options.
" )
let print_usage tool = Printf.printf "%s\n" (usage_msg tool); flush stdout


let (make_args : unit -> t) = 
  fun () -> 
    {
      topo = "";
      length = 10000;
      verbose = 0;
      demon = Demon.Distributed;
      rif = false;
      seed = (Random.self_init (); Random.int 1073741823);
      ifi = false;
      gen_lutin = false;
      dummy_input = false;
      _args = [];        
      _user_man  = [];   
      _hidden_man  = []; 
      _others = [];
      _margin =12;
    }


let pspec args os  (c, ml) = (
  let (m1, oth) = match ml with
	 |	h::t -> (h,t)
	 |	_ -> ("",[])
  in
  let t2 = String.make args._margin ' ' in
  let cl = String.length c in
  let t1 = if (cl < args._margin ) then
	 String.make (args._margin - cl) ' '
  else
	 "\n"^t2
  in
	 Printf.fprintf os "%s%s%s" c t1 m1;
	 List.iter (function x -> Printf.fprintf os "\n%s%s" t2 x) oth ;
	 Printf.fprintf os "\n" ;
)

let options args oc = (
	let l = List.rev args._user_man in
	List.iter (pspec args oc) l
)
let more_options args oc = (
	let l = List.rev (args._hidden_man) in
	List.iter (pspec args oc) l
)
let (mkopt : t -> string list -> ?hide:bool -> ?arg:string -> Arg.spec ->
     string list -> unit) =
  fun opt ol ?(hide=false) ?(arg="") se ml ->
    let treto o = opt._args <- (o, se, "")::opt._args in
	   List.iter treto ol ;
	   let col1 = (String.concat ", " ol)^arg in
	     if hide 
        then opt._hidden_man <- (col1, ml)::opt._hidden_man
	     else opt._user_man   <- (col1, ml)::opt._user_man

let myexit i = exit i

(*** User Options Tab **)
let (mkoptab : string array -> t -> unit) = 
  fun argv args ->  
    (
    mkopt args  ["--synchronous-demon";"-sd"]
      (Arg.Unit(fun () -> args.demon <- Demon.Synchronous))
      ["Use a Synchronous demon"];

    mkopt args  ["--central-demon";"-cd"]
      (Arg.Unit(fun () -> args.demon <- Demon.Central))
      ["Use a Central demon (selects exactly one action)"];
    
    mkopt args  ["--locally-central-demon";"-lcd"]
      (Arg.Unit(fun () -> args.demon <- Demon.LocallyCentral))
      ["Use a Locally Central demon";
       "(i.e., never activates two neighbors actions in the same step)"];
    mkopt args  ["--distributed-demon";"-dd"]
      (Arg.Unit(fun () -> args.demon <- Demon.Distributed))
      ["Use a Distributed demon (which select at least one action)"];
    
    mkopt args  ["--custom-demon";"-custd"]
      (Arg.Unit(fun () -> args.demon <- Demon.Custom;args.rif <- true))
      ["Use a Custom demon (forces --rif)"];

   mkopt args  ["--rif";"-rif"]
      (Arg.Unit(fun () -> args.rif <- true))
      ["Follows RIF conventions"];

    mkopt args  ["--seed";"-seed"]
      (Arg.Int(fun i -> args.seed <- i))
      ["Set the pseudo-random generator seed of build-in demons"];

   mkopt args ~hide:true ["--gen-lutin-demon";"-gld"]
      (Arg.Unit(fun () -> args.gen_lutin <- true))
      ["Generate Lutin demons and exit"];

   mkopt args ~hide:true ["--dummy-input"]
      (Arg.Unit(fun () -> args.dummy_input <- true))
      ["Add a dummy input to sasa so that built-in demon can be used from rdbg"];

    mkopt args ~hide:true ["--ignore-first-inputs"; "-ifi"]
      (Arg.Unit(fun () -> args.ifi <- true))
      ["Ignore first inputs (necessary to use luciole via lurette/rdbg/luciole-rif)"];

    mkopt args ["--length";"-l"] ~arg:" <int>"
      (Arg.Int (fun i -> args.length <- i))
      ["Maximum number of steps to be done (" ^ (string_of_int args.length) ^ " by default).\n"];

    mkopt args ~hide:true ["--version";"-version";"-v"]
      (Arg.Unit (fun _ ->
           (print_string (SasaVersion.str^"-"^SasaVersion.sha^"\n");flush stdout;exit 0)))
      ["Display the sasa version and exit."];

    mkopt args ~hide:true ["--ocaml-version"]
      (Arg.Unit (fun _ -> (print_string (Sys.ocaml_version^"\n"); flush stdout; exit 0)))
      ["Display the version ocaml version sasa was compiled with and exit."];

    mkopt args  ["--verbose";"-vl"] ~arg:" <int>"
      (Arg.Int (fun i -> args.verbose <- i))   ["Set the verbose level"];

    mkopt args ["--help";"-help"; "-h"]
      (Arg.Unit (fun _ -> print_usage (argv.(0)); options args stdout; exit 0))
      ["Display main options"];

    mkopt args ["--more";"-m"] (Arg.Unit (fun () -> more_options args stdout; exit 0)) 
      ["Display more options"]

  )

(* all unrecognized options are accumulated *)
let (add_other : t -> string -> unit) =
  fun opt s -> 
    opt._others <- s::opt._others

let current = ref 0;;
let first_line b = (
	try (
		let f = String.index b '\n' in
		String.sub b 0 f
	) with Not_found -> b
)
let file_notfound f = (
	prerr_string ("File not found: \""^f^"\"");
	prerr_newline ();
	myexit 1
)
let unexpected s = (
	prerr_string ("unexpected argument \""^s^"\"");
	prerr_newline ();
	myexit 1
)

let parse argv = (
  let save_current = !current in
  try (
    let args = make_args () in 
    mkoptab argv args;
	 Arg.parse_argv ~current:current argv args._args (add_other args) (usage_msg argv.(0));
    (List.iter 
       (fun f -> 
         if (String.sub f 0 1 = "-") then
           unexpected f 
         else if not (Sys.file_exists f) then
           file_notfound f
         else ()
       ) 
       args._others);
    current := save_current;
    args.topo <- (match args._others with
          [] -> 
          Printf.fprintf stderr "*** The topology file is missing in '%s'\n%s\n"
            (argv.(0)) (usage_msg argv.(0));  
          exit 2; 
        | x::_ -> x
      );
      args
  )
  with
  | Arg.Bad msg ->
    Printf.fprintf stderr "*** Error when calling '%s': %s\n%s\n" (argv.(0))
      (first_line msg) (usage_msg argv.(0)); exit 2; 
  | Arg.Help msg -> 
    Printf.fprintf stdout "%s\n%s\n" msg (usage_msg argv.(0)); 
    exit 0
)