diff --git a/src/CombSys.ml b/src/CombSys.ml index 8d5d4b9..bb2db2c 100644 --- a/src/CombSys.ml +++ b/src/CombSys.ml @@ -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 = diff --git a/src/Gen.ml b/src/Gen.ml index 2c9f848..374a3c1 100644 --- a/src/Gen.ml +++ b/src/Gen.ml @@ -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 @@ -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 @@ -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') ) [] @@ -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 @@ -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 = @@ -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 @@ -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) @@ -233,7 +263,7 @@ let generator if self_seed then begin Random.self_init (); - Random.int 11231231; + Random.int 1000000; end else seed @@ -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 diff --git a/src/OracleSimple.ml b/src/OracleSimple.ml index 89be82c..47fe450 100644 --- a/src/OracleSimple.ml +++ b/src/OracleSimple.ml @@ -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') @@ -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 diff --git a/src/WeightedGrammar.ml b/src/WeightedGrammar.ml index 6f4c552..9852088 100644 --- a/src/WeightedGrammar.ml +++ b/src/WeightedGrammar.ml @@ -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 =