Merge pull request fredokun#6 from MarwanG/seq

Seq

src/Arbogen.ml

@@ -2,6 +2,7 @@ open Printf
 
 open Options
 
+
 let version_str = "arbogen v0.20121006 (beta)"
 
 let usage = "Usage: arbogen <opt> <specfile>.arb"
@@ -133,6 +134,15 @@ Arg.parse [
     ),
   "<x>: set the name of the file to be created at end of execution"
   );
+  ("-zstart", Arg.Float(fun x -> 
+    if(x > 1.0 || x < 0.0) then(
+            eprintf "Error: value must be between 0 and 1\n...arborting\n";
+            exit 1;
+    )else(
+      global_options.zstart <- x;
+    )
+  ),
+  "<x>: sets the value of zstart");
 ]
   (fun arg ->
     if (String.compare global_options.grammar_file "")=0
@@ -160,6 +170,7 @@ then printf "==> Grammar file loaded\n%!" ;;
 if (global_options.verbosity) > 0
 then printf "Generating tree\n%!" ;;
 
+
 let result =
   Gen.generator
     grammar
@@ -176,6 +187,7 @@ let result =
     global_options.max_try
     global_options.ratio_rejected
     global_options.max_refine
+    global_options.zstart
 in match result with
   None ->
     eprintf "Error: no tree generated ==> try to use different parameters\n%!" ;
@@ -199,5 +211,4 @@ in match result with
          printf "==> file saved\n%!"
   end  
 
-
-
+

src/GParser.ml

@@ -21,6 +21,15 @@ type character =
     Char of char
   | EOF;;
 
+let contains s1 s2 =
+  try
+    let len = String.length s2 in
+    for i = 0 to String.length s1 - len do
+      if String.sub s1 i len = s2 then raise Exit
+    done;
+    false
+  with Exit -> true  
+
 let is_space = function
   | Char(ch) -> ch == ' ' or ch == '\n' or ch == '\t' or ch == '\r'
   | EOF -> false ;;
@@ -131,6 +140,16 @@ let parse_component str i =
          raise (Parse_Error "Expecting '*', '+' or ';' after <z>"))
     else if componentName="*" or componentName="+" then
       raise (Parse_Error ("Unexpected '" ^ componentName ^ "'"))
+    else if (contains componentName "SEQ(") == true then
+       let start = String.index componentName '(' in
+        let stop = String.index componentName ')' in
+          let name = String.sub componentName (start+1) (stop-start-1) in
+            let (next,i'') = next_word str i' in
+              if next="+" or next =";" then
+                ((weight,List.rev ((SEQ name)::refs)),i')
+              else if next="*" then
+                aux i'' weight ((SEQ name)::refs)
+              else raise (Parse_Error "Expecting '+', ';' or '*'")
     else (* component Name is ok *)
       let (next,i'') = next_word str i' in
       (* print_endline ("Next = " ^ next) ; *)
@@ -249,6 +268,14 @@ let parse_option str i =
        else if not global_options.epsilon2_factor_set
        then global_options.epsilon2_factor <- eps2_val) ;
       advance str i' ";"
+   | "zstart" ->
+    let start, i' = parse_float str  i'
+    in
+    (if (start > 1.0 || start < 0.0) then
+      raise (Option_Error (sprintf "incorrect zstart value %f => should be between 0 and 1" start))
+    else
+      global_options.zstart <- start);
+    advance str i' ";"
   | _ -> raise (Parse_Error (sprintf "Uknown or unsupported option: %s" opt_id))
 
 

src/Gen.ml

@@ -60,7 +60,10 @@ let pondere2 (g:grammar) (y:float array)
 				1.
 				componentList
 			in
-			let len = List.length componentList in
+			let len = if (List.length componentList = 1) & 
+			    (List.exists (fun x -> x = (name_of_elem (List.hd componentList))) (leafs_of_grammar g)) then 0
+			  else List.length componentList
+			in
 			(componentList,len,proba)
 		in
 		(* renvoie la map des composants avec leurs sous composants (prochain fils) et pondération *)
@@ -111,7 +114,7 @@ let rec gen_stack_tree
 					| SEQ(rul) -> let (_,rdm) = StringMap.find rul map in
 (*						print_endline (string_of_float rdm);*)
 						let n' = int_of_float (floor((log( Random.float 1.)) /. (log rdm))) in
-						((List.append (concat_n [rul] n) l),(n'+n-1))
+						((List.append (concat_n [rul] n') l),(n'+n-1))
 						| ELEM(rul) -> if(List.exists (fun x -> x = rul) leafs) then
 					                   begin subst_rule := rul; (l,0) end   
 					               else ((rul::l),n))
@@ -208,29 +211,12 @@ let gen_tree
 	(with_prefix:bool) (idprefix:string)
 	(sizemax:int)
 	(y:float array) : (tree option * int) =
-	(*let (first_rule,_) = List.hd g in
-	let (wmap,gmap) = pondere (completion g) y in
-	gen_tree_rec 0 first_rule wmap gmap sizemax with_prefix idprefix*)
 	let map = pondere2 g y in
 	let leafs = leafs_of_grammar g in
-
-(*	StringMap.iter
-	(fun key (l,_)-> print_endline key;
-	print_endline (string_of_int (List.length l));
-	List.iter (fun (_,a,_) -> print_endline (string_of_int a)) l )
-	map;*)
-
 	let queue = Queue.create () in
 	let (first_rule,_) = List.hd g in
-(*	print_endline first_rule;*)
 	Queue.push first_rule queue;
 	let (stack,size) = gen_stack_tree 1 queue (Stack.create ()) map sizemax leafs in
-(*	print_int size;
-	print_endline " ";*)
-	(*Stack.iter (fun (s,a) -> print_string s; print_string " "; print_int a; print_endline " ") stack;
-	print_endline "je suis ici";*)
-	(*print_endline (string_of_int (Stack.length stack));
-	print_endline (string_of_int size) ;*)
 	gen_tree_of_stack (stack,size) with_prefix idprefix
 
 (* TODO: à documenter *)
@@ -242,26 +228,23 @@ let generator
 	(epsilon2:float) (epsilon2_factor:float)
 	(with_prefix:bool) (idprefix:string)
 	(max_try:int) (ratio_rejected:float)
-	(max_refine:int)
+	(max_refine:int)(zstart:float)
 	: (tree*int) option =
 	(if self_seed
 	then Random.self_init ()
 	else Random.init seed) ;
   let sys = combsys_of_grammar (completion g) in
     (if global_options.verbosity >= 2
      then printf "[GEN]: combinatorial system is:\n%s\n%!" (fst (string_of_combsys sys))) ;
-	let rec gen epsilon1 epsilon2 zmin zmax nb_refine =
-(*		print_endline "test";*)
+	let rec gen epsilon1 epsilon2 zmin zmax nb_refine zstart =
+
 		let (zmin',zmax',y) = 
                   (if global_options.verbosity >= 2
-                   then printf "[ORACLE]: search singularity at z=%f\n%!" zmin) ;
-                  searchSingularity sys zmin zmax epsilon1 epsilon2 in
+                   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%!" zmin') ;
 
-(*		print_endline "test";*)
-		(*Array.iter (fun e -> print_endline (string_of_float e)) y;
-		print_endline "";*)
 		let rec try_gen (nb_try:int) (nb_smaller:int) (nb_bigger:int) : ((tree * int) option * int * int) =
 			if nb_try > 0 then
 				(match gen_tree g with_prefix idprefix sizemax y with
@@ -293,8 +276,8 @@ let generator
 				| None ->
 				if (float_of_int nb_smaller) /. (float_of_int (nb_smaller+nb_larger)) >= ratio_rejected
 				then (* if more than e.g. 80% of the trees are too small, then refine *)
-					gen (epsilon1 *. epsilon1_factor) (epsilon2 *. epsilon2_factor) zmin' zmax' (nb_refine+1)
+					gen (epsilon1 *. epsilon1_factor) (epsilon2 *. epsilon2_factor) zmin' zmax' (nb_refine+1) zstart
 				else failwith "Your trees are too big, change paramaters please")
 		else None (* refined too much : could not generate a tree *)
 	in
-	gen epsilon1 epsilon2 0. 1. 1
+	gen epsilon1 epsilon2 0. 1. 1 zstart

src/Options.ml

@@ -31,6 +31,7 @@ type options_record = {
   mutable max_refine_set: bool;
   mutable output_type: int;
   mutable fileName: string;
+  mutable zstart: float;
 } ;;
 
 let global_options = {
@@ -65,6 +66,7 @@ let global_options = {
   max_refine_set = false;
   output_type = 0;
   fileName = "tree";
+  zstart = 0.0;
 } ;;
 
 exception Option_Error of string ;;

src/OracleSimple.ml

@@ -46,19 +46,19 @@ let diverge (y:float array) (epsilon:float):bool =
   dvgi 0 ((Array.length y) - 1)
 
 (* output:zmin,zmax,vectorY *)
-let rec searchSingularity phi (zmin:float) (zmax:float) (epsilon1:float) (epsilon2:float):float *float* float array =
+let rec searchSingularity phi (zmin:float) (zmax:float) (epsilon1:float) (epsilon2:float)(zstart:float):float *float* float array =
 	(*print_endline ((string_of_float zmin)^" "^(string_of_float zmax));*)
 	if zmax -. zmin < epsilon1 then
 		(zmin,zmax,iterationSimple phi zmin epsilon2)
 	else
-		let z = ((zmin +. zmax) /. 2.0) in
+		let z = zstart in
 		(*print_float z;*)
 		let y = iterationSimple phi z epsilon2 in
 		(*print_endline ("singularite= " ^ (string_of_float zmin) ^ "moyenne= " ^ (string_of_float z));*)
 		if diverge y epsilon2 = true then
-			searchSingularity phi zmin z epsilon1 epsilon2
+			searchSingularity phi zmin zstart epsilon1 epsilon2 ((zmin+.zstart)/.2.)
 		else
-			searchSingularity phi z zmax epsilon1 epsilon2
+			searchSingularity phi zstart zmax epsilon1 epsilon2 ((zmax+.zstart)/.2.)