+exception Nothing_to_do;;
+
+let fix_outty curi tyno t context outty =
+ let leftno,rightno =
+ match fst (CicEnvironment.get_obj CicUniv.oblivion_ugraph curi) with
+ Cic.InductiveDefinition (tyl,_,leftno,_) ->
+ let _,_,arity,_ = List.nth tyl tyno in
+ let rec count_prods leftno context arity =
+ match leftno, CicReduction.whd context arity with
+ 0, Cic.Sort _ -> 0
+ | 0, Cic.Prod (name,so,ty) ->
+ 1 + count_prods 0 (Some (name, Cic.Decl so)::context) ty
+ | _, Cic.Prod (name,so,ty) ->
+ count_prods (leftno - 1) (Some (name, Cic.Decl so)::context) ty
+ | _,_ -> assert false
+ in
+(*prerr_endline (UriManager.string_of_uri curi);
+prerr_endline ("LEFTNO: " ^ string_of_int leftno ^ " " ^ CicPp.ppterm arity);*)
+ leftno, count_prods leftno [] arity
+ | _ -> assert false in
+ let ens,args =
+ let tty,_= CicTypeChecker.type_of_aux' [] context t CicUniv.oblivion_ugraph in
+ match CicReduction.whd context tty with
+ Cic.MutInd (_,_,ens) -> ens,[]
+ | Cic.Appl (Cic.MutInd (_,_,ens)::args) ->
+ ens,fst (HExtlib.split_nth leftno args)
+ | _ -> assert false
+ in
+ let rec aux n irl context outsort =
+ match n, CicReduction.whd context outsort with
+ 0, Cic.Prod _ -> raise Nothing_to_do
+ | 0, _ ->
+ let irl = List.rev irl in
+ let ty = CicSubstitution.lift rightno (Cic.MutInd (curi,tyno,ens)) in
+ let ty =
+ if args = [] && irl = [] then ty
+ else
+ Cic.Appl (ty::(List.map (CicSubstitution.lift rightno) args)@irl) in
+ let he = CicSubstitution.lift (rightno + 1) outty in
+ let t =
+ if irl = [] then he
+ else Cic.Appl (he::List.map (CicSubstitution.lift 1) irl)
+ in
+ Cic.Lambda (Cic.Anonymous, ty, t)
+ | n, Cic.Prod (name,so,ty) ->
+ let ty' =
+ aux (n - 1) (Cic.Rel n::irl) (Some (name, Cic.Decl so)::context) ty
+ in
+ Cic.Lambda (name,so,ty')
+ | _,_ -> assert false
+ in
+(*prerr_endline ("RIGHTNO = " ^ string_of_int rightno ^ " OUTTY = " ^ CicPp.ppterm outty);*)
+ let outsort =
+ fst (CicTypeChecker.type_of_aux' [] context outty CicUniv.oblivion_ugraph)
+ in
+ try aux rightno [] context outsort
+ with Nothing_to_do -> outty
+(*prerr_endline (CicPp.ppterm outty ^ " <==> " ^ CicPp.ppterm outty');*)
+;;
+
+let fix_outtype t =
+ let module C = Cic in
+ let rec aux context =
+ function
+ C.Rel _ as t -> t
+ | C.Var (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function i,t -> i, (aux context t)) exp_named_subst in
+ C.Var (uri,exp_named_subst')
+ | C.Implicit _
+ | C.Meta _ -> assert false
+ | C.Sort _ as t -> t
+ | C.Cast (v,t) -> C.Cast (aux context v, aux context t)
+ | C.Prod (n,s,t) ->
+ C.Prod (n, aux context s, aux ((Some (n, C.Decl s))::context) t)
+ | C.Lambda (n,s,t) ->
+ C.Lambda (n, aux context s, aux ((Some (n, C.Decl s))::context) t)
+ | C.LetIn (n,s,ty,t) ->
+ C.LetIn
+ (n, aux context s, aux context ty,
+ aux ((Some (n, C.Def(s,ty)))::context) t)
+ | C.Appl l -> C.Appl (List.map (aux context) l)
+ | C.Const (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function i,t -> i, (aux 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, (aux 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, (aux context t)) exp_named_subst
+ in
+ C.MutConstruct (uri, tyno, consno, exp_named_subst')
+ | C.MutCase (uri, tyno, outty, term, patterns) ->
+ let outty = fix_outty uri tyno term context outty in
+ C.MutCase (uri, tyno, aux context outty,
+ aux context term, List.map (aux context) patterns)
+ | C.Fix (funno, funs) ->
+ let tys,_ =
+ List.fold_left
+ (fun (types,len) (n,_,ty,_) ->
+ ((Some (C.Name n,(C.Decl (CicSubstitution.lift len ty)))))::types,
+ len+1
+ ) ([],0) funs
+ in
+ C.Fix (funno,
+ List.map
+ (fun (name, indidx, ty, bo) ->
+ (name, indidx, aux context ty, aux (tys@context) bo)
+ ) funs
+ )
+ | C.CoFix (funno, funs) ->
+ let tys,_ =
+ List.fold_left
+ (fun (types,len) (n,ty,_) ->
+ ((Some (C.Name n,(C.Decl (CicSubstitution.lift len ty)))))::types,
+ len+1
+ ) ([],0) funs
+ in
+ C.CoFix (funno,
+ List.map
+ (fun (name, ty, bo) ->
+ (name, aux context ty, aux (tys@context) bo)
+ ) funs
+ )
+ in
+ aux [] t
+;;
+
+let get_fresh,reset_seed =
+ let seed = ref 0 in
+ (function () ->
+ incr seed;
+ string_of_int !seed),
+ (function () -> seed := 0)
+;;
+
+exception NotSimilar
+let alpha t1 t2 ref ref' =
+ let rec aux t1 t2 = match t1,t2 with
+ | NCic.Rel n, NCic.Rel m when n=m -> ()
+ | NCic.Appl l1, NCic.Appl l2 -> List.iter2 aux l1 l2
+ | NCic.Lambda (_,s1,t1), NCic.Lambda (_,s2,t2)
+ | NCic.Prod (_,s1,t1), NCic.Prod (_,s2,t2) -> aux s1 s2; aux t1 t2
+ | NCic.LetIn (_,s1,ty1,t1), NCic.LetIn (_,s2,ty2,t2) ->
+ aux s1 s2; aux ty1 ty2; aux t1 t2
+ | NCic.Const (NReference.Ref (uu1,xp1)),
+ NCic.Const (NReference.Ref (uu2,xp2)) when
+ let NReference.Ref (u1,_) = ref in
+ let NReference.Ref (u2,_) = ref' in
+ NUri.eq uu1 u1 && NUri.eq uu2 u2 && xp1 = xp2
+ -> ()
+ | NCic.Const r1, NCic.Const r2 when NReference.eq r1 r2 -> ()
+ | NCic.Meta _,NCic.Meta _ -> ()
+ | NCic.Implicit _,NCic.Implicit _ -> ()
+ | NCic.Sort x,NCic.Sort y when x=y -> ()
+ | NCic.Match (_,t1,t11,tl1), NCic.Match (_,t2,t22,tl2) ->
+ aux t1 t2;aux t11 t22;List.iter2 aux tl1 tl2
+ | _-> raise NotSimilar
+ in
+ try aux t1 t2; true with NotSimilar -> false
+;;
+
+exception Found of NReference.reference;;
+let cache = Hashtbl.create 313;;
+let same_obj ref ref' =
+ function
+ | (_,_,_,_,NCic.Fixpoint (b1,l1,_)), (_,_,_,_,NCic.Fixpoint (b2,l2,_))
+ when List.for_all2 (fun (_,_,_,ty1,bo1) (_,_,_,ty2,bo2) ->
+ alpha ty1 ty2 ref ref' && alpha bo1 bo2 ref ref') l1 l2 && b1=b2->
+ true
+ | _ -> false
+;;
+let find_in_cache name obj ref =
+ try
+ List.iter
+ (function (ref',obj') ->
+ let recno, fixno =
+ match ref with
+ NReference.Ref (_,NReference.Fix (fixno,recno,_)) -> recno,fixno
+ | NReference.Ref (_,NReference.CoFix (fixno)) -> ~-1,fixno
+ | _ -> assert false in
+ let recno',fixno' =
+ match ref' with
+ NReference.Ref (_,NReference.Fix (fixno',recno,_)) -> recno,fixno'
+ | NReference.Ref (_,NReference.CoFix (fixno')) -> ~-1,fixno'
+ | _ -> assert false in
+ if recno = recno' && fixno = fixno' && same_obj ref ref' (obj,obj') then (
+(*
+prerr_endline ("!!!!!!!!!!! CACHE HIT !!!!!!!!!!\n" ^
+NReference.string_of_reference ref ^ "\n" ^
+NReference.string_of_reference ref' ^ "\n");
+ *)
+ raise (Found ref'));
+(*
+prerr_endline ("CACHE SAME NAME: " ^ NReference.string_of_reference ref ^ " <==> " ^ NReference.string_of_reference ref');
+ *)
+ ) (Hashtbl.find_all cache name);
+(* prerr_endline "<<< CACHE MISS >>>"; *)
+ begin
+ match obj, ref with
+ | (_,_,_,_,NCic.Fixpoint (true,fl,_)) ,
+ NReference.Ref (_,NReference.Fix _) ->
+ ignore(List.fold_left (fun i (_,name,rno,_,_) ->
+ let ref = NReference.mk_fix i rno ref in
+ Hashtbl.add cache name (ref,obj);
+ i+1
+ ) 0 fl)
+ | (_,_,_,_,NCic.Fixpoint (false,fl,_)) ,
+ NReference.Ref (_,NReference.CoFix _) ->
+ ignore(List.fold_left (fun i (_,name,_,_,_) ->
+ let ref = NReference.mk_cofix i ref in
+ Hashtbl.add cache name (ref,obj);
+ i+1
+ ) 0 fl)
+ | _ -> assert false
+ end;
+ None
+ with Found ref -> Some ref
+;;
+
+let cache1 = UriManager.UriHashtbl.create 313;;
+let rec get_height =
+ function u ->
+ try
+ UriManager.UriHashtbl.find cache1 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 cache1 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 (_,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; incr h
+ | Cic.CoFix (_, fl) -> List.iter (fun (_, ty, bo) -> aux ty; aux bo) fl; incr h
+ in
+ aux t;
+ 1 + !h
+;;
+
+ (* k=true if we are converting a term to be pushed in a ctx or if we are
+ converting the type of a fix;
+ k=false if we are converting a term to be put in the body of a fix;
+ in the latter case, we must permute Rels since the Fix abstraction will
+ preceed its lefts parameters; in the former case, there is nothing to
+ permute *)
+ let rec aux k octx (ctx : ctx list) n_fix uri = function
+ | Cic.CoFix _ as cofix ->
+ let octx,ctx,fix,rels = restrict octx ctx cofix in
+ let cofixno,fl =
+ match fix with Cic.CoFix (cofixno,fl)->cofixno,fl | _-> assert false in