feat: add 2 new CLI options: --es-abort-if-not-progressing and --es-no-tabu

lib/sasacore/exhaustSearch.ml

+(* Time-stamp: <modified the 08/02/2023 (at 14:57) by Erwan Jahier> *)
 
 open LocalSearch
 
@@ -8,17 +9,17 @@ type node = {
   d : int;
   cost : float;
   pot : float;
-  cpt : int;
+  cpt : int;  (* => no sharing between config *)
   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 *)
+   promising node *)
 let best = ref None
 let pot_init = ref max_float
 
@@ -31,17 +32,13 @@ let priority n =
 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 
+
+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)
+module StrMap = Map.Make(String)
+
 
 let cumulated_Q_time = ref 0.0
 let update_Q_now = ref false
@@ -53,23 +50,22 @@ let update_Q q =
   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;      
+  update_Q_now := false;
   q
 
-let verbl = 1
-    
+
 let pf = Printf.fprintf
-let v args = not args.SasArg.no_data_file
+let do_log args = not args.SasArg.no_data_file && args.SasArg.verbose > 1
 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%!" 
+  if not args.SasArg.no_data_file && args.SasArg.verbose > 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 _all_false ll = List.for_all (fun b -> not b) (List.flatten ll)
 
 let sob = fun b -> if b then "t" else "f"
 
@@ -78,9 +74,10 @@ let (bnb : out_channel -> bool -> 'v ss ->
      (bool list list * bool list list * bool * float * 'v Conf.t) list) =
   fun log central st0 ->
   let max_step = st0.sasarg.length in
-  let cpt = ref 0 in  
+  let cpt = ref 0 in
+  let cpt_of_last_improvement = ref 0 in (* to measure the progress of the search*)
   let qsize = ref 0 in
-  let args = st0.sasarg 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
@@ -102,7 +99,7 @@ let (bnb : out_channel -> bool -> 'v ss ->
            let node = {
              st = nst_str;
              d = n.d+1;
-             pot = pot_nst;           
+             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 *)
@@ -114,57 +111,84 @@ let (bnb : out_channel -> bool -> 'v ss ->
         all
     )
   in
+  let visited_config_cpt = ref 0 in
+  let visiting, visited =
+    let visiting n v =
+      StrMap.add n.st n.d v
+    in
+    let visited n v =
+      match StrMap.find_opt n.st v with
+      | None -> incr visited_config_cpt; false
+      | Some d -> d >= n.d (* if the depth of n is higher, we revisit it *)
+    in
+    if st0.sasarg.es_tabu_mode then
+      visiting, visited
+    else
+      visiting,
+        (*         (fun _ v -> v), (fun _ _ -> false) *)
+      (fun n v -> if not (StrMap.mem n.st v) then incr visited_config_cpt; false)
+  in
   let pot0 = pot st0 in
   pot_init := pot0;
-(*  let t0 = 1000. in
-  let lambda = 0.99 in
-  let sa_temp pt =
-    if args.init_search_sa then
-      pt *. lambda
-    else
-      min_float
+  let not_progressing es_stop_if_no_progress = (* should this be done in LocalSearch ? *)
+    match es_stop_if_no_progress with
+    | None -> false
+    | Some factor ->
+      !cpt_of_last_improvement > 0 &&
+      !cpt > !cpt_of_last_improvement * factor (* should be a CLI parameter? *)
   in
-  let sa_reset
-  *)
   let pb =
-    { 
-      init = { st=marshall_ss st0; d=0; pot=pot0 ; cpt=0; path=[]; cost=pot0 }, Q.empty, ();
+    {
+      init = { st=marshall_ss st0; d=0; pot=pot0 ; cpt=0; path=[]; cost=pot0 }, Q.empty, StrMap.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;
-            if not st0.sasarg.quiet then
-              pf stdout "Max number of step reached (%d). Queue size=%d\n%!" !cpt !qsize;
+            pf log "Max number of step reached (%d). Queue size=%d; visited confirations=%d\n%!"
+              !cpt !qsize !visited_config_cpt;
+            pf stdout "Max number of step reached (%d); use -l to change it\n%!" !cpt ;
             true
-          ) else false
-      );
+          ) else if not_progressing st0.sasarg.es_stop_if_no_progress then (
+            pf log "The exhaustive search did not progress for a long time (%d steps): Abort.\n%!"
+              (!cpt - !cpt_of_last_improvement);
+            pf stdout "The exhaustive search did not progress for a long time (%d steps): Abort.\n%!"
+              (!cpt - !cpt_of_last_improvement);
+            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
+          if do_log 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 ->      
+      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
+            if do_log 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);
+      visiting = visiting;
+      visited  = visited;
       cut = (fun psol n -> if psol.cost >= n.cost then (
-          if v args then
+          if do_log 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;
+    let msg = Printf.sprintf "  - the worst path is of length %d
+  - %f seconds have been spent in the priority queue
+  - %d configurations have been (re-)visited\n%!" sol.d !cumulated_Q_time !visited_config_cpt
+    in
+    print_string msg;
+    output_string log msg;
     LocalSearch.stat stdout;
     LocalSearch.stat log;
     let path =
@@ -179,30 +203,37 @@ let (bnb : out_channel -> bool -> 'v ss ->
   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. ";
+      pf log "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.\n%!";
+      pf stdout "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.\n%!";
       format psol
     )
-    else    
+    else
       let more_sol = more (Some psol) in
       match more_sol with
-      | LocalSearch.Stopped 
+      | 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 
+        if more_sol = LocalSearch.Stopped then (
+          pf log "The search stopped before the end\n";
+          pf stdout "The search stopped before the end\n"
+        )
+        else (
+          pf log "All possible paths have been explored!\n";
           pf stdout "All possible paths have been explored!\n";
+        );
         format psol
-      | LocalSearch.Sol (nsol, more) ->          
+      | 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;
+          pf stdout "==> [New longuest path] I've found a path of length %d! (after #%d steps)\n%!" (nsol.d) !cpt;
+          update_Q_now := true;
+          pf log "==> [New longuest path] I've found a path of length %d! (after #%d steps)\n%!"    (nsol.d) !cpt;
           best := Some (float_of_int nsol.d);
+          cpt_of_last_improvement := nsol.cpt;
           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;
+          pf log "==> I've found a path of length %d! (after #%d steps)\n%!" nsol.d !cpt;
+          pf stdout "==> I've found a path of length %d (after #%d steps)\n%!" nsol.d !cpt;
           run_more psol more
         )
   in
@@ -212,9 +243,9 @@ let (bnb : out_channel -> bool -> 'v ss ->
               ^" 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;      
+    pf log "==> The first solution has a path of length %d (step #%d)\n%!" sol.d !cpt;
+    pf stdout "==> The first solution has a path of length %d (step #%d)\n%!" sol.d !cpt;
+    update_Q_now := true;
     best := Some (float_of_int sol.d);
     run_more sol more
 

lib/sasacore/exhaustSearch.mli

+(* Time-stamp: <modified the 07/02/2023 (at 15:37) by Erwan Jahier> *)
+
+(*  [f  outc  is_central  simuState]  returns  the  longest  possible
+   execution after exploring exhaustively the configuration state space *)
+val f : out_channel ->  bool -> 'v SimuState.t ->
+        (bool list list * bool list list * bool * float * 'v Conf.t) list
+
+val reset : unit -> unit

lib/sasacore/localSearch.ml

 
 type ('n, 'tv, 'v) t = {
   init : 'n * 'tv * 'v;
-  succ : 'n -> 'n list; (* returns (all or some) neighbors *)     
+  succ : 'n -> 'n list; (* returns (all or some) neighbors *)
 
   is_goal : 'n -> bool; (* is the node a solution of the problem *)
   stop : 'n -> 'n -> bool; (* [stop pre_sol n] to stop the search before all nodes are visited *)
@@ -14,7 +14,6 @@ type ('n, 'tv, 'v) t = {
   visited  : 'n -> 'v -> bool; (* check if a node has been visited *)
 }
 
-
 type 'n sol = Stopped | NoMore | Sol of 'n * 'n moresol
 and 'n moresol = 'n option -> 'n sol
 
@@ -22,9 +21,10 @@ and 'n moresol = 'n option -> 'n sol
 let debug = false
 
 let cut_nb = ref 0
+let tabu_nb = ref 0
 let sol_nb = ref 0
-    
-let (run : ('n, 'tv, 'v) t -> 'n option -> 'n sol) = 
+
+let (run : ('n, 'tv, 'v) t -> 'n option -> 'n sol) =
  fun g pre_sol ->
   let cut sol_opt n = match sol_opt with
     | None -> false
@@ -33,15 +33,16 @@ let (run : ('n, 'tv, 'v) t -> 'n option -> 'n sol) =
       if res then incr cut_nb;
       res
   in
+  let visited n v = if g.visited n v then (incr tabu_nb; true) else (false) in
   let pre_process sol_opt (v, tv) n =
-    if g.visited n v || cut sol_opt n then (v, tv) else (g.visiting n v, g.push tv n)
-  in 
+    if visited n v || cut sol_opt n then (v, tv) else (g.visiting n v, g.push tv n)
+  in
   let rec loop ps n tv v psol =
    let do_succ_cont s =
      if g.stop ps n then Stopped else loop2 n tv v s
    in (* to avoid code duplication *)
    if not (g.is_goal n) then
-     do_succ_cont psol 
+     do_succ_cont psol
    else
      (incr sol_nb; Sol(n, do_succ_cont))
   and loop2 n tv v psol = (* look at the n successors *)
@@ -56,6 +57,10 @@ let (run : ('n, 'tv, 'v) t -> 'n option -> 'n sol) =
   loop n n tv v pre_sol
 
 let stat log =
-  Printf.fprintf log "\n- local search stat:\n\t- cut: %d\n\t- sol nb: %d\n%!" !cut_nb !sol_nb
-
+  Printf.fprintf log "
+- local search statistics:
+  - | cutted branches | = %d
+  - | tabu list hits  | = %d
+  - | solutions | = %d
 
+%!" !cut_nb !tabu_nb !sol_nb

lib/sasacore/sasArg.ml

-(* Time-stamp: <modified the 10/01/2023 (at 22:07) by Erwan Jahier> *)
+(* Time-stamp: <modified the 08/02/2023 (at 15:19) by Erwan Jahier> *)
 
 type init_search =
    No_init_search | Local of int | Global of int  | Annealing of int
@@ -9,6 +9,11 @@ type t = {
   mutable cores_nb: int;
   mutable verbose: int;
   mutable daemon: DaemonType.t;
+
+  (* for exhaustive daemon only *)
+  mutable es_stop_if_no_progress: int option;
+  mutable es_tabu_mode: bool;
+
   mutable rif: bool;
   mutable output_file_name: string option;
   mutable no_data_file: bool;
@@ -40,10 +45,12 @@ let (make_args : unit -> t) =
   fun () ->
     {
       topo = "";
-      length = 10000;
+      length = max_int;
       cores_nb = 1;
       verbose = 0;
       daemon = DaemonType.Distributed;
+      es_stop_if_no_progress = None;
+      es_tabu_mode = true;
       rif = false;
       output_file_name = None;
       no_data_file = false;
@@ -151,6 +158,15 @@ let (mkoptab : string array -> t -> unit) =
       (Arg.Unit(fun () -> args.daemon <- DaemonType.ExhaustCentralSearch))
       ["Ditto, but for central daemons" ];
 
+    mkopt args  ["--es-abort-if-not-progressing"]
+      (Arg.Int(fun i -> args.es_stop_if_no_progress <- Some i))
+      ["Abort the exhaustive search if not progressing (i.e., when #step>step(last sol)x<int>)." ] ~arg:" <int>";
+
+    mkopt args  ["--es-no-tabu"]
+      (Arg.Unit(fun () -> args.es_tabu_mode <- false))
+      ["Do not use Tabu list during the exhaustive search." ];
+
+
     (*     mkopt args  ["--bad-daemon";"-bd"] ~arg:" <int>" *)
     (*       (Arg.Int (fun i -> args.daemon <- DaemonType.Bad i)) *)
     (*       ["Use a  daemon that tries  to maximize the  potential function, "; *)

lib/sasacore/sasArg.mli

-(* Time-stamp: <modified the 10/01/2023 (at 22:08) by Erwan Jahier> *)
+(* Time-stamp: <modified the 08/02/2023 (at 14:24) by Erwan Jahier> *)
 
 type init_search =
    No_init_search | Local of int | Global of int  | Annealing of int
@@ -9,6 +9,8 @@ type t = {
   mutable cores_nb: int;
   mutable verbose: int;
   mutable daemon: DaemonType.t;
+  mutable es_stop_if_no_progress: int option;
+  mutable es_tabu_mode: bool;
   mutable rif: bool;
   mutable output_file_name: string option;
   mutable no_data_file: bool;