From a1ff37abdbcdf931ff3fa2396c629b95344a0849 Mon Sep 17 00:00:00 2001
From: Enrico Tassi <enrico.tassi@inria.fr>
Date: Thu, 15 May 2008 14:12:21 +0000
Subject: [PATCH] Implementation of calculation of heights.

---
 .../components/ng_kernel/oCic2NCic.ml         | 62 ++++++++++++++++---
 1 file changed, 55 insertions(+), 7 deletions(-)

diff --git a/helm/software/components/ng_kernel/oCic2NCic.ml b/helm/software/components/ng_kernel/oCic2NCic.ml
index 6a9dd715a..0e6ebe32f 100644
--- a/helm/software/components/ng_kernel/oCic2NCic.ml
+++ b/helm/software/components/ng_kernel/oCic2NCic.ml
@@ -398,6 +398,52 @@ prerr_endline ("CACHE SAME NAME: " ^ NReference.string_of_reference ref ^ " <==>
  with Found ref -> Some ref
 ;;
 
+let rec get_height =
+ let cache = UriManager.UriHashtbl.create 313 in
+   function u ->
+     try
+       UriManager.UriHashtbl.find cache u
+     with
+      Not_found ->
+        let h = ref 0 in
+         let res =
+          match fst (CicEnvironment.get_obj CicUniv.oblivion_ugraph u) with
+             Cic.Constant (_,Some bo,ty,params,_)
+           | Cic.Variable (_,Some bo,ty,params,_) ->
+               ignore (height_of_term ~h bo);
+               ignore (height_of_term ~h ty);
+               List.iter (function uri -> h := max !h (get_height uri)) params;
+               1 + !h
+           | _ -> 0
+         in
+           UriManager.UriHashtbl.add cache u res;
+           res
+and height_of_term ?(h=ref 0) t =
+ let rec aux =
+  function
+   Cic.Rel _
+ | Cic.Sort _ -> ()
+ | Cic.Implicit _ -> assert false
+ | Cic.Var (uri,exp_named_subst)
+ | Cic.Const (uri,exp_named_subst)
+ | Cic.MutInd (uri,_,exp_named_subst)
+ | Cic.MutConstruct (uri,_,_,exp_named_subst) ->
+    h := max !h (get_height uri);
+    List.iter (function (_,t) -> aux t) exp_named_subst
+ | Cic.Meta (i,l) -> List.iter (function None -> () | Some t -> aux t) l
+ | Cic.Cast (t1,t2)
+ | Cic.Prod (_,t1,t2)
+ | Cic.Lambda (_,t1,t2) -> aux t1; aux t2
+ | Cic.LetIn (_,s,ty,t) -> aux s; aux ty; aux t
+ | Cic.Appl l -> List.iter aux l
+ | Cic.MutCase (_,_,outty,t,pl) -> aux outty; aux t; List.iter aux pl
+ | Cic.Fix (_, fl) -> List.iter (fun (_, _, ty, bo) ->  aux ty; aux bo) fl
+ | Cic.CoFix (_, fl) -> List.iter (fun (_, ty, bo) ->  aux ty; aux bo) fl
+ in
+   aux t;
+   1 + !h
+;;
+
 (* we are lambda-lifting also variables that do not occur *)
 (* ctx does not distinguish successive blocks of cofix, since there may be no
  *   lambda separating them *)
@@ -464,14 +510,14 @@ let convert_term uri t =
         let buri = 
           UriManager.uri_of_string 
            (UriManager.buri_of_uri uri^"/"^
-            UriManager.name_of_uri uri ^ "___" ^ get_fresh () ^ ".con")
-        in
+            UriManager.name_of_uri uri ^ "___" ^ get_fresh () ^ ".con") in
+        let height = height_of_term fix in
         let bad_bctx, fixpoints_tys, tys, _ = 
           List.fold_right 
             (fun (name,recno,ty,_) (bctx, fixpoints, tys, idx) -> 
               let ty, fixpoints_ty = aux true octx ctx n_fix uri ty in
               let r =  (* recno is dummy here, must be lifted by the ctx len *)
-                reference_of_ouri buri (Ref.Fix (idx,recno,1)) 
+                reference_of_ouri buri (Ref.Fix (idx,recno,height)) 
               in
               bctx @ [Fix (lazy (r,name,ty))],
                fixpoints_ty@fixpoints,ty::tys,idx-1)
@@ -507,9 +553,10 @@ let convert_term uri t =
             fl tys ([],fixpoints_tys,0)
         in
         let obj = 
-          nuri_of_ouri buri,max_int,[],[],
+          nuri_of_ouri buri,height,[],[],
             NCic.Fixpoint (true, fl, (`Generated, `Definition)) in
-        let r = reference_of_ouri buri (Ref.Fix (fixno,!rno_fixno,1)) in
+(*prerr_endline ("H(" ^ UriManager.string_of_uri buri ^ ") = " ^ string_of_int * height);*)
+        let r = reference_of_ouri buri (Ref.Fix (fixno,!rno_fixno,height)) in
         let obj,r =
          let _,name,_,_,_ = List.nth fl fixno in
          match find_in_cache name obj r with
@@ -587,7 +634,7 @@ let convert_term uri t =
        aux_ens k curi octx ctx n_fix uri ens
         (match fst(CicEnvironment.get_obj CicUniv.oblivion_ugraph curi) with
         | Cic.Constant (_,Some _,_,_,_) ->
-               NCic.Const (reference_of_ouri curi (Ref.Def 1))
+               NCic.Const (reference_of_ouri curi (Ref.Def (get_height curi)))
         | Cic.Constant (_,None,_,_,_) ->
                NCic.Const (reference_of_ouri curi Ref.Decl)
         | _ -> assert false)
@@ -733,6 +780,7 @@ let convert_obj_aux uri = function
 let convert_obj uri obj = 
   reset_seed ();
   let o, fixpoints = convert_obj_aux uri obj in
-  let obj = nuri_of_ouri uri,max_int, [], [], o in
+  let obj = nuri_of_ouri uri,get_height uri, [], [], o in
+(*prerr_endline ("H(" ^ UriManager.string_of_uri uri ^ ") = " ^ string_of_int * (get_height uri));*)
   fixpoints @ [obj]
 ;;
-- 
2.39.2