This commit makes ProofEngineHelpers.select reach its full potentials.

[helm.git] / helm / ocaml / tactics / reductionTactics.ml

diff --git a/helm/ocaml/tactics/reductionTactics.ml b/helm/ocaml/tactics/reductionTactics.ml
index 65dc199124e576de389490937a666acb61be0802..af5edd160db47875e8604796969137e93e109fed 100644 (file)
--- a/helm/ocaml/tactics/reductionTactics.ml
+++ b/helm/ocaml/tactics/reductionTactics.ml
@@ -26,98 +26,41 @@
 open ProofEngineTypes
 
 (* The default of term is the thesis of the goal to be prooved *)
-let reduction_tac ~reduction ~pattern:(what,hyp_patterns,goal_pattern)
+let reduction_tac ~reduction ~pattern
  (proof,goal)
 =
   let curi,metasenv,pbo,pty = proof in
-  let metano,context,ty = CicUtil.lookup_meta goal metasenv in
+  let (metano,context,ty) as conjecture = CicUtil.lookup_meta goal metasenv in
   let replace where terms =
-   let terms, terms' = 
-     List.split (List.map (fun (context, t) -> t, reduction context t) terms)
-   in
-    ProofEngineReduction.replace ~equality:(==) ~what:terms ~with_what:terms'
-     ~where:where in
-  let find_pattern_for name =
-    try Some (snd(List.find (fun (n, pat) -> Cic.Name n = name) hyp_patterns))
-    with Not_found -> None in
-  let ty' = 
-   let terms =
-    ProofEngineHelpers.select ~context ~term:ty ~pattern:(what,goal_pattern)
-   in
-    replace ty terms in
-  let context_len = List.length context in
-  let context' =
-    if hyp_patterns <> [] then
-    List.fold_right
-     (fun entry context ->
-       match entry with
-         None -> None::context
-       | Some (name,Cic.Decl term) ->
-           (match find_pattern_for name with
-           | None -> entry::context
-           | Some pat -> 
-              try
-               let what =
-                match what with
-                   None -> None
-                 | Some what ->
-                    let what,subst',metasenv' =
-                     CicMetaSubst.delift_rels [] metasenv
-                      (context_len - List.length context) what
-                    in
-                     assert (subst' = []);
-                     assert (metasenv' = metasenv);
-                     Some what in
-               let terms =
-                ProofEngineHelpers.select ~context ~term ~pattern:(what,pat) in
-               let term' = replace term terms in
-                Some (name,Cic.Decl term') :: context
-              with
-               CicMetaSubst.DeliftingARelWouldCaptureAFreeVariable ->
-                raise
-                 (ProofEngineTypes.Fail
-                   ("The term the user wants to convert is not closed " ^
-                    "in the context of the position of the substitution.")))
-       | Some (name,Cic.Def (term, ty)) ->
-           (match find_pattern_for name with
-           | None -> entry::context
-           | Some pat -> 
-              try
-               let what =
-                match what with
-                   None -> None
-                 | Some what ->
-                    let what,subst',metasenv' =
-                     CicMetaSubst.delift_rels [] metasenv
-                      (context_len - List.length context) what
-                    in
-                     assert (subst' = []);
-                     assert (metasenv' = metasenv);
-                     Some what in
-               let terms =
-                ProofEngineHelpers.select ~context ~term ~pattern:(what,pat) in
-               let term' = replace term terms in
-               let ty' =
-                match ty with
-                   None -> None
-                 | Some ty ->
-                    let terms = 
-                     ProofEngineHelpers.select
-                      ~context ~term:ty ~pattern:(what,pat)
-                    in
-                     Some (replace ty terms)
-               in
-                Some (name,Cic.Def (term',ty')) :: context
-              with
-               CicMetaSubst.DeliftingARelWouldCaptureAFreeVariable ->
-                raise
-                 (ProofEngineTypes.Fail
-                   ("The term the user wants to convert is not closed " ^
-                    "in the context of the position of the substitution.")))
-     ) context []
+   if terms = [] then where
    else
-    context
-  in
+    let terms, terms' = 
+      List.split (List.map (fun (context, t) -> t, reduction context t) terms)
+    in
+     ProofEngineReduction.replace ~equality:(==) ~what:terms ~with_what:terms'
+      ~where:where in
+  let (selected_context,selected_ty) =
+   ProofEngineHelpers.select ~metasenv ~conjecture ~pattern in
+  let ty' = replace ty selected_ty in
+  let context' =
+   List.fold_right2
+    (fun entry selected_entry context' ->
+      match entry,selected_entry with
+         None,None -> None::context'
+       | Some (name,Cic.Decl ty),Some (`Decl selected_ty) ->
+          let ty' = replace ty selected_ty in
+           Some (name,Cic.Decl ty')::context'
+       | Some (name,Cic.Def (bo,ty)),Some (`Def (selected_bo,selected_ty)) ->
+          let bo' = replace bo selected_bo in
+          let ty' =
+           match ty,selected_ty with
+              None,None -> None
+            | Some ty,Some selected_ty -> Some (replace ty selected_ty)
+            | _,_ -> assert false
+          in
+           Some (name,Cic.Def (bo',ty'))::context'
+       | _,_ -> assert false
+    ) context selected_context [] in
   let metasenv' = 
     List.map (function 
       | (n,_,_) when n = metano -> (metano,context',ty')