X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fsoftware%2Fcomponents%2Ftactics%2Finversion.ml;h=fa4b71178a7886ba20c3ded480c323c0e4ea3b50;hb=f9abd21eb0d26cf9b632af4df819225be4d091e3;hp=d80814fc363da2945b236a42381ba67e2e8b03bd;hpb=61a2faa2694907757dd617175e0144705e79d65a;p=helm.git

diff --git a/helm/software/components/tactics/inversion.ml b/helm/software/components/tactics/inversion.ml
index d80814fc3..fa4b71178 100644
--- a/helm/software/components/tactics/inversion.ml
+++ b/helm/software/components/tactics/inversion.ml
@@ -49,22 +49,25 @@ let rec baseuri_of_term = function
  | _ -> raise (Invalid_argument "baseuri_of_term")
 
 (* returns DX1 = DX1 -> ... DXn=DXn -> GOALTY *)
-let rec foo_cut nleft parameters parameters_ty body uri_of_eq = 
+let rec foo_cut nleft parameters parameters_ty body uri_of_eq selections = 
  if nleft > 0 
  then 
   foo_cut (nleft-1) (List.tl parameters)  (List.tl parameters_ty) body 
-   uri_of_eq
+   uri_of_eq selections
  else
-  match parameters with
-   | hd::tl -> 
+  match parameters,selections with
+   | hd::tl, x::xs when x -> 
     Cic.Prod (
      Cic.Anonymous, 
      Cic.Appl[Cic.MutInd (uri_of_eq  ,0,[]);
       (List.hd parameters_ty) ; hd; hd], 
      foo_cut nleft (List.map (CicSubstitution.lift 1) tl) 
       (List.map (CicSubstitution.lift 1) (List.tl parameters_ty)) 
-      (CicSubstitution.lift 1 body) uri_of_eq )
-   | [] -> body
+      (CicSubstitution.lift 1 body) uri_of_eq xs)
+   | hd::tl,x::xs ->
+      foo_cut nleft tl (List.tl parameters_ty) body uri_of_eq xs
+   | [],[] -> body
+   | _ -> raise (Invalid_argument "inverter: the selection doesn't match the arity of the specified inductive type")
 ;;
 
 (* from a complex Cic.Prod term, return the list of its components *)
@@ -106,10 +109,15 @@ let foo_appl nleft nright_consno term uri =
 ;;
 
 
+(* induction/inversion, abbastanza semplicemente, consiste nel generare i prod
+ * delle uguaglianze corrispondenti ai soli parametri destri appartenenti all'insieme S.
+ * Attenzione al caso base: cos'e` replace_lifting?
+ * S = {} e` il principio di induzione
+ * S = insieme_dei_destri e` il principio di inversione *)
 let rec foo_prod nright right_param_tys rightparameters l2 base_rel goalty 
- uri_of_eq rightparameters_ termty isSetType term =
-  match right_param_tys with
-   | hd::tl -> Cic.Prod (
+ uri_of_eq rightparameters_ termty isSetType term selections selections_ =
+  match right_param_tys, selections with
+   | hd::tl, x::xs when x -> Cic.Prod (
     Cic.Anonymous, 
     Cic.Appl
      [Cic.MutInd(uri_of_eq,0,[]); hd; (List.hd rightparameters); 
@@ -121,20 +129,32 @@ let rec foo_prod nright right_param_tys rightparameters l2 base_rel goalty
      base_rel (CicSubstitution.lift 1 goalty) uri_of_eq
      (List.map (CicSubstitution.lift 1) rightparameters_) 
      (CicSubstitution.lift 1 termty)
-     isSetType (CicSubstitution.lift 1 term))
-   | [] -> ProofEngineReduction.replace_lifting 
-    ~equality:(ProofEngineReduction.alpha_equivalence)
+     isSetType (CicSubstitution.lift 1 term)) xs selections_
+   | hd::tl, x::xs -> 
+       foo_prod (nright-1) tl (List.tl rightparameters) l2 
+                        (base_rel-1) goalty uri_of_eq rightparameters_ termty
+                        isSetType term xs selections_
+   | [],[] -> 
+       ProofEngineReduction.replace_lifting 
+    ~equality:(fun _ -> CicUtil.alpha_equivalence)
+    ~context:[]
     ~what: (if isSetType
-     then (rightparameters_ @ [term] ) 
-     else (rightparameters_ ) )
+     then rightparameters_ @ [term]
+     else rightparameters_ ) 
     ~with_what: (List.map (CicSubstitution.lift (-1)) l2)
     ~where:goalty 
+   | _ -> raise (Invalid_argument "inverter: the selection doesn't match the arity of the specified inductive type")
 (* the same subterm of goalty could be simultaneously sx and dx!*)
 ;;
 
+(* induction/inversion, abbastanza semplicemente, consiste nel generare i lambda
+ * soltanto per i parametri destri appartenenti all'insieme S.
+ * Warning: non ne sono piu` cosi` sicuro...
+ * S = {} e` il principio di induzione
+ * S = insieme_dei_destri e` il principio di inversione *)
 let rec foo_lambda nright right_param_tys nright_ right_param_tys_ 
  rightparameters created_vars base_rel goalty uri_of_eq rightparameters_ 
- termty isSetType term =
+ termty isSetType term selections =
   match right_param_tys with
    | hd::tl -> Cic.Lambda (
     (Cic.Name ("lambda" ^ (string_of_int nright))),
@@ -147,11 +167,12 @@ let rec foo_lambda nright right_param_tys nright_ right_param_tys_
      base_rel (CicSubstitution.lift 1 goalty) uri_of_eq
      (List.map (CicSubstitution.lift 1) rightparameters_) 
      (CicSubstitution.lift 1 termty) isSetType
-     (CicSubstitution.lift 1 term)) 
+     (CicSubstitution.lift 1 term)) selections
    | [] when isSetType -> Cic.Lambda (
     (Cic.Name ("lambda" ^ (string_of_int nright))),
     (ProofEngineReduction.replace_lifting
-     ~equality:(ProofEngineReduction.alpha_equivalence)
+     ~equality:(fun _ -> CicUtil.alpha_equivalence)
+     ~context:[]
      ~what: (rightparameters_ ) 
      ~with_what: (List.map (CicSubstitution.lift (-1)) created_vars)
      ~where:termty), (* type of H with replaced right parameters *)
@@ -161,10 +182,10 @@ let rec foo_lambda nright right_param_tys nright_ right_param_tys_
      (base_rel+1) (CicSubstitution.lift 1 goalty) uri_of_eq
      (List.map (CicSubstitution.lift 1) rightparameters_) 
      (CicSubstitution.lift 1 termty) isSetType
-     (CicSubstitution.lift 1 term))
+     (CicSubstitution.lift 1 term)) selections selections 
    | [] -> foo_prod nright_ right_param_tys_ rightparameters created_vars 
-   base_rel goalty uri_of_eq rightparameters_ 
-    termty isSetType term
+             base_rel goalty uri_of_eq rightparameters_ 
+             termty isSetType term selections selections
 ;;
 
 let isSetType paramty = ((Pervasives.compare 
@@ -172,7 +193,7 @@ let isSetType paramty = ((Pervasives.compare
   (Cic.Sort Cic.Prop)) != 0) 
 
 exception EqualityNotDefinedYet
-let private_inversion_tac ~term =
+let private_inversion_tac ~term selections =
  let module T = CicTypeChecker in
  let module R = CicReduction in
  let module C = Cic in
@@ -181,16 +202,16 @@ let private_inversion_tac ~term =
  let private_inversion_tac ~term (proof, goal) =
  
  (*DEBUG*) debug_print (lazy  ("private inversion begins"));
- let _,metasenv,_,_, _ = proof in
+ let _,metasenv,_subst,_,_, _ = proof in
  let uri_of_eq =
   match LibraryObjects.eq_URI () with
      None -> raise EqualityNotDefinedYet
   | Some uri -> uri
  in
  let (_,context,goalty) = CicUtil.lookup_meta goal metasenv in
- let termty,_ = T.type_of_aux' metasenv context term CicUniv.empty_ugraph in
+ let termty,_ = T.type_of_aux' metasenv context term CicUniv.oblivion_ugraph in
  let uri = baseuri_of_term termty in  
- let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
+ let o,_ = CicEnvironment.get_obj CicUniv.oblivion_ugraph uri in
  let (_,_,typeno,_) =
   match termty with
    C.MutInd (uri,typeno,exp_named_subst) -> (uri,exp_named_subst,typeno,[])
@@ -213,7 +234,7 @@ let private_inversion_tac ~term =
  let parameters_tys =  
   (List.map 
    (fun t -> (
-    match (T.type_of_aux' metasenv context t CicUniv.empty_ugraph) with
+    match (T.type_of_aux' metasenv context t CicUniv.oblivion_ugraph) with
      (term,graph) -> term))
    parameters) 
  in
@@ -221,7 +242,7 @@ let private_inversion_tac ~term =
  let nright= ((List.length parameters)- nleft) in 
  let isSetType = isSetType paramty in
  let cut_term = foo_cut nleft parameters 
-  parameters_tys goalty uri_of_eq in
+  parameters_tys goalty uri_of_eq selections in
  (*DEBUG*)  debug_print (lazy ("cut term " ^ CicPp.ppterm cut_term));
   debug_print (lazy ("CONTEXT before apply HCUT: " ^ 
    (CicMetaSubst.ppcontext ~metasenv [] context )));
@@ -238,16 +259,18 @@ let private_inversion_tac ~term =
  (*DEBUG*) debug_print (lazy  ("after apply HCUT;reflexivity 
   in private inversion"));
  (* apply (ledx_ind( lambda x. lambda y, ...)) *)
- let t1,metasenv,t3,t4, attrs = proof2 in
+ let t1,metasenv,_subst,t3,t4, attrs = proof2 in
  let goal2 = List.hd (List.tl gl1) in
- let (_,context,_) = CicUtil.lookup_meta goal2 metasenv in
+ let (_,context,g2ty) = CicUtil.lookup_meta goal2 metasenv in
  (* rightparameters type list *)
  let rightparam_ty_l = (cut_first nleft parameters_tys) in
  (* rightparameters list *)
  let rightparameters= cut_first nleft parameters in
+ debug_print 
+  (lazy ("Right param: " ^ (CicPp.ppterm (Cic.Appl rightparameters))));
  let lambda_t = foo_lambda nright rightparam_ty_l nright rightparam_ty_l 
  rightparameters [] nright goalty uri_of_eq rightparameters termty isSetType
- term in 
+ term selections in 
  let t = foo_appl nleft (nright+consno) lambda_t eliminator_uri in
  debug_print (lazy ("Lambda_t: " ^ (CicPp.ppterm t)));
  debug_print (lazy ("Term: " ^ (CicPp.ppterm termty)));
@@ -259,17 +282,17 @@ let private_inversion_tac ~term =
   (*DEBUG*) debug_print (lazy  ("private inversion: term before refinement: " ^ 
    CicPp.ppterm t));
  let (ref_t,_,metasenv'',_) = CicRefine.type_of_aux' metasenv context t 
-  CicUniv.empty_ugraph 
+  CicUniv.oblivion_ugraph 
  in
  (*DEBUG*) debug_print (lazy  ("private inversion: termine after refinement: "
   ^ CicPp.ppterm ref_t));
- let proof2 = (t1,metasenv'',t3,t4, attrs) in
+ let proof2 = (t1,metasenv'',_subst,t3,t4, attrs) in
  let my_apply_tac =
   let my_apply_tac status =
    let proof,goals = 
     ProofEngineTypes.apply_tactic (P.apply_tac ref_t) status in
    let patched_new_goals =
-    let (_,metasenv''',_,_, _) = proof in
+    let (_,metasenv''',_subst,_,_, _) = proof in
     let new_goals = ProofEngineHelpers.compare_metasenvs
      ~oldmetasenv:metasenv ~newmetasenv:metasenv''
     in
@@ -303,9 +326,9 @@ let inversion_tac ~term =
  let module PET = ProofEngineTypes in
  let inversion_tac ~term (proof, goal) =
  (*DEBUG*) debug_print (lazy ("inversion begins"));
-  let _,metasenv,_,_, _ = proof in
+  let _,metasenv,_subst,_,_, _ = proof in
   let (_,context,goalty) = CicUtil.lookup_meta goal metasenv in
-  let termty,_ = T.type_of_aux' metasenv context term CicUniv.empty_ugraph in
+  let termty,_ = T.type_of_aux' metasenv context term CicUniv.oblivion_ugraph in
   let uri, typeno = 
     match termty with
       | Cic.MutInd (uri,typeno,_) 
@@ -313,7 +336,7 @@ let inversion_tac ~term =
       | _ -> assert false
   in
   (* let uri = baseuri_of_term termty in *)
-  let obj,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
+  let obj,_ = CicEnvironment.get_obj CicUniv.oblivion_ugraph uri in
   let name,nleft,arity,cons_list =
    match obj with
     Cic.InductiveDefinition (tys,_,nleft,_) ->
@@ -334,19 +357,19 @@ let inversion_tac ~term =
    for n = 1 to arity_consno do
     a := (Cic.Implicit None)::(!a)
    done;
-  (* apply    i_inv             ? ...?      H).     *)
-  Cic.Appl ([Cic.Const(uri,[])] @ !a @ [Cic.Rel 1])
+   (* apply    i_inv             ? ...?      H).     *)
+   Cic.Appl ([Cic.Const(uri,[])] @ !a @ [term])
   in
   let t = appl_term (arity_length + (List.length cons_list)) inversor_uri in
-  let (t1,metasenv,t3,t4, attrs) = proof in
+  let (t1,metasenv,_subst,t3,t4, attrs) = proof in
   let (ref_t,_,metasenv'',_) = CicRefine.type_of_aux' metasenv context t
-  CicUniv.empty_ugraph 
+  CicUniv.oblivion_ugraph 
   in
-  let proof = (t1,metasenv'',t3,t4, attrs) in
+  let proof = (t1,metasenv'',_subst,t3,t4, attrs) in
   let proof3,gl3 = 
      ProofEngineTypes.apply_tactic (P.apply_tac ref_t) (proof,goal) in
   let patched_new_goals =
-     let (_,metasenv''',_,_, _) = proof3 in
+     let (_,metasenv''',_subst,_,_, _) = proof3 in
      let new_goals = ProofEngineHelpers.compare_metasenvs
       ~oldmetasenv:metasenv ~newmetasenv:metasenv''
      in