From 059db27238ba60f5c6bdf229bdb2265fa194a280 Mon Sep 17 00:00:00 2001
From: Andrea Asperti <andrea.asperti@unibo.it>
Date: Wed, 30 Jul 2003 12:58:07 +0000
Subject: [PATCH] Eta fixing for MTCases added (that meant to recursively pass
 around the context).

---
 helm/ocaml/cic_omdoc/eta_fixing.ml | 88 +++++++++++++++++++++++-------
 1 file changed, 69 insertions(+), 19 deletions(-)

diff --git a/helm/ocaml/cic_omdoc/eta_fixing.ml b/helm/ocaml/cic_omdoc/eta_fixing.ml
index 8407f8357..876c5c678 100644
--- a/helm/ocaml/cic_omdoc/eta_fixing.ml
+++ b/helm/ocaml/cic_omdoc/eta_fixing.ml
@@ -162,16 +162,17 @@ let fix_according_to_type ty hd tl =
 ;;
 
 let eta_fix metasenv t =
- let rec eta_fix' t = 
-(*  prerr_endline ("entering aux with: term=" ^ CicPp.ppterm t); 
-  flush stderr ; *)
+ let rec eta_fix' context t = 
+  prerr_endline ("entering aux with: term=" ^ CicPp.ppterm t); 
+  flush stderr ; 
   let module C = Cic in
+  let module S = CicSubstitution in
   match t with
      C.Rel n -> C.Rel n 
    | C.Var (uri,exp_named_subst) ->
       let exp_named_subst' =
        List.map
-        (function i,t -> i, (eta_fix' t)) exp_named_subst
+        (function i,t -> i, (eta_fix' context t)) exp_named_subst
       in
       C.Var (uri,exp_named_subst')
    | C.Meta (n,l) ->
@@ -183,19 +184,25 @@ let eta_fix metasenv t =
          (fun ct t ->
           match (ct, t) with
             None, _ -> None
-          | _, Some t -> Some (eta_fix' t)
+          | _, Some t -> Some (eta_fix' context t)
           | Some _, None -> assert false (* due to typing rules *))
         canonical_context l
        in
        C.Meta (n,l')
    | C.Sort s -> C.Sort s
    | C.Implicit -> C.Implicit
-   | C.Cast (v,t) -> C.Cast (eta_fix' v, eta_fix' t)
-   | C.Prod (n,s,t) -> C.Prod (n, eta_fix' s, eta_fix' t)
-   | C.Lambda (n,s,t) -> C.Lambda (n, eta_fix' s, eta_fix' t)
-   | C.LetIn (n,s,t) -> C.LetIn (n, eta_fix' s, eta_fix' t)
+   | C.Cast (v,t) -> C.Cast (eta_fix' context v, eta_fix' context t)
+   | C.Prod (n,s,t) -> 
+       C.Prod 
+        (n, eta_fix' context s, eta_fix' ((Some (n,(C.Decl s)))::context) t)
+   | C.Lambda (n,s,t) -> 
+       C.Lambda 
+        (n, eta_fix' context s, eta_fix' ((Some (n,(C.Decl s)))::context) t)
+   | C.LetIn (n,s,t) -> 
+       C.LetIn 
+        (n, eta_fix' context s, eta_fix' ((Some (n,(C.Def s)))::context) t)
    | C.Appl l as appl -> 
-       let l' =  List.map eta_fix' l 
+       let l' =  List.map (eta_fix' context) l 
        in 
        (match l' with
          C.Const(uri,exp_named_subst)::l'' ->
@@ -216,37 +223,80 @@ let eta_fix metasenv t =
    | C.Const (uri,exp_named_subst) ->
        let exp_named_subst' =
        List.map
-        (function i,t -> i, (eta_fix' t)) exp_named_subst
+        (function i,t -> i, (eta_fix' context t)) exp_named_subst
        in
        C.Const (uri,exp_named_subst')
    | C.MutInd (uri,tyno,exp_named_subst) ->
        let exp_named_subst' =
        List.map
-        (function i,t -> i, (eta_fix' t)) exp_named_subst
+        (function i,t -> i, (eta_fix' context t)) exp_named_subst
        in
         C.MutInd (uri, tyno, exp_named_subst')
    | C.MutConstruct (uri,tyno,consno,exp_named_subst) ->
        let exp_named_subst' =
        List.map
-        (function i,t -> i, (eta_fix' t)) exp_named_subst
+        (function i,t -> i, (eta_fix' context t)) exp_named_subst
        in
         C.MutConstruct (uri, tyno, consno, exp_named_subst')
-   | C.MutCase (uri, tyno, outty, term, patterns) ->
-       C.MutCase (uri, tyno, eta_fix' outty,
-              eta_fix' term, List.map eta_fix' patterns)
+   | C.MutCase (uri, tyno, outty, term, patterns) as prima ->
+       let outty' =  eta_fix' context outty in
+       let term' = eta_fix' context term in
+       let patterns' = List.map (eta_fix' context) patterns in
+       let inductive_types,noparams =
+           (match CicEnvironment.get_obj uri with
+               Cic.Constant _ -> assert false
+             | Cic.Variable _ -> assert false
+             | Cic.CurrentProof _ -> assert false
+             | Cic.InductiveDefinition (l,_,n) -> l,n 
+           ) in
+       let (_,_,_,constructors) = List.nth inductive_types tyno in
+        prerr_endline ("QUI"); 
+       let constructor_types = 
+         let rec clean_up t =
+           function 
+               [] -> t
+             | a::tl -> 
+                 (match t with
+                   Cic.Prod (_,_,t') -> clean_up (S.subst a t') tl
+                  | _ -> assert false) in
+          if noparams = 0 then 
+            List.map (fun (_,t) -> t) constructors 
+          else 
+	    let term_type = 
+              CicTypeChecker.type_of_aux' metasenv context term in
+            (match term_type with
+               C.Appl (hd::params) -> 
+                 List.map (fun (_,t) -> clean_up t params) constructors
+             | _ -> prerr_endline ("QUA"); assert false) in 
+       let patterns2 = 
+         List.map2 fix_lambdas_wrt_type
+           constructor_types patterns in 
+       let dopo = 
+         C.MutCase (uri, tyno, outty',term',patterns2) in
+       if not (CicReduction.are_convertible [] prima dopo) then 
+             (prerr_endline ("prima :" ^(CicPp.ppterm prima)); 
+              prerr_endline ("dopo :" ^(CicPp.ppterm dopo)));
+           dopo
    | C.Fix (funno, funs) ->
+       let fun_types = 
+         List.map (fun (n,_,ty,_) -> Some (C.Name n,(Cic.Decl ty))) funs in
        C.Fix (funno,
         List.map
          (fun (name, no, ty, bo) ->
-           (name, no, eta_fix' ty, eta_fix' bo)) funs)
+           (name, no, eta_fix' context ty, eta_fix' (fun_types@context) bo)) 
+        funs)
    | C.CoFix (funno, funs) ->
+       let fun_types = 
+         List.map (fun (n,ty,_) -> Some (C.Name n,(Cic.Decl ty))) funs in
        C.CoFix (funno,
         List.map
          (fun (name, ty, bo) ->
-           (name, eta_fix' ty, eta_fix' bo)) funs)
+           (name, eta_fix' context ty, eta_fix' (fun_types@context) bo)) funs)
    in
-   eta_fix' t
+   eta_fix' [] t
 ;;
 
 
 
+
+
-- 
2.39.2