diff --git a/lib/sasacore/exhaustSearch.ml b/lib/sasacore/exhaustSearch.ml
index d56251dd0608967866e9e2adb190d481f0f7484f..f7dd442f2adbe4cf37eef1c652decfaf197b1342 100644
--- a/lib/sasacore/exhaustSearch.ml
+++ b/lib/sasacore/exhaustSearch.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 01/03/2023 (at 15:10) by Erwan Jahier> *)
+(* Time-stamp: <modified the 17/03/2023 (at 22:14) by Erwan Jahier> *)
open LocalSearch
@@ -24,12 +24,14 @@ let best = ref None
let pot_init = ref max_float
let dfs = ref false
+let bfs = ref false
let priority n =
let d = float_of_int n.d in
- match !best, !dfs with
- | None, _ | _, true -> if n.pot <= 0.0 then d else d -. (1.0 /. (n.pot/.delta))
- | Some b, false -> d +. n.pot *. (b /. !pot_init)
+ match !best, !dfs, !bfs with
+ | None, _, false | _, true, _ -> if n.pot <= 0.0 then d else d -. (1.0 /. (n.pot/.delta))
+ | Some b, false, false -> d +. n.pot *. (b /. !pot_init)
+ | _,_, true -> -. d
let _priority n =
let d = float_of_int n.d in
@@ -76,6 +78,7 @@ let (bnb : out_channel -> bool -> 'v ss ->
(bool list list * bool list list * bool * float * 'v Conf.t) list) =
fun log central st0 ->
dfs := st0.sasarg.es_dfs;
+ bfs := st0.sasarg.es_bfs;
let max_step = st0.sasarg.length in
let cpt = ref 0 in
let cpt_of_last_improvement = ref 0 in (* to measure the progress of the search*)
diff --git a/lib/sasacore/sasArg.ml b/lib/sasacore/sasArg.ml
index c4331d13f095e05354adad247a1e231cec565d4c..82120d4e7314e5fa1a82fc0f03a9dd83b81a64e8 100644
--- a/lib/sasacore/sasArg.ml
+++ b/lib/sasacore/sasArg.ml
@@ -1,7 +1,7 @@
-(* Time-stamp: <modified the 15/03/2023 (at 15:59) by Erwan Jahier> *)
+(* Time-stamp: <modified the 24/03/2023 (at 15:40) by Erwan Jahier> *)
type init_search =
- No_init_search | Local of int | Global of int | Annealing of int
+ No_init_search | Local of int * int | Global of int | Annealing of int
type t = {
mutable topo: string;
@@ -13,7 +13,9 @@ type t = {
(* for exhaustive daemon only *)
mutable es_stop_if_no_progress: int option;
mutable es_dfs: bool;
+ mutable es_bfs: bool;
mutable es_tabu_mode: bool;
+ mutable is_tabu_mode: bool;
mutable es_continue_after_best: bool;
mutable es_dont_cut: bool;
mutable rif: bool;
@@ -53,7 +55,9 @@ let (make_args : unit -> t) =
daemon = DaemonType.Distributed;
es_stop_if_no_progress = None;
es_dfs = false;
+ es_bfs = false;
es_tabu_mode = true;
+ is_tabu_mode = true;
es_continue_after_best = false;
es_dont_cut= false;
rif = false;
@@ -173,12 +177,20 @@ let (mkoptab : string array -> t -> unit) =
mkopt args ["--es-dfs"]
(Arg.Unit(fun () -> args.es_dfs <- true))
- ["Use a depth first search to exploration." ];
+ ["Use a depth first search to perform the exploration." ];
+
+ mkopt args ~hide:true ["--es-bfs"]
+ (Arg.Unit(fun () -> args.es_bfs <- true))
+ ["Use a breadth first search to perform the exploration." ];
mkopt args ["--es-no-tabu"]
(Arg.Unit(fun () -> args.es_tabu_mode <- false))
["Do not use Tabu list during the exhaustive search." ];
+ mkopt args ["--is-no-tabu"]
+ (Arg.Unit(fun () -> args.is_tabu_mode <- false))
+ ["Do not use Tabu list during the initial configuration search." ];
+
mkopt args ~hide:true ["--es-continue-when-best-sol-found"]
(Arg.Unit(fun () -> args.es_continue_after_best <- true))
["Do not stop when |path(sol)|=pot(init): this is necessary when E.x phi'(c)>0 (pseudo pot)" ];
@@ -193,13 +205,19 @@ let (mkoptab : string array -> t -> unit) =
(* ["Use a daemon that tries to maximize the potential function, "; *)
(* "considering sub-graphs of a given maximal size"]; *)
mkopt args ["--local-init-search";"-is"]
- (Arg.Int(fun i -> args.init_search <- Local i))
+ (Arg.Int(fun i ->
+ match args.init_search with
+ | Global g -> args.init_search <- Local (g,i)
+ | _ -> args.init_search <- Local (0,i)))
["Use local search algorithms to find an initial configuration that pessimize ";
"the step number. The argument is the maximum number of trials to do the search. ";
"Require the state_to_nums Algo.to_register field to be defined."] ~arg:" <int>";
mkopt args ["--global-init-search";"-gis"]
- (Arg.Int(fun i -> args.init_search <- Global i))
+ (Arg.Int(fun i ->
+ match args.init_search with
+ | Local (_,l) -> args.init_search <- Local (i,l)
+ | _ -> args.init_search <- Global i))
["Use global (i.e., completely random) search to find an initial configuration ";
"that pessimize the step number. The argument is the maximum number of trials";
" to do the search. "] ~arg:" <int>";
@@ -271,7 +289,7 @@ let (mkoptab : string array -> t -> unit) =
["Display the version ocaml version sasa was compiled with and exit."];
mkopt args ["--quiet";"-q"]
- (Arg.Unit (fun () -> args.quiet <- true)) ["Set the quiet mode"];
+ (Arg.Unit (fun () -> args.quiet <- true)) ["Set the quiet mode (for batch)"];
mkopt args ["--verbose";"-vl"] ~arg:" <int>"
(Arg.Int (fun i -> args.verbose <- i)) ["Set the verbose level"];
diff --git a/lib/sasacore/sasArg.mli b/lib/sasacore/sasArg.mli
index a134b188dc218d6f269b51e9eaa0e39aa5047b1f..7a53ead9e1263834aeb3d5694476fe75365c091c 100644
--- a/lib/sasacore/sasArg.mli
+++ b/lib/sasacore/sasArg.mli
@@ -1,7 +1,7 @@
-(* Time-stamp: <modified the 01/03/2023 (at 12:20) by Erwan Jahier> *)
+(* Time-stamp: <modified the 24/03/2023 (at 15:16) by Erwan Jahier> *)
type init_search =
- No_init_search | Local of int | Global of int | Annealing of int
+ No_init_search | Local of int * int | Global of int | Annealing of int
type t = {
mutable topo: string;
@@ -11,7 +11,9 @@ type t = {
mutable daemon: DaemonType.t;
mutable es_stop_if_no_progress: int option;
mutable es_dfs: bool;
+ mutable es_bfs: bool;
mutable es_tabu_mode: bool;
+ mutable is_tabu_mode: bool;
mutable es_continue_after_best: bool;
mutable es_dont_cut: bool;
mutable rif: bool;
diff --git a/lib/sasacore/worstInit.ml b/lib/sasacore/worstInit.ml
index 17827b399f1af6c2f3331fa10f78268c7dff48ee..8ff9a482d6192a5695218ef34b54e49d157a3018 100644
--- a/lib/sasacore/worstInit.ml
+++ b/lib/sasacore/worstInit.ml
@@ -1,8 +1,8 @@
-(* Time-stamp: <modified the 25/01/2023 (at 15:24) by Erwan Jahier> *)
+(* Time-stamp: <modified the 24/03/2023 (at 23:02) by Erwan Jahier> *)
open Register
-type 's node = { st : 's ; d : int ; cost : int ; cpt : int }
+type 's search_node = { st : 's ; d : int ; cost : int ; cpt : int }
type point = value Array.t
let debug = false
@@ -161,7 +161,7 @@ open LocalSearch
module ValueArrayNode = struct
- type t = value array node
+ type t = value array search_node
let compare n1 n2 = compare n2.cost n1.cost
end
@@ -179,6 +179,105 @@ let _point2str p =
Array.fold_right (fun value acc -> (value2str value)::acc) p []
|> String.concat ";"
+open SimuState
+
+(* mix local and global search, a la simulating annealing, with one round *)
+let _succ_far_and_close dmax log cpt step_cpt percent_done cost ss_init n =
+ let beam_size = max 50 ss_init.sasarg.cores_nb in
+ let percent_close = ((tf !cpt) /. (tf dmax)) ** 2.0 in
+ let percent_far = 1.0 -. percent_close in
+
+ let far_nb = max 1 (ti ((tf beam_size) *. percent_far) / 6) in
+ let close_nb = max 1 (ti ((tf beam_size) *. percent_close) / 6) in
+ incr step_cpt;
+ let pl = (choose far_nb n.st (one_dim_succ Close)) @
+ (choose far_nb n.st (ran_dim_succ Close)) @
+ (choose far_nb n.st (all_dim_succ Close)) @
+ (choose close_nb n.st (one_dim_succ Far)) @
+ (choose close_nb n.st (ran_dim_succ Far)) @
+ (choose close_nb n.st (all_dim_succ Far))
+ in
+ let new_cpt, res =
+ map_local_fold
+ ~f: (fun p -> cost p, p)
+ ~fold:(fun (cpt,nl) (c,p) ->
+ assert(dmax <> 0);
+ let n_percent_done = if dmax < 100 then 1 else cpt / (dmax / 100) in
+ if n_percent_done <> !percent_done && not (ss_init.sasarg.quiet) 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
+
+(* purely local search *)
+let succ_close dmax log cpt step_cpt percent_done cost ss_init n =
+ let beam_size = max 50 ss_init.sasarg.cores_nb in
+ let close_nb = max 1 (ti ((tf beam_size)) / 3) in
+ incr step_cpt;
+ let pl = (choose close_nb n.st (one_dim_succ Far)) @
+ (choose close_nb n.st (ran_dim_succ Far)) @
+ (choose close_nb n.st (all_dim_succ Far))
+ in
+ let new_cpt, res =
+ map_local_fold
+ ~f: (fun p -> cost p, p)
+ ~fold:(fun (cpt,nl) (c,p) ->
+ assert(dmax <> 0);
+ let n_percent_done = if dmax < 100 then 1 else cpt / (dmax / 100) in
+ if n_percent_done <> !percent_done && not (ss_init.sasarg.quiet) 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
+
+
+(**********************************************************************)
+(* Use hashed configuration + int set to implement Tabu list.
+
+nb 1 : the evaluation of each initial config is (generally) costy, so
+ this set should remain small => no need to drop elements
+
+nb 2 : using a hash function is not safe, but clashes are
+- unlikely (cf nb 1)
+- not critical : configurations are created at random, and only a
+ very small fraction of the set of possible configurations will be
+ tried anyway. So if a config is wrongly rejected, it is not a big deal
+ *)
+
+module IntSet = Set.Make(Int)
+let (tabu_add : 's search_node -> IntSet.t -> IntSet.t) =
+ fun n tabu ->
+ IntSet.add (Hashtbl.hash n) tabu
+
+let (tabu_mem : 's search_node -> IntSet.t -> bool) =
+ fun n tabu ->
+ IntSet.mem (Hashtbl.hash n) tabu
+
+let empty_tabu_list = IntSet.empty
+
+(**********************************************************************)
+
+
(* First Choice Hill Climbing: a successor is chosen at random (using
some heuristics), and became the current state if its cost is
better.
@@ -187,7 +286,7 @@ let _point2str p =
heuristics. The probability of each heuristic evolves, but is
never null. *)
let (fchc : out_channel -> ('v SimuState.t -> int) -> 'v SimuState.t -> int
- -> 'v SimuState.t) =
+ -> 'v SimuState.t) =
fun log run ss_init dmax ->
let cpt = ref 0 in
let step_cpt = ref 1 in
@@ -195,54 +294,15 @@ let (fchc : out_channel -> ('v SimuState.t -> int) -> 'v SimuState.t -> int
let pinit = ss_to_point ss_init in
let percent_done = ref 0 in
Functory.Cores.set_number_of_cores ss_init.sasarg.cores_nb;
+ let visiting, visited =
+ match ss_init.sasarg.is_tabu_mode with
+ | false -> (fun _ x -> x), (fun _ _ -> false)
+ | true -> tabu_add, tabu_mem
+ in
let g =
{
- init = ({ st = pinit ; d = 0 ; cost = cost pinit ; cpt = 0 }, Q.empty, ());
- succ = (fun n ->
- (* let beam_size = min 50 (max 1 (dmax / 10)) in *)
- (* let beam_size = min m (max 1 (dmax - !cpt - 2)) in *)
- (* let beam_size = max 1 (dmax / (10 * !step_cpt)) in (* 10% of the points to simulate. *)
-
- let beam_size_part0 = beam_size / 6 in
- let beam_size_part1 = max 1 beam_size_part0 in
-
- *)
- let beam_size = max 50 ss_init.sasarg.cores_nb in
- let percent_close = ((tf !cpt) /. (tf dmax)) ** 2.0 in
- let percent_far = 1.0 -. percent_close in
-
- let far_nb = max 1 (ti ((tf beam_size) *. percent_far) / 6) in
- let close_nb = max 1 (ti ((tf beam_size) *. percent_close) / 6) in
- incr step_cpt;
- let pl = (choose far_nb n.st (one_dim_succ Close)) @
- (choose far_nb n.st (ran_dim_succ Close)) @
- (choose far_nb n.st (all_dim_succ Close)) @
- (choose close_nb n.st (one_dim_succ Far)) @
- (choose close_nb n.st (ran_dim_succ Far)) @
- (choose close_nb n.st (all_dim_succ Far))
- in
- let new_cpt, res =
- map_local_fold
- ~f: (fun p -> cost p, p)
- ~fold:(fun (cpt,nl) (c,p) ->
- assert(dmax <> 0);
- let n_percent_done = if dmax < 100 then 1 else 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
- );
+ init = ({ st = pinit ; d = 0 ; cost = cost pinit ; cpt = 0 }, Q.empty, empty_tabu_list);
+ succ = succ_close dmax log cpt step_cpt percent_done cost ss_init ;
stop = (fun _ _n -> !cpt >= dmax);
is_goal = (fun _n -> true);
push = (fun tv n ->
@@ -250,46 +310,57 @@ let (fchc : out_channel -> ('v SimuState.t -> int) -> 'v SimuState.t -> int
(n.cost) (Q.size tv);
Q.add n.cpt n tv);
pop = (fun tv -> match Q.pop tv with None -> None | Some((i,x),t) ->
- Printf.fprintf log "Poping a point of cost %d (simu #%d)\n%!" x.cost i;
- Some(x, t));
- visiting = (fun _ x -> x);
- visited = (fun _ _ -> false);
+ Printf.fprintf log "Poping a point of cost %d (simu #%d)\n%!" x.cost i;
+ Some(x, t));
+ visiting;
+ visited;
cut = (fun pn n -> if pn.cost > n.cost then (
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.NoMore ->
- (* occurs if all successors are cut *)
+ ( match more (Some psol) with
+ | LocalSearch.NoMore ->
+ (* occurs if all successors are cut *)
+ run_more psol more
+ | LocalSearch.Stopped ->
+ Printf.printf "\nThe worst initial configuration costs %d :" psol.cost;
+ point_to_ss psol.st ss_init
+ | LocalSearch.Sol (nsol, more) ->
+ if nsol.cost > psol.cost then (
+ if ss_init.sasarg.quiet then
+ Printf.printf "data: %d %d %d\n%!" nsol.cost nsol.cpt nsol.d
+ else
+ 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
- | LocalSearch.Stopped ->
- Printf.printf "\nThe worst initial configuration costs %d :" psol.cost;
- point_to_ss psol.st ss_init
- | 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
- )
- )
+ )
+ )
in
match LocalSearch.run g None with
| LocalSearch.Stopped -> assert false (* SNO *)
| LocalSearch.NoMore-> assert false (* SNO *)
- | LocalSearch.Sol (sol, more) -> run_more sol more
+ | LocalSearch.Sol (sol, more) ->
+ if ss_init.sasarg.quiet then
+ Printf.printf "data: %d %d %d\n%!" sol.cost sol.cpt sol.d
+ else
+ Printf.printf "Hey, I've found a conf of cost %d! (simu #%d, depth %d)\n%!"
+ sol.cost sol.cpt sol.d;
+ run_more sol more
open Topology
open SimuState
open Process
+
(* generate a new random configuration using the user init functions *)
let reinit_simu g ss =
let pl = List.map2
@@ -320,18 +391,25 @@ let (global : out_channel -> ('v SimuState.t -> int) -> 'v SimuState.t -> int
let res = run ss in
Printf.fprintf log "simu %d, cost=%d\n%!" cpt res;
if res > worst then (
- Printf.printf "Hey, I've found a conf of cost %d! (simu #%d)\n%!" res cpt;
+ if ss_init.sasarg.quiet then
+ Printf.printf "data: %d %d\n%!" res cpt
+ else
+ Printf.printf "Hey, I've found a conf of cost %d! (simu #%d)\n%!" res cpt;
ss, res
)
else
ss_worst, worst
in
let n_percent_done = if dmax < 100 then 1 else cpt / (dmax / 100) in
- if n_percent_done <> !percent_done then (
+ if n_percent_done <> !percent_done && not (ss_init.sasarg.quiet) then (
percent_done := n_percent_done;
Printf.printf "%d%% of the %d simulations have been tryied so far...\r%!"
n_percent_done dmax
);
- if cpt > dmax then ss_worst else loop (cpt+1) (ss_worst, worst)
+ if cpt > dmax then (
+ Printf.printf "\nThe worst initial configuration costs %d :" worst;
+ ss_worst
+ )
+ else loop (cpt+1) (ss_worst, worst)
in
loop 1 (ss_init, run ss_init)
diff --git a/src/sasaMain.ml b/src/sasaMain.ml
index ea2ee657e45020dda1e01d2af976d25bf5d1a482..46ef799cfdf2833cdbccac3dc860a02f6c39721a 100644
--- a/src/sasaMain.ml
+++ b/src/sasaMain.ml
@@ -204,13 +204,13 @@ let () =
Printf.printf
"\n%sThis algo reached a null potential after %i move%s, %i step%s, %i round%s.\n%!"
(if st.sasarg.rif then "#" else "#")
- Round.s.moves (plur Round.s.moves) i (plur i) Round.s.cpt (plur Round.s.cpt);
+ Round.s.moves (plur Round.s.moves) i (plur i) Round.s.cpt (plur Round.s.cpt);
| No_init_search, _ ->
ignore (simuloop stdout n n "" st)
| Annealing _, _ -> assert false (* TODO *)
- | (Local maxt|Global maxt) , _ ->
+ | (Local _ |Global _) , _ ->
let log = open_out (st.sasarg.topo ^ ".log") in
let newdot_fn = (Filename.chop_extension st.sasarg.topo) ^ "_wi.dot" in
let newdot = open_out newdot_fn in
@@ -224,9 +224,9 @@ let () =
let res =
try if st.sasarg.daemon = ExhaustSearch ||
st.sasarg.daemon = ExhaustCentralSearch
- then
+ then
List.length (ExhaustSearch.f log (st.sasarg.daemon=ExhaustCentralSearch) st)
- else
+ else
simuloop log n n "" s
with error ->
(* We consider that error here mean that a meaningless configuration
@@ -247,16 +247,19 @@ let () =
failwith(Printf.sprintf
"Maximum simulation length reached. Something went wrong or %d %s"
n "is not long enough (use sasa -l to try longer simulation)"
- )
+ )
)
else
res
in
let st =
- if search_kind = "local" then
- WorstInit.fchc log run st maxt
- else
- WorstInit.global log run st maxt
+ match st.sasarg.init_search with
+ | Local (maxg, maxl) ->
+ let st = if maxg=0 then st else WorstInit.global log run st maxg in
+ WorstInit.fchc log run st maxl
+ | Global maxg ->
+ WorstInit.global log run st maxg
+ | _ -> assert false
in
Printf.printf " (%s)\n%!" (StringOf.env_rif st.config st.network);
Printf.fprintf newdot "%s\n" (SimuState.to_dot st);
@@ -266,7 +269,7 @@ let () =
close_out log
with
| e ->
- Printf.printf "%s%s\n%!" (if st.sasarg.rif then "#" else "") (Printexc.to_string e);
- print_string "\nq\n#quit\n%!";
- flush_all();
- exit 2
+ Printf.printf "%s%s\n%!" (if st.sasarg.rif then "#" else "") (Printexc.to_string e);
+ print_string "\nq\n#quit\n%!";
+ flush_all();
+ exit 2