type binder_type = Declaration of Cic.name * Cic.term | Definition of Cic.name * Cic.term ;; type metasenv = (int * Cic.term) list;; type named_context = binder_type list;; type sequent = named_context * Cic.term;; let proof = ref (None : (UriManager.uri * metasenv * Cic.term * Cic.term) option) ;; (*CSC: Quando facciamo Clear di una ipotesi, cosa succede? *) (* Note: the sequent is redundant: it can be computed from the type of the *) (* metavariable and its context in the proof. We keep it just for efficiency *) (* because computing the context of a term may be quite expensive. *) let goal = ref (None : (int * sequent) option);; exception NotImplemented let cic_context_of_named_context = List.map (function Declaration (_,t) -> Cic.Decl t | Definition (_,t) -> Cic.Def t ) ;; let refine_meta meta term newmetasenv = let (uri,metasenv,bo,ty) = match !proof with None -> assert false | Some (uri,metasenv,bo,ty) -> uri,metasenv,bo,ty in let metasenv' = newmetasenv @ (List.remove_assoc meta metasenv) in let rec aux = let module C = Cic in function C.Rel _ as t -> t | C.Var _ as t -> t | C.Meta meta' when meta=meta' -> term | C.Meta _ as t -> t | C.Sort _ as t -> t | C.Implicit as t -> t | C.Cast (te,ty) -> C.Cast (aux te, aux ty) | C.Prod (n,s,t) -> C.Prod (n, aux s, aux t) | C.Lambda (n,s,t) -> C.Lambda (n, aux s, aux t) | C.LetIn (n,s,t) -> C.LetIn (n, aux s, aux t) | C.Appl l -> C.Appl (List.map aux l) | C.Const _ as t -> t | C.Abst _ as t -> t | C.MutInd _ as t -> t | C.MutConstruct _ as t -> t | C.MutCase (sp,cookingsno,i,outt,t,pl) -> C.MutCase (sp,cookingsno,i,aux outt, aux t, List.map aux pl) | C.Fix (i,fl) -> let substitutedfl = List.map (fun (name,i,ty,bo) -> (name, i, aux ty, aux bo)) fl in C.Fix (i, substitutedfl) | C.CoFix (i,fl) -> let substitutedfl = List.map (fun (name,ty,bo) -> (name, aux ty, aux bo)) fl in C.CoFix (i, substitutedfl) in let metasenv'' = List.map (function i,ty -> i,(aux ty)) metasenv' in let bo' = aux bo in proof := Some (uri,metasenv'',bo',ty) ;; (* Returns the first meta whose number is above the number of the higher meta. *) let new_meta () = let metasenv = match !proof with None -> assert false | Some (_,metasenv,_,_) -> metasenv in let rec aux = function None,[] -> 1 | Some n,[] -> n | None,(n,_)::tl -> aux (Some n,tl) | Some m,(n,_)::tl -> if n > m then aux (Some n,tl) else aux (Some m,tl) in 1 + aux (None,metasenv) ;; (* metas_in_term term *) (* Returns the ordered list of the metas that occur in [term]. *) (* Duplicates are removed. The implementation is not very efficient. *) let metas_in_term term = let module C = Cic in let rec aux = function C.Rel _ | C.Var _ -> [] | C.Meta n -> [n] | C.Sort _ | C.Implicit -> [] | C.Cast (te,ty) -> (aux te) @ (aux ty) | C.Prod (_,s,t) -> (aux s) @ (aux t) | C.Lambda (_,s,t) -> (aux s) @ (aux t) | C.LetIn (_,s,t) -> (aux s) @ (aux t) | C.Appl l -> List.fold_left (fun i t -> i @ (aux t)) [] l | C.Const _ | C.Abst _ | C.MutInd _ | C.MutConstruct _ -> [] | C.MutCase (sp,cookingsno,i,outt,t,pl) -> (aux outt) @ (aux t) @ (List.fold_left (fun i t -> i @ (aux t)) [] pl) | C.Fix (i,fl) -> List.fold_left (fun i (_,_,ty,bo) -> i @ (aux bo) @ (aux ty)) [] fl | C.CoFix (i,fl) -> List.fold_left (fun i (_,ty,bo) -> i @ (aux bo) @ (aux ty)) [] fl in let metas = aux term in let rec elim_duplicates = function [] -> [] | he::tl -> he::(elim_duplicates (List.filter (function el -> he <> el) tl)) in elim_duplicates metas ;; (* perforate context term ty *) (* replaces the term [term] in the proof with a new metavariable whose type *) (* is [ty]. [context] must be the context of [term] in the whole proof. This *) (* could be easily computed; so the only reasons to have it as an argument *) (* are efficiency reasons. *) let perforate context term ty = let module C = Cic in let newmeta = new_meta () in match !proof with None -> assert false | Some (uri,metasenv,bo,gty) -> (* We push the new meta at the end of the list for pretty-printing *) (* purposes: in this way metas are ordered. *) let metasenv' = metasenv@[newmeta,ty] in let bo' = ProofEngineReduction.replace term (C.Meta newmeta) bo in (* It may be possible that some metavariables occurred only in *) (* the term we are perforating and they now occurs no more. We *) (* get rid of them, collecting the really useful metavariables *) (* in metasenv''. *) let newmetas = metas_in_term bo' in let metasenv'' = List.filter (function (n,_) -> List.mem n newmetas) metasenv' in proof := Some (uri,metasenv'',bo',gty) ; goal := Some (newmeta,(context,ty)) ; newmeta ;; (************************************************************) (* Some easy tactics. *) (************************************************************) exception Fail of string;; let intros () = let module C = Cic in let module R = CicReduction in let metasenv = match !proof with None -> assert false | Some (_,metasenv,_,_) -> metasenv in let (metano,context,ty) = match !goal with None -> assert false | Some (metano,(context,ty)) -> metano,context,ty in let newmeta = new_meta () in let rec collect_context = function C.Cast (te,_) -> collect_context te | C.Prod (n,s,t) -> let (ctx,ty,bo) = collect_context t in let n' = match n with C.Name _ -> n (*CSC: generatore di nomi? Chiedere il nome? *) | C.Anonimous -> C.Name "fresh_name" in ((Declaration (n',s))::ctx,ty,C.Lambda(n',s,bo)) | C.LetIn (n,s,t) -> let (ctx,ty,bo) = collect_context t in ((Definition (n,s))::ctx,ty,C.LetIn(n,s,bo)) | _ as t -> [], t, (C.Meta newmeta) in let revcontext',ty',bo' = collect_context ty in let context'' = (List.rev revcontext') @ context in refine_meta metano bo' [newmeta,ty'] ; goal := Some (newmeta,(context'',ty')) ;; (* The term bo must be closed in the current context *) let exact bo = let module T = CicTypeChecker in let module R = CicReduction in let metasenv = match !proof with None -> assert false | Some (_,metasenv,_,_) -> metasenv in let (metano,context,ty) = match !goal with None -> assert false | Some (metano,(context,ty)) -> assert (ty = List.assoc metano metasenv) ; (* Invariant: context is the actual context of the meta in the proof *) metano,context,ty in let context = cic_context_of_named_context context in if R.are_convertible (T.type_of_aux' metasenv context bo) ty then begin refine_meta metano bo [] ; goal := None end else raise (Fail "The type of the provided term is not the one expected.") ;; let fix_andreas_meta mgu mgut = let mgul = Array.to_list mgu in let mgutl = Array.to_list mgut in let applymetas_to_metas = let newmeta = new_meta () in (* WARNING: here we are using the invariant that above the most *) (* recente new_meta() there are no used metas. *) Array.init (List.length mgul) (function i -> newmeta + i) in (* WARNING!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *) (* Here we assume that either a META has been instantiated with *) (* a close term or with itself. *) let uninstantiatedmetas = List.fold_right2 (fun bo ty newmetas -> let module C = Cic in match bo with Cic.Meta i -> let newmeta = applymetas_to_metas.(i) in (*CSC: se ty contiene metas, queste hanno il numero errato!!! *) let ty_with_newmetas = (* Substitues (META n) with (META (applymetas_to_metas.(n))) *) let rec aux = function C.Rel _ | C.Var _ as t -> t | C.Meta n -> C.Meta (applymetas_to_metas.(n)) | C.Sort _ | C.Implicit as t -> t | C.Cast (te,ty) -> C.Cast (aux te, aux ty) | C.Prod (n,s,t) -> C.Prod (n, aux s, aux t) | C.Lambda (n,s,t) -> C.Lambda (n, aux s, aux t) | C.LetIn (n,s,t) -> C.LetIn (n, aux s, aux t) | C.Appl l -> C.Appl (List.map aux l) | C.Const _ as t -> t | C.Abst _ -> assert false | C.MutInd _ | C.MutConstruct _ as t -> t | C.MutCase (sp,cookingsno,i,outt,t,pl) -> C.MutCase (sp,cookingsno,i,aux outt, aux t, List.map aux pl) | C.Fix (i,fl) -> let substitutedfl = List.map (fun (name,i,ty,bo) -> (name, i, aux ty, aux bo)) fl in C.Fix (i, substitutedfl) | C.CoFix (i,fl) -> let substitutedfl = List.map (fun (name,ty,bo) -> (name, aux ty, aux bo)) fl in C.CoFix (i, substitutedfl) in aux ty in (newmeta,ty_with_newmetas)::newmetas | _ -> newmetas ) mgul mgutl [] in let mgul' = List.map (function Cic.Meta i -> Cic.Meta (applymetas_to_metas.(i)) | _ as t -> t ) mgul in mgul',uninstantiatedmetas ;; (* The term bo must be closed in the current context *) let apply term = let module T = CicTypeChecker in let module R = CicReduction in let module C = Cic in let metasenv = match !proof with None -> assert false | Some (_,metasenv,_,_) -> metasenv in let (metano,context,ty) = match !goal with None -> assert false | Some (metano,(context,ty)) -> assert (ty = List.assoc metano metasenv) ; (* Invariant: context is the actual context of the meta in the proof *) metano,context,ty in let ciccontext = cic_context_of_named_context context in let mgu,mgut = CicUnification.apply metasenv ciccontext term ty in let mgul',uninstantiatedmetas = fix_andreas_meta mgu mgut in let bo' = if List.length mgul' = 0 then term else Cic.Appl (term::mgul') in refine_meta metano bo' uninstantiatedmetas ; match uninstantiatedmetas with (n,ty)::tl -> goal := Some (n,(context,ty)) | [] -> goal := None ;; let eta_expand metasenv ciccontext t arg = let module T = CicTypeChecker in let module S = CicSubstitution in let module C = Cic in let rec aux n = function t' when t' = S.lift n arg -> C.Rel (1 + n) | C.Rel m -> if m <= n then C.Rel m else C.Rel (m+1) | C.Var _ | C.Meta _ | C.Sort _ | C.Implicit as t -> t | C.Cast (te,ty) -> C.Cast (aux n te, aux n ty) | C.Prod (nn,s,t) -> C.Prod (nn, aux n s, aux (n+1) t) | C.Lambda (nn,s,t) -> C.Lambda (nn, aux n s, aux (n+1) t) | C.LetIn (nn,s,t) -> C.LetIn (nn, aux n s, aux (n+1) t) | C.Appl l -> C.Appl (List.map (aux n) l) | C.Const _ as t -> t | C.Abst _ -> assert false | C.MutInd _ | C.MutConstruct _ as t -> t | C.MutCase (sp,cookingsno,i,outt,t,pl) -> C.MutCase (sp,cookingsno,i,aux n outt, aux n t, List.map (aux n) pl) | C.Fix (i,fl) -> let tylen = List.length fl in let substitutedfl = List.map (fun (name,i,ty,bo) -> (name, i, aux n ty, aux (n+tylen) bo)) fl in C.Fix (i, substitutedfl) | C.CoFix (i,fl) -> let tylen = List.length fl in let substitutedfl = List.map (fun (name,ty,bo) -> (name, aux n ty, aux (n+tylen) bo)) fl in C.CoFix (i, substitutedfl) in let argty = T.type_of_aux' metasenv ciccontext arg in (C.Appl [C.Lambda ((C.Name "dummy"),argty,aux 0 t) ; arg]) ;; exception NotAnInductiveTypeToEliminate;; exception NotTheRightEliminatorShape;; exception NoHypothesesFound;; let elim term = let module T = CicTypeChecker in let module U = UriManager in let module R = CicReduction in let module C = Cic in let curi,metasenv = match !proof with None -> assert false | Some (curi,metasenv,_,_) -> curi,metasenv in let (metano,context,ty) = match !goal with None -> assert false | Some (metano,(context,ty)) -> assert (ty = List.assoc metano metasenv) ; (* Invariant: context is the actual context of the meta in the proof *) metano,context,ty in let ciccontext = cic_context_of_named_context context in let termty = T.type_of_aux' metasenv ciccontext term in let uri,cookingno,typeno,args = match termty with C.MutInd (uri,cookingno,typeno) -> (uri,cookingno,typeno,[]) | C.Appl ((C.MutInd (uri,cookingno,typeno))::args) -> (uri,cookingno,typeno,args) | _ -> raise NotAnInductiveTypeToEliminate in let eliminator_uri = let buri = U.buri_of_uri uri in let name = match CicEnvironment.get_cooked_obj uri cookingno with C.InductiveDefinition (tys,_,_) -> let (name,_,_,_) = List.nth tys typeno in name | _ -> assert false in let ext = match T.type_of_aux' metasenv ciccontext ty with C.Sort C.Prop -> "_ind" | C.Sort C.Set -> "_rec" | C.Sort C.Type -> "_rect" | _ -> assert false in U.uri_of_string (buri ^ "/" ^ name ^ ext ^ ".con") in let eliminator_cookingno = UriManager.relative_depth curi eliminator_uri 0 in let eliminator_ref = C.Const (eliminator_uri,eliminator_cookingno) in let ety = T.type_of_aux' [] [] eliminator_ref in let earity = CicUnification.get_arity ety in let mgu = Array.init earity (fun i -> (C.Meta i)) in let mgut = Array.make earity C.Implicit in (* Here we assume that we have only one inductive hypothesis to *) (* eliminate and that it is the last hypothesis of the theorem. *) (* A better approach would be fingering the hypotheses in some *) (* way. *) let hypothesis_to_eliminate,econclusion = (* aux n h t *) (* traverses the backbone [t] looking for the last hypothesis *) (* and substituting Pi-abstractions with META declarations. *) (* [h] is the last hypothesis met up to now. [n] is the next *) (* unused META. *) let rec aux n h = function C.Prod (_,s,t) -> mgut.(n) <- s ; aux (n+1) (Some s) (CicSubstitution.subst (C.Meta n) t) | C.Cast (te,_) -> aux n h te | t -> match h with None -> raise NoHypothesesFound | Some h' -> h',t in aux 0 None ety in prerr_endline ("HTOELIM: " ^ CicPp.ppterm hypothesis_to_eliminate) ; prerr_endline ("ECONCLUSION: " ^ CicPp.ppterm econclusion) ; flush stderr ; ignore (CicUnification.fo_unif_mgu 0 hypothesis_to_eliminate termty mgu) ; ignore (CicUnification.fo_unif_mgu 0 term (C.Meta (earity - 1)) mgu) ; let mgu = CicUnification.unwind mgu in prerr_endline "Dopo l'unwind dell'mgu"; flush stderr ; let mark = Array.make earity 1 in let ueconclusion = CicUnification.unwind_meta mgu mark econclusion in prerr_endline ("ECONCLUSION DOPO UNWIND: " ^ CicPp.ppterm ueconclusion) ; flush stderr ; (* The conclusion of our elimination principle is *) (* (?i farg1 ... fargn) *) (* The conclusion of our goal is ty. So, we can *) (* eta-expand ty w.r.t. farg1 .... fargn to get *) (* a new ty equal to (P farg1 ... fargn). Now *) (* ?i can be instantiated with P and we are ready *) (* to refine the term. *) let emeta, fargs = match ueconclusion with C.Appl ((C.Meta emeta)::fargs) -> emeta,fargs | _ -> raise NotTheRightEliminatorShape in let eta_expanded_ty = (*CSC: metasenv e ?????????????*) List.fold_left (eta_expand metasenv ciccontext) ty fargs in (*CSC: 0????????*) prerr_endline ("ETAEXPANDEDTY:" ^ CicPp.ppterm eta_expanded_ty) ; flush stdout ; ignore (CicUnification.fo_unif_mgu 0 ueconclusion eta_expanded_ty mgu) ; prerr_endline "Dopo la seconda unificazione" ; flush stdout ; let mgu = CicUnification.unwind mgu in print_endline "unwind"; flush stdout; (* When unwinding the META that corresponds to the elimination *) (* predicate (which is emeta), we must also perform one-step *) (* beta-reduction. *) let mgut = let mark = Array.make (Array.length mgu) 1 in Array.map (CicUnification.unwind_meta_reducing mgu mark (Some emeta)) mgut ; in print_endline "unwind_array"; flush stdout; let mgu' = Array.copy mgu in let mgut' = CicUnification.list_of_array mgut in print_endline "list"; flush stdout; Array.iteri (fun i ty -> prerr_endline ("META " ^ string_of_int i ^ ": " ^ CicPp.ppterm mgu'.(i) ^ " == " ^ CicPp.ppterm ty) ; flush stderr ; let ty' = CicTypeChecker.type_of_aux' mgut' ciccontext mgu'.(i) in ignore (CicUnification.fo_unif_mgu 0 ty ty' mgu) ) mgut ; let mgu = CicUnification.unwind mgu in let mgut = CicUnification.unwind_array mgu mgut in prerr_endline "Dopo le unwind dell'mgut" ; flush stdout ; let mgul',uninstantiatedmetas = fix_andreas_meta mgu mgut in prerr_endline "Dopo il fissaggio" ; flush stdout ; let bo' = Cic.Appl (eliminator_ref::mgul') in prerr_endline ("BODY': " ^ CicPp.ppterm bo') ; flush stdout ; refine_meta metano bo' uninstantiatedmetas ; prerr_endline "dopo refine meta" ; flush stdout ; match uninstantiatedmetas with (n,ty)::tl -> goal := Some (n,(context,ty)) | [] -> goal := None ;; let elim_intros term = elim term ; intros () ;; let reduction_tactic reduction_function term = let curi,metasenv,pbo,pty = match !proof with None -> assert false | Some (curi,metasenv,bo,ty) -> curi,metasenv,bo,ty in let (metano,context,ty) = match !goal with None -> assert false | Some (metano,(context,ty)) -> metano,context,ty in let term' = reduction_function term in (* We don't know if [term] is a subterm of [ty] or a subterm of *) (* the type of one metavariable. So we replace it everywhere. *) (*CSC: ma si potrebbe ovviare al problema. Ma non credo *) (*CSC: che si guadagni nulla in fatto di efficienza. *) let replace = ProofEngineReduction.replace ~what:term ~with_what:term' in let ty' = replace ty in let context' = List.map (function Definition (n,t) -> Definition (n,replace t) | Declaration (n,t) -> Declaration (n,replace t) ) context in let metasenv' = List.map (function (n,_) when n = metano -> (metano,ty') | _ as t -> t ) metasenv in proof := Some (curi,metasenv',pbo,pty) ; goal := Some (metano,(context',ty')) ;; let reduction_tactic_in_scratch reduction_function ty term = let metasenv = match !proof with None -> [] | Some (_,metasenv,_,_) -> metasenv in let context = match !goal with None -> [] | Some (_,(context,_)) -> context in let term' = reduction_function term in ProofEngineReduction.replace ~what:term ~with_what:term' ~where:ty ;; let whd = reduction_tactic CicReduction.whd;; let reduce = reduction_tactic ProofEngineReduction.reduce;; let simpl = reduction_tactic ProofEngineReduction.simpl;; let whd_in_scratch = reduction_tactic_in_scratch CicReduction.whd;; let reduce_in_scratch = reduction_tactic_in_scratch ProofEngineReduction.reduce;; let simpl_in_scratch = reduction_tactic_in_scratch ProofEngineReduction.simpl;; (* It is just the opposite of whd. The code should probably be merged. *) let fold term = let curi,metasenv,pbo,pty = match !proof with None -> assert false | Some (curi,metasenv,bo,ty) -> curi,metasenv,bo,ty in let (metano,context,ty) = match !goal with None -> assert false | Some (metano,(context,ty)) -> metano,context,ty in let term' = CicReduction.whd term in (* We don't know if [term] is a subterm of [ty] or a subterm of *) (* the type of one metavariable. So we replace it everywhere. *) (*CSC: ma si potrebbe ovviare al problema. Ma non credo *) (*CSC: che si guadagni nulla in fatto di efficienza. *) let replace = ProofEngineReduction.replace ~what:term' ~with_what:term in let ty' = replace ty in let context' = List.map (function Declaration (n,t) -> Declaration (n,replace t) | Definition (n,t) -> Definition (n,replace t) ) context in let metasenv' = List.map (function (n,_) when n = metano -> (metano,ty') | _ as t -> t ) metasenv in proof := Some (curi,metasenv',pbo,pty) ; goal := Some (metano,(context',ty')) ;; let cut term = let module C = Cic in let curi,metasenv,pbo,pty = match !proof with None -> assert false | Some (curi,metasenv,bo,ty) -> curi,metasenv,bo,ty in let (metano,context,ty) = match !goal with None -> assert false | Some (metano,(context,ty)) -> metano,context,ty in let newmeta1 = new_meta () in let newmeta2 = newmeta1 + 1 in let newmeta1ty = CicSubstitution.lift 1 ty in let bo' = C.Appl [C.Lambda (C.Name "dummy_for_cut",term,C.Meta newmeta1) ; C.Meta newmeta2] in prerr_endline ("BO': " ^ CicPp.ppterm bo') ; flush stderr ; refine_meta metano bo' [newmeta2,term; newmeta1,newmeta1ty]; goal := Some (newmeta1,((Declaration (C.Name "dummy_for_cut", term))::context, newmeta1ty)) ;; let letin term = let module C = Cic in let curi,metasenv,pbo,pty = match !proof with None -> assert false | Some (curi,metasenv,bo,ty) -> curi,metasenv,bo,ty in let (metano,context,ty) = match !goal with None -> assert false | Some (metano,(context,ty)) -> metano,context,ty in let ciccontext = cic_context_of_named_context context in let _ = CicTypeChecker.type_of_aux' metasenv ciccontext term in let newmeta = new_meta () in let newmetaty = CicSubstitution.lift 1 ty in let bo' = C.LetIn (C.Name "dummy_for_letin",term,C.Meta newmeta) in refine_meta metano bo' [newmeta,newmetaty]; goal := Some (newmeta, ((Definition (C.Name "dummy_for_letin", term))::context, newmetaty)) ;; exception NotConvertible;; (*CSC: Bug (or feature?). [input] is parsed in the context of the goal, *) (*CSC: while [goal_input] can have a richer context (because of binders) *) (*CSC: So it is _NOT_ possible to use those binders in the [input] term. *) (*CSC: Is that evident? Is that right? Or should it be changed? *) let change ~goal_input ~input = let curi,metasenv,pbo,pty = match !proof with None -> assert false | Some (curi,metasenv,bo,ty) -> curi,metasenv,bo,ty in let (metano,context,ty) = match !goal with None -> assert false | Some (metano,(context,ty)) -> metano,context,ty in let ciccontext = cic_context_of_named_context context in (* are_convertible works only on well-typed terms *) ignore (CicTypeChecker.type_of_aux' metasenv ciccontext input) ; if CicReduction.are_convertible goal_input input then begin let ty' = ProofEngineReduction.replace goal_input input ty in let metasenv' = List.map (function (n,_) when n = metano -> (metano,ty') | _ as t -> t ) metasenv in proof := Some (curi,metasenv',pbo,pty) ; goal := Some (metano,(context,ty')) end else raise NotConvertible ;;