Skip to content

Commit

Permalink
bug fix
Browse files Browse the repository at this point in the history
  • Loading branch information
@MatthieuDien
MatthieuDien committed Aug 27, 2014
1 parent 385ee2e commit 3b89d2e
Show file tree
Hide file tree
Showing 4 changed files with 124 additions and 80 deletions.
6 changes: 3 additions & 3 deletions src/CombSys.ml
View file
Expand Up @@ -36,9 +36,9 @@ let combsys_size = Array.length
let eval_combnode (z:float) (y:float array) (cn:combnode):float =
match cn with
Z -> z
|One -> 1.0
|Refe(i) -> y.(i)
|Seq(i) -> 1./.(1.-.y.(i))
| One -> 1.0
| Refe(i) -> y.(i)
| Seq(i) -> 1./.(1.-.y.(i))

(** evaluation of a product at a given coordinate z *)
let eval_combprod (z:float) (y:float array) (cp:combprod):float =
Expand Down
126 changes: 78 additions & 48 deletions src/Gen.ml
View file
Expand Up @@ -24,6 +24,19 @@ open Grammar
open GenState


let geom p =
let rec g u s k l p =
(* printf "%f %f \n%!" u s; *)
if u > s then
let pk = p *. l in
g u (s +. pk) (k + 1) l pk
else
k
in
let u = Random.float 1. in
g u p 0 (1. -. p) p


let rec find_component (rdm_float:float) componentList =
match componentList with
| [comp] -> comp
Expand All @@ -36,7 +49,8 @@ let rec find_component (rdm_float:float) componentList =

let rec get_next_rule (name_rule:string) (wgrm:weighted_grammar) (isCall:bool) =
let (total_weight,component_list) = (StringMap.find name_rule wgrm) in
let rdm_float = Random.float total_weight in
let rdm_float = (Random.float 1.) *. total_weight in
(* printf "%f %f \n" total_weight rdm_float ; *)
let comp = (find_component rdm_float component_list) in
match comp with
| (Grammar.Call elem), _ -> get_next_rule elem wgrm true
Expand All @@ -48,7 +62,9 @@ let rec get_next_rule (name_rule:string) (wgrm:weighted_grammar) (isCall:bool) =
match elem with
| (Grammar.Elem name) -> name :: next_rules
| (Grammar.Seq name) -> let (w,_) = StringMap.find name wgrm in
let n' = int_of_float (floor((log( Random.float 1.)) /. (log w))) in
(* let n' = int_of_float (ceil ( ( (log( Random.float 1.)) -. (log w) ) /. (log (1. -. w) ) ) ) in *)
let n' = geom w in
(* printf "%d \n%!" n'; *)
next_rules @ (concat_n [name] n')
)
[]
Expand Down Expand Up @@ -91,6 +107,11 @@ let rec sim (size:int) counters (wgrm:WeightedGrammar.weighted_grammar) (sizemax
else
begin
let (total_weight,next_rules,isCall) = get_next_rule current_rule wgrm false in

(* printf "sim debug\n"; *)
(* List.iter (fun x -> printf "%s " x) next_rules; *)
(* printf "\n"; *)

if (List.length next_rules) > 0 then
begin
let new_counters = (count_rules counters (List.tl next_rules)) in
Expand All @@ -113,61 +134,64 @@ let rec sim (size:int) counters (wgrm:WeightedGrammar.weighted_grammar) (sizemax
let rec simulate_seed (wgrm:WeightedGrammar.weighted_grammar)
(grm:grammar) (nb_try:int) (nb_smaller:int) (nb_bigger:int) (sizemin:int) (sizemax:int) =
if nb_try > 0 then
let counters = init_counter grm StringMap.empty in
let (first_rule,_) = List.hd grm in
let rdm_state = Random.get_state () in
let res = sim 0 counters wgrm sizemax first_rule in
if global_options.verbosity >= 3
then printf "[SIM]: Generated tree of size = %d\n%!" res ;
if res < sizemin then
begin
(if global_options.verbosity >= 3
then printf " ==> tree is too small => reject\n%!");
simulate_seed wgrm grm (nb_try - 1) (nb_smaller+1) nb_bigger sizemin sizemax
end
else if res > sizemax then
begin
(if global_options.verbosity >= 3
then printf " ==> tree is too large\n%!") ;
begin
let counters = init_counter grm StringMap.empty in
let (first_rule,_) = List.hd grm in
let rdm_state = Random.get_state () in
let res = sim 0 counters wgrm sizemax first_rule in
if global_options.verbosity >= 3
then printf "[SIM]: Simulated size of tree = %d\n%!" res ;
if res < sizemin then
begin
(if global_options.verbosity >= 3
then printf " ==> size is too small => reject\n%!");
simulate_seed wgrm grm (nb_try - 1) (nb_smaller+1) nb_bigger sizemin sizemax
end
else if res > sizemax then
begin
(if global_options.verbosity >= 3
then printf " ==> size is too big\n%!") ;
simulate_seed wgrm grm (nb_try - 1) nb_smaller (nb_bigger+1) sizemin sizemax
end
else
begin
(if global_options.verbosity >= 3
then printf " ==> tree matches expecte size, select\n%!");
(Some(res),nb_smaller,nb_bigger,Some(rdm_state))
end
else (* max number of tries *)
(None,nb_smaller,nb_bigger,None)
end
else
begin
(if global_options.verbosity >= 3
then printf " ==> simulated size matches expecte size, select\n%!");
(Some(res),nb_smaller,nb_bigger,Some(rdm_state))
end
end
else (* max number of tries *)
(None,nb_smaller,nb_bigger,None)



let rec simulator nb_refine_seed nb_try g epsilon1 epsilon2 zmin zmax zstart epsilon1_factor epsilon2_factor sys sizemin sizemax ratio_rejected=
let rec simulator nb_refine nb_try g epsilon1 epsilon2 zmin zmax zstart epsilon1_factor epsilon2_factor sys sizemin sizemax ratio_rejected=
let (zmin',zmax',y) =
(if global_options.verbosity >= 2
then printf "[ORACLE]: search singularity at z=%f\n%!" zstart) ;
searchSingularity sys zmin zmax epsilon1 epsilon2 zstart in
(if global_options.verbosity >= 2
then printf " ==> found singularity at z=%f\n\n%!" zmin');
let wgrm = weighted_grm_of_grm g y in
let wgrm = weighted_grm_of_grm g y zmin' in
(if global_options.verbosity >= 2
then printf "[SIM]: weighted grammar is :\n%s\n%!" (WeightedGrammar.string_of_weighted_grammar wgrm));
let (size,nb_smaller,nb_bigger,state) = simulate_seed wgrm g nb_try 0 0 sizemin sizemax in
match size with
| Some size -> (match state with
| Some size ->
(match state with
|Some state -> Some(size,state,wgrm)
|None -> failwith "should never be here") (* unreachable case *)
| None -> if nb_refine_seed > 0 then
|None -> assert false) (* unreachable case *)
| None ->
if nb_refine > 0 then
begin
if (float_of_int nb_smaller) /. (float_of_int (nb_smaller+nb_bigger)) >= ratio_rejected then
simulator (nb_refine_seed - 1) nb_try g (epsilon1 *. epsilon1_factor) (epsilon2 *. epsilon2_factor) zmin' zmax' zstart epsilon1_factor epsilon2_factor sys sizemin sizemax ratio_rejected
simulator (nb_refine - 1) nb_try g (epsilon1 *. epsilon1_factor) (epsilon2 *. epsilon2_factor) zmin' zmax' zstart epsilon1_factor epsilon2_factor sys sizemin sizemax ratio_rejected
else
failwith "try with other parameters Trees too big"
end
else
None


type 'a queue = 'a Queue.t

let rec gen_stack_tree_rec (wgrm:WeightedGrammar.weighted_grammar) (size:int) (next_rules: string queue) rules =
Expand All @@ -176,6 +200,11 @@ let rec gen_stack_tree_rec (wgrm:WeightedGrammar.weighted_grammar) (size:int) (n
else
let current_rule = Queue.pop next_rules in
let(total_weight,next_rules_list,_) = get_next_rule current_rule wgrm false in

(* printf "gen debug\n"; *)
(* List.iter (fun x -> printf "%s " x) next_rules_list; *)
(* printf "\n"; *)

Stack.push (current_rule,(List.length next_rules_list)) rules;
List.iter (fun elt -> Queue.push elt next_rules) next_rules_list;
gen_stack_tree_rec wgrm (size+total_weight) next_rules rules
Expand All @@ -190,18 +219,19 @@ let rec gen_tree_of_stack_rec
(stack,size)
(current_rules: tree queue)
(with_prefix:bool) (idprefix:string) =
match (Stack.is_empty stack) with
|true -> ()
|false -> let prefix = if with_prefix then idprefix ^ (string_of_int (size)) else (string_of_int (size)) in
let (rule,arity) = Stack.pop stack in
let next_rule =
if arity=0 then
Leaf(rule,prefix)
else
let sons = npop arity current_rules in Node(rule,prefix,sons)
in
Queue.push next_rule current_rules;
gen_tree_of_stack_rec (stack,size-1) current_rules with_prefix idprefix
if (not (Stack.is_empty stack)) then
begin
let prefix = if with_prefix then idprefix ^ (string_of_int (size)) else (string_of_int (size)) in
let (rule,arity) = Stack.pop stack in
let next_rule =
if arity = 0 then
Leaf(rule,prefix)
else
let sons = npop arity current_rules in Node(rule,prefix,sons)
in
Queue.push next_rule current_rules;
gen_tree_of_stack_rec (stack,size-1) current_rules with_prefix idprefix
end

let gen_tree_of_stack
(stack,size)
Expand Down Expand Up @@ -233,7 +263,7 @@ let generator
if self_seed then
begin
Random.self_init ();
Random.int 11231231;
Random.int 1000000;
end
else
seed
Expand All @@ -247,7 +277,7 @@ let generator
(if global_options.verbosity >= 2
then printf "[GEN]: combinatorial system is:\n%s\n%!" (fst (string_of_combsys sys))
);
let res = simulator max_refine max_try g epsilon1 epsilon2 0. 1. zstart epsilon1_factor epsilon2_factor sys sizemin sizemax ratio_rejected in
let res = simulator max_refine max_try g epsilon1 epsilon2 0. 1. zstart epsilon1_factor epsilon2_factor sys sizemin sizemax ratio_rejected in
match res with
| Some(final_size,state,wgrm) ->
let (first_rule,_) = List.hd g in
Expand Down
17 changes: 13 additions & 4 deletions src/OracleSimple.ml
View file
Expand Up @@ -20,10 +20,12 @@ open Util
let normInf_diff = array_fold_left_2 (fun norm y y' -> let z = abs_float (y -. y') in if z>norm then z else norm) 0.0

let iterationSimple (phi:combsys) (z:float) (epsilon:float):float array =
let open Printf in
printf "it simple et z = %f\n" z;
let rec iterate (y:float array): float array =
(* print_endline "lol"; *)
(* let open Printf in *)
(* Array.iter (fun x -> printf "%f \n" x) y; *)
(* print_endline "lol "; *)
Array.iter (fun x -> printf "%f " x) y;
printf "\n";
let y' = evaluation phi z y
in
if (Array.fold_left (fun pred x -> pred || (x > 1.)) false y')
Expand All @@ -48,7 +50,14 @@ let diverge (y:float array) (epsilon:float):bool =
dvgi 0 ((Array.length y) - 1)

(* output:zmin,zmax,vectorY *)
let rec searchSingularity (phi:combsys) (zmin:float) (zmax:float) (epsilon1:float) (epsilon2:float)(zstart:float):float *float* float array =
let rec searchSingularity
(phi:combsys)
(zmin:float)
(zmax:float)
(epsilon1:float)
(epsilon2:float)
(zstart:float)
: float *float* float array =
if zmax -. zmin < epsilon1 then
(zmin,zmax,iterationSimple phi zmin epsilon2)
else
Expand Down
55 changes: 30 additions & 25 deletions src/WeightedGrammar.ml
View file
Expand Up @@ -22,65 +22,70 @@ let rule_names_to_index grm =
match grm with
| [] -> index_map
| (rule_name, _) :: grm' ->
rn_to_ind grm' (StringMap.add rule_name index index_map) (index-1)
let open Printf in
printf "name %s id %d \n" rule_name index;

rn_to_ind grm' (StringMap.add rule_name index index_map) (index+1) (* (index-1) *)
in
let n = List.length grm in
let index_map = StringMap.empty in
rn_to_ind grm index_map (n-1)
rn_to_ind grm index_map 0 (* (n-1) *)

let cpnt_to_wcpnt rules_indexes values component =
let cpnt_to_wcpnt z rules_indexes values component =
match component with
| Call ref as cpnt->
begin
let rule_index = StringMap.find ref rules_indexes in
(cpnt, values.(rule_index))
end
| Cons (_,l) as cpnt ->
| Cons (zn,l) as cpnt ->
begin
let w =
List.fold_left
(fun total_weight elem ->
match elem with
| Elem name ->
begin
let rule_index = StringMap.find name rules_indexes in
total_weight *. values.(rule_index)
end
| Seq name ->
begin
let rule_index = StringMap.find name rules_indexes in
total_weight *. values.(rule_index)
(* total_weight /. (1. -. values.(rule_index)) *)
end
)
1.
l
let w = (z ** (float_of_int zn)) *.
(List.fold_left
(fun total_weight elem ->
match elem with
| Elem name ->
begin
let rule_index = StringMap.find name rules_indexes in
total_weight *. values.(rule_index)
end
| Seq name ->
begin
let rule_index = StringMap.find name rules_indexes in
total_weight *. values.(rule_index)
(* total_weight /. (1. -. values.(rule_index)) *)
end
)
1.
l)
in (cpnt, w)
end

let weighted_grm_of_grm
(grm:Grammar.grammar)
(values:float array)
(z:float)
: weighted_grammar =
let rec wgrm_of_grm
(grm:Grammar.grammar)
(wgrm:weighted_grammar)
(rules_indexes:int StringMap.t)
(values:float array)
(z:float)
: weighted_grammar =
match grm with
| [] -> wgrm
| (rule_name, components) :: grm' ->
begin
let components_weight = List.map (cpnt_to_wcpnt rules_indexes values) components in
let components_weight = List.map (cpnt_to_wcpnt z rules_indexes values) components in
let rule_weight = List.fold_left (fun r (_,w) -> r+.w) 0. components_weight in
let wgrm' = StringMap.add rule_name (rule_weight, components_weight) wgrm in
wgrm_of_grm grm' wgrm' rules_indexes values
wgrm_of_grm grm' wgrm' rules_indexes values z
end
in
let rules_indexes = rule_names_to_index grm in
let wgrm = StringMap.empty in
wgrm_of_grm grm wgrm rules_indexes values
wgrm_of_grm grm wgrm rules_indexes values z

let string_of_weighted_component comp =
let strz w =
Expand Down

0 comments on commit 3b89d2e

Please sign in to comment.