let fire_beta, upto =
match l with C.Meta _ :: _ -> true, List.length l - 1 | _ -> false, 0
in
- let a,l1 =
- (* sharing fold? *)
- List.fold_right
- (fun t (a,l) -> let a,t = f k a t in a, t :: l)
- l (a,[])
- in
+ let a,l1 = HExtlib.sharing_map_acc (f k) a l in
a, if l1 == l then orig else
let t =
match l1 with
a, if ty1 == ty && t1 == t && b1 == b then orig else C.LetIn (n,ty1,t1,b1)
| C.Match (r,oty,t,pl) as orig ->
let a,oty1 = f k a oty in let a,t1 = f k a t in
- let a,pl1 =
- (* sharing fold? *)
- List.fold_right (fun t (a,l) -> let a,t = f k a t in a,t::l) pl (a,[])
- in
+ let a,pl1 = HExtlib.sharing_map_acc (f k) a pl in
a, if oty1 == oty && t1 == t && pl1 == pl then orig
else C.Match(r,oty1,t1,pl1)
;;
aux (List.map fst ctx) t
;;
-let apply_subst subst context t =
+let rec fire_projection_redex on_args = function
+ | C.Meta _ as t -> t
+ | C.Appl(C.Const(Ref.Ref(_,Ref.Fix(fno,rno,_)) as r)::args as ol)as ot->
+ let l= if on_args then List.map (fire_projection_redex true) ol else ol in
+ let t = if l == ol then ot else C.Appl l in
+ let ifl,(_,_,pragma),_ = NCicEnvironment.get_checked_fixes_or_cofixes r in
+ let conclude () =
+ if on_args then
+ let l' = HExtlib.sharing_map (fire_projection_redex true) l in
+ if l == l' then t else C.Appl l'
+ else
+ t (* ot is the same *)
+ in
+ if pragma <> `Projection || List.length args <= rno then conclude ()
+ else
+ (match List.nth l (rno+1) with
+ | C.Appl (C.Const(Ref.Ref(_,Ref.Con _))::_) ->
+ let _, _, _, _, fbody = List.nth ifl fno in (* fbody is closed! *)
+ let t = C.Appl (fbody::List.tl l) in
+ (match NCicReduction.head_beta_reduce ~delta:max_int t with
+ | C.Match (_,_, C.Appl(C.Const(Ref.Ref(_,Ref.Con (_,_,leftno)))
+ ::kargs),[pat])->
+ let _,kargs = HExtlib.split_nth leftno kargs in
+ fire_projection_redex false
+ (NCicReduction.head_beta_reduce
+ ~delta:max_int (C.Appl (pat :: kargs)))
+ | C.Appl(C.Match(_,_,C.Appl(C.Const(Ref.Ref(_,Ref.Con (_,_,leftno)))
+ ::kargs),[pat]) :: args) ->
+ let _,kargs = HExtlib.split_nth leftno kargs in
+ fire_projection_redex false
+ (NCicReduction.head_beta_reduce
+ ~delta:max_int (C.Appl (pat :: kargs @ args)))
+ | _ -> conclude ())
+ | _ -> conclude ())
+ | t when on_args -> NCicUtils.map (fun _ x -> x) true fire_projection_redex t
+ | t -> t
+;;
+
+let apply_subst ?(fix_projections=false) subst context t =
let rec apply_subst subst () =
function
NCic.Meta (i,lc) ->
let t = NCicSubstitution.subst_meta lc t in
apply_subst subst () t
with
- Not_found ->
+ NCicUtils.Subst_not_found j when j = i ->
match lc with
_,NCic.Irl _ -> NCic.Meta (i,lc)
| n,NCic.Ctx l ->
apply_subst subst () (NCicSubstitution.lift n t)) l))))
| t -> NCicUtils.map (fun _ () -> ()) () (apply_subst subst) t
in
- clean_or_fix_dependent_abstrations context (apply_subst subst () t)
+ (if fix_projections then fire_projection_redex true else fun x -> x)
+ (clean_or_fix_dependent_abstrations context (apply_subst subst () t))
;;
-let apply_subst_context subst context =
+let apply_subst_context ~fix_projections subst context =
+ let apply_subst = apply_subst ~fix_projections in
let rec aux c = function
| [] -> []
| (name,NCic.Decl t as e) :: tl ->
| [] -> []
| (i,_) :: _ when List.mem_assoc i subst -> assert false
| (i,(name,ctx,ty)) :: tl ->
- (i,(name,apply_subst_context subst ctx,apply_subst subst ctx ty)) ::
+ (i,(name,apply_subst_context ~fix_projections:true subst ctx,
+ apply_subst ~fix_projections:true subst ctx ty)) ::
apply_subst_metasenv subst tl
;;
-let height_of_term tl =
- let h = ref 0 in
- let get_height (NReference.Ref (uri,_)) =
- let _,height,_,_,_ = NCicEnvironment.get_checked_obj uri in
- height in
- let rec aux =
- function
- NCic.Meta (_,(_,NCic.Ctx l)) -> List.iter aux l
- | NCic.Meta _ -> ()
- | NCic.Rel _
- | NCic.Sort _ -> ()
- | NCic.Implicit _ -> assert false
- | NCic.Const nref -> h := max !h (get_height nref)
- | NCic.Prod (_,t1,t2)
- | NCic.Lambda (_,t1,t2) -> aux t1; aux t2
- | NCic.LetIn (_,s,ty,t) -> aux s; aux ty; aux t
- | NCic.Appl l -> List.iter aux l
- | NCic.Match (_,outty,t,pl) -> aux outty; aux t; List.iter aux pl
- in
- List.iter aux tl;
- 1 + !h
+(* hide optional arg *)
+let apply_subst s c t = apply_subst s c t;;
+
+
+type meta_kind = [ `IsSort | `IsType | `IsTerm ]
+
+let is_kind x = x = `IsSort || x = `IsType || x = `IsTerm ;;
+
+let kind_of_meta l =
+ try
+ (match List.find is_kind l with
+ | `IsSort | `IsType | `IsTerm as x -> x
+ | _ -> assert false)
+ with
+ Not_found -> assert false
;;
-let height_of_obj_kind uri =
- function
- NCic.Inductive _
- | NCic.Constant (_,_,None,_,_)
- | NCic.Fixpoint (false,_,_) -> 0
- | NCic.Fixpoint (true,ifl,_) ->
- let iflno = List.length ifl in
- height_of_term
- (List.fold_left
- (fun l (_,_,_,ty,bo) ->
- let bo = NCicTypeChecker.debruijn uri iflno [] bo in
- ty::bo::l
- ) [] ifl)
- | NCic.Constant (_,_,Some bo,ty,_) -> height_of_term [bo;ty]
+let rec replace_in_metasenv i f = function
+ | [] -> assert false
+ | (j,e)::tl when j=i -> (i,f e) :: tl
+ | x::tl -> x :: replace_in_metasenv i f tl
+;;
+
+let rec replace_in_subst i f = function
+ | [] -> assert false
+ | (j,e)::tl when j=i -> (i,f e) :: tl
+ | x::tl -> x :: replace_in_subst i f tl
+;;
+
+let set_kind newkind attrs =
+ (newkind :> NCic.meta_attr) :: List.filter (fun x -> not (is_kind x)) attrs
+;;
+
+let max_kind k1 k2 =
+ match k1, k2 with
+ | `IsSort, _ | _, `IsSort -> `IsSort
+ | `IsType, _ | _, `IsType -> `IsType
+ | _ -> `IsTerm
+;;
+
+module OT =
+ struct
+ type t = int * NCic.conjecture
+ let compare (i,_) (j,_) = Pervasives.compare i j
+ end
+
+module MS = HTopoSort.Make(OT)
+let relations_of_menv subst m c =
+ let i, (_, ctx, ty) = c in
+ let m = List.filter (fun (j,_) -> j <> i) m in
+ let m_ty = metas_of_term subst ctx ty in
+ let m_ctx =
+ snd
+ (List.fold_right
+ (fun i (ctx,res) ->
+ (i::ctx),
+ (match i with
+ | _,NCic.Decl ty -> metas_of_term subst ctx ty
+ | _,NCic.Def (t,ty) ->
+ metas_of_term subst ctx ty @ metas_of_term subst ctx t) @ res)
+ ctx ([],[]))
+ in
+ let metas = HExtlib.list_uniq (List.sort compare (m_ty @ m_ctx)) in
+ List.filter (fun (i,_) -> List.exists ((=) i) metas) m
+;;
+
+let sort_metasenv subst (m : NCic.metasenv) =
+ (MS.topological_sort m (relations_of_menv subst m) : NCic.metasenv)
+;;
+
+let count_occurrences ~subst n t =
+ let occurrences = ref 0 in
+ let rec aux k _ = function
+ | C.Rel m when m = n+k -> incr occurrences
+ | C.Rel _m -> ()
+ | C.Implicit _ -> ()
+ | C.Meta (_,(_,(C.Irl 0 | C.Ctx []))) -> (* closed meta *) ()
+ | C.Meta (mno,(s,l)) ->
+ (try
+ (* possible optimization here: try does_not_occur on l and
+ perform substitution only if DoesOccur is raised *)
+ let _,_,term,_ = NCicUtils.lookup_subst mno subst in
+ aux (k-s) () (NCicSubstitution.subst_meta (0,l) term)
+ with NCicUtils.Subst_not_found _ -> () (*match l with
+ | C.Irl len -> if not (n+k >= s+len || s > nn+k) then raise DoesOccur
+ | C.Ctx lc -> List.iter (aux (k-s) ()) lc*))
+ | t -> NCicUtils.fold (fun _ k -> k + 1) k aux () t
+ in
+ aux 0 () t;
+ !occurrences
+;;
+
+exception Found_variable
+
+let looks_closed t =
+ let rec aux k _ = function
+ | C.Rel m when k < m -> raise Found_variable
+ | C.Rel _m -> ()
+ | C.Implicit _ -> ()
+ | C.Meta (_,(_,(C.Irl 0 | C.Ctx []))) -> (* closed meta *) ()
+ | C.Meta _ -> raise Found_variable
+ | t -> NCicUtils.fold (fun _ k -> k + 1) k aux () t
+ in
+ try aux 0 () t; true with Found_variable -> false
;;
projects / helm.git / blobdiff