X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=ocaml%2Flambda4.ml;h=1e978f281336137234264b00068e869fa43ade8d;hb=f7ba4d1225ca4fb09750f3d23b197b8372f1350b;hp=c79cade6383dccc699c3ea591c6216237de477ff;hpb=e1d685cb4c1f5479fdca1b5888a08ec5f13b49f5;p=fireball-separation.git

diff --git a/ocaml/lambda4.ml b/ocaml/lambda4.ml
index c79cade..1e978f2 100644
--- a/ocaml/lambda4.ml
+++ b/ocaml/lambda4.ml
@@ -27,8 +27,12 @@ type problem =
  ; sigma: (int * nf) list (* the computed substitution *)
  ; deltas: (int * nf) list ref list (* collection of all branches *)
  ; initialSpecialK: int
+ ; label : string
+ ; var_names : string list (* names of the original free variables *)
 };;
 
+let label_of_problem {label} = label;;
+
 let all_terms p =
  (match p.div with None -> [] | Some t -> [(t :> i_n_var)])
  @ p.conv
@@ -65,7 +69,7 @@ let string_of_measure = string_of_int;;
 
 let string_of_problem label ({freshno; div; conv; ps; deltas} as p) =
  Console.print_hline ();
- prerr_string ("\n(* DISPLAY PROBLEM (" ^ label ^ ") - ");
+ prerr_string ("\n(* DISPLAY PROBLEM (" ^ p.label ^ " - " ^ label ^ ") ");
  let nl = "\n" in
  let deltas = String.concat (nl^"   ") (List.map (fun r -> String.concat " <> " (List.map (fun (i,_) -> string_of_int i) !r)) deltas) in
  let l = Array.to_list (Array.init (freshno + 1) string_of_var) in
@@ -244,7 +248,7 @@ exception Dangerous
 
 let arity_of arities k =
  let _,pos,y = List.find (fun (v,_,_) -> v=k) arities in
- let arity = match y with `Var _ -> 0 | `I(_,args) -> Listx.length args | _ -> assert false in
+ let arity = match y with `Var _ -> 0 | `I(_,args) -> Listx.length args | `N _ -> assert false in
  arity + if pos = -1 then - 1 else 0
 ;;
 
@@ -663,33 +667,43 @@ let env_of_sigma freshno sigma should_explode =
       else ([],Pure.V n,[]))::e
  in aux 0
 ;;
+(* ************************************************************************** *)
+
+type result = [
+ | `Separable of (int * Num.nf) list
+ | `Unseparable of string
+]
+
+let check p =
+ (* check if there are duplicates in p.ps *)
+ (* FIXME what about initial fragments? *)
+ if (let rec f = function
+     | [] -> false
+     | hd::tl -> List.exists (eta_eq hd) tl || f tl in
+   f p.ps)
+  then Some "ps contains duplicate entries"
+ (* check if div occurs somewhere in ps@conv *)
+ else match p.div with
+  | None -> None
+  | Some div ->
+     if (List.exists (eta_subterm div) (p.ps@p.conv))
+      then Some "div occurs as subterm in ps or conv"
+      else None
+;;
 
-let solve p  =
+let solve p =
+ prerr_endline (string_of_problem "main" p);
+ match check p with
+ | Some s -> `Unseparable s
+ | None ->
  bomb := `Var(-1,-666);
- if List.for_all (function `N _ -> true | _ -> false) p.ps && p.div = None
-  then (prerr_endline "Initial problem is already completed, nothing to do")
-  else (
-  Console.print_hline();
-  prerr_endline (string_of_problem "main" p);
-  let p_finale = auto p p.initialSpecialK in
-  let freshno,sigma = p_finale.freshno, p_finale.sigma in
-  prerr_endline ("------- <DONE> ------ measure=. \n ");
-  (* prerr_endline (string_of_problem "Original problem" p); *)
-  (* prerr_endline "---------------------"; *)
-  let l = Array.to_list (Array.init (freshno + 1) string_of_var) in
-  (* prerr_endline "---------------------"; *)
-  List.iter (fun (x,inst) -> prerr_endline (string_of_var x ^ " := " ^ print ~l inst)) sigma;
-(*
-   prerr_endline "----------------------";
-   let ps =
-    List.fold_left (fun ps (x,inst) ->
-     (* CSC: XXXX Is the subst always sorted correctly? Otherwise, implement a recursive subst *)
-     (* In this non-recursive version, the intermediate states may containt Matchs *)
-     List.map (fun t -> let t = subst false x inst (t :> nf) in cast_to_i_num_var t) ps)
-     (p.ps :> i_num_var list) sigma in
-   prerr_endline (string_of_problem {p with ps= List.map (function t -> cast_to_i_n_var t) ps; freshno});
-   List.iteri (fun i (n,more_args) -> assert (more_args = 0 && n = `N i)) ps ;
-*)
+ Console.print_hline();
+ let p_finale = auto p p.initialSpecialK in
+ let freshno,sigma = p_finale.freshno, p_finale.sigma in
+ prerr_endline ("------- <DONE> ------ measure=. \n ");
+ let l = Array.to_list (Array.init (freshno + 1) string_of_var) in
+ List.iter (fun (x,inst) -> prerr_endline (string_of_var x ^ " := " ^ print ~l inst)) sigma;
+
   prerr_endline "---------<OPT>----------";
   let sigma = optimize_numerals p_finale in (* optimize numerals *)
   let l = Array.to_list (Array.init (freshno + 1) string_of_var) in
@@ -704,17 +718,6 @@ let solve p  =
   let sigma' = List.map (fun (x,inst) -> x, ToScott.t_of_nf inst) sigma in
   let e' = env_of_sigma freshno sigma' false (* FIXME shoudl_explode *) in
 
-(*
-   prerr_endline "---------<PPP>---------";
-let rec print_e e =
-"[" ^ String.concat ";" (List.map (fun (e,t,[]) -> print_e e ^ ":" ^ Pure.print t) e) ^ "]"
-in
-   prerr_endline (print_e e);
-   List.iter (fun (t,t_ok) ->
-    prerr_endline ("T0= " ^ Pure.print t ^ "\nTM= " ^ Pure.print (Pure.unwind (e,t,[])) ^ "\nOM= " ^ Pure.print t_ok);
-    (*assert (Pure.unwind (e,t,[]) = t_ok)*)
-   ) (List.combine ps ps_ok);
-*)
   prerr_endline "--------<REDUCE>---------";
   let pure_bomb = ToScott.t_of_nf (!bomb) in (* Pure.B *)
   (function Some div ->
@@ -735,57 +738,59 @@ in
     verbose ((string_of_int i) ^ ":: " ^ (Pure.print t));
     assert (t = Scott.mk_n i)
   ) ps ;
-  prerr_endline "-------- </DONE> --------"
- )
+  prerr_endline "-------- </DONE> --------";
+  `Separable p_finale.sigma
 ;;
 
-(********************** problems *******************)
-
 let zero = `Var(0,0);;
 
 let append_zero =
  function
   | `I _
-  | `Var _ as i ->  cast_to_i_n_var (mk_app i zero)
-  | _ -> assert false
+  | `Var _ as i -> cast_to_i_n_var (mk_app i zero)
+  | `N _ -> raise (Parser.ParsingError " numbers in ps")
+;;
+
+let tmp (label, div, conv, nums, var_names) =
+ (* DA SPOSTARE NEI TEST: *)
+ let ps = List.map append_zero nums in (* crea lista applicando zeri o dummies *)
+ let ps = sort_uniq ~compare:eta_compare (ps :> nf list) in
+ let ps = List.map (cast_to_i_n_var) ps in
+
+ (* TODO: *)
+ (* replace div with bottom in problem??? *)
+ let all_tms = (match div with None -> [] | Some div -> [(div :> i_n_var)]) @ nums @ conv in
+ if all_tms = [] then failwith "FIXME: empty problem";
+ let initialSpecialK = compute_special_k (Listx.from_list (all_tms :> nf list)) in
+ let freshno = List.length var_names in
+ let deltas =
+  let dummy = `Var (max_int / 2, -666) in
+   [ ref (Array.to_list (Array.init (List.length ps) (fun i -> i, dummy))) ] in
+ {freshno; div; conv; ps; sigma=[]; deltas; initialSpecialK; var_names; label}
 ;;
 
 let problem_of ~div ~conv ~nums =
- let all_tms = (match div with None -> [] | Some div -> print_endline(div);[div]) @ nums @ conv in
-  let all_tms, var_names = parse' all_tms in
-  let div, (tms, conv) = match div with
-    | None -> None, list_cut (List.length nums, all_tms)
-    | Some _ -> Some (List.hd all_tms), list_cut (List.length nums, List.tl all_tms) in
-
- if match div with None -> false | Some div -> List.exists (eta_subterm div) (tms@conv)
- then (
-  prerr_endline "--- TEST SKIPPED ---";
-  {freshno=0; div=None; conv=[]; ps=[]; sigma=[]; deltas=[]; initialSpecialK=0}
- ) else
-  let tms = sort_uniq ~compare:eta_compare tms in
-  let special_k = compute_special_k (Listx.from_list all_tms) in (* compute initial special K *)
-  (* casts *)
-  let div =
-   match div with
-    | None -> None
-    | Some (`I _ as t) -> Some t
-    | _ -> raise (Failure "div is not an inert or BOT in the initial problem") in
-  let conv = Util.filter_map (
-   function
-   | #i_n_var as t -> Some t
-   | `Lam _ -> None
-   | _ -> raise (Failure "A term in conv is not i_n_var")
-   ) conv in
-  let tms = List.map (
-   function
-    | #i_n_var as y -> y
-    | _ -> raise (Failure "A term in num is not i_n_var")
-   ) tms in
-
-  let ps = List.map append_zero tms in (* crea lista applicando zeri o dummies *)
-  let freshno = List.length var_names in
-  let deltas =
-   let dummy = `Var (max_int / 2, -666) in
-    [ ref (Array.to_list (Array.init (List.length ps) (fun i -> i, dummy))) ] in
-  {freshno; div; conv; ps; sigma=[] ; deltas; initialSpecialK=special_k}
+ let all_tms = (match div with None -> [] | Some div -> [div]) @ nums @ conv in
+ let all_tms, var_names = Parser.parse' all_tms in
+ let div, (ps, conv) = match div with
+   | None -> None, list_cut (List.length nums, all_tms)
+   | Some _ -> Some (List.hd all_tms), list_cut (List.length nums, List.tl all_tms) in
+
+ let div =
+  match div with
+   | None -> None
+   | Some (`I _ as t) -> Some t
+   | _ -> raise (Parser.ParsingError "div is not an inert or BOT in the initial problem") in
+ let conv = Util.filter_map (
+  function
+  | #i_n_var as t -> Some t
+  | `Lam _ -> None
+  | _ -> raise (Parser.ParsingError "A term in conv is not i_n_var")
+  ) conv in
+ let ps = List.map (
+  function
+   | #i_n_var as y -> y
+   | _ -> raise (Parser.ParsingError "A term in num is not i_n_var")
+  ) ps in
+ tmp("missing label", div, conv, ps, var_names)
 ;;