X-Git-Url: http://matita.cs.unibo.it/gitweb/?p=helm.git;a=blobdiff_plain;f=matita%2Fcomponents%2Fng_tactics%2Fdeclarative.ml;h=a136a51dd88afc306661a18aee087139dadaf99f;hp=41584d1d3803237b43639b8bce94118a83a6fc88;hb=784f0d4d7cff3700363affe647f7b8b218726fcb;hpb=5cfd68a5d9e73edb40e1cfe021a1426354767aa8

diff --git a/matita/components/ng_tactics/declarative.ml b/matita/components/ng_tactics/declarative.ml
index 41584d1d3..a136a51dd 100644
--- a/matita/components/ng_tactics/declarative.ml
+++ b/matita/components/ng_tactics/declarative.ml
@@ -43,19 +43,18 @@ let extract_first_goal_from_status status =
   let s = status#stack in
   match s with
   | [] -> fail (lazy "There's nothing to prove")
-  | (g1, _, k, tag1, _) :: tl ->
+  | (g1, _, _k, _tag1, _) :: _tl ->
     let goals = filter_open g1 in
     match goals with
       [] -> fail (lazy "No goals under focus")
-    | loc::tl -> 
+    | loc::_tl -> 
       let goal = goal_of_loc (loc) in
       goal ;;
 
 let extract_conclusion_type status goal =
   let gty = get_goalty status goal in
   let ctx = ctx_of gty in
-  let status,gty = term_of_cic_term status gty ctx in
-  gty
+  term_of_cic_term status gty ctx
 ;;
 
 let alpha_eq_tacterm_kerterm ty t status goal =
@@ -83,7 +82,7 @@ let clear_volatile_params_tac status =
   | (g,t,k,tag,p)::tl -> 
     let rec remove_volatile = function
         [] -> []
-      | (k,v as hd')::tl' ->
+      | (k,_v as hd')::tl' ->
         let re = Str.regexp "volatile_.*" in
         if Str.string_match re k 0 then
           remove_volatile tl'
@@ -94,43 +93,41 @@ let clear_volatile_params_tac status =
     status#set_stack ((g,t,k,tag,newp)::tl)
 ;;
 
+let add_parameter_tac key value status =
+  match status#stack with
+    [] -> status
+  | (g,t,k,tag,p) :: tl -> status#set_stack ((g,t,k,tag,(key,value)::p)::tl)
+;;
+
+
 (* LCF-like tactic that checks whether the conclusion of the sequent of the given goal is a product, checks that
    the type of the conclusion's bound variable is the same as t1 and then uses an exact_tac with
    \lambda id: t1. ?. If a t2 is given it checks that t1 ~_{\beta} t2 and uses and exact_tac with \lambda id: t2. ?
 *)
-let lambda_abstract_tac id t1 t2 status goal =
+let lambda_abstract_tac id t1 status goal =
   match extract_conclusion_type status goal with
-  | NCic.Prod (_,t,_) ->
+  | status,NCic.Prod (_,t,_) ->
     if alpha_eq_tacterm_kerterm t1 t status goal then
-      match t2 with
-      | None ->
-        let (_,_,t1) = t1 in
-        block_tac [exact_tac ("",0,(Ast.Binder (`Lambda,(Ast.Ident (id,None),Some t1),Ast.Implicit
-                                                  `JustOne))); clear_volatile_params_tac] status
-      | Some t2 ->
-        let status,res = are_convertible t1 t2 status goal in
-        if res then
-          let (_,_,t2) = t2 in
-          block_tac [exact_tac ("",0,(Ast.Binder (`Lambda,(Ast.Ident (id,None),Some t2),Ast.Implicit
-                                                    `JustOne))); clear_volatile_params_tac] status
-        else
-          raise NotEquivalentTypes
+      let (_,_,t1) = t1 in
+      block_tac [exact_tac ("",0,(Ast.Binder (`Lambda,(Ast.Ident (id,None),Some t1),Ast.Implicit
+                                                `JustOne))); clear_volatile_params_tac;
+                 add_parameter_tac "volatile_newhypo" id] status
     else
       raise FirstTypeWrong
   | _ -> raise NotAProduct
 
-let assume name ty eqty status =
+let assume name ty status =
   let goal = extract_first_goal_from_status status in
-  try lambda_abstract_tac name ty eqty status goal
+  try lambda_abstract_tac name ty status goal
   with
   | NotAProduct -> fail (lazy "You can't assume without an universal quantification")
   | FirstTypeWrong ->  fail (lazy "The assumed type is wrong")
   | NotEquivalentTypes -> fail (lazy "The two given types are not equivalent")
 ;;
 
-let suppose t1 id t2 status =
+let suppose t1 id status =
   let goal = extract_first_goal_from_status status in
-  try lambda_abstract_tac id t1 t2 status goal
+  try lambda_abstract_tac id t1 status goal
   with
   | NotAProduct -> fail (lazy "You can't suppose without a logical implication")
   | FirstTypeWrong ->  fail (lazy "The supposed proposition is different from the premise")
@@ -138,12 +135,12 @@ let suppose t1 id t2 status =
 ;;
 
 let assert_tac t1 t2 status goal continuation =
-  let t = extract_conclusion_type status goal in
+  let status,t = extract_conclusion_type status goal in
   if alpha_eq_tacterm_kerterm t1 t status goal then
     match t2 with
     | None -> continuation
     | Some t2 ->
-      let status,res = are_convertible t1 t2 status goal in
+      let _status,res = are_convertible t1 t2 status goal in
       if res then continuation
       else
         raise NotEquivalentTypes
@@ -163,12 +160,19 @@ let branch_dot_tac status =
 let status_parameter key status =
   match status#stack with
     [] -> ""
-  | (g,t,k,tag,p)::_ -> try List.assoc key p with _ -> ""
+  | (_g,_t,_k,_tag,p)::_ -> try List.assoc key p with _ -> ""
 ;;
 
 let beta_rewriting_step t status =
   let ctx = status_parameter "volatile_context" status in
-  if ctx <> "beta_rewrite" then fail (lazy "Invalid use of 'or equivalently'")
+  if ctx <> "beta_rewrite" then 
+    (
+      let newhypo = status_parameter "volatile_newhypo" status in
+      if newhypo = "" then
+        fail (lazy "Invalid use of 'that is equivalent to'")
+      else
+        change_tac ~where:("",0,(None,[newhypo,Ast.UserInput],None)) ~with_what:t status
+    )
   else
     change_tac ~where:("",0,(None,[],Some
                                Ast.UserInput)) ~with_what:t status
@@ -214,88 +218,34 @@ let push_goals_tac status =
     else status (* Nothing to push *)
   | _ -> status
 
-let add_parameter_tac key value status =
-  match status#stack with
-    [] -> status
-  | (g,t,k,tag,p) :: tl -> status#set_stack ((g,t,k,tag,(key,value)::p)::tl)
-;;
-
-let we_need_to_prove t id t1 status =
+let we_need_to_prove t id status =
   let goal = extract_first_goal_from_status status in
   match id with
   | None ->
     (
-      match t1 with
-      | None ->  (* We need to prove t *)
-        (
-          try assert_tac t None status goal (add_parameter_tac "volatile_context" "beta_rewrite" status)
-          with
-          | FirstTypeWrong -> fail (lazy "The given proposition is not the same as the conclusion")
-        )
-      | Some t1 -> (* We need to prove t or equivalently t1 *)
-        (
-          try assert_tac t (Some t1) status goal (block_tac [change_tac ~where:("",0,(None,[],Some
-                                                                             Ast.UserInput))
-                                                               ~with_what:t1;
-                                                             add_parameter_tac "volatile_context"
-                                                               "beta_rewrite"] status)
-          with
-          | FirstTypeWrong -> fail (lazy "The given proposition is not the same as the conclusion")
-          | NotEquivalentTypes -> fail (lazy "The given propositions are not equivalent")
-        )
+      try assert_tac t None status goal (add_parameter_tac "volatile_context" "beta_rewrite" status)
+      with
+      | FirstTypeWrong -> fail (lazy "The given proposition is not the same as the conclusion")
     )
   | Some id ->
     (
-      match t1 with
-      (* We need to prove t (id) *)
-      | None -> block_tac [clear_volatile_params_tac; cut_tac t; branch_tac; shift_tac; intro_tac id; merge_tac; branch_tac;
-                           push_goals_tac
+      block_tac [clear_volatile_params_tac; cut_tac t; branch_tac; shift_tac; intro_tac id; merge_tac; branch_tac;
+                 push_goals_tac; add_parameter_tac "volatile_context" "beta_rewrite"
                           ] status
-      (* We need to prove t (id) or equivalently t1 *)
-      | Some t1 ->  block_tac [clear_volatile_params_tac; cut_tac t; branch_tac ; change_tac ~where:("",0,(None,[],Some
-                                                                                  Ast.UserInput))
-                                 ~with_what:t1; shift_tac; intro_tac id; merge_tac;
-                               branch_tac; push_goals_tac
-                              ]
-                      status
     )
 ;;
 
-let by_just_we_proved just ty id ty' status =
+let by_just_we_proved just ty id status =
   let goal = extract_first_goal_from_status status in
-  let wrappedjust = just in
   let just = mk_just status goal just in
   match id with
   | None ->
-    (match ty' with
-     | None -> (* just we proved P done *)
-       (
-         try
-           assert_tac ty None status goal (bydone wrappedjust status)
-         with
-         | FirstTypeWrong -> fail (lazy "The given proposition is not the same as the conclusion")
-         | NotEquivalentTypes -> fail (lazy "The given propositions are not equivalent")
-       )
-     | Some ty' -> (* just we proved P that is equivalent to P' done *)
-       (
-         try
-           assert_tac ty' None status goal (block_tac [change_tac ~where:("",0,(None,[],Some
-                                                                                  Ast.UserInput))
-                                                         ~with_what:ty; bydone wrappedjust]
-                                              status )
-         with
-         | FirstTypeWrong -> fail (lazy "The second proposition is not the same as the conclusion")
-         | NotEquivalentTypes -> fail (lazy "The given propositions are not equivalent")
-       )
-    )
+    assert_tac ty None status goal (block_tac [clear_volatile_params_tac; add_parameter_tac
+                                                 "volatile_context" "beta_rewrite"] status)
   | Some id ->
     (
-      match ty' with
-      | None -> block_tac [cut_tac ty; branch_tac; just; shift_tac; intro_tac id; merge_tac;
-                           clear_volatile_params_tac ] status
-      | Some ty' -> block_tac [cut_tac ty; branch_tac; just; shift_tac; intro_tac id; change_tac
-                                 ~where:("",0,(None,[id,Ast.UserInput],None)) ~with_what:ty';
-                               merge_tac; clear_volatile_params_tac] status
+      block_tac [cut_tac ty; branch_tac; just; shift_tac; intro_tac id; merge_tac;
+                 clear_volatile_params_tac; add_parameter_tac "volatile_newhypo" id] status
     )
 ;;
 
@@ -351,7 +301,7 @@ let swap_first_two_goals_tac status =
   in
   status#set_stack gstatus
 
-let thesisbecomes t1 l = we_need_to_prove t1 None l
+let thesisbecomes t1 = we_need_to_prove t1 None
 ;;
 
 let obtain id t1 status =
@@ -376,6 +326,7 @@ let conclude t1 status =
   let ctx = ctx_of cicgty in
   let _,gty = term_of_cic_term status cicgty ctx in
   match gty with
+    (* The first term of this Appl should probably be "eq" *)
     NCic.Appl [_;_;plhs;_] ->
     if alpha_eq_tacterm_kerterm t1 plhs status goal then
       add_parameter_tac "volatile_context" "rewrite" status
@@ -422,10 +373,7 @@ let rewritingstep rhs just last_step status =
       in
       let continuation =
         if last_step then
-          (*CSC:manca controllo sul fatto che rhs sia convertibile con prhs*)
           let todo = [just'] @ (done_continuation status) in
-          (*       let todo = if mustdot status then List.append todo [dot_tac] else todo *)
-          (*       in *)
           block_tac todo
         else
           let (_,_,rhs) = rhs in
@@ -462,12 +410,12 @@ let print_goals_names_tac s (status:#NTacStatus.tac_status) =
 (* Useful as it does not change the order in the list *)
 let rec list_change_assoc k v = function
     [] -> []
-  | (k',v' as hd) :: tl -> if k' = k then (k',v) :: tl else hd :: (list_change_assoc k v tl)
+  | (k',_v' as hd) :: tl -> if k' = k then (k',v) :: tl else hd :: (list_change_assoc k v tl)
 ;;
 
 let add_names_to_goals_tac (cl:NCic.constructor list ref) (status:#NTacStatus.tac_status) =
   let add_name_to_goal name goal metasenv =
-    let (mattrs,ctx,t as conj) = try List.assoc goal metasenv with _ -> assert false in
+    let (mattrs,ctx,t) = try List.assoc goal metasenv with _ -> assert false in
     let mattrs = (`Name name) :: (List.filter (function `Name _ -> false | _ -> true) mattrs) in
     let newconj = (mattrs,ctx,t) in
     list_change_assoc goal newconj metasenv
@@ -477,7 +425,7 @@ let add_names_to_goals_tac (cl:NCic.constructor list ref) (status:#NTacStatus.ta
      * the new goals, when they are still under focus *)
     match status#stack with
       [] -> fail (lazy "Can not add names to an empty stack")
-    | (g,_,_,_,_) :: tl -> 
+    | (g,_,_,_,_) :: _tl -> 
       let rec sublist n = function
           [] -> []
         | hd :: tl -> if n = 0 then [] else hd :: (sublist (n-1) tl)
@@ -529,7 +477,11 @@ let we_proceed_by_induction_on t1 t2 status =
   let t1 = txt, len, Ast.Appl [t1; Ast.Implicit `Vector] in
   let indtyinfo = ref None in
   let sort = ref (NCic.Rel 1) in
-  let cl = ref [] in
+  let cl = ref [] in (* this is a ref on purpose, as the block of code after sort_of_goal_tac in
+  block_tac acts as a block of asynchronous code, in which cl gets modified with the info retrieved
+  with analize_indty_tac, and later used to label each new goal with a costructor name. Using a
+  plain list this doesn't seem to work, as add_names_to_goals_tac would immediately act on an empty
+  list, instead of acting on the list of constructors *)
   try
     assert_tac t2 None status goal (block_tac [
         analyze_indty_tac ~what:t1 indtyinfo;
@@ -586,7 +538,11 @@ let we_proceed_by_cases_on ((txt,len,ast1) as t1)  t2 status =
   | FirstTypeWrong -> fail (lazy "What you want to prove is different from the conclusion")
 ;;
 
-let byinduction t1 id = suppose t1 id None ;;
+let byinduction t1 id status =
+  let ctx = status_parameter "context" status in
+  if ctx <> "induction" then fail (lazy "You can't use this tactic outside of an induction context")
+  else suppose t1 id status
+;;
 
 let name_of_conj conj =
   let mattrs,_,_ = conj in
@@ -613,7 +569,7 @@ let rec loc_of_goal goal l =
 let has_focused_goal status =
   match status#stack with
     [] -> false
-  | ([],_,_,_,_) :: tl -> false
+  | ([],_,_,_,_) :: _tl -> false
   | _ -> true
 ;;
 
@@ -667,7 +623,7 @@ else
             match l with
               [] -> [id_tac]
             | (id,ty)::tl ->
-              (try_tac (assume id ("",0,ty) None)) :: (aux tl)
+              (try_tac (assume id ("",0,ty))) :: (aux tl)
           in
           aux l
         in