diff --git a/lib/sasacore/worstInit.ml b/lib/sasacore/worstInit.ml
index c0bd1ae0a336a95c6ba2899ca00f245e106e7bf9..728ce99d92cc3a9b4deef439e3d7f1daac6af4d1 100644
--- a/lib/sasacore/worstInit.ml
+++ b/lib/sasacore/worstInit.ml
@@ -1,4 +1,4 @@
-(* 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
)
)
diff --git a/src/exhaustSearch.ml b/src/exhaustSearch.ml
new file mode 100644
index 0000000000000000000000000000000000000000..54b7ed023532f03d109ef43f1b8db189d5e9f466
--- /dev/null
+++ b/src/exhaustSearch.ml
@@ -0,0 +1,209 @@
+
+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