track the exhaustSearch file! and add a progress percentage to -is

lib/sasacore/worstInit.ml

-(* Time-stamp: <modified the 14/10/2021 (at 15:45) by Erwan Jahier> *)
+(* Time-stamp: <modified the 21/10/2021 (at 13:53) by Erwan Jahier> *)
 
 open Register
 
@@ -175,31 +175,39 @@ let (fchc : out_channel -> ('v SimuState.t -> int) -> 'v SimuState.t -> int
   let cpt = ref 0 in  
   let cost p = run (point_to_ss p ss_init) in
   let pinit = ss_to_point ss_init in
+  let percent_done = ref 0 in  
   let g =
     { 
       init = ({ st = pinit ; d = 0 ; cost = cost pinit ; cpt = 0 }, Q.empty, ());
       succ = (fun n ->
           let m = min 50 (max 1 (dmax / 10)) in
+          let m = min m (max 1 (dmax - !cpt - 2)) in
           let pl = (choose m n.st one_dim_succ) @
                    (choose 1 n.st ran_dim_succ) @
                    (choose 1 n.st all_dim_succ)
           in
-            let new_cpt, res =
+          let new_cpt, res =
             map_local_fold
               ~f: (fun p -> cost p, p)
               ~fold:(fun (cpt,nl) (c,p) ->
+                  let n_percent_done = cpt / (dmax / 100) in
+                  if n_percent_done <> !percent_done then (
+                    percent_done := n_percent_done;
+                    Printf.printf "%d%% of the %d simulations have been tryied so far...\r%!"
+                      n_percent_done dmax
+                  );
                   Printf.fprintf log "At depth %d, cost=%d\n%!" (n.d+1) c;
                   cpt+1,{ d=n.d+1; cost=c; st=p ; cpt = cpt}::nl
-                )
+              )
               (!cpt, [])
               pl
-            in
-            Printf.fprintf log "fchc: cpt=%d->%d cost=[%s]\n%!" !cpt new_cpt
-              (String.concat "," (List.map (fun n -> string_of_int n.cost) res));
-            cpt:=new_cpt;
-            res
+          in
+          Printf.fprintf log "fchc: cpt=%d->%d cost=[%s]\n%!" !cpt new_cpt
+            (String.concat "," (List.map (fun n -> string_of_int n.cost) res));
+          cpt:=new_cpt;
+          res
       );
-      stop = (fun _ _n -> !cpt > dmax);
+      stop = (fun _ _n -> !cpt >= dmax);
       is_goal = (fun _n -> true);
       push = (fun tv n ->
           Printf.fprintf log "Pushing a point of cost %d (queue size=%d)\n%!"
@@ -214,25 +222,26 @@ let (fchc : out_channel -> ('v SimuState.t -> int) -> 'v SimuState.t -> int
           Printf.fprintf log "%d: cut a point at depth %d of cost %d < %d\n%!"
             !cpt n.d n.cost pn.cost;
           true
-        )
+      )
           else false
-        );
+      );
     }
   in
   let rec run_more psol more =
       ( match more (Some psol) with
-        | LocalSearch.Stopped 
-        | LocalSearch.NoMore->
+        | LocalSearch.NoMore ->
+          (* occurs if all successors are cut *)
+          run_more psol more
+        | LocalSearch.Stopped -> 
           Printf.printf "The worst initial configuration, which costs %d, is " psol.cost;
           point_to_ss psol.st ss_init
-        | LocalSearch.Sol (nsol, more) ->
-          
+        | LocalSearch.Sol (nsol, more) ->          
             if nsol.cost > psol.cost then (
               Printf.printf "Hey, I've found a conf of cost %d! (simu #%d, depth %d)\n%!"
                 nsol.cost nsol.cpt nsol.d;
               run_more nsol more
             ) else (
-              run_more psol more            
+              run_more psol more
             )
       )
   

src/exhaustSearch.ml

+
+open Sasacore
+open LocalSearch
+
+type 'v ss = 'v SimuState.t
+let pot = SimuState.compute_potentiel
+
+type node = {
+  d : int;
+  cost : float;
+  pot : float;
+  cpt : int;
+  path : (bool list list * bool list list * bool * float * string) list;
+  st : string;
+}
+    
+let delta = 1.0 (* the potential decreases of at least delta at each step *)
+    
+(* This priority is given to  the highest (depth, potential) couple at
+   the beginning,  which induces a  greedy depth first  search.  Then,
+   once a first solution has been found, the priority goes to the most
+   promising node *)
+let best = ref None
+let pot_init = ref max_float
+
+let priority n =
+  let d = float_of_int n.d in
+  match !best with
+  | None -> if n.pot <= 0.0 then d else d -. (1.0 /. (n.pot/.delta))
+  | Some b ->  d +. n.pot *. (b /. !pot_init)
+
+let priority n =
+  let d = float_of_int n.d in
+    if n.pot <= 0.0 then d else d -. (1.0 /. (n.pot/.delta))
+  
+module M = struct type t = node 
+  let compare a b = compare (priority b) (priority a)
+(*
+      match !best with
+      | None -> compare b a (* greedy depth first search at the beginning *)
+      | Some best -> (* Give the priority to the most promising node once 1 solution has been found *)
+        (int_of_float ((priority best a) -. (priority best  b)))
+*)
+end
+module Q = Psq.Make (Int) (M)
+
+let cumulated_Q_time = ref 0.0
+let update_Q_now = ref false 
+let update_Q q =
+  (* when  the priority changes, we  need to recompute the  queue from
+     scratch (actually,  it does  not work  too bad  if we  don't, but
+     well...) *)
+  let t0 = Sys.time () in
+  let q = Q.fold (fun k p acc -> Q.add k p acc) Q.empty q in
+  cumulated_Q_time := !cumulated_Q_time +. (Sys.time () -. t0);
+  update_Q_now := false;      
+  q
+
+let verbl = 1
+    
+let pf = Printf.fprintf
+let v args = not args.SasArg.no_data_file
+let p log args n pot enab trig =
+  if not args.SasArg.no_data_file && verbl > 1 then 
+  pf log " {%d: d = %d cost=%.1f ; pot=%.1f; enab = %s; trig = %s\n%!" 
+     n.cpt n.d n.cost  pot enab trig
+
+let (marshall_ss : 'v ss -> string) =
+  fun ss ->
+  Marshal.to_string ss.config []
+
+let all_false ll = List.for_all (fun b -> not b) (List.flatten ll)
+
+let sob = fun b -> if b then "t" else "f"
+
+let (bnb : out_channel -> bool -> int -> 'v ss ->
+     (bool list list * bool list list * bool * float * 'v Conf.t) list) =
+  fun log central max_step st0 ->
+  let cpt = ref 0 in  
+  let qsize = ref 0 in
+  let args = st0.sasarg in  
+  let get_ss str = SimuState.update_config (Marshal.from_string str 0) st0 in
+  let successors n =
+    let st = get_ss n.st in
+    let pot_st = n.cost -. (float_of_int n.d) in
+    let all, enab_ll = Sasacore.SimuState.get_enable_processes st in
+    let enable_val = String.concat " " (List.map sob (List.flatten enab_ll)) in
+    if Sasacore.SimuState.legitimate st then [] else (    
+      let all = if central then Enumerate.central_list all else Enumerate.all_list all in
+      List.map
+        (fun al ->
+           incr cpt;
+           if !cpt mod (st0.sasarg.length / 100) = 0 then
+             Printf.printf "%d%% of steps have been tryied so far...\r%!" (!cpt / (st0.sasarg.length / 100));
+           let nst = Step.f al st in
+           let pot_nst = pot nst in
+           let nst_str = marshall_ss nst in
+           let trig_val = Daemon.get_activate_val al st.network in
+           let trig_val_str = String.concat " " (List.map sob (List.flatten trig_val)) in
+           let node = {
+             st = nst_str;
+             d = n.d+1;
+             pot = pot_nst;           
+             cpt = !cpt;
+             path=(enab_ll, trig_val, false, pot_st, n.st)::n.path;
+             cost = (float_of_int (n.d+1)) +. pot_nst (* XXX * delta *)
+           }
+           in
+           p log st.sasarg node pot_nst enable_val trig_val_str;
+           node
+        )
+        all
+    )
+  in
+  let pot0 = pot st0 in
+  pot_init := pot0;  
+  let pb =
+    { 
+      init = { st=marshall_ss st0; d=0; pot=pot0 ; cpt=0; path=[]; cost=pot0 }, Q.empty, ();
+      succ = successors;
+      stop = (fun _ node ->
+          if !cpt >= max_step then (
+            pf log "Max number of step reached (%d). Queue size=%d\n%!" !cpt !qsize;
+            pf stdout "Max number of step reached (%d). Queue size=%d\n%!" !cpt !qsize;
+            true
+          ) else false
+      );
+      is_goal = (fun n -> n.cost <= float_of_int n.d);
+      push = (fun tv n ->
+          qsize := Q.size tv;
+          if v args then
+            pf log " ==> Pushing a node (#%d) of cost %.1f (pot=%.1f ; d=%d ; queue size=%d ; priority=%.3f)\n%!"
+              n.cpt n.cost n.pot n.d  !qsize (priority n);
+          Q.add n.cpt n tv);
+      pop = (fun tv ->      
+          let tv = if !update_Q_now then update_Q tv else tv in
+          match Q.pop tv with None -> None | Some((i,x),t) ->
+            if v args then
+              pf log "<== Poping a node (#%d) of cost %.1f (pot %.1f, depth %d, priority=%.3f)\n%!"
+                i x.cost x.pot x.d  (priority x);
+            Some(x, t));
+      visiting = (fun _ x -> x);
+      visited  = (fun _ _ -> false);
+      cut = (fun psol n -> if psol.cost >= n.cost then (
+          if v args then
+            pf log "%d: cut at depth %d of cost %.1f<=%.1f\n%!" !cpt n.d n.cost psol.cost;
+          true
+      )
+          else false
+      );
+    }
+  in
+  let format sol =
+    Printf.printf "The worst path has %d steps (update_Q time = %f)" sol.d !cumulated_Q_time;
+    LocalSearch.stat stdout;
+    LocalSearch.stat log;
+    let path =
+      let st = get_ss sol.st in
+      let pot_st = sol.cost -. (float_of_int sol.d) in
+      let _all, enab_ll = Sasacore.SimuState.get_enable_processes st in
+      (enab_ll,[], true, pot_st, sol.st)::sol.path
+    in
+    List.map
+      (fun (e, t, leg, pot, str) -> e, t, leg, pot, Marshal.from_string str 0)
+      (List.rev path)
+  in
+  let rec run_more psol more =
+    if psol.d = int_of_float !pot_init then (
+      Printf.printf "The length of this solution is equal to the initial potential (%.1f). %s\n" !pot_init
+        "\n\tIt is therefore the best we can find. \n\tStop the search. ";
+      format psol
+    )
+    else    
+      let more_sol = more (Some psol) in
+      match more_sol with
+      | LocalSearch.Stopped 
+      | LocalSearch.NoMore ->
+        if more_sol = LocalSearch.Stopped then
+          pf stdout "The search stopped because the max number of step has been reached\n"
+        else 
+          pf stdout "All possible paths have been explored!\n";
+        format psol
+      | LocalSearch.Sol (nsol, more) ->          
+        if nsol.cost > psol.cost then (
+          pf stdout "Hey, I've found a path of length %d! (simu #%d)\n%!" (nsol.d) nsol.cpt;
+          update_Q_now := true;      
+          pf log "Hey, I've found a path of length %d! (simu #%d)\n%!"    (nsol.d) nsol.cpt;
+          best := Some (float_of_int nsol.d);
+          run_more nsol more
+        ) else (
+          pf log "I've found a path of length %d! (simu #%d)\n%!" nsol.d nsol.cpt;
+          pf stdout "I've found a path of length %d (simu #%d)\n%!" nsol.d nsol.cpt;
+          run_more psol more
+        )
+  in
+  match LocalSearch.run pb None with
+  | LocalSearch.Stopped ->
+    failwith ("The exploration stopped after "^(string_of_int max_step)
+              ^" step without finding solution")
+  | LocalSearch.NoMore-> failwith "There is no solution!"
+  | LocalSearch.Sol (sol, more) ->
+    pf log "The first solution has a path of length %d (simu #%d)\n%!" sol.d sol.cpt;
+    pf stdout "The first solution has a path of length %d (simu #%d)\n%!" sol.d sol.cpt;
+    update_Q_now := true;      
+    best := Some (float_of_int sol.d);
+    run_more sol more
+
+
+let f = bnb