Skip to content
Snippets Groups Projects
Commit d4e5955a authored by erwan's avatar erwan
Browse files

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

parent fbc45fbc
No related branches found
No related tags found
No related merge requests found
Hide whitespace changes
Inline Side-by-side
lib/sasacore/worstInit.ml
+ 25
− 16
View file @ d4e5955a
(* 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 0 → 100644
+ 209
− 0
View file @ d4e5955a
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
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment