diff --git a/src/HOL/Library/old_recdef.ML b/src/HOL/Library/old_recdef.ML --- a/src/HOL/Library/old_recdef.ML +++ b/src/HOL/Library/old_recdef.ML @@ -1,2891 +1,2891 @@ (* Title: HOL/Library/old_recdef.ML Author: Konrad Slind, Cambridge University Computer Laboratory Author: Lucas Dixon, University of Edinburgh Old TFL/recdef package. *) signature CASE_SPLIT = sig (* try to recursively split conjectured thm to given list of thms *) val splitto : Proof.context -> thm list -> thm -> thm end; signature UTILS = sig exception ERR of {module: string, func: string, mesg: string} val end_itlist: ('a -> 'a -> 'a) -> 'a list -> 'a val itlist2: ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c val pluck: ('a -> bool) -> 'a list -> 'a * 'a list val zip3: 'a list -> 'b list -> 'c list -> ('a*'b*'c) list val take: ('a -> 'b) -> int * 'a list -> 'b list end; signature USYNTAX = sig datatype lambda = VAR of {Name : string, Ty : typ} | CONST of {Name : string, Ty : typ} | COMB of {Rator: term, Rand : term} | LAMB of {Bvar : term, Body : term} val alpha : typ (* Types *) val type_vars : typ -> typ list val type_varsl : typ list -> typ list val mk_vartype : string -> typ val is_vartype : typ -> bool val strip_prod_type : typ -> typ list (* Terms *) val free_vars_lr : term -> term list val type_vars_in_term : term -> typ list val dest_term : term -> lambda (* Prelogic *) val inst : (typ*typ) list -> term -> term (* Construction routines *) val mk_abs :{Bvar : term, Body : term} -> term val mk_imp :{ant : term, conseq : term} -> term val mk_select :{Bvar : term, Body : term} -> term val mk_forall :{Bvar : term, Body : term} -> term val mk_exists :{Bvar : term, Body : term} -> term val mk_conj :{conj1 : term, conj2 : term} -> term val mk_disj :{disj1 : term, disj2 : term} -> term val mk_pabs :{varstruct : term, body : term} -> term (* Destruction routines *) val dest_const: term -> {Name : string, Ty : typ} val dest_comb : term -> {Rator : term, Rand : term} val dest_abs : string list -> term -> {Bvar : term, Body : term} * string list val dest_eq : term -> {lhs : term, rhs : term} val dest_imp : term -> {ant : term, conseq : term} val dest_forall : term -> {Bvar : term, Body : term} val dest_exists : term -> {Bvar : term, Body : term} val dest_neg : term -> term val dest_conj : term -> {conj1 : term, conj2 : term} val dest_disj : term -> {disj1 : term, disj2 : term} val dest_pair : term -> {fst : term, snd : term} val dest_pabs : string list -> term -> {varstruct : term, body : term, used : string list} val lhs : term -> term val rhs : term -> term val rand : term -> term (* Query routines *) val is_imp : term -> bool val is_forall : term -> bool val is_exists : term -> bool val is_neg : term -> bool val is_conj : term -> bool val is_disj : term -> bool val is_pair : term -> bool val is_pabs : term -> bool (* Construction of a term from a list of Preterms *) val list_mk_abs : (term list * term) -> term val list_mk_imp : (term list * term) -> term val list_mk_forall : (term list * term) -> term val list_mk_conj : term list -> term (* Destructing a term to a list of Preterms *) val strip_comb : term -> (term * term list) val strip_abs : term -> (term list * term) val strip_imp : term -> (term list * term) val strip_forall : term -> (term list * term) val strip_exists : term -> (term list * term) val strip_disj : term -> term list (* Miscellaneous *) val mk_vstruct : typ -> term list -> term val gen_all : term -> term val find_term : (term -> bool) -> term -> term option val dest_relation : term -> term * term * term val is_WFR : term -> bool val ARB : typ -> term end; signature DCTERM = sig val dest_comb: cterm -> cterm * cterm val dest_abs: string option -> cterm -> cterm * cterm val capply: cterm -> cterm -> cterm val cabs: cterm -> cterm -> cterm val mk_conj: cterm * cterm -> cterm val mk_disj: cterm * cterm -> cterm val mk_exists: cterm * cterm -> cterm val dest_conj: cterm -> cterm * cterm val dest_const: cterm -> {Name: string, Ty: typ} val dest_disj: cterm -> cterm * cterm val dest_eq: cterm -> cterm * cterm val dest_exists: cterm -> cterm * cterm val dest_forall: cterm -> cterm * cterm val dest_imp: cterm -> cterm * cterm val dest_neg: cterm -> cterm val dest_pair: cterm -> cterm * cterm val dest_var: cterm -> {Name:string, Ty:typ} val is_conj: cterm -> bool val is_disj: cterm -> bool val is_eq: cterm -> bool val is_exists: cterm -> bool val is_forall: cterm -> bool val is_imp: cterm -> bool val is_neg: cterm -> bool val is_pair: cterm -> bool val list_mk_disj: cterm list -> cterm val strip_abs: cterm -> cterm list * cterm val strip_comb: cterm -> cterm * cterm list val strip_disj: cterm -> cterm list val strip_exists: cterm -> cterm list * cterm val strip_forall: cterm -> cterm list * cterm val strip_imp: cterm -> cterm list * cterm val drop_prop: cterm -> cterm val mk_prop: cterm -> cterm end; signature RULES = sig val dest_thm: thm -> term list * term (* Inference rules *) val REFL: cterm -> thm val ASSUME: cterm -> thm val MP: thm -> thm -> thm val MATCH_MP: thm -> thm -> thm val CONJUNCT1: thm -> thm val CONJUNCT2: thm -> thm val CONJUNCTS: thm -> thm list val DISCH: cterm -> thm -> thm val UNDISCH: thm -> thm val SPEC: cterm -> thm -> thm val ISPEC: cterm -> thm -> thm val ISPECL: cterm list -> thm -> thm val GEN: Proof.context -> cterm -> thm -> thm val GENL: Proof.context -> cterm list -> thm -> thm val LIST_CONJ: thm list -> thm val SYM: thm -> thm val DISCH_ALL: thm -> thm val FILTER_DISCH_ALL: (term -> bool) -> thm -> thm val SPEC_ALL: thm -> thm val GEN_ALL: Proof.context -> thm -> thm val IMP_TRANS: thm -> thm -> thm val PROVE_HYP: thm -> thm -> thm val CHOOSE: Proof.context -> cterm * thm -> thm -> thm val EXISTS: Proof.context -> cterm * cterm -> thm -> thm val IT_EXISTS: Proof.context -> (cterm * cterm) list -> thm -> thm val EVEN_ORS: thm list -> thm list val DISJ_CASESL: thm -> thm list -> thm val list_beta_conv: cterm -> cterm list -> thm val SUBS: Proof.context -> thm list -> thm -> thm val simpl_conv: Proof.context -> thm list -> cterm -> thm val rbeta: thm -> thm val tracing: bool Unsynchronized.ref val CONTEXT_REWRITE_RULE: Proof.context -> term * term list * thm * thm list -> thm -> thm * term list val RIGHT_ASSOC: Proof.context -> thm -> thm val prove: Proof.context -> bool -> term * tactic -> thm end; signature THRY = sig val match_term: theory -> term -> term -> (term * term) list * (typ * typ) list val match_type: theory -> typ -> typ -> (typ * typ) list val typecheck: theory -> term -> cterm (*datatype facts of various flavours*) val match_info: theory -> string -> {constructors: term list, case_const: term} option val induct_info: theory -> string -> {constructors: term list, nchotomy: thm} option val extract_info: theory -> {case_congs: thm list, case_rewrites: thm list} end; signature PRIM = sig val trace: bool Unsynchronized.ref val trace_thms: Proof.context -> string -> thm list -> unit val trace_cterm: Proof.context -> string -> cterm -> unit type pattern val mk_functional: theory -> term list -> {functional: term, pats: pattern list} val wfrec_definition0: string -> term -> term -> theory -> thm * theory val post_definition: Proof.context -> thm list -> thm * pattern list -> {rules: thm, rows: int list, TCs: term list list, full_pats_TCs: (term * term list) list} val mk_induction: Proof.context -> {fconst: term, R: term, SV: term list, pat_TCs_list: (term * term list) list} -> thm val postprocess: Proof.context -> bool -> {wf_tac: tactic, terminator: tactic, simplifier: cterm -> thm} -> {rules: thm, induction: thm, TCs: term list list} -> {rules: thm, induction: thm, nested_tcs: thm list} end; signature TFL = sig val define_i: bool -> thm list -> thm list -> xstring -> term -> term list -> Proof.context -> {lhs: term, rules: (thm * int) list, induct: thm, tcs: term list} * Proof.context val define: bool -> thm list -> thm list -> xstring -> string -> string list -> Proof.context -> {lhs: term, rules: (thm * int) list, induct: thm, tcs: term list} * Proof.context end; signature OLD_RECDEF = sig val get_recdef: theory -> string -> {lhs: term, simps: thm list, rules: thm list list, induct: thm, tcs: term list} option val get_hints: Proof.context -> {simps: thm list, congs: (string * thm) list, wfs: thm list} val simp_add: attribute val simp_del: attribute val cong_add: attribute val cong_del: attribute val wf_add: attribute val wf_del: attribute val add_recdef: bool -> xstring -> string -> ((binding * string) * Token.src list) list -> Token.src option -> theory -> theory * {lhs: term, simps: thm list, rules: thm list list, induct: thm, tcs: term list} val add_recdef_i: bool -> xstring -> term -> ((binding * term) * attribute list) list -> theory -> theory * {lhs: term, simps: thm list, rules: thm list list, induct: thm, tcs: term list} end; structure Old_Recdef: OLD_RECDEF = struct (*** extra case splitting for TFL ***) structure CaseSplit: CASE_SPLIT = struct (* make a casethm from an induction thm *) fun cases_thm_of_induct_thm ctxt = Seq.hd o (ALLGOALS (fn i => REPEAT (eresolve_tac ctxt [Drule.thin_rl] i))); (* get the case_thm (my version) from a type *) fun case_thm_of_ty ctxt ty = let val thy = Proof_Context.theory_of ctxt val ty_str = case ty of Type(ty_str, _) => ty_str | TFree(s,_) => error ("Free type: " ^ s) | TVar((s,_),_) => error ("Free variable: " ^ s) val {induct, ...} = BNF_LFP_Compat.the_info thy [BNF_LFP_Compat.Keep_Nesting] ty_str in cases_thm_of_induct_thm ctxt induct end; (* for use when there are no prems to the subgoal *) (* does a case split on the given variable *) fun mk_casesplit_goal_thm ctxt (vstr,ty) gt = let val thy = Proof_Context.theory_of ctxt; val x = Free(vstr,ty); val abst = Abs(vstr, ty, Term.abstract_over (x, gt)); val case_thm = case_thm_of_ty ctxt ty; val abs_ct = Thm.cterm_of ctxt abst; val free_ct = Thm.cterm_of ctxt x; val (Pv, Dv, type_insts) = case (Thm.concl_of case_thm) of (_ $ (Pv $ (Dv as Var(_, Dty)))) => (Pv, Dv, Sign.typ_match thy (Dty, ty) Vartab.empty) | _ => error "not a valid case thm"; val type_cinsts = map (fn (ixn, (S, T)) => ((ixn, S), Thm.ctyp_of ctxt T)) (Vartab.dest type_insts); val Pv = dest_Var (Envir.subst_term_types type_insts Pv); val Dv = dest_Var (Envir.subst_term_types type_insts Dv); in Conv.fconv_rule Drule.beta_eta_conversion (case_thm |> Thm.instantiate (type_cinsts, []) |> Thm.instantiate ([], [(Pv, abs_ct), (Dv, free_ct)])) end; (* the find_XXX_split functions are simply doing a lightwieght (I think) term matching equivalent to find where to do the next split *) (* assuming two twems are identical except for a free in one at a subterm, or constant in another, ie assume that one term is a plit of another, then gives back the free variable that has been split. *) exception find_split_exp of string fun find_term_split (Free v, _ $ _) = SOME v | find_term_split (Free v, Const _) = SOME v | find_term_split (Free v, Abs _) = SOME v (* do we really want this case? *) | find_term_split (Free _, Var _) = NONE (* keep searching *) | find_term_split (a $ b, a2 $ b2) = (case find_term_split (a, a2) of NONE => find_term_split (b,b2) | vopt => vopt) | find_term_split (Abs(_,_,t1), Abs(_,_,t2)) = find_term_split (t1, t2) | find_term_split (Const (x,_), Const(x2,_)) = if x = x2 then NONE else (* keep searching *) raise find_split_exp (* stop now *) "Terms are not identical upto a free varaible! (Consts)" | find_term_split (Bound i, Bound j) = if i = j then NONE else (* keep searching *) raise find_split_exp (* stop now *) "Terms are not identical upto a free varaible! (Bound)" | find_term_split _ = raise find_split_exp (* stop now *) "Terms are not identical upto a free varaible! (Other)"; (* assume that "splitth" is a case split form of subgoal i of "genth", then look for a free variable to split, breaking the subgoal closer to splitth. *) fun find_thm_split splitth i genth = find_term_split (Logic.get_goal (Thm.prop_of genth) i, Thm.concl_of splitth) handle find_split_exp _ => NONE; (* as above but searches "splitths" for a theorem that suggest a case split *) fun find_thms_split splitths i genth = Library.get_first (fn sth => find_thm_split sth i genth) splitths; (* split the subgoal i of "genth" until we get to a member of splitths. Assumes that genth will be a general form of splitths, that can be case-split, as needed. Otherwise fails. Note: We assume that all of "splitths" are split to the same level, and thus it doesn't matter which one we choose to look for the next split. Simply add search on splitthms and split variable, to change this. *) (* Note: possible efficiency measure: when a case theorem is no longer useful, drop it? *) (* Note: This should not be a separate tactic but integrated into the case split done during recdef's case analysis, this would avoid us having to (re)search for variables to split. *) fun splitto ctxt splitths genth = let val _ = not (null splitths) orelse error "splitto: no given splitths"; (* check if we are a member of splitths - FIXME: quicker and more flexible with discrim net. *) fun solve_by_splitth th split = Thm.biresolution (SOME ctxt) false [(false,split)] 1 th; fun split th = (case find_thms_split splitths 1 th of NONE => (writeln (cat_lines (["th:", Thm.string_of_thm ctxt th, "split ths:"] @ map (Thm.string_of_thm ctxt) splitths @ ["\n--"])); error "splitto: cannot find variable to split on") | SOME v => let val gt = HOLogic.dest_Trueprop (#1 (Logic.dest_implies (Thm.prop_of th))); val split_thm = mk_casesplit_goal_thm ctxt v gt; val (subthms, expf) = IsaND.fixed_subgoal_thms ctxt split_thm; in expf (map recsplitf subthms) end) and recsplitf th = (* note: multiple unifiers! we only take the first element, probably fine -- there is probably only one anyway. *) (case get_first (Seq.pull o solve_by_splitth th) splitths of NONE => split th | SOME (solved_th, _) => solved_th); in recsplitf genth end; end; (*** basic utilities ***) structure Utils: UTILS = struct (*standard exception for TFL*) exception ERR of {module: string, func: string, mesg: string}; fun UTILS_ERR func mesg = ERR {module = "Utils", func = func, mesg = mesg}; fun end_itlist _ [] = raise (UTILS_ERR "end_itlist" "list too short") | end_itlist _ [x] = x | end_itlist f (x :: xs) = f x (end_itlist f xs); fun itlist2 f L1 L2 base_value = let fun it ([],[]) = base_value | it ((a::rst1),(b::rst2)) = f a b (it (rst1,rst2)) | it _ = raise UTILS_ERR "itlist2" "different length lists" in it (L1,L2) end; fun pluck p = let fun remv ([],_) = raise UTILS_ERR "pluck" "item not found" | remv (h::t, A) = if p h then (h, rev A @ t) else remv (t,h::A) in fn L => remv(L,[]) end; fun take f = let fun grab(0, _) = [] | grab(n, x::rst) = f x::grab(n-1,rst) in grab end; fun zip3 [][][] = [] | zip3 (x::l1) (y::l2) (z::l3) = (x,y,z)::zip3 l1 l2 l3 | zip3 _ _ _ = raise UTILS_ERR "zip3" "different lengths"; end; (*** emulation of HOL's abstract syntax functions ***) structure USyntax: USYNTAX = struct infix 4 ##; fun USYN_ERR func mesg = Utils.ERR {module = "USyntax", func = func, mesg = mesg}; (*--------------------------------------------------------------------------- * * Types * *---------------------------------------------------------------------------*) val mk_prim_vartype = TVar; fun mk_vartype s = mk_prim_vartype ((s, 0), \<^sort>\type\); (* But internally, it's useful *) fun dest_vtype (TVar x) = x | dest_vtype _ = raise USYN_ERR "dest_vtype" "not a flexible type variable"; val is_vartype = can dest_vtype; val type_vars = map mk_prim_vartype o Misc_Legacy.typ_tvars fun type_varsl L = distinct (op =) (fold (curry op @ o type_vars) L []); val alpha = mk_vartype "'a" val strip_prod_type = HOLogic.flatten_tupleT; (*--------------------------------------------------------------------------- * * Terms * *---------------------------------------------------------------------------*) (* Free variables, in order of occurrence, from left to right in the * syntax tree. *) fun free_vars_lr tm = let fun memb x = let fun m[] = false | m(y::rst) = (x=y)orelse m rst in m end fun add (t, frees) = case t of Free _ => if (memb t frees) then frees else t::frees | Abs (_,_,body) => add(body,frees) | f$t => add(t, add(f, frees)) | _ => frees in rev(add(tm,[])) end; val type_vars_in_term = map mk_prim_vartype o Misc_Legacy.term_tvars; (* Prelogic *) fun dest_tybinding (v,ty) = (#1(dest_vtype v),ty) fun inst theta = subst_vars (map dest_tybinding theta,[]) (* Construction routines *) fun mk_abs{Bvar as Var((s,_),ty),Body} = Abs(s,ty,abstract_over(Bvar,Body)) | mk_abs{Bvar as Free(s,ty),Body} = Abs(s,ty,abstract_over(Bvar,Body)) | mk_abs _ = raise USYN_ERR "mk_abs" "Bvar is not a variable"; fun mk_imp{ant,conseq} = let val c = Const(\<^const_name>\HOL.implies\,HOLogic.boolT --> HOLogic.boolT --> HOLogic.boolT) in list_comb(c,[ant,conseq]) end; fun mk_select (r as {Bvar,Body}) = let val ty = type_of Bvar val c = Const(\<^const_name>\Eps\,(ty --> HOLogic.boolT) --> ty) in list_comb(c,[mk_abs r]) end; fun mk_forall (r as {Bvar,Body}) = let val ty = type_of Bvar val c = Const(\<^const_name>\All\,(ty --> HOLogic.boolT) --> HOLogic.boolT) in list_comb(c,[mk_abs r]) end; fun mk_exists (r as {Bvar,Body}) = let val ty = type_of Bvar val c = Const(\<^const_name>\Ex\,(ty --> HOLogic.boolT) --> HOLogic.boolT) in list_comb(c,[mk_abs r]) end; fun mk_conj{conj1,conj2} = let val c = Const(\<^const_name>\HOL.conj\,HOLogic.boolT --> HOLogic.boolT --> HOLogic.boolT) in list_comb(c,[conj1,conj2]) end; fun mk_disj{disj1,disj2} = let val c = Const(\<^const_name>\HOL.disj\,HOLogic.boolT --> HOLogic.boolT --> HOLogic.boolT) in list_comb(c,[disj1,disj2]) end; fun prod_ty ty1 ty2 = HOLogic.mk_prodT (ty1,ty2); local fun mk_uncurry (xt, yt, zt) = Const(\<^const_name>\case_prod\, (xt --> yt --> zt) --> prod_ty xt yt --> zt) fun dest_pair(Const(\<^const_name>\Pair\,_) $ M $ N) = {fst=M, snd=N} | dest_pair _ = raise USYN_ERR "dest_pair" "not a pair" fun is_var (Var _) = true | is_var (Free _) = true | is_var _ = false in fun mk_pabs{varstruct,body} = let fun mpa (varstruct, body) = if is_var varstruct then mk_abs {Bvar = varstruct, Body = body} else let val {fst, snd} = dest_pair varstruct in mk_uncurry (type_of fst, type_of snd, type_of body) $ mpa (fst, mpa (snd, body)) end in mpa (varstruct, body) end handle TYPE _ => raise USYN_ERR "mk_pabs" ""; end; (* Destruction routines *) datatype lambda = VAR of {Name : string, Ty : typ} | CONST of {Name : string, Ty : typ} | COMB of {Rator: term, Rand : term} | LAMB of {Bvar : term, Body : term}; fun dest_term(Var((s,_),ty)) = VAR{Name = s, Ty = ty} | dest_term(Free(s,ty)) = VAR{Name = s, Ty = ty} | dest_term(Const(s,ty)) = CONST{Name = s, Ty = ty} | dest_term(M$N) = COMB{Rator=M,Rand=N} | dest_term(Abs(s,ty,M)) = let val v = Free(s,ty) in LAMB{Bvar = v, Body = Term.betapply (M,v)} end | dest_term(Bound _) = raise USYN_ERR "dest_term" "Bound"; fun dest_const(Const(s,ty)) = {Name = s, Ty = ty} | dest_const _ = raise USYN_ERR "dest_const" "not a constant"; fun dest_comb(t1 $ t2) = {Rator = t1, Rand = t2} | dest_comb _ = raise USYN_ERR "dest_comb" "not a comb"; fun dest_abs used (a as Abs(s, ty, _)) = let val s' = singleton (Name.variant_list used) s; val v = Free(s', ty); in ({Bvar = v, Body = Term.betapply (a,v)}, s'::used) end | dest_abs _ _ = raise USYN_ERR "dest_abs" "not an abstraction"; fun dest_eq(Const(\<^const_name>\HOL.eq\,_) $ M $ N) = {lhs=M, rhs=N} | dest_eq _ = raise USYN_ERR "dest_eq" "not an equality"; fun dest_imp(Const(\<^const_name>\HOL.implies\,_) $ M $ N) = {ant=M, conseq=N} | dest_imp _ = raise USYN_ERR "dest_imp" "not an implication"; fun dest_forall(Const(\<^const_name>\All\,_) $ (a as Abs _)) = fst (dest_abs [] a) | dest_forall _ = raise USYN_ERR "dest_forall" "not a forall"; fun dest_exists(Const(\<^const_name>\Ex\,_) $ (a as Abs _)) = fst (dest_abs [] a) | dest_exists _ = raise USYN_ERR "dest_exists" "not an existential"; fun dest_neg(Const(\<^const_name>\Not\,_) $ M) = M | dest_neg _ = raise USYN_ERR "dest_neg" "not a negation"; fun dest_conj(Const(\<^const_name>\HOL.conj\,_) $ M $ N) = {conj1=M, conj2=N} | dest_conj _ = raise USYN_ERR "dest_conj" "not a conjunction"; fun dest_disj(Const(\<^const_name>\HOL.disj\,_) $ M $ N) = {disj1=M, disj2=N} | dest_disj _ = raise USYN_ERR "dest_disj" "not a disjunction"; fun mk_pair{fst,snd} = let val ty1 = type_of fst val ty2 = type_of snd val c = Const(\<^const_name>\Pair\,ty1 --> ty2 --> prod_ty ty1 ty2) in list_comb(c,[fst,snd]) end; fun dest_pair(Const(\<^const_name>\Pair\,_) $ M $ N) = {fst=M, snd=N} | dest_pair _ = raise USYN_ERR "dest_pair" "not a pair"; local fun ucheck t = (if #Name (dest_const t) = \<^const_name>\case_prod\ then t else raise Match) in fun dest_pabs used tm = let val ({Bvar,Body}, used') = dest_abs used tm in {varstruct = Bvar, body = Body, used = used'} end handle Utils.ERR _ => let val {Rator,Rand} = dest_comb tm val _ = ucheck Rator val {varstruct = lv, body, used = used'} = dest_pabs used Rand val {varstruct = rv, body, used = used''} = dest_pabs used' body in {varstruct = mk_pair {fst = lv, snd = rv}, body = body, used = used''} end end; val lhs = #lhs o dest_eq val rhs = #rhs o dest_eq val rand = #Rand o dest_comb (* Query routines *) val is_imp = can dest_imp val is_forall = can dest_forall val is_exists = can dest_exists val is_neg = can dest_neg val is_conj = can dest_conj val is_disj = can dest_disj val is_pair = can dest_pair val is_pabs = can (dest_pabs []) (* Construction of a cterm from a list of Terms *) fun list_mk_abs(L,tm) = fold_rev (fn v => fn M => mk_abs{Bvar=v, Body=M}) L tm; (* These others are almost never used *) fun list_mk_imp(A,c) = fold_rev (fn a => fn tm => mk_imp{ant=a,conseq=tm}) A c; fun list_mk_forall(V,t) = fold_rev (fn v => fn b => mk_forall{Bvar=v, Body=b})V t; val list_mk_conj = Utils.end_itlist(fn c1 => fn tm => mk_conj{conj1=c1, conj2=tm}) (* Need to reverse? *) fun gen_all tm = list_mk_forall(Misc_Legacy.term_frees tm, tm); (* Destructing a cterm to a list of Terms *) fun strip_comb tm = let fun dest(M$N, A) = dest(M, N::A) | dest x = x in dest(tm,[]) end; fun strip_abs(tm as Abs _) = let val ({Bvar,Body}, _) = dest_abs [] tm val (bvs, core) = strip_abs Body in (Bvar::bvs, core) end | strip_abs M = ([],M); fun strip_imp fm = if (is_imp fm) then let val {ant,conseq} = dest_imp fm val (was,wb) = strip_imp conseq in ((ant::was), wb) end else ([],fm); fun strip_forall fm = if (is_forall fm) then let val {Bvar,Body} = dest_forall fm val (bvs,core) = strip_forall Body in ((Bvar::bvs), core) end else ([],fm); fun strip_exists fm = if (is_exists fm) then let val {Bvar, Body} = dest_exists fm val (bvs,core) = strip_exists Body in (Bvar::bvs, core) end else ([],fm); fun strip_disj w = if (is_disj w) then let val {disj1,disj2} = dest_disj w in (strip_disj disj1@strip_disj disj2) end else [w]; (* Miscellaneous *) fun mk_vstruct ty V = let fun follow_prod_type (Type(\<^type_name>\Product_Type.prod\,[ty1,ty2])) vs = let val (ltm,vs1) = follow_prod_type ty1 vs val (rtm,vs2) = follow_prod_type ty2 vs1 in (mk_pair{fst=ltm, snd=rtm}, vs2) end | follow_prod_type _ (v::vs) = (v,vs) in #1 (follow_prod_type ty V) end; (* Search a term for a sub-term satisfying the predicate p. *) fun find_term p = let fun find tm = if (p tm) then SOME tm else case tm of Abs(_,_,body) => find body | (t$u) => (case find t of NONE => find u | some => some) | _ => NONE in find end; fun dest_relation tm = if (type_of tm = HOLogic.boolT) then let val (Const(\<^const_name>\Set.member\,_) $ (Const(\<^const_name>\Pair\,_)$y$x) $ R) = tm in (R,y,x) end handle Bind => raise USYN_ERR "dest_relation" "unexpected term structure" else raise USYN_ERR "dest_relation" "not a boolean term"; fun is_WFR (Const(\<^const_name>\Wellfounded.wf\,_)$_) = true | is_WFR _ = false; fun ARB ty = mk_select{Bvar=Free("v",ty), Body=Const(\<^const_name>\True\,HOLogic.boolT)}; end; (*** derived cterm destructors ***) structure Dcterm: DCTERM = struct fun ERR func mesg = Utils.ERR {module = "Dcterm", func = func, mesg = mesg}; fun dest_comb t = Thm.dest_comb t handle CTERM (msg, _) => raise ERR "dest_comb" msg; fun dest_abs a t = Thm.dest_abs a t handle CTERM (msg, _) => raise ERR "dest_abs" msg; fun capply t u = Thm.apply t u handle CTERM (msg, _) => raise ERR "capply" msg; fun cabs a t = Thm.lambda a t handle CTERM (msg, _) => raise ERR "cabs" msg; (*--------------------------------------------------------------------------- * Some simple constructor functions. *---------------------------------------------------------------------------*) val mk_hol_const = Thm.cterm_of \<^theory_context>\HOL\ o Const; fun mk_exists (r as (Bvar, Body)) = let val ty = Thm.typ_of_cterm Bvar val c = mk_hol_const(\<^const_name>\Ex\, (ty --> HOLogic.boolT) --> HOLogic.boolT) in capply c (uncurry cabs r) end; local val c = mk_hol_const(\<^const_name>\HOL.conj\, HOLogic.boolT --> HOLogic.boolT --> HOLogic.boolT) in fun mk_conj(conj1,conj2) = capply (capply c conj1) conj2 end; local val c = mk_hol_const(\<^const_name>\HOL.disj\, HOLogic.boolT --> HOLogic.boolT --> HOLogic.boolT) in fun mk_disj(disj1,disj2) = capply (capply c disj1) disj2 end; (*--------------------------------------------------------------------------- * The primitives. *---------------------------------------------------------------------------*) fun dest_const ctm = (case Thm.term_of ctm of Const(s,ty) => {Name = s, Ty = ty} | _ => raise ERR "dest_const" "not a constant"); fun dest_var ctm = (case Thm.term_of ctm of Var((s,_),ty) => {Name=s, Ty=ty} | Free(s,ty) => {Name=s, Ty=ty} | _ => raise ERR "dest_var" "not a variable"); (*--------------------------------------------------------------------------- * Derived destructor operations. *---------------------------------------------------------------------------*) fun dest_monop expected tm = let fun err () = raise ERR "dest_monop" ("Not a(n) " ^ quote expected); val (c, N) = dest_comb tm handle Utils.ERR _ => err (); val name = #Name (dest_const c handle Utils.ERR _ => err ()); in if name = expected then N else err () end; fun dest_binop expected tm = let fun err () = raise ERR "dest_binop" ("Not a(n) " ^ quote expected); val (M, N) = dest_comb tm handle Utils.ERR _ => err () in (dest_monop expected M, N) handle Utils.ERR _ => err () end; fun dest_binder expected tm = dest_abs NONE (dest_monop expected tm) handle Utils.ERR _ => raise ERR "dest_binder" ("Not a(n) " ^ quote expected); val dest_neg = dest_monop \<^const_name>\Not\ val dest_pair = dest_binop \<^const_name>\Pair\ val dest_eq = dest_binop \<^const_name>\HOL.eq\ val dest_imp = dest_binop \<^const_name>\HOL.implies\ val dest_conj = dest_binop \<^const_name>\HOL.conj\ val dest_disj = dest_binop \<^const_name>\HOL.disj\ val dest_exists = dest_binder \<^const_name>\Ex\ val dest_forall = dest_binder \<^const_name>\All\ (* Query routines *) val is_eq = can dest_eq val is_imp = can dest_imp val is_forall = can dest_forall val is_exists = can dest_exists val is_neg = can dest_neg val is_conj = can dest_conj val is_disj = can dest_disj val is_pair = can dest_pair (*--------------------------------------------------------------------------- * Iterated creation. *---------------------------------------------------------------------------*) val list_mk_disj = Utils.end_itlist (fn d1 => fn tm => mk_disj (d1, tm)); (*--------------------------------------------------------------------------- * Iterated destruction. (To the "right" in a term.) *---------------------------------------------------------------------------*) fun strip break tm = let fun dest (p as (ctm,accum)) = let val (M,N) = break ctm in dest (N, M::accum) end handle Utils.ERR _ => p in dest (tm,[]) end; fun rev2swap (x,l) = (rev l, x); val strip_comb = strip (Library.swap o dest_comb) (* Goes to the "left" *) val strip_imp = rev2swap o strip dest_imp val strip_abs = rev2swap o strip (dest_abs NONE) val strip_forall = rev2swap o strip dest_forall val strip_exists = rev2swap o strip dest_exists val strip_disj = rev o (op::) o strip dest_disj (*--------------------------------------------------------------------------- * Going into and out of prop *---------------------------------------------------------------------------*) fun is_Trueprop ct = (case Thm.term_of ct of Const (\<^const_name>\Trueprop\, _) $ _ => true | _ => false); fun mk_prop ct = if is_Trueprop ct then ct else Thm.apply \<^cterm>\Trueprop\ ct; fun drop_prop ct = if is_Trueprop ct then Thm.dest_arg ct else ct; end; (*** emulation of HOL inference rules for TFL ***) structure Rules: RULES = struct fun RULES_ERR func mesg = Utils.ERR {module = "Rules", func = func, mesg = mesg}; fun cconcl thm = Dcterm.drop_prop (Thm.cprop_of thm); fun chyps thm = map Dcterm.drop_prop (Thm.chyps_of thm); fun dest_thm thm = (map HOLogic.dest_Trueprop (Thm.hyps_of thm), HOLogic.dest_Trueprop (Thm.prop_of thm)) handle TERM _ => raise RULES_ERR "dest_thm" "missing Trueprop"; (* Inference rules *) (*--------------------------------------------------------------------------- * Equality (one step) *---------------------------------------------------------------------------*) fun REFL tm = HOLogic.mk_obj_eq (Thm.reflexive tm) handle THM (msg, _, _) => raise RULES_ERR "REFL" msg; fun SYM thm = thm RS sym handle THM (msg, _, _) => raise RULES_ERR "SYM" msg; fun ALPHA thm ctm1 = let val ctm2 = Thm.cprop_of thm; val ctm2_eq = Thm.reflexive ctm2; val ctm1_eq = Thm.reflexive ctm1; in Thm.equal_elim (Thm.transitive ctm2_eq ctm1_eq) thm end handle THM (msg, _, _) => raise RULES_ERR "ALPHA" msg; fun rbeta th = (case Dcterm.strip_comb (cconcl th) of (_, [_, r]) => Thm.transitive th (Thm.beta_conversion false r) | _ => raise RULES_ERR "rbeta" ""); (*---------------------------------------------------------------------------- * Implication and the assumption list * * Assumptions get stuck on the meta-language assumption list. Implications * are in the object language, so discharging an assumption "A" from theorem * "B" results in something that looks like "A --> B". *---------------------------------------------------------------------------*) fun ASSUME ctm = Thm.assume (Dcterm.mk_prop ctm); (*--------------------------------------------------------------------------- * Implication in TFL is -->. Meta-language implication (==>) is only used * in the implementation of some of the inference rules below. *---------------------------------------------------------------------------*) fun MP th1 th2 = th2 RS (th1 RS mp) handle THM (msg, _, _) => raise RULES_ERR "MP" msg; (*forces the first argument to be a proposition if necessary*) fun DISCH tm thm = Thm.implies_intr (Dcterm.mk_prop tm) thm COMP impI handle THM (msg, _, _) => raise RULES_ERR "DISCH" msg; fun DISCH_ALL thm = fold_rev DISCH (Thm.chyps_of thm) thm; fun FILTER_DISCH_ALL P thm = let fun check tm = P (Thm.term_of tm) in fold_rev (fn tm => fn th => if check tm then DISCH tm th else th) (chyps thm) thm end; fun UNDISCH thm = let val tm = Dcterm.mk_prop (#1 (Dcterm.dest_imp (cconcl thm))) in Thm.implies_elim (thm RS mp) (ASSUME tm) end handle Utils.ERR _ => raise RULES_ERR "UNDISCH" "" | THM _ => raise RULES_ERR "UNDISCH" ""; fun PROVE_HYP ath bth = MP (DISCH (cconcl ath) bth) ath; fun IMP_TRANS th1 th2 = th2 RS (th1 RS @{thm tfl_imp_trans}) handle THM (msg, _, _) => raise RULES_ERR "IMP_TRANS" msg; (*---------------------------------------------------------------------------- * Conjunction *---------------------------------------------------------------------------*) fun CONJUNCT1 thm = thm RS conjunct1 handle THM (msg, _, _) => raise RULES_ERR "CONJUNCT1" msg; fun CONJUNCT2 thm = thm RS conjunct2 handle THM (msg, _, _) => raise RULES_ERR "CONJUNCT2" msg; fun CONJUNCTS th = CONJUNCTS (CONJUNCT1 th) @ CONJUNCTS (CONJUNCT2 th) handle Utils.ERR _ => [th]; fun LIST_CONJ [] = raise RULES_ERR "LIST_CONJ" "empty list" | LIST_CONJ [th] = th | LIST_CONJ (th :: rst) = MP (MP (conjI COMP (impI RS impI)) th) (LIST_CONJ rst) handle THM (msg, _, _) => raise RULES_ERR "LIST_CONJ" msg; (*---------------------------------------------------------------------------- * Disjunction *---------------------------------------------------------------------------*) local val prop = Thm.prop_of disjI1 val [_,Q] = Misc_Legacy.term_vars prop val disj1 = Thm.forall_intr (Thm.cterm_of \<^context> Q) disjI1 in fun DISJ1 thm tm = thm RS (Thm.forall_elim (Dcterm.drop_prop tm) disj1) handle THM (msg, _, _) => raise RULES_ERR "DISJ1" msg; end; local val prop = Thm.prop_of disjI2 val [P,_] = Misc_Legacy.term_vars prop val disj2 = Thm.forall_intr (Thm.cterm_of \<^context> P) disjI2 in fun DISJ2 tm thm = thm RS (Thm.forall_elim (Dcterm.drop_prop tm) disj2) handle THM (msg, _, _) => raise RULES_ERR "DISJ2" msg; end; (*---------------------------------------------------------------------------- * * A1 |- M1, ..., An |- Mn * --------------------------------------------------- * [A1 |- M1 \/ ... \/ Mn, ..., An |- M1 \/ ... \/ Mn] * *---------------------------------------------------------------------------*) fun EVEN_ORS thms = let fun blue ldisjs [] _ = [] | blue ldisjs (th::rst) rdisjs = let val tail = tl rdisjs val rdisj_tl = Dcterm.list_mk_disj tail in fold_rev DISJ2 ldisjs (DISJ1 th rdisj_tl) :: blue (ldisjs @ [cconcl th]) rst tail end handle Utils.ERR _ => [fold_rev DISJ2 ldisjs th] in blue [] thms (map cconcl thms) end; (*---------------------------------------------------------------------------- * * A |- P \/ Q B,P |- R C,Q |- R * --------------------------------------------------- * A U B U C |- R * *---------------------------------------------------------------------------*) fun DISJ_CASES th1 th2 th3 = let val c = Dcterm.drop_prop (cconcl th1); val (disj1, disj2) = Dcterm.dest_disj c; val th2' = DISCH disj1 th2; val th3' = DISCH disj2 th3; in th3' RS (th2' RS (th1 RS @{thm tfl_disjE})) handle THM (msg, _, _) => raise RULES_ERR "DISJ_CASES" msg end; (*----------------------------------------------------------------------------- * * |- A1 \/ ... \/ An [A1 |- M, ..., An |- M] * --------------------------------------------------- * |- M * * Note. The list of theorems may be all jumbled up, so we have to * first organize it to align with the first argument (the disjunctive * theorem). *---------------------------------------------------------------------------*) fun organize eq = (* a bit slow - analogous to insertion sort *) let fun extract a alist = let fun ex (_,[]) = raise RULES_ERR "organize" "not a permutation.1" | ex(left,h::t) = if (eq h a) then (h,rev left@t) else ex(h::left,t) in ex ([],alist) end fun place [] [] = [] | place (a::rst) alist = let val (item,next) = extract a alist in item::place rst next end | place _ _ = raise RULES_ERR "organize" "not a permutation.2" in place end; fun DISJ_CASESL disjth thl = let val c = cconcl disjth fun eq th atm = exists (fn t => HOLogic.dest_Trueprop t aconv Thm.term_of atm) (Thm.hyps_of th) val tml = Dcterm.strip_disj c fun DL _ [] = raise RULES_ERR "DISJ_CASESL" "no cases" | DL th [th1] = PROVE_HYP th th1 | DL th [th1,th2] = DISJ_CASES th th1 th2 | DL th (th1::rst) = let val tm = #2 (Dcterm.dest_disj (Dcterm.drop_prop(cconcl th))) in DISJ_CASES th th1 (DL (ASSUME tm) rst) end in DL disjth (organize eq tml thl) end; (*---------------------------------------------------------------------------- * Universals *---------------------------------------------------------------------------*) local (* this is fragile *) val prop = Thm.prop_of spec val x = hd (tl (Misc_Legacy.term_vars prop)) val TV = dest_TVar (type_of x) val gspec = Thm.forall_intr (Thm.cterm_of \<^context> x) spec in fun SPEC tm thm = let val gspec' = Drule.instantiate_normalize ([(TV, Thm.ctyp_of_cterm tm)], []) gspec in thm RS (Thm.forall_elim tm gspec') end end; fun SPEC_ALL thm = fold SPEC (#1 (Dcterm.strip_forall(cconcl thm))) thm; val ISPEC = SPEC val ISPECL = fold ISPEC; (* Not optimized! Too complicated. *) local val prop = Thm.prop_of allI val [P] = Misc_Legacy.add_term_vars (prop, []) fun cty_theta ctxt = map (fn (i, (S, ty)) => ((i, S), Thm.ctyp_of ctxt ty)) fun ctm_theta ctxt = map (fn (i, (_, tm2)) => let val ctm2 = Thm.cterm_of ctxt tm2 in ((i, Thm.typ_of_cterm ctm2), ctm2) end) fun certify ctxt (ty_theta,tm_theta) = (cty_theta ctxt (Vartab.dest ty_theta), ctm_theta ctxt (Vartab.dest tm_theta)) in fun GEN ctxt v th = let val gth = Thm.forall_intr v th val thy = Proof_Context.theory_of ctxt val Const(\<^const_name>\Pure.all\,_)$Abs(x,ty,rst) = Thm.prop_of gth val P' = Abs(x,ty, HOLogic.dest_Trueprop rst) (* get rid of trueprop *) val theta = Pattern.match thy (P,P') (Vartab.empty, Vartab.empty); val allI2 = Drule.instantiate_normalize (certify ctxt theta) allI val thm = Thm.implies_elim allI2 gth val tp $ (A $ Abs(_,_,M)) = Thm.prop_of thm val prop' = tp $ (A $ Abs(x,ty,M)) in ALPHA thm (Thm.cterm_of ctxt prop') end end; fun GENL ctxt = fold_rev (GEN ctxt); fun GEN_ALL ctxt thm = let val prop = Thm.prop_of thm val vlist = map (Thm.cterm_of ctxt) (Misc_Legacy.add_term_vars (prop, [])) in GENL ctxt vlist thm end; fun MATCH_MP th1 th2 = if (Dcterm.is_forall (Dcterm.drop_prop(cconcl th1))) then MATCH_MP (th1 RS spec) th2 else MP th1 th2; (*---------------------------------------------------------------------------- * Existentials *---------------------------------------------------------------------------*) (*--------------------------------------------------------------------------- * Existential elimination * * A1 |- ?x.t[x] , A2, "t[v]" |- t' * ------------------------------------ (variable v occurs nowhere) * A1 u A2 |- t' * *---------------------------------------------------------------------------*) fun CHOOSE ctxt (fvar, exth) fact = let val lam = #2 (Dcterm.dest_comb (Dcterm.drop_prop (cconcl exth))) val redex = Dcterm.capply lam fvar val t$u = Thm.term_of redex val residue = Thm.cterm_of ctxt (Term.betapply (t, u)) in GEN ctxt fvar (DISCH residue fact) RS (exth RS @{thm tfl_exE}) handle THM (msg, _, _) => raise RULES_ERR "CHOOSE" msg end; fun EXISTS ctxt (template,witness) thm = let val abstr = #2 (Dcterm.dest_comb template) in thm RS (infer_instantiate ctxt [(("P", 0), abstr), (("x", 0), witness)] exI) handle THM (msg, _, _) => raise RULES_ERR "EXISTS" msg end; (*---------------------------------------------------------------------------- * * A |- M[x_1,...,x_n] * ---------------------------- [(x |-> y)_1,...,(x |-> y)_n] * A |- ?y_1...y_n. M * *---------------------------------------------------------------------------*) (* Could be improved, but needs "subst_free" for certified terms *) fun IT_EXISTS ctxt blist th = let val blist' = map (apply2 Thm.term_of) blist fun ex v M = Thm.cterm_of ctxt (USyntax.mk_exists{Bvar=v,Body = M}) in fold_rev (fn (b as (r1,r2)) => fn thm => EXISTS ctxt (ex r2 (subst_free [b] (HOLogic.dest_Trueprop(Thm.prop_of thm))), Thm.cterm_of ctxt r1) thm) blist' th end; (*---------------------------------------------------------------------------- * Rewriting *---------------------------------------------------------------------------*) fun SUBS ctxt thl = rewrite_rule ctxt (map (fn th => th RS eq_reflection handle THM _ => th) thl); val rew_conv = Raw_Simplifier.rewrite_cterm (true, false, false) (K (K NONE)); fun simpl_conv ctxt thl ctm = HOLogic.mk_obj_eq (rew_conv (ctxt addsimps thl) ctm); fun RIGHT_ASSOC ctxt = rewrite_rule ctxt @{thms tfl_disj_assoc}; (*--------------------------------------------------------------------------- * TERMINATION CONDITION EXTRACTION *---------------------------------------------------------------------------*) (* Object language quantifier, i.e., "!" *) fun Forall v M = USyntax.mk_forall{Bvar=v, Body=M}; (* Fragile: it's a cong if it is not "R y x ==> cut f R x y = f y" *) fun is_cong thm = case (Thm.prop_of thm) of (Const(\<^const_name>\Pure.imp\,_)$(Const(\<^const_name>\Trueprop\,_)$ _) $ (Const(\<^const_name>\Pure.eq\,_) $ (Const (\<^const_name>\Wfrec.cut\,_) $ _ $ _ $ _ $ _) $ _)) => false | _ => true; fun dest_equal(Const (\<^const_name>\Pure.eq\,_) $ (Const (\<^const_name>\Trueprop\,_) $ lhs) $ (Const (\<^const_name>\Trueprop\,_) $ rhs)) = {lhs=lhs, rhs=rhs} | dest_equal(Const (\<^const_name>\Pure.eq\,_) $ lhs $ rhs) = {lhs=lhs, rhs=rhs} | dest_equal tm = USyntax.dest_eq tm; fun get_lhs tm = #lhs(dest_equal (HOLogic.dest_Trueprop tm)); fun dest_all used (Const(\<^const_name>\Pure.all\,_) $ (a as Abs _)) = USyntax.dest_abs used a | dest_all _ _ = raise RULES_ERR "dest_all" "not a !!"; val is_all = can (dest_all []); fun strip_all used fm = if (is_all fm) then let val ({Bvar, Body}, used') = dest_all used fm val (bvs, core, used'') = strip_all used' Body in ((Bvar::bvs), core, used'') end else ([], fm, used); fun list_break_all(Const(\<^const_name>\Pure.all\,_) $ Abs (s,ty,body)) = let val (L,core) = list_break_all body in ((s,ty)::L, core) end | list_break_all tm = ([],tm); (*--------------------------------------------------------------------------- * Rename a term of the form * * !!x1 ...xn. x1=M1 ==> ... ==> xn=Mn * ==> ((%v1...vn. Q) x1 ... xn = g x1 ... xn. * to one of * * !!v1 ... vn. v1=M1 ==> ... ==> vn=Mn * ==> ((%v1...vn. Q) v1 ... vn = g v1 ... vn. * * This prevents name problems in extraction, and helps the result to read * better. There is a problem with varstructs, since they can introduce more * than n variables, and some extra reasoning needs to be done. *---------------------------------------------------------------------------*) fun get ([],_,L) = rev L | get (ant::rst,n,L) = case (list_break_all ant) of ([],_) => get (rst, n+1,L) | (_,body) => let val eq = Logic.strip_imp_concl body val (f,_) = USyntax.strip_comb (get_lhs eq) val (vstrl,_) = USyntax.strip_abs f val names = Name.variant_list (Misc_Legacy.add_term_names(body, [])) (map (#1 o dest_Free) vstrl) in get (rst, n+1, (names,n)::L) end handle TERM _ => get (rst, n+1, L) | Utils.ERR _ => get (rst, n+1, L); (* Note: Thm.rename_params_rule counts from 1, not 0 *) fun rename thm = let val ants = Logic.strip_imp_prems (Thm.prop_of thm) val news = get (ants,1,[]) in fold Thm.rename_params_rule news thm end; (*--------------------------------------------------------------------------- * Beta-conversion to the rhs of an equation (taken from hol90/drule.sml) *---------------------------------------------------------------------------*) fun list_beta_conv tm = let fun rbeta th = Thm.transitive th (Thm.beta_conversion false (#2(Dcterm.dest_eq(cconcl th)))) fun iter [] = Thm.reflexive tm | iter (v::rst) = rbeta (Thm.combination(iter rst) (Thm.reflexive v)) in iter end; (*--------------------------------------------------------------------------- * Trace information for the rewriter *---------------------------------------------------------------------------*) val tracing = Unsynchronized.ref false; fun say s = if !tracing then writeln s else (); fun print_thms ctxt s L = say (cat_lines (s :: map (Thm.string_of_thm ctxt) L)); fun print_term ctxt s t = say (cat_lines [s, Syntax.string_of_term ctxt t]); (*--------------------------------------------------------------------------- * General abstraction handlers, should probably go in USyntax. *---------------------------------------------------------------------------*) fun mk_aabs (vstr, body) = USyntax.mk_abs {Bvar = vstr, Body = body} handle Utils.ERR _ => USyntax.mk_pabs {varstruct = vstr, body = body}; fun list_mk_aabs (vstrl,tm) = fold_rev (fn vstr => fn tm => mk_aabs(vstr,tm)) vstrl tm; fun dest_aabs used tm = let val ({Bvar,Body}, used') = USyntax.dest_abs used tm in (Bvar, Body, used') end handle Utils.ERR _ => let val {varstruct, body, used} = USyntax.dest_pabs used tm in (varstruct, body, used) end; fun strip_aabs used tm = let val (vstr, body, used') = dest_aabs used tm val (bvs, core, used'') = strip_aabs used' body in (vstr::bvs, core, used'') end handle Utils.ERR _ => ([], tm, used); fun dest_combn tm 0 = (tm,[]) | dest_combn tm n = let val {Rator,Rand} = USyntax.dest_comb tm val (f,rands) = dest_combn Rator (n-1) in (f,Rand::rands) end; local fun dest_pair M = let val {fst,snd} = USyntax.dest_pair M in (fst,snd) end fun mk_fst tm = let val ty as Type(\<^type_name>\Product_Type.prod\, [fty,sty]) = type_of tm in Const (\<^const_name>\Product_Type.fst\, ty --> fty) $ tm end fun mk_snd tm = let val ty as Type(\<^type_name>\Product_Type.prod\, [fty,sty]) = type_of tm in Const (\<^const_name>\Product_Type.snd\, ty --> sty) $ tm end in fun XFILL tych x vstruct = let fun traverse p xocc L = if (is_Free p) then tych xocc::L else let val (p1,p2) = dest_pair p in traverse p1 (mk_fst xocc) (traverse p2 (mk_snd xocc) L) end in traverse vstruct x [] end end; (*--------------------------------------------------------------------------- * Replace a free tuple (vstr) by a universally quantified variable (a). * Note that the notion of "freeness" for a tuple is different than for a * variable: if variables in the tuple also occur in any other place than * an occurrences of the tuple, they aren't "free" (which is thus probably * the wrong word to use). *---------------------------------------------------------------------------*) fun VSTRUCT_ELIM ctxt tych a vstr th = let val L = USyntax.free_vars_lr vstr val bind1 = tych (HOLogic.mk_Trueprop (HOLogic.mk_eq(a,vstr))) val thm1 = Thm.implies_intr bind1 (SUBS ctxt [SYM(Thm.assume bind1)] th) val thm2 = forall_intr_list (map tych L) thm1 val thm3 = forall_elim_list (XFILL tych a vstr) thm2 in refl RS rewrite_rule ctxt [Thm.symmetric (@{thm surjective_pairing} RS eq_reflection)] thm3 end; fun PGEN ctxt tych a vstr th = let val a1 = tych a in Thm.forall_intr a1 (VSTRUCT_ELIM ctxt tych a vstr th) end; (*--------------------------------------------------------------------------- * Takes apart a paired beta-redex, looking like "(\(x,y).N) vstr", into * * (([x,y],N),vstr) *---------------------------------------------------------------------------*) fun dest_pbeta_redex used M n = let val (f,args) = dest_combn M n val _ = dest_aabs used f in (strip_aabs used f,args) end; fun pbeta_redex M n = can (fn t => dest_pbeta_redex [] t n) M; fun dest_impl tm = let val ants = Logic.strip_imp_prems tm val eq = Logic.strip_imp_concl tm in (ants,get_lhs eq) end; fun restricted t = is_some (USyntax.find_term (fn (Const(\<^const_name>\Wfrec.cut\,_)) =>true | _ => false) t) fun CONTEXT_REWRITE_RULE main_ctxt (func, G, cut_lemma, congs) th = let val globals = func::G val ctxt0 = empty_simpset main_ctxt val pbeta_reduce = simpl_conv ctxt0 [@{thm split_conv} RS eq_reflection]; val tc_list = Unsynchronized.ref []: term list Unsynchronized.ref val cut_lemma' = cut_lemma RS eq_reflection fun prover used ctxt thm = let fun cong_prover ctxt thm = let val _ = say "cong_prover:" val cntxt = Simplifier.prems_of ctxt val _ = print_thms ctxt "cntxt:" cntxt val _ = say "cong rule:" val _ = say (Thm.string_of_thm ctxt thm) (* Unquantified eliminate *) fun uq_eliminate (thm,imp) = let val tych = Thm.cterm_of ctxt val _ = print_term ctxt "To eliminate:" imp val ants = map tych (Logic.strip_imp_prems imp) val eq = Logic.strip_imp_concl imp val lhs = tych(get_lhs eq) val ctxt' = Simplifier.add_prems (map ASSUME ants) ctxt val lhs_eq_lhs1 = Raw_Simplifier.rewrite_cterm (false,true,false) (prover used) ctxt' lhs handle Utils.ERR _ => Thm.reflexive lhs val _ = print_thms ctxt' "proven:" [lhs_eq_lhs1] val lhs_eq_lhs2 = implies_intr_list ants lhs_eq_lhs1 val lhs_eeq_lhs2 = HOLogic.mk_obj_eq lhs_eq_lhs2 in lhs_eeq_lhs2 COMP thm end fun pq_eliminate (thm, vlist, imp_body, lhs_eq) = let val ((vstrl, _, used'), args) = dest_pbeta_redex used lhs_eq (length vlist) val _ = forall (op aconv) (ListPair.zip (vlist, args)) orelse error "assertion failed in CONTEXT_REWRITE_RULE" val imp_body1 = subst_free (ListPair.zip (args, vstrl)) imp_body val tych = Thm.cterm_of ctxt val ants1 = map tych (Logic.strip_imp_prems imp_body1) val eq1 = Logic.strip_imp_concl imp_body1 val Q = get_lhs eq1 val QeqQ1 = pbeta_reduce (tych Q) val Q1 = #2(Dcterm.dest_eq(cconcl QeqQ1)) val ctxt' = Simplifier.add_prems (map ASSUME ants1) ctxt val Q1eeqQ2 = Raw_Simplifier.rewrite_cterm (false,true,false) (prover used') ctxt' Q1 handle Utils.ERR _ => Thm.reflexive Q1 val Q2 = #2 (Logic.dest_equals (Thm.prop_of Q1eeqQ2)) val Q3 = tych(list_comb(list_mk_aabs(vstrl,Q2),vstrl)) val Q2eeqQ3 = Thm.symmetric(pbeta_reduce Q3 RS eq_reflection) val thA = Thm.transitive(QeqQ1 RS eq_reflection) Q1eeqQ2 val QeeqQ3 = Thm.transitive thA Q2eeqQ3 handle THM _ => (HOLogic.mk_obj_eq Q2eeqQ3 RS (HOLogic.mk_obj_eq thA RS trans)) RS eq_reflection val impth = implies_intr_list ants1 QeeqQ3 val impth1 = HOLogic.mk_obj_eq impth (* Need to abstract *) val ant_th = Utils.itlist2 (PGEN ctxt' tych) args vstrl impth1 in ant_th COMP thm end fun q_eliminate (thm, imp) = let val (vlist, imp_body, used') = strip_all used imp val (ants,Q) = dest_impl imp_body in if (pbeta_redex Q) (length vlist) then pq_eliminate (thm, vlist, imp_body, Q) else let val tych = Thm.cterm_of ctxt val ants1 = map tych ants val ctxt' = Simplifier.add_prems (map ASSUME ants1) ctxt val Q_eeq_Q1 = Raw_Simplifier.rewrite_cterm (false,true,false) (prover used') ctxt' (tych Q) handle Utils.ERR _ => Thm.reflexive (tych Q) val lhs_eeq_lhs2 = implies_intr_list ants1 Q_eeq_Q1 val lhs_eq_lhs2 = HOLogic.mk_obj_eq lhs_eeq_lhs2 val ant_th = forall_intr_list(map tych vlist)lhs_eq_lhs2 in ant_th COMP thm end end fun eliminate thm = case Thm.prop_of thm of Const(\<^const_name>\Pure.imp\,_) $ imp $ _ => eliminate (if not(is_all imp) then uq_eliminate (thm, imp) else q_eliminate (thm, imp)) (* Assume that the leading constant is ==, *) | _ => thm (* if it is not a ==> *) in SOME(eliminate (rename thm)) end handle Utils.ERR _ => NONE (* FIXME handle THM as well?? *) fun restrict_prover ctxt thm = let val _ = say "restrict_prover:" val cntxt = rev (Simplifier.prems_of ctxt) val _ = print_thms ctxt "cntxt:" cntxt val Const(\<^const_name>\Pure.imp\,_) $ (Const(\<^const_name>\Trueprop\,_) $ A) $ _ = Thm.prop_of thm fun genl tm = let val vlist = subtract (op aconv) globals (Misc_Legacy.add_term_frees(tm,[])) in fold_rev Forall vlist tm end (*-------------------------------------------------------------- * This actually isn't quite right, since it will think that * not-fully applied occs. of "f" in the context mean that the * current call is nested. The real solution is to pass in a * term "f v1..vn" which is a pattern that any full application * of "f" will match. *-------------------------------------------------------------*) val func_name = #1(dest_Const func) fun is_func (Const (name,_)) = (name = func_name) | is_func _ = false val rcontext = rev cntxt val cncl = HOLogic.dest_Trueprop o Thm.prop_of val antl = case rcontext of [] => [] | _ => [USyntax.list_mk_conj(map cncl rcontext)] val TC = genl(USyntax.list_mk_imp(antl, A)) val _ = print_term ctxt "func:" func val _ = print_term ctxt "TC:" (HOLogic.mk_Trueprop TC) val _ = tc_list := (TC :: !tc_list) val nestedp = is_some (USyntax.find_term is_func TC) val _ = if nestedp then say "nested" else say "not_nested" val th' = if nestedp then raise RULES_ERR "solver" "nested function" else let val cTC = Thm.cterm_of ctxt (HOLogic.mk_Trueprop TC) in case rcontext of [] => SPEC_ALL(ASSUME cTC) | _ => MP (SPEC_ALL (ASSUME cTC)) (LIST_CONJ rcontext) end val th'' = th' RS thm in SOME (th'') end handle Utils.ERR _ => NONE (* FIXME handle THM as well?? *) in (if (is_cong thm) then cong_prover else restrict_prover) ctxt thm end val ctm = Thm.cprop_of th val names = Misc_Legacy.add_term_names (Thm.term_of ctm, []) val th1 = Raw_Simplifier.rewrite_cterm (false, true, false) (prover names) (ctxt0 addsimps [cut_lemma'] |> fold Simplifier.add_eqcong congs) ctm val th2 = Thm.equal_elim th1 th in (th2, filter_out restricted (!tc_list)) end; fun prove ctxt strict (t, tac) = let val ctxt' = Proof_Context.augment t ctxt; in if strict then Goal.prove ctxt' [] [] t (K tac) else Goal.prove ctxt' [] [] t (K tac) handle ERROR msg => (warning msg; raise RULES_ERR "prove" msg) end; end; (*** theory operations ***) structure Thry: THRY = struct fun THRY_ERR func mesg = Utils.ERR {module = "Thry", func = func, mesg = mesg}; (*--------------------------------------------------------------------------- * Matching *---------------------------------------------------------------------------*) local fun tybind (ixn, (S, T)) = (TVar (ixn, S), T); in fun match_term thry pat ob = let val (ty_theta, tm_theta) = Pattern.match thry (pat,ob) (Vartab.empty, Vartab.empty); fun tmbind (ixn, (T, t)) = (Var (ixn, Envir.subst_type ty_theta T), t) in (map tmbind (Vartab.dest tm_theta), map tybind (Vartab.dest ty_theta)) end; fun match_type thry pat ob = map tybind (Vartab.dest (Sign.typ_match thry (pat, ob) Vartab.empty)); end; (*--------------------------------------------------------------------------- * Typing *---------------------------------------------------------------------------*) fun typecheck thy t = Thm.global_cterm_of thy t handle TYPE (msg, _, _) => raise THRY_ERR "typecheck" msg | TERM (msg, _) => raise THRY_ERR "typecheck" msg; (*--------------------------------------------------------------------------- * Get information about datatypes *---------------------------------------------------------------------------*) fun match_info thy dtco = case (BNF_LFP_Compat.get_info thy [BNF_LFP_Compat.Keep_Nesting] dtco, BNF_LFP_Compat.get_constrs thy dtco) of (SOME {case_name, ... }, SOME constructors) => SOME {case_const = Const (case_name, Sign.the_const_type thy case_name), constructors = map Const constructors} | _ => NONE; fun induct_info thy dtco = case BNF_LFP_Compat.get_info thy [BNF_LFP_Compat.Keep_Nesting] dtco of NONE => NONE | SOME {nchotomy, ...} => SOME {nchotomy = nchotomy, constructors = (map Const o the o BNF_LFP_Compat.get_constrs thy) dtco}; fun extract_info thy = let val infos = map snd (Symtab.dest (BNF_LFP_Compat.get_all thy [BNF_LFP_Compat.Keep_Nesting])) in {case_congs = map (mk_meta_eq o #case_cong) infos, case_rewrites = maps (map mk_meta_eq o #case_rewrites) infos} end; end; (*** first part of main module ***) structure Prim: PRIM = struct val trace = Unsynchronized.ref false; fun TFL_ERR func mesg = Utils.ERR {module = "Tfl", func = func, mesg = mesg}; val concl = #2 o Rules.dest_thm; val list_mk_type = Utils.end_itlist (curry (op -->)); fun front_last [] = raise TFL_ERR "front_last" "empty list" | front_last [x] = ([],x) | front_last (h::t) = let val (pref,x) = front_last t in (h::pref,x) end; (*--------------------------------------------------------------------------- * The next function is common to pattern-match translation and * proof of completeness of cases for the induction theorem. * * The curried function "gvvariant" returns a function to generate distinct * variables that are guaranteed not to be in names. The names of * the variables go u, v, ..., z, aa, ..., az, ... The returned * function contains embedded refs! *---------------------------------------------------------------------------*) fun gvvariant names = let val slist = Unsynchronized.ref names val vname = Unsynchronized.ref "u" fun new() = if member (op =) (!slist) (!vname) then (vname := Symbol.bump_string (!vname); new()) else (slist := !vname :: !slist; !vname) in fn ty => Free(new(), ty) end; (*--------------------------------------------------------------------------- * Used in induction theorem production. This is the simple case of * partitioning up pattern rows by the leading constructor. *---------------------------------------------------------------------------*) fun ipartition gv (constructors,rows) = let fun pfail s = raise TFL_ERR "partition.part" s fun part {constrs = [], rows = [], A} = rev A | part {constrs = [], rows = _::_, A} = pfail"extra cases in defn" | part {constrs = _::_, rows = [], A} = pfail"cases missing in defn" | part {constrs = c::crst, rows, A} = let val (c, T) = dest_Const c val L = binder_types T val (in_group, not_in_group) = fold_rev (fn (row as (p::rst, rhs)) => fn (in_group,not_in_group) => let val (pc,args) = USyntax.strip_comb p in if (#1(dest_Const pc) = c) then ((args@rst, rhs)::in_group, not_in_group) else (in_group, row::not_in_group) end) rows ([],[]) val col_types = Utils.take type_of (length L, #1(hd in_group)) in part{constrs = crst, rows = not_in_group, A = {constructor = c, new_formals = map gv col_types, group = in_group}::A} end in part{constrs = constructors, rows = rows, A = []} end; (*--------------------------------------------------------------------------- * Each pattern carries with it a tag (i,b) where * i is the clause it came from and * b=true indicates that clause was given by the user * (or is an instantiation of a user supplied pattern) * b=false --> i = ~1 *---------------------------------------------------------------------------*) type pattern = term * (int * bool) fun pattern_map f (tm,x) = (f tm, x); fun pattern_subst theta = pattern_map (subst_free theta); val pat_of = fst; fun row_of_pat x = fst (snd x); fun given x = snd (snd x); (*--------------------------------------------------------------------------- * Produce an instance of a constructor, plus genvars for its arguments. *---------------------------------------------------------------------------*) fun fresh_constr ty_match colty gv c = let val (_,Ty) = dest_Const c val L = binder_types Ty and ty = body_type Ty val ty_theta = ty_match ty colty val c' = USyntax.inst ty_theta c val gvars = map (USyntax.inst ty_theta o gv) L in (c', gvars) end; (*--------------------------------------------------------------------------- * Goes through a list of rows and picks out the ones beginning with a * pattern with constructor = name. *---------------------------------------------------------------------------*) fun mk_group name rows = fold_rev (fn (row as ((prfx, p::rst), rhs)) => fn (in_group,not_in_group) => let val (pc,args) = USyntax.strip_comb p in if ((#1 (Term.dest_Const pc) = name) handle TERM _ => false) then (((prfx,args@rst), rhs)::in_group, not_in_group) else (in_group, row::not_in_group) end) rows ([],[]); (*--------------------------------------------------------------------------- * Partition the rows. Not efficient: we should use hashing. *---------------------------------------------------------------------------*) fun partition _ _ (_,_,_,[]) = raise TFL_ERR "partition" "no rows" | partition gv ty_match (constructors, colty, res_ty, rows as (((prfx,_),_)::_)) = let val fresh = fresh_constr ty_match colty gv fun part {constrs = [], rows, A} = rev A | part {constrs = c::crst, rows, A} = let val (c',gvars) = fresh c val (in_group, not_in_group) = mk_group (#1 (dest_Const c')) rows val in_group' = if (null in_group) (* Constructor not given *) then [((prfx, #2(fresh c)), (USyntax.ARB res_ty, (~1,false)))] else in_group in part{constrs = crst, rows = not_in_group, A = {constructor = c', new_formals = gvars, group = in_group'}::A} end in part{constrs=constructors, rows=rows, A=[]} end; (*--------------------------------------------------------------------------- * Misc. routines used in mk_case *---------------------------------------------------------------------------*) fun mk_pat (c,l) = let val L = length (binder_types (type_of c)) fun build (prfx,tag,plist) = let val (args, plist') = chop L plist in (prfx,tag,list_comb(c,args)::plist') end in map build l end; fun v_to_prfx (prfx, v::pats) = (v::prfx,pats) | v_to_prfx _ = raise TFL_ERR "mk_case" "v_to_prfx"; fun v_to_pats (v::prfx,tag, pats) = (prfx, tag, v::pats) | v_to_pats _ = raise TFL_ERR "mk_case" "v_to_pats"; (*---------------------------------------------------------------------------- * Translation of pattern terms into nested case expressions. * * This performs the translation and also builds the full set of patterns. * Thus it supports the construction of induction theorems even when an * incomplete set of patterns is given. *---------------------------------------------------------------------------*) fun mk_case ty_info ty_match usednames range_ty = let fun mk_case_fail s = raise TFL_ERR "mk_case" s val fresh_var = gvvariant usednames val divide = partition fresh_var ty_match fun expand _ ty ((_,[]), _) = mk_case_fail"expand_var_row" | expand constructors ty (row as ((prfx, p::rst), rhs)) = if (is_Free p) then let val fresh = fresh_constr ty_match ty fresh_var fun expnd (c,gvs) = let val capp = list_comb(c,gvs) in ((prfx, capp::rst), pattern_subst[(p,capp)] rhs) end in map expnd (map fresh constructors) end else [row] fun mk{rows=[],...} = mk_case_fail"no rows" | mk{path=[], rows = ((prfx, []), (tm,tag))::_} = (* Done *) ([(prfx,tag,[])], tm) | mk{path=[], rows = _::_} = mk_case_fail"blunder" | mk{path as u::rstp, rows as ((prfx, []), rhs)::rst} = mk{path = path, rows = ((prfx, [fresh_var(type_of u)]), rhs)::rst} | mk{path = u::rstp, rows as ((_, p::_), _)::_} = let val (pat_rectangle,rights) = ListPair.unzip rows val col0 = map(hd o #2) pat_rectangle in if (forall is_Free col0) then let val rights' = map (fn(v,e) => pattern_subst[(v,u)] e) (ListPair.zip (col0, rights)) val pat_rectangle' = map v_to_prfx pat_rectangle val (pref_patl,tm) = mk{path = rstp, rows = ListPair.zip (pat_rectangle', rights')} in (map v_to_pats pref_patl, tm) end else let val pty as Type (ty_name,_) = type_of p in case (ty_info ty_name) of NONE => mk_case_fail("Not a known datatype: "^ty_name) | SOME{case_const,constructors} => let val case_const_name = #1(dest_Const case_const) val nrows = maps (expand constructors pty) rows val subproblems = divide(constructors, pty, range_ty, nrows) val groups = map #group subproblems and new_formals = map #new_formals subproblems and constructors' = map #constructor subproblems val news = map (fn (nf,rows) => {path = nf@rstp, rows=rows}) (ListPair.zip (new_formals, groups)) val rec_calls = map mk news val (pat_rect,dtrees) = ListPair.unzip rec_calls val case_functions = map USyntax.list_mk_abs (ListPair.zip (new_formals, dtrees)) val types = map type_of (case_functions@[u]) @ [range_ty] val case_const' = Const(case_const_name, list_mk_type types) val tree = list_comb(case_const', case_functions@[u]) val pat_rect1 = flat (ListPair.map mk_pat (constructors', pat_rect)) in (pat_rect1,tree) end end end in mk end; (* Repeated variable occurrences in a pattern are not allowed. *) fun FV_multiset tm = case (USyntax.dest_term tm) of USyntax.VAR{Name = c, Ty = T} => [Free(c, T)] | USyntax.CONST _ => [] | USyntax.COMB{Rator, Rand} => FV_multiset Rator @ FV_multiset Rand | USyntax.LAMB _ => raise TFL_ERR "FV_multiset" "lambda"; fun no_repeat_vars thy pat = let fun check [] = true | check (v::rst) = if member (op aconv) rst v then raise TFL_ERR "no_repeat_vars" (quote (#1 (dest_Free v)) ^ " occurs repeatedly in the pattern " ^ quote (Syntax.string_of_term_global thy pat)) else check rst in check (FV_multiset pat) end; fun dest_atom (Free p) = p | dest_atom (Const p) = p | dest_atom _ = raise TFL_ERR "dest_atom" "function name not an identifier"; fun same_name (p,q) = #1(dest_atom p) = #1(dest_atom q); local fun mk_functional_err s = raise TFL_ERR "mk_functional" s fun single [_$_] = mk_functional_err "recdef does not allow currying" | single [f] = f | single fs = (*multiple function names?*) if length (distinct same_name fs) < length fs then mk_functional_err "The function being declared appears with multiple types" else mk_functional_err (string_of_int (length fs) ^ " distinct function names being declared") in fun mk_functional thy clauses = let val (L,R) = ListPair.unzip (map HOLogic.dest_eq clauses handle TERM _ => raise TFL_ERR "mk_functional" "recursion equations must use the = relation") val (funcs,pats) = ListPair.unzip (map (fn (t$u) =>(t,u)) L) val atom = single (distinct (op aconv) funcs) val (fname,ftype) = dest_atom atom val _ = map (no_repeat_vars thy) pats val rows = ListPair.zip (map (fn x => ([]:term list,[x])) pats, map_index (fn (i, t) => (t,(i,true))) R) val names = List.foldr Misc_Legacy.add_term_names [] R val atype = type_of(hd pats) and aname = singleton (Name.variant_list names) "a" val a = Free(aname,atype) val ty_info = Thry.match_info thy val ty_match = Thry.match_type thy val range_ty = type_of (hd R) val (patts, case_tm) = mk_case ty_info ty_match (aname::names) range_ty {path=[a], rows=rows} val patts1 = map (fn (_,tag,[pat]) => (pat,tag)) patts handle Match => mk_functional_err "error in pattern-match translation" val patts2 = Library.sort (Library.int_ord o apply2 row_of_pat) patts1 val finals = map row_of_pat patts2 val originals = map (row_of_pat o #2) rows val _ = case (subtract (op =) finals originals) of [] => () | L => mk_functional_err ("The following clauses are redundant (covered by preceding clauses): " ^ commas (map (fn i => string_of_int (i + 1)) L)) in {functional = Abs(Long_Name.base_name fname, ftype, abstract_over (atom, absfree (aname,atype) case_tm)), pats = patts2} end end; (*---------------------------------------------------------------------------- * * PRINCIPLES OF DEFINITION * *---------------------------------------------------------------------------*) (*For Isabelle, the lhs of a definition must be a constant.*) fun const_def sign (c, Ty, rhs) = singleton (Syntax.check_terms (Proof_Context.init_global sign)) (Const(\<^const_name>\Pure.eq\,dummyT) $ Const(c,Ty) $ rhs); (*Make all TVars available for instantiation by adding a ? to the front*) fun poly_tvars (Type(a,Ts)) = Type(a, map (poly_tvars) Ts) | poly_tvars (TFree (a,sort)) = TVar (("?" ^ a, 0), sort) | poly_tvars (TVar ((a,i),sort)) = TVar (("?" ^ a, i+1), sort); local val f_eq_wfrec_R_M = #ant(USyntax.dest_imp(#2(USyntax.strip_forall (concl @{thm tfl_wfrec})))) val {lhs=f, rhs} = USyntax.dest_eq f_eq_wfrec_R_M val _ = dest_Free f val (wfrec,_) = USyntax.strip_comb rhs in fun wfrec_definition0 fid R (functional as Abs(x, Ty, _)) thy = let val def_name = Thm.def_name (Long_Name.base_name fid) val wfrec_R_M = map_types poly_tvars (wfrec $ map_types poly_tvars R) $ functional val def_term = const_def thy (fid, Ty, wfrec_R_M) val ([def], thy') = Global_Theory.add_defs false [Thm.no_attributes (Binding.name def_name, def_term)] thy in (def, thy') end; end; (*--------------------------------------------------------------------------- * This structure keeps track of congruence rules that aren't derived * from a datatype definition. *---------------------------------------------------------------------------*) fun extraction_thms thy = let val {case_rewrites,case_congs} = Thry.extract_info thy in (case_rewrites, case_congs) end; (*--------------------------------------------------------------------------- * Pair patterns with termination conditions. The full list of patterns for * a definition is merged with the TCs arising from the user-given clauses. * There can be fewer clauses than the full list, if the user omitted some * cases. This routine is used to prepare input for mk_induction. *---------------------------------------------------------------------------*) fun merge full_pats TCs = let fun insert (p,TCs) = let fun insrt ((x as (h,[]))::rst) = if (p aconv h) then (p,TCs)::rst else x::insrt rst | insrt (x::rst) = x::insrt rst | insrt[] = raise TFL_ERR "merge.insert" "pattern not found" in insrt end fun pass ([],ptcl_final) = ptcl_final | pass (ptcs::tcl, ptcl) = pass(tcl, insert ptcs ptcl) in pass (TCs, map (fn p => (p,[])) full_pats) end; fun givens pats = map pat_of (filter given pats); fun post_definition ctxt meta_tflCongs (def, pats) = let val thy = Proof_Context.theory_of ctxt val tych = Thry.typecheck thy val f = #lhs(USyntax.dest_eq(concl def)) val corollary = Rules.MATCH_MP @{thm tfl_wfrec} def val pats' = filter given pats val given_pats = map pat_of pats' val rows = map row_of_pat pats' val WFR = #ant(USyntax.dest_imp(concl corollary)) val R = #Rand(USyntax.dest_comb WFR) val corollary' = Rules.UNDISCH corollary (* put WF R on assums *) val corollaries = map (fn pat => Rules.SPEC (tych pat) corollary') given_pats val (case_rewrites,context_congs) = extraction_thms thy (*case_ss causes minimal simplification: bodies of case expressions are not simplified. Otherwise large examples (Red-Black trees) are too slow.*) val case_simpset = put_simpset HOL_basic_ss ctxt addsimps case_rewrites |> fold (Simplifier.add_cong o #case_cong_weak o snd) (Symtab.dest (BNF_LFP_Compat.get_all thy [BNF_LFP_Compat.Keep_Nesting])) val corollaries' = map (Simplifier.simplify case_simpset) corollaries val extract = Rules.CONTEXT_REWRITE_RULE ctxt (f, [R], @{thm cut_apply}, meta_tflCongs @ context_congs) val (rules, TCs) = ListPair.unzip (map extract corollaries') val rules0 = map (rewrite_rule ctxt @{thms tfl_cut_def}) rules val mk_cond_rule = Rules.FILTER_DISCH_ALL(not o curry (op aconv) WFR) val rules1 = Rules.LIST_CONJ(map mk_cond_rule rules0) in {rules = rules1, rows = rows, full_pats_TCs = merge (map pat_of pats) (ListPair.zip (given_pats, TCs)), TCs = TCs} end; (*---------------------------------------------------------------------------- * * INDUCTION THEOREM * *---------------------------------------------------------------------------*) (*------------------------ Miscellaneous function -------------------------- * * [x_1,...,x_n] ?v_1...v_n. M[v_1,...,v_n] * ----------------------------------------------------------- * ( M[x_1,...,x_n], [(x_i,?v_1...v_n. M[v_1,...,v_n]), * ... * (x_j,?v_n. M[x_1,...,x_(n-1),v_n])] ) * * This function is totally ad hoc. Used in the production of the induction * theorem. The nchotomy theorem can have clauses that look like * * ?v1..vn. z = C vn..v1 * * in which the order of quantification is not the order of occurrence of the * quantified variables as arguments to C. Since we have no control over this * aspect of the nchotomy theorem, we make the correspondence explicit by * pairing the incoming new variable with the term it gets beta-reduced into. *---------------------------------------------------------------------------*) fun alpha_ex_unroll (xlist, tm) = let val (qvars,body) = USyntax.strip_exists tm val vlist = #2 (USyntax.strip_comb (USyntax.rhs body)) val plist = ListPair.zip (vlist, xlist) val args = map (the o AList.lookup (op aconv) plist) qvars handle Option.Option => raise Fail "TFL.alpha_ex_unroll: no correspondence" fun build ex [] = [] | build (_$rex) (v::rst) = let val ex1 = Term.betapply(rex, v) in ex1 :: build ex1 rst end val (nex::exl) = rev (tm::build tm args) in (nex, ListPair.zip (args, rev exl)) end; (*---------------------------------------------------------------------------- * * PROVING COMPLETENESS OF PATTERNS * *---------------------------------------------------------------------------*) fun mk_case ctxt ty_info usednames = let val thy = Proof_Context.theory_of ctxt val divide = ipartition (gvvariant usednames) val tych = Thry.typecheck thy fun tych_binding(x,y) = (tych x, tych y) fun fail s = raise TFL_ERR "mk_case" s fun mk{rows=[],...} = fail"no rows" | mk{path=[], rows = [([], (thm, bindings))]} = Rules.IT_EXISTS ctxt (map tych_binding bindings) thm | mk{path = u::rstp, rows as (p::_, _)::_} = let val (pat_rectangle,rights) = ListPair.unzip rows val col0 = map hd pat_rectangle val pat_rectangle' = map tl pat_rectangle in if (forall is_Free col0) (* column 0 is all variables *) then let val rights' = map (fn ((thm,theta),v) => (thm,theta@[(u,v)])) (ListPair.zip (rights, col0)) in mk{path = rstp, rows = ListPair.zip (pat_rectangle', rights')} end else (* column 0 is all constructors *) let val Type (ty_name,_) = type_of p in case (ty_info ty_name) of NONE => fail("Not a known datatype: "^ty_name) | SOME{constructors,nchotomy} => let val thm' = Rules.ISPEC (tych u) nchotomy val disjuncts = USyntax.strip_disj (concl thm') val subproblems = divide(constructors, rows) val groups = map #group subproblems and new_formals = map #new_formals subproblems val existentials = ListPair.map alpha_ex_unroll (new_formals, disjuncts) val constraints = map #1 existentials val vexl = map #2 existentials fun expnd tm (pats,(th,b)) = (pats, (Rules.SUBS ctxt [Rules.ASSUME (tych tm)] th, b)) val news = map (fn (nf,rows,c) => {path = nf@rstp, rows = map (expnd c) rows}) (Utils.zip3 new_formals groups constraints) val recursive_thms = map mk news val build_exists = Library.foldr (fn((x,t), th) => Rules.CHOOSE ctxt (tych x, Rules.ASSUME (tych t)) th) val thms' = ListPair.map build_exists (vexl, recursive_thms) val same_concls = Rules.EVEN_ORS thms' in Rules.DISJ_CASESL thm' same_concls end end end in mk end; fun complete_cases ctxt = let val thy = Proof_Context.theory_of ctxt val tych = Thry.typecheck thy val ty_info = Thry.induct_info thy in fn pats => let val names = List.foldr Misc_Legacy.add_term_names [] pats val T = type_of (hd pats) val aname = singleton (Name.variant_list names) "a" val vname = singleton (Name.variant_list (aname::names)) "v" val a = Free (aname, T) val v = Free (vname, T) val a_eq_v = HOLogic.mk_eq(a,v) val ex_th0 = Rules.EXISTS ctxt (tych (USyntax.mk_exists{Bvar=v,Body=a_eq_v}), tych a) (Rules.REFL (tych a)) val th0 = Rules.ASSUME (tych a_eq_v) val rows = map (fn x => ([x], (th0,[]))) pats in Rules.GEN ctxt (tych a) (Rules.RIGHT_ASSOC ctxt (Rules.CHOOSE ctxt (tych v, ex_th0) (mk_case ctxt ty_info (vname::aname::names) {path=[v], rows=rows}))) end end; (*--------------------------------------------------------------------------- * Constructing induction hypotheses: one for each recursive call. * * Note. R will never occur as a variable in the ind_clause, because * to do so, it would have to be from a nested definition, and we don't * allow nested defns to have R variable. * * Note. When the context is empty, there can be no local variables. *---------------------------------------------------------------------------*) local infix 5 ==> fun (tm1 ==> tm2) = USyntax.mk_imp{ant = tm1, conseq = tm2} in fun build_ih f (P,SV) (pat,TCs) = let val pat_vars = USyntax.free_vars_lr pat val globals = pat_vars@SV fun nested tm = is_some (USyntax.find_term (curry (op aconv) f) tm) fun dest_TC tm = let val (cntxt,R_y_pat) = USyntax.strip_imp(#2(USyntax.strip_forall tm)) val (R,y,_) = USyntax.dest_relation R_y_pat val P_y = if (nested tm) then R_y_pat ==> P$y else P$y in case cntxt of [] => (P_y, (tm,[])) | _ => let val imp = USyntax.list_mk_conj cntxt ==> P_y val lvs = subtract (op aconv) globals (USyntax.free_vars_lr imp) val locals = #2(Utils.pluck (curry (op aconv) P) lvs) handle Utils.ERR _ => lvs in (USyntax.list_mk_forall(locals,imp), (tm,locals)) end end in case TCs of [] => (USyntax.list_mk_forall(pat_vars, P$pat), []) | _ => let val (ihs, TCs_locals) = ListPair.unzip(map dest_TC TCs) val ind_clause = USyntax.list_mk_conj ihs ==> P$pat in (USyntax.list_mk_forall(pat_vars,ind_clause), TCs_locals) end end end; (*--------------------------------------------------------------------------- * This function makes good on the promise made in "build_ih". * * Input is tm = "(!y. R y pat ==> P y) ==> P pat", * TCs = TC_1[pat] ... TC_n[pat] * thm = ih1 /\ ... /\ ih_n |- ih[pat] *---------------------------------------------------------------------------*) fun prove_case ctxt f (tm,TCs_locals,thm) = let val tych = Thry.typecheck (Proof_Context.theory_of ctxt) val antc = tych(#ant(USyntax.dest_imp tm)) val thm' = Rules.SPEC_ALL thm fun nested tm = is_some (USyntax.find_term (curry (op aconv) f) tm) fun get_cntxt TC = tych(#ant(USyntax.dest_imp(#2(USyntax.strip_forall(concl TC))))) fun mk_ih ((TC,locals),th2,nested) = Rules.GENL ctxt (map tych locals) (if nested then Rules.DISCH (get_cntxt TC) th2 handle Utils.ERR _ => th2 else if USyntax.is_imp (concl TC) then Rules.IMP_TRANS TC th2 else Rules.MP th2 TC) in Rules.DISCH antc (if USyntax.is_imp(concl thm') (* recursive calls in this clause *) then let val th1 = Rules.ASSUME antc val TCs = map #1 TCs_locals val ylist = map (#2 o USyntax.dest_relation o #2 o USyntax.strip_imp o #2 o USyntax.strip_forall) TCs val TClist = map (fn(TC,lvs) => (Rules.SPEC_ALL(Rules.ASSUME(tych TC)),lvs)) TCs_locals val th2list = map (fn t => Rules.SPEC (tych t) th1) ylist val nlist = map nested TCs val triples = Utils.zip3 TClist th2list nlist val Pylist = map mk_ih triples in Rules.MP thm' (Rules.LIST_CONJ Pylist) end else thm') end; (*--------------------------------------------------------------------------- * * x = (v1,...,vn) |- M[x] * --------------------------------------------- * ?v1 ... vn. x = (v1,...,vn) |- M[x] * *---------------------------------------------------------------------------*) fun LEFT_ABS_VSTRUCT ctxt tych thm = let fun CHOOSER v (tm,thm) = let val ex_tm = USyntax.mk_exists{Bvar=v,Body=tm} in (ex_tm, Rules.CHOOSE ctxt (tych v, Rules.ASSUME (tych ex_tm)) thm) end val [veq] = filter (can USyntax.dest_eq) (#1 (Rules.dest_thm thm)) val {lhs,rhs} = USyntax.dest_eq veq val L = USyntax.free_vars_lr rhs in #2 (fold_rev CHOOSER L (veq,thm)) end; (*---------------------------------------------------------------------------- * Input : f, R, and [(pat1,TCs1),..., (patn,TCsn)] * * Instantiates tfl_wf_induct, getting Sinduct and then tries to prove * recursion induction (Rinduct) by proving the antecedent of Sinduct from * the antecedent of Rinduct. *---------------------------------------------------------------------------*) fun mk_induction ctxt {fconst, R, SV, pat_TCs_list} = let val thy = Proof_Context.theory_of ctxt val tych = Thry.typecheck thy val Sinduction = Rules.UNDISCH (Rules.ISPEC (tych R) @{thm tfl_wf_induct}) val (pats,TCsl) = ListPair.unzip pat_TCs_list val case_thm = complete_cases ctxt pats val domain = (type_of o hd) pats val Pname = singleton (Name.variant_list (List.foldr (Library.foldr Misc_Legacy.add_term_names) [] (pats::TCsl))) "P" val P = Free(Pname, domain --> HOLogic.boolT) val Sinduct = Rules.SPEC (tych P) Sinduction val Sinduct_assumf = USyntax.rand ((#ant o USyntax.dest_imp o concl) Sinduct) val Rassums_TCl' = map (build_ih fconst (P,SV)) pat_TCs_list val (Rassums,TCl') = ListPair.unzip Rassums_TCl' val Rinduct_assum = Rules.ASSUME (tych (USyntax.list_mk_conj Rassums)) val cases = map (fn pat => Term.betapply (Sinduct_assumf, pat)) pats val tasks = Utils.zip3 cases TCl' (Rules.CONJUNCTS Rinduct_assum) val proved_cases = map (prove_case ctxt fconst) tasks val v = Free (singleton (Name.variant_list (List.foldr Misc_Legacy.add_term_names [] (map concl proved_cases))) "v", domain) val vtyped = tych v val substs = map (Rules.SYM o Rules.ASSUME o tych o (curry HOLogic.mk_eq v)) pats val proved_cases1 = ListPair.map (fn (th,th') => Rules.SUBS ctxt [th]th') (substs, proved_cases) val abs_cases = map (LEFT_ABS_VSTRUCT ctxt tych) proved_cases1 val dant = Rules.GEN ctxt vtyped (Rules.DISJ_CASESL (Rules.ISPEC vtyped case_thm) abs_cases) val dc = Rules.MP Sinduct dant val Parg_ty = type_of(#Bvar(USyntax.dest_forall(concl dc))) val vars = map (gvvariant[Pname]) (USyntax.strip_prod_type Parg_ty) val dc' = fold_rev (Rules.GEN ctxt o tych) vars (Rules.SPEC (tych(USyntax.mk_vstruct Parg_ty vars)) dc) in Rules.GEN ctxt (tych P) (Rules.DISCH (tych(concl Rinduct_assum)) dc') end handle Utils.ERR _ => raise TFL_ERR "mk_induction" "failed derivation"; (*--------------------------------------------------------------------------- * * POST PROCESSING * *---------------------------------------------------------------------------*) fun simplify_induction thy hth ind = let val tych = Thry.typecheck thy val (asl,_) = Rules.dest_thm ind val (_,tc_eq_tc') = Rules.dest_thm hth val tc = USyntax.lhs tc_eq_tc' fun loop [] = ind | loop (asm::rst) = if (can (Thry.match_term thy asm) tc) then Rules.UNDISCH (Rules.MATCH_MP (Rules.MATCH_MP @{thm tfl_simp_thm} (Rules.DISCH (tych asm) ind)) hth) else loop rst in loop asl end; (*--------------------------------------------------------------------------- * The termination condition is an antecedent to the rule, and an * assumption to the theorem. *---------------------------------------------------------------------------*) fun elim_tc tcthm (rule,induction) = (Rules.MP rule tcthm, Rules.PROVE_HYP tcthm induction) fun trace_thms ctxt s L = if !trace then writeln (cat_lines (s :: map (Thm.string_of_thm ctxt) L)) else (); fun trace_cterm ctxt s ct = if !trace then writeln (cat_lines [s, Syntax.string_of_term ctxt (Thm.term_of ct)]) else (); fun postprocess ctxt strict {wf_tac, terminator, simplifier} {rules,induction,TCs} = let val thy = Proof_Context.theory_of ctxt; val tych = Thry.typecheck thy; (*--------------------------------------------------------------------- * Attempt to eliminate WF condition. It's the only assumption of rules *---------------------------------------------------------------------*) val (rules1,induction1) = let val thm = Rules.prove ctxt strict (HOLogic.mk_Trueprop (hd(#1(Rules.dest_thm rules))), wf_tac) in (Rules.PROVE_HYP thm rules, Rules.PROVE_HYP thm induction) end handle Utils.ERR _ => (rules,induction); (*---------------------------------------------------------------------- * The termination condition (tc) is simplified to |- tc = tc' (there * might not be a change!) and then 3 attempts are made: * * 1. if |- tc = T, then eliminate it with tfl_eq_True; otherwise, * 2. apply the terminator to tc'. If |- tc' = T then eliminate; else * 3. replace tc by tc' in both the rules and the induction theorem. *---------------------------------------------------------------------*) fun simplify_tc tc (r,ind) = let val tc1 = tych tc val _ = trace_cterm ctxt "TC before simplification: " tc1 val tc_eq = simplifier tc1 val _ = trace_thms ctxt "result: " [tc_eq] in elim_tc (Rules.MATCH_MP @{thm tfl_eq_True} tc_eq) (r,ind) handle Utils.ERR _ => (elim_tc (Rules.MATCH_MP(Rules.MATCH_MP @{thm tfl_rev_eq_mp} tc_eq) (Rules.prove ctxt strict (HOLogic.mk_Trueprop(USyntax.rhs(concl tc_eq)), terminator))) (r,ind) handle Utils.ERR _ => (Rules.UNDISCH(Rules.MATCH_MP (Rules.MATCH_MP @{thm tfl_simp_thm} r) tc_eq), simplify_induction thy tc_eq ind)) end (*---------------------------------------------------------------------- * Nested termination conditions are harder to get at, since they are * left embedded in the body of the function (and in induction * theorem hypotheses). Our "solution" is to simplify them, and try to * prove termination, but leave the application of the resulting theorem * to a higher level. So things go much as in "simplify_tc": the * termination condition (tc) is simplified to |- tc = tc' (there might * not be a change) and then 2 attempts are made: * * 1. if |- tc = T, then return |- tc; otherwise, * 2. apply the terminator to tc'. If |- tc' = T then return |- tc; else * 3. return |- tc = tc' *---------------------------------------------------------------------*) fun simplify_nested_tc tc = let val tc_eq = simplifier (tych (#2 (USyntax.strip_forall tc))) in Rules.GEN_ALL ctxt (Rules.MATCH_MP @{thm tfl_eq_True} tc_eq handle Utils.ERR _ => (Rules.MATCH_MP(Rules.MATCH_MP @{thm tfl_rev_eq_mp} tc_eq) (Rules.prove ctxt strict (HOLogic.mk_Trueprop (USyntax.rhs(concl tc_eq)), terminator)) handle Utils.ERR _ => tc_eq)) end (*------------------------------------------------------------------- * Attempt to simplify the termination conditions in each rule and * in the induction theorem. *-------------------------------------------------------------------*) fun strip_imp tm = if USyntax.is_neg tm then ([],tm) else USyntax.strip_imp tm fun loop ([],extras,R,ind) = (rev R, ind, extras) | loop ((r,ftcs)::rst, nthms, R, ind) = let val tcs = #1(strip_imp (concl r)) val extra_tcs = subtract (op aconv) tcs ftcs val extra_tc_thms = map simplify_nested_tc extra_tcs val (r1,ind1) = fold simplify_tc tcs (r,ind) val r2 = Rules.FILTER_DISCH_ALL(not o USyntax.is_WFR) r1 in loop(rst, nthms@extra_tc_thms, r2::R, ind1) end val rules_tcs = ListPair.zip (Rules.CONJUNCTS rules1, TCs) val (rules2,ind2,extras) = loop(rules_tcs,[],[],induction1) in {induction = ind2, rules = Rules.LIST_CONJ rules2, nested_tcs = extras} end; end; (*** second part of main module (postprocessing of TFL definitions) ***) structure Tfl: TFL = struct (* misc *) (*--------------------------------------------------------------------------- * Extract termination goals so that they can be put it into a goalstack, or * have a tactic directly applied to them. *--------------------------------------------------------------------------*) fun termination_goals rules = map (Type.legacy_freeze o HOLogic.dest_Trueprop) (fold_rev (union (op aconv) o Thm.prems_of) rules []); (*--------------------------------------------------------------------------- * Three postprocessors are applied to the definition. It * attempts to prove wellfoundedness of the given relation, simplifies the * non-proved termination conditions, and finally attempts to prove the * simplified termination conditions. *--------------------------------------------------------------------------*) fun std_postprocessor ctxt strict wfs = Prim.postprocess ctxt strict {wf_tac = REPEAT (ares_tac ctxt wfs 1), terminator = asm_simp_tac ctxt 1 THEN TRY (Arith_Data.arith_tac ctxt 1 ORELSE fast_force_tac (ctxt addSDs @{thms not0_implies_Suc}) 1), simplifier = Rules.simpl_conv ctxt []}; val concl = #2 o Rules.dest_thm; (*--------------------------------------------------------------------------- * Postprocess a definition made by "define". This is a separate stage of * processing from the definition stage. *---------------------------------------------------------------------------*) local (* The rest of these local definitions are for the tricky nested case *) val solved = not o can USyntax.dest_eq o #2 o USyntax.strip_forall o concl fun id_thm th = let val {lhs,rhs} = USyntax.dest_eq (#2 (USyntax.strip_forall (#2 (Rules.dest_thm th)))); in lhs aconv rhs end handle Utils.ERR _ => false; val P_imp_P_eq_True = @{thm eqTrueI} RS eq_reflection; fun mk_meta_eq r = (case Thm.concl_of r of Const(\<^const_name>\Pure.eq\,_)$_$_ => r | _ $(Const(\<^const_name>\HOL.eq\,_)$_$_) => r RS eq_reflection | _ => r RS P_imp_P_eq_True) (*Is this the best way to invoke the simplifier??*) fun rewrite ctxt L = rewrite_rule ctxt (map mk_meta_eq (filter_out id_thm L)) fun join_assums ctxt th = let val tych = Thm.cterm_of ctxt val {lhs,rhs} = USyntax.dest_eq(#2 (USyntax.strip_forall (concl th))) val cntxtl = (#1 o USyntax.strip_imp) lhs (* cntxtl should = cntxtr *) val cntxtr = (#1 o USyntax.strip_imp) rhs (* but union is solider *) val cntxt = union (op aconv) cntxtl cntxtr in Rules.GEN_ALL ctxt (Rules.DISCH_ALL (rewrite ctxt (map (Rules.ASSUME o tych) cntxt) (Rules.SPEC_ALL th))) end val gen_all = USyntax.gen_all in fun proof_stage ctxt strict wfs {f, R, rules, full_pats_TCs, TCs} = let val _ = writeln "Proving induction theorem ..." val ind = Prim.mk_induction ctxt {fconst=f, R=R, SV=[], pat_TCs_list=full_pats_TCs} val _ = writeln "Postprocessing ..."; val {rules, induction, nested_tcs} = std_postprocessor ctxt strict wfs {rules=rules, induction=ind, TCs=TCs} in case nested_tcs of [] => {induction=induction, rules=rules,tcs=[]} | L => let val _ = writeln "Simplifying nested TCs ..." val (solved,simplified,stubborn) = fold_rev (fn th => fn (So,Si,St) => if (id_thm th) then (So, Si, th::St) else if (solved th) then (th::So, Si, St) else (So, th::Si, St)) nested_tcs ([],[],[]) val simplified' = map (join_assums ctxt) simplified val dummy = (Prim.trace_thms ctxt "solved =" solved; Prim.trace_thms ctxt "simplified' =" simplified') val rewr = full_simplify (ctxt addsimps (solved @ simplified')); val dummy = Prim.trace_thms ctxt "Simplifying the induction rule..." [induction] val induction' = rewr induction val dummy = Prim.trace_thms ctxt "Simplifying the recursion rules..." [rules] val rules' = rewr rules val _ = writeln "... Postprocessing finished"; in {induction = induction', rules = rules', tcs = map (gen_all o USyntax.rhs o #2 o USyntax.strip_forall o concl) (simplified@stubborn)} end end; (*lcp: curry the predicate of the induction rule*) fun curry_rule ctxt rl = Split_Rule.split_rule_var ctxt (Term.head_of (HOLogic.dest_Trueprop (Thm.concl_of rl))) rl; (*lcp: put a theorem into Isabelle form, using meta-level connectives*) fun meta_outer ctxt = curry_rule ctxt o Drule.export_without_context o rule_by_tactic ctxt (REPEAT (FIRSTGOAL (resolve_tac ctxt [allI, impI, conjI] ORELSE' eresolve_tac ctxt [conjE]))); (*Strip off the outer !P*) val spec'= Rule_Insts.read_instantiate \<^context> [((("x", 0), Position.none), "P::'b=>bool")] [] spec; fun simplify_defn ctxt strict congs wfs pats def0 = let val thy = Proof_Context.theory_of ctxt; val def = HOLogic.mk_obj_eq (Thm.unvarify_global thy def0) val {rules, rows, TCs, full_pats_TCs} = Prim.post_definition ctxt congs (def, pats) val {lhs=f,rhs} = USyntax.dest_eq (concl def) val (_,[R,_]) = USyntax.strip_comb rhs val _ = Prim.trace_thms ctxt "congs =" congs (*the next step has caused simplifier looping in some cases*) val {induction, rules, tcs} = proof_stage ctxt strict wfs {f = f, R = R, rules = rules, full_pats_TCs = full_pats_TCs, TCs = TCs} val rules' = map (Drule.export_without_context o Object_Logic.rulify_no_asm ctxt) (Rules.CONJUNCTS rules) in {induct = meta_outer ctxt (Object_Logic.rulify_no_asm ctxt (induction RS spec')), rules = ListPair.zip(rules', rows), tcs = (termination_goals rules') @ tcs} end handle Utils.ERR {mesg,func,module} => error (mesg ^ "\n (In TFL function " ^ module ^ "." ^ func ^ ")"); (* Derive the initial equations from the case-split rules to meet the users specification of the recursive function. *) local fun get_related_thms i = map_filter ((fn (r,x) => if x = i then SOME r else NONE)); fun solve_eq _ (_, [], _) = error "derive_init_eqs: missing rules" | solve_eq _ (_, [a], i) = [(a, i)] | solve_eq ctxt (th, splitths, i) = (writeln "Proving unsplit equation..."; [((Drule.export_without_context o Object_Logic.rulify_no_asm ctxt) (CaseSplit.splitto ctxt splitths th), i)]) handle ERROR s => (warning ("recdef (solve_eq): " ^ s); map (fn x => (x,i)) splitths); in fun derive_init_eqs ctxt rules eqs = map (Thm.trivial o Thm.cterm_of ctxt o HOLogic.mk_Trueprop) eqs |> map_index (fn (i, e) => solve_eq ctxt (e, (get_related_thms i rules), i)) |> flat; end; (*--------------------------------------------------------------------------- * Defining a function with an associated termination relation. *---------------------------------------------------------------------------*) fun define_i strict congs wfs fid R eqs ctxt = let val thy = Proof_Context.theory_of ctxt val {functional, pats} = Prim.mk_functional thy eqs val (def, thy') = Prim.wfrec_definition0 fid R functional thy val ctxt' = Proof_Context.transfer thy' ctxt val (lhs, _) = Logic.dest_equals (Thm.prop_of def) val {induct, rules, tcs} = simplify_defn ctxt' strict congs wfs pats def val rules' = if strict then derive_init_eqs ctxt' rules eqs else rules in ({lhs = lhs, rules = rules', induct = induct, tcs = tcs}, ctxt') end; fun define strict congs wfs fid R seqs ctxt = define_i strict congs wfs fid (Syntax.read_term ctxt R) (map (Syntax.read_term ctxt) seqs) ctxt handle Utils.ERR {mesg,...} => error mesg; end; end; (*** wrappers for Isar ***) (** recdef hints **) (* type hints *) type hints = {simps: thm list, congs: (string * thm) list, wfs: thm list}; fun mk_hints (simps, congs, wfs) = {simps = simps, congs = congs, wfs = wfs}: hints; fun map_hints f ({simps, congs, wfs}: hints) = mk_hints (f (simps, congs, wfs)); fun map_simps f = map_hints (fn (simps, congs, wfs) => (f simps, congs, wfs)); fun map_congs f = map_hints (fn (simps, congs, wfs) => (simps, f congs, wfs)); fun map_wfs f = map_hints (fn (simps, congs, wfs) => (simps, congs, f wfs)); (* congruence rules *) local val cong_head = fst o Term.dest_Const o Term.head_of o fst o Logic.dest_equals o Thm.concl_of; fun prep_cong raw_thm = let val thm = safe_mk_meta_eq raw_thm in (cong_head thm, thm) end; in fun add_cong raw_thm congs = let val (c, thm) = prep_cong raw_thm; val _ = if AList.defined (op =) congs c then warning ("Overwriting recdef congruence rule for " ^ quote c) else (); in AList.update (op =) (c, thm) congs end; fun del_cong raw_thm congs = let val (c, _) = prep_cong raw_thm; val _ = if AList.defined (op =) congs c then () else warning ("No recdef congruence rule for " ^ quote c); in AList.delete (op =) c congs end; end; (** global and local recdef data **) (* theory data *) type recdef_info = {lhs: term, simps: thm list, rules: thm list list, induct: thm, tcs: term list}; structure Data = Generic_Data ( type T = recdef_info Symtab.table * hints; val empty = (Symtab.empty, mk_hints ([], [], [])): T; val extend = I; fun merge ((tab1, {simps = simps1, congs = congs1, wfs = wfs1}), (tab2, {simps = simps2, congs = congs2, wfs = wfs2})) : T = (Symtab.merge (K true) (tab1, tab2), mk_hints (Thm.merge_thms (simps1, simps2), AList.merge (op =) (K true) (congs1, congs2), Thm.merge_thms (wfs1, wfs2))); ); val get_recdef = Symtab.lookup o #1 o Data.get o Context.Theory; fun put_recdef name info = (Context.theory_map o Data.map o apfst) (fn tab => Symtab.update_new (name, info) tab handle Symtab.DUP _ => error ("Duplicate recursive function definition " ^ quote name)); val get_hints = #2 o Data.get o Context.Proof; val map_hints = Data.map o apsnd; (* attributes *) fun attrib f = Thm.declaration_attribute (map_hints o f); val simp_add = attrib (map_simps o Thm.add_thm); val simp_del = attrib (map_simps o Thm.del_thm); val cong_add = attrib (map_congs o add_cong); val cong_del = attrib (map_congs o del_cong); val wf_add = attrib (map_wfs o Thm.add_thm); val wf_del = attrib (map_wfs o Thm.del_thm); (* modifiers *) val recdef_simpN = "recdef_simp"; val recdef_congN = "recdef_cong"; val recdef_wfN = "recdef_wf"; val recdef_modifiers = [Args.$$$ recdef_simpN -- Args.colon >> K (Method.modifier simp_add \<^here>), Args.$$$ recdef_simpN -- Args.add -- Args.colon >> K (Method.modifier simp_add \<^here>), Args.$$$ recdef_simpN -- Args.del -- Args.colon >> K (Method.modifier simp_del \<^here>), Args.$$$ recdef_congN -- Args.colon >> K (Method.modifier cong_add \<^here>), Args.$$$ recdef_congN -- Args.add -- Args.colon >> K (Method.modifier cong_add \<^here>), Args.$$$ recdef_congN -- Args.del -- Args.colon >> K (Method.modifier cong_del \<^here>), Args.$$$ recdef_wfN -- Args.colon >> K (Method.modifier wf_add \<^here>), Args.$$$ recdef_wfN -- Args.add -- Args.colon >> K (Method.modifier wf_add \<^here>), Args.$$$ recdef_wfN -- Args.del -- Args.colon >> K (Method.modifier wf_del \<^here>)] @ Clasimp.clasimp_modifiers; (** prepare hints **) fun prepare_hints opt_src ctxt = let val ctxt' = (case opt_src of NONE => ctxt | SOME src => #2 (Token.syntax (Method.sections recdef_modifiers) src ctxt)); val {simps, congs, wfs} = get_hints ctxt'; val ctxt'' = ctxt' addsimps simps |> Simplifier.del_cong @{thm imp_cong}; in ((rev (map snd congs), wfs), ctxt'') end; fun prepare_hints_i () ctxt = let val {simps, congs, wfs} = get_hints ctxt; val ctxt' = ctxt addsimps simps |> Simplifier.del_cong @{thm imp_cong}; in ((rev (map snd congs), wfs), ctxt') end; (** add_recdef(_i) **) fun gen_add_recdef tfl_fn prep_att prep_hints not_permissive raw_name R eq_srcs hints thy = let val _ = legacy_feature "Old 'recdef' command -- use 'fun' or 'function' instead"; val name = Sign.intern_const thy raw_name; val bname = Long_Name.base_name name; val _ = writeln ("Defining recursive function " ^ quote name ^ " ..."); val ((eq_names, eqs), raw_eq_atts) = apfst split_list (split_list eq_srcs); val eq_atts = map (map (prep_att thy)) raw_eq_atts; val ((congs, wfs), ctxt) = prep_hints hints (Proof_Context.init_global thy); (*We must remove imp_cong to prevent looping when the induction rule is simplified. Many induction rules have nested implications that would give rise to looping conditional rewriting.*) val ({lhs, rules = rules_idx, induct, tcs}, ctxt1) = tfl_fn not_permissive congs wfs name R eqs ctxt; val rules = (map o map) fst (partition_eq (eq_snd (op = : int * int -> bool)) rules_idx); val simp_att = if null tcs then [Simplifier.simp_add, Named_Theorems.add \<^named_theorems>\nitpick_simp\] else []; val ((simps' :: rules', [induct']), thy2) = Proof_Context.theory_of ctxt1 |> Sign.add_path bname |> Global_Theory.add_thmss (((Binding.name "simps", flat rules), simp_att) :: ((eq_names ~~ rules) ~~ eq_atts)) ||>> Global_Theory.add_thms [((Binding.name "induct", induct), [])] - ||> Spec_Rules.add_global Spec_Rules.equational_recdef ([lhs], flat rules) + ||> Spec_Rules.add_global name Spec_Rules.equational_recdef [lhs] (flat rules) ||> null tcs ? Code.declare_default_eqns_global (map (rpair true) (flat rules)); val result = {lhs = lhs, simps = simps', rules = rules', induct = induct', tcs = tcs}; val thy3 = thy2 |> put_recdef name result |> Sign.parent_path; in (thy3, result) end; val add_recdef = gen_add_recdef Tfl.define Attrib.attribute_cmd_global prepare_hints; fun add_recdef_i x y z w = gen_add_recdef Tfl.define_i (K I) prepare_hints_i x y z w (); (** package setup **) (* setup theory *) val _ = Theory.setup (Attrib.setup \<^binding>\recdef_simp\ (Attrib.add_del simp_add simp_del) "declaration of recdef simp rule" #> Attrib.setup \<^binding>\recdef_cong\ (Attrib.add_del cong_add cong_del) "declaration of recdef cong rule" #> Attrib.setup \<^binding>\recdef_wf\ (Attrib.add_del wf_add wf_del) "declaration of recdef wf rule"); (* outer syntax *) val hints = \<^keyword>\(\ |-- Parse.!!! ((Parse.token \<^keyword>\hints\ ::: Parse.args) --| \<^keyword>\)\); val recdef_decl = Scan.optional (\<^keyword>\(\ -- Parse.!!! (\<^keyword>\permissive\ -- \<^keyword>\)\) >> K false) true -- Parse.name -- Parse.term -- Scan.repeat1 (Parse_Spec.opt_thm_name ":" -- Parse.prop) -- Scan.option hints >> (fn ((((p, f), R), eqs), src) => #1 o add_recdef p f R (map (fn ((x, y), z) => ((x, z), y)) eqs) src); val _ = Outer_Syntax.command \<^command_keyword>\recdef\ "define general recursive functions (obsolete TFL)" (recdef_decl >> Toplevel.theory); end; diff --git a/src/HOL/Tools/BNF/bnf_fp_def_sugar.ML b/src/HOL/Tools/BNF/bnf_fp_def_sugar.ML --- a/src/HOL/Tools/BNF/bnf_fp_def_sugar.ML +++ b/src/HOL/Tools/BNF/bnf_fp_def_sugar.ML @@ -1,2927 +1,2927 @@ (* Title: HOL/Tools/BNF/bnf_fp_def_sugar.ML Author: Jasmin Blanchette, TU Muenchen Author: Martin Desharnais, TU Muenchen Copyright 2012, 2013, 2014 Sugared datatype and codatatype constructions. *) signature BNF_FP_DEF_SUGAR = sig type fp_ctr_sugar = {ctrXs_Tss: typ list list, ctor_iff_dtor: thm, ctr_defs: thm list, ctr_sugar: Ctr_Sugar.ctr_sugar, ctr_transfers: thm list, case_transfers: thm list, disc_transfers: thm list, sel_transfers: thm list} type fp_bnf_sugar = {map_thms: thm list, map_disc_iffs: thm list, map_selss: thm list list, rel_injects: thm list, rel_distincts: thm list, rel_sels: thm list, rel_intros: thm list, rel_cases: thm list, pred_injects: thm list, set_thms: thm list, set_selssss: thm list list list list, set_introssss: thm list list list list, set_cases: thm list} type fp_co_induct_sugar = {co_rec: term, common_co_inducts: thm list, co_inducts: thm list, co_rec_def: thm, co_rec_thms: thm list, co_rec_discs: thm list, co_rec_disc_iffs: thm list, co_rec_selss: thm list list, co_rec_codes: thm list, co_rec_transfers: thm list, co_rec_o_maps: thm list, common_rel_co_inducts: thm list, rel_co_inducts: thm list, common_set_inducts: thm list, set_inducts: thm list} type fp_sugar = {T: typ, BT: typ, X: typ, fp: BNF_Util.fp_kind, fp_res_index: int, fp_res: BNF_FP_Util.fp_result, pre_bnf: BNF_Def.bnf, fp_bnf: BNF_Def.bnf, absT_info: BNF_Comp.absT_info, fp_nesting_bnfs: BNF_Def.bnf list, live_nesting_bnfs: BNF_Def.bnf list, fp_ctr_sugar: fp_ctr_sugar, fp_bnf_sugar: fp_bnf_sugar, fp_co_induct_sugar: fp_co_induct_sugar option} val co_induct_of: 'a list -> 'a val strong_co_induct_of: 'a list -> 'a val morph_fp_bnf_sugar: morphism -> fp_bnf_sugar -> fp_bnf_sugar val morph_fp_co_induct_sugar: morphism -> fp_co_induct_sugar -> fp_co_induct_sugar val morph_fp_ctr_sugar: morphism -> fp_ctr_sugar -> fp_ctr_sugar val morph_fp_sugar: morphism -> fp_sugar -> fp_sugar val transfer_fp_sugar: theory -> fp_sugar -> fp_sugar val fp_sugar_of: Proof.context -> string -> fp_sugar option val fp_sugar_of_global: theory -> string -> fp_sugar option val fp_sugars_of: Proof.context -> fp_sugar list val fp_sugars_of_global: theory -> fp_sugar list val fp_sugars_interpretation: string -> (fp_sugar list -> local_theory -> local_theory) -> theory -> theory val interpret_fp_sugars: (string -> bool) -> fp_sugar list -> local_theory -> local_theory val register_fp_sugars_raw: fp_sugar list -> local_theory -> local_theory val register_fp_sugars: (string -> bool) -> fp_sugar list -> local_theory -> local_theory val merge_type_args: BNF_Util.fp_kind -> ''a list * ''a list -> ''a list val type_args_named_constrained_of_spec: (((('a * 'b) * 'c) * 'd) * 'e) * 'f -> 'a val type_binding_of_spec: (((('a * 'b) * 'c) * 'd) * 'e) * 'f -> 'b val mixfix_of_spec: ((('a * 'b) * 'c) * 'd) * 'e -> 'b val mixfixed_ctr_specs_of_spec: (('a * 'b) * 'c) * 'd -> 'b val map_binding_of_spec: ('a * ('b * 'c * 'd)) * 'e -> 'b val rel_binding_of_spec: ('a * ('b * 'c * 'd)) * 'e -> 'c val pred_binding_of_spec: ('a * ('b * 'c * 'd)) * 'e -> 'd val sel_default_eqs_of_spec: 'a * 'b -> 'b val mk_parametricity_goal: Proof.context -> term list -> term -> term -> term val flat_corec_preds_predsss_gettersss: 'a list -> 'a list list list -> 'a list list list -> 'a list val mk_ctor: typ list -> term -> term val mk_dtor: typ list -> term -> term val mk_bnf_sets: BNF_Def.bnf -> string * term list val liveness_of_fp_bnf: int -> BNF_Def.bnf -> bool list val nesting_bnfs: Proof.context -> typ list list list -> typ list -> BNF_Def.bnf list val massage_simple_notes: string -> (bstring * 'a list * (int -> 'b)) list -> ((binding * 'c list) * ('a list * 'b) list) list val massage_multi_notes: string list -> typ list -> (string * 'a list list * (string -> 'b)) list -> ((binding * 'b) * ('a list * 'c list) list) list val define_ctrs_dtrs_for_type: string -> typ -> term -> term -> thm -> thm -> int -> int list -> term -> binding list -> mixfix list -> typ list list -> local_theory -> (term list list * term list * thm * thm list) * local_theory val wrap_ctrs: (string -> bool) -> BNF_Util.fp_kind -> bool -> string -> thm -> int -> int list -> thm -> thm -> binding list -> binding list list -> term list -> term list -> thm -> thm list -> local_theory -> Ctr_Sugar.ctr_sugar * local_theory val derive_map_set_rel_pred_thms: (string -> bool) -> BNF_Util.fp_kind -> int -> typ list -> typ list -> typ -> typ -> thm list -> thm list -> thm list -> thm list -> thm list -> thm list -> thm list -> thm list -> thm list -> string -> BNF_Def.bnf -> BNF_Def.bnf list -> typ -> term -> thm -> thm -> thm -> thm list -> thm -> thm -> thm list -> thm -> thm list -> thm list -> thm list -> typ list list -> Ctr_Sugar.ctr_sugar -> local_theory -> (thm list * thm list * thm list list * thm list * thm list * thm list * thm list * thm list * thm list * thm list * thm list list list list * thm list list list list * thm list * thm list * thm list * thm list * thm list) * local_theory type lfp_sugar_thms = (thm list * thm * Token.src list) * (thm list list * Token.src list) val morph_lfp_sugar_thms: morphism -> lfp_sugar_thms -> lfp_sugar_thms val transfer_lfp_sugar_thms: theory -> lfp_sugar_thms -> lfp_sugar_thms type gfp_sugar_thms = ((thm list * thm) list * (Token.src list * Token.src list)) * thm list list * thm list list * (thm list list * Token.src list) * (thm list list list * Token.src list) val morph_gfp_sugar_thms: morphism -> gfp_sugar_thms -> gfp_sugar_thms val transfer_gfp_sugar_thms: theory -> gfp_sugar_thms -> gfp_sugar_thms val mk_co_recs_prelims: Proof.context -> BNF_Util.fp_kind -> typ list list list -> typ list -> typ list -> typ list -> typ list -> int list -> int list list -> term list -> term list * (typ list list * typ list list list list * term list list * term list list list list) option * (string * term list * term list list * (((term list list * term list list * term list list list list * term list list list list) * term list list list) * typ list)) option val repair_nullary_single_ctr: typ list list -> typ list list val mk_corec_p_pred_types: typ list -> int list -> typ list list val mk_corec_fun_arg_types: typ list list list -> typ list -> typ list -> typ list -> int list -> int list list -> term -> typ list list * (typ list list list list * typ list list list * typ list list list list * typ list) val define_co_rec_as: BNF_Util.fp_kind -> typ list -> typ -> binding -> term -> local_theory -> (term * thm) * local_theory val define_rec: typ list list * typ list list list list * term list list * term list list list list -> (string -> binding) -> typ list -> typ list -> term list -> term -> Proof.context -> (term * thm) * Proof.context val define_corec: 'a * term list * term list list * (((term list list * term list list * term list list list list * term list list list list) * term list list list) * typ list) -> (string -> binding) -> 'b list -> typ list -> term list -> term -> local_theory -> (term * thm) * local_theory val mk_induct_raw_prem: (term -> term) -> Proof.context -> typ list list -> (string * term list) list -> term -> term -> typ list -> typ list -> term list * ((term * (term * term)) list * (int * term)) list * term val finish_induct_prem: Proof.context -> int -> term list -> term list * ((term * (term * term)) list * (int * term)) list * term -> term val mk_coinduct_prem: Proof.context -> typ list list -> typ list list -> term list -> term -> term -> term -> int -> term list -> term list list -> term list -> term list list -> typ list list -> term val mk_induct_attrs: term list list -> Token.src list val mk_coinduct_attrs: typ list -> term list list -> term list list -> int list list -> Token.src list * Token.src list val derive_induct_recs_thms_for_types: (string -> bool) -> BNF_Def.bnf list -> ('a * typ list list list list * term list list * 'b) option -> thm -> thm list -> BNF_Def.bnf list -> BNF_Def.bnf list -> typ list -> typ list -> typ list -> typ list list list -> thm list -> thm list -> thm list -> term list list -> thm list list -> term list -> thm list -> Proof.context -> lfp_sugar_thms val derive_coinduct_thms_for_types: Proof.context -> bool -> (term -> term) -> BNF_Def.bnf list -> thm -> thm list -> BNF_Def.bnf list -> typ list -> typ list -> typ list list list -> int list -> thm list -> thm list -> (thm -> thm) -> thm list list -> Ctr_Sugar.ctr_sugar list -> (thm list * thm) list val derive_coinduct_corecs_thms_for_types: Proof.context -> BNF_Def.bnf list -> string * term list * term list list * (((term list list * term list list * term list list list list * term list list list list) * term list list list) * typ list) -> thm -> thm list -> thm list -> thm list -> BNF_Def.bnf list -> typ list -> typ list -> typ list -> typ list list list -> int list list -> int list list -> int list -> thm list -> thm list -> (thm -> thm) -> thm list list -> Ctr_Sugar.ctr_sugar list -> term list -> thm list -> gfp_sugar_thms val co_datatypes: BNF_Util.fp_kind -> (mixfix list -> binding list -> binding list -> binding list -> binding list list -> binding list -> (string * sort) list -> typ list * typ list list -> BNF_Def.bnf list -> BNF_Comp.absT_info list -> local_theory -> BNF_FP_Util.fp_result * local_theory) -> Ctr_Sugar.ctr_options * ((((((binding option * (typ * sort)) list * binding) * mixfix) * ((binding, binding * typ) Ctr_Sugar.ctr_spec * mixfix) list) * (binding * binding * binding)) * term list) list -> local_theory -> local_theory val co_datatype_cmd: BNF_Util.fp_kind -> (mixfix list -> binding list -> binding list -> binding list -> binding list list -> binding list -> (string * sort) list -> typ list * typ list list -> BNF_Def.bnf list -> BNF_Comp.absT_info list -> local_theory -> BNF_FP_Util.fp_result * Proof.context) -> ((Proof.context -> Plugin_Name.filter) * bool) * ((((((binding option * (string * string option)) list * binding) * mixfix) * ((binding, binding * string) Ctr_Sugar.ctr_spec * mixfix) list) * (binding * binding * binding)) * string list) list -> Proof.context -> local_theory val parse_ctr_arg: (binding * string) parser val parse_ctr_specs: ((binding, binding * string) Ctr_Sugar.ctr_spec * mixfix) list parser val parse_spec: ((((((binding option * (string * string option)) list * binding) * mixfix) * ((binding, binding * string) Ctr_Sugar.ctr_spec * mixfix) list) * (binding * binding * binding)) * string list) parser val parse_co_datatype: (Ctr_Sugar.ctr_options_cmd * ((((((binding option * (string * string option)) list * binding) * mixfix) * ((binding, binding * string) Ctr_Sugar.ctr_spec * mixfix) list) * (binding * binding * binding)) * string list) list) parser val parse_co_datatype_cmd: BNF_Util.fp_kind -> (mixfix list -> binding list -> binding list -> binding list -> binding list list -> binding list -> (string * sort) list -> typ list * typ list list -> BNF_Def.bnf list -> BNF_Comp.absT_info list -> local_theory -> BNF_FP_Util.fp_result * local_theory) -> (local_theory -> local_theory) parser end; structure BNF_FP_Def_Sugar : BNF_FP_DEF_SUGAR = struct open Ctr_Sugar open BNF_FP_Rec_Sugar_Util open BNF_Util open BNF_Comp open BNF_Def open BNF_FP_Util open BNF_FP_Def_Sugar_Tactics val Eq_prefix = "Eq_"; val case_transferN = "case_transfer"; val ctor_iff_dtorN = "ctor_iff_dtor"; val ctr_transferN = "ctr_transfer"; val disc_transferN = "disc_transfer"; val sel_transferN = "sel_transfer"; val corec_codeN = "corec_code"; val corec_transferN = "corec_transfer"; val map_disc_iffN = "map_disc_iff"; val map_o_corecN = "map_o_corec"; val map_selN = "map_sel"; val pred_injectN = "pred_inject"; val rec_o_mapN = "rec_o_map"; val rec_transferN = "rec_transfer"; val set0N = "set0"; val set_casesN = "set_cases"; val set_introsN = "set_intros"; val set_inductN = "set_induct"; val set_selN = "set_sel"; type fp_ctr_sugar = {ctrXs_Tss: typ list list, ctor_iff_dtor: thm, ctr_defs: thm list, ctr_sugar: Ctr_Sugar.ctr_sugar, ctr_transfers: thm list, case_transfers: thm list, disc_transfers: thm list, sel_transfers: thm list}; type fp_bnf_sugar = {map_thms: thm list, map_disc_iffs: thm list, map_selss: thm list list, rel_injects: thm list, rel_distincts: thm list, rel_sels: thm list, rel_intros: thm list, rel_cases: thm list, pred_injects: thm list, set_thms: thm list, set_selssss: thm list list list list, set_introssss: thm list list list list, set_cases: thm list}; type fp_co_induct_sugar = {co_rec: term, common_co_inducts: thm list, co_inducts: thm list, co_rec_def: thm, co_rec_thms: thm list, co_rec_discs: thm list, co_rec_disc_iffs: thm list, co_rec_selss: thm list list, co_rec_codes: thm list, co_rec_transfers: thm list, co_rec_o_maps: thm list, common_rel_co_inducts: thm list, rel_co_inducts: thm list, common_set_inducts: thm list, set_inducts: thm list}; type fp_sugar = {T: typ, BT: typ, X: typ, fp: fp_kind, fp_res_index: int, fp_res: fp_result, pre_bnf: bnf, fp_bnf: bnf, absT_info: absT_info, fp_nesting_bnfs: bnf list, live_nesting_bnfs: bnf list, fp_ctr_sugar: fp_ctr_sugar, fp_bnf_sugar: fp_bnf_sugar, fp_co_induct_sugar: fp_co_induct_sugar option}; fun co_induct_of (i :: _) = i; fun strong_co_induct_of [_, s] = s; fun morph_fp_bnf_sugar phi ({map_thms, map_disc_iffs, map_selss, rel_injects, rel_distincts, rel_sels, rel_intros, rel_cases, pred_injects, set_thms, set_selssss, set_introssss, set_cases} : fp_bnf_sugar) = {map_thms = map (Morphism.thm phi) map_thms, map_disc_iffs = map (Morphism.thm phi) map_disc_iffs, map_selss = map (map (Morphism.thm phi)) map_selss, rel_injects = map (Morphism.thm phi) rel_injects, rel_distincts = map (Morphism.thm phi) rel_distincts, rel_sels = map (Morphism.thm phi) rel_sels, rel_intros = map (Morphism.thm phi) rel_intros, rel_cases = map (Morphism.thm phi) rel_cases, pred_injects = map (Morphism.thm phi) pred_injects, set_thms = map (Morphism.thm phi) set_thms, set_selssss = map (map (map (map (Morphism.thm phi)))) set_selssss, set_introssss = map (map (map (map (Morphism.thm phi)))) set_introssss, set_cases = map (Morphism.thm phi) set_cases}; fun morph_fp_co_induct_sugar phi ({co_rec, common_co_inducts, co_inducts, co_rec_def, co_rec_thms, co_rec_discs, co_rec_disc_iffs, co_rec_selss, co_rec_codes, co_rec_transfers, co_rec_o_maps, common_rel_co_inducts, rel_co_inducts, common_set_inducts, set_inducts} : fp_co_induct_sugar) = {co_rec = Morphism.term phi co_rec, common_co_inducts = map (Morphism.thm phi) common_co_inducts, co_inducts = map (Morphism.thm phi) co_inducts, co_rec_def = Morphism.thm phi co_rec_def, co_rec_thms = map (Morphism.thm phi) co_rec_thms, co_rec_discs = map (Morphism.thm phi) co_rec_discs, co_rec_disc_iffs = map (Morphism.thm phi) co_rec_disc_iffs, co_rec_selss = map (map (Morphism.thm phi)) co_rec_selss, co_rec_codes = map (Morphism.thm phi) co_rec_codes, co_rec_transfers = map (Morphism.thm phi) co_rec_transfers, co_rec_o_maps = map (Morphism.thm phi) co_rec_o_maps, common_rel_co_inducts = map (Morphism.thm phi) common_rel_co_inducts, rel_co_inducts = map (Morphism.thm phi) rel_co_inducts, common_set_inducts = map (Morphism.thm phi) common_set_inducts, set_inducts = map (Morphism.thm phi) set_inducts}; fun morph_fp_ctr_sugar phi ({ctrXs_Tss, ctor_iff_dtor, ctr_defs, ctr_sugar, ctr_transfers, case_transfers, disc_transfers, sel_transfers} : fp_ctr_sugar) = {ctrXs_Tss = map (map (Morphism.typ phi)) ctrXs_Tss, ctor_iff_dtor = Morphism.thm phi ctor_iff_dtor, ctr_defs = map (Morphism.thm phi) ctr_defs, ctr_sugar = morph_ctr_sugar phi ctr_sugar, ctr_transfers = map (Morphism.thm phi) ctr_transfers, case_transfers = map (Morphism.thm phi) case_transfers, disc_transfers = map (Morphism.thm phi) disc_transfers, sel_transfers = map (Morphism.thm phi) sel_transfers}; fun morph_fp_sugar phi ({T, BT, X, fp, fp_res, fp_res_index, pre_bnf, fp_bnf, absT_info, fp_nesting_bnfs, live_nesting_bnfs, fp_ctr_sugar, fp_bnf_sugar, fp_co_induct_sugar} : fp_sugar) = {T = Morphism.typ phi T, BT = Morphism.typ phi BT, X = Morphism.typ phi X, fp = fp, fp_res = morph_fp_result phi fp_res, fp_res_index = fp_res_index, pre_bnf = morph_bnf phi pre_bnf, fp_bnf = morph_bnf phi fp_bnf, absT_info = morph_absT_info phi absT_info, fp_nesting_bnfs = map (morph_bnf phi) fp_nesting_bnfs, live_nesting_bnfs = map (morph_bnf phi) live_nesting_bnfs, fp_ctr_sugar = morph_fp_ctr_sugar phi fp_ctr_sugar, fp_bnf_sugar = morph_fp_bnf_sugar phi fp_bnf_sugar, fp_co_induct_sugar = Option.map (morph_fp_co_induct_sugar phi) fp_co_induct_sugar}; val transfer_fp_sugar = morph_fp_sugar o Morphism.transfer_morphism; structure Data = Generic_Data ( type T = fp_sugar Symtab.table; val empty = Symtab.empty; val extend = I; fun merge data : T = Symtab.merge (K true) data; ); fun fp_sugar_of_generic context = Option.map (transfer_fp_sugar (Context.theory_of context)) o Symtab.lookup (Data.get context); fun fp_sugars_of_generic context = Symtab.fold (cons o transfer_fp_sugar (Context.theory_of context) o snd) (Data.get context) []; val fp_sugar_of = fp_sugar_of_generic o Context.Proof; val fp_sugar_of_global = fp_sugar_of_generic o Context.Theory; val fp_sugars_of = fp_sugars_of_generic o Context.Proof; val fp_sugars_of_global = fp_sugars_of_generic o Context.Theory; structure FP_Sugar_Plugin = Plugin(type T = fp_sugar list); fun fp_sugars_interpretation name f = FP_Sugar_Plugin.interpretation name (fn fp_sugars => fn lthy => f (map (transfer_fp_sugar (Proof_Context.theory_of lthy)) fp_sugars) lthy); val interpret_fp_sugars = FP_Sugar_Plugin.data; val register_fp_sugars_raw = fold (fn fp_sugar as {T = Type (s, _), ...} => Local_Theory.declaration {syntax = false, pervasive = true} (fn phi => Data.map (Symtab.update (s, morph_fp_sugar phi fp_sugar)))); fun register_fp_sugars plugins fp_sugars = register_fp_sugars_raw fp_sugars #> interpret_fp_sugars plugins fp_sugars; fun interpret_bnfs_register_fp_sugars plugins Ts BTs Xs fp pre_bnfs absT_infos fp_nesting_bnfs live_nesting_bnfs fp_res ctrXs_Tsss ctor_iff_dtors ctr_defss ctr_sugars co_recs co_rec_defs map_thmss common_co_inducts co_inductss co_rec_thmss co_rec_discss co_rec_selsss rel_injectss rel_distinctss map_disc_iffss map_selsss rel_selss rel_intross rel_casess pred_injectss set_thmss set_selsssss set_introsssss set_casess ctr_transferss case_transferss disc_transferss sel_transferss co_rec_disc_iffss co_rec_codess co_rec_transferss common_rel_co_inducts rel_co_inductss common_set_inducts set_inductss co_rec_o_mapss noted = let val fp_sugars = map_index (fn (kk, T) => {T = T, BT = nth BTs kk, X = nth Xs kk, fp = fp, fp_res = fp_res, fp_res_index = kk, pre_bnf = nth pre_bnfs kk, absT_info = nth absT_infos kk, fp_bnf = nth (#bnfs fp_res) kk, fp_nesting_bnfs = fp_nesting_bnfs, live_nesting_bnfs = live_nesting_bnfs, fp_ctr_sugar = {ctrXs_Tss = nth ctrXs_Tsss kk, ctor_iff_dtor = nth ctor_iff_dtors kk, ctr_defs = nth ctr_defss kk, ctr_sugar = nth ctr_sugars kk, ctr_transfers = nth ctr_transferss kk, case_transfers = nth case_transferss kk, disc_transfers = nth disc_transferss kk, sel_transfers = nth sel_transferss kk}, fp_bnf_sugar = {map_thms = nth map_thmss kk, map_disc_iffs = nth map_disc_iffss kk, map_selss = nth map_selsss kk, rel_injects = nth rel_injectss kk, rel_distincts = nth rel_distinctss kk, rel_sels = nth rel_selss kk, rel_intros = nth rel_intross kk, rel_cases = nth rel_casess kk, pred_injects = nth pred_injectss kk, set_thms = nth set_thmss kk, set_selssss = nth set_selsssss kk, set_introssss = nth set_introsssss kk, set_cases = nth set_casess kk}, fp_co_induct_sugar = SOME {co_rec = nth co_recs kk, common_co_inducts = common_co_inducts, co_inducts = nth co_inductss kk, co_rec_def = nth co_rec_defs kk, co_rec_thms = nth co_rec_thmss kk, co_rec_discs = nth co_rec_discss kk, co_rec_disc_iffs = nth co_rec_disc_iffss kk, co_rec_selss = nth co_rec_selsss kk, co_rec_codes = nth co_rec_codess kk, co_rec_transfers = nth co_rec_transferss kk, co_rec_o_maps = nth co_rec_o_mapss kk, common_rel_co_inducts = common_rel_co_inducts, rel_co_inducts = nth rel_co_inductss kk, common_set_inducts = common_set_inducts, set_inducts = nth set_inductss kk}} |> morph_fp_sugar (substitute_noted_thm noted)) Ts; in register_fp_sugars_raw fp_sugars #> fold (interpret_bnf plugins) (#bnfs fp_res) #> interpret_fp_sugars plugins fp_sugars end; fun quasi_unambiguous_case_names names = let val ps = map (`Long_Name.base_name) names; val dups = Library.duplicates (op =) (map fst ps); fun underscore s = let val ss = Long_Name.explode s in space_implode "_" (drop (length ss - 2) ss) end; in map (fn (base, full) => if member (op =) dups base then underscore full else base) ps |> Name.variant_list [] end; fun zipper_map f = let fun zed _ [] = [] | zed xs (y :: ys) = f (xs, y, ys) :: zed (xs @ [y]) ys; in zed [] end; fun cannot_merge_types fp = error ("Mutually " ^ co_prefix fp ^ "recursive types must have the same type parameters"); fun merge_type_arg fp T T' = if T = T' then T else cannot_merge_types fp; fun merge_type_args fp (As, As') = if length As = length As' then map2 (merge_type_arg fp) As As' else cannot_merge_types fp; fun type_args_named_constrained_of_spec (((((ncAs, _), _), _), _), _) = ncAs; fun type_binding_of_spec (((((_, b), _), _), _), _) = b; fun mixfix_of_spec ((((_, mx), _), _), _) = mx; fun mixfixed_ctr_specs_of_spec (((_, mx_ctr_specs), _), _) = mx_ctr_specs; fun map_binding_of_spec ((_, (b, _, _)), _) = b; fun rel_binding_of_spec ((_, (_, b, _)), _) = b; fun pred_binding_of_spec ((_, (_, _, b)), _) = b; fun sel_default_eqs_of_spec (_, ts) = ts; fun ctr_sugar_kind_of_fp_kind Least_FP = Datatype | ctr_sugar_kind_of_fp_kind Greatest_FP = Codatatype; fun uncurry_thm 0 thm = thm | uncurry_thm 1 thm = thm | uncurry_thm n thm = rotate_prems ~1 (uncurry_thm (n - 1) (rotate_prems 1 (conjI RS thm))); fun choose_binary_fun fs AB = find_first (fastype_of #> binder_types #> (fn [A, B] => AB = (A, B))) fs; fun build_binary_fun_app fs t u = Option.map (rapp u o rapp t) (choose_binary_fun fs (fastype_of t, fastype_of u)); fun build_the_rel ctxt Rs Ts A B = build_rel [] ctxt Ts [] (the o choose_binary_fun Rs) (A, B); fun build_rel_app ctxt Rs Ts t u = build_the_rel ctxt Rs Ts (fastype_of t) (fastype_of u) $ t $ u; fun build_set_app ctxt A t = Term.betapply (build_set ctxt A (fastype_of t), t); fun mk_parametricity_goal ctxt Rs t u = let val prem = build_the_rel ctxt Rs [] (fastype_of t) (fastype_of u) in HOLogic.mk_Trueprop (prem $ t $ u) end; val name_of_set = name_of_const "set function" domain_type; val fundefcong_attrs = @{attributes [fundef_cong]}; val nitpicksimp_attrs = @{attributes [nitpick_simp]}; val simp_attrs = @{attributes [simp]}; val lists_bmoc = fold (fn xs => fn t => Term.list_comb (t, xs)); fun flat_corec_predss_getterss qss gss = maps (op @) (qss ~~ gss); fun flat_corec_preds_predsss_gettersss [] [qss] [gss] = flat_corec_predss_getterss qss gss | flat_corec_preds_predsss_gettersss (p :: ps) (qss :: qsss) (gss :: gsss) = p :: flat_corec_predss_getterss qss gss @ flat_corec_preds_predsss_gettersss ps qsss gsss; fun mk_flip (x, Type (_, [T1, Type (_, [T2, T3])])) = Abs ("x", T1, Abs ("y", T2, Var (x, T2 --> T1 --> T3) $ Bound 0 $ Bound 1)); fun flip_rels ctxt n thm = let val Rs = Term.add_vars (Thm.prop_of thm) []; val Rs' = rev (drop (length Rs - n) Rs); in infer_instantiate ctxt (map (fn f => (fst f, Thm.cterm_of ctxt (mk_flip f))) Rs') thm end; fun mk_ctor_or_dtor get_T Ts t = let val Type (_, Ts0) = get_T (fastype_of t) in Term.subst_atomic_types (Ts0 ~~ Ts) t end; val mk_ctor = mk_ctor_or_dtor range_type; val mk_dtor = mk_ctor_or_dtor domain_type; fun mk_bnf_sets bnf = let val Type (T_name, Us) = T_of_bnf bnf; val lives = lives_of_bnf bnf; val sets = sets_of_bnf bnf; fun mk_set U = (case find_index (curry (op =) U) lives of ~1 => Term.dummy | i => nth sets i); in (T_name, map mk_set Us) end; fun mk_xtor_co_recs thy fp fpTs Cs ts0 = let val nn = length fpTs; val (fpTs0, Cs0) = map ((fp = Greatest_FP ? swap) o dest_funT o snd o strip_typeN nn o fastype_of) ts0 |> split_list; val rho = tvar_subst thy (fpTs0 @ Cs0) (fpTs @ Cs); in map (Term.subst_TVars rho) ts0 end; fun liveness_of_fp_bnf n bnf = (case T_of_bnf bnf of Type (_, Ts) => map (not o member (op =) (deads_of_bnf bnf)) Ts | _ => replicate n false); fun add_nesting_bnf_names Us = let fun add (Type (s, Ts)) ss = let val (needs, ss') = fold_map add Ts ss in if exists I needs then (true, insert (op =) s ss') else (false, ss') end | add T ss = (member (op =) Us T, ss); in snd oo add end; fun nesting_bnfs ctxt ctr_Tsss Us = map_filter (bnf_of ctxt) (fold (fold (fold (add_nesting_bnf_names Us))) ctr_Tsss []); fun indexify proj xs f p = f (find_index (curry (op =) (proj p)) xs) p; fun massage_simple_notes base = filter_out (null o #2) #> map (fn (thmN, thms, f_attrs) => ((Binding.qualify true base (Binding.name thmN), []), map_index (fn (i, thm) => ([thm], f_attrs i)) thms)); fun massage_multi_notes b_names Ts = maps (fn (thmN, thmss, attrs) => @{map 3} (fn b_name => fn Type (T_name, _) => fn thms => ((Binding.qualify true b_name (Binding.name thmN), attrs T_name), [(thms, [])])) b_names Ts thmss) #> filter_out (null o fst o hd o snd); fun define_ctrs_dtrs_for_type fp_b_name fpT ctor dtor ctor_dtor dtor_ctor n ks abs ctr_bindings ctr_mixfixes ctr_Tss lthy = let val ctor_absT = domain_type (fastype_of ctor); val (((w, xss), u'), _) = lthy |> yield_singleton (mk_Frees "w") ctor_absT ||>> mk_Freess "x" ctr_Tss ||>> yield_singleton Variable.variant_fixes fp_b_name; val u = Free (u', fpT); val ctor_iff_dtor_thm = let val goal = fold_rev Logic.all [w, u] (mk_Trueprop_eq (HOLogic.mk_eq (u, ctor $ w), HOLogic.mk_eq (dtor $ u, w))); val vars = Variable.add_free_names lthy goal []; in Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, ...} => mk_ctor_iff_dtor_tac ctxt (map (SOME o Thm.ctyp_of lthy) [ctor_absT, fpT]) (Thm.cterm_of lthy ctor) (Thm.cterm_of lthy dtor) ctor_dtor dtor_ctor) |> Thm.close_derivation \<^here> end; val ctr_rhss = map2 (fn k => fn xs => fold_rev Term.lambda xs (ctor $ mk_absumprod ctor_absT abs n k xs)) ks xss; val ((raw_ctrs, raw_ctr_defs), (lthy, lthy_old)) = lthy |> Local_Theory.open_target |> snd |> apfst split_list o @{fold_map 3} (fn b => fn mx => fn rhs => Local_Theory.define ((b, mx), ((Thm.make_def_binding (Config.get lthy bnf_internals) b, []), rhs)) #>> apsnd snd) ctr_bindings ctr_mixfixes ctr_rhss ||> `Local_Theory.close_target; val phi = Proof_Context.export_morphism lthy_old lthy; val ctr_defs = map (Morphism.thm phi) raw_ctr_defs; val ctrs0 = map (Morphism.term phi) raw_ctrs; in ((xss, ctrs0, ctor_iff_dtor_thm, ctr_defs), lthy) end; fun wrap_ctrs plugins fp discs_sels fp_b_name ctor_inject n ms abs_inject type_definition disc_bindings sel_bindingss sel_default_eqs ctrs0 ctor_iff_dtor_thm ctr_defs lthy = let val sumEN_thm' = unfold_thms lthy @{thms unit_all_eq1} (mk_absumprodE type_definition ms); fun exhaust_tac {context = ctxt, prems = _} = mk_exhaust_tac ctxt n ctr_defs ctor_iff_dtor_thm sumEN_thm'; val inject_tacss = map2 (fn ctr_def => fn 0 => [] | _ => [fn {context = ctxt, ...} => mk_inject_tac ctxt ctr_def ctor_inject abs_inject]) ctr_defs ms; val half_distinct_tacss = map (map (fn (def, def') => fn {context = ctxt, ...} => mk_half_distinct_tac ctxt ctor_inject abs_inject [def, def'])) (mk_half_pairss (`I ctr_defs)); val tacss = [exhaust_tac] :: inject_tacss @ half_distinct_tacss; fun ctr_spec_of disc_b ctr0 sel_bs = ((disc_b, ctr0), sel_bs); val ctr_specs = @{map 3} ctr_spec_of disc_bindings ctrs0 sel_bindingss; val (ctr_sugar as {case_cong, ...}, lthy) = free_constructors (ctr_sugar_kind_of_fp_kind fp) tacss ((((plugins, discs_sels), standard_binding), ctr_specs), sel_default_eqs) lthy; val anonymous_notes = [([case_cong], fundefcong_attrs)] |> map (fn (thms, attrs) => ((Binding.empty, attrs), [(thms, [])])); val notes = if Config.get lthy bnf_internals then [(ctor_iff_dtorN, [ctor_iff_dtor_thm], K [])] |> massage_simple_notes fp_b_name else []; in (ctr_sugar, lthy |> Local_Theory.notes (anonymous_notes @ notes) |> snd) end; fun derive_map_set_rel_pred_thms plugins fp live As Bs C E abs_inverses ctr_defs fp_nesting_set_maps fp_nesting_rel_eq_onps live_nesting_map_id0s live_nesting_set_maps live_nesting_rel_eqs live_nesting_rel_eq_onps fp_nested_rel_eq_onps fp_b_name fp_bnf fp_bnfs fpT ctor ctor_dtor dtor_ctor pre_map_def pre_set_defs pre_rel_def fp_map_thm fp_set_thms fp_rel_thm extra_unfolds_map extra_unfolds_set extra_unfolds_rel ctr_Tss ({casex, case_thms, discs, selss, sel_defs, ctrs, exhaust, exhaust_discs, disc_thmss, sel_thmss, injects, distincts, distinct_discsss, ...} : ctr_sugar) lthy = let val n = length ctr_Tss; val ms = map length ctr_Tss; val B_ify_T = Term.typ_subst_atomic (As ~~ Bs); val fpBT = B_ify_T fpT; val live_AsBs = filter (op <>) (As ~~ Bs); val live_As = map fst live_AsBs; val fTs = map (op -->) live_AsBs; val ((((((((xss, yss), fs), Ps), Rs), ta), tb), thesis), names_lthy) = lthy |> fold (fold Variable.declare_typ) [As, Bs] |> mk_Freess "x" ctr_Tss ||>> mk_Freess "y" (map (map B_ify_T) ctr_Tss) ||>> mk_Frees "f" fTs ||>> mk_Frees "P" (map mk_pred1T live_As) ||>> mk_Frees "R" (map (uncurry mk_pred2T) live_AsBs) ||>> yield_singleton (mk_Frees "a") fpT ||>> yield_singleton (mk_Frees "b") fpBT ||>> apfst HOLogic.mk_Trueprop o yield_singleton (mk_Frees "thesis") HOLogic.boolT; val ctrAs = map (mk_ctr As) ctrs; val ctrBs = map (mk_ctr Bs) ctrs; val ctr_defs' = map2 (fn m => fn def => mk_unabs_def m (HOLogic.mk_obj_eq def)) ms ctr_defs; val ABfs = live_AsBs ~~ fs; fun derive_rel_case relAsBs rel_inject_thms rel_distinct_thms = let val rel_Rs_a_b = list_comb (relAsBs, Rs) $ ta $ tb; fun mk_assms ctrA ctrB ctxt = let val argA_Ts = binder_types (fastype_of ctrA); val argB_Ts = binder_types (fastype_of ctrB); val ((argAs, argBs), names_ctxt) = ctxt |> mk_Frees "x" argA_Ts ||>> mk_Frees "y" argB_Ts; val ctrA_args = list_comb (ctrA, argAs); val ctrB_args = list_comb (ctrB, argBs); in (fold_rev Logic.all (argAs @ argBs) (Logic.list_implies (mk_Trueprop_eq (ta, ctrA_args) :: mk_Trueprop_eq (tb, ctrB_args) :: map2 (HOLogic.mk_Trueprop oo build_rel_app lthy Rs []) argAs argBs, thesis)), names_ctxt) end; val (assms, names_lthy) = @{fold_map 2} mk_assms ctrAs ctrBs names_lthy; val goal = Logic.list_implies (HOLogic.mk_Trueprop rel_Rs_a_b :: assms, thesis); in Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, prems = _} => mk_rel_case_tac ctxt (Thm.cterm_of ctxt ta) (Thm.cterm_of ctxt tb) exhaust injects rel_inject_thms distincts rel_distinct_thms live_nesting_rel_eqs) |> singleton (Proof_Context.export names_lthy lthy) |> Thm.close_derivation \<^here> end; fun derive_case_transfer rel_case_thm = let val (S, names_lthy) = yield_singleton (mk_Frees "S") (mk_pred2T C E) names_lthy; val caseA = mk_case As C casex; val caseB = mk_case Bs E casex; val goal = mk_parametricity_goal names_lthy (S :: Rs) caseA caseB; in Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, prems = _} => mk_case_transfer_tac ctxt rel_case_thm case_thms) |> singleton (Proof_Context.export names_lthy lthy) |> Thm.close_derivation \<^here> end; in if live = 0 then if plugins transfer_plugin then let val relAsBs = HOLogic.eq_const fpT; val rel_case_thm = derive_rel_case relAsBs [] []; val case_transfer_thm = derive_case_transfer rel_case_thm; val notes = [(case_transferN, [case_transfer_thm], K [])] |> massage_simple_notes fp_b_name; val (noted, lthy') = lthy |> Local_Theory.notes notes; val subst = Morphism.thm (substitute_noted_thm noted); in (([], [], [], [], [], [], [], [], [], [], [], [], [], [], [subst case_transfer_thm], [], []), lthy') end else (([], [], [], [], [], [], [], [], [], [], [], [], [], [], [], [], []), lthy) else let val mapx = mk_map live As Bs (map_of_bnf fp_bnf); val relAsBs = mk_rel live As Bs (rel_of_bnf fp_bnf); val setAs = map (mk_set As) (sets_of_bnf fp_bnf); val discAs = map (mk_disc_or_sel As) discs; val discBs = map (mk_disc_or_sel Bs) discs; val selAss = map (map (mk_disc_or_sel As)) selss; val selBss = map (map (mk_disc_or_sel Bs)) selss; val map_ctor_thm = if fp = Least_FP then fp_map_thm else let val ctorA = mk_ctor As ctor; val ctorB = mk_ctor Bs ctor; val y_T = domain_type (fastype_of ctorA); val (y as Free (y_s, _), _) = lthy |> yield_singleton (mk_Frees "y") y_T; val ctor_cong = infer_instantiate' lthy [NONE, NONE, SOME (Thm.cterm_of lthy ctorB)] arg_cong; val fp_map_thm' = fp_map_thm |> infer_instantiate' lthy (replicate live NONE @ [SOME (Thm.cterm_of lthy (ctorA $ y))]) |> unfold_thms lthy [dtor_ctor]; in (fp_map_thm' RS ctor_cong RS (ctor_dtor RS sym RS trans)) |> Drule.generalize ([], [y_s]) end; val map_thms = let fun mk_goal ctrA ctrB xs ys = let val fmap = list_comb (mapx, fs); fun mk_arg (x as Free (_, T)) (Free (_, U)) = if T = U then x else build_map lthy [] [] (the o AList.lookup (op =) ABfs) (T, U) $ x; val xs' = map2 mk_arg xs ys; in mk_Trueprop_eq (fmap $ list_comb (ctrA, xs), list_comb (ctrB, xs')) end; val goals = @{map 4} mk_goal ctrAs ctrBs xss yss; val goal = Logic.mk_conjunction_balanced goals; val vars = Variable.add_free_names lthy goal []; in Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, prems = _} => mk_map_tac ctxt abs_inverses pre_map_def map_ctor_thm live_nesting_map_id0s ctr_defs' extra_unfolds_map) |> Thm.close_derivation \<^here> |> Conjunction.elim_balanced (length goals) end; val set0_thms = let fun mk_goal A setA ctrA xs = let val sets = map (build_set_app lthy A) (filter (exists_subtype_in [A] o fastype_of) xs); in mk_Trueprop_eq (setA $ list_comb (ctrA, xs), (if null sets then HOLogic.mk_set A [] else Library.foldl1 mk_union sets)) end; val goals = @{map 2} (fn live_A => fn setA => map2 (mk_goal live_A setA) ctrAs xss) live_As setAs |> flat; in if null goals then [] else let val goal = Logic.mk_conjunction_balanced goals; val vars = Variable.add_free_names lthy goal []; in Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, prems = _} => mk_set0_tac ctxt abs_inverses pre_set_defs dtor_ctor fp_set_thms fp_nesting_set_maps live_nesting_set_maps ctr_defs' extra_unfolds_set) |> Thm.close_derivation \<^here> |> Conjunction.elim_balanced (length goals) end end; val set_thms = set0_thms |> map (unfold_thms lthy @{thms insert_is_Un[THEN sym] Un_empty_left Un_insert_left}); val rel_ctor_thm = if fp = Least_FP then fp_rel_thm else let val ctorA = mk_ctor As ctor; val ctorB = mk_ctor Bs ctor; val y_T = domain_type (fastype_of ctorA); val z_T = domain_type (fastype_of ctorB); val ((y as Free (y_s, _), z as Free (z_s, _)), _) = lthy |> yield_singleton (mk_Frees "y") y_T ||>> yield_singleton (mk_Frees "z") z_T; in fp_rel_thm |> infer_instantiate' lthy (replicate live NONE @ [SOME (Thm.cterm_of lthy (ctorA $ y)), SOME (Thm.cterm_of lthy (ctorB $ z))]) |> unfold_thms lthy [dtor_ctor] |> Drule.generalize ([], [y_s, z_s]) end; val rel_inject_thms = let fun mk_goal ctrA ctrB xs ys = let val lhs = list_comb (relAsBs, Rs) $ list_comb (ctrA, xs) $ list_comb (ctrB, ys); val conjuncts = map2 (build_rel_app lthy Rs []) xs ys; in HOLogic.mk_Trueprop (if null conjuncts then lhs else HOLogic.mk_eq (lhs, Library.foldr1 HOLogic.mk_conj conjuncts)) end; val goals = @{map 4} mk_goal ctrAs ctrBs xss yss; val goal = Logic.mk_conjunction_balanced goals; val vars = Variable.add_free_names lthy goal []; in Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, prems = _} => mk_rel_tac ctxt abs_inverses pre_rel_def rel_ctor_thm live_nesting_rel_eqs ctr_defs' extra_unfolds_rel) |> Thm.close_derivation \<^here> |> Conjunction.elim_balanced (length goals) end; val half_rel_distinct_thmss = let fun mk_goal ((ctrA, xs), (ctrB, ys)) = HOLogic.mk_Trueprop (HOLogic.mk_not (list_comb (relAsBs, Rs) $ list_comb (ctrA, xs) $ list_comb (ctrB, ys))); val rel_infos = (ctrAs ~~ xss, ctrBs ~~ yss); val goalss = map (map mk_goal) (mk_half_pairss rel_infos); val goals = flat goalss; in unflat goalss (if null goals then [] else let val goal = Logic.mk_conjunction_balanced goals; val vars = Variable.add_free_names lthy goal []; in Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, prems = _} => mk_rel_tac ctxt abs_inverses pre_rel_def rel_ctor_thm live_nesting_rel_eqs ctr_defs' extra_unfolds_rel) |> Thm.close_derivation \<^here> |> Conjunction.elim_balanced (length goals) end) end; val rel_flip = rel_flip_of_bnf fp_bnf; fun mk_other_half_rel_distinct_thm thm = flip_rels lthy live thm RS (rel_flip RS sym RS @{thm arg_cong[of _ _ Not]} RS iffD2); val other_half_rel_distinct_thmss = map (map mk_other_half_rel_distinct_thm) half_rel_distinct_thmss; val (rel_distinct_thms, _) = join_halves n half_rel_distinct_thmss other_half_rel_distinct_thmss; fun mk_rel_intro_thm m thm = uncurry_thm m (thm RS iffD2) handle THM _ => thm; val rel_intro_thms = map2 mk_rel_intro_thm ms rel_inject_thms; val rel_code_thms = map (fn thm => thm RS @{thm eq_False[THEN iffD2]}) rel_distinct_thms @ map2 (fn thm => fn 0 => thm RS @{thm eq_True[THEN iffD2]} | _ => thm) rel_inject_thms ms; val ctr_transfer_thms = let val goals = map2 (mk_parametricity_goal names_lthy Rs) ctrAs ctrBs; val goal = Logic.mk_conjunction_balanced goals; val vars = Variable.add_free_names lthy goal []; in Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, prems = _} => mk_ctr_transfer_tac ctxt rel_intro_thms live_nesting_rel_eqs) |> Thm.close_derivation \<^here> |> Conjunction.elim_balanced (length goals) end; val (set_cases_thms, set_cases_attrss) = let fun mk_prems assms elem t ctxt = (case fastype_of t of Type (type_name, xs) => (case bnf_of ctxt type_name of NONE => ([], ctxt) | SOME bnf => apfst flat (fold_map (fn set => fn ctxt => let val T = HOLogic.dest_setT (range_type (fastype_of set)); val new_var = not (T = fastype_of elem); val (x, ctxt') = if new_var then yield_singleton (mk_Frees "x") T ctxt else (elem, ctxt); in mk_prems (mk_Trueprop_mem (x, set $ t) :: assms) elem x ctxt' |>> map (new_var ? Logic.all x) end) (map (mk_set xs) (sets_of_bnf bnf)) ctxt)) | T => rpair ctxt (if T = fastype_of elem then [fold (curry Logic.mk_implies) assms thesis] else [])); in split_list (map (fn set => let val A = HOLogic.dest_setT (range_type (fastype_of set)); val (elem, names_lthy) = yield_singleton (mk_Frees "e") A names_lthy; val premss = map (fn ctr => let val (args, names_lthy) = mk_Frees "z" (binder_types (fastype_of ctr)) names_lthy; in flat (zipper_map (fn (prev_args, arg, next_args) => let val (args_with_elem, args_without_elem) = if fastype_of arg = A then (prev_args @ [elem] @ next_args, prev_args @ next_args) else `I (prev_args @ [arg] @ next_args); in mk_prems [mk_Trueprop_eq (ta, Term.list_comb (ctr, args_with_elem))] elem arg names_lthy |> fst |> map (fold_rev Logic.all args_without_elem) end) args) end) ctrAs; val goal = Logic.mk_implies (mk_Trueprop_mem (elem, set $ ta), thesis); val vars = Variable.add_free_names lthy goal []; val thm = Goal.prove_sorry lthy vars (flat premss) goal (fn {context = ctxt, prems} => mk_set_cases_tac ctxt (Thm.cterm_of ctxt ta) prems exhaust set_thms) |> Thm.close_derivation \<^here> |> rotate_prems ~1; val cases_set_attr = Attrib.internal (K (Induct.cases_pred (name_of_set set))); val ctr_names = quasi_unambiguous_case_names (flat (map (uncurry mk_names o map_prod length name_of_ctr) (premss ~~ ctrAs))); in (* TODO: @{attributes [elim?]} *) (thm, [Attrib.consumes 1, cases_set_attr, Attrib.case_names ctr_names]) end) setAs) end; val (set_intros_thmssss, set_intros_thms) = let fun mk_goals A setA ctr_args t ctxt = (case fastype_of t of Type (type_name, innerTs) => (case bnf_of ctxt type_name of NONE => ([], ctxt) | SOME bnf => apfst flat (fold_map (fn set => fn ctxt => let val T = HOLogic.dest_setT (range_type (fastype_of set)); val (y, ctxt') = yield_singleton (mk_Frees "y") T ctxt; val assm = mk_Trueprop_mem (y, set $ t); in apfst (map (Logic.mk_implies o pair assm)) (mk_goals A setA ctr_args y ctxt') end) (map (mk_set innerTs) (sets_of_bnf bnf)) ctxt)) | T => (if T = A then [mk_Trueprop_mem (t, setA $ ctr_args)] else [], ctxt)); val (goalssss, _) = fold_map (fn set => let val A = HOLogic.dest_setT (range_type (fastype_of set)) in @{fold_map 2} (fn ctr => fn xs => fold_map (mk_goals A set (Term.list_comb (ctr, xs))) xs) ctrAs xss end) setAs lthy; val goals = flat (flat (flat goalssss)); in `(unflattt goalssss) (if null goals then [] else let val goal = Logic.mk_conjunction_balanced goals; val vars = Variable.add_free_names lthy goal []; in Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, prems = _} => mk_set_intros_tac ctxt set0_thms) |> Thm.close_derivation \<^here> |> Conjunction.elim_balanced (length goals) end) end; val rel_sel_thms = let val n = length discAs; fun mk_conjunct n k discA selAs discB selBs = (if k = n then [] else [HOLogic.mk_eq (discA $ ta, discB $ tb)]) @ (if null selAs then [] else [Library.foldr HOLogic.mk_imp (if n = 1 then [] else [discA $ ta, discB $ tb], Library.foldr1 HOLogic.mk_conj (map2 (build_rel_app names_lthy Rs []) (map (rapp ta) selAs) (map (rapp tb) selBs)))]); val goals = if n = 0 then [] else [mk_Trueprop_eq (build_rel_app names_lthy Rs [] ta tb, (case flat (@{map 5} (mk_conjunct n) (1 upto n) discAs selAss discBs selBss) of [] => \<^term>\True\ | conjuncts => Library.foldr1 HOLogic.mk_conj conjuncts))]; fun prove goal = Variable.add_free_names lthy goal [] |> (fn vars => Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, prems = _} => mk_rel_sel_tac ctxt (Thm.cterm_of ctxt ta) (Thm.cterm_of ctxt tb) exhaust (flat disc_thmss) (flat sel_thmss) rel_inject_thms distincts rel_distinct_thms live_nesting_rel_eqs)) |> Thm.close_derivation \<^here>; in map prove goals end; val (rel_case_thm, rel_case_attrs) = let val thm = derive_rel_case relAsBs rel_inject_thms rel_distinct_thms; val ctr_names = quasi_unambiguous_case_names (map name_of_ctr ctrAs); in (thm, [Attrib.case_names ctr_names, Attrib.consumes 1] @ @{attributes [cases pred]}) end; val case_transfer_thm = derive_case_transfer rel_case_thm; val sel_transfer_thms = if null selAss then [] else let val shared_sels = foldl1 (uncurry (inter (op =))) (map (op ~~) (selAss ~~ selBss)); val goals = map (uncurry (mk_parametricity_goal names_lthy Rs)) shared_sels; in if null goals then [] else let val goal = Logic.mk_conjunction_balanced goals; val vars = Variable.add_free_names lthy goal []; in Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, prems = _} => mk_sel_transfer_tac ctxt n sel_defs case_transfer_thm) |> Thm.close_derivation \<^here> |> Conjunction.elim_balanced (length goals) end end; val disc_transfer_thms = let val goals = map2 (mk_parametricity_goal names_lthy Rs) discAs discBs in if null goals then [] else let val goal = Logic.mk_conjunction_balanced goals; val vars = Variable.add_free_names lthy goal []; in Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, prems = _} => mk_disc_transfer_tac ctxt (the_single rel_sel_thms) (the_single exhaust_discs) (flat (flat distinct_discsss))) |> Thm.close_derivation \<^here> |> Conjunction.elim_balanced (length goals) end end; val map_disc_iff_thms = let val discsB = map (mk_disc_or_sel Bs) discs; val discsA_t = map (fn disc1 => Term.betapply (disc1, ta)) discAs; fun mk_goal (discA_t, discB) = if head_of discA_t aconv HOLogic.Not orelse is_refl_bool discA_t then NONE else SOME (mk_Trueprop_eq (betapply (discB, (Term.list_comb (mapx, fs) $ ta)), discA_t)); val goals = map_filter mk_goal (discsA_t ~~ discsB); in if null goals then [] else let val goal = Logic.mk_conjunction_balanced goals; val vars = Variable.add_free_names lthy goal []; in Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, prems = _} => mk_map_disc_iff_tac ctxt (Thm.cterm_of ctxt ta) exhaust (flat disc_thmss) map_thms) |> Thm.close_derivation \<^here> |> Conjunction.elim_balanced (length goals) end end; val (map_sel_thmss, map_sel_thms) = let fun mk_goal discA selA selB = let val prem = Term.betapply (discA, ta); val lhs = selB $ (Term.list_comb (mapx, fs) $ ta); val lhsT = fastype_of lhs; val map_rhsT = map_atyps (perhaps (AList.lookup (op =) (map swap live_AsBs))) lhsT; val map_rhs = build_map lthy [] [] (the o (AList.lookup (op =) (live_AsBs ~~ fs))) (map_rhsT, lhsT); val rhs = (case map_rhs of Const (\<^const_name>\id\, _) => selA $ ta | _ => map_rhs $ (selA $ ta)); val concl = mk_Trueprop_eq (lhs, rhs); in if is_refl_bool prem then concl else Logic.mk_implies (HOLogic.mk_Trueprop prem, concl) end; val goalss = @{map 3} (map2 o mk_goal) discAs selAss selBss; val goals = flat goalss; in `(unflat goalss) (if null goals then [] else let val goal = Logic.mk_conjunction_balanced goals; val vars = Variable.add_free_names lthy goal []; in Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, prems = _} => mk_map_sel_tac ctxt (Thm.cterm_of ctxt ta) exhaust (flat disc_thmss) map_thms (flat sel_thmss) live_nesting_map_id0s) |> Thm.close_derivation \<^here> |> Conjunction.elim_balanced (length goals) end) end; val (set_sel_thmssss, set_sel_thms) = let fun mk_goal setA discA selA ctxt = let val prem = Term.betapply (discA, ta); val sel_rangeT = range_type (fastype_of selA); val A = HOLogic.dest_setT (range_type (fastype_of setA)); fun travese_nested_types t ctxt = (case fastype_of t of Type (type_name, innerTs) => (case bnf_of ctxt type_name of NONE => ([], ctxt) | SOME bnf => let fun seq_assm a set ctxt = let val T = HOLogic.dest_setT (range_type (fastype_of set)); val (x, ctxt') = yield_singleton (mk_Frees "x") T ctxt; val assm = mk_Trueprop_mem (x, set $ a); in travese_nested_types x ctxt' |>> map (Logic.mk_implies o pair assm) end; in fold_map (seq_assm t o mk_set innerTs) (sets_of_bnf bnf) ctxt |>> flat end) | T => if T = A then ([mk_Trueprop_mem (t, setA $ ta)], ctxt) else ([], ctxt)); val (concls, ctxt') = if sel_rangeT = A then ([mk_Trueprop_mem (selA $ ta, setA $ ta)], ctxt) else travese_nested_types (selA $ ta) ctxt; in if exists_subtype_in [A] sel_rangeT then if is_refl_bool prem then (concls, ctxt') else (map (Logic.mk_implies o pair (HOLogic.mk_Trueprop prem)) concls, ctxt') else ([], ctxt) end; val (goalssss, _) = fold_map (fn set => @{fold_map 2} (fold_map o mk_goal set) discAs selAss) setAs names_lthy; val goals = flat (flat (flat goalssss)); in `(unflattt goalssss) (if null goals then [] else let val goal = Logic.mk_conjunction_balanced goals; val vars = Variable.add_free_names lthy goal []; in Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, prems = _} => mk_set_sel_tac ctxt (Thm.cterm_of ctxt ta) exhaust (flat disc_thmss) (flat sel_thmss) set0_thms) |> Thm.close_derivation \<^here> |> Conjunction.elim_balanced (length goals) end) end; val pred_injects = let fun top_sweep_rewr_conv rewrs = Conv.top_sweep_conv (K (Conv.rewrs_conv rewrs)) \<^context>; val rel_eq_onp_with_tops_of = Conv.fconv_rule (HOLogic.Trueprop_conv (Conv.arg1_conv (top_sweep_rewr_conv @{thms eq_onp_top_eq_eq[symmetric, THEN eq_reflection]}))); val eq_onps = map rel_eq_onp_with_tops_of (map rel_eq_onp_of_bnf fp_bnfs @ fp_nesting_rel_eq_onps @ live_nesting_rel_eq_onps @ fp_nested_rel_eq_onps); val cTs = map (SOME o Thm.ctyp_of lthy) (maps (replicate 2) live_As); val cts = map (SOME o Thm.cterm_of lthy) (map mk_eq_onp Ps); val get_rhs = Thm.concl_of #> HOLogic.dest_Trueprop #> HOLogic.dest_eq #> snd; val pred_eq_onp_conj = List.foldr (fn (_, thm) => thm RS @{thm eq_onp_live_step}) @{thm refl[of True]}; fun predify_rel_inject rel_inject = let val conjuncts = try (get_rhs #> HOLogic.dest_conj) rel_inject |> the_default []; fun postproc thm = if null conjuncts then thm RS (@{thm eq_onp_same_args} RS iffD1) else @{thm box_equals} OF [thm, @{thm eq_onp_same_args}, pred_eq_onp_conj conjuncts |> unfold_thms lthy @{thms simp_thms(21)}]; in rel_inject |> Thm.instantiate' cTs cts |> Conv.fconv_rule (HOLogic.Trueprop_conv (Conv.arg_conv (Raw_Simplifier.rewrite lthy false @{thms eq_onp_top_eq_eq[symmetric, THEN eq_reflection]}))) |> unfold_thms lthy eq_onps |> postproc |> unfold_thms lthy @{thms top_conj} end; in rel_inject_thms |> map (unfold_thms lthy [@{thm conj_assoc}]) |> map predify_rel_inject |> Proof_Context.export names_lthy lthy end; val anonymous_notes = [(rel_code_thms, nitpicksimp_attrs)] |> map (fn (thms, attrs) => ((Binding.empty, attrs), [(thms, [])])); val notes = (if Config.get lthy bnf_internals then [(set0N, set0_thms, K [])] else []) @ [(case_transferN, [case_transfer_thm], K []), (ctr_transferN, ctr_transfer_thms, K []), (disc_transferN, disc_transfer_thms, K []), (sel_transferN, sel_transfer_thms, K []), (mapN, map_thms, K (nitpicksimp_attrs @ simp_attrs)), (map_disc_iffN, map_disc_iff_thms, K simp_attrs), (map_selN, map_sel_thms, K []), (pred_injectN, pred_injects, K simp_attrs), (rel_casesN, [rel_case_thm], K rel_case_attrs), (rel_distinctN, rel_distinct_thms, K simp_attrs), (rel_injectN, rel_inject_thms, K simp_attrs), (rel_introsN, rel_intro_thms, K []), (rel_selN, rel_sel_thms, K []), (setN, set_thms, K (case_fp fp nitpicksimp_attrs [] @ simp_attrs)), (set_casesN, set_cases_thms, nth set_cases_attrss), (set_introsN, set_intros_thms, K []), (set_selN, set_sel_thms, K [])] |> massage_simple_notes fp_b_name; val (noted, lthy') = lthy - |> Spec_Rules.add Spec_Rules.equational (`(single o lhs_head_of o hd) map_thms) - |> fp = Least_FP - ? Spec_Rules.add Spec_Rules.equational (`(single o lhs_head_of o hd) rel_code_thms) - |> Spec_Rules.add Spec_Rules.equational (`(single o lhs_head_of o hd) set0_thms) + |> uncurry (Spec_Rules.add "" Spec_Rules.equational) (`(single o lhs_head_of o hd) map_thms) + |> fp = Least_FP ? + uncurry (Spec_Rules.add "" Spec_Rules.equational) (`(single o lhs_head_of o hd) rel_code_thms) + |> uncurry (Spec_Rules.add "" Spec_Rules.equational) (`(single o lhs_head_of o hd) set0_thms) |> plugins code_plugin ? Code.declare_default_eqns (map (rpair true) (rel_code_thms @ map_thms @ set_thms)) |> Local_Theory.notes (anonymous_notes @ notes); val subst = Morphism.thm (substitute_noted_thm noted); in ((map subst map_thms, map subst map_disc_iff_thms, map (map subst) map_sel_thmss, map subst rel_inject_thms, map subst rel_distinct_thms, map subst rel_sel_thms, map subst rel_intro_thms, [subst rel_case_thm], map subst pred_injects, map subst set_thms, map (map (map (map subst))) set_sel_thmssss, map (map (map (map subst))) set_intros_thmssss, map subst set_cases_thms, map subst ctr_transfer_thms, [subst case_transfer_thm], map subst disc_transfer_thms, map subst sel_transfer_thms), lthy') end end; type lfp_sugar_thms = (thm list * thm * Token.src list) * (thm list list * Token.src list); fun morph_lfp_sugar_thms phi ((inducts, induct, induct_attrs), (recss, rec_attrs)) = ((map (Morphism.thm phi) inducts, Morphism.thm phi induct, induct_attrs), (map (map (Morphism.thm phi)) recss, rec_attrs)) : lfp_sugar_thms; val transfer_lfp_sugar_thms = morph_lfp_sugar_thms o Morphism.transfer_morphism; type gfp_sugar_thms = ((thm list * thm) list * (Token.src list * Token.src list)) * thm list list * thm list list * (thm list list * Token.src list) * (thm list list list * Token.src list); fun morph_gfp_sugar_thms phi ((coinducts_pairs, coinduct_attrs_pair), corecss, corec_discss, (corec_disc_iffss, corec_disc_iff_attrs), (corec_selsss, corec_sel_attrs)) = ((map (apfst (map (Morphism.thm phi)) o apsnd (Morphism.thm phi)) coinducts_pairs, coinduct_attrs_pair), map (map (Morphism.thm phi)) corecss, map (map (Morphism.thm phi)) corec_discss, (map (map (Morphism.thm phi)) corec_disc_iffss, corec_disc_iff_attrs), (map (map (map (Morphism.thm phi))) corec_selsss, corec_sel_attrs)) : gfp_sugar_thms; val transfer_gfp_sugar_thms = morph_gfp_sugar_thms o Morphism.transfer_morphism; fun unzip_recT (Type (\<^type_name>\prod\, [_, TFree x])) (T as Type (\<^type_name>\prod\, Ts as [_, TFree y])) = if x = y then [T] else Ts | unzip_recT _ (Type (\<^type_name>\prod\, Ts as [_, TFree _])) = Ts | unzip_recT _ T = [T]; fun mk_recs_args_types ctxt ctr_Tsss Cs absTs repTs ns mss ctor_rec_fun_Ts = let val Css = map2 replicate ns Cs; val x_Tssss = @{map 6} (fn absT => fn repT => fn n => fn ms => fn ctr_Tss => fn ctor_rec_fun_T => map2 (map2 unzip_recT) ctr_Tss (dest_absumprodT absT repT n ms (domain_type ctor_rec_fun_T))) absTs repTs ns mss ctr_Tsss ctor_rec_fun_Ts; val x_Tsss' = map (map flat_rec_arg_args) x_Tssss; val f_Tss = map2 (map2 (curry (op --->))) x_Tsss' Css; val ((fss, xssss), _) = ctxt |> mk_Freess "f" f_Tss ||>> mk_Freessss "x" x_Tssss; in (f_Tss, x_Tssss, fss, xssss) end; fun unzip_corecT (Type (\<^type_name>\sum\, _)) T = [T] | unzip_corecT _ (Type (\<^type_name>\sum\, Ts)) = Ts | unzip_corecT _ T = [T]; (*avoid "'a itself" arguments in corecursors*) fun repair_nullary_single_ctr [[]] = [[HOLogic.unitT]] | repair_nullary_single_ctr Tss = Tss; fun mk_corec_fun_arg_types0 ctr_Tsss Cs absTs repTs ns mss fun_Ts = let val ctr_Tsss' = map repair_nullary_single_ctr ctr_Tsss; val g_absTs = map range_type fun_Ts; val g_Tsss = map repair_nullary_single_ctr (@{map 5} dest_absumprodT absTs repTs ns mss g_absTs); val g_Tssss = @{map 3} (fn C => map2 (map2 (map (curry (op -->) C) oo unzip_corecT))) Cs ctr_Tsss' g_Tsss; val q_Tssss = map (map (map (fn [_] => [] | [_, T] => [mk_pred1T (domain_type T)]))) g_Tssss; in (q_Tssss, g_Tsss, g_Tssss, g_absTs) end; fun mk_corec_p_pred_types Cs ns = map2 (fn n => replicate (Int.max (0, n - 1)) o mk_pred1T) ns Cs; fun mk_corec_fun_arg_types ctr_Tsss Cs absTs repTs ns mss dtor_corec = (mk_corec_p_pred_types Cs ns, mk_corec_fun_arg_types0 ctr_Tsss Cs absTs repTs ns mss (binder_fun_types (fastype_of dtor_corec))); fun mk_corecs_args_types ctxt ctr_Tsss Cs absTs repTs ns mss dtor_corec_fun_Ts = let val p_Tss = mk_corec_p_pred_types Cs ns; val (q_Tssss, g_Tsss, g_Tssss, corec_types) = mk_corec_fun_arg_types0 ctr_Tsss Cs absTs repTs ns mss dtor_corec_fun_Ts; val (((((Free (x, _), cs), pss), qssss), gssss), _) = ctxt |> yield_singleton (mk_Frees "x") dummyT ||>> mk_Frees "a" Cs ||>> mk_Freess "p" p_Tss ||>> mk_Freessss "q" q_Tssss ||>> mk_Freessss "g" g_Tssss; val cpss = map2 (map o rapp) cs pss; fun build_sum_inj mk_inj = build_map ctxt [] [] (uncurry mk_inj o dest_sumT o snd); fun build_dtor_corec_arg _ [] [cg] = cg | build_dtor_corec_arg T [cq] [cg, cg'] = mk_If cq (build_sum_inj Inl_const (fastype_of cg, T) $ cg) (build_sum_inj Inr_const (fastype_of cg', T) $ cg'); val pgss = @{map 3} flat_corec_preds_predsss_gettersss pss qssss gssss; val cqssss = map2 (map o map o map o rapp) cs qssss; val cgssss = map2 (map o map o map o rapp) cs gssss; val cqgsss = @{map 3} (@{map 3} (@{map 3} build_dtor_corec_arg)) g_Tsss cqssss cgssss; in (x, cs, cpss, (((pgss, pss, qssss, gssss), cqgsss), corec_types)) end; fun mk_co_recs_prelims ctxt fp ctr_Tsss fpTs Cs absTs repTs ns mss xtor_co_recs0 = let val thy = Proof_Context.theory_of ctxt; val (xtor_co_rec_fun_Ts, xtor_co_recs) = mk_xtor_co_recs thy fp fpTs Cs xtor_co_recs0 |> `(binder_fun_types o fastype_of o hd); val (recs_args_types, corecs_args_types) = if fp = Least_FP then mk_recs_args_types ctxt ctr_Tsss Cs absTs repTs ns mss xtor_co_rec_fun_Ts |> (rpair NONE o SOME) else mk_corecs_args_types ctxt ctr_Tsss Cs absTs repTs ns mss xtor_co_rec_fun_Ts |> (pair NONE o SOME); in (xtor_co_recs, recs_args_types, corecs_args_types) end; fun mk_preds_getterss_join c cps absT abs cqgss = let val n = length cqgss; val ts = map2 (mk_absumprod absT abs n) (1 upto n) cqgss; in Term.lambda c (mk_IfN absT cps ts) end; fun define_co_rec_as fp Cs fpT b rhs lthy0 = let val thy = Proof_Context.theory_of lthy0; val ((cst, (_, def)), (lthy', lthy)) = lthy0 |> Local_Theory.open_target |> snd |> Local_Theory.define ((b, NoSyn), ((Thm.make_def_binding (Config.get lthy0 bnf_internals) b, []), rhs)) ||> `Local_Theory.close_target; val phi = Proof_Context.export_morphism lthy lthy'; val cst' = mk_co_rec thy fp Cs fpT (Morphism.term phi cst); val def' = Morphism.thm phi def; in ((cst', def'), lthy') end; fun define_rec (_, _, fss, xssss) mk_binding fpTs Cs reps ctor_rec = let val nn = length fpTs; val (ctor_rec_absTs, fpT) = strip_typeN nn (fastype_of ctor_rec) |>> map domain_type ||> domain_type; in define_co_rec_as Least_FP Cs fpT (mk_binding recN) (fold_rev (fold_rev Term.lambda) fss (Term.list_comb (ctor_rec, @{map 4} (fn ctor_rec_absT => fn rep => fn fs => fn xsss => mk_case_absumprod ctor_rec_absT rep fs (map (map HOLogic.mk_tuple) xsss) (map flat_rec_arg_args xsss)) ctor_rec_absTs reps fss xssss))) end; fun define_corec (_, cs, cpss, (((pgss, _, _, _), cqgsss), f_absTs)) mk_binding fpTs Cs abss dtor_corec = let val nn = length fpTs; val fpT = range_type (snd (strip_typeN nn (fastype_of dtor_corec))); in define_co_rec_as Greatest_FP Cs fpT (mk_binding corecN) (fold_rev (fold_rev Term.lambda) pgss (Term.list_comb (dtor_corec, @{map 5} mk_preds_getterss_join cs cpss f_absTs abss cqgsss))) end; fun mk_induct_raw_prem_prems names_ctxt Xss setss_fp_nesting (x as Free (s, Type (T_name, Ts0))) (Type (_, Xs_Ts0)) = (case AList.lookup (op =) setss_fp_nesting T_name of NONE => [] | SOME raw_sets0 => let val (Xs_Ts, (Ts, raw_sets)) = filter (exists_subtype_in (flat Xss) o fst) (Xs_Ts0 ~~ (Ts0 ~~ raw_sets0)) |> split_list ||> split_list; val sets = map (mk_set Ts0) raw_sets; val (ys, names_ctxt') = names_ctxt |> mk_Frees s Ts; val xysets = map (pair x) (ys ~~ sets); val ppremss = map2 (mk_induct_raw_prem_prems names_ctxt' Xss setss_fp_nesting) ys Xs_Ts; in flat (map2 (map o apfst o cons) xysets ppremss) end) | mk_induct_raw_prem_prems _ Xss _ (x as Free (_, Type _)) X = [([], (find_index (fn Xs => member (op =) Xs X) Xss + 1, x))] | mk_induct_raw_prem_prems _ _ _ _ _ = []; fun mk_induct_raw_prem alter_x names_ctxt Xss setss_fp_nesting p ctr ctr_Ts ctrXs_Ts = let val (xs, names_ctxt') = names_ctxt |> mk_Frees "x" ctr_Ts; val pprems = flat (map2 (mk_induct_raw_prem_prems names_ctxt' Xss setss_fp_nesting) xs ctrXs_Ts); val y = Term.list_comb (ctr, map alter_x xs); val p' = enforce_type names_ctxt domain_type (fastype_of y) p; in (xs, pprems, HOLogic.mk_Trueprop (p' $ y)) end; fun close_induct_prem_prem nn ps xs t = fold_rev Logic.all (map Free (drop (nn + length xs) (rev (Term.add_frees t (map dest_Free xs @ map_filter (try dest_Free) ps))))) t; fun finish_induct_prem_prem ctxt nn ps xs (xysets, (j, x)) = let val p' = enforce_type ctxt domain_type (fastype_of x) (nth ps (j - 1)) in close_induct_prem_prem nn ps xs (Logic.list_implies (map (fn (x', (y, set)) => mk_Trueprop_mem (y, set $ x')) xysets, HOLogic.mk_Trueprop (p' $ x))) end; fun finish_induct_prem ctxt nn ps (xs, raw_pprems, concl) = fold_rev Logic.all xs (Logic.list_implies (map (finish_induct_prem_prem ctxt nn ps xs) raw_pprems, concl)); fun mk_coinduct_prem_ctr_concls ctxt Xss fpTss rs' n k udisc usels vdisc vsels ctrXs_Ts = let fun build_the_rel T Xs_T = build_rel [] ctxt [] [] (fn (T, X) => nth rs' (find_index (fn Xs => member (op =) Xs X) Xss) |> enforce_type ctxt domain_type T) (T, Xs_T) |> Term.subst_atomic_types (flat Xss ~~ flat fpTss); fun build_rel_app usel vsel Xs_T = fold rapp [usel, vsel] (build_the_rel (fastype_of usel) Xs_T); in (if k = n then [] else [HOLogic.mk_eq (udisc, vdisc)]) @ (if null usels then [] else [Library.foldr HOLogic.mk_imp (if n = 1 then [] else [udisc, vdisc], Library.foldr1 HOLogic.mk_conj (@{map 3} build_rel_app usels vsels ctrXs_Ts))]) end; fun mk_coinduct_prem_concl ctxt Xss fpTss rs' n udiscs uselss vdiscs vselss ctrXs_Tss = @{map 6} (mk_coinduct_prem_ctr_concls ctxt Xss fpTss rs' n) (1 upto n) udiscs uselss vdiscs vselss ctrXs_Tss |> flat |> Library.foldr1 HOLogic.mk_conj handle List.Empty => \<^term>\True\; fun mk_coinduct_prem ctxt Xss fpTss rs' uvr u v n udiscs uselss vdiscs vselss ctrXs_Tss = fold_rev Logic.all [u, v] (Logic.mk_implies (HOLogic.mk_Trueprop uvr, HOLogic.mk_Trueprop (mk_coinduct_prem_concl ctxt Xss fpTss rs' n udiscs uselss vdiscs vselss ctrXs_Tss))); fun postproc_co_induct ctxt nn prop prop_conj = Drule.zero_var_indexes #> `(conj_dests nn) #>> map (fn thm => Thm.permute_prems 0 ~1 (thm RS prop)) ##> (fn thm => Thm.permute_prems 0 (~ nn) (if nn = 1 then thm RS prop else funpow nn (fn thm => unfold_thms ctxt @{thms conj_assoc} (thm RS prop_conj)) thm)); fun mk_induct_attrs ctrss = let val induct_cases = quasi_unambiguous_case_names (maps (map name_of_ctr) ctrss); in [Attrib.case_names induct_cases] end; fun derive_rel_induct_thms_for_types ctxt nn fpA_Ts As Bs ctrAss ctrAs_Tsss exhausts ctor_rel_induct ctor_defss ctor_injects pre_rel_defs abs_inverses live_nesting_rel_eqs = let val B_ify_T = Term.typ_subst_atomic (As ~~ Bs); val B_ify = Term.map_types B_ify_T; val fpB_Ts = map B_ify_T fpA_Ts; val ctrBs_Tsss = map (map (map B_ify_T)) ctrAs_Tsss; val ctrBss = map (map B_ify) ctrAss; val ((((Rs, IRs), ctrAsss), ctrBsss), names_ctxt) = ctxt |> mk_Frees "R" (map2 mk_pred2T As Bs) ||>> mk_Frees "IR" (map2 mk_pred2T fpA_Ts fpB_Ts) ||>> mk_Freesss "a" ctrAs_Tsss ||>> mk_Freesss "b" ctrBs_Tsss; val prems = let fun mk_prem ctrA ctrB argAs argBs = fold_rev Logic.all (argAs @ argBs) (fold_rev (curry Logic.mk_implies) (map2 (HOLogic.mk_Trueprop oo build_rel_app names_ctxt (Rs @ IRs) fpA_Ts) argAs argBs) (HOLogic.mk_Trueprop (build_rel_app names_ctxt (Rs @ IRs) fpA_Ts (Term.list_comb (ctrA, argAs)) (Term.list_comb (ctrB, argBs))))); in flat (@{map 4} (@{map 4} mk_prem) ctrAss ctrBss ctrAsss ctrBsss) end; val goal = HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj (map2 mk_leq (map2 (build_the_rel ctxt (Rs @ IRs) []) fpA_Ts fpB_Ts) IRs)); val vars = Variable.add_free_names ctxt goal []; val rel_induct0_thm = Goal.prove_sorry ctxt vars prems goal (fn {context = ctxt, prems} => mk_rel_induct0_tac ctxt ctor_rel_induct prems (map (Thm.cterm_of ctxt) IRs) exhausts ctor_defss ctor_injects pre_rel_defs abs_inverses live_nesting_rel_eqs) |> Thm.close_derivation \<^here>; in (postproc_co_induct ctxt nn @{thm predicate2D} @{thm predicate2D_conj} rel_induct0_thm, mk_induct_attrs ctrAss) end; fun derive_induct_recs_thms_for_types plugins pre_bnfs rec_args_typess ctor_induct ctor_rec_thms live_nesting_bnfs fp_nesting_bnfs fpTs Cs Xs ctrXs_Tsss pre_abs_inverses pre_type_definitions abs_inverses ctrss ctr_defss recs rec_defs ctxt = let val ctr_Tsss = map (map (binder_types o fastype_of)) ctrss; val nn = length pre_bnfs; val ns = map length ctr_Tsss; val mss = map (map length) ctr_Tsss; val pre_map_defs = map map_def_of_bnf pre_bnfs; val pre_set_defss = map set_defs_of_bnf pre_bnfs; val live_nesting_map_ident0s = map map_ident0_of_bnf live_nesting_bnfs; val fp_nesting_map_ident0s = map map_ident0_of_bnf fp_nesting_bnfs; val fp_nesting_set_maps = maps set_map_of_bnf fp_nesting_bnfs; val fp_b_names = map base_name_of_typ fpTs; val (((ps, xsss), us'), names_ctxt) = ctxt |> mk_Frees "P" (map mk_pred1T fpTs) ||>> mk_Freesss "x" ctr_Tsss ||>> Variable.variant_fixes fp_b_names; val us = map2 (curry Free) us' fpTs; val setss_fp_nesting = map mk_bnf_sets fp_nesting_bnfs; val (induct_thms, induct_thm) = let val raw_premss = @{map 4} (@{map 3} o mk_induct_raw_prem I names_ctxt (map single Xs) setss_fp_nesting) ps ctrss ctr_Tsss ctrXs_Tsss; val concl = HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj (map2 (curry (op $)) ps us)); val goal = Library.foldr (Logic.list_implies o apfst (map (finish_induct_prem ctxt nn ps))) (raw_premss, concl); val vars = Variable.add_free_names ctxt goal []; val kksss = map (map (map (fst o snd) o #2)) raw_premss; val ctor_induct' = ctor_induct OF (map2 mk_absumprodE pre_type_definitions mss); val thm = Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, ...} => mk_induct_tac ctxt nn ns mss kksss (flat ctr_defss) ctor_induct' pre_abs_inverses abs_inverses fp_nesting_set_maps pre_set_defss) |> Thm.close_derivation \<^here>; in `(conj_dests nn) thm end; val xctrss = map2 (map2 (curry Term.list_comb)) ctrss xsss; fun mk_rec_thmss (_, x_Tssss, fss, _) recs rec_defs ctor_rec_thms = let val frecs = map (lists_bmoc fss) recs; fun mk_goal frec xctr f xs fxs = fold_rev (fold_rev Logic.all) (xs :: fss) (mk_Trueprop_eq (frec $ xctr, Term.list_comb (f, fxs))); fun maybe_tick (T, U) u f = if try (fst o HOLogic.dest_prodT) U = SOME T then Term.lambda u (HOLogic.mk_prod (u, f $ u)) else f; fun build_rec (x as Free (_, T)) U = if T = U then x else let val build_simple = indexify (perhaps (try (snd o HOLogic.dest_prodT)) o snd) Cs (fn kk => fn TU => maybe_tick TU (nth us kk) (nth frecs kk)); in build_map ctxt [] [] build_simple (T, U) $ x end; val fxsss = map2 (map2 (flat_rec_arg_args oo map2 (map o build_rec))) xsss x_Tssss; val goalss = @{map 5} (@{map 4} o mk_goal) frecs xctrss fss xsss fxsss; val tacss = @{map 4} (map ooo mk_rec_tac pre_map_defs (fp_nesting_map_ident0s @ live_nesting_map_ident0s) rec_defs) ctor_rec_thms pre_abs_inverses abs_inverses ctr_defss; fun prove goal tac = Goal.prove_sorry ctxt [] [] goal (tac o #context) |> Thm.close_derivation \<^here>; in map2 (map2 prove) goalss tacss end; val rec_thmss = mk_rec_thmss (the rec_args_typess) recs rec_defs ctor_rec_thms; in ((induct_thms, induct_thm, mk_induct_attrs ctrss), (rec_thmss, nitpicksimp_attrs @ simp_attrs)) end; fun mk_coinduct_attrs fpTs ctrss discss mss = let val fp_b_names = map base_name_of_typ fpTs; fun mk_coinduct_concls ms discs ctrs = let fun mk_disc_concl disc = [name_of_disc disc]; fun mk_ctr_concl 0 _ = [] | mk_ctr_concl _ ctr = [name_of_ctr ctr]; val disc_concls = map mk_disc_concl (fst (split_last discs)) @ [[]]; val ctr_concls = map2 mk_ctr_concl ms ctrs; in flat (map2 append disc_concls ctr_concls) end; val coinduct_cases = quasi_unambiguous_case_names (map (prefix Eq_prefix) fp_b_names); val coinduct_conclss = @{map 3} (quasi_unambiguous_case_names ooo mk_coinduct_concls) mss discss ctrss; val coinduct_case_names_attr = Attrib.case_names coinduct_cases; val coinduct_case_concl_attrs = map2 (fn casex => fn concls => Attrib.case_conclusion (casex, concls)) coinduct_cases coinduct_conclss; val common_coinduct_attrs = coinduct_case_names_attr :: coinduct_case_concl_attrs; val coinduct_attrs = Attrib.consumes 1 :: coinduct_case_names_attr :: coinduct_case_concl_attrs; in (coinduct_attrs, common_coinduct_attrs) end; fun derive_rel_coinduct_thms_for_types ctxt nn fpA_Ts ns As Bs mss (ctr_sugars : ctr_sugar list) abs_inverses abs_injects ctor_injects dtor_ctors rel_pre_defs ctor_defss dtor_rel_coinduct live_nesting_rel_eqs = let val B_ify_T = Term.typ_subst_atomic (As ~~ Bs); val fpB_Ts = map B_ify_T fpA_Ts; val (Rs, IRs, fpAs, fpBs, _) = let val fp_names = map base_name_of_typ fpA_Ts; val ((((Rs, IRs), fpAs_names), fpBs_names), names_ctxt) = ctxt |> mk_Frees "R" (map2 mk_pred2T As Bs) ||>> mk_Frees "IR" (map2 mk_pred2T fpA_Ts fpB_Ts) ||>> Variable.variant_fixes fp_names ||>> Variable.variant_fixes (map (suffix "'") fp_names); in (Rs, IRs, map2 (curry Free) fpAs_names fpA_Ts, map2 (curry Free) fpBs_names fpB_Ts, names_ctxt) end; val ((discA_tss, selA_tsss), (discB_tss, selB_tsss)) = let val discss = map #discs ctr_sugars; val selsss = map #selss ctr_sugars; fun mk_discss ts Ts = map2 (map o rapp) ts (map (map (mk_disc_or_sel Ts)) discss); fun mk_selsss ts Ts = map2 (map o map o rapp) ts (map (map (map (mk_disc_or_sel Ts))) selsss); in ((mk_discss fpAs As, mk_selsss fpAs As), (mk_discss fpBs Bs, mk_selsss fpBs Bs)) end; val prems = let fun mk_prem_ctr_concls n k discA_t selA_ts discB_t selB_ts = (if k = n then [] else [HOLogic.mk_eq (discA_t, discB_t)]) @ (case (selA_ts, selB_ts) of ([], []) => [] | (_ :: _, _ :: _) => [Library.foldr HOLogic.mk_imp (if n = 1 then [] else [discA_t, discB_t], Library.foldr1 HOLogic.mk_conj (map2 (build_rel_app ctxt (Rs @ IRs) fpA_Ts) selA_ts selB_ts))]); fun mk_prem_concl n discA_ts selA_tss discB_ts selB_tss = Library.foldr1 HOLogic.mk_conj (flat (@{map 5} (mk_prem_ctr_concls n) (1 upto n) discA_ts selA_tss discB_ts selB_tss)) handle List.Empty => \<^term>\True\; fun mk_prem IR tA tB n discA_ts selA_tss discB_ts selB_tss = fold_rev Logic.all [tA, tB] (Logic.mk_implies (HOLogic.mk_Trueprop (IR $ tA $ tB), HOLogic.mk_Trueprop (mk_prem_concl n discA_ts selA_tss discB_ts selB_tss))); in @{map 8} mk_prem IRs fpAs fpBs ns discA_tss selA_tsss discB_tss selB_tsss end; val goal = HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj (map2 mk_leq IRs (map2 (build_the_rel ctxt (Rs @ IRs) []) fpA_Ts fpB_Ts))); val vars = Variable.add_free_names ctxt goal []; val rel_coinduct0_thm = Goal.prove_sorry ctxt vars prems goal (fn {context = ctxt, prems} => mk_rel_coinduct0_tac ctxt dtor_rel_coinduct (map (Thm.cterm_of ctxt) IRs) prems (map #exhaust ctr_sugars) (map (flat o #disc_thmss) ctr_sugars) (map (flat o #sel_thmss) ctr_sugars) ctor_defss dtor_ctors ctor_injects abs_injects rel_pre_defs abs_inverses live_nesting_rel_eqs) |> Thm.close_derivation \<^here>; in (postproc_co_induct ctxt nn @{thm predicate2D} @{thm predicate2D_conj} rel_coinduct0_thm, mk_coinduct_attrs fpA_Ts (map #ctrs ctr_sugars) (map #discs ctr_sugars) mss) end; fun derive_set_induct_thms_for_types ctxt nn fpTs ctrss setss dtor_set_inducts exhausts set_pre_defs ctor_defs dtor_ctors Abs_pre_inverses = let fun mk_prems A Ps ctr_args t ctxt = (case fastype_of t of Type (type_name, innerTs) => (case bnf_of ctxt type_name of NONE => ([], ctxt) | SOME bnf => let fun seq_assm a set ctxt = let val X = HOLogic.dest_setT (range_type (fastype_of set)); val (x, ctxt') = yield_singleton (mk_Frees "x") X ctxt; val assm = mk_Trueprop_mem (x, set $ a); in (case build_binary_fun_app Ps x a of NONE => mk_prems A Ps ctr_args x ctxt' |>> map (Logic.all x o Logic.mk_implies o pair assm) | SOME f => ([Logic.all x (Logic.mk_implies (assm, Logic.mk_implies (HOLogic.mk_Trueprop f, HOLogic.mk_Trueprop (the (build_binary_fun_app Ps x ctr_args)))))], ctxt')) end; in fold_map (seq_assm t o mk_set innerTs) (sets_of_bnf bnf) ctxt |>> flat end) | T => if T = A then ([HOLogic.mk_Trueprop (the (build_binary_fun_app Ps t ctr_args))], ctxt) else ([], ctxt)); fun mk_prems_for_ctr A Ps ctr ctxt = let val (args, ctxt') = mk_Frees "z" (binder_types (fastype_of ctr)) ctxt; in fold_map (mk_prems A Ps (list_comb (ctr, args))) args ctxt' |>> map (fold_rev Logic.all args) o flat |>> (fn prems => (prems, mk_names (length prems) (name_of_ctr ctr))) end; fun mk_prems_and_concl_for_type A Ps ((fpT, ctrs), set) ctxt = let val ((x, fp), ctxt') = ctxt |> yield_singleton (mk_Frees "x") A ||>> yield_singleton (mk_Frees "a") fpT; val concl = mk_Ball (set $ fp) (Term.absfree (dest_Free x) (the (build_binary_fun_app Ps x fp))); in fold_map (mk_prems_for_ctr A Ps) ctrs ctxt' |>> split_list |>> map_prod flat flat |>> apfst (rpair concl) end; fun mk_thm ctxt fpTs ctrss sets = let val A = HOLogic.dest_setT (range_type (fastype_of (hd sets))); val (Ps, ctxt') = mk_Frees "P" (map (fn fpT => A --> fpT --> HOLogic.boolT) fpTs) ctxt; val (((prems, concl), case_names), ctxt'') = fold_map (mk_prems_and_concl_for_type A Ps) (fpTs ~~ ctrss ~~ sets) ctxt' |>> apfst split_list o split_list |>> apfst (apfst flat) |>> apfst (apsnd (Library.foldr1 HOLogic.mk_conj)) |>> apsnd flat; val vars = fold (Variable.add_free_names ctxt) (concl :: prems) []; val thm = Goal.prove_sorry ctxt vars prems (HOLogic.mk_Trueprop concl) (fn {context = ctxt, prems} => mk_set_induct0_tac ctxt (map (Thm.cterm_of ctxt'') Ps) prems dtor_set_inducts exhausts set_pre_defs ctor_defs dtor_ctors Abs_pre_inverses) |> Thm.close_derivation \<^here>; val case_names_attr = Attrib.case_names (quasi_unambiguous_case_names case_names); val induct_set_attrs = map (Attrib.internal o K o Induct.induct_pred o name_of_set) sets; in (thm, case_names_attr :: induct_set_attrs) end val consumes_attr = Attrib.consumes 1; in map (mk_thm ctxt fpTs ctrss #> nn = 1 ? map_prod (fn thm => rotate_prems ~1 (thm RS bspec)) (cons consumes_attr)) (transpose setss) end; fun mk_coinduct_strong_thm coind rel_eqs rel_monos mk_vimage2p ctxt = let val n = Thm.nprems_of coind; val m = Thm.nprems_of (hd rel_monos) - n; fun mk_inst phi = (phi, Thm.cterm_of ctxt (mk_union (Var phi, HOLogic.eq_const (fst (dest_pred2T (#2 phi)))))); val insts = Term.add_vars (Thm.prop_of coind) [] |> rev |> take n |> map mk_inst; fun mk_unfold rel_eq rel_mono = let val eq = iffD2 OF [rel_eq RS @{thm predicate2_eqD}, refl]; val mono = rel_mono OF (replicate m @{thm order_refl} @ replicate n @{thm eq_subset}); in mk_vimage2p (eq RS (mono RS @{thm predicate2D})) RS eqTrueI end; val unfolds = map2 mk_unfold rel_eqs rel_monos @ @{thms sup_fun_def sup_bool_def imp_disjL all_conj_distrib subst_eq_imp simp_thms(18,21,35)}; in Thm.instantiate ([], insts) coind |> unfold_thms ctxt unfolds end; fun derive_coinduct_thms_for_types ctxt strong alter_r pre_bnfs dtor_coinduct dtor_ctors live_nesting_bnfs fpTs Xs ctrXs_Tsss ns pre_abs_inverses abs_inverses mk_vimage2p ctr_defss (ctr_sugars : ctr_sugar list) = let val nn = length pre_bnfs; val pre_rel_defs = map rel_def_of_bnf pre_bnfs; val live_nesting_rel_eqs = map rel_eq_of_bnf live_nesting_bnfs; val fp_b_names = map base_name_of_typ fpTs; val discss = map #discs ctr_sugars; val selsss = map #selss ctr_sugars; val exhausts = map #exhaust ctr_sugars; val disc_thmsss = map #disc_thmss ctr_sugars; val sel_thmsss = map #sel_thmss ctr_sugars; val (((rs, us'), vs'), _) = ctxt |> mk_Frees "R" (map (fn T => mk_pred2T T T) fpTs) ||>> Variable.variant_fixes fp_b_names ||>> Variable.variant_fixes (map (suffix "'") fp_b_names); val us = map2 (curry Free) us' fpTs; val udiscss = map2 (map o rapp) us discss; val uselsss = map2 (map o map o rapp) us selsss; val vs = map2 (curry Free) vs' fpTs; val vdiscss = map2 (map o rapp) vs discss; val vselsss = map2 (map o map o rapp) vs selsss; val uvrs = @{map 3} (fn r => fn u => fn v => r $ u $ v) rs us vs; val uv_eqs = map2 (curry HOLogic.mk_eq) us vs; val strong_rs = @{map 4} (fn u => fn v => fn uvr => fn uv_eq => fold_rev Term.lambda [u, v] (HOLogic.mk_disj (uvr, uv_eq))) us vs uvrs uv_eqs; val concl = HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj (@{map 3} (fn uvr => fn u => fn v => HOLogic.mk_imp (uvr, HOLogic.mk_eq (u, v))) uvrs us vs)) fun mk_goal rs0' = Logic.list_implies (@{map 9} (mk_coinduct_prem ctxt (map single Xs) (map single fpTs) (map alter_r rs0')) uvrs us vs ns udiscss uselsss vdiscss vselsss ctrXs_Tsss, concl); val goals = map mk_goal ([rs] @ (if strong then [strong_rs] else [])); fun prove dtor_coinduct' goal = Variable.add_free_names ctxt goal [] |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, ...} => mk_coinduct_tac ctxt live_nesting_rel_eqs nn ns dtor_coinduct' pre_rel_defs pre_abs_inverses abs_inverses dtor_ctors exhausts ctr_defss disc_thmsss sel_thmsss)) |> Thm.close_derivation \<^here>; val rel_eqs = map rel_eq_of_bnf pre_bnfs; val rel_monos = map rel_mono_of_bnf pre_bnfs; val dtor_coinducts = [dtor_coinduct] @ (if strong then [mk_coinduct_strong_thm dtor_coinduct rel_eqs rel_monos mk_vimage2p ctxt] else []); in map2 (postproc_co_induct ctxt nn mp @{thm conj_commute[THEN iffD1]} oo prove) dtor_coinducts goals end; fun derive_coinduct_corecs_thms_for_types ctxt pre_bnfs (x, cs, cpss, (((pgss, _, _, _), cqgsss), _)) dtor_coinduct dtor_injects dtor_ctors dtor_corec_thms live_nesting_bnfs fpTs Cs Xs ctrXs_Tsss kss mss ns pre_abs_inverses abs_inverses mk_vimage2p ctr_defss (ctr_sugars : ctr_sugar list) corecs corec_defs = let fun mk_ctor_dtor_corec_thm dtor_inject dtor_ctor corec = iffD1 OF [dtor_inject, trans OF [corec, dtor_ctor RS sym]]; val ctor_dtor_corec_thms = @{map 3} mk_ctor_dtor_corec_thm dtor_injects dtor_ctors dtor_corec_thms; val pre_map_defs = map map_def_of_bnf pre_bnfs; val live_nesting_map_ident0s = map map_ident0_of_bnf live_nesting_bnfs; val fp_b_names = map base_name_of_typ fpTs; val ctrss = map #ctrs ctr_sugars; val discss = map #discs ctr_sugars; val selsss = map #selss ctr_sugars; val disc_thmsss = map #disc_thmss ctr_sugars; val discIss = map #discIs ctr_sugars; val sel_thmsss = map #sel_thmss ctr_sugars; val coinduct_thms_pairs = derive_coinduct_thms_for_types ctxt true I pre_bnfs dtor_coinduct dtor_ctors live_nesting_bnfs fpTs Xs ctrXs_Tsss ns pre_abs_inverses abs_inverses mk_vimage2p ctr_defss ctr_sugars; fun mk_maybe_not pos = not pos ? HOLogic.mk_not; val gcorecs = map (lists_bmoc pgss) corecs; val corec_thmss = let val (us', _) = ctxt |> Variable.variant_fixes fp_b_names; val us = map2 (curry Free) us' fpTs; fun mk_goal c cps gcorec n k ctr m cfs' = fold_rev (fold_rev Logic.all) ([c] :: pgss) (Logic.list_implies (seq_conds (HOLogic.mk_Trueprop oo mk_maybe_not) n k cps, mk_Trueprop_eq (gcorec $ c, Term.list_comb (ctr, take m cfs')))); val mk_U = typ_subst_nonatomic (map2 (fn C => fn fpT => (mk_sumT (fpT, C), fpT)) Cs fpTs); fun tack (c, u) f = let val x' = Free (x, mk_sumT (fastype_of u, fastype_of c)) in Term.lambda x' (mk_case_sum (Term.lambda u u, Term.lambda c (f $ c)) $ x') end; fun build_corec cqg = let val T = fastype_of cqg in if exists_subtype_in Cs T then let val U = mk_U T; val build_simple = indexify fst (map2 (curry mk_sumT) fpTs Cs) (fn kk => fn _ => tack (nth cs kk, nth us kk) (nth gcorecs kk)); in build_map ctxt [] [] build_simple (T, U) $ cqg end else cqg end; val cqgsss' = map (map (map build_corec)) cqgsss; val goalss = @{map 8} (@{map 4} oooo mk_goal) cs cpss gcorecs ns kss ctrss mss cqgsss'; val tacss = @{map 4} (map ooo mk_corec_tac corec_defs live_nesting_map_ident0s) ctor_dtor_corec_thms pre_map_defs abs_inverses ctr_defss; fun prove goal tac = Goal.prove_sorry ctxt [] [] goal (tac o #context) |> Thm.close_derivation \<^here>; in map2 (map2 prove) goalss tacss |> map (map (unfold_thms ctxt @{thms case_sum_if})) end; val corec_disc_iff_thmss = let fun mk_goal c cps gcorec n k disc = mk_Trueprop_eq (disc $ (gcorec $ c), if n = 1 then \<^const>\True\ else Library.foldr1 HOLogic.mk_conj (seq_conds mk_maybe_not n k cps)); val goalss = @{map 6} (map2 oooo mk_goal) cs cpss gcorecs ns kss discss; fun mk_case_split' cp = Thm.instantiate' [] [SOME (Thm.cterm_of ctxt cp)] @{thm case_split}; val case_splitss' = map (map mk_case_split') cpss; val tacss = @{map 3} (map oo mk_corec_disc_iff_tac) case_splitss' corec_thmss disc_thmsss; fun prove goal tac = Variable.add_free_names ctxt goal [] |> (fn vars => Goal.prove_sorry ctxt vars [] goal (tac o #context)) |> Thm.close_derivation \<^here>; fun proves [_] [_] = [] | proves goals tacs = map2 prove goals tacs; in map2 proves goalss tacss end; fun mk_corec_disc_thms corecs discIs = map (op RS) (corecs ~~ discIs); val corec_disc_thmss = map2 mk_corec_disc_thms corec_thmss discIss; fun mk_corec_sel_thm corec_thm sel sel_thm = let val (domT, ranT) = dest_funT (fastype_of sel); val arg_cong' = Thm.instantiate' (map (SOME o Thm.ctyp_of ctxt) [domT, ranT]) [NONE, NONE, SOME (Thm.cterm_of ctxt sel)] arg_cong |> Thm.varifyT_global; val sel_thm' = sel_thm RSN (2, trans); in corec_thm RS arg_cong' RS sel_thm' end; fun mk_corec_sel_thms corec_thmss = @{map 3} (@{map 3} (map2 o mk_corec_sel_thm)) corec_thmss selsss sel_thmsss; val corec_sel_thmsss = mk_corec_sel_thms corec_thmss; in ((coinduct_thms_pairs, mk_coinduct_attrs fpTs (map #ctrs ctr_sugars) (map #discs ctr_sugars) mss), corec_thmss, corec_disc_thmss, (corec_disc_iff_thmss, simp_attrs), (corec_sel_thmsss, simp_attrs)) end; fun define_co_datatypes prepare_plugins prepare_constraint prepare_typ prepare_term fp construct_fp ((raw_plugins, discs_sels0), specs) lthy = let val plugins = prepare_plugins lthy raw_plugins; val discs_sels = discs_sels0 orelse fp = Greatest_FP; val nn = length specs; val fp_bs = map type_binding_of_spec specs; val fp_b_names = map Binding.name_of fp_bs; val fp_common_name = mk_common_name fp_b_names; val map_bs = map map_binding_of_spec specs; val rel_bs = map rel_binding_of_spec specs; val pred_bs = map pred_binding_of_spec specs; fun prepare_type_arg (_, (ty, c)) = let val TFree (s, _) = prepare_typ lthy ty in TFree (s, prepare_constraint lthy c) end; val Ass0 = map (map prepare_type_arg o type_args_named_constrained_of_spec) specs; val unsorted_Ass0 = map (map (resort_tfree_or_tvar \<^sort>\type\)) Ass0; val unsorted_As = Library.foldr1 (merge_type_args fp) unsorted_Ass0; val num_As = length unsorted_As; val set_boss = map (map fst o type_args_named_constrained_of_spec) specs; val set_bss = map (map (the_default Binding.empty)) set_boss; fun add_fake_type spec = Typedecl.basic_typedecl {final = true} (type_binding_of_spec spec, num_As, Mixfix.reset_pos (mixfix_of_spec spec)); val (fake_T_names, fake_lthy) = fold_map add_fake_type specs lthy; val qsoty = quote o Syntax.string_of_typ fake_lthy; val _ = (case Library.duplicates (op =) unsorted_As of [] => () | A :: _ => error ("Duplicate type parameter " ^ qsoty A ^ " in " ^ co_prefix fp ^ "datatype specification")); val bad_args = map (Logic.type_map (singleton (Variable.polymorphic lthy))) unsorted_As |> filter_out Term.is_TVar; val _ = null bad_args orelse error ("Locally fixed type argument " ^ qsoty (hd bad_args) ^ " in " ^ co_prefix fp ^ "datatype specification"); val mixfixes = map mixfix_of_spec specs; val _ = (case Library.duplicates Binding.eq_name fp_bs of [] => () | b :: _ => error ("Duplicate type name declaration " ^ quote (Binding.name_of b))); val mx_ctr_specss = map mixfixed_ctr_specs_of_spec specs; val ctr_specss = map (map fst) mx_ctr_specss; val ctr_mixfixess = map (map snd) mx_ctr_specss; val disc_bindingss = map (map disc_of_ctr_spec) ctr_specss; val ctr_bindingss = map2 (fn fp_b_name => map (Binding.qualify false fp_b_name o ctr_of_ctr_spec)) fp_b_names ctr_specss; val ctr_argsss = map (map args_of_ctr_spec) ctr_specss; val sel_bindingsss = map (map (map fst)) ctr_argsss; val fake_ctr_Tsss0 = map (map (map (prepare_typ fake_lthy o snd))) ctr_argsss; val raw_sel_default_eqss = map sel_default_eqs_of_spec specs; val (As :: _) :: fake_ctr_Tsss = burrow (burrow (Syntax.check_typs fake_lthy)) (Ass0 :: fake_ctr_Tsss0); val As' = map dest_TFree As; val rhs_As' = fold (fold (fold Term.add_tfreesT)) fake_ctr_Tsss []; val _ = (case subtract (op =) As' rhs_As' of [] => () | extras => error ("Extra type variables on right-hand side: " ^ commas (map (qsoty o TFree) extras))); val fake_Ts = map (fn s => Type (s, As)) fake_T_names; val ((((Bs0, Cs), Es), Xs), _) = lthy |> fold (Variable.declare_typ o resort_tfree_or_tvar dummyS) unsorted_As |> mk_TFrees num_As ||>> mk_TFrees nn ||>> mk_TFrees nn ||>> variant_tfrees fp_b_names; fun eq_fpT_check (T as Type (s, Ts)) (T' as Type (s', Ts')) = s = s' andalso (Ts = Ts' orelse error ("Wrong type arguments in " ^ co_prefix fp ^ "recursive type " ^ qsoty T ^ " (expected " ^ qsoty T' ^ ")")) | eq_fpT_check _ _ = false; fun freeze_fp (T as Type (s, Ts)) = (case find_index (eq_fpT_check T) fake_Ts of ~1 => Type (s, map freeze_fp Ts) | kk => nth Xs kk) | freeze_fp T = T; val unfreeze_fp = Term.typ_subst_atomic (Xs ~~ fake_Ts); val ctrXs_Tsss = map (map (map freeze_fp)) fake_ctr_Tsss; val ctrXs_repTs = map mk_sumprodT_balanced ctrXs_Tsss; val _ = let fun add_deps i = fold (fn T => fold_index (fn (j, X) => (i <> j andalso exists_subtype_in [X] T) ? insert (op =) (i, j)) Xs); val add_missing_nodes = fold (AList.default (op =) o rpair []) (0 upto nn - 1); val deps = fold_index (uncurry (fold o add_deps)) ctrXs_Tsss [] |> AList.group (op =) |> add_missing_nodes; val G = Int_Graph.make (map (apfst (rpair ())) deps); val sccs = map (sort int_ord) (Int_Graph.strong_conn G); val str_of_scc = prefix (co_prefix fp ^ "datatype ") o space_implode " and " o map (suffix " = \" o Long_Name.base_name); fun warn [_] = () | warn sccs = warning ("Defined types not fully mutually " ^ co_prefix fp ^ "recursive\n\ \Alternative specification:\n" ^ cat_lines (map (prefix " " o str_of_scc o map (nth fp_b_names)) sccs)); in warn (order_strong_conn (op =) Int_Graph.make Int_Graph.topological_order deps sccs) end; val killed_As = map_filter (fn (A, set_bos) => if exists is_none set_bos then SOME A else NONE) (As ~~ transpose set_boss); val (((pre_bnfs, absT_infos), _), (fp_res as {bnfs = fp_bnfs as any_fp_bnf :: _, ctors = ctors0, dtors = dtors0, xtor_co_recs = xtor_co_recs0, xtor_co_induct, dtor_ctors, ctor_dtors, ctor_injects, dtor_injects, xtor_maps, xtor_setss, xtor_rels, xtor_co_rec_thms, xtor_rel_co_induct, dtor_set_inducts, xtor_co_rec_transfers, xtor_co_rec_o_maps, ...}, lthy)) = fixpoint_bnf false I (construct_fp mixfixes map_bs rel_bs pred_bs set_bss) fp_bs (map dest_TFree As) (map dest_TFree killed_As) (map dest_TFree Xs) ctrXs_repTs empty_comp_cache lthy handle BAD_DEAD (X, X_backdrop) => (case X_backdrop of Type (bad_tc, _) => let val fake_T = qsoty (unfreeze_fp X); val fake_T_backdrop = qsoty (unfreeze_fp X_backdrop); fun register_hint () = "\nUse the " ^ quote (#1 \<^command_keyword>\bnf\) ^ " command to register " ^ quote bad_tc ^ " as a bounded natural functor to allow nested (co)recursion through \ \it"; in if is_some (bnf_of lthy bad_tc) orelse is_some (fp_sugar_of lthy bad_tc) then error ("Inadmissible " ^ co_prefix fp ^ "recursive occurrence of type " ^ fake_T ^ " in type expression " ^ fake_T_backdrop) else if is_some (Old_Datatype_Data.get_info (Proof_Context.theory_of lthy) bad_tc) then error ("Unsupported " ^ co_prefix fp ^ "recursive occurrence of type " ^ fake_T ^ " via the old-style datatype " ^ quote bad_tc ^ " in type expression " ^ fake_T_backdrop ^ register_hint ()) else error ("Unsupported " ^ co_prefix fp ^ "recursive occurrence of type " ^ fake_T ^ " via type constructor " ^ quote bad_tc ^ " in type expression " ^ fake_T_backdrop ^ register_hint ()) end); val time = time lthy; val timer = time (Timer.startRealTimer ()); val fp_nesting_bnfs = nesting_bnfs lthy ctrXs_Tsss Xs; val live_nesting_bnfs = nesting_bnfs lthy ctrXs_Tsss As; val pre_map_defs = map map_def_of_bnf pre_bnfs; val pre_set_defss = map set_defs_of_bnf pre_bnfs; val pre_rel_defs = map rel_def_of_bnf pre_bnfs; val fp_nesting_set_maps = maps set_map_of_bnf fp_nesting_bnfs; val fp_nesting_rel_eq_onps = map rel_eq_onp_of_bnf fp_nesting_bnfs; val live_nesting_map_id0s = map map_id0_of_bnf live_nesting_bnfs; val live_nesting_map_ident0s = map map_ident0_of_bnf live_nesting_bnfs; val live_nesting_set_maps = maps set_map_of_bnf live_nesting_bnfs; val live_nesting_rel_eqs = map rel_eq_of_bnf live_nesting_bnfs; val live_nesting_rel_eq_onps = map rel_eq_onp_of_bnf live_nesting_bnfs; val liveness = liveness_of_fp_bnf num_As any_fp_bnf; val live = live_of_bnf any_fp_bnf; val _ = if live = 0 andalso exists (not o Binding.is_empty) (map_bs @ rel_bs @ pred_bs) then warning "Map function, relator, and predicator names ignored" else (); val Bs = @{map 3} (fn alive => fn A as TFree (_, S) => fn B => if alive then resort_tfree_or_tvar S B else A) liveness As Bs0; val B_ify_T = Term.typ_subst_atomic (As ~~ Bs); val B_ify = Term.map_types B_ify_T; val live_AsBs = filter (op <>) (As ~~ Bs); val abss = map #abs absT_infos; val reps = map #rep absT_infos; val absTs = map #absT absT_infos; val repTs = map #repT absT_infos; val abs_injects = map #abs_inject absT_infos; val abs_inverses = map #abs_inverse absT_infos; val type_definitions = map #type_definition absT_infos; val ctors = map (mk_ctor As) ctors0; val dtors = map (mk_dtor As) dtors0; val fpTs = map (domain_type o fastype_of) dtors; val fpBTs = map B_ify_T fpTs; val real_unfreeze_fp = Term.typ_subst_atomic (Xs ~~ fpTs); val ctr_Tsss = map (map (map real_unfreeze_fp)) ctrXs_Tsss; val ns = map length ctr_Tsss; val kss = map (fn n => 1 upto n) ns; val mss = map (map length) ctr_Tsss; val (xtor_co_recs, recs_args_types, corecs_args_types) = mk_co_recs_prelims lthy fp ctr_Tsss fpTs Cs absTs repTs ns mss xtor_co_recs0; fun define_ctrs_dtrs_for_type_etc fp_bnf fp_b fpT C E ctor dtor xtor_co_rec ctor_dtor dtor_ctor ctor_inject pre_map_def pre_set_defs pre_rel_def fp_map_thm fp_set_thms fp_rel_thm n ks ms abs abs_inject type_definition ctr_bindings ctr_mixfixes ctr_Tss disc_bindings sel_bindingss raw_sel_default_eqs lthy = let val fp_b_name = Binding.name_of fp_b; val ((xss, ctrs0, ctor_iff_dtor_thm, ctr_defs), lthy) = define_ctrs_dtrs_for_type fp_b_name fpT ctor dtor ctor_dtor dtor_ctor n ks abs ctr_bindings ctr_mixfixes ctr_Tss lthy; val ctrs = map (mk_ctr As) ctrs0; val sel_default_eqs = let val sel_Tss = map (map (curry (op -->) fpT)) ctr_Tss; val sel_bTs = flat sel_bindingss ~~ flat sel_Tss |> filter_out (Binding.is_empty o fst) |> distinct (Binding.eq_name o apply2 fst); val sel_default_lthy = fake_local_theory_for_sel_defaults sel_bTs lthy in map (prepare_term sel_default_lthy) raw_sel_default_eqs end; fun mk_binding pre = Binding.qualify false fp_b_name (Binding.prefix_name (pre ^ "_") fp_b); fun massage_res (ctr_sugar, maps_sets_rels) = (maps_sets_rels, (ctrs, xss, ctor_iff_dtor_thm, ctr_defs, ctr_sugar)); in (wrap_ctrs plugins fp discs_sels fp_b_name ctor_inject n ms abs_inject type_definition disc_bindings sel_bindingss sel_default_eqs ctrs0 ctor_iff_dtor_thm ctr_defs #> (fn (ctr_sugar, lthy) => derive_map_set_rel_pred_thms plugins fp live As Bs C E abs_inverses ctr_defs fp_nesting_set_maps fp_nesting_rel_eq_onps live_nesting_map_id0s live_nesting_set_maps live_nesting_rel_eqs live_nesting_rel_eq_onps [] fp_b_name fp_bnf fp_bnfs fpT ctor ctor_dtor dtor_ctor pre_map_def pre_set_defs pre_rel_def fp_map_thm fp_set_thms fp_rel_thm [] [] [] ctr_Tss ctr_sugar lthy |>> pair ctr_sugar) ##>> (if fp = Least_FP then define_rec (the recs_args_types) mk_binding fpTs Cs reps else define_corec (the corecs_args_types) mk_binding fpTs Cs abss) xtor_co_rec #>> apfst massage_res, lthy) end; fun wrap_ctrs_derive_map_set_rel_pred_thms_define_co_rec_for_types (wrap_one_etcs, lthy) = fold_map I wrap_one_etcs lthy |>> apsnd split_list o apfst (apsnd @{split_list 5} o apfst @{split_list 17} o split_list) o split_list; fun mk_simp_thms ({injects, distincts, case_thms, ...} : ctr_sugar) co_recs map_thms rel_injects rel_distincts set_thmss = injects @ distincts @ case_thms @ co_recs @ map_thms @ rel_injects @ rel_distincts @ set_thmss; fun mk_co_rec_transfer_goals lthy co_recs = let val BE_ify = Term.subst_atomic_types (live_AsBs @ (Cs ~~ Es)); val ((Rs, Ss), names_lthy) = lthy |> mk_Frees "R" (map (uncurry mk_pred2T) live_AsBs) ||>> mk_Frees "S" (map2 mk_pred2T Cs Es); val co_recBs = map BE_ify co_recs; in (Rs, Ss, map2 (mk_parametricity_goal lthy (Rs @ Ss)) co_recs co_recBs, names_lthy) end; fun derive_rec_transfer_thms lthy recs rec_defs (SOME (_, _, _, xsssss)) = let val (Rs, Ss, goals, _) = mk_co_rec_transfer_goals lthy recs; val goal = Logic.mk_conjunction_balanced goals; val vars = Variable.add_free_names lthy goal []; in Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, prems = _} => mk_rec_transfer_tac ctxt nn ns (map (Thm.cterm_of ctxt) Ss) (map (Thm.cterm_of ctxt) Rs) xsssss rec_defs xtor_co_rec_transfers pre_rel_defs live_nesting_rel_eqs) |> Thm.close_derivation \<^here> |> Conjunction.elim_balanced nn end; fun derive_rec_o_map_thmss lthy recs rec_defs = if live = 0 then replicate nn [] else let fun variant_names n pre = fst (Variable.variant_fixes (replicate n pre) lthy); val maps0 = map map_of_bnf fp_bnfs; val f_names = variant_names num_As "f"; val fs = map2 (curry Free) f_names (map (op -->) (As ~~ Bs)); val live_gs = AList.find (op =) (fs ~~ liveness) true; val gmaps = map (fn map0 => Term.list_comb (mk_map live As Bs map0, live_gs)) maps0; val rec_arg_Ts = binder_fun_types (hd (map fastype_of recs)); val num_rec_args = length rec_arg_Ts; val g_Ts = map B_ify_T rec_arg_Ts; val g_names = variant_names num_rec_args "g"; val gs = map2 (curry Free) g_names g_Ts; val grecs = map (fn recx => Term.list_comb (Term.map_types B_ify_T recx, gs)) recs; val rec_o_map_lhss = map2 (curry HOLogic.mk_comp) grecs gmaps; val ABfs = (As ~~ Bs) ~~ fs; fun mk_rec_arg_arg (x as Free (_, T)) = let val U = B_ify_T T in if T = U then x else build_map lthy [] [] (the o AList.lookup (op =) ABfs) (T, U) $ x end; fun mk_rec_o_map_arg rec_arg_T h = let val x_Ts = binder_types rec_arg_T; val m = length x_Ts; val x_names = variant_names m "x"; val xs = map2 (curry Free) x_names x_Ts; val xs' = map mk_rec_arg_arg xs; in fold_rev Term.lambda xs (Term.list_comb (h, xs')) end; fun mk_rec_o_map_rhs recx = let val args = map2 mk_rec_o_map_arg rec_arg_Ts gs in Term.list_comb (recx, args) end; val rec_o_map_rhss = map mk_rec_o_map_rhs recs; val rec_o_map_goals = map2 (fold_rev (fold_rev Logic.all) [fs, gs] o HOLogic.mk_Trueprop oo curry HOLogic.mk_eq) rec_o_map_lhss rec_o_map_rhss; val rec_o_map_thms = @{map 3} (fn goal => fn rec_def => fn ctor_rec_o_map => Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, ...} => mk_co_rec_o_map_tac ctxt rec_def pre_map_defs live_nesting_map_ident0s abs_inverses ctor_rec_o_map) |> Thm.close_derivation \<^here>) rec_o_map_goals rec_defs xtor_co_rec_o_maps; in map single rec_o_map_thms end; fun derive_note_induct_recs_thms_for_types ((((map_thmss, map_disc_iffss, map_selsss, rel_injectss, rel_distinctss, rel_selss, rel_intross, rel_casess, pred_injectss, set_thmss, set_selsssss, set_introsssss, set_casess, ctr_transferss, case_transferss, disc_transferss, sel_transferss), (ctrss, _, ctor_iff_dtors, ctr_defss, ctr_sugars)), (recs, rec_defs)), lthy) = let val ((induct_thms, induct_thm, induct_attrs), (rec_thmss, rec_attrs)) = derive_induct_recs_thms_for_types plugins pre_bnfs recs_args_types xtor_co_induct xtor_co_rec_thms live_nesting_bnfs fp_nesting_bnfs fpTs Cs Xs ctrXs_Tsss abs_inverses type_definitions abs_inverses ctrss ctr_defss recs rec_defs lthy; val rec_transfer_thmss = map single (derive_rec_transfer_thms lthy recs rec_defs recs_args_types); val induct_type_attr = Attrib.internal o K o Induct.induct_type; val induct_pred_attr = Attrib.internal o K o Induct.induct_pred; val ((rel_induct_thmss, common_rel_induct_thms), (rel_induct_attrs, common_rel_induct_attrs)) = if live = 0 then ((replicate nn [], []), ([], [])) else let val ((rel_induct_thms, common_rel_induct_thm), rel_induct_attrs) = derive_rel_induct_thms_for_types lthy nn fpTs As Bs ctrss ctr_Tsss (map #exhaust ctr_sugars) xtor_rel_co_induct ctr_defss ctor_injects pre_rel_defs abs_inverses live_nesting_rel_eqs; in ((map single rel_induct_thms, single common_rel_induct_thm), (rel_induct_attrs, rel_induct_attrs)) end; val rec_o_map_thmss = derive_rec_o_map_thmss lthy recs rec_defs; val simp_thmss = @{map 6} mk_simp_thms ctr_sugars rec_thmss map_thmss rel_injectss rel_distinctss set_thmss; val common_notes = (if nn > 1 then [(inductN, [induct_thm], K induct_attrs), (rel_inductN, common_rel_induct_thms, K common_rel_induct_attrs)] else []) |> massage_simple_notes fp_common_name; val notes = [(inductN, map single induct_thms, fn T_name => induct_attrs @ [induct_type_attr T_name]), (recN, rec_thmss, K rec_attrs), (rec_o_mapN, rec_o_map_thmss, K []), (rec_transferN, rec_transfer_thmss, K []), (rel_inductN, rel_induct_thmss, K (rel_induct_attrs @ [induct_pred_attr ""])), (simpsN, simp_thmss, K [])] |> massage_multi_notes fp_b_names fpTs; in lthy - |> Spec_Rules.add Spec_Rules.equational (recs, flat rec_thmss) + |> Spec_Rules.add "" Spec_Rules.equational recs (flat rec_thmss) |> plugins code_plugin ? Code.declare_default_eqns (map (rpair true) (flat rec_thmss)) |> Local_Theory.notes (common_notes @ notes) (* for "datatype_realizer.ML": *) |>> name_noted_thms (fst (dest_Type (hd fpTs)) ^ implode (map (prefix "_") (tl fp_b_names))) inductN |-> interpret_bnfs_register_fp_sugars plugins fpTs fpBTs Xs Least_FP pre_bnfs absT_infos fp_nesting_bnfs live_nesting_bnfs fp_res ctrXs_Tsss ctor_iff_dtors ctr_defss ctr_sugars recs rec_defs map_thmss [induct_thm] (map single induct_thms) rec_thmss (replicate nn []) (replicate nn []) rel_injectss rel_distinctss map_disc_iffss map_selsss rel_selss rel_intross rel_casess pred_injectss set_thmss set_selsssss set_introsssss set_casess ctr_transferss case_transferss disc_transferss sel_transferss (replicate nn []) (replicate nn []) rec_transfer_thmss common_rel_induct_thms rel_induct_thmss [] (replicate nn []) rec_o_map_thmss end; fun derive_corec_transfer_thms lthy corecs corec_defs = let val (Rs, Ss, goals, _) = mk_co_rec_transfer_goals lthy corecs; val (_, _, _, (((pgss, pss, qssss, gssss), _), _)) = the corecs_args_types; val goal = Logic.mk_conjunction_balanced goals; val vars = Variable.add_free_names lthy goal []; in Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, prems = _} => mk_corec_transfer_tac ctxt (map (Thm.cterm_of ctxt) Ss) (map (Thm.cterm_of ctxt) Rs) type_definitions corec_defs xtor_co_rec_transfers pre_rel_defs live_nesting_rel_eqs (flat pgss) pss qssss gssss) |> Thm.close_derivation \<^here> |> Conjunction.elim_balanced (length goals) end; fun derive_map_o_corec_thmss lthy0 lthy2 corecs corec_defs = if live = 0 then replicate nn [] else let fun variant_names n pre = fst (Variable.variant_fixes (replicate n pre) lthy0); val maps0 = map map_of_bnf fp_bnfs; val f_names = variant_names num_As "f"; val fs = map2 (curry Free) f_names (map (op -->) (As ~~ Bs)); val live_fs = AList.find (op =) (fs ~~ liveness) true; val fmaps = map (fn map0 => Term.list_comb (mk_map live As Bs map0, live_fs)) maps0; val corec_arg_Ts = binder_fun_types (hd (map fastype_of corecs)); val num_rec_args = length corec_arg_Ts; val g_names = variant_names num_rec_args "g"; val gs = map2 (curry Free) g_names corec_arg_Ts; val gcorecs = map (fn corecx => Term.list_comb (corecx, gs)) corecs; val map_o_corec_lhss = map2 (curry HOLogic.mk_comp) fmaps gcorecs; val ABfs = (As ~~ Bs) ~~ fs; fun mk_map_o_corec_arg corec_argB_T g = let val T = range_type (fastype_of g); val U = range_type corec_argB_T; in if T = U then g else HOLogic.mk_comp (build_map lthy2 [] [] (the o AList.lookup (op =) ABfs) (T, U), g) end; fun mk_map_o_corec_rhs corecx = let val args = map2 (mk_map_o_corec_arg o B_ify_T) corec_arg_Ts gs in Term.list_comb (B_ify corecx, args) end; val map_o_corec_rhss = map mk_map_o_corec_rhs corecs; val map_o_corec_goals = map2 (fold_rev (fold_rev Logic.all) [fs, gs] o HOLogic.mk_Trueprop oo curry HOLogic.mk_eq) map_o_corec_lhss map_o_corec_rhss; val map_o_corec_thms = @{map 3} (fn goal => fn corec_def => fn dtor_map_o_corec => Goal.prove_sorry lthy2 [] [] goal (fn {context = ctxt, ...} => mk_co_rec_o_map_tac ctxt corec_def pre_map_defs live_nesting_map_ident0s abs_inverses dtor_map_o_corec) |> Thm.close_derivation \<^here>) map_o_corec_goals corec_defs xtor_co_rec_o_maps; in map single map_o_corec_thms end; fun derive_note_coinduct_corecs_thms_for_types ((((map_thmss, map_disc_iffss, map_selsss, rel_injectss, rel_distinctss, rel_selss, rel_intross, rel_casess, pred_injectss, set_thmss, set_selsssss, set_introsssss, set_casess, ctr_transferss, case_transferss, disc_transferss, sel_transferss), (_, _, ctor_iff_dtors, ctr_defss, ctr_sugars)), (corecs, corec_defs)), lthy) = let val (([(coinduct_thms, coinduct_thm), (coinduct_strong_thms, coinduct_strong_thm)], (coinduct_attrs, common_coinduct_attrs)), corec_thmss, corec_disc_thmss, (corec_disc_iff_thmss, corec_disc_iff_attrs), (corec_sel_thmsss, corec_sel_attrs)) = derive_coinduct_corecs_thms_for_types lthy pre_bnfs (the corecs_args_types) xtor_co_induct dtor_injects dtor_ctors xtor_co_rec_thms live_nesting_bnfs fpTs Cs Xs ctrXs_Tsss kss mss ns abs_inverses abs_inverses I ctr_defss ctr_sugars corecs corec_defs; fun distinct_prems ctxt thm = Goal.prove (*no sorry*) ctxt [] [] (thm |> Thm.prop_of |> Logic.strip_horn |>> distinct (op aconv) |> Logic.list_implies) (fn _ => HEADGOAL (cut_tac thm THEN' assume_tac ctxt) THEN ALLGOALS eq_assume_tac); fun eq_ifIN _ [thm] = thm | eq_ifIN ctxt (thm :: thms) = distinct_prems ctxt (@{thm eq_ifI} OF (map (unfold_thms ctxt @{thms atomize_imp[of _ "t = u" for t u]}) [thm, eq_ifIN ctxt thms])); val corec_code_thms = map (eq_ifIN lthy) corec_thmss; val corec_sel_thmss = map flat corec_sel_thmsss; val coinduct_type_attr = Attrib.internal o K o Induct.coinduct_type; val coinduct_pred_attr = Attrib.internal o K o Induct.coinduct_pred; val flat_corec_thms = append oo append; val corec_transfer_thmss = map single (derive_corec_transfer_thms lthy corecs corec_defs); val ((rel_coinduct_thmss, common_rel_coinduct_thms), (rel_coinduct_attrs, common_rel_coinduct_attrs)) = if live = 0 then ((replicate nn [], []), ([], [])) else let val ((rel_coinduct_thms, common_rel_coinduct_thm), (rel_coinduct_attrs, common_rel_coinduct_attrs)) = derive_rel_coinduct_thms_for_types lthy nn fpTs ns As Bs mss ctr_sugars abs_inverses abs_injects ctor_injects dtor_ctors pre_rel_defs ctr_defss xtor_rel_co_induct live_nesting_rel_eqs; in ((map single rel_coinduct_thms, single common_rel_coinduct_thm), (rel_coinduct_attrs, common_rel_coinduct_attrs)) end; val map_o_corec_thmss = derive_map_o_corec_thmss lthy lthy corecs corec_defs; val (set_induct_thms, set_induct_attrss) = derive_set_induct_thms_for_types lthy nn fpTs (map #ctrs ctr_sugars) (map (map (mk_set As)) (map sets_of_bnf fp_bnfs)) dtor_set_inducts (map #exhaust ctr_sugars) (flat pre_set_defss) (flat ctr_defss) dtor_ctors abs_inverses |> split_list; val simp_thmss = @{map 6} mk_simp_thms ctr_sugars (@{map 3} flat_corec_thms corec_disc_thmss corec_disc_iff_thmss corec_sel_thmss) map_thmss rel_injectss rel_distinctss set_thmss; val common_notes = (set_inductN, set_induct_thms, nth set_induct_attrss) :: (if nn > 1 then [(coinductN, [coinduct_thm], K common_coinduct_attrs), (coinduct_strongN, [coinduct_strong_thm], K common_coinduct_attrs), (rel_coinductN, common_rel_coinduct_thms, K common_rel_coinduct_attrs)] else []) |> massage_simple_notes fp_common_name; val notes = [(coinductN, map single coinduct_thms, fn T_name => coinduct_attrs @ [coinduct_type_attr T_name]), (coinduct_strongN, map single coinduct_strong_thms, K coinduct_attrs), (corecN, corec_thmss, K []), (corec_codeN, map single corec_code_thms, K (nitpicksimp_attrs)), (corec_discN, corec_disc_thmss, K []), (corec_disc_iffN, corec_disc_iff_thmss, K corec_disc_iff_attrs), (corec_selN, corec_sel_thmss, K corec_sel_attrs), (corec_transferN, corec_transfer_thmss, K []), (map_o_corecN, map_o_corec_thmss, K []), (rel_coinductN, rel_coinduct_thmss, K (rel_coinduct_attrs @ [coinduct_pred_attr ""])), (simpsN, simp_thmss, K [])] |> massage_multi_notes fp_b_names fpTs; in lthy - |> fold (curry (Spec_Rules.add Spec_Rules.equational) corecs) + |> fold (Spec_Rules.add "" Spec_Rules.equational corecs) [flat corec_sel_thmss, flat corec_thmss] |> plugins code_plugin ? Code.declare_default_eqns (map (rpair true) corec_code_thms) |> Local_Theory.notes (common_notes @ notes) |-> interpret_bnfs_register_fp_sugars plugins fpTs fpBTs Xs Greatest_FP pre_bnfs absT_infos fp_nesting_bnfs live_nesting_bnfs fp_res ctrXs_Tsss ctor_iff_dtors ctr_defss ctr_sugars corecs corec_defs map_thmss [coinduct_thm, coinduct_strong_thm] (transpose [coinduct_thms, coinduct_strong_thms]) corec_thmss corec_disc_thmss corec_sel_thmsss rel_injectss rel_distinctss map_disc_iffss map_selsss rel_selss rel_intross rel_casess pred_injectss set_thmss set_selsssss set_introsssss set_casess ctr_transferss case_transferss disc_transferss sel_transferss corec_disc_iff_thmss (map single corec_code_thms) corec_transfer_thmss common_rel_coinduct_thms rel_coinduct_thmss set_induct_thms (replicate nn (if nn = 1 then set_induct_thms else [])) map_o_corec_thmss end; val lthy = lthy |> live > 0 ? fold2 (fn Type (s, _) => fn bnf => register_bnf_raw s bnf) fpTs fp_bnfs |> @{fold_map 29} define_ctrs_dtrs_for_type_etc fp_bnfs fp_bs fpTs Cs Es ctors dtors xtor_co_recs ctor_dtors dtor_ctors ctor_injects pre_map_defs pre_set_defss pre_rel_defs xtor_maps xtor_setss xtor_rels ns kss mss abss abs_injects type_definitions ctr_bindingss ctr_mixfixess ctr_Tsss disc_bindingss sel_bindingsss raw_sel_default_eqss |> wrap_ctrs_derive_map_set_rel_pred_thms_define_co_rec_for_types |> case_fp fp derive_note_induct_recs_thms_for_types derive_note_coinduct_corecs_thms_for_types; val timer = time (timer ("Constructors, discriminators, selectors, etc., for the new " ^ co_prefix fp ^ "datatype")); in lthy end; fun co_datatypes fp = define_co_datatypes (K I) (K I) (K I) (K I) fp; fun co_datatype_cmd fp construct_fp options lthy = define_co_datatypes Plugin_Name.make_filter Typedecl.read_constraint Syntax.parse_typ Syntax.parse_term fp construct_fp options lthy handle EMPTY_DATATYPE s => error ("Cannot define empty datatype " ^ quote s); val parse_ctr_arg = \<^keyword>\(\ |-- parse_binding_colon -- Parse.typ --| \<^keyword>\)\ || Parse.typ >> pair Binding.empty; val parse_ctr_specs = Parse.enum1 "|" (parse_ctr_spec Parse.binding parse_ctr_arg -- Parse.opt_mixfix); val parse_spec = parse_type_args_named_constrained -- Parse.binding -- Parse.opt_mixfix -- (\<^keyword>\=\ |-- parse_ctr_specs) -- parse_map_rel_pred_bindings -- parse_sel_default_eqs; val parse_co_datatype = parse_ctr_options -- Parse.and_list1 parse_spec; fun parse_co_datatype_cmd fp construct_fp = parse_co_datatype >> co_datatype_cmd fp construct_fp; end; diff --git a/src/HOL/Tools/BNF/bnf_gfp_grec_sugar.ML b/src/HOL/Tools/BNF/bnf_gfp_grec_sugar.ML --- a/src/HOL/Tools/BNF/bnf_gfp_grec_sugar.ML +++ b/src/HOL/Tools/BNF/bnf_gfp_grec_sugar.ML @@ -1,2391 +1,2391 @@ (* Title: HOL/Tools/BNF/bnf_gfp_grec_sugar.ML Author: Aymeric Bouzy, Ecole polytechnique Author: Jasmin Blanchette, Inria, LORIA, MPII Author: Dmitriy Traytel, ETH Zürich Copyright 2015, 2016 Generalized corecursor sugar ("corec" and friends). *) signature BNF_GFP_GREC_SUGAR = sig datatype corec_option = Plugins_Option of Proof.context -> Plugin_Name.filter | Friend_Option | Transfer_Option val parse_corec_equation: Proof.context -> term list -> term -> term list * term val explore_corec_equation: Proof.context -> bool -> bool -> string -> term -> BNF_GFP_Grec_Sugar_Util.s_parse_info -> typ -> term list * term -> term list * term val build_corecUU_arg_and_goals: bool -> term -> term list * term -> local_theory -> (((thm list * thm list * thm list) * term list) * term) * local_theory val derive_eq_corecUU: Proof.context -> BNF_GFP_Grec.corec_info -> term -> term -> thm -> thm val derive_unique: Proof.context -> morphism -> term -> BNF_GFP_Grec.corec_info -> string -> thm -> thm val corec_cmd: bool -> corec_option list -> (binding * string option * mixfix) list * string -> local_theory -> local_theory val corecursive_cmd: bool -> corec_option list -> (binding * string option * mixfix) list * string -> local_theory -> Proof.state val friend_of_corec_cmd: (string * string option) * string -> local_theory -> Proof.state val coinduction_upto_cmd: string * string -> local_theory -> local_theory end; structure BNF_GFP_Grec_Sugar : BNF_GFP_GREC_SUGAR = struct open Ctr_Sugar open BNF_Util open BNF_Tactics open BNF_Def open BNF_Comp open BNF_FP_Util open BNF_FP_Def_Sugar open BNF_FP_N2M_Sugar open BNF_GFP_Util open BNF_GFP_Rec_Sugar open BNF_FP_Rec_Sugar_Transfer open BNF_GFP_Grec open BNF_GFP_Grec_Sugar_Util open BNF_GFP_Grec_Sugar_Tactics val cong_N = "cong_"; val baseN = "base"; val reflN = "refl"; val symN = "sym"; val transN = "trans"; val cong_introsN = prefix cong_N "intros"; val codeN = "code"; val coinductN = "coinduct"; val coinduct_uptoN = "coinduct_upto"; val corecN = "corec"; val ctrN = "ctr"; val discN = "disc"; val disc_iffN = "disc_iff"; val eq_algrhoN = "eq_algrho"; val eq_corecUUN = "eq_corecUU"; val friendN = "friend"; val inner_elimN = "inner_elim"; val inner_inductN = "inner_induct"; val inner_simpN = "inner_simp"; val rhoN = "rho"; val selN = "sel"; val uniqueN = "unique"; val inner_fp_suffix = "_inner_fp"; val nitpicksimp_attrs = @{attributes [nitpick_simp]}; val simp_attrs = @{attributes [simp]}; val unfold_id_thms1 = map (fn thm => thm RS eq_reflection) @{thms id_bnf_o o_id_bnf id_apply o_apply} @ @{thms fst_def[abs_def, symmetric] snd_def[abs_def, symmetric]}; fun unfold_id_bnf_etc lthy = let val thy = Proof_Context.theory_of lthy in Raw_Simplifier.rewrite_term thy unfold_id_thms1 [] #> Raw_Simplifier.rewrite_term thy @{thms BNF_Composition.id_bnf_def} [] end; datatype corec_option = Plugins_Option of Proof.context -> Plugin_Name.filter | Friend_Option | Transfer_Option; val corec_option_parser = Parse.group (K "option") (Plugin_Name.parse_filter >> Plugins_Option || Parse.reserved "friend" >> K Friend_Option || Parse.reserved "transfer" >> K Transfer_Option); type codatatype_extra = {case_dtor: thm, case_trivial: thm, abs_rep_transfers: thm list}; fun morph_codatatype_extra phi ({case_dtor, case_trivial, abs_rep_transfers} : codatatype_extra) = {case_dtor = Morphism.thm phi case_dtor, case_trivial = Morphism.thm phi case_trivial, abs_rep_transfers = map (Morphism.thm phi) abs_rep_transfers}; val transfer_codatatype_extra = morph_codatatype_extra o Morphism.transfer_morphism; type coinduct_extra = {coinduct: thm, coinduct_attrs: Token.src list, cong_intro_pairs: (string * thm) list}; fun morph_coinduct_extra phi ({coinduct, coinduct_attrs, cong_intro_pairs} : coinduct_extra) = {coinduct = Morphism.thm phi coinduct, coinduct_attrs = coinduct_attrs, cong_intro_pairs = map (apsnd (Morphism.thm phi)) cong_intro_pairs}; val transfer_coinduct_extra = morph_coinduct_extra o Morphism.transfer_morphism; type friend_extra = {eq_algrhos: thm list, algrho_eqs: thm list}; val empty_friend_extra = {eq_algrhos = [], algrho_eqs = []}; fun merge_friend_extras ({eq_algrhos = eq_algrhos1, algrho_eqs = algrho_eqs1}, {eq_algrhos = eq_algrhos2, algrho_eqs = algrho_eqs2}) = {eq_algrhos = union Thm.eq_thm_prop eq_algrhos1 eq_algrhos2, algrho_eqs = union Thm.eq_thm_prop algrho_eqs1 algrho_eqs2}; type corec_sugar_data = codatatype_extra Symtab.table * coinduct_extra Symtab.table * friend_extra Symtab.table; structure Data = Generic_Data ( type T = corec_sugar_data; val empty = (Symtab.empty, Symtab.empty, Symtab.empty); val extend = I; fun merge data : T = (Symtab.merge (K true) (apply2 #1 data), Symtab.merge (K true) (apply2 #2 data), Symtab.join (K merge_friend_extras) (apply2 #3 data)); ); fun register_codatatype_extra fpT_name extra = Local_Theory.declaration {syntax = false, pervasive = true} (fn phi => Data.map (@{apply 3(1)} (Symtab.update (fpT_name, morph_codatatype_extra phi extra)))); fun codatatype_extra_of ctxt = Symtab.lookup (#1 (Data.get (Context.Proof ctxt))) #> Option.map (transfer_codatatype_extra (Proof_Context.theory_of ctxt)); fun all_codatatype_extras_of ctxt = Symtab.dest (#1 (Data.get (Context.Proof ctxt))); fun register_coinduct_extra fpT_name extra = Local_Theory.declaration {syntax = false, pervasive = true} (fn phi => Data.map (@{apply 3(2)} (Symtab.update (fpT_name, morph_coinduct_extra phi extra)))); fun coinduct_extra_of ctxt = Symtab.lookup (#2 (Data.get (Context.Proof ctxt))) #> Option.map (transfer_coinduct_extra (Proof_Context.theory_of ctxt)); fun register_friend_extra fun_name eq_algrho algrho_eq = Local_Theory.declaration {syntax = false, pervasive = true} (fn phi => Data.map (@{apply 3(3)} (Symtab.map_default (fun_name, empty_friend_extra) (fn {eq_algrhos, algrho_eqs} => {eq_algrhos = Morphism.thm phi eq_algrho :: eq_algrhos, algrho_eqs = Morphism.thm phi algrho_eq :: algrho_eqs})))); fun all_friend_extras_of ctxt = Symtab.dest (#3 (Data.get (Context.Proof ctxt))); fun coinduct_extras_of_generic context = corec_infos_of_generic context #> map (#corecUU #> dest_Const #> fst #> Symtab.lookup (#2 (Data.get context)) #> the #> transfer_coinduct_extra (Context.theory_of context)); fun get_coinduct_uptos fpT_name context = coinduct_extras_of_generic context fpT_name |> map #coinduct; fun get_cong_all_intros fpT_name context = coinduct_extras_of_generic context fpT_name |> maps (#cong_intro_pairs #> map snd); fun get_cong_intros fpT_name name context = coinduct_extras_of_generic context fpT_name |> map_filter (#cong_intro_pairs #> (fn ps => AList.lookup (op =) ps name)); fun ctr_names_of_fp_name lthy fpT_name = fpT_name |> fp_sugar_of lthy |> the |> #fp_ctr_sugar |> #ctr_sugar |> #ctrs |> map (Long_Name.base_name o name_of_ctr); fun register_coinduct_dynamic_base fpT_name lthy = let val fp_b = Binding.name (Long_Name.base_name fpT_name) in lthy |> fold Local_Theory.add_thms_dynamic ((mk_fp_binding fp_b coinduct_uptoN, get_coinduct_uptos fpT_name) :: map (fn N => let val N = cong_N ^ N in (mk_fp_binding fp_b N, get_cong_intros fpT_name N) end) ([baseN, reflN, symN, transN] @ ctr_names_of_fp_name lthy fpT_name)) |> Local_Theory.add_thms_dynamic (mk_fp_binding fp_b cong_introsN, get_cong_all_intros fpT_name) end; fun register_coinduct_dynamic_friend fpT_name friend_name = let val fp_b = Binding.name (Long_Name.base_name fpT_name); val friend_base_name = cong_N ^ Long_Name.base_name friend_name; in Local_Theory.add_thms_dynamic (mk_fp_binding fp_b friend_base_name, get_cong_intros fpT_name friend_base_name) end; fun derive_case_dtor ctxt fpT_name = let val thy = Proof_Context.theory_of ctxt; val SOME ({fp_res_index, fp_res = {dtors = dtors0, dtor_ctors, ...}, absT_info = {rep = rep0, abs_inverse, ...}, fp_ctr_sugar = {ctr_defs, ctr_sugar = {casex, exhaust, case_thms, ...}, ...}, ...}) = fp_sugar_of ctxt fpT_name; val (f_Ts, Type (_, [fpT as Type (_, As), _])) = strip_fun_type (fastype_of casex); val x_Tss = map binder_types f_Ts; val (((u, fs), xss), _) = ctxt |> yield_singleton (mk_Frees "y") fpT ||>> mk_Frees "f" f_Ts ||>> mk_Freess "x" x_Tss; val dtor0 = nth dtors0 fp_res_index; val dtor = mk_dtor As dtor0; val u' = dtor $ u; val absT = fastype_of u'; val rep = mk_rep absT rep0; val goal = mk_Trueprop_eq (list_comb (casex, fs) $ u, mk_case_absumprod absT rep fs xss xss $ u') |> Raw_Simplifier.rewrite_term thy @{thms comp_def[THEN eq_reflection]} []; val vars = map (fst o dest_Free) (u :: fs); val dtor_ctor = nth dtor_ctors fp_res_index; in Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} => mk_case_dtor_tac ctxt u abs_inverse dtor_ctor ctr_defs exhaust case_thms) |> Thm.close_derivation \<^here> end; fun derive_case_trivial ctxt fpT_name = let val SOME {casex, exhaust, case_thms, ...} = ctr_sugar_of ctxt fpT_name; val Type (_, As0) = domain_type (body_fun_type (fastype_of casex)); val (As, _) = ctxt |> mk_TFrees' (map Type.sort_of_atyp As0); val fpT = Type (fpT_name, As); val (var_name, ()) = singleton (Variable.variant_frees ctxt []) ("x", ()); val var = Free (var_name, fpT); val goal = mk_Trueprop_eq (expand_to_ctr_term ctxt fpT var, var); val exhaust' = infer_instantiate' ctxt [SOME (Thm.cterm_of ctxt var)] exhaust; in Goal.prove_sorry ctxt [var_name] [] goal (fn {context = ctxt, prems = _} => HEADGOAL (rtac ctxt exhaust') THEN ALLGOALS (hyp_subst_tac ctxt) THEN unfold_thms_tac ctxt case_thms THEN ALLGOALS (rtac ctxt refl)) |> Thm.close_derivation \<^here> end; fun mk_abs_rep_transfers ctxt fpT_name = [mk_abs_transfer ctxt fpT_name, mk_rep_transfer ctxt fpT_name] handle Fail _ => []; fun ensure_codatatype_extra fpT_name ctxt = (case codatatype_extra_of ctxt fpT_name of NONE => let val abs_rep_transfers = mk_abs_rep_transfers ctxt fpT_name in ctxt |> register_codatatype_extra fpT_name {case_dtor = derive_case_dtor ctxt fpT_name, case_trivial = derive_case_trivial ctxt fpT_name, abs_rep_transfers = abs_rep_transfers} |> set_transfer_rule_attrs abs_rep_transfers end | SOME {abs_rep_transfers, ...} => ctxt |> set_transfer_rule_attrs abs_rep_transfers); fun setup_base fpT_name = register_coinduct_dynamic_base fpT_name #> ensure_codatatype_extra fpT_name; fun is_set ctxt (const_name, T) = (case T of Type (\<^type_name>\fun\, [Type (fpT_name, _), Type (\<^type_name>\set\, [_])]) => (case bnf_of ctxt fpT_name of SOME bnf => exists (fn Const (s, _) => s = const_name | _ => false) (sets_of_bnf bnf) | NONE => false) | _ => false); fun case_eq_if_thms_of_term ctxt t = let val ctr_sugars = map_filter (ctr_sugar_of_case ctxt o fst) (Term.add_consts t []) in maps #case_eq_ifs ctr_sugars end; fun all_algrho_eqs_of ctxt = maps (#algrho_eqs o snd) (all_friend_extras_of ctxt); fun derive_code ctxt inner_fp_simps goal {sig_fp_sugars, ssig_fp_sugar, eval, eval_simps, all_algLam_algs, corecUU_thm, ...} fun_t fun_def = let val fun_T = fastype_of fun_t; val (arg_Ts, Type (fpT_name, _)) = strip_type fun_T; val num_args = length arg_Ts; val SOME {pre_bnf, fp_bnf, absT_info, fp_nesting_bnfs, live_nesting_bnfs, fp_ctr_sugar, ...} = fp_sugar_of ctxt fpT_name; val SOME {case_trivial, ...} = codatatype_extra_of ctxt fpT_name; val ctr_sugar = #ctr_sugar fp_ctr_sugar; val pre_map_def = map_def_of_bnf pre_bnf; val abs_inverse = #abs_inverse absT_info; val ctr_defs = #ctr_defs fp_ctr_sugar; val case_eq_ifs = #case_eq_ifs ctr_sugar @ case_eq_if_thms_of_term ctxt goal; val all_sig_map_thms = maps (#map_thms o #fp_bnf_sugar) sig_fp_sugars; val fp_map_ident = map_ident_of_bnf fp_bnf; val fpsig_nesting_bnfs = fp_nesting_bnfs @ maps #live_nesting_bnfs sig_fp_sugars; val fpsig_nesting_T_names = map (fst o dest_Type o T_of_bnf) fpsig_nesting_bnfs; val fpsig_nesting_fp_sugars = map_filter (fp_sugar_of ctxt) fpsig_nesting_T_names; val fpsig_nesting_fp_bnf_sugars = map #fp_bnf_sugar fpsig_nesting_fp_sugars; val ssig_fp_bnf_sugar = #fp_bnf_sugar ssig_fp_sugar; val ssig_bnf = #fp_bnf ssig_fp_sugar; val ssig_map = map_of_bnf ssig_bnf; val fpsig_nesting_maps = map map_of_bnf fpsig_nesting_bnfs; val fpsig_nesting_map_ident0s = map map_ident0_of_bnf fpsig_nesting_bnfs; val fpsig_nesting_map_comps = map map_comp_of_bnf fpsig_nesting_bnfs; val fpsig_nesting_map_thms = maps #map_thms fpsig_nesting_fp_bnf_sugars; val live_nesting_map_ident0s = map map_ident0_of_bnf live_nesting_bnfs; val ssig_map_thms = #map_thms ssig_fp_bnf_sugar; val all_algLam_alg_pointfuls = map (mk_pointful ctxt) all_algLam_algs; in Variable.add_free_names ctxt goal [] |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} => mk_code_tac ctxt num_args fpsig_nesting_maps ssig_map eval pre_map_def abs_inverse fpsig_nesting_map_ident0s fpsig_nesting_map_comps fpsig_nesting_map_thms live_nesting_map_ident0s fp_map_ident case_trivial ctr_defs case_eq_ifs corecUU_thm all_sig_map_thms ssig_map_thms all_algLam_alg_pointfuls (all_algrho_eqs_of ctxt) eval_simps inner_fp_simps fun_def)) |> Thm.close_derivation \<^here> end; fun derive_unique ctxt phi code_goal {sig_fp_sugars, ssig_fp_sugar, eval, eval_simps, all_algLam_algs, corecUU_unique, ...} fpT_name eq_corecUU = let val SOME {pre_bnf, fp_bnf, absT_info, fp_nesting_bnfs, live_nesting_bnfs, fp_ctr_sugar, ...} = fp_sugar_of ctxt fpT_name; val SOME {case_trivial, ...} = codatatype_extra_of ctxt fpT_name; val ctr_sugar = #ctr_sugar fp_ctr_sugar; val pre_map_def = map_def_of_bnf pre_bnf; val abs_inverse = #abs_inverse absT_info; val ctr_defs = #ctr_defs fp_ctr_sugar; val case_eq_ifs = #case_eq_ifs ctr_sugar @ case_eq_if_thms_of_term ctxt code_goal; val all_sig_map_thms = maps (#map_thms o #fp_bnf_sugar) sig_fp_sugars; val fp_map_ident = map_ident_of_bnf fp_bnf; val fpsig_nesting_bnfs = fp_nesting_bnfs @ maps #live_nesting_bnfs sig_fp_sugars; val fpsig_nesting_T_names = map (fst o dest_Type o T_of_bnf) fpsig_nesting_bnfs; val fpsig_nesting_fp_sugars = map_filter (fp_sugar_of ctxt) fpsig_nesting_T_names; val fpsig_nesting_fp_bnf_sugars = map #fp_bnf_sugar fpsig_nesting_fp_sugars; val ssig_fp_bnf_sugar = #fp_bnf_sugar ssig_fp_sugar; val ssig_bnf = #fp_bnf ssig_fp_sugar; val ssig_map = map_of_bnf ssig_bnf; val fpsig_nesting_maps = map map_of_bnf fpsig_nesting_bnfs; val fpsig_nesting_map_ident0s = map map_ident0_of_bnf fpsig_nesting_bnfs; val fpsig_nesting_map_comps = map map_comp_of_bnf fpsig_nesting_bnfs; val fpsig_nesting_map_thms = maps #map_thms fpsig_nesting_fp_bnf_sugars; val live_nesting_map_ident0s = map map_ident0_of_bnf live_nesting_bnfs; val ssig_map_thms = #map_thms ssig_fp_bnf_sugar; val all_algLam_alg_pointfuls = map (mk_pointful ctxt) all_algLam_algs; val \<^const>\Trueprop\ $ (Const (\<^const_name>\HOL.eq\, _) $ lhs $ rhs) = code_goal; val (fun_t, args) = strip_comb lhs; val closed_rhs = fold_rev lambda args rhs; val fun_T = fastype_of fun_t; val num_args = num_binder_types fun_T; val f = Free (singleton (Variable.variant_frees ctxt []) ("f", fun_T)); val is_self_call = curry (op aconv) fun_t; val has_self_call = exists_subterm is_self_call; fun fify args (t $ u) = fify (u :: args) t $ fify [] u | fify _ (Abs (s, T, t)) = Abs (s, T, fify [] t) | fify args t = if t = fun_t andalso not (exists has_self_call args) then f else t; val goal = Logic.mk_implies (mk_Trueprop_eq (f, fify [] closed_rhs), mk_Trueprop_eq (f, fun_t)) |> Morphism.term phi; in Goal.prove_sorry ctxt [fst (dest_Free f)] [] goal (fn {context = ctxt, prems = _} => mk_unique_tac ctxt num_args fpsig_nesting_maps ssig_map eval pre_map_def abs_inverse fpsig_nesting_map_ident0s fpsig_nesting_map_comps fpsig_nesting_map_thms live_nesting_map_ident0s fp_map_ident case_trivial ctr_defs case_eq_ifs all_sig_map_thms ssig_map_thms all_algLam_alg_pointfuls (all_algrho_eqs_of ctxt) eval_simps corecUU_unique eq_corecUU) |> Thm.close_derivation \<^here> end; fun derive_last_disc ctxt fcT_name = let val SOME {T = fcT, discs, exhaust, disc_thmss, ...} = ctr_sugar_of ctxt fcT_name; val (u, _) = ctxt |> yield_singleton (mk_Frees "x") fcT; val udiscs = map (rapp u) discs; val (not_udiscs, last_udisc) = split_last udiscs |>> map HOLogic.mk_not; val goal = mk_Trueprop_eq (last_udisc, foldr1 HOLogic.mk_conj not_udiscs); in Goal.prove_sorry ctxt [fst (dest_Free u)] [] goal (fn {context = ctxt, prems = _} => mk_last_disc_tac ctxt u exhaust (flat disc_thmss)) |> Thm.close_derivation \<^here> end; fun derive_eq_algrho ctxt {sig_fp_sugars, ssig_fp_sugar, eval, eval_simps, all_algLam_algs, corecUU_unique, ...} ({algrho = algrho0, dtor_algrho, ...} : friend_info) fun_t k_T code_goal const_transfers rho_def eq_corecUU = let val fun_T = fastype_of fun_t; val (arg_Ts, Type (fpT_name, Ts)) = strip_type fun_T; val num_args = length arg_Ts; val SOME {fp_res_index, fp_res, pre_bnf, fp_bnf, absT_info, fp_nesting_bnfs, live_nesting_bnfs, fp_ctr_sugar, ...} = fp_sugar_of ctxt fpT_name; val SOME {case_dtor, ...} = codatatype_extra_of ctxt fpT_name; val fp_nesting_Ts = map T_of_bnf fp_nesting_bnfs; fun is_nullary_disc_def (\<^const>\Trueprop\ $ (Const (\<^const_name>\HOL.eq\, _) $ _ $ (Const (\<^const_name>\HOL.eq\, _) $ _ $ _))) = true | is_nullary_disc_def (Const (\<^const_name>\Pure.eq\, _) $ _ $ (Const (\<^const_name>\HOL.eq\, _) $ _ $ _)) = true | is_nullary_disc_def _ = false; val dtor_ctor = nth (#dtor_ctors fp_res) fp_res_index; val ctor_iff_dtor = #ctor_iff_dtor fp_ctr_sugar; val ctr_sugar = #ctr_sugar fp_ctr_sugar; val pre_map_def = map_def_of_bnf pre_bnf; val abs_inverse = #abs_inverse absT_info; val ctr_defs = #ctr_defs fp_ctr_sugar; val nullary_disc_defs = filter (is_nullary_disc_def o Thm.prop_of) (#disc_defs ctr_sugar); val disc_sel_eq_cases = #disc_eq_cases ctr_sugar @ #sel_defs ctr_sugar; val case_eq_ifs = #case_eq_ifs ctr_sugar @ case_eq_if_thms_of_term ctxt code_goal; val all_sig_map_thms = maps (#map_thms o #fp_bnf_sugar) sig_fp_sugars; fun add_tnameT (Type (s, Ts)) = insert (op =) s #> fold add_tnameT Ts | add_tnameT _ = I; fun map_disc_sels'_of s = (case fp_sugar_of ctxt s of SOME {fp_bnf_sugar = {map_disc_iffs, map_selss, ...}, ...} => let val map_selss' = if length map_selss <= 1 then map_selss else map (map (unfold_thms ctxt (no_refl [derive_last_disc ctxt s]))) map_selss; in map_disc_iffs @ flat map_selss' end | NONE => []); fun mk_const_pointful_natural const_transfer = SOME (mk_pointful_natural_from_transfer ctxt const_transfer) handle UNNATURAL () => NONE; val const_pointful_natural_opts = map mk_const_pointful_natural const_transfers; val const_pointful_naturals = map_filter I const_pointful_natural_opts; val fp_nesting_k_T_names = fold add_tnameT (k_T :: fp_nesting_Ts) []; val fp_nesting_k_map_disc_sels' = maps map_disc_sels'_of fp_nesting_k_T_names; val fp_map_ident = map_ident_of_bnf fp_bnf; val fpsig_nesting_bnfs = fp_nesting_bnfs @ maps #live_nesting_bnfs sig_fp_sugars; val fpsig_nesting_T_names = map (fst o dest_Type o T_of_bnf) fpsig_nesting_bnfs; val fpsig_nesting_fp_sugars = map_filter (fp_sugar_of ctxt) fpsig_nesting_T_names; val fpsig_nesting_fp_bnf_sugars = map #fp_bnf_sugar fpsig_nesting_fp_sugars; val ssig_fp_bnf_sugar = #fp_bnf_sugar ssig_fp_sugar; val ssig_bnf = #fp_bnf ssig_fp_sugar; val ssig_map = map_of_bnf ssig_bnf; val fpsig_nesting_maps = map map_of_bnf fpsig_nesting_bnfs; val fpsig_nesting_map_ident0s = map map_ident0_of_bnf fpsig_nesting_bnfs; val fpsig_nesting_map_comps = map map_comp_of_bnf fpsig_nesting_bnfs; val fpsig_nesting_map_thms = maps #map_thms fpsig_nesting_fp_bnf_sugars; val live_nesting_map_ident0s = map map_ident0_of_bnf live_nesting_bnfs; val ssig_map_thms = #map_thms ssig_fp_bnf_sugar; val all_algLam_alg_pointfuls = map (mk_pointful ctxt) all_algLam_algs; val ctor = nth (#ctors fp_res) fp_res_index; val abs = #abs absT_info; val rep = #rep absT_info; val algrho = mk_ctr Ts algrho0; val goal = mk_Trueprop_eq (fun_t, abs_curried_balanced arg_Ts algrho); fun const_of_transfer thm = (case Thm.prop_of thm of \<^const>\Trueprop\ $ (_ $ cst $ _) => cst); val eq_algrho = Goal.prove (*no sorry*) ctxt [] [] goal (fn {context = ctxt, prems = _} => mk_eq_algrho_tac ctxt fpsig_nesting_maps abs rep ctor ssig_map eval pre_map_def abs_inverse fpsig_nesting_map_ident0s fpsig_nesting_map_comps fpsig_nesting_map_thms live_nesting_map_ident0s fp_map_ident dtor_ctor ctor_iff_dtor ctr_defs nullary_disc_defs disc_sel_eq_cases case_dtor case_eq_ifs const_pointful_naturals fp_nesting_k_map_disc_sels' rho_def dtor_algrho corecUU_unique eq_corecUU all_sig_map_thms ssig_map_thms all_algLam_alg_pointfuls (all_algrho_eqs_of ctxt) eval_simps) |> Thm.close_derivation \<^here> handle e as ERROR _ => (case filter (is_none o snd) (const_transfers ~~ const_pointful_natural_opts) of [] => Exn.reraise e | thm_nones => error ("Failed to state naturality property for " ^ commas (map (Syntax.string_of_term ctxt o const_of_transfer o fst) thm_nones))); val algrho_eq = eq_algrho RS (mk_curry_uncurryN_balanced ctxt num_args RS iffD2) RS sym; in (eq_algrho, algrho_eq) end; fun prime_rho_transfer_goal ctxt fpT_name rho_def goal = let val thy = Proof_Context.theory_of ctxt; val SOME {pre_bnf, ...} = fp_sugar_of ctxt fpT_name; val SOME {abs_rep_transfers, ...} = codatatype_extra_of ctxt fpT_name; val simps = rel_def_of_bnf pre_bnf :: rho_transfer_simps; val fold_rho = unfold_thms ctxt [rho_def RS @{thm symmetric}]; fun derive_unprimed rho_transfer' = Variable.add_free_names ctxt goal [] |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} => unfold_thms_tac ctxt simps THEN HEADGOAL (rtac ctxt rho_transfer'))) |> Thm.close_derivation \<^here>; val goal' = Raw_Simplifier.rewrite_term thy simps [] goal; in if null abs_rep_transfers then (goal', derive_unprimed #> fold_rho) else (goal, fold_rho) end; fun derive_rho_transfer_folded ctxt fpT_name const_transfers rho_def goal = let val SOME {pre_bnf, ...} = fp_sugar_of ctxt fpT_name; val SOME {abs_rep_transfers, ...} = codatatype_extra_of ctxt fpT_name; in Variable.add_free_names ctxt goal [] |> (fn vars => Goal.prove (*no sorry*) ctxt vars [] goal (fn {context = ctxt, prems = _} => mk_rho_transfer_tac ctxt (null abs_rep_transfers) (rel_def_of_bnf pre_bnf) const_transfers)) |> unfold_thms ctxt [rho_def RS @{thm symmetric}] |> Thm.close_derivation \<^here> end; fun mk_cong_intro_ctr_or_friend_goal ctxt fpT Rcong alg = let val xy_Ts = binder_types (fastype_of alg); val ((xs, ys), _) = ctxt |> mk_Frees "x" xy_Ts ||>> mk_Frees "y" xy_Ts; fun mk_prem xy_T x y = build_rel [] ctxt [fpT] [] (fn (T, _) => if T = fpT then Rcong else HOLogic.eq_const T) (xy_T, xy_T) $ x $ y; val prems = @{map 3} mk_prem xy_Ts xs ys; val concl = Rcong $ list_comb (alg, xs) $ list_comb (alg, ys); in Logic.list_implies (map HOLogic.mk_Trueprop prems, HOLogic.mk_Trueprop concl) end; fun derive_cong_ctr_intros ctxt cong_ctor_intro = let val \<^const>\Pure.imp\ $ _ $ (\<^const>\Trueprop\ $ ((Rcong as _ $ _) $ _ $ (ctor $ _))) = Thm.prop_of cong_ctor_intro; val fpT as Type (fpT_name, fp_argTs) = range_type (fastype_of ctor); val SOME {pre_bnf, absT_info = {abs_inverse, ...}, fp_ctr_sugar = {ctr_defs, ctr_sugar = {ctrs = ctrs0, ...}, ...}, ...} = fp_sugar_of ctxt fpT_name; val ctrs = map (mk_ctr fp_argTs) ctrs0; val pre_rel_def = rel_def_of_bnf pre_bnf; fun prove ctr_def goal = Variable.add_free_names ctxt goal [] |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} => mk_cong_intro_ctr_or_friend_tac ctxt ctr_def [pre_rel_def, abs_inverse] cong_ctor_intro)) |> Thm.close_derivation \<^here>; val goals = map (mk_cong_intro_ctr_or_friend_goal ctxt fpT Rcong) ctrs; in map2 prove ctr_defs goals end; fun derive_cong_friend_intro ctxt cong_algrho_intro = let val \<^const>\Pure.imp\ $ _ $ (\<^const>\Trueprop\ $ ((Rcong as _ $ _) $ _ $ ((algrho as Const (algrho_name, _)) $ _))) = Thm.prop_of cong_algrho_intro; val fpT as Type (_, fp_argTs) = range_type (fastype_of algrho); fun has_algrho (\<^const>\Trueprop\ $ (Const (\<^const_name>\HOL.eq\, _) $ _ $ rhs)) = fst (dest_Const (head_of (strip_abs_body rhs))) = algrho_name; val eq_algrho :: _ = maps (filter (has_algrho o Thm.prop_of) o #eq_algrhos o snd) (all_friend_extras_of ctxt); val \<^const>\Trueprop\ $ (Const (\<^const_name>\HOL.eq\, _) $ friend0 $ _) = Thm.prop_of eq_algrho; val friend = mk_ctr fp_argTs friend0; val goal = mk_cong_intro_ctr_or_friend_goal ctxt fpT Rcong friend; in Variable.add_free_names ctxt goal [] |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} => mk_cong_intro_ctr_or_friend_tac ctxt eq_algrho [] cong_algrho_intro)) |> Thm.close_derivation \<^here> end; fun derive_cong_intros lthy ctr_names friend_names ({cong_base, cong_refl, cong_sym, cong_trans, cong_alg_intros, ...} : dtor_coinduct_info) = let val cong_ctor_intro :: cong_algrho_intros = rev cong_alg_intros; val names = map (prefix cong_N) ([baseN, reflN, symN, transN] @ ctr_names @ friend_names); val thms = [cong_base, cong_refl, cong_sym, cong_trans] @ derive_cong_ctr_intros lthy cong_ctor_intro @ map (derive_cong_friend_intro lthy) cong_algrho_intros; in names ~~ thms end; fun derive_coinduct ctxt (fpT as Type (fpT_name, fpT_args)) dtor_coinduct = let val thy = Proof_Context.theory_of ctxt; val \<^const>\Pure.imp\ $ (\<^const>\Trueprop\ $ (_ $ Abs (_, _, _ $ Abs (_, _, \<^const>\implies\ $ _ $ (_ $ (cong0 $ _) $ _ $ _))))) $ _ = Thm.prop_of dtor_coinduct; val SOME {X as TVar ((X_s, _), _), fp_res = {dtor_ctors, ...}, pre_bnf, absT_info = {abs_inverse, ...}, live_nesting_bnfs, fp_ctr_sugar = {ctrXs_Tss, ctr_defs, ctr_sugar = ctr_sugar0 as {T = Type (_, T0_args), ctrs = ctrs0, discs = discs0, ...}, ...}, ...} = fp_sugar_of ctxt fpT_name; val n = length ctrXs_Tss; val ms = map length ctrXs_Tss; val X' = TVar ((X_s, maxidx_of_typ fpT + 1), \<^sort>\type\); val As_rho = tvar_subst thy T0_args fpT_args; val substXAT = Term.typ_subst_TVars As_rho o Tsubst X X'; val substXA = Term.subst_TVars As_rho o substT X X'; val phi = Morphism.typ_morphism "BNF" substXAT $> Morphism.term_morphism "BNF" substXA; fun mk_applied_cong arg = enforce_type ctxt domain_type (fastype_of arg) cong0 $ arg; val thm = derive_coinduct_thms_for_types ctxt false mk_applied_cong [pre_bnf] dtor_coinduct dtor_ctors live_nesting_bnfs [fpT] [substXAT X] [map (map substXAT) ctrXs_Tss] [n] [abs_inverse] [abs_inverse] I [ctr_defs] [morph_ctr_sugar phi ctr_sugar0] |> map snd |> the_single; val (attrs, _) = mk_coinduct_attrs [fpT] [ctrs0] [discs0] [ms]; in (thm, attrs) end; type explore_parameters = {bound_Us: typ list, bound_Ts: typ list, U: typ, T: typ}; fun update_UT {bound_Us, bound_Ts, ...} U T = {bound_Us = bound_Us, bound_Ts = bound_Ts, U = U, T = T}; fun explore_nested lthy explore {bound_Us, bound_Ts, U, T} t = let fun build_simple (T, U) = if T = U then \<^term>\%y. y\ else Bound 0 |> explore {bound_Us = T :: bound_Us, bound_Ts = T :: bound_Ts, U = U, T = T} |> (fn t => Abs (Name.uu, T, t)); in betapply (build_map lthy [] [] build_simple (T, U), t) end; fun add_boundvar t = betapply (incr_boundvars 1 t, Bound 0); fun explore_fun (arg_U :: arg_Us) explore {bound_Us, bound_Ts, U, T} t = let val arg_name = the_default Name.uu (try (fn (Abs (s, _, _)) => s) t) in add_boundvar t |> explore_fun arg_Us explore {bound_Us = arg_U :: bound_Us, bound_Ts = domain_type T :: bound_Ts, U = range_type U, T = range_type T} |> (fn t => Abs (arg_name, arg_U, t)) end | explore_fun [] explore params t = explore params t; fun massage_fun explore (params as {T, U, ...}) = if can dest_funT T then explore_fun [domain_type U] explore params else explore params; fun massage_star massages explore = let fun after_massage massages' t params t' = if t aconv t' then massage_any massages' params t else massage_any massages params t' and massage_any [] params t = explore params t | massage_any (massage :: massages') params t = massage (after_massage massages' t) params t; in massage_any massages end; fun massage_let explore params t = (case strip_comb t of (Const (\<^const_name>\Let\, _), [_, _]) => unfold_lets_splits t | _ => t) |> explore params; fun check_corec_equation ctxt fun_frees (lhs, rhs) = let val (fun_t, arg_ts) = strip_comb lhs; fun check_fun_name () = null fun_frees orelse member (op aconv) fun_frees fun_t orelse ill_formed_equation_head ctxt [] fun_t; fun check_no_other_frees () = (case Term.add_frees rhs [] |> map Free |> subtract (op =) (fun_frees @ arg_ts) |> find_first (not o Variable.is_fixed ctxt o fst o dest_Free) of NONE => () | SOME t => extra_variable_in_rhs ctxt [] t); in check_duplicate_variables_in_lhs ctxt [] arg_ts; check_fun_name (); check_all_fun_arg_frees ctxt [] (filter_out is_Var arg_ts); check_no_other_frees () end; fun parse_corec_equation ctxt fun_frees eq = let val (lhs, rhs) = HOLogic.dest_eq (HOLogic.dest_Trueprop (drop_all eq)) handle TERM _ => ill_formed_equation_lhs_rhs ctxt [eq]; val _ = check_corec_equation ctxt fun_frees (lhs, rhs); val (fun_t, arg_ts) = strip_comb lhs; val (arg_Ts, _) = strip_type (fastype_of fun_t); val added_Ts = drop (length arg_ts) arg_Ts; val free_names = mk_names (length added_Ts) "x" ~~ added_Ts; val free_args = Variable.variant_frees ctxt [rhs, lhs] free_names |> map Free; in (arg_ts @ free_args, list_comb (rhs, free_args)) end; fun morph_views phi (code, ctrs, discs, disc_iffs, sels) = (Morphism.term phi code, map (Morphism.term phi) ctrs, map (Morphism.term phi) discs, map (Morphism.term phi) disc_iffs, map (Morphism.term phi) sels); fun generate_views ctxt eq fun_t (lhs_free_args, rhs) = let val lhs = list_comb (fun_t, lhs_free_args); val T as Type (T_name, Ts) = fastype_of rhs; val SOME {fp_ctr_sugar = {ctr_sugar = {ctrs = ctrs0, discs = discs0, selss = selss0, ...}, ...}, ...} = fp_sugar_of ctxt T_name; val ctrs = map (mk_ctr Ts) ctrs0; val discs = map (mk_disc_or_sel Ts) discs0; val selss = map (map (mk_disc_or_sel Ts)) selss0; val code_view = drop_all eq; fun can_case_expand t = not (can (dest_ctr ctxt T_name) t); fun generate_raw_views conds t raw_views = let fun analyse (ctr :: ctrs) (disc :: discs) ctr' = if ctr = ctr' then (conds, disc, ctr) else analyse ctrs discs ctr'; in (analyse ctrs discs (fst (strip_comb t))) :: raw_views end; fun generate_disc_views raw_views = if length discs = 1 then ([], []) else let fun collect_condss_disc condss [] _ = condss | collect_condss_disc condss ((conds, disc', _) :: raw_views) disc = collect_condss_disc (condss |> disc = disc' ? cons conds) raw_views disc; val grouped_disc_views = discs |> map (collect_condss_disc [] raw_views) |> curry (op ~~) (map (fn disc => disc $ lhs) discs); fun mk_disc_iff_props props [] = props | mk_disc_iff_props _ ((lhs, \<^const>\HOL.True\) :: _) = [lhs] | mk_disc_iff_props props ((lhs, rhs) :: views) = mk_disc_iff_props ((HOLogic.mk_eq (lhs, rhs)) :: props) views; in (grouped_disc_views |> map swap, grouped_disc_views |> map (apsnd (s_dnf #> mk_conjs)) |> mk_disc_iff_props [] |> map (fn eq => ([[]], eq))) end; fun generate_ctr_views raw_views = let fun collect_condss_ctr condss [] _ = condss | collect_condss_ctr condss ((conds, _, ctr') :: raw_views) ctr = collect_condss_ctr (condss |> ctr = ctr' ? cons conds) raw_views ctr; fun mk_ctr_eq ctr_sels ctr = let fun extract_arg n sel _(*bound_Ts*) fun_t arg_ts = if ctr = fun_t then nth arg_ts n else let val t = list_comb (fun_t, arg_ts) in if can_case_expand t then sel $ t else Term.dummy_pattern (range_type (fastype_of sel)) end; in ctr_sels |> map_index (uncurry extract_arg) |> map (fn extract => massage_corec_code_rhs ctxt extract [] rhs) |> curry list_comb ctr |> curry HOLogic.mk_eq lhs end; fun remove_condss_if_alone [(_, concl)] = [([[]], concl)] | remove_condss_if_alone views = views; in ctrs |> `(map (collect_condss_ctr [] raw_views)) ||> map2 mk_ctr_eq selss |> op ~~ |> filter_out (null o fst) |> remove_condss_if_alone end; fun generate_sel_views raw_views only_one_ctr = let fun mk_sel_positions sel = let fun get_sel_position _ [] = NONE | get_sel_position i (sel' :: sels) = if sel = sel' then SOME i else get_sel_position (i + 1) sels; in ctrs ~~ map (get_sel_position 0) selss |> map_filter (fn (ctr, pos_opt) => if is_some pos_opt then SOME (ctr, the pos_opt) else NONE) end; fun collect_sel_condss0 condss [] _ = condss | collect_sel_condss0 condss ((conds, _, ctr) :: raw_views) sel_positions = let val condss' = condss |> is_some (AList.lookup (op =) sel_positions ctr) ? cons conds in collect_sel_condss0 condss' raw_views sel_positions end; val collect_sel_condss = if only_one_ctr then K [[]] else collect_sel_condss0 [] raw_views; fun mk_sel_rhs sel_positions sel = let val sel_T = range_type (fastype_of sel); fun extract_sel_value _(*bound_Ts*) fun_t arg_ts = (case AList.lookup (op =) sel_positions fun_t of SOME n => nth arg_ts n | NONE => let val t = list_comb (fun_t, arg_ts) in if can_case_expand t then sel $ t else Term.dummy_pattern sel_T end); in massage_corec_code_rhs ctxt extract_sel_value [] rhs end; val ordered_sels = distinct (op =) (flat selss); val sel_positionss = map mk_sel_positions ordered_sels; val sel_rhss = map2 mk_sel_rhs sel_positionss ordered_sels; val sel_lhss = map (rapp lhs o mk_disc_or_sel Ts) ordered_sels; val sel_condss = map collect_sel_condss sel_positionss; fun is_undefined (Const (\<^const_name>\undefined\, _)) = true | is_undefined _ = false; in sel_condss ~~ (sel_lhss ~~ sel_rhss) |> filter_out (is_undefined o snd o snd) |> map (apsnd HOLogic.mk_eq) end; fun mk_atomic_prop fun_args (condss, concl) = (Logic.list_all (map dest_Free fun_args, abstract_over_list fun_args (Logic.list_implies (map HOLogic.mk_Trueprop (s_dnf condss), HOLogic.mk_Trueprop concl)))); val raw_views = rhs |> massage_let_if_case ctxt (K false) (fn _(*bound_Ts*) => fn t => t |> can_case_expand t ? expand_to_ctr_term ctxt T) (K (K ())) (K I) [] |> (fn expanded_rhs => fold_rev_let_if_case ctxt generate_raw_views [] expanded_rhs []) |> rev; val (disc_views, disc_iff_views) = generate_disc_views raw_views; val ctr_views = generate_ctr_views raw_views; val sel_views = generate_sel_views raw_views (length ctr_views = 1); val mk_props = filter_out (null o fst) #> map (mk_atomic_prop lhs_free_args); in (code_view, mk_props ctr_views, mk_props disc_views, mk_props disc_iff_views, mk_props sel_views) end; fun find_all_associated_types [] _ = [] | find_all_associated_types ((Type (_, Ts1), Type (_, Ts2)) :: TTs) T = find_all_associated_types ((Ts1 ~~ Ts2) @ TTs) T | find_all_associated_types ((T1, T2) :: TTs) T = find_all_associated_types TTs T |> T1 = T ? cons T2; fun as_member_of tab = try dest_Const #> Option.mapPartial (fst #> Symtab.lookup tab); fun extract_rho_from_equation ({ctr_guards, inner_buffer = {Oper, VLeaf, CLeaf, ctr_wrapper, friends}, ...}, {pattern_ctrs, discs, sels, it, mk_case}) b version Y preT ssig_T friend_tm (lhs_args, rhs) lthy = let val thy = Proof_Context.theory_of lthy; val res_T = fastype_of rhs; val YpreT = HOLogic.mk_prodT (Y, preT); fun fpT_to new_T T = if T = res_T then new_T else (case T of Type (s, Ts) => Type (s, map (fpT_to new_T) Ts) | _ => T); fun build_params bound_Us bound_Ts T = {bound_Us = bound_Us, bound_Ts = bound_Ts, U = T, T = T}; fun typ_before explore {bound_Us, bound_Ts, ...} t = explore (build_params bound_Us bound_Ts (fastype_of1 (bound_Ts, t))) t; val is_self_call = curry (op aconv) friend_tm; val has_self_call = Term.exists_subterm is_self_call; fun has_res_T bound_Ts t = fastype_of1 (bound_Ts, t) = res_T; fun contains_res_T (Type (s, Ts)) = s = fst (dest_Type res_T) orelse exists contains_res_T Ts | contains_res_T _ = false; val is_lhs_arg = member (op =) lhs_args; fun is_constant t = not (Term.exists_subterm is_lhs_arg t orelse has_self_call t orelse loose_bvar (t, 0)); fun is_nested_type T = T <> res_T andalso T <> YpreT andalso T <> ssig_T; val is_valid_case_argumentT = not o member (op =) [Y, ssig_T]; fun is_same_type_constr (Type (s, _)) (Type (s', _)) = (s = s') | is_same_type_constr _ _ = false; exception NO_ENCAPSULATION of unit; val parametric_consts = Unsynchronized.ref []; (* We are assuming that set functions are marked with "[transfer_rule]" (cf. the "transfer" plugin). Otherwise, the "eq_algrho" tactic might fail. *) fun is_special_parametric_const (x as (s, _)) = s = \<^const_name>\id\ orelse is_set lthy x; fun add_parametric_const s general_T T U = let fun tupleT_of_funT T = let val (Ts, T) = strip_type T in mk_tupleT_balanced (Ts @ [T]) end; fun funT_of_tupleT n = dest_tupleT_balanced (n + 1) #> split_last #> op --->; val m = num_binder_types general_T; val param1_T = Type_Infer.paramify_vars general_T; val param2_T = Type_Infer.paramify_vars param1_T; val deadfixed_T = build_map lthy [] [] (mk_undefined o op -->) (apply2 tupleT_of_funT (param1_T, param2_T)) |> singleton (Type_Infer_Context.infer_types lthy) |> singleton (Type_Infer.fixate lthy false) |> type_of |> dest_funT |-> generalize_types 1 |> funT_of_tupleT m; val j = maxidx_of_typ deadfixed_T + 1; fun varifyT (Type (s, Ts)) = Type (s, map varifyT Ts) | varifyT (TFree (s, T)) = TVar ((s, j), T) | varifyT T = T; val dedvarified_T = varifyT deadfixed_T; val new_vars = Sign.typ_match thy (dedvarified_T, T) Vartab.empty |> Vartab.dest |> filter (curry (op =) j o snd o fst) |> Vartab.make; val deadinstantiated_T = map_atyps (Type.devar new_vars) dedvarified_T; val final_T = if Sign.typ_instance thy (U, deadinstantiated_T) then deadfixed_T else general_T; in parametric_consts := insert (op =) (s, final_T) (!parametric_consts) end; fun encapsulate (params as {U, T, ...}) t = if U = T then t else if T = Y then VLeaf $ t else if T = res_T then CLeaf $ t else if T = YpreT then it $ t else if is_nested_type T andalso is_same_type_constr T U then explore_nested lthy encapsulate params t else raise NO_ENCAPSULATION (); fun build_function_after_encapsulation fun_t fun_t' (params as {bound_Us, ...}) arg_ts arg_ts' = let val arg_Us' = fst (strip_typeN (length arg_ts) (fastype_of1 (bound_Us, fun_t'))); fun the_or_error arg NONE = error ("Illegal argument " ^ quote (Syntax.string_of_term lthy arg) ^ " to " ^ quote (Syntax.string_of_term lthy fun_t)) | the_or_error _ (SOME arg') = arg'; in arg_ts' |> `(map (curry fastype_of1 bound_Us)) |>> map2 (update_UT params) arg_Us' |> op ~~ |> map (try (uncurry encapsulate)) |> map2 the_or_error arg_ts |> curry list_comb fun_t' end; fun rebuild_function_after_exploration old_fn new_fn explore params arg_ts = arg_ts |> map (typ_before explore params) |> build_function_after_encapsulation old_fn new_fn params arg_ts; fun update_case Us U casex = let val Type (T_name, _) = domain_type (snd (strip_fun_type (fastype_of casex))); val SOME {fp_ctr_sugar = {ctr_sugar = {T = Type (_, Ts), casex, ...}, ...}, ...} = fp_sugar_of lthy T_name; val T = body_type (fastype_of casex); in Term.subst_atomic_types ((T :: Ts) ~~ (U :: Us)) casex end; fun deduce_according_type default_T [] = default_T | deduce_according_type default_T Ts = (case distinct (op =) Ts of U :: [] => U | _ => fpT_to ssig_T default_T); fun massage_if explore_cond explore (params as {bound_Us, bound_Ts, ...}) t = (case strip_comb t of (const as Const (\<^const_name>\If\, _), obj :: (branches as [_, _])) => (case List.partition Term.is_dummy_pattern (map (explore params) branches) of (dummy_branch' :: _, []) => dummy_branch' | (_, [branch']) => branch' | (_, branches') => let val brancheUs = map (curry fastype_of1 bound_Us) branches'; val U = deduce_according_type (fastype_of1 (bound_Ts, hd branches)) brancheUs; val const_obj' = (If_const U, obj) ||> explore_cond (update_UT params \<^typ>\bool\ \<^typ>\bool\) |> op $; in build_function_after_encapsulation (const $ obj) const_obj' params branches branches' end) | _ => explore params t); fun massage_map explore (params as {bound_Us, bound_Ts, T = Type (T_name, Ts), ...}) (t as func $ mapped_arg) = if is_self_call (head_of func) then explore params t else (case try (dest_map lthy T_name) func of SOME (map_tm, fs) => let val n = length fs; val mapped_arg' = mapped_arg |> `(curry fastype_of1 bound_Ts) |>> build_params bound_Us bound_Ts |-> explore; in (case fastype_of1 (bound_Us, mapped_arg') of Type (U_name, Us0) => if U_name = T_name then let val Us = map (fpT_to ssig_T) Us0; val temporary_map = map_tm |> mk_map n Us Ts; val map_fn_Ts = fastype_of #> strip_fun_type #> fst; val binder_Uss = map_fn_Ts temporary_map |> map (map (fpT_to ssig_T) o binder_types); val fun_paramss = map_fn_Ts (head_of func) |> map (build_params bound_Us bound_Ts); val fs' = fs |> @{map 4} explore_fun binder_Uss (replicate n explore) fun_paramss; val SOME bnf = bnf_of lthy T_name; val Type (_, bnf_Ts) = T_of_bnf bnf; val typ_alist = lives_of_bnf bnf ~~ map (curry fastype_of1 bound_Us #> range_type) fs'; val Us' = map2 the_default Us (map (AList.lookup (op =) typ_alist) bnf_Ts); val map_tm' = map_tm |> mk_map n Us Us'; in build_function_after_encapsulation func (list_comb (map_tm', fs')) params [mapped_arg] [mapped_arg'] end else explore params t | _ => explore params t) end | NONE => explore params t) | massage_map explore params t = explore params t; fun massage_comp explore (params as {bound_Us, ...}) t = (case strip_comb t of (Const (\<^const_name>\comp\, _), f1 :: f2 :: args) => let val args' = map (typ_before explore params) args; val f2' = typ_before (explore_fun (map (curry fastype_of1 bound_Us) args') explore) params f2; val f1' = typ_before (explore_fun [range_type (fastype_of1 (bound_Us, f2'))] explore) params f1; in betapply (f1', list_comb (f2', args')) end | _ => explore params t); fun massage_ctr explore (params as {T = T as Type (s, Ts), bound_Us, ...}) t = if T <> res_T then (case try (dest_ctr lthy s) t of SOME (ctr, args) => let val args' = map (typ_before explore params) args; val SOME {T = Type (_, ctr_Ts), ...} = ctr_sugar_of lthy s; val temp_ctr = mk_ctr ctr_Ts ctr; val argUs = map (curry fastype_of1 bound_Us) args'; val typ_alist = binder_types (fastype_of temp_ctr) ~~ argUs; val Us = ctr_Ts |> map (find_all_associated_types typ_alist) |> map2 deduce_according_type Ts; val ctr' = mk_ctr Us ctr; in build_function_after_encapsulation ctr ctr' params args args' end | NONE => explore params t) else explore params t | massage_ctr explore params t = explore params t; fun const_of [] _ = NONE | const_of ((sel as Const (s1, _)) :: r) (const as Const (s2, _)) = if s1 = s2 then SOME sel else const_of r const | const_of _ _ = NONE; fun massage_disc explore (params as {T, bound_Us, bound_Ts, ...}) t = (case (strip_comb t, T = \<^typ>\bool\) of ((fun_t, arg :: []), true) => let val arg_T = fastype_of1 (bound_Ts, arg) in if arg_T <> res_T then (case arg_T |> try (fst o dest_Type) |> Option.mapPartial (ctr_sugar_of lthy) of SOME {discs, T = Type (_, Ts), ...} => (case const_of discs fun_t of SOME disc => let val arg' = arg |> typ_before explore params; val Type (_, Us) = fastype_of1 (bound_Us, arg'); val disc' = disc |> Term.subst_TVars (map (fst o dest_TVar) Ts ~~ Us); in disc' $ arg' end | NONE => explore params t) | NONE => explore params t) else explore params t end | _ => explore params t); fun massage_sel explore (params as {bound_Us, bound_Ts, ...}) t = let val (fun_t, args) = strip_comb t in if args = [] then explore params t else let val T = fastype_of1 (bound_Ts, hd args) in (case (Option.mapPartial (ctr_sugar_of lthy) (try (fst o dest_Type) T), T <> res_T) of (SOME {selss, T = Type (_, Ts), ...}, true) => (case const_of (flat selss) fun_t of SOME sel => let val args' = args |> map (typ_before explore params); val Type (_, Us) = fastype_of1 (bound_Us, hd args'); val sel' = sel |> Term.subst_TVars (map (fst o dest_TVar) Ts ~~ Us); in build_function_after_encapsulation sel sel' params args args' end | NONE => explore params t) | _ => explore params t) end end; fun massage_equality explore (params as {bound_Us, bound_Ts, ...}) (t as Const (\<^const_name>\HOL.eq\, _) $ t1 $ t2) = let val check_is_VLeaf = not o (Term.exists_subterm (fn t => t aconv CLeaf orelse t aconv Oper)); fun try_pattern_matching (fun_t, arg_ts) t = (case as_member_of pattern_ctrs fun_t of SOME (disc, sels) => let val t' = typ_before explore params t in if fastype_of1 (bound_Us, t') = YpreT then let val arg_ts' = map (typ_before explore params) arg_ts; val sels_t' = map (fn sel => betapply (sel, t')) sels; val Ts = map (curry fastype_of1 bound_Us) arg_ts'; val Us = map (curry fastype_of1 bound_Us) sels_t'; val arg_ts' = map2 encapsulate (map2 (update_UT params) Us Ts) arg_ts'; in if forall check_is_VLeaf arg_ts' then SOME (Library.foldl1 HOLogic.mk_conj (betapply (disc, t') :: (map HOLogic.mk_eq (arg_ts' ~~ sels_t')))) else NONE end else NONE end | NONE => NONE); in (case try_pattern_matching (strip_comb t1) t2 of SOME cond => cond | NONE => (case try_pattern_matching (strip_comb t2) t1 of SOME cond => cond | NONE => let val T = fastype_of1 (bound_Ts, t1); val params' = build_params bound_Us bound_Ts T; val t1' = explore params' t1; val t2' = explore params' t2; in if fastype_of1 (bound_Us, t1') = T andalso fastype_of1 (bound_Us, t2') = T then HOLogic.mk_eq (t1', t2') else error ("Unsupported condition: " ^ quote (Syntax.string_of_term lthy t)) end)) end | massage_equality explore params t = explore params t; fun infer_types (TVar _) (TVar _) = [] | infer_types (U as TVar _) T = [(U, T)] | infer_types (Type (s', Us)) (Type (s, Ts)) = if s' = s then flat (map2 infer_types Us Ts) else [] | infer_types _ _ = []; fun group_by_fst associations [] = associations | group_by_fst associations ((a, b) :: r) = group_by_fst (add_association a b associations) r and add_association a b [] = [(a, [b])] | add_association a b ((c, d) :: r) = if a = c then (c, b :: d) :: r else (c, d) :: (add_association a b r); fun new_TVar known_TVars = Name.invent_list (map (fst o fst o dest_TVar) known_TVars) "x" 1 |> (fn [s] => TVar ((s, 0), [])); fun instantiate_type inferred_types = Term.typ_subst_TVars (map (apfst (fst o dest_TVar)) inferred_types); fun chose_unknown_TVar (T as TVar _) = SOME T | chose_unknown_TVar (Type (_, Ts)) = fold (curry merge_options) (map chose_unknown_TVar Ts) NONE | chose_unknown_TVar _ = NONE; (* The function under definition might not be defined yet when this is queried. *) fun maybe_const_type ctxt (s, T) = Sign.const_type (Proof_Context.theory_of ctxt) s |> the_default T; fun massage_const polymorphic explore (params as {bound_Us, ...}) t = let val (fun_t, arg_ts) = strip_comb t in (case fun_t of Const (fun_x as (s, fun_T)) => let val general_T = if polymorphic then maybe_const_type lthy fun_x else fun_T in if fun_t aconv friend_tm orelse contains_res_T (body_type general_T) orelse is_constant t then explore params t else let val inferred_types = infer_types general_T fun_T; fun prepare_skeleton [] _ = [] | prepare_skeleton ((T, U) :: inferred_types) As = let fun schematize_res_T U As = if U = res_T then let val A = new_TVar As in (A, A :: As) end else (case U of Type (s, Us) => fold_map schematize_res_T Us As |>> curry Type s | _ => (U, As)); val (U', As') = schematize_res_T U As; in (T, U') :: (prepare_skeleton inferred_types As') end; val inferred_types' = prepare_skeleton inferred_types (map fst inferred_types); val skeleton_T = instantiate_type inferred_types' general_T; fun explore_if_possible (exp_arg as (_, true)) _ = exp_arg | explore_if_possible (exp_arg as (arg, false)) arg_T = if exists (exists_subtype is_TVar) (binder_types arg_T) then exp_arg else (typ_before (explore_fun (binder_types arg_T) explore) params arg, true); fun collect_inferred_types [] _ = [] | collect_inferred_types ((arg, explored) :: exp_arg_ts) (arg_T :: arg_Ts) = (if explored then infer_types arg_T (fastype_of1 (bound_Us, arg)) else []) @ collect_inferred_types exp_arg_ts arg_Ts; fun propagate exp_arg_ts skeleton_T = let val arg_gen_Ts = binder_types skeleton_T; val exp_arg_ts = map2 explore_if_possible exp_arg_ts arg_gen_Ts; val inferred_types = collect_inferred_types exp_arg_ts arg_gen_Ts |> group_by_fst [] |> map (apsnd (deduce_according_type ssig_T)); in (exp_arg_ts, instantiate_type inferred_types skeleton_T) end; val remaining_to_be_explored = filter_out snd #> length; fun try_exploring_args exp_arg_ts skeleton_T = let val n = remaining_to_be_explored exp_arg_ts; val (exp_arg_ts', skeleton_T') = propagate exp_arg_ts skeleton_T; val n' = remaining_to_be_explored exp_arg_ts'; fun try_instantiating A T = try (try_exploring_args exp_arg_ts') (instantiate_type [(A, T)] skeleton_T'); in if n' = 0 then SOME (exp_arg_ts', skeleton_T') else if n = n' then if exists_subtype is_TVar skeleton_T' then let val SOME A = chose_unknown_TVar skeleton_T' in (case try_instantiating A ssig_T of SOME result => result | NONE => (case try_instantiating A YpreT of SOME result => result | NONE => (case try_instantiating A res_T of SOME result => result | NONE => NONE))) end else NONE else try_exploring_args exp_arg_ts' skeleton_T' end; in (case try_exploring_args (map (fn arg => (arg, false)) arg_ts) skeleton_T of SOME (exp_arg_ts, fun_U) => let val arg_ts' = map fst exp_arg_ts; val fun_t' = Const (s, fun_U); fun finish_off () = let val t' = build_function_after_encapsulation fun_t fun_t' params arg_ts arg_ts'; in if can type_of1 (bound_Us, t') then (if fun_T = fun_U orelse is_special_parametric_const (s, fun_T) then () else add_parametric_const s general_T fun_T fun_U; t') else explore params t end; in if polymorphic then finish_off () else (case try finish_off () of SOME t' => t' | NONE => explore params t) end | NONE => explore params t) end end | _ => explore params t) end; fun massage_rho explore = massage_star [massage_let, massage_if explore_cond, massage_case, massage_fun, massage_comp, massage_map, massage_ctr, massage_sel, massage_disc, massage_equality, massage_const false, massage_const true] explore and massage_case explore (params as {bound_Ts, bound_Us, ...}) t = (case strip_comb t of (casex as Const (case_x as (c, _)), args as _ :: _ :: _) => (case try strip_fun_type (maybe_const_type lthy case_x) of SOME (gen_branch_Ts, gen_body_fun_T) => let val gen_branch_ms = map num_binder_types gen_branch_Ts; val n = length gen_branch_ms; val (branches, obj_leftovers) = chop n args; in if n < length args then (case gen_body_fun_T of Type (_, [Type (T_name, _), _]) => if case_of lthy T_name = SOME (c, true) then let val brancheTs = binder_fun_types (fastype_of1 (bound_Ts, casex)); val obj_leftover_Ts = map (curry fastype_of1 bound_Ts) obj_leftovers; val obj_leftovers' = if is_constant (hd obj_leftovers) then obj_leftovers else (obj_leftover_Ts, obj_leftovers) |>> map (build_params bound_Us bound_Ts) |> op ~~ |> map (uncurry explore_inner); val obj_leftoverUs = obj_leftovers' |> map (curry fastype_of1 bound_Us); val _ = is_valid_case_argumentT (hd obj_leftoverUs) orelse error (quote (Syntax.string_of_term lthy (hd obj_leftovers)) ^ " is not a valid case argument"); val Us = obj_leftoverUs |> hd |> dest_Type |> snd; val branche_binderUss = (if hd obj_leftoverUs = YpreT then mk_case HOLogic.boolT else update_case Us HOLogic.boolT casex) |> fastype_of |> binder_fun_types |> map binder_types; val b_params = map (build_params bound_Us bound_Ts) brancheTs; val branches' = branches |> @{map 4} explore_fun branche_binderUss (replicate n explore) b_params; val brancheUs = map (curry fastype_of1 bound_Us) branches'; val U = deduce_according_type (body_type (hd brancheTs)) (map body_type brancheUs); val casex' = if hd obj_leftoverUs = YpreT then mk_case U else update_case Us U casex; in build_function_after_encapsulation casex casex' params (branches @ obj_leftovers) (branches' @ obj_leftovers') end else explore params t | _ => explore params t) else explore params t end | NONE => explore params t) | _ => explore params t) and explore_cond params t = if has_self_call t then unexpected_rec_call_in lthy [] t else explore_inner params t and explore_inner params t = massage_rho explore_inner_general params t and explore_inner_general (params as {bound_Us, bound_Ts, T, ...}) t = let val (fun_t, arg_ts) = strip_comb t in if is_constant t then t else (case (as_member_of discs fun_t, length arg_ts = 1 andalso has_res_T bound_Ts (the_single arg_ts)) of (SOME disc', true) => let val arg' = explore_inner params (the_single arg_ts); val arg_U = fastype_of1 (bound_Us, arg'); in if arg_U = res_T then fun_t $ arg' else if arg_U = YpreT then disc' $ arg' else error ("Discriminator " ^ quote (Syntax.string_of_term lthy fun_t) ^ " cannot be applied to non-variable " ^ quote (Syntax.string_of_term lthy (hd arg_ts))) end | _ => (case as_member_of sels fun_t of SOME sel' => let val arg_ts' = map (explore_inner params) arg_ts; val arg_U = fastype_of1 (bound_Us, hd arg_ts'); in if arg_U = res_T then build_function_after_encapsulation fun_t fun_t params arg_ts arg_ts' else if arg_U = YpreT then build_function_after_encapsulation fun_t sel' params arg_ts arg_ts' else error ("Selector " ^ quote (Syntax.string_of_term lthy fun_t) ^ " cannot be applied to non-variable " ^ quote (Syntax.string_of_term lthy (hd arg_ts))) end | NONE => (case as_member_of friends fun_t of SOME (_, friend') => rebuild_function_after_exploration fun_t friend' explore_inner params arg_ts |> curry (op $) Oper | NONE => (case as_member_of ctr_guards fun_t of SOME ctr_guard' => rebuild_function_after_exploration fun_t ctr_guard' explore_inner params arg_ts |> curry (op $) ctr_wrapper |> curry (op $) Oper | NONE => if is_Bound fun_t then rebuild_function_after_exploration fun_t fun_t explore_inner params arg_ts else if is_Free fun_t then let val fun_t' = map_types (fpT_to YpreT) fun_t in rebuild_function_after_exploration fun_t fun_t' explore_inner params arg_ts end else if T = res_T then error (quote (Syntax.string_of_term lthy fun_t) ^ " not polymorphic enough to be applied like this and no friend") else error (quote (Syntax.string_of_term lthy fun_t) ^ " not polymorphic enough to be applied like this"))))) end; fun explore_ctr params t = massage_rho explore_ctr_general params t and explore_ctr_general params t = let val (fun_t, arg_ts) = strip_comb t; val ctr_opt = as_member_of ctr_guards fun_t; in if is_some ctr_opt then rebuild_function_after_exploration fun_t (the ctr_opt) explore_inner params arg_ts else not_constructor_in_rhs lthy [] fun_t end; val rho_rhs = rhs |> explore_ctr (build_params [] [] (fastype_of rhs)) |> abs_tuple_balanced (map (map_types (fpT_to YpreT)) lhs_args) |> unfold_id_bnf_etc lthy; in lthy |> define_const false b version rhoN rho_rhs |>> pair (!parametric_consts, rho_rhs) end; fun mk_rho_parametricity_goal ctxt Y Z preT ssig_T dead_pre_rel dead_k_rel dead_ssig_rel rho_rhs = let val YpreT = HOLogic.mk_prodT (Y, preT); val ZpreT = Tsubst Y Z YpreT; val ssigZ_T = Tsubst Y Z ssig_T; val dead_pre_rel' = Term.subst_atomic_types [(Y, ssig_T), (Z, ssigZ_T)] dead_pre_rel; val dead_k_rel' = Term.subst_atomic_types [(Y, YpreT), (Z, ZpreT)] dead_k_rel; val (R, _) = ctxt |> yield_singleton (mk_Frees "R") (mk_pred2T Y Z); val rho_rel = mk_rel_fun (dead_k_rel' $ mk_rel_prod R (dead_pre_rel $ R)) (dead_pre_rel' $ (dead_ssig_rel $ R)); val rho_rhsZ = substT Y Z rho_rhs; in HOLogic.mk_Trueprop (rho_rel $ rho_rhs $ rho_rhsZ) end; fun extract_rho_return_transfer_goals fun_b version dead_pre_bnf dead_k_bnf Y Z preT k_T ssig_T ssig_fp_sugar friend_parse_info fun_t parsed_eq lthy = let fun mk_rel T bnf = let val ZT = Tsubst Y Z T; val rel_T = mk_predT [mk_pred2T Y Z, T, ZT]; in enforce_type lthy I rel_T (rel_of_bnf bnf) end; val ssig_bnf = #fp_bnf ssig_fp_sugar; val (dead_ssig_bnf, lthy) = bnf_kill_all_but 1 ssig_bnf lthy; val dead_pre_rel = mk_rel preT dead_pre_bnf; val dead_k_rel = mk_rel k_T dead_k_bnf; val dead_ssig_rel = mk_rel ssig_T dead_ssig_bnf; val (((parametric_consts, rho_rhs), rho_data), lthy) = extract_rho_from_equation friend_parse_info fun_b version Y preT ssig_T fun_t parsed_eq lthy; val const_transfer_goals = map (mk_const_transfer_goal lthy) parametric_consts; val rho_transfer_goal = mk_rho_parametricity_goal lthy Y Z preT ssig_T dead_pre_rel dead_k_rel dead_ssig_rel rho_rhs; in ((rho_data, (const_transfer_goals, rho_transfer_goal)), lthy) end; fun explore_corec_equation ctxt could_be_friend friend fun_name fun_free {outer_buffer, ctr_guards, inner_buffer} res_T (args, rhs) = let val is_self_call = curry (op aconv) fun_free; val has_self_call = Term.exists_subterm is_self_call; val outer_ssig_T = body_type (fastype_of (#Oper outer_buffer)); fun inner_fp_of (Free (s, _)) = Free (s ^ inner_fp_suffix, mk_tupleT_balanced (map fastype_of args) --> outer_ssig_T); fun build_params bound_Ts U T = {bound_Us = bound_Ts, bound_Ts = bound_Ts, U = U, T = T}; fun rebuild_function_after_exploration new_fn explore {bound_Ts, ...} arg_ts = let val binder_types_old_fn = map (curry fastype_of1 bound_Ts) arg_ts; val binder_types_new_fn = new_fn |> binder_types o (curry fastype_of1 bound_Ts) |> take (length binder_types_old_fn); val paramss = map2 (build_params bound_Ts) binder_types_new_fn binder_types_old_fn; in map2 explore paramss arg_ts |> curry list_comb new_fn end; fun massage_map_corec explore {bound_Ts, U, T, ...} t = let val explore' = explore ooo build_params in massage_nested_corec_call ctxt has_self_call explore' explore' bound_Ts U T t end; fun massage_comp explore params t = (case strip_comb t of (Const (\<^const_name>\comp\, _), f1 :: f2 :: args) => explore params (betapply (f1, (betapplys (f2, args)))) | _ => explore params t); fun massage_fun explore (params as {bound_Us, bound_Ts, U, T}) t = if can dest_funT T then let val arg_T = domain_type T; val arg_name = the_default Name.uu (try (fn (Abs (s, _, _)) => s) t); in add_boundvar t |> explore {bound_Us = arg_T :: bound_Us, bound_Ts = arg_T :: bound_Ts, U = range_type U, T = range_type T} |> (fn t => Abs (arg_name, arg_T, t)) end else explore params t fun massage_let_if_case_corec explore {bound_Ts, U, T, ...} t = massage_let_if_case ctxt has_self_call (fn bound_Ts => explore (build_params bound_Ts U T)) (K (unexpected_corec_call_in ctxt [t])) (K (unsupported_case_around_corec_call ctxt [t])) bound_Ts t; val massage_map_let_if_case = massage_star [massage_map_corec, massage_fun, massage_comp, massage_let_if_case_corec]; fun explore_arg _ t = if has_self_call t then error (quote (Syntax.string_of_term ctxt t) ^ " contains a nested corecursive call" ^ (if could_be_friend then " (try specifying \"(friend)\")" else "")) else t; fun explore_inner params t = massage_map_let_if_case explore_inner_general params t and explore_inner_general (params as {bound_Ts, T, ...}) t = if T = res_T then let val (f_t, arg_ts) = strip_comb t in if has_self_call t then (case as_member_of (#friends inner_buffer) f_t of SOME (_, friend') => rebuild_function_after_exploration friend' explore_inner params arg_ts |> curry (op $) (#Oper inner_buffer) | NONE => (case as_member_of ctr_guards f_t of SOME ctr_guard' => rebuild_function_after_exploration ctr_guard' explore_inner params arg_ts |> curry (op $) (#ctr_wrapper inner_buffer) |> curry (op $) (#Oper inner_buffer) | NONE => if is_self_call f_t then if friend andalso exists has_self_call arg_ts then (case Symtab.lookup (#friends inner_buffer) fun_name of SOME (_, friend') => rebuild_function_after_exploration friend' explore_inner params arg_ts |> curry (op $) (#Oper inner_buffer)) else let val arg_Ts = binder_types (fastype_of1 (bound_Ts, f_t)) in map2 explore_arg (map2 (update_UT params) arg_Ts arg_Ts) arg_ts |> mk_tuple1_balanced bound_Ts |> curry (op $) (#VLeaf inner_buffer) end else error (quote (Syntax.string_of_term ctxt f_t) ^ " not registered as friend"))) else #CLeaf inner_buffer $ t end else if has_self_call t then error (quote (Syntax.string_of_term ctxt t) ^ " contains a corecursive call but has type " ^ quote (Syntax.string_of_typ ctxt T)) else explore_nested ctxt explore_inner_general params t; fun explore_outer params t = massage_map_let_if_case explore_outer_general params t and explore_outer_general (params as {bound_Ts, T, ...}) t = if T = res_T then let val (f_t, arg_ts) = strip_comb t in (case as_member_of ctr_guards f_t of SOME ctr_guard' => rebuild_function_after_exploration ctr_guard' explore_inner params arg_ts |> curry (op $) (#VLeaf outer_buffer) | NONE => if not (has_self_call t) then t |> expand_to_ctr_term ctxt T |> massage_let_if_case_corec explore_outer_general params else (case as_member_of (#friends outer_buffer) f_t of SOME (_, friend') => rebuild_function_after_exploration friend' explore_outer params arg_ts |> curry (op $) (#Oper outer_buffer) | NONE => if is_self_call f_t then let val arg_Ts = binder_types (fastype_of1 (bound_Ts, f_t)) in map2 explore_arg (map2 (update_UT params) arg_Ts arg_Ts) arg_ts |> mk_tuple1_balanced bound_Ts |> curry (op $) (inner_fp_of f_t) end else error (quote (Syntax.string_of_term ctxt f_t) ^ " not registered as friend"))) end else if has_self_call t then error (quote (Syntax.string_of_term ctxt t) ^ " contains a corecursive call but has type " ^ quote (Syntax.string_of_typ ctxt T)) else explore_nested ctxt explore_outer_general params t; in (args, rhs |> explore_outer (build_params [] outer_ssig_T res_T) |> abs_tuple_balanced args) end; fun mk_corec_fun_def_rhs ctxt arg_Ts corecUU0 corecUU_arg = let val corecUU = enforce_type ctxt domain_type (fastype_of corecUU_arg) corecUU0 in abs_curried_balanced arg_Ts (corecUU $ unfold_id_bnf_etc ctxt corecUU_arg) end; fun get_options ctxt opts = let val plugins = get_first (fn Plugins_Option f => SOME (f ctxt) | _ => NONE) (rev opts) |> the_default Plugin_Name.default_filter; val friend = exists (can (fn Friend_Option => ())) opts; val transfer = exists (can (fn Transfer_Option => ())) opts; in (plugins, friend, transfer) end; fun add_function binding parsed_eq lthy = let fun pat_completeness_auto ctxt = Pat_Completeness.pat_completeness_tac ctxt 1 THEN auto_tac ctxt; val ({defname, pelims = [[pelim]], pinducts = [pinduct], psimps = [psimp], ...}, lthy) = Function.add_function [(Binding.concealed binding, NONE, NoSyn)] [(((Binding.concealed Binding.empty, []), parsed_eq), [], [])] Function_Common.default_config pat_completeness_auto lthy; in ((defname, (pelim, pinduct, psimp)), lthy) end; fun build_corecUU_arg_and_goals prove_termin (Free (fun_base_name, _)) (arg_ts, explored_rhs) lthy = let val inner_fp_name0 = fun_base_name ^ inner_fp_suffix; val inner_fp_free = Free (inner_fp_name0, fastype_of explored_rhs); in if Term.exists_subterm (curry (op aconv) inner_fp_free) explored_rhs then let val arg = mk_tuple_balanced arg_ts; val inner_fp_eq = mk_Trueprop_eq (betapply (inner_fp_free, arg), betapply (explored_rhs, arg)); val ((inner_fp_name, (pelim, pinduct, psimp)), lthy') = add_function (Binding.name inner_fp_name0) inner_fp_eq lthy; fun mk_triple elim induct simp = ([elim], [induct], [simp]); fun prepare_termin () = let val {goal, ...} = Proof.goal (Function.termination NONE lthy'); val termin_goal = goal |> Thm.concl_of |> Logic.unprotect |> Envir.beta_eta_contract; in (lthy', (mk_triple pelim pinduct psimp, [termin_goal])) end; val (lthy'', (inner_fp_triple, termin_goals)) = if prove_termin then (case try (Function.prove_termination NONE (Function_Common.termination_prover_tac true lthy')) lthy' of NONE => prepare_termin () | SOME ({elims = SOME [[elim]], inducts = SOME [induct], simps = SOME [simp], ...}, lthy'') => (lthy'', (mk_triple elim induct simp, []))) else prepare_termin (); val inner_fp_const = (Binding.name_of inner_fp_name, fastype_of explored_rhs) |>> Proof_Context.read_const {proper = true, strict = false} lthy' |> (fn (Const (s, _), T) => Const (s, T)); in (((inner_fp_triple, termin_goals), inner_fp_const), lthy'') end else (((([], [], []), []), explored_rhs), lthy) end; fun derive_eq_corecUU ctxt {sig_fp_sugars, ssig_fp_sugar, eval, corecUU, eval_simps, all_algLam_algs, corecUU_unique, ...} fun_t corecUU_arg fun_code = let val fun_T = fastype_of fun_t; val (arg_Ts, Type (fpT_name, _)) = strip_type fun_T; val num_args = length arg_Ts; val SOME {pre_bnf, fp_bnf, absT_info, fp_nesting_bnfs, live_nesting_bnfs, fp_ctr_sugar, ...} = fp_sugar_of ctxt fpT_name; val SOME {case_trivial, ...} = codatatype_extra_of ctxt fpT_name; val ctr_sugar = #ctr_sugar fp_ctr_sugar; val pre_map_def = map_def_of_bnf pre_bnf; val abs_inverse = #abs_inverse absT_info; val ctr_defs = #ctr_defs fp_ctr_sugar; val case_eq_ifs = #case_eq_ifs ctr_sugar @ case_eq_if_thms_of_term ctxt (Thm.prop_of fun_code); val all_sig_map_thms = maps (#map_thms o #fp_bnf_sugar) sig_fp_sugars; val fp_map_ident = map_ident_of_bnf fp_bnf; val fpsig_nesting_bnfs = fp_nesting_bnfs @ maps #live_nesting_bnfs sig_fp_sugars; val fpsig_nesting_T_names = map (fst o dest_Type o T_of_bnf) fpsig_nesting_bnfs; val fpsig_nesting_fp_sugars = map_filter (fp_sugar_of ctxt) fpsig_nesting_T_names; val fpsig_nesting_fp_bnf_sugars = map #fp_bnf_sugar fpsig_nesting_fp_sugars; val ssig_fp_bnf_sugar = #fp_bnf_sugar ssig_fp_sugar; val ssig_bnf = #fp_bnf ssig_fp_sugar; val ssig_map = map_of_bnf ssig_bnf; val fpsig_nesting_maps = map map_of_bnf fpsig_nesting_bnfs; val fpsig_nesting_map_ident0s = map map_ident0_of_bnf fpsig_nesting_bnfs; val fpsig_nesting_map_comps = map map_comp_of_bnf fpsig_nesting_bnfs; val fpsig_nesting_map_thms = maps #map_thms fpsig_nesting_fp_bnf_sugars; val live_nesting_map_ident0s = map map_ident0_of_bnf live_nesting_bnfs; val ssig_map_thms = #map_thms ssig_fp_bnf_sugar; val all_algLam_alg_pointfuls = map (mk_pointful ctxt) all_algLam_algs; val def_rhs = mk_corec_fun_def_rhs ctxt arg_Ts corecUU corecUU_arg; val goal = mk_Trueprop_eq (fun_t, def_rhs); in Goal.prove_sorry ctxt [] [] goal (fn {context = ctxt, prems = _} => mk_eq_corecUU_tac ctxt num_args fpsig_nesting_maps ssig_map eval pre_map_def abs_inverse fpsig_nesting_map_ident0s fpsig_nesting_map_comps fpsig_nesting_map_thms live_nesting_map_ident0s fp_map_ident case_trivial ctr_defs case_eq_ifs all_sig_map_thms ssig_map_thms all_algLam_alg_pointfuls (all_algrho_eqs_of ctxt) eval_simps corecUU_unique fun_code) |> Thm.close_derivation \<^here> end; fun derive_coinduct_cong_intros ({fpT = fpT0 as Type (fpT_name, _), friend_names = friend_names0, corecUU = Const (corecUU_name, _), dtor_coinduct_info as {dtor_coinduct, ...}, ...}) lthy = let val thy = Proof_Context.theory_of lthy; val phi = Proof_Context.export_morphism lthy (Local_Theory.target_of lthy); val fpT = Morphism.typ phi fpT0; val general_fpT = body_type (Sign.the_const_type thy corecUU_name); val most_general = Sign.typ_instance thy (general_fpT, fpT); in (case (most_general, coinduct_extra_of lthy corecUU_name) of (true, SOME extra) => ((false, extra), lthy) | _ => let val ctr_names = ctr_names_of_fp_name lthy fpT_name; val friend_names = friend_names0 |> map Long_Name.base_name |> rev; val cong_intro_pairs = derive_cong_intros lthy ctr_names friend_names dtor_coinduct_info; val (coinduct, coinduct_attrs) = derive_coinduct lthy fpT0 dtor_coinduct; val ((_, [coinduct]), lthy) = (* TODO check: only if most_general?*) Local_Theory.note ((Binding.empty, coinduct_attrs), [coinduct]) lthy; val extra = {coinduct = coinduct, coinduct_attrs = coinduct_attrs, cong_intro_pairs = cong_intro_pairs}; in ((most_general, extra), lthy |> most_general ? register_coinduct_extra corecUU_name extra) end) end; fun update_coinduct_cong_intross_dynamic fpT_name lthy = let val all_corec_infos = corec_infos_of lthy fpT_name in lthy |> fold_map (apfst snd oo derive_coinduct_cong_intros) all_corec_infos |> snd end; fun derive_and_update_coinduct_cong_intross [] = pair (false, []) | derive_and_update_coinduct_cong_intross (corec_infos as {fpT = Type (fpT_name, _), ...} :: _) = fold_map derive_coinduct_cong_intros corec_infos #>> split_list #> (fn ((changeds, extras), lthy) => if exists I changeds then ((true, extras), lthy |> update_coinduct_cong_intross_dynamic fpT_name) else ((false, extras), lthy)); fun prepare_corec_ursive_cmd int long_cmd opts (raw_fixes, raw_eq) lthy = let val _ = can the_single raw_fixes orelse error "Mutually corecursive functions not supported"; val (plugins, friend, transfer) = get_options lthy opts; val ([((b, fun_T), mx)], [(_, eq)]) = fst (Specification.read_multi_specs raw_fixes [((Binding.empty_atts, raw_eq), [], [])] lthy); val _ = check_top_sort lthy b fun_T; val (arg_Ts, res_T) = strip_type fun_T; val fpT_name = (case res_T of Type (s, _) => s | _ => not_codatatype lthy res_T); val fun_free = Free (Binding.name_of b, fun_T); val parsed_eq = parse_corec_equation lthy [fun_free] eq; val fun_name = Local_Theory.full_name lthy b; val fun_t = Const (fun_name, fun_T); (* FIXME: does this work with locales that fix variables? *) val no_base = has_no_corec_info lthy fpT_name; val lthy = lthy |> no_base ? setup_base fpT_name; fun extract_rho lthy = let val lthy = lthy |> Variable.declare_typ fun_T; val (prepared as (_, _, version, Y, Z, preT, k_T, ssig_T, dead_pre_bnf, dead_k_bnf, _, ssig_fp_sugar, buffer), lthy) = prepare_friend_corec fun_name fun_T lthy; val friend_parse_info = friend_parse_info_of lthy arg_Ts res_T buffer; val parsed_eq' = parsed_eq ||> subst_atomic [(fun_free, fun_t)]; in lthy |> extract_rho_return_transfer_goals b version dead_pre_bnf dead_k_bnf Y Z preT k_T ssig_T ssig_fp_sugar friend_parse_info fun_t parsed_eq' |>> pair prepared end; val ((prepareds, (rho_datas, transfer_goal_datas)), lthy) = if friend then extract_rho lthy |>> (apfst single ##> (apfst single #> apsnd single)) else (([], ([], [])), lthy); val ((buffer, corec_infos), lthy) = if friend then ((#13 (the_single prepareds), []), lthy) else corec_info_of res_T lthy ||> no_base ? update_coinduct_cong_intross_dynamic fpT_name |>> (fn info as {buffer, ...} => (buffer, [info])); val corec_parse_info = corec_parse_info_of lthy arg_Ts res_T buffer; val explored_eq = explore_corec_equation lthy true friend fun_name fun_free corec_parse_info res_T parsed_eq; val (((inner_fp_triple, termin_goals), corecUU_arg), lthy) = build_corecUU_arg_and_goals (not long_cmd) fun_free explored_eq lthy; fun def_fun (inner_fp_elims0, inner_fp_inducts0, inner_fp_simps0) const_transfers rho_transfers_foldeds lthy = let fun register_friend lthy = let val [(old_corec_info, fp_b, version, Y, Z, _, k_T, _, _, dead_k_bnf, sig_fp_sugar, ssig_fp_sugar, _)] = prepareds; val [(rho, rho_def)] = rho_datas; val [(_, rho_transfer_goal)] = transfer_goal_datas; val Type (fpT_name, _) = res_T; val rho_transfer_folded = (case rho_transfers_foldeds of [] => derive_rho_transfer_folded lthy fpT_name const_transfers rho_def rho_transfer_goal | [thm] => thm); in lthy |> register_coinduct_dynamic_friend fpT_name fun_name |> register_friend_corec fun_name fp_b version Y Z k_T dead_k_bnf sig_fp_sugar ssig_fp_sugar fun_t rho rho_transfer_folded old_corec_info end; val (friend_infos, lthy) = lthy |> (if friend then register_friend #>> single else pair []); val (corec_info as {corecUU = corecUU0, ...}, lthy) = (case corec_infos of [] => corec_info_of res_T lthy | [info] => (info, lthy)); val def_rhs = mk_corec_fun_def_rhs lthy arg_Ts corecUU0 corecUU_arg; val def = ((b, mx), ((Binding.concealed (Thm.def_binding b), []), def_rhs)); val ((fun_t0, (_, fun_def0)), (lthy, lthy_old)) = lthy |> Local_Theory.open_target |> snd |> Local_Theory.define def |> tap (fn (def, lthy) => print_def_consts int [def] lthy) ||> `Local_Theory.close_target; val parsed_eq = parse_corec_equation lthy [fun_free] eq; val views0 = generate_views lthy eq fun_free parsed_eq; val lthy' = lthy |> fold Variable.declare_typ (res_T :: arg_Ts); val phi = Proof_Context.export_morphism lthy_old lthy'; val fun_t = Morphism.term phi fun_t0; (* FIXME: shadows "fun_t" -- identical? *) val fun_def = Morphism.thm phi fun_def0; val inner_fp_elims = map (Morphism.thm phi) inner_fp_elims0; val inner_fp_inducts = map (Morphism.thm phi) inner_fp_inducts0; val inner_fp_simps = map (Morphism.thm phi) inner_fp_simps0; val (code_goal, _, _, _, _) = morph_views phi views0; fun derive_and_note_friend_extra_theorems lthy = let val k_T = #7 (the_single prepareds); val rho_def = snd (the_single rho_datas); val (eq_algrho, algrho_eq) = derive_eq_algrho lthy corec_info (the_single friend_infos) fun_t k_T code_goal const_transfers rho_def fun_def; val notes = (if Config.get lthy bnf_internals then [(eq_algrhoN, [eq_algrho])] else []) |> map (fn (thmN, thms) => ((Binding.qualify true (Binding.name_of b) (Binding.qualify false friendN (Binding.name thmN)), []), [(thms, [])])); in lthy |> register_friend_extra fun_name eq_algrho algrho_eq |> Local_Theory.notes notes |> snd end; val lthy = lthy |> friend ? derive_and_note_friend_extra_theorems; val code_thm = derive_code lthy inner_fp_simps code_goal corec_info fun_t fun_def; (* TODO: val ctr_thmss = map mk_thm (#2 views); val disc_thmss = map mk_thm (#3 views); val disc_iff_thmss = map mk_thm (#4 views); val sel_thmss = map mk_thm (#5 views); *) val uniques = if null inner_fp_simps then [derive_unique lthy phi (#1 views0) corec_info fpT_name fun_def] else []; (* TODO: val disc_iff_or_disc_thmss = map2 (fn [] => I | disc_iffs => K disc_iffs) disc_iff_thmss disc_thmss; val simp_thmss = map2 append disc_iff_or_disc_thmss sel_thmss; *) val ((_, [{cong_intro_pairs, coinduct, coinduct_attrs}]), lthy) = lthy |> derive_and_update_coinduct_cong_intross [corec_info]; val cong_intros_pairs = AList.group (op =) cong_intro_pairs; val anonymous_notes = []; (* TODO: [(flat disc_iff_or_disc_thmss, simp_attrs)] |> map (fn (thms, attrs) => ((Binding.empty, attrs), [(thms, [])])); *) val notes = [(cong_introsN, maps snd cong_intros_pairs, []), (codeN, [code_thm], nitpicksimp_attrs), (coinductN, [coinduct], coinduct_attrs), (inner_inductN, inner_fp_inducts, []), (uniqueN, uniques, [])] @ map (fn (thmN, thms) => (thmN, thms, [])) cong_intros_pairs @ (if Config.get lthy bnf_internals then [(inner_elimN, inner_fp_elims, []), (inner_simpN, inner_fp_simps, [])] else []) (* TODO: (ctrN, ctr_thms, []), (discN, disc_thms, []), (disc_iffN, disc_iff_thms, []), (selN, sel_thms, simp_attrs), (simpsN, simp_thms, []), *) |> map (fn (thmN, thms, attrs) => ((Binding.qualify true (Binding.name_of b) (Binding.qualify false corecN (Binding.name thmN)), attrs), [(thms, [])])) |> filter_out (null o fst o hd o snd); in lthy (* TODO: |> Spec_Rules.add Spec_Rules.equational ([fun_t0], flat sel_thmss) |> Spec_Rules.add Spec_Rules.equational ([fun_t0], flat ctr_thmss) *) - |> Spec_Rules.add Spec_Rules.equational ([fun_t0], [code_thm]) + |> Spec_Rules.add "" Spec_Rules.equational [fun_t0] [code_thm] |> plugins code_plugin ? Code.declare_default_eqns [(code_thm, true)] |> Local_Theory.notes (anonymous_notes @ notes) |> snd end; fun prove_transfer_goal ctxt goal = Variable.add_free_names ctxt goal [] |> (fn vars => Goal.prove (*no sorry*) ctxt vars [] goal (fn {context = ctxt, prems = _} => HEADGOAL (Transfer.transfer_prover_tac ctxt))) |> Thm.close_derivation \<^here>; fun maybe_prove_transfer_goal ctxt goal = (case try (prove_transfer_goal ctxt) goal of SOME thm => apfst (cons thm) | NONE => apsnd (cons goal)); val const_transfer_goals = fold (union (op aconv) o fst) transfer_goal_datas []; val (const_transfers, const_transfer_goals') = if long_cmd then ([], const_transfer_goals) else fold (maybe_prove_transfer_goal lthy) const_transfer_goals ([], []); in ((def_fun, (([res_T], prepareds, rho_datas, map snd transfer_goal_datas), (inner_fp_triple, termin_goals), (const_transfers, const_transfer_goals'))), lthy) end; fun corec_cmd int opts (raw_fixes, raw_eq) lthy = let val ((def_fun, (_, (inner_fp_triple, termin_goals), (const_transfers, const_transfer_goals))), lthy) = prepare_corec_ursive_cmd int false opts (raw_fixes, raw_eq) lthy; in if not (null termin_goals) then error ("Termination prover failed (try " ^ quote (#1 \<^command_keyword>\corecursive\) ^ " instead of " ^ quote (#1 \<^command_keyword>\corec\) ^ ")") else if not (null const_transfer_goals) then error ("Transfer prover failed (try " ^ quote (#1 \<^command_keyword>\corecursive\) ^ " instead of " ^ quote (#1 \<^command_keyword>\corec\) ^ ")") else def_fun inner_fp_triple const_transfers [] lthy end; fun corecursive_cmd int opts (raw_fixes, raw_eq) lthy = let val ((def_fun, (([Type (fpT_name, _)], prepareds, rho_datas, rho_transfer_goals), (inner_fp_triple, termin_goals), (const_transfers, const_transfer_goals))), lthy) = prepare_corec_ursive_cmd int true opts (raw_fixes, raw_eq) lthy; val (rho_transfer_goals', unprime_rho_transfer_and_folds) = @{map 3} (fn (_, _, _, _, _, _, _, _, _, _, _, _, _) => fn (_, rho_def) => prime_rho_transfer_goal lthy fpT_name rho_def) prepareds rho_datas rho_transfer_goals |> split_list; in Proof.theorem NONE (fn [termin_thms, const_transfers', rho_transfers'] => let val remove_domain_condition = full_simplify (put_simpset HOL_basic_ss lthy addsimps (@{thm True_implies_equals} :: termin_thms)); in def_fun (@{apply 3} (map remove_domain_condition) inner_fp_triple) (const_transfers @ const_transfers') (map2 (fn f => f) unprime_rho_transfer_and_folds rho_transfers') end) (map (map (rpair [])) [termin_goals, const_transfer_goals, rho_transfer_goals']) lthy end; fun friend_of_corec_cmd ((raw_fun_name, raw_fun_T_opt), raw_eq) lthy = let val Const (fun_name, _) = Proof_Context.read_const {proper = true, strict = false} lthy raw_fun_name; val fake_lthy = lthy |> (case raw_fun_T_opt of SOME raw_T => Proof_Context.add_const_constraint (fun_name, SOME (Syntax.read_typ lthy raw_T)) | NONE => I) handle TYPE (s, _, _) => error s; val fun_b = Binding.name (Long_Name.base_name fun_name); val code_goal = Syntax.read_prop fake_lthy raw_eq; val fun_T = (case code_goal of \<^const>\Trueprop\ $ (Const (\<^const_name>\HOL.eq\, _) $ t $ _) => fastype_of (head_of t) | _ => ill_formed_equation_lhs_rhs lthy [code_goal]); val fun_t = Const (fun_name, fun_T); val (arg_Ts, res_T as Type (fpT_name, _)) = strip_type fun_T; val no_base = has_no_corec_info lthy fpT_name; val lthy = lthy |> no_base ? setup_base fpT_name; val lthy = lthy |> Variable.declare_typ fun_T; val ((old_corec_info, fp_b, version, Y, Z, preT, k_T, ssig_T, dead_pre_bnf, dead_k_bnf, sig_fp_sugar, ssig_fp_sugar, buffer), lthy) = prepare_friend_corec fun_name fun_T lthy; val friend_parse_info = friend_parse_info_of lthy arg_Ts res_T buffer; val parsed_eq = parse_corec_equation lthy [] code_goal; val (((rho, rho_def), (const_transfer_goals, rho_transfer_goal)), lthy) = extract_rho_return_transfer_goals fun_b version dead_pre_bnf dead_k_bnf Y Z preT k_T ssig_T ssig_fp_sugar friend_parse_info fun_t parsed_eq lthy; fun register_friend_extra_and_note_thms code_goal code_thm const_transfers k_T friend_info lthy = let val (corec_info, lthy) = corec_info_of res_T lthy; val fun_free = Free (Binding.name_of fun_b, fun_T); fun freeze_fun (t as Const (s, T)) = if s = fun_name andalso T = fun_T then fun_free else t | freeze_fun t = t; val eq = Term.map_aterms freeze_fun code_goal; val parsed_eq = parse_corec_equation lthy [fun_free] eq; val corec_parse_info = corec_parse_info_of lthy arg_Ts res_T buffer; val explored_eq = explore_corec_equation lthy false false fun_name fun_free corec_parse_info res_T parsed_eq; val ((_, corecUU_arg), _) = build_corecUU_arg_and_goals false fun_free explored_eq lthy; val eq_corecUU = derive_eq_corecUU lthy corec_info fun_t corecUU_arg code_thm; val (eq_algrho, algrho_eq) = derive_eq_algrho lthy corec_info friend_info fun_t k_T code_goal const_transfers rho_def eq_corecUU; val ((_, [{cong_intro_pairs, coinduct, coinduct_attrs}]), lthy) = lthy |> register_friend_extra fun_name eq_algrho algrho_eq |> register_coinduct_dynamic_friend fpT_name fun_name |> derive_and_update_coinduct_cong_intross [corec_info]; val cong_intros_pairs = AList.group (op =) cong_intro_pairs; val unique = derive_unique lthy Morphism.identity code_goal corec_info fpT_name eq_corecUU; val notes = [(codeN, [code_thm], []), (coinductN, [coinduct], coinduct_attrs), (cong_introsN, maps snd cong_intros_pairs, []), (uniqueN, [unique], [])] @ map (fn (thmN, thms) => (thmN, thms, [])) cong_intros_pairs @ (if Config.get lthy bnf_internals then [(eq_algrhoN, [eq_algrho], []), (eq_corecUUN, [eq_corecUU], [])] else []) |> map (fn (thmN, thms, attrs) => ((Binding.qualify true (Binding.name_of fun_b) (Binding.qualify false friendN (Binding.name thmN)), attrs), [(thms, [])])); in lthy |> Local_Theory.notes notes |> snd end; val (rho_transfer_goal', unprime_rho_transfer_and_fold) = prime_rho_transfer_goal lthy fpT_name rho_def rho_transfer_goal; in lthy |> Proof.theorem NONE (fn [[code_thm], const_transfers, [rho_transfer']] => register_friend_corec fun_name fp_b version Y Z k_T dead_k_bnf sig_fp_sugar ssig_fp_sugar fun_t rho (unprime_rho_transfer_and_fold rho_transfer') old_corec_info #-> register_friend_extra_and_note_thms code_goal code_thm const_transfers k_T) (map (map (rpair [])) [[code_goal], const_transfer_goals, [rho_transfer_goal']]) |> Proof.refine_singleton (Method.primitive_text (K I)) end; fun coinduction_upto_cmd (base_name, raw_fpT) lthy = let val fpT as Type (fpT_name, _) = Syntax.read_typ lthy raw_fpT; val no_base = has_no_corec_info lthy fpT_name; val (corec_info as {version, ...}, lthy) = lthy |> corec_info_of fpT; val lthy = lthy |> no_base ? setup_base fpT_name; val ((changed, [{cong_intro_pairs, coinduct, coinduct_attrs}]), lthy) = lthy |> derive_and_update_coinduct_cong_intross [corec_info]; val lthy = lthy |> (changed orelse no_base) ? update_coinduct_cong_intross_dynamic fpT_name; val cong_intros_pairs = AList.group (op =) cong_intro_pairs; val notes = [(cong_introsN, maps snd cong_intros_pairs, []), (coinduct_uptoN, [coinduct], coinduct_attrs)] @ map (fn (thmN, thms) => (thmN, thms, [])) cong_intros_pairs |> map (fn (thmN, thms, attrs) => (((Binding.qualify true base_name (Binding.qualify false ("v" ^ string_of_int version) (Binding.name thmN))), attrs), [(thms, [])])); in lthy |> Local_Theory.notes notes |> snd end; fun consolidate lthy = let val corec_infoss = map (corec_infos_of lthy o fst) (all_codatatype_extras_of lthy); val (changeds, lthy) = lthy |> fold_map (apfst fst oo derive_and_update_coinduct_cong_intross) corec_infoss; in if exists I changeds then lthy else raise Same.SAME end; fun consolidate_global thy = SOME (Named_Target.theory_map consolidate thy) handle Same.SAME => NONE; val _ = Outer_Syntax.local_theory \<^command_keyword>\corec\ "define nonprimitive corecursive functions" ((Scan.optional (\<^keyword>\(\ |-- Parse.!!! (Parse.list1 corec_option_parser) --| \<^keyword>\)\) []) -- (Parse.vars --| Parse.where_ -- Parse.prop) >> uncurry (corec_cmd true)); val _ = Outer_Syntax.local_theory_to_proof \<^command_keyword>\corecursive\ "define nonprimitive corecursive functions" ((Scan.optional (\<^keyword>\(\ |-- Parse.!!! (Parse.list1 corec_option_parser) --| \<^keyword>\)\) []) -- (Parse.vars --| Parse.where_ -- Parse.prop) >> uncurry (corecursive_cmd true)); val _ = Outer_Syntax.local_theory_to_proof \<^command_keyword>\friend_of_corec\ "register a function as a legal context for nonprimitive corecursion" (Parse.const -- Scan.option (Parse.$$$ "::" |-- Parse.typ) --| Parse.where_ -- Parse.prop >> friend_of_corec_cmd); val _ = Outer_Syntax.local_theory \<^command_keyword>\coinduction_upto\ "derive a coinduction up-to principle and a corresponding congruence closure" (Parse.name --| Parse.$$$ ":" -- Parse.typ >> coinduction_upto_cmd); val _ = Theory.setup (Theory.at_begin consolidate_global); end; diff --git a/src/HOL/Tools/BNF/bnf_gfp_rec_sugar.ML b/src/HOL/Tools/BNF/bnf_gfp_rec_sugar.ML --- a/src/HOL/Tools/BNF/bnf_gfp_rec_sugar.ML +++ b/src/HOL/Tools/BNF/bnf_gfp_rec_sugar.ML @@ -1,1606 +1,1606 @@ (* Title: HOL/Tools/BNF/bnf_gfp_rec_sugar.ML Author: Lorenz Panny, TU Muenchen Author: Jasmin Blanchette, TU Muenchen Copyright 2013 Corecursor sugar ("primcorec" and "primcorecursive"). *) signature BNF_GFP_REC_SUGAR = sig datatype corec_option = Plugins_Option of Proof.context -> Plugin_Name.filter | Sequential_Option | Exhaustive_Option | Transfer_Option datatype corec_call = Dummy_No_Corec of int | No_Corec of int | Mutual_Corec of int * int * int | Nested_Corec of int type corec_ctr_spec = {ctr: term, disc: term, sels: term list, pred: int option, calls: corec_call list, discI: thm, sel_thms: thm list, distinct_discss: thm list list, collapse: thm, corec_thm: thm, corec_disc: thm, corec_sels: thm list} type corec_spec = {T: typ, corec: term, exhaust_discs: thm list, sel_defs: thm list, fp_nesting_maps: thm list, fp_nesting_map_ident0s: thm list, fp_nesting_map_comps: thm list, ctr_specs: corec_ctr_spec list} val abstract_over_list: term list -> term -> term val abs_tuple_balanced: term list -> term -> term val mk_conjs: term list -> term val mk_disjs: term list -> term val mk_dnf: term list list -> term val conjuncts_s: term -> term list val s_not: term -> term val s_not_conj: term list -> term list val s_conjs: term list -> term val s_disjs: term list -> term val s_dnf: term list list -> term list val case_of: Proof.context -> string -> (string * bool) option val fold_rev_let_if_case: Proof.context -> (term list -> term -> 'a -> 'a) -> typ list -> term -> 'a -> 'a val massage_let_if_case: Proof.context -> (term -> bool) -> (typ list -> term -> term) -> (typ list -> term -> unit) -> (typ list -> term -> term) -> typ list -> term -> term val massage_nested_corec_call: Proof.context -> (term -> bool) -> (typ list -> typ -> typ -> term -> term) -> (typ list -> typ -> typ -> term -> term) -> typ list -> typ -> typ -> term -> term val expand_to_ctr_term: Proof.context -> typ -> term -> term val massage_corec_code_rhs: Proof.context -> (typ list -> term -> term list -> term) -> typ list -> term -> term val fold_rev_corec_code_rhs: Proof.context -> (term list -> term -> term list -> 'a -> 'a) -> typ list -> term -> 'a -> 'a val case_thms_of_term: Proof.context -> term -> thm list * thm list * thm list * thm list * thm list val map_thms_of_type: Proof.context -> typ -> thm list val corec_specs_of: binding list -> typ list -> typ list -> term list -> (term * term list list) list list -> local_theory -> corec_spec list * typ list * thm * thm * thm list * thm list * (Token.src list * Token.src list) * bool * local_theory val gfp_rec_sugar_interpretation: string -> (BNF_FP_Rec_Sugar_Util.fp_rec_sugar -> local_theory -> local_theory) -> theory -> theory val primcorec_ursive: bool -> bool -> corec_option list -> ((binding * typ) * mixfix) list -> ((binding * Token.T list list) * term) list -> term option list -> Proof.context -> (term * 'a list) list list * (thm list list -> local_theory -> local_theory) * local_theory val primcorec_ursive_cmd: bool -> bool -> corec_option list -> (binding * string option * mixfix) list * ((Attrib.binding * string) * string option) list -> Proof.context -> (term * 'a list) list list * (thm list list -> local_theory -> local_theory) * local_theory val primcorecursive_cmd: bool -> corec_option list -> (binding * string option * mixfix) list * ((Attrib.binding * string) * string option) list -> Proof.context -> Proof.state val primcorec_cmd: bool -> corec_option list -> (binding * string option * mixfix) list * ((Attrib.binding * string) * string option) list -> local_theory -> local_theory end; structure BNF_GFP_Rec_Sugar : BNF_GFP_REC_SUGAR = struct open Ctr_Sugar_General_Tactics open Ctr_Sugar open BNF_Util open BNF_Def open BNF_FP_Util open BNF_FP_Def_Sugar open BNF_FP_N2M_Sugar open BNF_FP_Rec_Sugar_Util open BNF_FP_Rec_Sugar_Transfer open BNF_GFP_Rec_Sugar_Tactics val codeN = "code"; val ctrN = "ctr"; val discN = "disc"; val disc_iffN = "disc_iff"; val excludeN = "exclude"; val selN = "sel"; val nitpicksimp_attrs = @{attributes [nitpick_simp]}; val simp_attrs = @{attributes [simp]}; fun use_primcorecursive () = error ("\"auto\" failed (try " ^ quote (#1 \<^command_keyword>\primcorecursive\) ^ " instead of " ^ quote (#1 \<^command_keyword>\primcorec\) ^ ")"); datatype corec_option = Plugins_Option of Proof.context -> Plugin_Name.filter | Sequential_Option | Exhaustive_Option | Transfer_Option; datatype corec_call = Dummy_No_Corec of int | No_Corec of int | Mutual_Corec of int * int * int | Nested_Corec of int; type basic_corec_ctr_spec = {ctr: term, disc: term, sels: term list}; type corec_ctr_spec = {ctr: term, disc: term, sels: term list, pred: int option, calls: corec_call list, discI: thm, sel_thms: thm list, distinct_discss: thm list list, collapse: thm, corec_thm: thm, corec_disc: thm, corec_sels: thm list}; type corec_spec = {T: typ, corec: term, exhaust_discs: thm list, sel_defs: thm list, fp_nesting_maps: thm list, fp_nesting_map_ident0s: thm list, fp_nesting_map_comps: thm list, ctr_specs: corec_ctr_spec list}; exception NO_MAP of term; fun abstract_over_list rev_vs = let val vs = rev rev_vs; fun abs n (t $ u) = abs n t $ abs n u | abs n (Abs (s, T, t)) = Abs (s, T, abs (n + 1) t) | abs n t = let val j = find_index (curry (op =) t) vs in if j < 0 then t else Bound (n + j) end; in abs 0 end; val abs_tuple_balanced = HOLogic.tupled_lambda o mk_tuple_balanced; fun curried_type (Type (\<^type_name>\fun\, [Type (\<^type_name>\prod\, Ts), T])) = Ts ---> T; fun sort_list_duplicates xs = map snd (sort (int_ord o apply2 fst) xs); val mk_conjs = try (foldr1 HOLogic.mk_conj) #> the_default \<^const>\True\; val mk_disjs = try (foldr1 HOLogic.mk_disj) #> the_default \<^const>\False\; val mk_dnf = mk_disjs o map mk_conjs; val conjuncts_s = filter_out (curry (op aconv) \<^const>\True\) o HOLogic.conjuncts; fun s_not \<^const>\True\ = \<^const>\False\ | s_not \<^const>\False\ = \<^const>\True\ | s_not (\<^const>\Not\ $ t) = t | s_not (\<^const>\conj\ $ t $ u) = \<^const>\disj\ $ s_not t $ s_not u | s_not (\<^const>\disj\ $ t $ u) = \<^const>\conj\ $ s_not t $ s_not u | s_not t = \<^const>\Not\ $ t; val s_not_conj = conjuncts_s o s_not o mk_conjs; fun propagate_unit_pos u cs = if member (op aconv) cs u then [\<^const>\False\] else cs; fun propagate_unit_neg not_u cs = remove (op aconv) not_u cs; fun propagate_units css = (case List.partition (can the_single) css of ([], _) => css | ([u] :: uss, css') => [u] :: propagate_units (map (propagate_unit_neg (s_not u)) (map (propagate_unit_pos u) (uss @ css')))); fun s_conjs cs = if member (op aconv) cs \<^const>\False\ then \<^const>\False\ else mk_conjs (remove (op aconv) \<^const>\True\ cs); fun s_disjs ds = if member (op aconv) ds \<^const>\True\ then \<^const>\True\ else mk_disjs (remove (op aconv) \<^const>\False\ ds); fun s_dnf css0 = let val css = propagate_units css0 in if null css then [\<^const>\False\] else if exists null css then [] else map (fn c :: cs => (c, cs)) css |> AList.coalesce (op =) |> map (fn (c, css) => c :: s_dnf css) |> (fn [cs] => cs | css => [s_disjs (map s_conjs css)]) end; fun fold_rev_let_if_case ctxt f bound_Ts = let val thy = Proof_Context.theory_of ctxt; fun fld conds t = (case Term.strip_comb t of (Const (\<^const_name>\Let\, _), [_, _]) => fld conds (unfold_lets_splits t) | (Const (\<^const_name>\If\, _), [cond, then_branch, else_branch]) => fld (conds @ conjuncts_s cond) then_branch o fld (conds @ s_not_conj [cond]) else_branch | (Const (c, _), args as _ :: _ :: _) => let val n = num_binder_types (Sign.the_const_type thy c) - 1 in if n >= 0 andalso n < length args then (case fastype_of1 (bound_Ts, nth args n) of Type (s, Ts) => (case dest_case ctxt s Ts t of SOME ({split_sels = _ :: _, ...}, conds', branches) => fold_rev (uncurry fld) (map (append conds o conjuncts_s) conds' ~~ branches) | _ => f conds t) | _ => f conds t) else f conds t end | _ => f conds t); in fld [] end; fun case_of ctxt s = (case ctr_sugar_of ctxt s of SOME {casex = Const (s', _), split_sels, ...} => SOME (s', not (null split_sels)) | _ => NONE); fun massage_let_if_case ctxt has_call massage_leaf unexpected_call unsupported_case bound_Ts t0 = let val thy = Proof_Context.theory_of ctxt; fun check_no_call bound_Ts t = if has_call t then unexpected_call bound_Ts t else (); fun massage_abs bound_Ts 0 t = massage_rec bound_Ts t | massage_abs bound_Ts m (Abs (s, T, t)) = Abs (s, T, massage_abs (T :: bound_Ts) (m - 1) t) | massage_abs bound_Ts m t = let val T = domain_type (fastype_of1 (bound_Ts, t)) in Abs (Name.uu, T, massage_abs (T :: bound_Ts) (m - 1) (incr_boundvars 1 t $ Bound 0)) end and massage_rec bound_Ts t = let val typof = curry fastype_of1 bound_Ts in (case Term.strip_comb t of (Const (\<^const_name>\Let\, _), [_, _]) => massage_rec bound_Ts (unfold_lets_splits t) | (Const (\<^const_name>\If\, _), obj :: (branches as [_, _])) => (case List.partition Term.is_dummy_pattern (map (massage_rec bound_Ts) branches) of (dummy_branch' :: _, []) => dummy_branch' | (_, [branch']) => branch' | (_, branches') => Term.list_comb (If_const (typof (hd branches')) $ tap (check_no_call bound_Ts) obj, branches')) | (c as Const (\<^const_name>\case_prod\, _), arg :: args) => massage_rec bound_Ts (unfold_splits_lets (Term.list_comb (c $ Envir.eta_long bound_Ts arg, args))) | (Const (c, _), args as _ :: _ :: _) => (case try strip_fun_type (Sign.the_const_type thy c) of SOME (gen_branch_Ts, gen_body_fun_T) => let val gen_branch_ms = map num_binder_types gen_branch_Ts; val n = length gen_branch_ms; in if n < length args then (case gen_body_fun_T of Type (_, [Type (T_name, _), _]) => (case case_of ctxt T_name of SOME (c', has_split_sels) => if c' = c then if has_split_sels then let val (branches, obj_leftovers) = chop n args; val branches' = map2 (massage_abs bound_Ts) gen_branch_ms branches; val branch_Ts' = map typof branches'; val body_T' = snd (strip_typeN (hd gen_branch_ms) (hd branch_Ts')); val casex' = Const (c, branch_Ts' ---> map typof obj_leftovers ---> body_T'); in Term.list_comb (casex', branches' @ tap (List.app (check_no_call bound_Ts)) obj_leftovers) end else unsupported_case bound_Ts t else massage_leaf bound_Ts t | NONE => massage_leaf bound_Ts t) | _ => massage_leaf bound_Ts t) else massage_leaf bound_Ts t end | NONE => massage_leaf bound_Ts t) | _ => massage_leaf bound_Ts t) end; in massage_rec bound_Ts t0 |> Term.map_aterms (fn t => if Term.is_dummy_pattern t then Const (\<^const_name>\undefined\, fastype_of t) else t) end; fun massage_let_if_case_corec ctxt has_call massage_leaf bound_Ts t0 = massage_let_if_case ctxt has_call massage_leaf (K (unexpected_corec_call_in ctxt [t0])) (K (unsupported_case_around_corec_call ctxt [t0])) bound_Ts t0; fun massage_nested_corec_call ctxt has_call massage_call massage_noncall bound_Ts U T t0 = let fun check_no_call t = if has_call t then unexpected_corec_call_in ctxt [t0] t else (); fun massage_mutual_call bound_Ts (Type (\<^type_name>\fun\, [_, U2])) (Type (\<^type_name>\fun\, [T1, T2])) t = Abs (Name.uu, T1, massage_mutual_call (T1 :: bound_Ts) U2 T2 (incr_boundvars 1 t $ Bound 0)) | massage_mutual_call bound_Ts U T t = (if has_call t then massage_call else massage_noncall) bound_Ts U T t; fun massage_map bound_Ts (Type (_, Us)) (Type (s, Ts)) t = (case try (dest_map ctxt s) t of SOME (map0, fs) => let val Type (_, dom_Ts) = domain_type (fastype_of1 (bound_Ts, t)); val map' = mk_map (length fs) dom_Ts Us map0; val fs' = map_flattened_map_args ctxt s (@{map 3} (massage_map_or_map_arg bound_Ts) Us Ts) fs; in Term.list_comb (map', fs') end | NONE => raise NO_MAP t) | massage_map _ _ _ t = raise NO_MAP t and massage_map_or_map_arg bound_Ts U T t = if T = U then tap check_no_call t else massage_map bound_Ts U T t handle NO_MAP _ => massage_mutual_fun bound_Ts U T t and massage_mutual_fun bound_Ts U T t = let val j = Term.maxidx_of_term t + 1; val var = Var ((Name.uu, j), domain_type (fastype_of1 (bound_Ts, t))); fun massage_body () = Term.lambda var (Term.incr_boundvars 1 (massage_any_call bound_Ts U T (betapply (t, var)))); in (case t of Const (\<^const_name>\comp\, _) $ t1 $ t2 => if has_call t2 then massage_body () else mk_comp bound_Ts (massage_mutual_fun bound_Ts U T t1, t2) | _ => massage_body ()) end and massage_any_call bound_Ts U T = massage_let_if_case_corec ctxt has_call (fn bound_Ts => fn t => if has_call t then (case U of Type (s, Us) => (case try (dest_ctr ctxt s) t of SOME (f, args) => let val typof = curry fastype_of1 bound_Ts; val f' = mk_ctr Us f val f'_T = typof f'; val arg_Ts = map typof args; in Term.list_comb (f', @{map 3} (massage_any_call bound_Ts) (binder_types f'_T) arg_Ts args) end | NONE => (case t of Const (\<^const_name>\case_prod\, _) $ t' => let val U' = curried_type U; val T' = curried_type T; in Const (\<^const_name>\case_prod\, U' --> U) $ massage_any_call bound_Ts U' T' t' end | t1 $ t2 => (if has_call t2 then massage_mutual_call bound_Ts U T t else massage_map bound_Ts U T t1 $ t2 handle NO_MAP _ => massage_mutual_call bound_Ts U T t) | Abs (s, T', t') => Abs (s, T', massage_any_call (T' :: bound_Ts) (range_type U) (range_type T) t') | _ => massage_mutual_call bound_Ts U T t)) | _ => ill_formed_corec_call ctxt t) else massage_noncall bound_Ts U T t) bound_Ts; in (if has_call t0 then massage_any_call else massage_noncall) bound_Ts U T t0 end; fun expand_to_ctr_term ctxt (T as Type (s, Ts)) t = (case ctr_sugar_of ctxt s of SOME {ctrs, casex, ...} => Term.list_comb (mk_case Ts T casex, map (mk_ctr Ts) ctrs) $ t | NONE => raise Fail "expand_to_ctr_term"); fun expand_corec_code_rhs ctxt has_call bound_Ts t = (case fastype_of1 (bound_Ts, t) of T as Type (s, _) => massage_let_if_case_corec ctxt has_call (fn _ => fn t => if can (dest_ctr ctxt s) t then t else expand_to_ctr_term ctxt T t) bound_Ts t | _ => raise Fail "expand_corec_code_rhs"); fun massage_corec_code_rhs ctxt massage_ctr = massage_let_if_case_corec ctxt (K false) (fn bound_Ts => uncurry (massage_ctr bound_Ts) o Term.strip_comb); fun fold_rev_corec_code_rhs ctxt f = fold_rev_let_if_case ctxt (fn conds => uncurry (f conds) o Term.strip_comb); fun case_thms_of_term ctxt t = let val ctr_sugars = map_filter (Ctr_Sugar.ctr_sugar_of_case ctxt o fst) (Term.add_consts t []) in (maps #distincts ctr_sugars, maps #discIs ctr_sugars, maps #exhaust_discs ctr_sugars, maps #split_sels ctr_sugars, maps #split_sel_asms ctr_sugars) end; fun basic_corec_specs_of ctxt res_T = (case res_T of Type (T_name, _) => (case Ctr_Sugar.ctr_sugar_of ctxt T_name of NONE => not_codatatype ctxt res_T | SOME {T = fpT, ctrs, discs, selss, ...} => let val thy = Proof_Context.theory_of ctxt; val As_rho = tvar_subst thy [fpT] [res_T]; val substA = Term.subst_TVars As_rho; fun mk_spec ctr disc sels = {ctr = substA ctr, disc = substA disc, sels = map substA sels}; in @{map 3} mk_spec ctrs discs selss handle ListPair.UnequalLengths => not_codatatype ctxt res_T end) | _ => not_codatatype ctxt res_T); fun map_thms_of_type ctxt (Type (s, _)) = (case fp_sugar_of ctxt s of SOME {fp_bnf_sugar = {map_thms, ...}, ...} => map_thms | NONE => []) | map_thms_of_type _ _ = []; structure GFP_Rec_Sugar_Plugin = Plugin(type T = fp_rec_sugar); fun gfp_rec_sugar_interpretation name f = GFP_Rec_Sugar_Plugin.interpretation name (fn fp_rec_sugar => fn lthy => f (transfer_fp_rec_sugar (Proof_Context.theory_of lthy) fp_rec_sugar) lthy); val interpret_gfp_rec_sugar = GFP_Rec_Sugar_Plugin.data; fun corec_specs_of bs arg_Ts res_Ts callers callssss0 lthy0 = let val thy = Proof_Context.theory_of lthy0; val ((missing_res_Ts, perm0_kks, fp_sugars as {fp_nesting_bnfs, fp_co_induct_sugar = SOME {common_co_inducts = common_coinduct_thms, ...}, ...} :: _, (_, gfp_sugar_thms)), lthy) = nested_to_mutual_fps (K true) Greatest_FP bs res_Ts callers callssss0 lthy0; val coinduct_attrs_pair = (case gfp_sugar_thms of SOME ((_, attrs_pair), _, _, _, _) => attrs_pair | NONE => ([], [])); val perm_fp_sugars = sort (int_ord o apply2 #fp_res_index) fp_sugars; val indices = map #fp_res_index fp_sugars; val perm_indices = map #fp_res_index perm_fp_sugars; val perm_fpTs = map #T perm_fp_sugars; val perm_ctrXs_Tsss' = map (repair_nullary_single_ctr o #ctrXs_Tss o #fp_ctr_sugar) perm_fp_sugars; val nn0 = length res_Ts; val nn = length perm_fpTs; val kks = 0 upto nn - 1; val perm_ns' = map length perm_ctrXs_Tsss'; val perm_Ts = map #T perm_fp_sugars; val perm_Xs = map #X perm_fp_sugars; val perm_Cs = map (domain_type o body_fun_type o fastype_of o #co_rec o the o #fp_co_induct_sugar) perm_fp_sugars; val Xs_TCs = perm_Xs ~~ (perm_Ts ~~ perm_Cs); fun zip_corecT (Type (s, Us)) = [Type (s, map (mk_sumTN o zip_corecT) Us)] | zip_corecT U = (case AList.lookup (op =) Xs_TCs U of SOME (T, C) => [T, C] | NONE => [U]); val perm_p_Tss = mk_corec_p_pred_types perm_Cs perm_ns'; val perm_f_Tssss = map2 (fn C => map (map (map (curry (op -->) C) o zip_corecT))) perm_Cs perm_ctrXs_Tsss'; val perm_q_Tssss = map (map (map (fn [_] => [] | [_, T] => [mk_pred1T (domain_type T)]))) perm_f_Tssss; val (perm_p_hss, h) = indexedd perm_p_Tss 0; val (perm_q_hssss, h') = indexedddd perm_q_Tssss h; val (perm_f_hssss, _) = indexedddd perm_f_Tssss h'; val fun_arg_hs = flat (@{map 3} flat_corec_preds_predsss_gettersss perm_p_hss perm_q_hssss perm_f_hssss); fun unpermute0 perm0_xs = permute_like_unique (op =) perm0_kks kks perm0_xs; fun unpermute perm_xs = permute_like_unique (op =) perm_indices indices perm_xs; val coinduct_thmss = map (unpermute0 o conj_dests nn) common_coinduct_thms; val p_iss = map (map (find_index_eq fun_arg_hs)) (unpermute perm_p_hss); val q_issss = map (map (map (map (find_index_eq fun_arg_hs)))) (unpermute perm_q_hssss); val f_issss = map (map (map (map (find_index_eq fun_arg_hs)))) (unpermute perm_f_hssss); val f_Tssss = unpermute perm_f_Tssss; val fpTs = unpermute perm_fpTs; val Cs = unpermute perm_Cs; val As_rho = tvar_subst thy (take nn0 fpTs) res_Ts; val Cs_rho = map (fst o dest_TVar) Cs ~~ pad_list HOLogic.unitT nn arg_Ts; val substA = Term.subst_TVars As_rho; val substAT = Term.typ_subst_TVars As_rho; val substCT = Term.typ_subst_TVars Cs_rho; val perm_Cs' = map substCT perm_Cs; fun call_of nullary [] [g_i] [Type (\<^type_name>\fun\, [_, T])] = (if exists_subtype_in Cs T then Nested_Corec else if nullary then Dummy_No_Corec else No_Corec) g_i | call_of _ [q_i] [g_i, g_i'] _ = Mutual_Corec (q_i, g_i, g_i'); fun mk_ctr_spec ctr disc sels p_io q_iss f_iss f_Tss discI sel_thms distinct_discss collapse corec_thm corec_disc corec_sels = let val nullary = not (can dest_funT (fastype_of ctr)) in {ctr = substA ctr, disc = substA disc, sels = map substA sels, pred = p_io, calls = @{map 3} (call_of nullary) q_iss f_iss f_Tss, discI = discI, sel_thms = sel_thms, distinct_discss = distinct_discss, collapse = collapse, corec_thm = corec_thm, corec_disc = corec_disc, corec_sels = corec_sels} end; fun mk_ctr_specs ({ctrs, discs, selss, discIs, sel_thmss, distinct_discsss, collapses, ...} : ctr_sugar) p_is q_isss f_isss f_Tsss corec_thms corec_discs corec_selss = let val p_ios = map SOME p_is @ [NONE] in @{map 14} mk_ctr_spec ctrs discs selss p_ios q_isss f_isss f_Tsss discIs sel_thmss distinct_discsss collapses corec_thms corec_discs corec_selss end; fun mk_spec ({T, fp_ctr_sugar = {ctr_sugar as {exhaust_discs, sel_defs, ...}, ...}, fp_co_induct_sugar = SOME {co_rec = corec, co_rec_thms = corec_thms, co_rec_discs = corec_discs, co_rec_selss = corec_selss, ...}, ...} : fp_sugar) p_is q_isss f_isss f_Tsss = {T = T, corec = mk_co_rec thy Greatest_FP perm_Cs' (substAT T) corec, exhaust_discs = exhaust_discs, sel_defs = sel_defs, fp_nesting_maps = maps (map_thms_of_type lthy o T_of_bnf) fp_nesting_bnfs, fp_nesting_map_ident0s = map map_ident0_of_bnf fp_nesting_bnfs, fp_nesting_map_comps = map map_comp_of_bnf fp_nesting_bnfs, ctr_specs = mk_ctr_specs ctr_sugar p_is q_isss f_isss f_Tsss corec_thms corec_discs corec_selss}; in (@{map 5} mk_spec fp_sugars p_iss q_issss f_issss f_Tssss, missing_res_Ts, co_induct_of common_coinduct_thms, strong_co_induct_of common_coinduct_thms, co_induct_of coinduct_thmss, strong_co_induct_of coinduct_thmss, coinduct_attrs_pair, is_some gfp_sugar_thms, lthy) end; val undef_const = Const (\<^const_name>\undefined\, dummyT); type coeqn_data_disc = {fun_name: string, fun_T: typ, fun_args: term list, ctr: term, ctr_no: int, disc: term, prems: term list, auto_gen: bool, ctr_rhs_opt: term option, code_rhs_opt: term option, eqn_pos: int, user_eqn: term}; type coeqn_data_sel = {fun_name: string, fun_T: typ, fun_args: term list, ctr: term, sel: term, rhs_term: term, ctr_rhs_opt: term option, code_rhs_opt: term option, eqn_pos: int, user_eqn: term}; fun ctr_sel_of ({ctr, sel, ...} : coeqn_data_sel) = (ctr, sel); datatype coeqn_data = Disc of coeqn_data_disc | Sel of coeqn_data_sel; fun is_free_in frees (Free (s, _)) = member (op =) frees s | is_free_in _ _ = false; fun is_catch_all_prem (Free (s, _)) = s = Name.uu_ | is_catch_all_prem _ = false; fun add_extra_frees ctxt frees names = fold_aterms (fn x as Free (s, _) => (not (member (op =) frees x) andalso not (member (op =) names s) andalso not (Variable.is_fixed ctxt s) andalso not (is_catch_all_prem x)) ? cons x | _ => I); fun check_extra_frees ctxt frees names t = let val bads = add_extra_frees ctxt frees names t [] in null bads orelse extra_variable_in_rhs ctxt [t] (hd bads) end; fun check_fun_args ctxt eqn fun_args = (check_duplicate_variables_in_lhs ctxt [eqn] fun_args; check_all_fun_arg_frees ctxt [eqn] fun_args); fun dissect_coeqn_disc ctxt fun_names sequentials (basic_ctr_specss : basic_corec_ctr_spec list list) eqn_pos ctr_rhs_opt code_rhs_opt prems0 concl matchedsss = let fun find_subterm p = let (* FIXME \? *) fun find (t as u $ v) = if p t then SOME t else merge_options (find u, find v) | find t = if p t then SOME t else NONE; in find end; val applied_fun = concl |> find_subterm (member (op = o apsnd SOME) fun_names o try (fst o dest_Free o head_of)) |> the handle Option.Option => error_at ctxt [concl] "Ill-formed discriminator formula"; val ((fun_name, fun_T), fun_args) = strip_comb applied_fun |>> dest_Free; val _ = check_fun_args ctxt concl fun_args; val bads = filter (Term.exists_subterm (is_free_in fun_names)) prems0; val _ = null bads orelse unexpected_rec_call_in ctxt [] (hd bads); val (sequential, basic_ctr_specs) = the (AList.lookup (op =) (fun_names ~~ (sequentials ~~ basic_ctr_specss)) fun_name); val discs = map #disc basic_ctr_specs; val ctrs = map #ctr basic_ctr_specs; val not_disc = head_of concl = \<^term>\Not\; val _ = not_disc andalso length ctrs <> 2 andalso error_at ctxt [concl] "Negated discriminator for a type with \ 2 constructors"; val disc' = find_subterm (member (op =) discs o head_of) concl; val eq_ctr0 = concl |> perhaps (try HOLogic.dest_not) |> try (HOLogic.dest_eq #> snd) |> (fn SOME t => let val n = find_index (curry (op =) t) ctrs in if n >= 0 then SOME n else NONE end | _ => NONE); val _ = is_none disc' orelse perhaps (try HOLogic.dest_not) concl = the disc' orelse error_at ctxt [concl] "Ill-formed discriminator formula"; val _ = is_some disc' orelse is_some eq_ctr0 orelse error_at ctxt [concl] "No discriminator in equation"; val ctr_no' = if is_none disc' then the eq_ctr0 else find_index (curry (op =) (head_of (the disc'))) discs; val ctr_no = if not_disc then 1 - ctr_no' else ctr_no'; val {ctr, disc, ...} = nth basic_ctr_specs ctr_no; val catch_all = (case prems0 of [prem] => is_catch_all_prem prem | _ => if exists is_catch_all_prem prems0 then error_at ctxt [concl] "Superfluous premises" else false); val matchedss = AList.lookup (op =) matchedsss fun_name |> the_default []; val prems = map (abstract_over_list fun_args) prems0; val actual_prems = (if catch_all orelse sequential then maps s_not_conj matchedss else []) @ (if catch_all then [] else prems); val matchedsss' = AList.delete (op =) fun_name matchedsss |> cons (fun_name, if sequential then matchedss @ [prems] else matchedss @ [actual_prems]); val user_eqn = (actual_prems, concl) |>> map HOLogic.mk_Trueprop ||> HOLogic.mk_Trueprop o abstract_over_list fun_args |> curry Logic.list_all (map dest_Free fun_args) o Logic.list_implies; val _ = check_extra_frees ctxt fun_args fun_names user_eqn; in (Disc {fun_name = fun_name, fun_T = fun_T, fun_args = fun_args, ctr = ctr, ctr_no = ctr_no, disc = disc, prems = actual_prems, auto_gen = catch_all, ctr_rhs_opt = ctr_rhs_opt, code_rhs_opt = code_rhs_opt, eqn_pos = eqn_pos, user_eqn = user_eqn}, matchedsss') end; fun dissect_coeqn_sel ctxt fun_names (basic_ctr_specss : basic_corec_ctr_spec list list) eqn_pos ctr_rhs_opt code_rhs_opt eqn0 of_spec_opt eqn = let val (lhs, rhs) = HOLogic.dest_eq eqn handle TERM _ => ill_formed_equation_lhs_rhs ctxt [eqn]; val sel = head_of lhs; val ((fun_name, fun_T), fun_args) = dest_comb lhs |> snd |> strip_comb |> apfst dest_Free handle TERM _ => error_at ctxt [eqn] "Ill-formed selector argument in left-hand side"; val _ = check_fun_args ctxt eqn fun_args; val basic_ctr_specs = the (AList.lookup (op =) (fun_names ~~ basic_ctr_specss) fun_name) handle Option.Option => error_at ctxt [eqn] "Ill-formed selector argument in left-hand side"; val {ctr, ...} = (case of_spec_opt of SOME of_spec => the (find_first (curry (op =) of_spec o #ctr) basic_ctr_specs) | NONE => filter (exists (curry (op =) sel) o #sels) basic_ctr_specs |> the_single handle List.Empty => error_at ctxt [eqn] "Ambiguous selector (without \"of\")"); val user_eqn = drop_all eqn0; val _ = check_extra_frees ctxt fun_args fun_names user_eqn; in Sel {fun_name = fun_name, fun_T = fun_T, fun_args = fun_args, ctr = ctr, sel = sel, rhs_term = rhs, ctr_rhs_opt = ctr_rhs_opt, code_rhs_opt = code_rhs_opt, eqn_pos = eqn_pos, user_eqn = user_eqn} end; fun dissect_coeqn_ctr ctxt fun_names sequentials (basic_ctr_specss : basic_corec_ctr_spec list list) eqn_pos eqn0 code_rhs_opt prems concl matchedsss = let val (lhs, rhs) = HOLogic.dest_eq concl; val (fun_name, fun_args) = strip_comb lhs |>> fst o dest_Free; val _ = check_fun_args ctxt concl fun_args; val _ = check_extra_frees ctxt fun_args fun_names (drop_all eqn0); val basic_ctr_specs = the (AList.lookup (op =) (fun_names ~~ basic_ctr_specss) fun_name); val (ctr, ctr_args) = strip_comb (unfold_lets_splits rhs); val {disc, sels, ...} = the (find_first (curry (op =) ctr o #ctr) basic_ctr_specs) handle Option.Option => not_constructor_in_rhs ctxt [] ctr; val disc_concl = betapply (disc, lhs); val (eqn_data_disc_opt, matchedsss') = if null (tl basic_ctr_specs) andalso not (null sels) then (NONE, matchedsss) else apfst SOME (dissect_coeqn_disc ctxt fun_names sequentials basic_ctr_specss eqn_pos (SOME (abstract_over_list fun_args rhs)) code_rhs_opt prems disc_concl matchedsss); val sel_concls = sels ~~ ctr_args |> map (fn (sel, ctr_arg) => HOLogic.mk_eq (betapply (sel, lhs), ctr_arg)) handle ListPair.UnequalLengths => partially_applied_ctr_in_rhs ctxt [rhs]; val eqns_data_sel = map (dissect_coeqn_sel ctxt fun_names basic_ctr_specss eqn_pos (SOME (abstract_over_list fun_args rhs)) code_rhs_opt eqn0 (SOME ctr)) sel_concls; in (the_list eqn_data_disc_opt @ eqns_data_sel, matchedsss') end; fun dissect_coeqn_code ctxt has_call fun_names basic_ctr_specss eqn_pos eqn0 concl matchedsss = let val (lhs, (rhs', rhs)) = HOLogic.dest_eq concl ||> `(expand_corec_code_rhs ctxt has_call []); val (fun_name, fun_args) = strip_comb lhs |>> fst o dest_Free; val _ = check_fun_args ctxt concl fun_args; val _ = check_extra_frees ctxt fun_args fun_names concl; val basic_ctr_specs = the (AList.lookup (op =) (fun_names ~~ basic_ctr_specss) fun_name); val cond_ctrs = fold_rev_corec_code_rhs ctxt (fn cs => fn ctr => fn _ => if member (op = o apsnd #ctr) basic_ctr_specs ctr then cons (ctr, cs) else not_constructor_in_rhs ctxt [] ctr) [] rhs' [] |> AList.group (op =); val ctr_premss = (case cond_ctrs of [_] => [[]] | _ => map (s_dnf o snd) cond_ctrs); val ctr_concls = cond_ctrs |> map (fn (ctr, _) => binder_types (fastype_of ctr) |> map_index (fn (n, T) => massage_corec_code_rhs ctxt (fn _ => fn ctr' => fn args => if ctr' = ctr then nth args n else Term.dummy_pattern T) [] rhs') |> curry Term.list_comb ctr |> curry HOLogic.mk_eq lhs); val bads = maps (filter (Term.exists_subterm (is_free_in fun_names))) ctr_premss; val _ = null bads orelse unexpected_corec_call_in ctxt [eqn0] rhs; val sequentials = replicate (length fun_names) false; in @{fold_map 2} (dissect_coeqn_ctr ctxt fun_names sequentials basic_ctr_specss eqn_pos eqn0 (SOME (abstract_over_list fun_args rhs))) ctr_premss ctr_concls matchedsss end; fun dissect_coeqn ctxt has_call fun_names sequentials (basic_ctr_specss : basic_corec_ctr_spec list list) (eqn_pos, eqn0) of_spec_opt matchedsss = let val eqn = drop_all eqn0 handle TERM _ => ill_formed_formula ctxt eqn0; val (prems, concl) = Logic.strip_horn eqn |> map_prod (map HOLogic.dest_Trueprop) HOLogic.dest_Trueprop handle TERM _ => ill_formed_equation ctxt eqn; val head = concl |> perhaps (try HOLogic.dest_not) |> perhaps (try (fst o HOLogic.dest_eq)) |> head_of; val rhs_opt = concl |> perhaps (try HOLogic.dest_not) |> try (HOLogic.dest_eq #> snd); fun check_num_args () = is_none rhs_opt orelse not (can dest_funT (fastype_of (the rhs_opt))) orelse missing_args_to_fun_on_lhs ctxt [eqn]; val discs = maps (map #disc) basic_ctr_specss; val sels = maps (maps #sels) basic_ctr_specss; val ctrs = maps (map #ctr) basic_ctr_specss; in if member (op =) discs head orelse (is_some rhs_opt andalso member (op =) (map SOME fun_names) (try (fst o dest_Free) head) andalso member (op =) (filter (null o binder_types o fastype_of) ctrs) (the rhs_opt)) then (dissect_coeqn_disc ctxt fun_names sequentials basic_ctr_specss eqn_pos NONE NONE prems concl matchedsss |>> single) else if member (op =) sels head then (null prems orelse error_at ctxt [eqn] "Unexpected condition in selector formula"; ([dissect_coeqn_sel ctxt fun_names basic_ctr_specss eqn_pos NONE NONE eqn0 of_spec_opt concl], matchedsss)) else if is_some rhs_opt andalso is_Free head andalso is_free_in fun_names head then if member (op =) ctrs (head_of (unfold_lets_splits (the rhs_opt))) then (check_num_args (); dissect_coeqn_ctr ctxt fun_names sequentials basic_ctr_specss eqn_pos eqn0 (if null prems then SOME (snd (HOLogic.dest_eq (HOLogic.dest_Trueprop (Logic.strip_assums_concl eqn0)))) else NONE) prems concl matchedsss) else if null prems then (check_num_args (); dissect_coeqn_code ctxt has_call fun_names basic_ctr_specss eqn_pos eqn0 concl matchedsss |>> flat) else error_at ctxt [eqn] "Cannot mix constructor and code views" else if is_some rhs_opt then error_at ctxt [eqn] ("Ill-formed equation head: " ^ quote (Syntax.string_of_term ctxt head)) else error_at ctxt [eqn] "Expected equation or discriminator formula" end; fun build_corec_arg_disc (ctr_specs : corec_ctr_spec list) ({fun_args, ctr_no, prems, ...} : coeqn_data_disc) = if is_none (#pred (nth ctr_specs ctr_no)) then I else s_conjs prems |> curry subst_bounds (List.rev fun_args) |> abs_tuple_balanced fun_args |> K |> nth_map (the (#pred (nth ctr_specs ctr_no))); fun build_corec_arg_no_call (sel_eqns : coeqn_data_sel list) sel = find_first (curry (op =) sel o #sel) sel_eqns |> try (fn SOME {fun_args, rhs_term, ...} => abs_tuple_balanced fun_args rhs_term) |> the_default undef_const |> K; fun build_corec_args_mutual_call ctxt has_call (sel_eqns : coeqn_data_sel list) sel = (case find_first (curry (op =) sel o #sel) sel_eqns of NONE => (I, I, I) | SOME {fun_args, rhs_term, ... } => let val bound_Ts = List.rev (map fastype_of fun_args); fun rewrite_stop _ t = if has_call t then \<^term>\False\ else \<^term>\True\; fun rewrite_end _ t = if has_call t then undef_const else t; fun rewrite_cont bound_Ts t = if has_call t then mk_tuple1_balanced bound_Ts (snd (strip_comb t)) else undef_const; fun massage f _ = massage_let_if_case_corec ctxt has_call f bound_Ts rhs_term |> abs_tuple_balanced fun_args; in (massage rewrite_stop, massage rewrite_end, massage rewrite_cont) end); fun build_corec_arg_nested_call ctxt has_call (sel_eqns : coeqn_data_sel list) sel = (case find_first (curry (op =) sel o #sel) sel_eqns of NONE => I | SOME {fun_args, rhs_term, ...} => let fun massage_call bound_Ts U T t0 = let val U2 = (case try dest_sumT U of SOME (U1, U2) => if U1 = T then U2 else invalid_map ctxt [] t0 | NONE => invalid_map ctxt [] t0); fun rewrite bound_Ts (Abs (s, T', t')) = Abs (s, T', rewrite (T' :: bound_Ts) t') | rewrite bound_Ts (t as _ $ _) = let val (u, vs) = strip_comb t in if is_Free u andalso has_call u then Inr_const T U2 $ mk_tuple1_balanced bound_Ts vs else if try (fst o dest_Const) u = SOME \<^const_name>\case_prod\ then map (rewrite bound_Ts) vs |> chop 1 |>> HOLogic.mk_case_prod o the_single |> Term.list_comb else Term.list_comb (rewrite bound_Ts u, map (rewrite bound_Ts) vs) end | rewrite _ t = if is_Free t andalso has_call t then Inr_const T U2 $ HOLogic.unit else t; in rewrite bound_Ts t0 end; fun massage_noncall U T t = build_map ctxt [] [] (uncurry Inl_const o dest_sumT o snd) (T, U) $ t; val bound_Ts = List.rev (map fastype_of fun_args); in fn t => rhs_term |> massage_nested_corec_call ctxt has_call massage_call (K massage_noncall) bound_Ts (range_type (fastype_of t)) (fastype_of1 (bound_Ts, rhs_term)) |> abs_tuple_balanced fun_args end); fun build_corec_args_sel ctxt has_call (all_sel_eqns : coeqn_data_sel list) (ctr_spec : corec_ctr_spec) = (case filter (curry (op =) (#ctr ctr_spec) o #ctr) all_sel_eqns of [] => I | sel_eqns => let val sel_call_list = #sels ctr_spec ~~ #calls ctr_spec; val no_calls' = map_filter (try (apsnd (fn No_Corec n => n))) sel_call_list; val mutual_calls' = map_filter (try (apsnd (fn Mutual_Corec n => n))) sel_call_list; val nested_calls' = map_filter (try (apsnd (fn Nested_Corec n => n))) sel_call_list; in I #> fold (fn (sel, n) => nth_map n (build_corec_arg_no_call sel_eqns sel)) no_calls' #> fold (fn (sel, (q, g, h)) => let val (fq, fg, fh) = build_corec_args_mutual_call ctxt has_call sel_eqns sel in nth_map q fq o nth_map g fg o nth_map h fh end) mutual_calls' #> fold (fn (sel, n) => nth_map n (build_corec_arg_nested_call ctxt has_call sel_eqns sel)) nested_calls' end); fun build_defs ctxt bs mxs has_call arg_Tss (corec_specs : corec_spec list) (disc_eqnss : coeqn_data_disc list list) (sel_eqnss : coeqn_data_sel list list) = let val corecs = map #corec corec_specs; val ctr_specss = map #ctr_specs corec_specs; val corec_args = hd corecs |> fst o split_last o binder_types o fastype_of |> map (fn T => if range_type T = HOLogic.boolT then Abs (Name.uu_, domain_type T, \<^term>\False\) else Const (\<^const_name>\undefined\, T)) |> fold2 (fold o build_corec_arg_disc) ctr_specss disc_eqnss |> fold2 (fold o build_corec_args_sel ctxt has_call) sel_eqnss ctr_specss; val bad = fold (add_extra_frees ctxt [] []) corec_args []; val _ = null bad orelse (if exists has_call corec_args then nonprimitive_corec ctxt [] else extra_variable_in_rhs ctxt [] (hd bad)); val excludess' = disc_eqnss |> map (map (fn x => (#fun_args x, #ctr_no x, #prems x, #auto_gen x)) #> fst o (fn xs => fold_map (fn x => fn ys => ((x, ys), ys @ [x])) xs []) #> maps (uncurry (map o pair) #> map (fn ((fun_args, c, x, a), (_, c', y, a')) => ((c, c', a orelse a'), (x, s_not (s_conjs y))) ||> map_prod (map HOLogic.mk_Trueprop) HOLogic.mk_Trueprop ||> Logic.list_implies ||> curry Logic.list_all (map dest_Free fun_args)))); in map (Term.list_comb o rpair corec_args) corecs |> map2 abs_curried_balanced arg_Tss |> (fn ts => Syntax.check_terms ctxt ts handle ERROR _ => nonprimitive_corec ctxt []) |> @{map 3} (fn b => fn mx => fn t => ((b, mx), ((Binding.concealed (Thm.def_binding b), []), t))) bs mxs |> rpair excludess' end; fun mk_actual_disc_eqns fun_binding arg_Ts exhaustive ({ctr_specs, ...} : corec_spec) (sel_eqns : coeqn_data_sel list) (disc_eqns : coeqn_data_disc list) = let val fun_name = Binding.name_of fun_binding; val num_disc_eqns = length disc_eqns; val num_ctrs = length ctr_specs; in if (exhaustive andalso num_disc_eqns <> 0) orelse num_disc_eqns <> num_ctrs - 1 then (num_disc_eqns > 0 orelse error ("Missing discriminator formula for " ^ quote fun_name); disc_eqns) else let val ctr_no = 0 upto length ctr_specs |> the o find_first (fn j => not (exists (curry (op =) j o #ctr_no) disc_eqns)); val {ctr, disc, ...} = nth ctr_specs ctr_no; val sel_eqn_opt = find_first (equal ctr o #ctr) sel_eqns; val fun_T = arg_Ts ---> body_type (fastype_of (#ctr (hd ctr_specs))); val fun_args = (try (#fun_args o hd) disc_eqns, try (#fun_args o hd) sel_eqns) |> the_default (map (curry Free Name.uu) arg_Ts) o merge_options; val prems = maps (s_not_conj o #prems) disc_eqns; val ctr_rhs_opt = Option.map #ctr_rhs_opt sel_eqn_opt |> the_default NONE; val code_rhs_opt = Option.map #code_rhs_opt sel_eqn_opt |> the_default NONE; val eqn_pos = Option.map (curry (op +) 1 o #eqn_pos) sel_eqn_opt |> the_default 100000; (* FIXME *) val extra_disc_eqn = {fun_name = fun_name, fun_T = fun_T, fun_args = fun_args, ctr = ctr, ctr_no = ctr_no, disc = disc, prems = prems, auto_gen = true, ctr_rhs_opt = ctr_rhs_opt, code_rhs_opt = code_rhs_opt, eqn_pos = eqn_pos, user_eqn = undef_const}; in chop ctr_no disc_eqns ||> cons extra_disc_eqn |> op @ end end; fun find_corec_calls ctxt has_call (basic_ctr_specs : basic_corec_ctr_spec list) ({ctr, sel, rhs_term, ...} : coeqn_data_sel) = let val sel_no = find_first (curry (op =) ctr o #ctr) basic_ctr_specs |> find_index (curry (op =) sel) o #sels o the; in K (if has_call rhs_term then fold_rev_let_if_case ctxt (K cons) [] rhs_term [] else []) |> nth_map sel_no |> AList.map_entry (op =) ctr end; fun applied_fun_of fun_name fun_T fun_args = Term.list_comb (Free (fun_name, fun_T), map Bound (length fun_args - 1 downto 0)); fun is_trivial_implies thm = uncurry (member (op aconv)) (Logic.strip_horn (Thm.prop_of thm)); fun primcorec_ursive int auto opts fixes specs of_specs_opt lthy = let val (bs, mxs) = map_split (apfst fst) fixes; val (arg_Ts, res_Ts) = map (strip_type o snd o fst #>> mk_tupleT_balanced) fixes |> split_list; val primcorec_types = map (#1 o dest_Type) res_Ts; val _ = check_duplicate_const_names bs; val _ = List.app (uncurry (check_top_sort lthy)) (bs ~~ arg_Ts); val actual_nn = length bs; val plugins = get_first (fn Plugins_Option f => SOME (f lthy) | _ => NONE) (rev opts) |> the_default Plugin_Name.default_filter; val sequentials = replicate actual_nn (exists (can (fn Sequential_Option => ())) opts); val exhaustives = replicate actual_nn (exists (can (fn Exhaustive_Option => ())) opts); val transfers = replicate actual_nn (exists (can (fn Transfer_Option => ())) opts); val fun_names = map Binding.name_of bs; val qualifys = map (fold_rev (uncurry Binding.qualify o swap) o Binding.path_of) bs; val basic_ctr_specss = map (basic_corec_specs_of lthy) res_Ts; val frees = map (fst #>> Binding.name_of #> Free) fixes; val has_call = Term.exists_subterm (member (op =) frees); val eqns_data = @{fold_map 2} (dissect_coeqn lthy has_call fun_names sequentials basic_ctr_specss) (tag_list 0 (map snd specs)) of_specs_opt [] |> flat o fst; val missing = fun_names |> filter (map (fn Disc x => #fun_name x | Sel x => #fun_name x) eqns_data |> not oo member (op =)); val _ = null missing orelse missing_equations_for_const (hd missing); val callssss = map_filter (try (fn Sel x => x)) eqns_data |> partition_eq (op = o apply2 #fun_name) |> fst o finds (fn (x, ({fun_name, ...} :: _)) => x = fun_name) fun_names |> map (flat o snd) |> map2 (fold o find_corec_calls lthy has_call) basic_ctr_specss |> map2 (curry (op |>)) (map (map (fn {ctr, sels, ...} => (ctr, map (K []) sels))) basic_ctr_specss); val (corec_specs0, _, coinduct_thm, coinduct_strong_thm, coinduct_thms, coinduct_strong_thms, (coinduct_attrs, common_coinduct_attrs), n2m, lthy) = corec_specs_of bs arg_Ts res_Ts frees callssss lthy; val corec_specs = take actual_nn corec_specs0; val ctr_specss = map #ctr_specs corec_specs; val disc_eqnss0 = map_filter (try (fn Disc x => x)) eqns_data |> partition_eq (op = o apply2 #fun_name) |> fst o finds (fn (x, ({fun_name, ...} :: _)) => x = fun_name) fun_names |> map (sort (op < o apply2 #ctr_no |> make_ord) o flat o snd); val _ = disc_eqnss0 |> map (fn x => let val dups = duplicates (op = o apply2 #ctr_no) x in null dups orelse error_at lthy (maps (fn t => filter (curry (op =) (#ctr_no t) o #ctr_no) x) dups |> map (fn {ctr_rhs_opt = SOME t, ...} => t | {user_eqn, ...} => user_eqn)) "Overspecified case(s)" end); val sel_eqnss = map_filter (try (fn Sel x => x)) eqns_data |> partition_eq (op = o apply2 #fun_name) |> fst o finds (fn (x, ({fun_name, ...} :: _)) => x = fun_name) fun_names |> map (flat o snd); val _ = sel_eqnss |> map (fn x => let val dups = duplicates (op = o apply2 ctr_sel_of) x in null dups orelse error_at lthy (maps (fn t => filter (curry (op =) (ctr_sel_of t) o ctr_sel_of) x) dups |> map (fn {ctr_rhs_opt = SOME t, ...} => t | {user_eqn, ...} => user_eqn)) "Overspecified case(s)" end); val arg_Tss = map (binder_types o snd o fst) fixes; val disc_eqnss = @{map 6} mk_actual_disc_eqns bs arg_Tss exhaustives corec_specs sel_eqnss disc_eqnss0; val (defs, excludess') = build_defs lthy bs mxs has_call arg_Tss corec_specs disc_eqnss sel_eqnss; val tac_opts = map (fn {code_rhs_opt, ...} :: _ => if auto orelse is_some code_rhs_opt then SOME (auto_tac o #context) else NONE) disc_eqnss; fun exclude_tac tac_opt sequential (c, c', a) = if a orelse c = c' orelse sequential then SOME (fn {context = ctxt, prems = _} => HEADGOAL (mk_primcorec_assumption_tac ctxt [])) else tac_opt; val excludess'' = @{map 3} (fn tac_opt => fn sequential => map (fn (j, goal) => (j, (Option.map (Goal.prove (*no sorry*) lthy [] [] goal #> Thm.close_derivation \<^here>) (exclude_tac tac_opt sequential j), goal)))) tac_opts sequentials excludess' handle ERROR _ => use_primcorecursive (); val taut_thmss = map (map (apsnd (the o fst)) o filter (is_some o fst o snd)) excludess''; val (goal_idxss, exclude_goalss) = excludess'' |> map (map (apsnd (rpair [] o snd)) o filter (is_none o fst o snd)) |> split_list o map split_list; fun list_all_fun_args extras = map2 (fn [] => I | {fun_args, ...} :: _ => map (curry Logic.list_all (extras @ map dest_Free fun_args))) disc_eqnss; val syntactic_exhaustives = map (fn disc_eqns => forall (null o #prems orf is_some o #code_rhs_opt) disc_eqns orelse exists #auto_gen disc_eqns) disc_eqnss; val de_facto_exhaustives = map2 (fn b => fn b' => b orelse b') exhaustives syntactic_exhaustives; val nchotomy_goalss = map2 (fn false => K [] | true => single o HOLogic.mk_Trueprop o mk_dnf o map #prems) de_facto_exhaustives disc_eqnss |> list_all_fun_args [] val nchotomy_taut_thmss = @{map 5} (fn tac_opt => fn {exhaust_discs = res_exhaust_discs, ...} => fn {code_rhs_opt, ...} :: _ => fn [] => K [] | [goal] => fn true => let val (_, _, arg_exhaust_discs, _, _) = case_thms_of_term lthy (the_default Term.dummy code_rhs_opt); in [Goal.prove (*no sorry*) lthy [] [] goal (fn {context = ctxt, ...} => mk_primcorec_nchotomy_tac ctxt (res_exhaust_discs @ arg_exhaust_discs)) |> Thm.close_derivation \<^here>] handle ERROR _ => use_primcorecursive () end | false => (case tac_opt of SOME tac => [Goal.prove_sorry lthy [] [] goal tac |> Thm.close_derivation \<^here>] | NONE => [])) tac_opts corec_specs disc_eqnss nchotomy_goalss syntactic_exhaustives; val syntactic_exhaustives = map (fn disc_eqns => forall (null o #prems orf is_some o #code_rhs_opt) disc_eqns orelse exists #auto_gen disc_eqns) disc_eqnss; val nchotomy_goalss = map2 (fn (NONE, false) => map (rpair []) | _ => K []) (tac_opts ~~ syntactic_exhaustives) nchotomy_goalss; val goalss = nchotomy_goalss @ exclude_goalss; fun prove thmss'' def_infos lthy = let val def_thms = map (snd o snd) def_infos; val ts = map fst def_infos; val (nchotomy_thmss, exclude_thmss) = (map2 append (take actual_nn thmss'') nchotomy_taut_thmss, drop actual_nn thmss''); val ps = Variable.variant_frees lthy (maps (maps #fun_args) disc_eqnss) [("P", HOLogic.boolT)]; val exhaust_thmss = map2 (fn false => K [] | true => fn disc_eqns as {fun_args, ...} :: _ => let val p = Bound (length fun_args); fun mk_imp_p Qs = Logic.list_implies (Qs, HOLogic.mk_Trueprop p); in [mk_imp_p (map (mk_imp_p o map HOLogic.mk_Trueprop o #prems) disc_eqns)] end) de_facto_exhaustives disc_eqnss |> list_all_fun_args ps |> @{map 3} (fn disc_eqns as {fun_args, ...} :: _ => fn [] => K [] | [nchotomy_thm] => fn [goal] => [Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, prems = _} => mk_primcorec_exhaust_tac ctxt ("" (* for "P" *) :: map (fst o dest_Free) fun_args) (length disc_eqns) nchotomy_thm) |> Thm.close_derivation \<^here>]) disc_eqnss nchotomy_thmss; val nontriv_exhaust_thmss = map (filter_out is_trivial_implies) exhaust_thmss; val excludess' = map (op ~~) (goal_idxss ~~ exclude_thmss); fun mk_excludesss excludes n = fold (fn ((c, c', _), thm) => nth_map c (nth_map c' (K [thm]))) excludes (map (fn k => replicate k [asm_rl] @ replicate (n - k) []) (0 upto n - 1)); val excludessss = map2 (fn excludes => mk_excludesss excludes o length o #ctr_specs) (map2 append excludess' taut_thmss) corec_specs; fun prove_disc ({ctr_specs, ...} : corec_spec) excludesss ({fun_name, fun_T, fun_args, ctr_no, prems, eqn_pos, ...} : coeqn_data_disc) = if Term.aconv_untyped (#disc (nth ctr_specs ctr_no), \<^term>\\x. x = x\) then [] else let val {disc, corec_disc, ...} = nth ctr_specs ctr_no; val k = 1 + ctr_no; val m = length prems; val goal = applied_fun_of fun_name fun_T fun_args |> curry betapply disc |> HOLogic.mk_Trueprop |> curry Logic.list_implies (map HOLogic.mk_Trueprop prems) |> curry Logic.list_all (map dest_Free fun_args); in if prems = [\<^term>\False\] then [] else Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, prems = _} => mk_primcorec_disc_tac ctxt def_thms corec_disc k m excludesss) |> Thm.close_derivation \<^here> |> pair (#disc (nth ctr_specs ctr_no)) |> pair eqn_pos |> single end; fun prove_sel ({sel_defs, fp_nesting_maps, fp_nesting_map_ident0s, fp_nesting_map_comps, ctr_specs, ...} : corec_spec) (disc_eqns : coeqn_data_disc list) excludesss ({fun_name, fun_T, fun_args, ctr, sel, rhs_term, code_rhs_opt, eqn_pos, ...} : coeqn_data_sel) = let val ctr_spec = the (find_first (curry (op =) ctr o #ctr) ctr_specs); val ctr_no = find_index (curry (op =) ctr o #ctr) ctr_specs; val prems = the_default (maps (s_not_conj o #prems) disc_eqns) (find_first (curry (op =) ctr_no o #ctr_no) disc_eqns |> Option.map #prems); val corec_sel = find_index (curry (op =) sel) (#sels ctr_spec) |> nth (#corec_sels ctr_spec); val k = 1 + ctr_no; val m = length prems; val goal = applied_fun_of fun_name fun_T fun_args |> curry betapply sel |> rpair (abstract_over_list fun_args rhs_term) |> HOLogic.mk_Trueprop o HOLogic.mk_eq |> curry Logic.list_implies (map HOLogic.mk_Trueprop prems) |> curry Logic.list_all (map dest_Free fun_args); val (distincts, _, _, split_sels, split_sel_asms) = case_thms_of_term lthy rhs_term; in Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, prems = _} => mk_primcorec_sel_tac ctxt def_thms distincts split_sels split_sel_asms fp_nesting_maps fp_nesting_map_ident0s fp_nesting_map_comps corec_sel k m excludesss) |> Thm.close_derivation \<^here> |> `(is_some code_rhs_opt ? Local_Defs.fold lthy sel_defs) (*mildly too aggressive*) |> pair sel |> pair eqn_pos end; fun prove_ctr disc_alist sel_alist ({sel_defs, ...} : corec_spec) (disc_eqns : coeqn_data_disc list) (sel_eqns : coeqn_data_sel list) ({ctr, disc, sels, collapse, ...} : corec_ctr_spec) = (* don't try to prove theorems when some sel_eqns are missing *) if not (exists (curry (op =) ctr o #ctr) disc_eqns) andalso not (exists (curry (op =) ctr o #ctr) sel_eqns) orelse filter (curry (op =) ctr o #ctr) sel_eqns |> fst o finds (op = o apsnd #sel) sels |> exists (null o snd) then [] else let val (fun_name, fun_T, fun_args, prems, ctr_rhs_opt, code_rhs_opt, eqn_pos) = (find_first (curry (op =) ctr o #ctr) disc_eqns, find_first (curry (op =) ctr o #ctr) sel_eqns) |>> Option.map (fn x => (#fun_name x, #fun_T x, #fun_args x, #prems x, #ctr_rhs_opt x, #code_rhs_opt x, #eqn_pos x)) ||> Option.map (fn x => (#fun_name x, #fun_T x, #fun_args x, [], #ctr_rhs_opt x, #code_rhs_opt x, #eqn_pos x)) |> the o merge_options; val m = length prems; val goal = (case ctr_rhs_opt of SOME rhs => rhs | NONE => filter (curry (op =) ctr o #ctr) sel_eqns |> fst o finds (op = o apsnd #sel) sels |> map (snd #> (fn [x] => (#fun_args x, #rhs_term x)) #-> abstract_over_list) |> curry Term.list_comb ctr) |> curry mk_Trueprop_eq (applied_fun_of fun_name fun_T fun_args) |> curry Logic.list_implies (map HOLogic.mk_Trueprop prems) |> curry Logic.list_all (map dest_Free fun_args); val disc_thm_opt = AList.lookup (op =) disc_alist disc; val sel_thms = map (snd o snd) (filter (member (op =) sels o fst) sel_alist); in if prems = [\<^term>\False\] then [] else Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, prems = _} => mk_primcorec_ctr_tac ctxt m collapse disc_thm_opt sel_thms) |> is_some code_rhs_opt ? Local_Defs.fold lthy sel_defs (*mildly too aggressive*) |> Thm.close_derivation \<^here> |> pair ctr |> pair eqn_pos |> single end; fun prove_code exhaustive (disc_eqns : coeqn_data_disc list) (sel_eqns : coeqn_data_sel list) nchotomys ctr_alist ctr_specs = let val fun_data_opt = (find_first (member (op =) (map #ctr ctr_specs) o #ctr) disc_eqns, find_first (member (op =) (map #ctr ctr_specs) o #ctr) sel_eqns) |>> Option.map (fn x => (#fun_name x, #fun_T x, #fun_args x, #code_rhs_opt x)) ||> Option.map (fn x => (#fun_name x, #fun_T x, #fun_args x, #code_rhs_opt x)) |> merge_options; in (case fun_data_opt of NONE => [] | SOME (fun_name, fun_T, fun_args, rhs_opt) => let val bound_Ts = List.rev (map fastype_of fun_args); val lhs = applied_fun_of fun_name fun_T fun_args; val rhs_info_opt = (case rhs_opt of SOME rhs => let val raw_rhs = expand_corec_code_rhs lthy has_call bound_Ts rhs; val cond_ctrs = fold_rev_corec_code_rhs lthy (K oo (cons oo pair)) bound_Ts raw_rhs []; val ctr_thms = map (the_default FalseE o AList.lookup (op =) ctr_alist o snd) cond_ctrs; in SOME (false, rhs, raw_rhs, ctr_thms) end | NONE => let fun prove_code_ctr ({ctr, sels, ...} : corec_ctr_spec) = if not (exists (curry (op =) ctr o fst) ctr_alist) then NONE else let val prems = find_first (curry (op =) ctr o #ctr) disc_eqns |> Option.map #prems |> the_default []; val t = filter (curry (op =) ctr o #ctr) sel_eqns |> fst o finds (op = o apsnd #sel) sels |> map (snd #> (fn [x] => (#fun_args x, #rhs_term x)) #-> abstract_over_list) |> curry Term.list_comb ctr; in SOME (prems, t) end; val ctr_conds_argss_opt = map prove_code_ctr ctr_specs; val exhaustive_code = exhaustive orelse exists (is_some andf (null o fst o the)) ctr_conds_argss_opt orelse forall is_some ctr_conds_argss_opt andalso exists #auto_gen disc_eqns; val rhs = (if exhaustive_code then split_last (map_filter I ctr_conds_argss_opt) ||> snd else Const (\<^const_name>\Code.abort\, \<^typ>\String.literal\ --> (HOLogic.unitT --> body_type fun_T) --> body_type fun_T) $ HOLogic.mk_literal fun_name $ absdummy HOLogic.unitT (incr_boundvars 1 lhs) |> pair (map_filter I ctr_conds_argss_opt)) |-> fold_rev (fn (prems, u) => mk_If (s_conjs prems) u) in SOME (exhaustive_code, rhs, rhs, map snd ctr_alist) end); in (case rhs_info_opt of NONE => [] | SOME (exhaustive_code, rhs, raw_rhs, ctr_thms) => let val ms = map (Logic.count_prems o Thm.prop_of) ctr_thms; val (raw_goal, goal) = (raw_rhs, rhs) |> apply2 (curry mk_Trueprop_eq (applied_fun_of fun_name fun_T fun_args) #> abstract_over_list fun_args #> curry Logic.list_all (map dest_Free fun_args)); val (distincts, discIs, _, split_sels, split_sel_asms) = case_thms_of_term lthy raw_rhs; val raw_code_thm = Goal.prove_sorry lthy [] [] raw_goal (fn {context = ctxt, prems = _} => mk_primcorec_raw_code_tac ctxt distincts discIs split_sels split_sel_asms ms ctr_thms (if exhaustive_code then try the_single nchotomys else NONE)) |> Thm.close_derivation \<^here>; in Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, prems = _} => mk_primcorec_code_tac ctxt distincts split_sels raw_code_thm) |> Thm.close_derivation \<^here> |> single end) end) end; val disc_alistss = @{map 3} (map oo prove_disc) corec_specs excludessss disc_eqnss; val disc_alists = map (map snd o flat) disc_alistss; val sel_alists = @{map 4} (map ooo prove_sel) corec_specs disc_eqnss excludessss sel_eqnss; val disc_thmss = map (map snd o sort_list_duplicates o flat) disc_alistss; val disc_thmsss' = map (map (map (snd o snd))) disc_alistss; val sel_thmss = map (map (fst o snd) o sort_list_duplicates) sel_alists; fun prove_disc_iff ({ctr_specs, ...} : corec_spec) exhaust_thms disc_thmss' (({fun_args = exhaust_fun_args, ...} : coeqn_data_disc) :: _) disc_thms ({fun_name, fun_T, fun_args, ctr_no, prems, eqn_pos, ...} : coeqn_data_disc) = if null exhaust_thms orelse null disc_thms then [] else let val {disc, distinct_discss, ...} = nth ctr_specs ctr_no; val goal = mk_Trueprop_eq (applied_fun_of fun_name fun_T fun_args |> curry betapply disc, mk_conjs prems) |> curry Logic.list_all (map dest_Free fun_args); in Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, prems = _} => mk_primcorec_disc_iff_tac ctxt (map (fst o dest_Free) exhaust_fun_args) (the_single exhaust_thms) disc_thms disc_thmss' (flat distinct_discss)) |> Thm.close_derivation \<^here> |> fold (fn rule => perhaps (try (fn thm => Meson.first_order_resolve lthy thm rule))) @{thms eqTrueE eq_False[THEN iffD1] notnotD} |> pair eqn_pos |> single end; val disc_iff_thmss = @{map 6} (flat ooo map2 oooo prove_disc_iff) corec_specs exhaust_thmss disc_thmsss' disc_eqnss disc_thmsss' disc_eqnss |> map sort_list_duplicates; val ctr_alists = @{map 6} (fn disc_alist => maps oooo prove_ctr disc_alist) disc_alists (map (map snd) sel_alists) corec_specs disc_eqnss sel_eqnss ctr_specss; val ctr_thmss0 = map (map snd) ctr_alists; val ctr_thmss = map (map (snd o snd) o sort (int_ord o apply2 fst)) ctr_alists; val code_thmss = @{map 6} prove_code exhaustives disc_eqnss sel_eqnss nchotomy_thmss ctr_thmss0 ctr_specss; val disc_iff_or_disc_thmss = map2 (fn [] => I | disc_iffs => K disc_iffs) disc_iff_thmss disc_thmss; val simp_thmss = map2 append disc_iff_or_disc_thmss sel_thmss; val common_name = mk_common_name fun_names; val common_qualify = fold_rev I qualifys; val anonymous_notes = [(flat disc_iff_or_disc_thmss, simp_attrs)] |> map (fn (thms, attrs) => ((Binding.empty, attrs), [(thms, [])])); val common_notes = [(coinductN, if n2m then [coinduct_thm] else [], common_coinduct_attrs), (coinduct_strongN, if n2m then [coinduct_strong_thm] else [], common_coinduct_attrs)] |> filter_out (null o #2) |> map (fn (thmN, thms, attrs) => ((common_qualify (Binding.qualify true common_name (Binding.name thmN)), attrs), [(thms, [])])); val notes = [(coinductN, map (if n2m then single else K []) coinduct_thms, coinduct_attrs), (coinduct_strongN, map (if n2m then single else K []) coinduct_strong_thms, coinduct_attrs), (codeN, code_thmss, nitpicksimp_attrs), (ctrN, ctr_thmss, []), (discN, disc_thmss, []), (disc_iffN, disc_iff_thmss, []), (excludeN, exclude_thmss, []), (exhaustN, nontriv_exhaust_thmss, []), (selN, sel_thmss, simp_attrs), (simpsN, simp_thmss, [])] |> maps (fn (thmN, thmss, attrs) => @{map 3} (fn fun_name => fn qualify => fn thms => ((qualify (Binding.qualify true fun_name (Binding.name thmN)), attrs), [(thms, [])])) fun_names qualifys (take actual_nn thmss)) |> filter_out (null o fst o hd o snd); val fun_ts0 = map fst def_infos; in lthy - |> Spec_Rules.add (Spec_Rules.equational_primcorec primcorec_types) (fun_ts0, flat sel_thmss) - |> Spec_Rules.add Spec_Rules.equational (fun_ts0, flat ctr_thmss) - |> Spec_Rules.add Spec_Rules.equational (fun_ts0, flat code_thmss) + |> Spec_Rules.add "" (Spec_Rules.equational_primcorec primcorec_types) fun_ts0 (flat sel_thmss) + |> Spec_Rules.add "" Spec_Rules.equational fun_ts0 (flat ctr_thmss) + |> Spec_Rules.add "" Spec_Rules.equational fun_ts0 (flat code_thmss) |> plugins code_plugin ? Code.declare_default_eqns (map (rpair true) (flat code_thmss)) |> Local_Theory.notes (anonymous_notes @ common_notes @ notes) |> snd |> (fn lthy => let val phi = Local_Theory.target_morphism lthy; val Ts = take actual_nn (map #T corec_specs); val fp_rec_sugar = {transfers = transfers, fun_names = fun_names, funs = map (Morphism.term phi) ts, fun_defs = Morphism.fact phi def_thms, fpTs = Ts}; in interpret_gfp_rec_sugar plugins fp_rec_sugar lthy end) end; fun after_qed thmss' = fold_map Local_Theory.define defs #> tap (uncurry (print_def_consts int)) #-> prove thmss'; in (goalss, after_qed, lthy) end; fun primcorec_ursive_cmd int auto opts (raw_fixes, raw_specs_of) lthy = let val (raw_specs, of_specs_opt) = split_list raw_specs_of ||> map (Option.map (Syntax.read_term lthy)); val (fixes, specs) = fst (Specification.read_multi_specs raw_fixes (map (fn spec => (spec, [], [])) raw_specs) lthy); in primcorec_ursive int auto opts fixes specs of_specs_opt lthy end; fun primcorecursive_cmd int = (fn (goalss, after_qed, lthy) => lthy |> Proof.theorem NONE after_qed goalss |> Proof.refine_singleton (Method.primitive_text (K I))) ooo primcorec_ursive_cmd int false; fun primcorec_cmd int = (fn (goalss, after_qed, lthy) => lthy |> after_qed (map (fn [] => [] | _ => use_primcorecursive ()) goalss)) ooo primcorec_ursive_cmd int true; val corec_option_parser = Parse.group (K "option") (Plugin_Name.parse_filter >> Plugins_Option || Parse.reserved "sequential" >> K Sequential_Option || Parse.reserved "exhaustive" >> K Exhaustive_Option || Parse.reserved "transfer" >> K Transfer_Option); val where_alt_props_of_parser = Parse.where_ |-- Parse.!!! (Parse.enum1 "|" ((Parse.prop >> pair Binding.empty_atts) -- Scan.option (Parse.reserved "of" |-- Parse.const))); val _ = Outer_Syntax.local_theory_to_proof \<^command_keyword>\primcorecursive\ "define primitive corecursive functions" ((Scan.optional (\<^keyword>\(\ |-- Parse.!!! (Parse.list1 corec_option_parser) --| \<^keyword>\)\) []) -- (Parse.vars -- where_alt_props_of_parser) >> uncurry (primcorecursive_cmd true)); val _ = Outer_Syntax.local_theory \<^command_keyword>\primcorec\ "define primitive corecursive functions" ((Scan.optional (\<^keyword>\(\ |-- Parse.!!! (Parse.list1 corec_option_parser) --| \<^keyword>\)\) []) -- (Parse.vars -- where_alt_props_of_parser) >> uncurry (primcorec_cmd true)); val _ = Theory.setup (gfp_rec_sugar_interpretation transfer_plugin gfp_rec_sugar_transfer_interpretation); end; diff --git a/src/HOL/Tools/BNF/bnf_lfp_rec_sugar.ML b/src/HOL/Tools/BNF/bnf_lfp_rec_sugar.ML --- a/src/HOL/Tools/BNF/bnf_lfp_rec_sugar.ML +++ b/src/HOL/Tools/BNF/bnf_lfp_rec_sugar.ML @@ -1,691 +1,692 @@ (* Title: HOL/Tools/BNF/bnf_lfp_rec_sugar.ML Author: Lorenz Panny, TU Muenchen Author: Jasmin Blanchette, TU Muenchen Copyright 2013 Recursor sugar ("primrec"). *) signature BNF_LFP_REC_SUGAR = sig datatype rec_option = Plugins_Option of Proof.context -> Plugin_Name.filter | Nonexhaustive_Option | Transfer_Option datatype rec_call = No_Rec of int * typ | Mutual_Rec of (int * typ) * (int * typ) | Nested_Rec of int * typ type rec_ctr_spec = {ctr: term, offset: int, calls: rec_call list, rec_thm: thm} type rec_spec = {recx: term, fp_nesting_map_ident0s: thm list, fp_nesting_map_comps: thm list, fp_nesting_pred_maps: thm list, ctr_specs: rec_ctr_spec list} type basic_lfp_sugar = {T: typ, fp_res_index: int, C: typ, fun_arg_Tsss : typ list list list, ctr_sugar: Ctr_Sugar.ctr_sugar, recx: term, rec_thms: thm list}; type lfp_rec_extension = {nested_simps: thm list, special_endgame_tac: Proof.context -> thm list -> thm list -> thm list -> tactic, is_new_datatype: Proof.context -> string -> bool, basic_lfp_sugars_of: binding list -> typ list -> term list -> (term * term list list) list list -> local_theory -> typ list * int list * basic_lfp_sugar list * thm list * thm list * thm list * thm * Token.src list * bool * local_theory, rewrite_nested_rec_call: (Proof.context -> (term -> bool) -> (string -> int) -> typ list -> term -> term -> term -> term) option}; val register_lfp_rec_extension: lfp_rec_extension -> theory -> theory val default_basic_lfp_sugars_of: binding list -> typ list -> term list -> (term * term list list) list list -> local_theory -> typ list * int list * basic_lfp_sugar list * thm list * thm list * thm list * thm * Token.src list * bool * local_theory val rec_specs_of: binding list -> typ list -> typ list -> term list -> (term * term list list) list list -> local_theory -> (bool * rec_spec list * typ list * thm * thm list * Token.src list * typ list) * local_theory val lfp_rec_sugar_interpretation: string -> (BNF_FP_Rec_Sugar_Util.fp_rec_sugar -> local_theory -> local_theory) -> theory -> theory val primrec: bool -> rec_option list -> (binding * typ option * mixfix) list -> Specification.multi_specs -> local_theory -> (term list * thm list * thm list list) * local_theory val primrec_cmd: bool -> rec_option list -> (binding * string option * mixfix) list -> Specification.multi_specs_cmd -> local_theory -> (term list * thm list * thm list list) * local_theory val primrec_global: bool -> rec_option list -> (binding * typ option * mixfix) list -> Specification.multi_specs -> theory -> (term list * thm list * thm list list) * theory val primrec_overloaded: bool -> rec_option list -> (string * (string * typ) * bool) list -> (binding * typ option * mixfix) list -> Specification.multi_specs -> theory -> (term list * thm list * thm list list) * theory val primrec_simple: bool -> ((binding * typ) * mixfix) list -> term list -> local_theory -> ((string list * (binding -> binding) list) * (term list * thm list * (int list list * thm list list))) * local_theory end; structure BNF_LFP_Rec_Sugar : BNF_LFP_REC_SUGAR = struct open Ctr_Sugar open Ctr_Sugar_Util open Ctr_Sugar_General_Tactics open BNF_FP_Rec_Sugar_Util val inductN = "induct"; val simpsN = "simps"; val nitpicksimp_attrs = @{attributes [nitpick_simp]}; val simp_attrs = @{attributes [simp]}; val nitpicksimp_simp_attrs = nitpicksimp_attrs @ simp_attrs; exception OLD_PRIMREC of unit; datatype rec_option = Plugins_Option of Proof.context -> Plugin_Name.filter | Nonexhaustive_Option | Transfer_Option; datatype rec_call = No_Rec of int * typ | Mutual_Rec of (int * typ) * (int * typ) | Nested_Rec of int * typ; type rec_ctr_spec = {ctr: term, offset: int, calls: rec_call list, rec_thm: thm}; type rec_spec = {recx: term, fp_nesting_map_ident0s: thm list, fp_nesting_map_comps: thm list, fp_nesting_pred_maps: thm list, ctr_specs: rec_ctr_spec list}; type basic_lfp_sugar = {T: typ, fp_res_index: int, C: typ, fun_arg_Tsss : typ list list list, ctr_sugar: ctr_sugar, recx: term, rec_thms: thm list}; type lfp_rec_extension = {nested_simps: thm list, special_endgame_tac: Proof.context -> thm list -> thm list -> thm list -> tactic, is_new_datatype: Proof.context -> string -> bool, basic_lfp_sugars_of: binding list -> typ list -> term list -> (term * term list list) list list -> local_theory -> typ list * int list * basic_lfp_sugar list * thm list * thm list * thm list * thm * Token.src list * bool * local_theory, rewrite_nested_rec_call: (Proof.context -> (term -> bool) -> (string -> int) -> typ list -> term -> term -> term -> term) option}; structure Data = Theory_Data ( type T = lfp_rec_extension option; val empty = NONE; val extend = I; val merge = merge_options; ); val register_lfp_rec_extension = Data.put o SOME; fun nested_simps ctxt = (case Data.get (Proof_Context.theory_of ctxt) of SOME {nested_simps, ...} => nested_simps | NONE => []); fun special_endgame_tac ctxt = (case Data.get (Proof_Context.theory_of ctxt) of SOME {special_endgame_tac, ...} => special_endgame_tac ctxt | NONE => K (K (K no_tac))); fun is_new_datatype ctxt = (case Data.get (Proof_Context.theory_of ctxt) of SOME {is_new_datatype, ...} => is_new_datatype ctxt | NONE => K true); fun default_basic_lfp_sugars_of _ [Type (arg_T_name, _)] _ _ ctxt = let val ctr_sugar as {T, ctrs, casex, case_thms, ...} = (case ctr_sugar_of ctxt arg_T_name of SOME ctr_sugar => ctr_sugar | NONE => error ("Unsupported type " ^ quote arg_T_name ^ " at this stage")); val C = body_type (fastype_of casex); val fun_arg_Tsss = map (map single o binder_types o fastype_of) ctrs; val basic_lfp_sugar = {T = T, fp_res_index = 0, C = C, fun_arg_Tsss = fun_arg_Tsss, ctr_sugar = ctr_sugar, recx = casex, rec_thms = case_thms}; in ([], [0], [basic_lfp_sugar], [], [], [], TrueI (*dummy*), [], false, ctxt) end | default_basic_lfp_sugars_of _ [T] _ _ ctxt = error ("Cannot recurse through type " ^ quote (Syntax.string_of_typ ctxt T)) | default_basic_lfp_sugars_of _ _ _ _ _ = error "Unsupported mutual recursion at this stage"; fun basic_lfp_sugars_of bs arg_Ts callers callssss lthy = (case Data.get (Proof_Context.theory_of lthy) of SOME {basic_lfp_sugars_of, ...} => basic_lfp_sugars_of | NONE => default_basic_lfp_sugars_of) bs arg_Ts callers callssss lthy; fun rewrite_nested_rec_call ctxt = (case Data.get (Proof_Context.theory_of ctxt) of SOME {rewrite_nested_rec_call = SOME f, ...} => f ctxt | _ => error "Unsupported nested recursion"); structure LFP_Rec_Sugar_Plugin = Plugin(type T = fp_rec_sugar); fun lfp_rec_sugar_interpretation name f = LFP_Rec_Sugar_Plugin.interpretation name (fn fp_rec_sugar => fn lthy => f (transfer_fp_rec_sugar (Proof_Context.theory_of lthy) fp_rec_sugar) lthy); val interpret_lfp_rec_sugar = LFP_Rec_Sugar_Plugin.data; fun rec_specs_of bs arg_Ts res_Ts callers callssss0 lthy0 = let val thy = Proof_Context.theory_of lthy0; val (missing_arg_Ts, perm0_kks, basic_lfp_sugars, fp_nesting_map_ident0s, fp_nesting_map_comps, fp_nesting_pred_maps, common_induct, induct_attrs, n2m, lthy) = basic_lfp_sugars_of bs arg_Ts callers callssss0 lthy0; val perm_basic_lfp_sugars = sort (int_ord o apply2 #fp_res_index) basic_lfp_sugars; val indices = map #fp_res_index basic_lfp_sugars; val perm_indices = map #fp_res_index perm_basic_lfp_sugars; val perm_ctrss = map (#ctrs o #ctr_sugar) perm_basic_lfp_sugars; val nn0 = length arg_Ts; val nn = length perm_ctrss; val kks = 0 upto nn - 1; val perm_ctr_offsets = map (fn kk => Integer.sum (map length (take kk perm_ctrss))) kks; val perm_fpTs = map #T perm_basic_lfp_sugars; val perm_Cs = map #C perm_basic_lfp_sugars; val perm_fun_arg_Tssss = map #fun_arg_Tsss perm_basic_lfp_sugars; fun unpermute0 perm0_xs = permute_like_unique (op =) perm0_kks kks perm0_xs; fun unpermute perm_xs = permute_like_unique (op =) perm_indices indices perm_xs; val inducts = unpermute0 (conj_dests nn common_induct); val fpTs = unpermute perm_fpTs; val Cs = unpermute perm_Cs; val ctr_offsets = unpermute perm_ctr_offsets; val As_rho = tvar_subst thy (take nn0 fpTs) arg_Ts; val Cs_rho = map (fst o dest_TVar) Cs ~~ pad_list HOLogic.unitT nn res_Ts; val substA = Term.subst_TVars As_rho; val substAT = Term.typ_subst_TVars As_rho; val substCT = Term.typ_subst_TVars Cs_rho; val substACT = substAT o substCT; val perm_Cs' = map substCT perm_Cs; fun call_of [i] [T] = (if exists_subtype_in Cs T then Nested_Rec else No_Rec) (i, substACT T) | call_of [i, i'] [T, T'] = Mutual_Rec ((i, substACT T), (i', substACT T')); fun mk_ctr_spec ctr offset fun_arg_Tss rec_thm = let val (fun_arg_hss, _) = indexedd fun_arg_Tss 0; val fun_arg_hs = flat_rec_arg_args fun_arg_hss; val fun_arg_iss = map (map (find_index_eq fun_arg_hs)) fun_arg_hss; in {ctr = substA ctr, offset = offset, calls = map2 call_of fun_arg_iss fun_arg_Tss, rec_thm = rec_thm} end; fun mk_ctr_specs fp_res_index k ctrs rec_thms = @{map 4} mk_ctr_spec ctrs (k upto k + length ctrs - 1) (nth perm_fun_arg_Tssss fp_res_index) rec_thms; fun mk_spec ctr_offset ({T, fp_res_index, ctr_sugar = {ctrs, ...}, recx, rec_thms, ...} : basic_lfp_sugar) = {recx = mk_co_rec thy Least_FP perm_Cs' (substAT T) recx, fp_nesting_map_ident0s = fp_nesting_map_ident0s, fp_nesting_map_comps = fp_nesting_map_comps, fp_nesting_pred_maps = fp_nesting_pred_maps, ctr_specs = mk_ctr_specs fp_res_index ctr_offset ctrs rec_thms}; in ((n2m, map2 mk_spec ctr_offsets basic_lfp_sugars, missing_arg_Ts, common_induct, inducts, induct_attrs, map #T basic_lfp_sugars), lthy) end; val undef_const = Const (\<^const_name>\undefined\, dummyT); type eqn_data = { fun_name: string, rec_type: typ, ctr: term, ctr_args: term list, left_args: term list, right_args: term list, res_type: typ, rhs_term: term, user_eqn: term }; fun dissect_eqn ctxt fun_names eqn0 = let val eqn = drop_all eqn0 |> HOLogic.dest_Trueprop handle TERM _ => ill_formed_equation_lhs_rhs ctxt [eqn0]; val (lhs, rhs) = HOLogic.dest_eq eqn handle TERM _ => ill_formed_equation_lhs_rhs ctxt [eqn]; val (fun_name, args) = strip_comb lhs |>> (fn x => if is_Free x then fst (dest_Free x) else ill_formed_equation_head ctxt [eqn]); val (left_args, rest) = chop_prefix is_Free args; val (nonfrees, right_args) = chop_suffix is_Free rest; val num_nonfrees = length nonfrees; val _ = num_nonfrees = 1 orelse (if num_nonfrees = 0 then missing_pattern ctxt [eqn] else more_than_one_nonvar_in_lhs ctxt [eqn]); val _ = member (op =) fun_names fun_name orelse raise ill_formed_equation_head ctxt [eqn]; val (ctr, ctr_args) = strip_comb (the_single nonfrees); val _ = try (num_binder_types o fastype_of) ctr = SOME (length ctr_args) orelse partially_applied_ctr_in_pattern ctxt [eqn]; val _ = check_duplicate_variables_in_lhs ctxt [eqn] (left_args @ ctr_args @ right_args) val _ = forall is_Free ctr_args orelse nonprimitive_pattern_in_lhs ctxt [eqn]; val _ = let val bads = fold_aterms (fn x as Free (v, _) => if (not (member (op =) (left_args @ ctr_args @ right_args) x) andalso not (member (op =) fun_names v) andalso not (Variable.is_fixed ctxt v)) then cons x else I | _ => I) rhs []; in null bads orelse extra_variable_in_rhs ctxt [eqn] (hd bads) end; in {fun_name = fun_name, rec_type = body_type (type_of ctr), ctr = ctr, ctr_args = ctr_args, left_args = left_args, right_args = right_args, res_type = map fastype_of (left_args @ right_args) ---> fastype_of rhs, rhs_term = rhs, user_eqn = eqn0} end; fun subst_rec_calls ctxt get_ctr_pos has_call ctr_args mutual_calls nested_calls = let fun try_nested_rec bound_Ts y t = AList.lookup (op =) nested_calls y |> Option.map (fn y' => rewrite_nested_rec_call ctxt has_call get_ctr_pos bound_Ts y y' t); fun subst bound_Ts (t as g' $ y) = let fun subst_comb (h $ z) = subst bound_Ts h $ subst bound_Ts z | subst_comb t = t; val y_head = head_of y; in if not (member (op =) ctr_args y_head) then subst_comb t else (case try_nested_rec bound_Ts y_head t of SOME t' => subst_comb t' | NONE => let val (g, g_args) = strip_comb g' in (case try (get_ctr_pos o fst o dest_Free) g of SOME ~1 => subst_comb t | SOME ctr_pos => (length g_args >= ctr_pos orelse too_few_args_in_rec_call ctxt [] t; (case AList.lookup (op =) mutual_calls y of SOME y' => list_comb (y', map (subst bound_Ts) g_args) | NONE => subst_comb t)) | NONE => subst_comb t) end) end | subst bound_Ts (Abs (v, T, b)) = Abs (v, T, subst (T :: bound_Ts) b) | subst _ t = t fun subst' t = if has_call t then rec_call_not_apply_to_ctr_arg ctxt [] t else try_nested_rec [] (head_of t) t |> the_default t; in subst' o subst [] end; fun build_rec_arg ctxt (funs_data : eqn_data list list) has_call (ctr_spec : rec_ctr_spec) (eqn_data_opt : eqn_data option) = (case eqn_data_opt of NONE => undef_const | SOME {ctr_args, left_args, right_args, rhs_term = t, ...} => let val calls = #calls ctr_spec; val n_args = fold (Integer.add o (fn Mutual_Rec _ => 2 | _ => 1)) calls 0; val no_calls' = tag_list 0 calls |> map_filter (try (apsnd (fn No_Rec p => p | Mutual_Rec (p, _) => p))); val mutual_calls' = tag_list 0 calls |> map_filter (try (apsnd (fn Mutual_Rec (_, p) => p))); val nested_calls' = tag_list 0 calls |> map_filter (try (apsnd (fn Nested_Rec p => p))); fun ensure_unique frees t = if member (op =) frees t then Free (the_single (Term.variant_frees t [dest_Free t])) else t; val args = replicate n_args ("", dummyT) |> Term.rename_wrt_term t |> map Free |> fold (fn (ctr_arg_idx, (arg_idx, _)) => nth_map arg_idx (K (nth ctr_args ctr_arg_idx))) no_calls' |> fold (fn (ctr_arg_idx, (arg_idx, T)) => fn xs => nth_map arg_idx (K (ensure_unique xs (retype_const_or_free T (nth ctr_args ctr_arg_idx)))) xs) mutual_calls' |> fold (fn (ctr_arg_idx, (arg_idx, T)) => nth_map arg_idx (K (retype_const_or_free T (nth ctr_args ctr_arg_idx)))) nested_calls'; val fun_name_ctr_pos_list = map (fn (x :: _) => (#fun_name x, length (#left_args x))) funs_data; val get_ctr_pos = try (the o AList.lookup (op =) fun_name_ctr_pos_list) #> the_default ~1; val mutual_calls = map (map_prod (nth ctr_args) (nth args o fst)) mutual_calls'; val nested_calls = map (map_prod (nth ctr_args) (nth args o fst)) nested_calls'; in t |> subst_rec_calls ctxt get_ctr_pos has_call ctr_args mutual_calls nested_calls |> fold_rev lambda (args @ left_args @ right_args) end); fun build_defs ctxt nonexhaustives bs mxs (funs_data : eqn_data list list) (rec_specs : rec_spec list) has_call = let val n_funs = length funs_data; val ctr_spec_eqn_data_list' = maps (fn ((xs, ys), z) => let val zs = replicate (length xs) z; val (b, c) = finds (fn ((x, _), y) => #ctr x = #ctr y) (xs ~~ zs) ys; val _ = null c orelse excess_equations ctxt (map #rhs_term c); in b end) (map #ctr_specs (take n_funs rec_specs) ~~ funs_data ~~ nonexhaustives); val (_ : unit list) = ctr_spec_eqn_data_list' |> map (fn (({ctr, ...}, nonexhaustive), x) => if length x > 1 then multiple_equations_for_ctr ctxt (map #user_eqn x) else if length x = 1 orelse nonexhaustive orelse not (Context_Position.is_visible ctxt) then () else no_equation_for_ctr_warning ctxt [] ctr); val ctr_spec_eqn_data_list = map (apfst fst) ctr_spec_eqn_data_list' @ (drop n_funs rec_specs |> maps #ctr_specs |> map (rpair [])); val recs = take n_funs rec_specs |> map #recx; val rec_args = ctr_spec_eqn_data_list |> sort (op < o apply2 (#offset o fst) |> make_ord) |> map (uncurry (build_rec_arg ctxt funs_data has_call) o apsnd (try the_single)); val ctr_poss = map (fn x => if length (distinct (op = o apply2 (length o #left_args)) x) <> 1 then inconstant_pattern_pos_for_fun ctxt [] (#fun_name (hd x)) else hd x |> #left_args |> length) funs_data; in (recs, ctr_poss) |-> map2 (fn recx => fn ctr_pos => list_comb (recx, rec_args) |> permute_args ctr_pos) |> Syntax.check_terms ctxt |> @{map 3} (fn b => fn mx => fn t => ((b, mx), ((Binding.concealed (Thm.def_binding b), []), t))) bs mxs end; fun find_rec_calls has_call ({ctr, ctr_args, rhs_term, ...} : eqn_data) = let fun find bound_Ts (Abs (_, T, b)) ctr_arg = find (T :: bound_Ts) b ctr_arg | find bound_Ts (t as _ $ _) ctr_arg = let val typof = curry fastype_of1 bound_Ts; val (f', args') = strip_comb t; val n = find_index (equal ctr_arg o head_of) args'; in if n < 0 then find bound_Ts f' ctr_arg @ maps (fn x => find bound_Ts x ctr_arg) args' else let val (f, args as arg :: _) = chop n args' |>> curry list_comb f' val (arg_head, arg_args) = Term.strip_comb arg; in if has_call f then mk_partial_compN (length arg_args) (typof arg_head) f :: maps (fn x => find bound_Ts x ctr_arg) args else find bound_Ts f ctr_arg @ maps (fn x => find bound_Ts x ctr_arg) args end end | find _ _ _ = []; in map (find [] rhs_term) ctr_args |> (fn [] => NONE | callss => SOME (ctr, callss)) end; fun mk_primrec_tac ctxt num_extra_args fp_nesting_map_ident0s fp_nesting_map_comps fp_nesting_pred_maps fun_defs recx = unfold_thms_tac ctxt fun_defs THEN HEADGOAL (rtac ctxt (funpow num_extra_args (fn thm => thm RS fun_cong) recx RS trans)) THEN unfold_thms_tac ctxt (nested_simps ctxt @ fp_nesting_map_ident0s @ fp_nesting_map_comps @ fp_nesting_pred_maps) THEN REPEAT_DETERM (HEADGOAL (rtac ctxt refl) ORELSE special_endgame_tac ctxt fp_nesting_map_ident0s fp_nesting_map_comps fp_nesting_pred_maps); fun prepare_primrec plugins nonexhaustives transfers fixes specs lthy0 = let val thy = Proof_Context.theory_of lthy0; val (bs, mxs) = map_split (apfst fst) fixes; val fun_names = map Binding.name_of bs; val qualifys = map (fold_rev (uncurry Binding.qualify o swap) o Binding.path_of) bs; val eqns_data = map (dissect_eqn lthy0 fun_names) specs; val funs_data = eqns_data |> partition_eq (op = o apply2 #fun_name) |> finds (fn (x, y) => x = #fun_name (hd y)) fun_names |> fst |> map (fn (x, y) => the_single y handle List.Empty => missing_equations_for_fun x); val frees = map (fst #>> Binding.name_of #> Free) fixes; val has_call = exists_subterm (member (op =) frees); val arg_Ts = map (#rec_type o hd) funs_data; val res_Ts = map (#res_type o hd) funs_data; val callssss = funs_data |> map (partition_eq (op = o apply2 #ctr)) |> map (maps (map_filter (find_rec_calls has_call))); fun is_only_old_datatype (Type (s, _)) = is_some (Old_Datatype_Data.get_info thy s) andalso not (is_new_datatype lthy0 s) | is_only_old_datatype _ = false; val _ = if exists is_only_old_datatype arg_Ts then raise OLD_PRIMREC () else (); val _ = List.app (uncurry (check_top_sort lthy0)) (bs ~~ res_Ts); val ((n2m, rec_specs, _, common_induct, inducts, induct_attrs, Ts), lthy) = rec_specs_of bs arg_Ts res_Ts frees callssss lthy0; val actual_nn = length funs_data; val ctrs = maps (map #ctr o #ctr_specs) rec_specs; val _ = List.app (fn {ctr, user_eqn, ...} => ignore (member (op =) ctrs ctr orelse not_constructor_in_pattern lthy0 [user_eqn] ctr)) eqns_data; val defs = build_defs lthy nonexhaustives bs mxs funs_data rec_specs has_call; fun prove def_thms ({ctr_specs, fp_nesting_map_ident0s, fp_nesting_map_comps, fp_nesting_pred_maps, ...} : rec_spec) (fun_data : eqn_data list) lthy' = let val js = find_indices (op = o apply2 (fn {fun_name, ctr, ...} => (fun_name, ctr))) fun_data eqns_data; val simps = finds (fn (x, y) => #ctr x = #ctr y) fun_data ctr_specs |> fst |> map_filter (try (fn (x, [y]) => (#user_eqn x, length (#left_args x) + length (#right_args x), #rec_thm y))) |> map (fn (user_eqn, num_extra_args, rec_thm) => Goal.prove_sorry lthy' [] [] user_eqn (fn {context = ctxt, prems = _} => mk_primrec_tac ctxt num_extra_args fp_nesting_map_ident0s fp_nesting_map_comps fp_nesting_pred_maps def_thms rec_thm) |> Thm.close_derivation \<^here>); in ((js, simps), lthy') end; val notes = (if n2m then @{map 3} (fn name => fn qualify => fn thm => (name, qualify, inductN, [thm], induct_attrs)) fun_names qualifys (take actual_nn inducts) else []) |> map (fn (prefix, qualify, thmN, thms, attrs) => ((qualify (Binding.qualify true prefix (Binding.name thmN)), attrs), [(thms, [])])); val common_name = mk_common_name fun_names; val common_qualify = fold_rev I qualifys; val common_notes = (if n2m then [(inductN, [common_induct], [])] else []) |> map (fn (thmN, thms, attrs) => ((common_qualify (Binding.qualify true common_name (Binding.name thmN)), attrs), [(thms, [])])); in (((fun_names, qualifys, arg_Ts, defs), fn lthy => fn defs => let val def_thms = map (snd o snd) defs; val ts = map fst defs; val phi = Local_Theory.target_morphism lthy; val fp_rec_sugar = {transfers = transfers, fun_names = fun_names, funs = map (Morphism.term phi) ts, fun_defs = Morphism.fact phi def_thms, fpTs = take actual_nn Ts}; in map_prod split_list (interpret_lfp_rec_sugar plugins fp_rec_sugar) (@{fold_map 2} (prove (map (snd o snd) defs)) (take actual_nn rec_specs) funs_data lthy) end), lthy |> Local_Theory.notes (notes @ common_notes) |> snd) end; fun primrec_simple0 int plugins nonexhaustive transfer fixes ts lthy = let val _ = check_duplicate_const_names (map (fst o fst) fixes); val actual_nn = length fixes; val nonexhaustives = replicate actual_nn nonexhaustive; val transfers = replicate actual_nn transfer; val (((names, qualifys, arg_Ts, defs), prove), lthy') = prepare_primrec plugins nonexhaustives transfers fixes ts lthy; in lthy' |> fold_map Local_Theory.define defs |> tap (uncurry (print_def_consts int)) |-> (fn defs => fn lthy => let val ((jss, simpss), lthy) = prove lthy defs; val res = {prefix = (names, qualifys), types = map (#1 o dest_Type) arg_Ts, result = (map fst defs, map (snd o snd) defs, (jss, simpss))}; in (res, lthy) end) end; fun primrec_simple int fixes ts lthy = primrec_simple0 int Plugin_Name.default_filter false false fixes ts lthy |>> (fn {prefix, result, ...} => (prefix, result)) handle OLD_PRIMREC () => Old_Primrec.primrec_simple int fixes ts lthy |>> (fn {prefix, result = (ts, thms), ...} => (map_split (rpair I) [prefix], (ts, [], ([], [thms])))) fun gen_primrec old_primrec prep_spec int opts raw_fixes raw_specs lthy = let val plugins = get_first (fn Plugins_Option f => SOME (f lthy) | _ => NONE) (rev opts) |> the_default Plugin_Name.default_filter; val nonexhaustive = exists (can (fn Nonexhaustive_Option => ())) opts; val transfer = exists (can (fn Transfer_Option => ())) opts; val (fixes, specs) = fst (prep_spec raw_fixes raw_specs lthy); + val spec_name = Local_Theory.full_name lthy (Binding.conglomerate (map (#1 o #1) fixes)); val mk_notes = flat oooo @{map 4} (fn js => fn prefix => fn qualify => fn thms => let val (bs, attrss) = map_split (fst o nth specs) js; val notes = @{map 3} (fn b => fn attrs => fn thm => ((Binding.qualify false prefix b, nitpicksimp_simp_attrs @ attrs), [([thm], [])])) bs attrss thms; in ((qualify (Binding.qualify true prefix (Binding.name simpsN)), []), [(thms, [])]) :: notes end); in lthy |> primrec_simple0 int plugins nonexhaustive transfer fixes (map snd specs) |-> (fn {prefix = (names, qualifys), types, result = (ts, defs, (jss, simpss))} => - Spec_Rules.add (Spec_Rules.equational_primrec types) (ts, flat simpss) + Spec_Rules.add spec_name (Spec_Rules.equational_primrec types) ts (flat simpss) #> Local_Theory.notes (mk_notes jss names qualifys simpss) #-> (fn notes => plugins code_plugin ? Code.declare_default_eqns (map (rpair true) (maps snd notes)) #> pair (ts, defs, map_filter (fn ("", _) => NONE | (_, thms) => SOME thms) notes))) end handle OLD_PRIMREC () => old_primrec int raw_fixes raw_specs lthy |>> (fn {result = (ts, thms), ...} => (ts, [], [thms])); val primrec = gen_primrec Old_Primrec.primrec Specification.check_multi_specs; val primrec_cmd = gen_primrec Old_Primrec.primrec_cmd Specification.read_multi_specs; fun primrec_global int opts fixes specs = Named_Target.theory_init #> primrec int opts fixes specs ##> Local_Theory.exit_global; fun primrec_overloaded int opts ops fixes specs = Overloading.overloading ops #> primrec int opts fixes specs ##> Local_Theory.exit_global; val rec_option_parser = Parse.group (K "option") (Plugin_Name.parse_filter >> Plugins_Option || Parse.reserved "nonexhaustive" >> K Nonexhaustive_Option || Parse.reserved "transfer" >> K Transfer_Option); val _ = Outer_Syntax.local_theory \<^command_keyword>\primrec\ "define primitive recursive functions" ((Scan.optional (\<^keyword>\(\ |-- Parse.!!! (Parse.list1 rec_option_parser) --| \<^keyword>\)\) []) -- Parse_Spec.specification >> (fn (opts, (fixes, specs)) => snd o primrec_cmd true opts fixes specs)); end; diff --git a/src/HOL/Tools/BNF/bnf_lfp_size.ML b/src/HOL/Tools/BNF/bnf_lfp_size.ML --- a/src/HOL/Tools/BNF/bnf_lfp_size.ML +++ b/src/HOL/Tools/BNF/bnf_lfp_size.ML @@ -1,399 +1,399 @@ (* Title: HOL/Tools/BNF/bnf_lfp_size.ML Author: Jasmin Blanchette, TU Muenchen Copyright 2014 Generation of size functions for datatypes. *) signature BNF_LFP_SIZE = sig val register_size: string -> string -> thm -> thm list -> thm list -> local_theory -> local_theory val register_size_global: string -> string -> thm -> thm list -> thm list -> theory -> theory val size_of: Proof.context -> string -> (string * (thm * thm list * thm list)) option val size_of_global: theory -> string -> (string * (thm * thm list * thm list)) option end; structure BNF_LFP_Size : BNF_LFP_SIZE = struct open BNF_Util open BNF_Tactics open BNF_Def open BNF_FP_Def_Sugar val size_N = "size_"; val sizeN = "size"; val size_genN = "size_gen"; val size_gen_o_mapN = "size_gen_o_map"; val size_neqN = "size_neq"; val nitpicksimp_attrs = @{attributes [nitpick_simp]}; val simp_attrs = @{attributes [simp]}; fun mk_plus_nat (t1, t2) = Const (\<^const_name>\Groups.plus\, HOLogic.natT --> HOLogic.natT --> HOLogic.natT) $ t1 $ t2; fun mk_to_natT T = T --> HOLogic.natT; fun mk_abs_zero_nat T = Term.absdummy T HOLogic.zero; fun mk_unabs_def_unused_0 n = funpow n (fn thm => thm RS @{thm fun_cong_unused_0} handle THM _ => thm RS fun_cong); structure Data = Generic_Data ( type T = (string * (thm * thm list * thm list)) Symtab.table; val empty = Symtab.empty; val extend = I fun merge data = Symtab.merge (K true) data; ); fun check_size_type thy T_name size_name = let val n = Sign.arity_number thy T_name; val As = map (fn s => TFree (s, \<^sort>\type\)) (Name.invent Name.context Name.aT n); val T = Type (T_name, As); val size_T = map mk_to_natT As ---> mk_to_natT T; val size_const = Const (size_name, size_T); in can (Thm.global_cterm_of thy) size_const orelse error ("Constant " ^ quote size_name ^ " registered as size function for " ^ quote T_name ^ " must have type\n" ^ quote (Syntax.string_of_typ_global thy size_T)) end; fun register_size T_name size_name overloaded_size_def size_simps size_gen_o_maps lthy = (check_size_type (Proof_Context.theory_of lthy) T_name size_name; Context.proof_map (Data.map (Symtab.update (T_name, (size_name, (overloaded_size_def, size_simps, size_gen_o_maps))))) lthy); fun register_size_global T_name size_name overloaded_size_def size_simps size_gen_o_maps thy = (check_size_type thy T_name size_name; Context.theory_map (Data.map (Symtab.update (T_name, (size_name, (overloaded_size_def, size_simps, size_gen_o_maps))))) thy); val size_of = Symtab.lookup o Data.get o Context.Proof; val size_of_global = Symtab.lookup o Data.get o Context.Theory; fun all_overloaded_size_defs_of ctxt = Symtab.fold (fn (_, (_, (overloaded_size_def, _, _))) => can (Logic.dest_equals o Thm.prop_of) overloaded_size_def ? cons overloaded_size_def) (Data.get (Context.Proof ctxt)) []; val size_gen_o_map_simps = @{thms inj_on_id snd_comp_apfst[simplified apfst_def]}; fun mk_size_gen_o_map_tac ctxt size_def rec_o_map inj_maps size_maps = unfold_thms_tac ctxt [size_def] THEN HEADGOAL (rtac ctxt (rec_o_map RS trans) THEN' asm_simp_tac (ss_only (inj_maps @ size_maps @ size_gen_o_map_simps) ctxt)) THEN IF_UNSOLVED (unfold_thms_tac ctxt @{thms id_def o_def} THEN HEADGOAL (rtac ctxt refl)); fun mk_size_neq ctxt cts exhaust sizes = HEADGOAL (rtac ctxt (infer_instantiate' ctxt (map SOME cts) exhaust)) THEN ALLGOALS (hyp_subst_tac ctxt) THEN unfold_thms_tac ctxt (@{thm neq0_conv} :: sizes) THEN ALLGOALS (REPEAT_DETERM o (rtac ctxt @{thm zero_less_Suc} ORELSE' rtac ctxt @{thm trans_less_add2})); fun generate_datatype_size (fp_sugars as ({T = Type (_, As), BT = Type (_, Bs), fp = Least_FP, fp_res = {bnfs = fp_bnfs, ...}, fp_nesting_bnfs, live_nesting_bnfs, fp_co_induct_sugar = SOME _, ...} : fp_sugar) :: _) lthy0 = let val data = Data.get (Context.Proof lthy0); val Ts = map #T fp_sugars val T_names = map (fst o dest_Type) Ts; val nn = length Ts; val B_ify = Term.typ_subst_atomic (As ~~ Bs); val recs = map (#co_rec o the o #fp_co_induct_sugar) fp_sugars; val rec_thmss = map (#co_rec_thms o the o #fp_co_induct_sugar) fp_sugars; val rec_Ts as rec_T1 :: _ = map fastype_of recs; val rec_arg_Ts = binder_fun_types rec_T1; val Cs = map body_type rec_Ts; val Cs_rho = map (rpair HOLogic.natT) Cs; val substCnatT = Term.subst_atomic_types Cs_rho; val f_Ts = map mk_to_natT As; val f_TsB = map mk_to_natT Bs; val num_As = length As; fun variant_names n pre = fst (Variable.variant_fixes (replicate n pre) lthy0); val f_names = variant_names num_As "f"; val fs = map2 (curry Free) f_names f_Ts; val fsB = map2 (curry Free) f_names f_TsB; val As_fs = As ~~ fs; val size_bs = map ((fn base => Binding.qualify false base (Binding.name (prefix size_N base))) o Long_Name.base_name) T_names; fun is_prod_C \<^type_name>\prod\ [_, T'] = member (op =) Cs T' | is_prod_C _ _ = false; fun mk_size_of_typ (T as TFree _) = pair (case AList.lookup (op =) As_fs T of SOME f => f | NONE => if member (op =) Cs T then Term.absdummy T (Bound 0) else mk_abs_zero_nat T) | mk_size_of_typ (T as Type (s, Ts)) = if is_prod_C s Ts then pair (snd_const T) else if exists (exists_subtype_in (As @ Cs)) Ts then (case Symtab.lookup data s of SOME (size_name, (_, _, size_gen_o_maps)) => let val (args, size_gen_o_mapss') = fold_map mk_size_of_typ Ts []; val size_T = map fastype_of args ---> mk_to_natT T; val size_const = Const (size_name, size_T); in append (size_gen_o_maps :: size_gen_o_mapss') #> pair (Term.list_comb (size_const, args)) end | _ => pair (mk_abs_zero_nat T)) else pair (mk_abs_zero_nat T); fun mk_size_of_arg t = mk_size_of_typ (fastype_of t) #>> (fn s => substCnatT (betapply (s, t))); fun is_recursive_or_plain_case Ts = exists (exists_subtype_in Cs) Ts orelse forall (not o exists_subtype_in As) Ts; (* We want the size function to enjoy the following properties: 1. The size of a list should coincide with its length. 2. All the nonrecursive constructors of a type should have the same size. 3. Each constructor through which nested recursion takes place should count as at least one in the generic size function. 4. The "size" function should be definable as "size_t (%_. 0) ... (%_. 0)", where "size_t" is the generic function. This explains the somewhat convoluted logic ahead. *) val base_case = if forall (is_recursive_or_plain_case o binder_types) rec_arg_Ts then HOLogic.zero else HOLogic.Suc_zero; fun mk_size_arg rec_arg_T = let val x_Ts = binder_types rec_arg_T; val m = length x_Ts; val x_names = variant_names m "x"; val xs = map2 (curry Free) x_names x_Ts; val (summands, size_gen_o_mapss) = fold_map mk_size_of_arg xs [] |>> remove (op =) HOLogic.zero; val sum = if null summands then base_case else foldl1 mk_plus_nat (summands @ [HOLogic.Suc_zero]); in append size_gen_o_mapss #> pair (fold_rev Term.lambda (map substCnatT xs) sum) end; fun mk_size_rhs recx = fold_map mk_size_arg rec_arg_Ts #>> (fn args => fold_rev Term.lambda fs (Term.list_comb (substCnatT recx, args))); val maybe_conceal_def_binding = Thm.def_binding #> not (Config.get lthy0 bnf_internals) ? Binding.concealed; val (size_rhss, nested_size_gen_o_mapss) = fold_map mk_size_rhs recs []; val size_Ts = map fastype_of size_rhss; val nested_size_gen_o_maps_complete = forall (not o null) nested_size_gen_o_mapss; val nested_size_gen_o_maps = fold (union Thm.eq_thm_prop) nested_size_gen_o_mapss []; val ((raw_size_consts, raw_size_defs), (lthy1, lthy1_old)) = lthy0 |> Local_Theory.open_target |> snd |> apfst split_list o @{fold_map 2} (fn b => fn rhs => Local_Theory.define ((b, NoSyn), ((maybe_conceal_def_binding b, []), rhs)) #>> apsnd snd) size_bs size_rhss ||> `Local_Theory.close_target; val phi = Proof_Context.export_morphism lthy1_old lthy1; val size_defs = map (Morphism.thm phi) raw_size_defs; val size_consts0 = map (Morphism.term phi) raw_size_consts; val size_consts = map2 retype_const_or_free size_Ts size_consts0; val size_constsB = map (Term.map_types B_ify) size_consts; val zeros = map mk_abs_zero_nat As; val overloaded_size_rhss = map (fn c => Term.list_comb (c, zeros)) size_consts; val overloaded_size_Ts = map fastype_of overloaded_size_rhss; val overloaded_size_consts = map (curry Const \<^const_name>\size\) overloaded_size_Ts; val overloaded_size_def_bs = map (maybe_conceal_def_binding o Binding.suffix_name "_overloaded") size_bs; fun define_overloaded_size def_b lhs0 rhs lthy = let val Free (c, _) = Syntax.check_term lthy lhs0; val ((_, (_, thm)), lthy') = lthy |> Local_Theory.define ((Binding.name c, NoSyn), ((def_b, []), rhs)); val thy_ctxt = Proof_Context.init_global (Proof_Context.theory_of lthy'); val thm' = singleton (Proof_Context.export lthy' thy_ctxt) thm; in (thm', lthy') end; val (overloaded_size_defs, lthy2) = lthy1 |> Local_Theory.background_theory_result (Class.instantiation (T_names, map dest_TFree As, [HOLogic.class_size]) #> @{fold_map 3} define_overloaded_size overloaded_size_def_bs overloaded_size_consts overloaded_size_rhss ##> Class.prove_instantiation_instance (fn ctxt => Class.intro_classes_tac ctxt []) ##> Local_Theory.exit_global); val size_defs' = map (mk_unabs_def (num_As + 1) o HOLogic.mk_obj_eq) size_defs; val size_defs_unused_0 = map (mk_unabs_def_unused_0 (num_As + 1) o HOLogic.mk_obj_eq) size_defs; val overloaded_size_defs' = map (mk_unabs_def 1 o HOLogic.mk_obj_eq) overloaded_size_defs; val nested_size_maps = map (mk_pointful lthy2) nested_size_gen_o_maps @ nested_size_gen_o_maps; val all_inj_maps = @{thm prod.inj_map} :: map inj_map_of_bnf (fp_bnfs @ fp_nesting_bnfs @ live_nesting_bnfs) |> distinct Thm.eq_thm_prop; fun derive_size_simp size_def' simp0 = (trans OF [size_def', simp0]) |> Simplifier.asm_full_simplify (ss_only (@{thms inj_on_convol_ident id_def o_def snd_conv} @ all_inj_maps @ nested_size_maps) lthy2) |> Local_Defs.fold lthy2 size_defs_unused_0; fun derive_overloaded_size_simp overloaded_size_def' simp0 = (trans OF [overloaded_size_def', simp0]) |> unfold_thms lthy2 @{thms add_0_left add_0_right} |> Local_Defs.fold lthy2 (overloaded_size_defs @ all_overloaded_size_defs_of lthy2); val size_simpss = map2 (map o derive_size_simp) size_defs' rec_thmss; val size_simps = flat size_simpss; val overloaded_size_simpss = map2 (map o derive_overloaded_size_simp) overloaded_size_defs' size_simpss; val overloaded_size_simps = flat overloaded_size_simpss; val size_thmss = map2 append size_simpss overloaded_size_simpss; val size_gen_thmss = size_simpss; fun rhs_is_zero thm = let val Const (trueprop, _) $ (Const (eq, _) $ _ $ rhs) = Thm.prop_of thm in trueprop = \<^const_name>\Trueprop\ andalso eq = \<^const_name>\HOL.eq\ andalso rhs = HOLogic.zero end; val size_neq_thmss = @{map 3} (fn fp_sugar => fn size => fn size_thms => if exists rhs_is_zero size_thms then [] else let val (xs, _) = mk_Frees "x" (binder_types (fastype_of size)) lthy2; val goal = HOLogic.mk_Trueprop (BNF_LFP_Util.mk_not_eq (list_comb (size, xs)) HOLogic.zero); val vars = Variable.add_free_names lthy2 goal []; val thm = Goal.prove_sorry lthy2 vars [] goal (fn {context = ctxt, ...} => mk_size_neq ctxt (map (Thm.cterm_of lthy2) xs) (#exhaust (#ctr_sugar (#fp_ctr_sugar fp_sugar))) size_thms) |> single |> map (Thm.close_derivation \<^here>); in thm end) fp_sugars overloaded_size_consts overloaded_size_simpss; val ABs = As ~~ Bs; val g_names = variant_names num_As "g"; val gs = map2 (curry Free) g_names (map (op -->) ABs); val liveness = map (op <>) ABs; val live_gs = AList.find (op =) (gs ~~ liveness) true; val live = length live_gs; val maps0 = map map_of_bnf fp_bnfs; val size_gen_o_map_thmss = if live = 0 then replicate nn [] else let val gmaps = map (fn map0 => Term.list_comb (mk_map live As Bs map0, live_gs)) maps0; val size_gen_o_map_conds = if exists (can Logic.dest_implies o Thm.prop_of) nested_size_gen_o_maps then map (HOLogic.mk_Trueprop o mk_inj) live_gs else []; val fsizes = map (fn size_constB => Term.list_comb (size_constB, fsB)) size_constsB; val size_gen_o_map_lhss = map2 (curry HOLogic.mk_comp) fsizes gmaps; val fgs = map2 (fn fB => fn g as Free (_, Type (_, [A, B])) => if A = B then fB else HOLogic.mk_comp (fB, g)) fsB gs; val size_gen_o_map_rhss = map (fn c => Term.list_comb (c, fgs)) size_consts; val size_gen_o_map_goals = map2 (fold_rev (fold_rev Logic.all) [fsB, gs] o curry Logic.list_implies size_gen_o_map_conds o HOLogic.mk_Trueprop oo curry HOLogic.mk_eq) size_gen_o_map_lhss size_gen_o_map_rhss; val rec_o_maps = fold_rev (curry (op @) o #co_rec_o_maps o the o #fp_co_induct_sugar) fp_sugars []; val size_gen_o_map_thmss = if nested_size_gen_o_maps_complete andalso forall (fn TFree (_, S) => S = \<^sort>\type\) As then @{map 3} (fn goal => fn size_def => fn rec_o_map => Goal.prove_sorry lthy2 [] [] goal (fn {context = ctxt, ...} => mk_size_gen_o_map_tac ctxt size_def rec_o_map all_inj_maps nested_size_maps) |> Thm.close_derivation \<^here> |> single) size_gen_o_map_goals size_defs rec_o_maps else replicate nn []; in size_gen_o_map_thmss end; val massage_multi_notes = maps (fn (thmN, thmss, attrs) => map2 (fn T_name => fn thms => ((Binding.qualify true (Long_Name.base_name T_name) (Binding.name thmN), attrs), [(thms, [])])) T_names thmss) #> filter_out (null o fst o hd o snd); val notes = [(sizeN, size_thmss, nitpicksimp_attrs @ simp_attrs), (size_genN, size_gen_thmss, []), (size_gen_o_mapN, size_gen_o_map_thmss, []), (size_neqN, size_neq_thmss, [])] |> massage_multi_notes; val (noted, lthy3) = lthy2 - |> Spec_Rules.add Spec_Rules.equational (size_consts, size_simps) - |> Spec_Rules.add Spec_Rules.equational (overloaded_size_consts, overloaded_size_simps) + |> Spec_Rules.add "" Spec_Rules.equational size_consts size_simps + |> Spec_Rules.add "" Spec_Rules.equational overloaded_size_consts overloaded_size_simps |> Code.declare_default_eqns (map (rpair true) (flat size_thmss)) (*Ideally, this would be issued only if the "code" plugin is enabled.*) |> Local_Theory.notes notes; val phi0 = substitute_noted_thm noted; in lthy3 |> Local_Theory.declaration {syntax = false, pervasive = true} (fn phi => Data.map (@{fold 3} (fn T_name => fn Const (size_name, _) => fn overloaded_size_def => let val morph = Morphism.thm (phi0 $> phi) in Symtab.update (T_name, (size_name, (morph overloaded_size_def, map morph overloaded_size_simps, maps (map morph) size_gen_o_map_thmss))) end) T_names size_consts overloaded_size_defs)) end | generate_datatype_size _ lthy = lthy; val size_plugin = Plugin_Name.declare_setup \<^binding>\size\; val _ = Theory.setup (fp_sugars_interpretation size_plugin generate_datatype_size); end; diff --git a/src/HOL/Tools/Ctr_Sugar/ctr_sugar.ML b/src/HOL/Tools/Ctr_Sugar/ctr_sugar.ML --- a/src/HOL/Tools/Ctr_Sugar/ctr_sugar.ML +++ b/src/HOL/Tools/Ctr_Sugar/ctr_sugar.ML @@ -1,1190 +1,1190 @@ (* Title: HOL/Tools/Ctr_Sugar/ctr_sugar.ML Author: Jasmin Blanchette, TU Muenchen Author: Martin Desharnais, TU Muenchen Copyright 2012, 2013 Wrapping existing freely generated type's constructors. *) signature CTR_SUGAR = sig datatype ctr_sugar_kind = Datatype | Codatatype | Record | Unknown type ctr_sugar = {kind: ctr_sugar_kind, T: typ, ctrs: term list, casex: term, discs: term list, selss: term list list, exhaust: thm, nchotomy: thm, injects: thm list, distincts: thm list, case_thms: thm list, case_cong: thm, case_cong_weak: thm, case_distribs: thm list, split: thm, split_asm: thm, disc_defs: thm list, disc_thmss: thm list list, discIs: thm list, disc_eq_cases: thm list, sel_defs: thm list, sel_thmss: thm list list, distinct_discsss: thm list list list, exhaust_discs: thm list, exhaust_sels: thm list, collapses: thm list, expands: thm list, split_sels: thm list, split_sel_asms: thm list, case_eq_ifs: thm list}; val morph_ctr_sugar: morphism -> ctr_sugar -> ctr_sugar val transfer_ctr_sugar: theory -> ctr_sugar -> ctr_sugar val ctr_sugar_of: Proof.context -> string -> ctr_sugar option val ctr_sugar_of_global: theory -> string -> ctr_sugar option val ctr_sugars_of: Proof.context -> ctr_sugar list val ctr_sugars_of_global: theory -> ctr_sugar list val ctr_sugar_of_case: Proof.context -> string -> ctr_sugar option val ctr_sugar_of_case_global: theory -> string -> ctr_sugar option val ctr_sugar_interpretation: string -> (ctr_sugar -> local_theory -> local_theory) -> theory -> theory val interpret_ctr_sugar: (string -> bool) -> ctr_sugar -> local_theory -> local_theory val register_ctr_sugar_raw: ctr_sugar -> local_theory -> local_theory val register_ctr_sugar: (string -> bool) -> ctr_sugar -> local_theory -> local_theory val default_register_ctr_sugar_global: (string -> bool) -> ctr_sugar -> theory -> theory val mk_half_pairss: 'a list * 'a list -> ('a * 'a) list list val join_halves: int -> 'a list list -> 'a list list -> 'a list * 'a list list list val mk_ctr: typ list -> term -> term val mk_case: typ list -> typ -> term -> term val mk_disc_or_sel: typ list -> term -> term val name_of_ctr: term -> string val name_of_disc: term -> string val dest_ctr: Proof.context -> string -> term -> term * term list val dest_case: Proof.context -> string -> typ list -> term -> (ctr_sugar * term list * term list) option type ('c, 'a) ctr_spec = (binding * 'c) * 'a list val disc_of_ctr_spec: ('c, 'a) ctr_spec -> binding val ctr_of_ctr_spec: ('c, 'a) ctr_spec -> 'c val args_of_ctr_spec: ('c, 'a) ctr_spec -> 'a list val code_plugin: string type ctr_options = (string -> bool) * bool type ctr_options_cmd = (Proof.context -> string -> bool) * bool val fake_local_theory_for_sel_defaults: (binding * typ) list -> Proof.context -> Proof.context val free_constructors: ctr_sugar_kind -> ({prems: thm list, context: Proof.context} -> tactic) list list -> ((ctr_options * binding) * (term, binding) ctr_spec list) * term list -> local_theory -> ctr_sugar * local_theory val free_constructors_cmd: ctr_sugar_kind -> ((((Proof.context -> Plugin_Name.filter) * bool) * binding) * ((binding * string) * binding list) list) * string list -> Proof.context -> Proof.state val default_ctr_options: ctr_options val default_ctr_options_cmd: ctr_options_cmd val parse_bound_term: (binding * string) parser val parse_ctr_options: ctr_options_cmd parser val parse_ctr_spec: 'c parser -> 'a parser -> ('c, 'a) ctr_spec parser val parse_sel_default_eqs: string list parser end; structure Ctr_Sugar : CTR_SUGAR = struct open Ctr_Sugar_Util open Ctr_Sugar_Tactics open Ctr_Sugar_Code datatype ctr_sugar_kind = Datatype | Codatatype | Record | Unknown; type ctr_sugar = {kind: ctr_sugar_kind, T: typ, ctrs: term list, casex: term, discs: term list, selss: term list list, exhaust: thm, nchotomy: thm, injects: thm list, distincts: thm list, case_thms: thm list, case_cong: thm, case_cong_weak: thm, case_distribs: thm list, split: thm, split_asm: thm, disc_defs: thm list, disc_thmss: thm list list, discIs: thm list, disc_eq_cases: thm list, sel_defs: thm list, sel_thmss: thm list list, distinct_discsss: thm list list list, exhaust_discs: thm list, exhaust_sels: thm list, collapses: thm list, expands: thm list, split_sels: thm list, split_sel_asms: thm list, case_eq_ifs: thm list}; fun morph_ctr_sugar phi ({kind, T, ctrs, casex, discs, selss, exhaust, nchotomy, injects, distincts, case_thms, case_cong, case_cong_weak, case_distribs, split, split_asm, disc_defs, disc_thmss, discIs, disc_eq_cases, sel_defs, sel_thmss, distinct_discsss, exhaust_discs, exhaust_sels, collapses, expands, split_sels, split_sel_asms, case_eq_ifs} : ctr_sugar) = {kind = kind, T = Morphism.typ phi T, ctrs = map (Morphism.term phi) ctrs, casex = Morphism.term phi casex, discs = map (Morphism.term phi) discs, selss = map (map (Morphism.term phi)) selss, exhaust = Morphism.thm phi exhaust, nchotomy = Morphism.thm phi nchotomy, injects = map (Morphism.thm phi) injects, distincts = map (Morphism.thm phi) distincts, case_thms = map (Morphism.thm phi) case_thms, case_cong = Morphism.thm phi case_cong, case_cong_weak = Morphism.thm phi case_cong_weak, case_distribs = map (Morphism.thm phi) case_distribs, split = Morphism.thm phi split, split_asm = Morphism.thm phi split_asm, disc_defs = map (Morphism.thm phi) disc_defs, disc_thmss = map (map (Morphism.thm phi)) disc_thmss, discIs = map (Morphism.thm phi) discIs, disc_eq_cases = map (Morphism.thm phi) disc_eq_cases, sel_defs = map (Morphism.thm phi) sel_defs, sel_thmss = map (map (Morphism.thm phi)) sel_thmss, distinct_discsss = map (map (map (Morphism.thm phi))) distinct_discsss, exhaust_discs = map (Morphism.thm phi) exhaust_discs, exhaust_sels = map (Morphism.thm phi) exhaust_sels, collapses = map (Morphism.thm phi) collapses, expands = map (Morphism.thm phi) expands, split_sels = map (Morphism.thm phi) split_sels, split_sel_asms = map (Morphism.thm phi) split_sel_asms, case_eq_ifs = map (Morphism.thm phi) case_eq_ifs}; val transfer_ctr_sugar = morph_ctr_sugar o Morphism.transfer_morphism; structure Data = Generic_Data ( type T = ctr_sugar Symtab.table; val empty = Symtab.empty; val extend = I; fun merge data : T = Symtab.merge (K true) data; ); fun ctr_sugar_of_generic context = Option.map (transfer_ctr_sugar (Context.theory_of context)) o Symtab.lookup (Data.get context); fun ctr_sugars_of_generic context = Symtab.fold (cons o transfer_ctr_sugar (Context.theory_of context) o snd) (Data.get context) []; fun ctr_sugar_of_case_generic context s = find_first (fn {casex = Const (s', _), ...} => s' = s | _ => false) (ctr_sugars_of_generic context); val ctr_sugar_of = ctr_sugar_of_generic o Context.Proof; val ctr_sugar_of_global = ctr_sugar_of_generic o Context.Theory; val ctr_sugars_of = ctr_sugars_of_generic o Context.Proof; val ctr_sugars_of_global = ctr_sugars_of_generic o Context.Theory; val ctr_sugar_of_case = ctr_sugar_of_case_generic o Context.Proof; val ctr_sugar_of_case_global = ctr_sugar_of_case_generic o Context.Theory; structure Ctr_Sugar_Plugin = Plugin(type T = ctr_sugar); fun ctr_sugar_interpretation name f = Ctr_Sugar_Plugin.interpretation name (fn ctr_sugar => fn lthy => f (transfer_ctr_sugar (Proof_Context.theory_of lthy) ctr_sugar) lthy); val interpret_ctr_sugar = Ctr_Sugar_Plugin.data; fun register_ctr_sugar_raw (ctr_sugar as {T = Type (s, _), ...}) = Local_Theory.declaration {syntax = false, pervasive = true} (fn phi => Data.map (Symtab.update (s, morph_ctr_sugar phi ctr_sugar))); fun register_ctr_sugar plugins ctr_sugar = register_ctr_sugar_raw ctr_sugar #> interpret_ctr_sugar plugins ctr_sugar; fun default_register_ctr_sugar_global plugins (ctr_sugar as {T = Type (s, _), ...}) thy = let val tab = Data.get (Context.Theory thy) in if Symtab.defined tab s then thy else thy |> Context.theory_map (Data.put (Symtab.update_new (s, ctr_sugar) tab)) |> Named_Target.theory_map (Ctr_Sugar_Plugin.data plugins ctr_sugar) end; val is_prefix = "is_"; val un_prefix = "un_"; val not_prefix = "not_"; fun mk_unN 1 1 suf = un_prefix ^ suf | mk_unN _ l suf = un_prefix ^ suf ^ string_of_int l; val caseN = "case"; val case_congN = "case_cong"; val case_eq_ifN = "case_eq_if"; val collapseN = "collapse"; val discN = "disc"; val disc_eq_caseN = "disc_eq_case"; val discIN = "discI"; val distinctN = "distinct"; val distinct_discN = "distinct_disc"; val exhaustN = "exhaust"; val exhaust_discN = "exhaust_disc"; val expandN = "expand"; val injectN = "inject"; val nchotomyN = "nchotomy"; val selN = "sel"; val exhaust_selN = "exhaust_sel"; val splitN = "split"; val split_asmN = "split_asm"; val split_selN = "split_sel"; val split_sel_asmN = "split_sel_asm"; val splitsN = "splits"; val split_selsN = "split_sels"; val case_cong_weak_thmsN = "case_cong_weak"; val case_distribN = "case_distrib"; val cong_attrs = @{attributes [cong]}; val dest_attrs = @{attributes [dest]}; val safe_elim_attrs = @{attributes [elim!]}; val iff_attrs = @{attributes [iff]}; val inductsimp_attrs = @{attributes [induct_simp]}; val nitpicksimp_attrs = @{attributes [nitpick_simp]}; val simp_attrs = @{attributes [simp]}; fun unflat_lookup eq xs ys = map (fn xs' => permute_like_unique eq xs xs' ys); fun mk_half_pairss' _ ([], []) = [] | mk_half_pairss' indent (x :: xs, _ :: ys) = indent @ fold_rev (cons o single o pair x) ys (mk_half_pairss' ([] :: indent) (xs, ys)); fun mk_half_pairss p = mk_half_pairss' [[]] p; fun join_halves n half_xss other_half_xss = (splice (flat half_xss) (flat other_half_xss), map2 (map2 append) (Library.chop_groups n half_xss) (transpose (Library.chop_groups n other_half_xss))); fun mk_undefined T = Const (\<^const_name>\undefined\, T); fun mk_ctr Ts t = let val Type (_, Ts0) = body_type (fastype_of t) in subst_nonatomic_types (Ts0 ~~ Ts) t end; fun mk_case Ts T t = let val (Type (_, Ts0), body) = strip_type (fastype_of t) |>> List.last in subst_nonatomic_types ((body, T) :: (Ts0 ~~ Ts)) t end; fun mk_disc_or_sel Ts t = subst_nonatomic_types (snd (Term.dest_Type (domain_type (fastype_of t))) ~~ Ts) t; val name_of_ctr = name_of_const "constructor" body_type; fun name_of_disc t = (case head_of t of Abs (_, _, \<^const>\Not\ $ (t' $ Bound 0)) => Long_Name.map_base_name (prefix not_prefix) (name_of_disc t') | Abs (_, _, Const (\<^const_name>\HOL.eq\, _) $ Bound 0 $ t') => Long_Name.map_base_name (prefix is_prefix) (name_of_disc t') | Abs (_, _, \<^const>\Not\ $ (Const (\<^const_name>\HOL.eq\, _) $ Bound 0 $ t')) => Long_Name.map_base_name (prefix (not_prefix ^ is_prefix)) (name_of_disc t') | t' => name_of_const "discriminator" (perhaps (try domain_type)) t'); val base_name_of_ctr = Long_Name.base_name o name_of_ctr; fun dest_ctr ctxt s t = let val (f, args) = Term.strip_comb t in (case ctr_sugar_of ctxt s of SOME {ctrs, ...} => (case find_first (can (fo_match ctxt f)) ctrs of SOME f' => (f', args) | NONE => raise Fail "dest_ctr") | NONE => raise Fail "dest_ctr") end; fun dest_case ctxt s Ts t = (case Term.strip_comb t of (Const (c, _), args as _ :: _) => (case ctr_sugar_of ctxt s of SOME (ctr_sugar as {casex = Const (case_name, _), discs = discs0, selss = selss0, ...}) => if case_name = c then let val n = length discs0 in if n < length args then let val (branches, obj :: leftovers) = chop n args; val discs = map (mk_disc_or_sel Ts) discs0; val selss = map (map (mk_disc_or_sel Ts)) selss0; val conds = map (rapp obj) discs; val branch_argss = map (fn sels => map (rapp obj) sels @ leftovers) selss; val branches' = map2 (curry Term.betapplys) branches branch_argss; in SOME (ctr_sugar, conds, branches') end else NONE end else NONE | _ => NONE) | _ => NONE); fun const_or_free_name (Const (s, _)) = Long_Name.base_name s | const_or_free_name (Free (s, _)) = s | const_or_free_name t = raise TERM ("const_or_free_name", [t]) fun extract_sel_default ctxt t = let fun malformed () = error ("Malformed selector default value equation: " ^ Syntax.string_of_term ctxt t); val ((sel, (ctr, vars)), rhs) = fst (Term.replace_dummy_patterns (Syntax.check_term ctxt t) 0) |> HOLogic.dest_eq |>> (Term.dest_comb #>> const_or_free_name ##> (Term.strip_comb #>> (Term.dest_Const #> fst))) handle TERM _ => malformed (); in if forall (is_Free orf is_Var) vars andalso not (has_duplicates (op aconv) vars) then ((ctr, sel), fold_rev Term.lambda vars rhs) else malformed () end; (* Ideally, we would enrich the context with constants rather than free variables. *) fun fake_local_theory_for_sel_defaults sel_bTs = Proof_Context.allow_dummies #> Proof_Context.add_fixes (map (fn (b, T) => (b, SOME T, NoSyn)) sel_bTs) #> snd; type ('c, 'a) ctr_spec = (binding * 'c) * 'a list; fun disc_of_ctr_spec ((disc, _), _) = disc; fun ctr_of_ctr_spec ((_, ctr), _) = ctr; fun args_of_ctr_spec (_, args) = args; val code_plugin = Plugin_Name.declare_setup \<^binding>\code\; fun prepare_free_constructors kind prep_plugins prep_term ((((raw_plugins, discs_sels), raw_case_binding), ctr_specs), sel_default_eqs) no_defs_lthy = let val plugins = prep_plugins no_defs_lthy raw_plugins; (* TODO: sanity checks on arguments *) val raw_ctrs = map ctr_of_ctr_spec ctr_specs; val raw_disc_bindings = map disc_of_ctr_spec ctr_specs; val raw_sel_bindingss = map args_of_ctr_spec ctr_specs; val n = length raw_ctrs; val ks = 1 upto n; val _ = n > 0 orelse error "No constructors specified"; val ctrs0 = map (prep_term no_defs_lthy) raw_ctrs; val (fcT_name, As0) = (case body_type (fastype_of (hd ctrs0)) of Type T' => T' | _ => error "Expected type constructor in body type of constructor"); val _ = forall ((fn Type (T_name, _) => T_name = fcT_name | _ => false) o body_type o fastype_of) (tl ctrs0) orelse error "Constructors not constructing same type"; val fc_b_name = Long_Name.base_name fcT_name; val fc_b = Binding.name fc_b_name; fun qualify mandatory = Binding.qualify mandatory fc_b_name; val (unsorted_As, [B, C]) = no_defs_lthy |> variant_tfrees (map (fst o dest_TFree_or_TVar) As0) ||> fst o mk_TFrees 2; val As = map2 (resort_tfree_or_tvar o snd o dest_TFree_or_TVar) As0 unsorted_As; val fcT = Type (fcT_name, As); val ctrs = map (mk_ctr As) ctrs0; val ctr_Tss = map (binder_types o fastype_of) ctrs; val ms = map length ctr_Tss; fun can_definitely_rely_on_disc k = not (Binding.is_empty (nth raw_disc_bindings (k - 1))) orelse nth ms (k - 1) = 0; fun can_rely_on_disc k = can_definitely_rely_on_disc k orelse (k = 1 andalso not (can_definitely_rely_on_disc 2)); fun should_omit_disc_binding k = n = 1 orelse (n = 2 andalso can_rely_on_disc (3 - k)); val equal_binding = \<^binding>\=\; fun is_disc_binding_valid b = not (Binding.is_empty b orelse Binding.eq_name (b, equal_binding)); val standard_disc_binding = Binding.name o prefix is_prefix o base_name_of_ctr; val disc_bindings = raw_disc_bindings |> @{map 4} (fn k => fn m => fn ctr => fn disc => qualify false (if Binding.is_empty disc then if m = 0 then equal_binding else if should_omit_disc_binding k then disc else standard_disc_binding ctr else if Binding.eq_name (disc, standard_binding) then standard_disc_binding ctr else disc)) ks ms ctrs0; fun standard_sel_binding m l = Binding.name o mk_unN m l o base_name_of_ctr; val sel_bindingss = @{map 3} (fn ctr => fn m => map2 (fn l => fn sel => qualify false (if Binding.is_empty sel orelse Binding.eq_name (sel, standard_binding) then standard_sel_binding m l ctr else sel)) (1 upto m) o pad_list Binding.empty m) ctrs0 ms raw_sel_bindingss; val add_bindings = Variable.add_fixes (distinct (op =) (filter Symbol_Pos.is_identifier (map Binding.name_of (disc_bindings @ flat sel_bindingss)))) #> snd; val case_Ts = map (fn Ts => Ts ---> B) ctr_Tss; val (((((((((u, exh_y), xss), yss), fs), gs), w), (p, p'))), _) = no_defs_lthy |> add_bindings |> yield_singleton (mk_Frees fc_b_name) fcT ||>> yield_singleton (mk_Frees "y") fcT (* for compatibility with "datatype_realizer.ML" *) ||>> mk_Freess "x" ctr_Tss ||>> mk_Freess "y" ctr_Tss ||>> mk_Frees "f" case_Ts ||>> mk_Frees "g" case_Ts ||>> yield_singleton (mk_Frees "z") B ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "P") HOLogic.boolT; val q = Free (fst p', mk_pred1T B); val xctrs = map2 (curry Term.list_comb) ctrs xss; val yctrs = map2 (curry Term.list_comb) ctrs yss; val xfs = map2 (curry Term.list_comb) fs xss; val xgs = map2 (curry Term.list_comb) gs xss; (* TODO: Eta-expension is for compatibility with the old datatype package (but it also provides nicer names). Consider removing. *) val eta_fs = map2 (fold_rev Term.lambda) xss xfs; val eta_gs = map2 (fold_rev Term.lambda) xss xgs; val case_binding = qualify false (if Binding.is_empty raw_case_binding orelse Binding.eq_name (raw_case_binding, standard_binding) then Binding.prefix_name (caseN ^ "_") fc_b else raw_case_binding); fun mk_case_disj xctr xf xs = list_exists_free xs (HOLogic.mk_conj (HOLogic.mk_eq (u, xctr), HOLogic.mk_eq (w, xf))); val case_rhs = fold_rev (fold_rev Term.lambda) [fs, [u]] (Const (\<^const_name>\The\, (B --> HOLogic.boolT) --> B) $ Term.lambda w (Library.foldr1 HOLogic.mk_disj (@{map 3} mk_case_disj xctrs xfs xss))); val ((raw_case, (_, raw_case_def)), (lthy, lthy_old)) = no_defs_lthy |> Local_Theory.open_target |> snd |> Local_Theory.define ((case_binding, NoSyn), ((Binding.concealed (Thm.def_binding case_binding), []), case_rhs)) ||> `Local_Theory.close_target; val phi = Proof_Context.export_morphism lthy_old lthy; val case_def = Morphism.thm phi raw_case_def; val case0 = Morphism.term phi raw_case; val casex = mk_case As B case0; val casexC = mk_case As C case0; val casexBool = mk_case As HOLogic.boolT case0; fun mk_uu_eq () = HOLogic.mk_eq (u, u); val exist_xs_u_eq_ctrs = map2 (fn xctr => fn xs => list_exists_free xs (HOLogic.mk_eq (u, xctr))) xctrs xss; val unique_disc_no_def = TrueI; (*arbitrary marker*) val alternate_disc_no_def = FalseE; (*arbitrary marker*) fun alternate_disc_lhs get_udisc k = HOLogic.mk_not (let val b = nth disc_bindings (k - 1) in if is_disc_binding_valid b then get_udisc b (k - 1) else nth exist_xs_u_eq_ctrs (k - 1) end); val no_discs_sels = not discs_sels andalso forall (forall Binding.is_empty) (raw_disc_bindings :: raw_sel_bindingss) andalso null sel_default_eqs; val (all_sels_distinct, discs, selss, disc_defs, sel_defs, sel_defss, lthy) = if no_discs_sels then (true, [], [], [], [], [], lthy) else let val all_sel_bindings = flat sel_bindingss; val num_all_sel_bindings = length all_sel_bindings; val uniq_sel_bindings = distinct Binding.eq_name all_sel_bindings; val all_sels_distinct = (length uniq_sel_bindings = num_all_sel_bindings); val sel_binding_index = if all_sels_distinct then 1 upto num_all_sel_bindings else map (fn b => find_index (curry Binding.eq_name b) uniq_sel_bindings) all_sel_bindings; val all_proto_sels = flat (@{map 3} (fn k => fn xs => map (pair k o pair xs)) ks xss xss); val sel_infos = AList.group (op =) (sel_binding_index ~~ all_proto_sels) |> sort (int_ord o apply2 fst) |> map snd |> curry (op ~~) uniq_sel_bindings; val sel_bindings = map fst sel_infos; val sel_defaults = if null sel_default_eqs then [] else let val sel_Ts = map (curry (op -->) fcT o fastype_of o snd o snd o hd o snd) sel_infos; val fake_lthy = fake_local_theory_for_sel_defaults (sel_bindings ~~ sel_Ts) no_defs_lthy; in map (extract_sel_default fake_lthy o prep_term fake_lthy) sel_default_eqs end; fun disc_free b = Free (Binding.name_of b, mk_pred1T fcT); fun disc_spec b exist_xs_u_eq_ctr = mk_Trueprop_eq (disc_free b $ u, exist_xs_u_eq_ctr); fun alternate_disc k = Term.lambda u (alternate_disc_lhs (K o rapp u o disc_free) (3 - k)); fun mk_sel_case_args b proto_sels T = @{map 3} (fn Const (c, _) => fn Ts => fn k => (case AList.lookup (op =) proto_sels k of NONE => (case filter (curry (op =) (c, Binding.name_of b) o fst) sel_defaults of [] => fold_rev (Term.lambda o curry Free Name.uu) Ts (mk_undefined T) | [(_, t)] => t | _ => error "Multiple default values for selector/constructor pair") | SOME (xs, x) => fold_rev Term.lambda xs x)) ctrs ctr_Tss ks; fun sel_spec b proto_sels = let val _ = (case duplicates (op =) (map fst proto_sels) of k :: _ => error ("Duplicate selector name " ^ quote (Binding.name_of b) ^ " for constructor " ^ quote (Syntax.string_of_term lthy (nth ctrs (k - 1)))) | [] => ()) val T = (case distinct (op =) (map (fastype_of o snd o snd) proto_sels) of [T] => T | T :: T' :: _ => error ("Inconsistent range type for selector " ^ quote (Binding.name_of b) ^ ": " ^ quote (Syntax.string_of_typ lthy T) ^ " vs. " ^ quote (Syntax.string_of_typ lthy T'))); in mk_Trueprop_eq (Free (Binding.name_of b, fcT --> T) $ u, Term.list_comb (mk_case As T case0, mk_sel_case_args b proto_sels T) $ u) end; fun unflat_selss xs = unflat_lookup Binding.eq_name sel_bindings xs sel_bindingss; val (((raw_discs, raw_disc_defs), (raw_sels, raw_sel_defs)), (lthy', lthy)) = lthy |> Local_Theory.open_target |> snd |> apfst split_list o @{fold_map 3} (fn k => fn exist_xs_u_eq_ctr => fn b => if Binding.is_empty b then if n = 1 then pair (Term.lambda u (mk_uu_eq ()), unique_disc_no_def) else pair (alternate_disc k, alternate_disc_no_def) else if Binding.eq_name (b, equal_binding) then pair (Term.lambda u exist_xs_u_eq_ctr, refl) else Specification.definition (SOME (b, NONE, NoSyn)) [] [] ((Thm.def_binding b, []), disc_spec b exist_xs_u_eq_ctr) #>> apsnd snd) ks exist_xs_u_eq_ctrs disc_bindings ||>> apfst split_list o fold_map (fn (b, proto_sels) => Specification.definition (SOME (b, NONE, NoSyn)) [] [] ((Thm.def_binding b, []), sel_spec b proto_sels) #>> apsnd snd) sel_infos ||> `Local_Theory.close_target; val phi = Proof_Context.export_morphism lthy lthy'; val disc_defs = map (Morphism.thm phi) raw_disc_defs; val sel_defs = map (Morphism.thm phi) raw_sel_defs; val sel_defss = unflat_selss sel_defs; val discs0 = map (Morphism.term phi) raw_discs; val selss0 = unflat_selss (map (Morphism.term phi) raw_sels); val discs = map (mk_disc_or_sel As) discs0; val selss = map (map (mk_disc_or_sel As)) selss0; in (all_sels_distinct, discs, selss, disc_defs, sel_defs, sel_defss, lthy') end; fun mk_imp_p Qs = Logic.list_implies (Qs, HOLogic.mk_Trueprop p); val exhaust_goal = let fun mk_prem xctr xs = fold_rev Logic.all xs (mk_imp_p [mk_Trueprop_eq (exh_y, xctr)]) in fold_rev Logic.all [p, exh_y] (mk_imp_p (map2 mk_prem xctrs xss)) end; val inject_goalss = let fun mk_goal _ _ [] [] = [] | mk_goal xctr yctr xs ys = [fold_rev Logic.all (xs @ ys) (mk_Trueprop_eq (HOLogic.mk_eq (xctr, yctr), Library.foldr1 HOLogic.mk_conj (map2 (curry HOLogic.mk_eq) xs ys)))]; in @{map 4} mk_goal xctrs yctrs xss yss end; val half_distinct_goalss = let fun mk_goal ((xs, xc), (xs', xc')) = fold_rev Logic.all (xs @ xs') (HOLogic.mk_Trueprop (HOLogic.mk_not (HOLogic.mk_eq (xc, xc')))); in map (map mk_goal) (mk_half_pairss (`I (xss ~~ xctrs))) end; val goalss = [exhaust_goal] :: inject_goalss @ half_distinct_goalss; fun after_qed ([exhaust_thm] :: thmss) lthy = let val ((((((((u, u'), (xss, xss')), fs), gs), h), v), p), _) = lthy |> add_bindings |> yield_singleton (apfst (op ~~) oo mk_Frees' fc_b_name) fcT ||>> mk_Freess' "x" ctr_Tss ||>> mk_Frees "f" case_Ts ||>> mk_Frees "g" case_Ts ||>> yield_singleton (mk_Frees "h") (B --> C) ||>> yield_singleton (mk_Frees (fc_b_name ^ "'")) fcT ||>> yield_singleton (mk_Frees "P") HOLogic.boolT; val xfs = map2 (curry Term.list_comb) fs xss; val xgs = map2 (curry Term.list_comb) gs xss; val fcase = Term.list_comb (casex, fs); val ufcase = fcase $ u; val vfcase = fcase $ v; val eta_fcase = Term.list_comb (casex, eta_fs); val eta_gcase = Term.list_comb (casex, eta_gs); val eta_ufcase = eta_fcase $ u; val eta_vgcase = eta_gcase $ v; fun mk_uu_eq () = HOLogic.mk_eq (u, u); val uv_eq = mk_Trueprop_eq (u, v); val ((inject_thms, inject_thmss), half_distinct_thmss) = chop n thmss |>> `flat; val rho_As = map (fn (T, U) => (dest_TVar T, Thm.ctyp_of lthy U)) (map Logic.varifyT_global As ~~ As); fun inst_thm t thm = Thm.instantiate' [] [SOME (Thm.cterm_of lthy t)] (Thm.instantiate (rho_As, []) (Drule.zero_var_indexes thm)); val uexhaust_thm = inst_thm u exhaust_thm; val exhaust_cases = map base_name_of_ctr ctrs; val other_half_distinct_thmss = map (map (fn thm => thm RS not_sym)) half_distinct_thmss; val (distinct_thms, (distinct_thmsss', distinct_thmsss)) = join_halves n half_distinct_thmss other_half_distinct_thmss ||> `transpose; val nchotomy_thm = let val goal = HOLogic.mk_Trueprop (HOLogic.mk_all (fst u', snd u', Library.foldr1 HOLogic.mk_disj exist_xs_u_eq_ctrs)); in Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, prems = _} => mk_nchotomy_tac ctxt n exhaust_thm) |> Thm.close_derivation \<^here> end; val case_thms = let val goals = @{map 3} (fn xctr => fn xf => fn xs => fold_rev Logic.all (fs @ xs) (mk_Trueprop_eq (fcase $ xctr, xf))) xctrs xfs xss; in @{map 4} (fn k => fn goal => fn injects => fn distinctss => Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, ...} => mk_case_tac ctxt n k case_def injects distinctss) |> Thm.close_derivation \<^here>) ks goals inject_thmss distinct_thmsss end; val (case_cong_thm, case_cong_weak_thm) = let fun mk_prem xctr xs xf xg = fold_rev Logic.all xs (Logic.mk_implies (mk_Trueprop_eq (v, xctr), mk_Trueprop_eq (xf, xg))); val goal = Logic.list_implies (uv_eq :: @{map 4} mk_prem xctrs xss xfs xgs, mk_Trueprop_eq (eta_ufcase, eta_vgcase)); val weak_goal = Logic.mk_implies (uv_eq, mk_Trueprop_eq (ufcase, vfcase)); val vars = Variable.add_free_names lthy goal []; val weak_vars = Variable.add_free_names lthy weak_goal []; in (Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, prems = _} => mk_case_cong_tac ctxt uexhaust_thm case_thms), Goal.prove_sorry lthy weak_vars [] weak_goal (fn {context = ctxt, prems = _} => etac ctxt arg_cong 1)) |> apply2 (Thm.close_derivation \<^here>) end; val split_lhs = q $ ufcase; fun mk_split_conjunct xctr xs f_xs = list_all_free xs (HOLogic.mk_imp (HOLogic.mk_eq (u, xctr), q $ f_xs)); fun mk_split_disjunct xctr xs f_xs = list_exists_free xs (HOLogic.mk_conj (HOLogic.mk_eq (u, xctr), HOLogic.mk_not (q $ f_xs))); fun mk_split_goal xctrs xss xfs = mk_Trueprop_eq (split_lhs, Library.foldr1 HOLogic.mk_conj (@{map 3} mk_split_conjunct xctrs xss xfs)); fun mk_split_asm_goal xctrs xss xfs = mk_Trueprop_eq (split_lhs, HOLogic.mk_not (Library.foldr1 HOLogic.mk_disj (@{map 3} mk_split_disjunct xctrs xss xfs))); fun prove_split selss goal = Variable.add_free_names lthy goal [] |> (fn vars => Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, prems = _} => mk_split_tac ctxt uexhaust_thm case_thms selss inject_thmss distinct_thmsss)) |> Thm.close_derivation \<^here>; fun prove_split_asm asm_goal split_thm = Variable.add_free_names lthy asm_goal [] |> (fn vars => Goal.prove_sorry lthy vars [] asm_goal (fn {context = ctxt, ...} => mk_split_asm_tac ctxt split_thm)) |> Thm.close_derivation \<^here>; val (split_thm, split_asm_thm) = let val goal = mk_split_goal xctrs xss xfs; val asm_goal = mk_split_asm_goal xctrs xss xfs; val thm = prove_split (replicate n []) goal; val asm_thm = prove_split_asm asm_goal thm; in (thm, asm_thm) end; val (sel_defs, all_sel_thms, sel_thmss, nontriv_disc_defs, disc_thmss, nontriv_disc_thmss, discI_thms, nontriv_discI_thms, distinct_disc_thms, distinct_disc_thmsss, exhaust_disc_thms, exhaust_sel_thms, all_collapse_thms, safe_collapse_thms, expand_thms, split_sel_thms, split_sel_asm_thms, case_eq_if_thms, disc_eq_case_thms) = if no_discs_sels then ([], [], [], [], [], [], [], [], [], [], [], [], [], [], [], [], [], [], []) else let val udiscs = map (rapp u) discs; val uselss = map (map (rapp u)) selss; val usel_ctrs = map2 (curry Term.list_comb) ctrs uselss; val usel_fs = map2 (curry Term.list_comb) fs uselss; val vdiscs = map (rapp v) discs; val vselss = map (map (rapp v)) selss; fun make_sel_thm xs' case_thm sel_def = zero_var_indexes (Variable.gen_all lthy (Drule.rename_bvars' (map (SOME o fst) xs') (Drule.forall_intr_vars (case_thm RS (sel_def RS trans))))); val sel_thmss = @{map 3} (map oo make_sel_thm) xss' case_thms sel_defss; fun has_undefined_rhs thm = (case snd (HOLogic.dest_eq (HOLogic.dest_Trueprop (Thm.prop_of thm))) of Const (\<^const_name>\undefined\, _) => true | _ => false); val all_sel_thms = (if all_sels_distinct andalso null sel_default_eqs then flat sel_thmss else map_product (fn s => fn (xs', c) => make_sel_thm xs' c s) sel_defs (xss' ~~ case_thms)) |> filter_out has_undefined_rhs; fun mk_unique_disc_def () = let val m = the_single ms; val goal = mk_Trueprop_eq (mk_uu_eq (), the_single exist_xs_u_eq_ctrs); val vars = Variable.add_free_names lthy goal []; in Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, prems = _} => mk_unique_disc_def_tac ctxt m uexhaust_thm) |> Thm.close_derivation \<^here> end; fun mk_alternate_disc_def k = let val goal = mk_Trueprop_eq (alternate_disc_lhs (K (nth udiscs)) (3 - k), nth exist_xs_u_eq_ctrs (k - 1)); val vars = Variable.add_free_names lthy goal []; in Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, ...} => mk_alternate_disc_def_tac ctxt k (nth disc_defs (2 - k)) (nth distinct_thms (2 - k)) uexhaust_thm) |> Thm.close_derivation \<^here> end; val has_alternate_disc_def = exists (fn def => Thm.eq_thm_prop (def, alternate_disc_no_def)) disc_defs; val nontriv_disc_defs = disc_defs |> filter_out (member Thm.eq_thm_prop [unique_disc_no_def, alternate_disc_no_def, refl]); val disc_defs' = map2 (fn k => fn def => if Thm.eq_thm_prop (def, unique_disc_no_def) then mk_unique_disc_def () else if Thm.eq_thm_prop (def, alternate_disc_no_def) then mk_alternate_disc_def k else def) ks disc_defs; val discD_thms = map (fn def => def RS iffD1) disc_defs'; val discI_thms = map2 (fn m => fn def => funpow m (fn thm => exI RS thm) (def RS iffD2)) ms disc_defs'; val not_discI_thms = map2 (fn m => fn def => funpow m (fn thm => allI RS thm) (unfold_thms lthy @{thms not_ex} (def RS @{thm ssubst[of _ _ Not]}))) ms disc_defs'; val (disc_thmss', disc_thmss) = let fun mk_thm discI _ [] = refl RS discI | mk_thm _ not_discI [distinct] = distinct RS not_discI; fun mk_thms discI not_discI distinctss = map (mk_thm discI not_discI) distinctss; in @{map 3} mk_thms discI_thms not_discI_thms distinct_thmsss' |> `transpose end; val nontriv_disc_thmss = map2 (fn b => if is_disc_binding_valid b then I else K []) disc_bindings disc_thmss; fun is_discI_triv b = (n = 1 andalso Binding.is_empty b) orelse Binding.eq_name (b, equal_binding); val nontriv_discI_thms = flat (map2 (fn b => if is_discI_triv b then K [] else single) disc_bindings discI_thms); val (distinct_disc_thms, (distinct_disc_thmsss', distinct_disc_thmsss)) = let fun mk_goal [] = [] | mk_goal [((_, udisc), (_, udisc'))] = [Logic.all u (Logic.mk_implies (HOLogic.mk_Trueprop udisc, HOLogic.mk_Trueprop (HOLogic.mk_not udisc')))]; fun prove tac goal = Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, prems = _} => tac ctxt) |> Thm.close_derivation \<^here>; val half_pairss = mk_half_pairss (`I (ms ~~ discD_thms ~~ udiscs)); val half_goalss = map mk_goal half_pairss; val half_thmss = @{map 3} (fn [] => K (K []) | [goal] => fn [(((m, discD), _), _)] => fn disc_thm => [prove (fn ctxt => mk_half_distinct_disc_tac ctxt m discD disc_thm) goal]) half_goalss half_pairss (flat disc_thmss'); val other_half_goalss = map (mk_goal o map swap) half_pairss; val other_half_thmss = map2 (map2 (fn thm => prove (fn ctxt => mk_other_half_distinct_disc_tac ctxt thm))) half_thmss other_half_goalss; in join_halves n half_thmss other_half_thmss ||> `transpose |>> has_alternate_disc_def ? K [] end; val exhaust_disc_thm = let fun mk_prem udisc = mk_imp_p [HOLogic.mk_Trueprop udisc]; val goal = fold_rev Logic.all [p, u] (mk_imp_p (map mk_prem udiscs)); in Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, prems = _} => mk_exhaust_disc_tac ctxt n exhaust_thm discI_thms) |> Thm.close_derivation \<^here> end; val (safe_collapse_thms, all_collapse_thms) = let fun mk_goal m udisc usel_ctr = let val prem = HOLogic.mk_Trueprop udisc; val concl = mk_Trueprop_eq ((usel_ctr, u) |> m = 0 ? swap); in (prem aconv concl, Logic.all u (Logic.mk_implies (prem, concl))) end; val (trivs, goals) = @{map 3} mk_goal ms udiscs usel_ctrs |> split_list; val thms = @{map 5} (fn m => fn discD => fn sel_thms => fn triv => fn goal => Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, ...} => mk_collapse_tac ctxt m discD sel_thms ORELSE HEADGOAL (assume_tac ctxt)) |> Thm.close_derivation \<^here> |> not triv ? perhaps (try (fn thm => refl RS thm))) ms discD_thms sel_thmss trivs goals; in (map_filter (fn (true, _) => NONE | (false, thm) => SOME thm) (trivs ~~ thms), thms) end; val swapped_all_collapse_thms = map2 (fn m => fn thm => if m = 0 then thm else thm RS sym) ms all_collapse_thms; val exhaust_sel_thm = let fun mk_prem usel_ctr = mk_imp_p [mk_Trueprop_eq (u, usel_ctr)]; val goal = fold_rev Logic.all [p, u] (mk_imp_p (map mk_prem usel_ctrs)); in Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, prems = _} => mk_exhaust_sel_tac ctxt n exhaust_disc_thm swapped_all_collapse_thms) |> Thm.close_derivation \<^here> end; val expand_thm = let fun mk_prems k udisc usels vdisc vsels = (if k = n then [] else [mk_Trueprop_eq (udisc, vdisc)]) @ (if null usels then [] else [Logic.list_implies (if n = 1 then [] else map HOLogic.mk_Trueprop [udisc, vdisc], HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj (map2 (curry HOLogic.mk_eq) usels vsels)))]); val goal = Library.foldr Logic.list_implies (@{map 5} mk_prems ks udiscs uselss vdiscs vselss, uv_eq); val uncollapse_thms = map2 (fn thm => fn [] => thm | _ => thm RS sym) all_collapse_thms uselss; val vars = Variable.add_free_names lthy goal []; in Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, prems = _} => mk_expand_tac ctxt n ms (inst_thm u exhaust_disc_thm) (inst_thm v exhaust_disc_thm) uncollapse_thms distinct_disc_thmsss distinct_disc_thmsss') |> Thm.close_derivation \<^here> end; val (split_sel_thm, split_sel_asm_thm) = let val zss = map (K []) xss; val goal = mk_split_goal usel_ctrs zss usel_fs; val asm_goal = mk_split_asm_goal usel_ctrs zss usel_fs; val thm = prove_split sel_thmss goal; val asm_thm = prove_split_asm asm_goal thm; in (thm, asm_thm) end; val case_eq_if_thm = let val goal = mk_Trueprop_eq (ufcase, mk_IfN B udiscs usel_fs); val vars = Variable.add_free_names lthy goal []; in Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, ...} => mk_case_eq_if_tac ctxt n uexhaust_thm case_thms disc_thmss' sel_thmss) |> Thm.close_derivation \<^here> end; val disc_eq_case_thms = let fun const_of_bool b = if b then \<^const>\True\ else \<^const>\False\; fun mk_case_args n = map_index (fn (k, argTs) => fold_rev Term.absdummy argTs (const_of_bool (n = k))) ctr_Tss; val goals = map_index (fn (n, udisc) => mk_Trueprop_eq (udisc, list_comb (casexBool, mk_case_args n) $ u)) udiscs; val goal = Logic.mk_conjunction_balanced goals; val vars = Variable.add_free_names lthy goal []; in Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, ...} => mk_disc_eq_case_tac ctxt (Thm.cterm_of ctxt u) exhaust_thm (flat nontriv_disc_thmss) distinct_thms case_thms) |> Thm.close_derivation \<^here> |> Conjunction.elim_balanced (length goals) end; in (sel_defs, all_sel_thms, sel_thmss, nontriv_disc_defs, disc_thmss, nontriv_disc_thmss, discI_thms, nontriv_discI_thms, distinct_disc_thms, distinct_disc_thmsss, [exhaust_disc_thm], [exhaust_sel_thm], all_collapse_thms, safe_collapse_thms, [expand_thm], [split_sel_thm], [split_sel_asm_thm], [case_eq_if_thm], disc_eq_case_thms) end; val case_distrib_thm = let val args = @{map 2} (fn f => fn argTs => let val (args, _) = mk_Frees "x" argTs lthy in fold_rev Term.lambda args (h $ list_comb (f, args)) end) fs ctr_Tss; val goal = mk_Trueprop_eq (h $ ufcase, list_comb (casexC, args) $ u); val vars = Variable.add_free_names lthy goal []; in Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, ...} => mk_case_distrib_tac ctxt (Thm.cterm_of ctxt u) exhaust_thm case_thms) |> Thm.close_derivation \<^here> end; val exhaust_case_names_attr = Attrib.internal (K (Rule_Cases.case_names exhaust_cases)); val cases_type_attr = Attrib.internal (K (Induct.cases_type fcT_name)); val nontriv_disc_eq_thmss = map (map (fn th => th RS @{thm eq_False[THEN iffD2]} handle THM _ => th RS @{thm eq_True[THEN iffD2]})) nontriv_disc_thmss; val anonymous_notes = [(map (fn th => th RS notE) distinct_thms, safe_elim_attrs), (flat nontriv_disc_eq_thmss, nitpicksimp_attrs)] |> map (fn (thms, attrs) => ((Binding.empty, attrs), [(thms, [])])); val notes = [(caseN, case_thms, nitpicksimp_attrs @ simp_attrs), (case_congN, [case_cong_thm], []), (case_cong_weak_thmsN, [case_cong_weak_thm], cong_attrs), (case_distribN, [case_distrib_thm], []), (case_eq_ifN, case_eq_if_thms, []), (collapseN, safe_collapse_thms, if ms = [0] then [] else simp_attrs), (discN, flat nontriv_disc_thmss, simp_attrs), (disc_eq_caseN, disc_eq_case_thms, []), (discIN, nontriv_discI_thms, []), (distinctN, distinct_thms, simp_attrs @ inductsimp_attrs), (distinct_discN, distinct_disc_thms, dest_attrs), (exhaustN, [exhaust_thm], [exhaust_case_names_attr, cases_type_attr]), (exhaust_discN, exhaust_disc_thms, [exhaust_case_names_attr]), (exhaust_selN, exhaust_sel_thms, [exhaust_case_names_attr]), (expandN, expand_thms, []), (injectN, inject_thms, iff_attrs @ inductsimp_attrs), (nchotomyN, [nchotomy_thm], []), (selN, all_sel_thms, nitpicksimp_attrs @ simp_attrs), (splitN, [split_thm], []), (split_asmN, [split_asm_thm], []), (split_selN, split_sel_thms, []), (split_sel_asmN, split_sel_asm_thms, []), (split_selsN, split_sel_thms @ split_sel_asm_thms, []), (splitsN, [split_thm, split_asm_thm], [])] |> filter_out (null o #2) |> map (fn (thmN, thms, attrs) => ((qualify true (Binding.name thmN), attrs), [(thms, [])])); val (noted, lthy') = lthy - |> Spec_Rules.add Spec_Rules.equational ([casex], case_thms) - |> fold (Spec_Rules.add Spec_Rules.equational) + |> Spec_Rules.add "" Spec_Rules.equational [casex] case_thms + |> fold (uncurry (Spec_Rules.add "" Spec_Rules.equational)) (AList.group (eq_list (op aconv)) (map (`(single o lhs_head_of)) all_sel_thms)) - |> fold (Spec_Rules.add Spec_Rules.equational) + |> fold (uncurry (Spec_Rules.add "" Spec_Rules.equational)) (filter_out (null o snd) (map single discs ~~ nontriv_disc_eq_thmss)) |> Local_Theory.declaration {syntax = false, pervasive = true} (fn phi => Case_Translation.register (Morphism.term phi casex) (map (Morphism.term phi) ctrs)) |> plugins code_plugin ? (Code.declare_default_eqns (map (rpair true) (flat nontriv_disc_eq_thmss @ case_thms @ all_sel_thms)) #> Local_Theory.declaration {syntax = false, pervasive = false} (fn phi => Context.mapping (add_ctr_code fcT_name (map (Morphism.typ phi) As) (map (dest_Const o Morphism.term phi) ctrs) (Morphism.fact phi inject_thms) (Morphism.fact phi distinct_thms) (Morphism.fact phi case_thms)) I)) |> Local_Theory.notes (anonymous_notes @ notes) (* for "datatype_realizer.ML": *) |>> name_noted_thms fcT_name exhaustN; val ctr_sugar = {kind = kind, T = fcT, ctrs = ctrs, casex = casex, discs = discs, selss = selss, exhaust = exhaust_thm, nchotomy = nchotomy_thm, injects = inject_thms, distincts = distinct_thms, case_thms = case_thms, case_cong = case_cong_thm, case_cong_weak = case_cong_weak_thm, case_distribs = [case_distrib_thm], split = split_thm, split_asm = split_asm_thm, disc_defs = nontriv_disc_defs, disc_thmss = disc_thmss, discIs = discI_thms, disc_eq_cases = disc_eq_case_thms, sel_defs = sel_defs, sel_thmss = sel_thmss, distinct_discsss = distinct_disc_thmsss, exhaust_discs = exhaust_disc_thms, exhaust_sels = exhaust_sel_thms, collapses = all_collapse_thms, expands = expand_thms, split_sels = split_sel_thms, split_sel_asms = split_sel_asm_thms, case_eq_ifs = case_eq_if_thms} |> morph_ctr_sugar (substitute_noted_thm noted); in (ctr_sugar, lthy' |> register_ctr_sugar plugins ctr_sugar) end; in (goalss, after_qed, lthy) end; fun free_constructors kind tacss = (fn (goalss, after_qed, lthy) => map2 (map2 (Thm.close_derivation \<^here> oo Goal.prove_sorry lthy [] [])) goalss tacss |> (fn thms => after_qed thms lthy)) oo prepare_free_constructors kind (K I) (K I); fun free_constructors_cmd kind = (fn (goalss, after_qed, lthy) => Proof.theorem NONE (snd oo after_qed) (map (map (rpair [])) goalss) lthy) oo prepare_free_constructors kind Plugin_Name.make_filter Syntax.read_term; val parse_bound_term = Parse.binding --| \<^keyword>\:\ -- Parse.term; type ctr_options = Plugin_Name.filter * bool; type ctr_options_cmd = (Proof.context -> Plugin_Name.filter) * bool; val default_ctr_options : ctr_options = (Plugin_Name.default_filter, false); val default_ctr_options_cmd : ctr_options_cmd = (K Plugin_Name.default_filter, false); val parse_ctr_options = Scan.optional (\<^keyword>\(\ |-- Parse.list1 (Plugin_Name.parse_filter >> (apfst o K) || Parse.reserved "discs_sels" >> (apsnd o K o K true)) --| \<^keyword>\)\ >> (fn fs => fold I fs default_ctr_options_cmd)) default_ctr_options_cmd; fun parse_ctr_spec parse_ctr parse_arg = parse_opt_binding_colon -- parse_ctr -- Scan.repeat parse_arg; val parse_ctr_specs = Parse.enum1 "|" (parse_ctr_spec Parse.term Parse.binding); val parse_sel_default_eqs = Scan.optional (\<^keyword>\where\ |-- Parse.enum1 "|" Parse.prop) []; val _ = Outer_Syntax.local_theory_to_proof \<^command_keyword>\free_constructors\ "register an existing freely generated type's constructors" (parse_ctr_options -- Parse.binding --| \<^keyword>\for\ -- parse_ctr_specs -- parse_sel_default_eqs >> free_constructors_cmd Unknown); end; diff --git a/src/HOL/Tools/Function/function.ML b/src/HOL/Tools/Function/function.ML --- a/src/HOL/Tools/Function/function.ML +++ b/src/HOL/Tools/Function/function.ML @@ -1,288 +1,288 @@ (* Title: HOL/Tools/Function/function.ML Author: Alexander Krauss, TU Muenchen Main entry points to the function package. *) signature FUNCTION = sig type info = Function_Common.info val add_function: (binding * typ option * mixfix) list -> Specification.multi_specs -> Function_Common.function_config -> (Proof.context -> tactic) -> local_theory -> info * local_theory val add_function_cmd: (binding * string option * mixfix) list -> Specification.multi_specs_cmd -> Function_Common.function_config -> (Proof.context -> tactic) -> bool -> local_theory -> info * local_theory val function: (binding * typ option * mixfix) list -> Specification.multi_specs -> Function_Common.function_config -> local_theory -> Proof.state val function_cmd: (binding * string option * mixfix) list -> Specification.multi_specs_cmd -> Function_Common.function_config -> bool -> local_theory -> Proof.state val prove_termination: term option -> tactic -> local_theory -> info * local_theory val prove_termination_cmd: string option -> tactic -> local_theory -> info * local_theory val termination : term option -> local_theory -> Proof.state val termination_cmd : string option -> local_theory -> Proof.state val get_congs : Proof.context -> thm list val get_info : Proof.context -> term -> info end structure Function : FUNCTION = struct open Function_Lib open Function_Common val simp_attribs = @{attributes [simp, nitpick_simp]} val psimp_attribs = @{attributes [nitpick_psimp]} fun note_derived (a, atts) (fname, thms) = Local_Theory.note ((derived_name fname a, atts), thms) #> apfst snd fun add_simps fnames post sort extra_qualify label mod_binding moreatts simps lthy = let val spec = post simps |> map (apfst (apsnd (fn ats => moreatts @ ats))) |> map (apfst (apfst extra_qualify)) val (saved_spec_simps, lthy') = fold_map Local_Theory.note spec lthy val saved_simps = maps snd saved_spec_simps val simps_by_f = sort saved_simps fun note fname simps = Local_Theory.note ((mod_binding (derived_name fname label), []), simps) #> snd in (saved_simps, fold2 note fnames simps_by_f lthy') end fun prepare_function do_print prep fixspec eqns config lthy = let val ((fixes0, spec0), ctxt') = prep fixspec eqns lthy val fixes = map (apfst (apfst Binding.name_of)) fixes0 val spec = map (fn (bnd, prop) => (bnd, [prop])) spec0 val (eqs, post, sort_cont, cnames) = get_preproc lthy config ctxt' fixes spec val fnames = map (fst o fst) fixes0 val defname = Binding.conglomerate fnames; val FunctionConfig {partials, default, ...} = config val _ = if is_some default then legacy_feature "\"function (default)\" -- use 'partial_function' instead" else () val ((goal_state, cont), lthy') = Function_Mutual.prepare_function_mutual config defname fixes0 eqs lthy fun afterqed [[proof]] lthy1 = let val result = cont lthy1 (Thm.close_derivation \<^here> proof) val FunctionResult {fs, R, dom, psimps, simple_pinducts, termination, domintros, cases, ...} = result val pelims = Function_Elims.mk_partial_elim_rules lthy1 result val concealed_partial = if partials then I else Binding.concealed val addsmps = add_simps fnames post sort_cont val (((((psimps', [pinducts']), [termination']), cases'), pelims'), lthy2) = lthy1 |> addsmps (concealed_partial o Binding.qualify false "partial") "psimps" concealed_partial psimp_attribs psimps ||>> Local_Theory.notes [((concealed_partial (derived_name defname "pinduct"), []), simple_pinducts |> map (fn th => ([th], [Attrib.case_names cnames, Attrib.consumes (1 - Thm.nprems_of th)] @ @{attributes [induct pred]})))] ||>> (apfst snd o Local_Theory.note ((Binding.concealed (derived_name defname "termination"), []), [termination])) ||>> fold_map (note_derived ("cases", [Attrib.case_names cnames])) (fnames ~~ map single cases) ||>> fold_map (note_derived ("pelims", [Attrib.consumes 1, Attrib.constraints 1])) (fnames ~~ pelims) ||> (case domintros of NONE => I | SOME thms => Local_Theory.note ((derived_name defname "domintros", []), thms) #> snd) val info = { add_simps=addsmps, fnames=fnames, case_names=cnames, psimps=psimps', pinducts=snd pinducts', simps=NONE, inducts=NONE, termination=termination', totality=NONE, fs=fs, R=R, dom=dom, defname=defname, is_partial=true, cases=flat cases', pelims=pelims',elims=NONE} val _ = Proof_Display.print_consts do_print (Position.thread_data ()) lthy2 (K false) (map fst fixes) in (info, lthy2 |> Local_Theory.declaration {syntax = false, pervasive = false} (fn phi => add_function_data (transform_function_data phi info))) end in ((goal_state, afterqed), lthy') end fun gen_add_function do_print prep fixspec eqns config tac lthy = let val ((goal_state, afterqed), lthy') = prepare_function do_print prep fixspec eqns config lthy val pattern_thm = case SINGLE (tac lthy') goal_state of NONE => error "pattern completeness and compatibility proof failed" | SOME st => Goal.finish lthy' st in lthy' |> afterqed [[pattern_thm]] end val add_function = gen_add_function false Specification.check_multi_specs fun add_function_cmd a b c d int = gen_add_function int Specification.read_multi_specs a b c d fun gen_function do_print prep fixspec eqns config lthy = let val ((goal_state, afterqed), lthy') = prepare_function do_print prep fixspec eqns config lthy in lthy' |> Proof.theorem NONE (snd oo afterqed) [[(Logic.unprotect (Thm.concl_of goal_state), [])]] |> Proof.refine_singleton (Method.primitive_text (K (K goal_state))) end val function = gen_function false Specification.check_multi_specs fun function_cmd a b c int = gen_function int Specification.read_multi_specs a b c fun prepare_termination_proof prep_binding prep_term raw_term_opt lthy = let val term_opt = Option.map (prep_term lthy) raw_term_opt val info = (case term_opt of SOME t => (case import_function_data t lthy of SOME info => info | NONE => error ("Not a function: " ^ quote (Syntax.string_of_term lthy t))) | NONE => (case import_last_function lthy of SOME info => info | NONE => error "Not a function")) val { termination, fs, R, add_simps, case_names, psimps, pinducts, defname, fnames, cases, dom, pelims, ...} = info val domT = domain_type (fastype_of R) val goal = HOLogic.mk_Trueprop (HOLogic.mk_all ("x", domT, mk_acc domT R $ Free ("x", domT))) fun afterqed [[raw_totality]] lthy1 = let val totality = Thm.close_derivation \<^here> raw_totality val remove_domain_condition = full_simplify (put_simpset HOL_basic_ss lthy1 addsimps [totality, @{thm True_implies_equals}]) val tsimps = map remove_domain_condition psimps val tinduct = map remove_domain_condition pinducts val telims = map (map remove_domain_condition) pelims in lthy1 |> add_simps prep_binding "simps" prep_binding simp_attribs tsimps ||> Code.declare_default_eqns (map (rpair true) tsimps) ||>> Local_Theory.note ((prep_binding (derived_name defname "induct"), [Attrib.case_names case_names]), tinduct) ||>> fold_map (note_derived ("elims", [Attrib.consumes 1, Attrib.constraints 1])) (map prep_binding fnames ~~ telims) |-> (fn ((simps,(_,inducts)), elims) => fn lthy2 => let val info' = { is_partial=false, defname=defname, fnames=fnames, add_simps=add_simps, case_names=case_names, fs=fs, R=R, dom=dom, psimps=psimps, pinducts=pinducts, simps=SOME simps, inducts=SOME inducts, termination=termination, totality=SOME totality, cases=cases, pelims=pelims, elims=SOME elims} |> transform_function_data (Morphism.binding_morphism "" prep_binding) in (info', lthy2 |> Local_Theory.declaration {syntax = false, pervasive = false} (fn phi => add_function_data (transform_function_data phi info')) - |> Spec_Rules.add Spec_Rules.equational_recdef (fs, tsimps)) + |> Spec_Rules.add "" Spec_Rules.equational_recdef fs tsimps) end) end in (goal, afterqed, termination) end fun gen_prove_termination prep_term raw_term_opt tac lthy = let val (goal, afterqed, termination) = prepare_termination_proof I prep_term raw_term_opt lthy val totality = Goal.prove lthy [] [] goal (K tac) in afterqed [[totality]] lthy end val prove_termination = gen_prove_termination Syntax.check_term val prove_termination_cmd = gen_prove_termination Syntax.read_term fun gen_termination prep_term raw_term_opt lthy = let val (goal, afterqed, termination) = prepare_termination_proof Binding.reset_pos prep_term raw_term_opt lthy in lthy |> Proof_Context.note_thms "" ((Binding.empty, [Context_Rules.rule_del]), [([allI], [])]) |> snd |> Proof_Context.note_thms "" ((Binding.empty, [Context_Rules.intro_bang (SOME 1)]), [([allI], [])]) |> snd |> Proof_Context.note_thms "" ((Binding.name "termination", [Context_Rules.intro_bang (SOME 0)]), [([Goal.norm_result lthy termination], [])]) |> snd |> Proof.theorem NONE (snd oo afterqed) [[(goal, [])]] end val termination = gen_termination Syntax.check_term val termination_cmd = gen_termination Syntax.read_term (* Datatype hook to declare datatype congs as "function_congs" *) fun add_case_cong n thy = let val cong = #case_cong (Old_Datatype_Data.the_info thy n) |> safe_mk_meta_eq in Context.theory_map (Function_Context_Tree.add_function_cong cong) thy end val _ = Theory.setup (Old_Datatype_Data.interpretation (K (fold add_case_cong))) (* get info *) val get_congs = Function_Context_Tree.get_function_congs fun get_info ctxt t = Function_Common.retrieve_function_data ctxt t |> the_single |> snd (* outer syntax *) val _ = Outer_Syntax.local_theory_to_proof' \<^command_keyword>\function\ "define general recursive functions" (function_parser default_config >> (fn (config, (fixes, specs)) => function_cmd fixes specs config)) val _ = Outer_Syntax.local_theory_to_proof \<^command_keyword>\termination\ "prove termination of a recursive function" (Scan.option Parse.term >> termination_cmd) end diff --git a/src/HOL/Tools/Function/function_common.ML b/src/HOL/Tools/Function/function_common.ML --- a/src/HOL/Tools/Function/function_common.ML +++ b/src/HOL/Tools/Function/function_common.ML @@ -1,369 +1,370 @@ (* Title: HOL/Tools/Function/function_common.ML Author: Alexander Krauss, TU Muenchen Common definitions and other infrastructure for the function package. *) signature FUNCTION_COMMON = sig type info = {is_partial : bool, defname : binding, (*contains no logical entities: invariant under morphisms:*) add_simps : (binding -> binding) -> string -> (binding -> binding) -> Token.src list -> thm list -> local_theory -> thm list * local_theory, fnames : binding list, case_names : string list, fs : term list, R : term, dom: term, psimps: thm list, pinducts: thm list, simps : thm list option, inducts : thm list option, termination : thm, totality : thm option, cases : thm list, pelims: thm list list, elims: thm list list option} val profile : bool Unsynchronized.ref val PROFILE : string -> ('a -> 'b) -> 'a -> 'b val mk_acc : typ -> term -> term val split_def : Proof.context -> (string -> 'a) -> term -> string * (string * typ) list * term list * term list * term val check_defs : Proof.context -> ((string * typ) * 'a) list -> term list -> unit type fixes = ((string * typ) * mixfix) list type 'a spec = (Attrib.binding * 'a list) list datatype function_config = FunctionConfig of {sequential: bool, default: string option, domintros: bool, partials: bool} type preproc = function_config -> Proof.context -> fixes -> term spec -> term list * (thm list -> thm spec) * (thm list -> thm list list) * string list val fname_of : term -> string val mk_case_names : int -> string -> int -> string list val empty_preproc : (Proof.context -> ((string * typ) * mixfix) list -> term list -> 'c) -> preproc val termination_rule_tac : Proof.context -> int -> tactic val store_termination_rule : thm -> Context.generic -> Context.generic val retrieve_function_data : Proof.context -> term -> (term * info) list val add_function_data : info -> Context.generic -> Context.generic val termination_prover_tac : bool -> Proof.context -> tactic val set_termination_prover : (bool -> Proof.context -> tactic) -> Context.generic -> Context.generic val get_preproc: Proof.context -> preproc val set_preproc: preproc -> Context.generic -> Context.generic datatype function_result = FunctionResult of {fs: term list, G: term, R: term, dom: term, psimps : thm list, simple_pinducts : thm list, cases : thm list, pelims : thm list list, termination : thm, domintros : thm list option} val transform_function_data : morphism -> info -> info val import_function_data : term -> Proof.context -> info option val import_last_function : Proof.context -> info option val default_config : function_config val function_parser : function_config -> (function_config * ((binding * string option * mixfix) list * Specification.multi_specs_cmd)) parser end structure Function_Common : FUNCTION_COMMON = struct local open Function_Lib in (* info *) type info = {is_partial : bool, defname : binding, (*contains no logical entities: invariant under morphisms:*) add_simps : (binding -> binding) -> string -> (binding -> binding) -> Token.src list -> thm list -> local_theory -> thm list * local_theory, fnames : binding list, case_names : string list, fs : term list, R : term, dom: term, psimps: thm list, pinducts: thm list, simps : thm list option, inducts : thm list option, termination : thm, totality : thm option, cases : thm list, pelims : thm list list, elims : thm list list option} fun transform_function_data phi ({add_simps, case_names, fnames, fs, R, dom, psimps, pinducts, simps, inducts, termination, totality, defname, is_partial, cases, pelims, elims} : info) = let val term = Morphism.term phi val thm = Morphism.thm phi val fact = Morphism.fact phi in { add_simps = add_simps, case_names = case_names, fnames = fnames, fs = map term fs, R = term R, dom = term dom, psimps = fact psimps, pinducts = fact pinducts, simps = Option.map fact simps, inducts = Option.map fact inducts, termination = thm termination, totality = Option.map thm totality, defname = Morphism.binding phi defname, is_partial = is_partial, cases = fact cases, pelims = map fact pelims, elims = Option.map (map fact) elims } end (* profiling *) val profile = Unsynchronized.ref false fun PROFILE msg = if !profile then timeap_msg msg else I val acc_const_name = \<^const_name>\Wellfounded.accp\ fun mk_acc domT R = Const (acc_const_name, (domT --> domT --> HOLogic.boolT) --> domT --> HOLogic.boolT) $ R (* analyzing function equations *) fun split_def ctxt check_head geq = let fun input_error msg = cat_lines [msg, Syntax.string_of_term ctxt geq] val qs = Term.strip_qnt_vars \<^const_name>\Pure.all\ geq val imp = Term.strip_qnt_body \<^const_name>\Pure.all\ geq val (gs, eq) = Logic.strip_horn imp val (f_args, rhs) = HOLogic.dest_eq (HOLogic.dest_Trueprop eq) handle TERM _ => error (input_error "Not an equation") val (head, args) = strip_comb f_args val fname = fst (dest_Free head) handle TERM _ => "" val _ = check_head fname in (fname, qs, gs, args, rhs) end (*check for various errors in the input*) fun check_defs ctxt fixes eqs = let val fnames = map (fst o fst) fixes fun check geq = let fun input_error msg = error (cat_lines [msg, Syntax.string_of_term ctxt geq]) fun check_head fname = member (op =) fnames fname orelse input_error ("Illegal equation head. Expected " ^ commas_quote fnames) val (fname, qs, gs, args, rhs) = split_def ctxt check_head geq val _ = length args > 0 orelse input_error "Function has no arguments:" fun add_bvs t is = add_loose_bnos (t, 0, is) val rvs = (subtract (op =) (fold add_bvs args []) (add_bvs rhs [])) |> map (fst o nth (rev qs)) val _ = null rvs orelse input_error ("Variable" ^ plural " " "s " rvs ^ commas_quote rvs ^ " occur" ^ plural "s" "" rvs ^ " on right hand side only:") val _ = forall (not o Term.exists_subterm (fn Free (n, _) => member (op =) fnames n | _ => false)) (gs @ args) orelse input_error "Defined function may not occur in premises or arguments" val freeargs = map (fn t => subst_bounds (rev (map Free qs), t)) args val funvars = filter (fn q => exists (exists_subterm (fn (Free q') $ _ => q = q' | _ => false)) freeargs) qs val _ = null funvars orelse (warning (cat_lines ["Bound variable" ^ plural " " "s " funvars ^ commas_quote (map fst funvars) ^ " occur" ^ plural "s" "" funvars ^ " in function position.", "Misspelled constructor???"]); true) in (fname, length args) end val grouped_args = AList.group (op =) (map check eqs) val _ = grouped_args |> map (fn (fname, ars) => length (distinct (op =) ars) = 1 orelse error ("Function " ^ quote fname ^ " has different numbers of arguments in different equations")) val not_defined = subtract (op =) (map fst grouped_args) fnames val _ = null not_defined orelse error ("No defining equations for function" ^ plural " " "s " not_defined ^ commas_quote not_defined) in () end (* preprocessors *) type fixes = ((string * typ) * mixfix) list type 'a spec = (Attrib.binding * 'a list) list datatype function_config = FunctionConfig of {sequential: bool, default: string option, domintros: bool, partials: bool} type preproc = function_config -> Proof.context -> fixes -> term spec -> term list * (thm list -> thm spec) * (thm list -> thm list list) * string list val fname_of = fst o dest_Free o fst o strip_comb o fst o HOLogic.dest_eq o HOLogic.dest_Trueprop o Logic.strip_imp_concl o snd o dest_all_all fun mk_case_names i "" k = mk_case_names i (string_of_int (i + 1)) k | mk_case_names _ _ 0 = [] | mk_case_names _ n 1 = [n] | mk_case_names _ n k = map (fn i => n ^ "_" ^ string_of_int i) (1 upto k) fun empty_preproc check (_: function_config) (ctxt: Proof.context) (fixes: fixes) spec = let val (bnds, tss) = split_list spec val ts = flat tss val _ = check ctxt fixes ts val fnames = map (fst o fst) fixes val indices = map (fn eq => find_index (curry op = (fname_of eq)) fnames) ts fun sort xs = partition_list (fn i => fn (j,_) => i = j) 0 (length fnames - 1) (indices ~~ xs) |> map (map snd) (* using theorem names for case name currently disabled *) val cnames = map_index (fn (i, _) => mk_case_names i "" 1) bnds |> flat in (ts, curry op ~~ bnds o Library.unflat tss, sort, cnames) end (* context data *) structure Data = Generic_Data ( type T = thm list * (term * info) Item_Net.T * (bool -> Proof.context -> tactic) * preproc val empty: T = ([], Item_Net.init (op aconv o apply2 fst) (single o fst), fn _ => error "Termination prover not configured", empty_preproc check_defs) val extend = I fun merge ((termination_rules1, functions1, termination_prover1, preproc1), (termination_rules2, functions2, _, _)) : T = (Thm.merge_thms (termination_rules1, termination_rules2), Item_Net.merge (functions1, functions2), termination_prover1, preproc1) ) fun termination_rule_tac ctxt = resolve_tac ctxt (#1 (Data.get (Context.Proof ctxt))) val store_termination_rule = Data.map o @{apply 4(1)} o cons o Thm.trim_context val get_functions = #2 o Data.get o Context.Proof fun retrieve_function_data ctxt t = Item_Net.retrieve (get_functions ctxt) t |> (map o apsnd) (transform_function_data (Morphism.transfer_morphism' ctxt)); val add_function_data = transform_function_data Morphism.trim_context_morphism #> (fn info as {fs, termination, ...} => (Data.map o @{apply 4(2)}) (fold (fn f => Item_Net.update (f, info)) fs) #> store_termination_rule termination) fun termination_prover_tac quiet ctxt = #3 (Data.get (Context.Proof ctxt)) quiet ctxt val set_termination_prover = Data.map o @{apply 4(3)} o K val get_preproc = #4 o Data.get o Context.Proof val set_preproc = Data.map o @{apply 4(4)} o K (* function definition result data *) datatype function_result = FunctionResult of {fs: term list, G: term, R: term, dom: term, psimps : thm list, simple_pinducts : thm list, cases : thm list, pelims : thm list list, termination : thm, domintros : thm list option} fun import_function_data t ctxt = let val ct = Thm.cterm_of ctxt t fun inst_morph u = Morphism.instantiate_morphism (Thm.match (Thm.cterm_of ctxt u, ct)) fun match (u, data) = SOME (transform_function_data (inst_morph u) data) handle Pattern.MATCH => NONE in get_first match (retrieve_function_data ctxt t) + |> Option.map (transform_function_data (Morphism.transfer_morphism' ctxt)) end fun import_last_function ctxt = (case Item_Net.content (get_functions ctxt) of [] => NONE | (t, _) :: _ => let val (t', ctxt') = yield_singleton (Variable.import_terms true) t ctxt in import_function_data t' ctxt' end) (* configuration management *) datatype function_opt = Sequential | Default of string | DomIntros | No_Partials fun apply_opt Sequential (FunctionConfig {sequential = _, default, domintros, partials}) = FunctionConfig {sequential = true, default = default, domintros = domintros, partials = partials} | apply_opt (Default d) (FunctionConfig {sequential, default = _, domintros, partials}) = FunctionConfig {sequential = sequential, default = SOME d, domintros = domintros, partials = partials} | apply_opt DomIntros (FunctionConfig {sequential, default, domintros = _, partials}) = FunctionConfig {sequential = sequential, default = default, domintros = true, partials = partials} | apply_opt No_Partials (FunctionConfig {sequential, default, domintros, partials = _}) = FunctionConfig {sequential = sequential, default = default, domintros = domintros, partials = false} val default_config = FunctionConfig { sequential=false, default=NONE, domintros=false, partials=true} local val option_parser = Parse.group (fn () => "option") ((Parse.reserved "sequential" >> K Sequential) || ((Parse.reserved "default" |-- Parse.term) >> Default) || (Parse.reserved "domintros" >> K DomIntros) || (Parse.reserved "no_partials" >> K No_Partials)) fun config_parser default = (Scan.optional (\<^keyword>\(\ |-- Parse.!!! (Parse.list1 option_parser) --| \<^keyword>\)\) []) >> (fn opts => fold apply_opt opts default) in fun function_parser default_cfg = config_parser default_cfg -- Parse_Spec.specification end end end diff --git a/src/HOL/Tools/Function/partial_function.ML b/src/HOL/Tools/Function/partial_function.ML --- a/src/HOL/Tools/Function/partial_function.ML +++ b/src/HOL/Tools/Function/partial_function.ML @@ -1,323 +1,323 @@ (* Title: HOL/Tools/Function/partial_function.ML Author: Alexander Krauss, TU Muenchen Partial function definitions based on least fixed points in ccpos. *) signature PARTIAL_FUNCTION = sig val init: string -> term -> term -> thm -> thm -> thm option -> declaration val mono_tac: Proof.context -> int -> tactic val add_partial_function: string -> (binding * typ option * mixfix) list -> Attrib.binding * term -> local_theory -> (term * thm) * local_theory val add_partial_function_cmd: string -> (binding * string option * mixfix) list -> Attrib.binding * string -> local_theory -> (term * thm) * local_theory val transform_result: morphism -> term * thm -> term * thm end; structure Partial_Function: PARTIAL_FUNCTION = struct open Function_Lib (*** Context Data ***) datatype setup_data = Setup_Data of {fixp: term, mono: term, fixp_eq: thm, fixp_induct: thm, fixp_induct_user: thm option}; fun transform_setup_data phi (Setup_Data {fixp, mono, fixp_eq, fixp_induct, fixp_induct_user}) = let val term = Morphism.term phi; val thm = Morphism.thm phi; in Setup_Data {fixp = term fixp, mono = term mono, fixp_eq = thm fixp_eq, fixp_induct = thm fixp_induct, fixp_induct_user = Option.map thm fixp_induct_user} end; structure Modes = Generic_Data ( type T = setup_data Symtab.table; val empty = Symtab.empty; val extend = I; fun merge data = Symtab.merge (K true) data; ) fun init mode fixp mono fixp_eq fixp_induct fixp_induct_user phi = let val data' = Setup_Data {fixp = fixp, mono = mono, fixp_eq = fixp_eq, fixp_induct = fixp_induct, fixp_induct_user = fixp_induct_user} |> transform_setup_data (phi $> Morphism.trim_context_morphism); in Modes.map (Symtab.update (mode, data')) end; val known_modes = Symtab.keys o Modes.get o Context.Proof; fun lookup_mode ctxt = Symtab.lookup (Modes.get (Context.Proof ctxt)) #> Option.map (transform_setup_data (Morphism.transfer_morphism' ctxt)); (*** Automated monotonicity proofs ***) (*rewrite conclusion with k-th assumtion*) fun rewrite_with_asm_tac ctxt k = Subgoal.FOCUS (fn {context = ctxt', prems, ...} => Local_Defs.unfold0_tac ctxt' [nth prems k]) ctxt; fun dest_case ctxt t = case strip_comb t of (Const (case_comb, _), args) => (case Ctr_Sugar.ctr_sugar_of_case ctxt case_comb of NONE => NONE | SOME {case_thms, ...} => let val lhs = Thm.prop_of (hd case_thms) |> HOLogic.dest_Trueprop |> HOLogic.dest_eq |> fst; val arity = length (snd (strip_comb lhs)); val conv = funpow (length args - arity) Conv.fun_conv (Conv.rewrs_conv (map mk_meta_eq case_thms)); in SOME (nth args (arity - 1), conv) end) | _ => NONE; (*split on case expressions*) val split_cases_tac = Subgoal.FOCUS_PARAMS (fn {context = ctxt, ...} => SUBGOAL (fn (t, i) => case t of _ $ (_ $ Abs (_, _, body)) => (case dest_case ctxt body of NONE => no_tac | SOME (arg, conv) => let open Conv in if Term.is_open arg then no_tac else ((DETERM o Induct.cases_tac ctxt false [[SOME arg]] NONE []) THEN_ALL_NEW (rewrite_with_asm_tac ctxt 0) THEN_ALL_NEW eresolve_tac ctxt @{thms thin_rl} THEN_ALL_NEW (CONVERSION (params_conv ~1 (fn ctxt' => arg_conv (arg_conv (abs_conv (K conv) ctxt'))) ctxt))) i end) | _ => no_tac) 1); (*monotonicity proof: apply rules + split case expressions*) fun mono_tac ctxt = K (Local_Defs.unfold0_tac ctxt [@{thm curry_def}]) THEN' (TRY o REPEAT_ALL_NEW (resolve_tac ctxt (rev (Named_Theorems.get ctxt \<^named_theorems>\partial_function_mono\)) ORELSE' split_cases_tac ctxt)); (*** Auxiliary functions ***) (*Returns t $ u, but instantiates the type of t to make the application type correct*) fun apply_inst ctxt t u = let val thy = Proof_Context.theory_of ctxt; val T = domain_type (fastype_of t); val T' = fastype_of u; val subst = Sign.typ_match thy (T, T') Vartab.empty handle Type.TYPE_MATCH => raise TYPE ("apply_inst", [T, T'], [t, u]) in map_types (Envir.norm_type subst) t $ u end; fun head_conv cv ct = if can Thm.dest_comb ct then Conv.fun_conv (head_conv cv) ct else cv ct; (*** currying transformation ***) fun curry_const (A, B, C) = Const (\<^const_name>\Product_Type.curry\, [HOLogic.mk_prodT (A, B) --> C, A, B] ---> C); fun mk_curry f = case fastype_of f of Type ("fun", [Type (_, [S, T]), U]) => curry_const (S, T, U) $ f | T => raise TYPE ("mk_curry", [T], [f]); (* iterated versions. Nonstandard left-nested tuples arise naturally from "split o split o split"*) fun curry_n arity = funpow (arity - 1) mk_curry; fun uncurry_n arity = funpow (arity - 1) HOLogic.mk_case_prod; val curry_uncurry_ss = simpset_of (put_simpset HOL_basic_ss \<^context> addsimps [@{thm Product_Type.curry_case_prod}, @{thm Product_Type.case_prod_curry}]) val split_conv_ss = simpset_of (put_simpset HOL_basic_ss \<^context> addsimps [@{thm Product_Type.split_conv}]); val curry_K_ss = simpset_of (put_simpset HOL_basic_ss \<^context> addsimps [@{thm Product_Type.curry_K}]); (* instantiate generic fixpoint induction and eliminate the canonical assumptions; curry induction predicate *) fun specialize_fixp_induct ctxt fT fT_uc curry uncurry mono_thm f_def rule = let val ([P], ctxt') = Variable.variant_fixes ["P"] ctxt val P_inst = Abs ("f", fT_uc, Free (P, fT --> HOLogic.boolT) $ (curry $ Bound 0)) in (* FIXME ctxt vs. ctxt' (!?) *) rule |> infer_instantiate' ctxt ((map o Option.map) (Thm.cterm_of ctxt) [SOME uncurry, NONE, SOME curry, NONE, SOME P_inst]) |> Tactic.rule_by_tactic ctxt (Simplifier.simp_tac (put_simpset curry_uncurry_ss ctxt) 3 (* discharge U (C f) = f *) THEN Simplifier.simp_tac (put_simpset curry_K_ss ctxt) 4 (* simplify bot case *) THEN Simplifier.full_simp_tac (put_simpset curry_uncurry_ss ctxt) 5) (* simplify induction step *) |> (fn thm => thm OF [mono_thm, f_def]) |> Conv.fconv_rule (Conv.concl_conv ~1 (* simplify conclusion *) (Raw_Simplifier.rewrite ctxt false [mk_meta_eq @{thm Product_Type.curry_case_prod}])) |> singleton (Variable.export ctxt' ctxt) end fun mk_curried_induct args ctxt inst_rule = let val cert = Thm.cterm_of ctxt (* FIXME ctxt vs. ctxt' (!?) *) val ([P], ctxt') = Variable.variant_fixes ["P"] ctxt val split_paired_all_conv = Conv.every_conv (replicate (length args - 1) (Conv.rewr_conv @{thm split_paired_all})) val split_params_conv = Conv.params_conv ~1 (fn _ => Conv.implies_conv split_paired_all_conv Conv.all_conv) val (P_var, x_var) = Thm.prop_of inst_rule |> Logic.strip_imp_concl |> HOLogic.dest_Trueprop |> strip_comb |> apsnd hd |> apply2 dest_Var val P_rangeT = range_type (snd P_var) val PT = map (snd o dest_Free) args ---> P_rangeT val x_inst = cert (foldl1 HOLogic.mk_prod args) val P_inst = cert (uncurry_n (length args) (Free (P, PT))) val inst_rule' = inst_rule |> Tactic.rule_by_tactic ctxt (Simplifier.simp_tac (put_simpset curry_uncurry_ss ctxt) 4 THEN Simplifier.simp_tac (put_simpset curry_uncurry_ss ctxt) 3 THEN CONVERSION (split_params_conv ctxt then_conv (Conv.forall_conv (K split_paired_all_conv) ctxt)) 3) |> Thm.instantiate ([], [(P_var, P_inst), (x_var, x_inst)]) |> Simplifier.full_simplify (put_simpset split_conv_ss ctxt) |> singleton (Variable.export ctxt' ctxt) in inst_rule' end; (*** partial_function definition ***) fun transform_result phi (t, thm) = (Morphism.term phi t, Morphism.thm phi thm); fun gen_add_partial_function prep mode fixes_raw eqn_raw lthy = let val setup_data = the (lookup_mode lthy mode) handle Option.Option => error (cat_lines ["Unknown mode " ^ quote mode ^ ".", "Known modes are " ^ commas_quote (known_modes lthy) ^ "."]); val Setup_Data {fixp, mono, fixp_eq, fixp_induct, fixp_induct_user} = setup_data; val ((fixes, [(eq_abinding, eqn)]), _) = prep fixes_raw [(eqn_raw, [], [])] lthy; val ((_, plain_eqn), args_ctxt) = Variable.focus NONE eqn lthy; val ((f_binding, fT), mixfix) = the_single fixes; val f_bname = Binding.name_of f_binding; fun note_qualified (name, thms) = Local_Theory.note ((derived_name f_binding name, []), thms) #> snd val (lhs, rhs) = HOLogic.dest_eq (HOLogic.dest_Trueprop plain_eqn); val (head, args) = strip_comb lhs; val argnames = map (fst o dest_Free) args; val F = fold_rev lambda (head :: args) rhs; val arity = length args; val (aTs, bTs) = chop arity (binder_types fT); val tupleT = foldl1 HOLogic.mk_prodT aTs; val fT_uc = tupleT :: bTs ---> body_type fT; val f_uc = Var ((f_bname, 0), fT_uc); val x_uc = Var (("x", 1), tupleT); val uncurry = lambda head (uncurry_n arity head); val curry = lambda f_uc (curry_n arity f_uc); val F_uc = lambda f_uc (uncurry_n arity (F $ curry_n arity f_uc)); val mono_goal = apply_inst lthy mono (lambda f_uc (F_uc $ f_uc $ x_uc)) |> HOLogic.mk_Trueprop |> Logic.all x_uc; val mono_thm = Goal.prove_internal lthy [] (Thm.cterm_of lthy mono_goal) (K (mono_tac lthy 1)) val inst_mono_thm = Thm.forall_elim (Thm.cterm_of lthy x_uc) mono_thm val f_def_rhs = curry_n arity (apply_inst lthy fixp F_uc); val f_def_binding = Thm.make_def_binding (Config.get lthy Function_Lib.function_internals) f_binding val ((f, (_, f_def)), lthy') = Local_Theory.define ((f_binding, mixfix), ((f_def_binding, []), f_def_rhs)) lthy; val eqn = HOLogic.mk_eq (list_comb (f, args), Term.betapplys (F, f :: args)) |> HOLogic.mk_Trueprop; val unfold = (infer_instantiate' lthy' (map (SOME o Thm.cterm_of lthy') [uncurry, F, curry]) fixp_eq OF [inst_mono_thm, f_def]) |> Tactic.rule_by_tactic lthy' (Simplifier.simp_tac (put_simpset curry_uncurry_ss lthy') 1); val specialized_fixp_induct = specialize_fixp_induct lthy' fT fT_uc curry uncurry inst_mono_thm f_def fixp_induct |> Drule.rename_bvars' (map SOME (f_bname :: f_bname :: argnames)); val mk_raw_induct = infer_instantiate' args_ctxt ((map o Option.map) (Thm.cterm_of args_ctxt) [SOME uncurry, NONE, SOME curry]) #> mk_curried_induct args args_ctxt #> singleton (Variable.export args_ctxt lthy') #> (fn thm => infer_instantiate' lthy' [SOME (Thm.cterm_of lthy' F)] thm OF [inst_mono_thm, f_def]) #> Drule.rename_bvars' (map SOME (f_bname :: argnames @ argnames)) val raw_induct = Option.map mk_raw_induct fixp_induct_user val rec_rule = let open Conv in Goal.prove lthy' (map (fst o dest_Free) args) [] eqn (fn _ => CONVERSION ((arg_conv o arg1_conv o head_conv o rewr_conv) (mk_meta_eq unfold)) 1 THEN resolve_tac lthy' @{thms refl} 1) end; val ((_, [rec_rule']), lthy'') = lthy' |> Local_Theory.note (eq_abinding, [rec_rule]) in lthy'' - |> Spec_Rules.add Spec_Rules.equational_recdef ([f], [rec_rule']) + |> Spec_Rules.add "" Spec_Rules.equational_recdef [f] [rec_rule'] |> note_qualified ("simps", [rec_rule']) |> note_qualified ("mono", [mono_thm]) |> (case raw_induct of NONE => I | SOME thm => note_qualified ("raw_induct", [thm])) |> note_qualified ("fixp_induct", [specialized_fixp_induct]) |> pair (f, rec_rule') end; val add_partial_function = gen_add_partial_function Specification.check_multi_specs; val add_partial_function_cmd = gen_add_partial_function Specification.read_multi_specs; val mode = \<^keyword>\(\ |-- Parse.name --| \<^keyword>\)\; val _ = Outer_Syntax.local_theory \<^command_keyword>\partial_function\ "define partial function" ((mode -- (Parse.vars -- (Parse.where_ |-- Parse_Spec.simple_spec))) >> (fn (mode, (vars, spec)) => add_partial_function_cmd mode vars spec #> #2)); end; diff --git a/src/HOL/Tools/Nitpick/nitpick_hol.ML b/src/HOL/Tools/Nitpick/nitpick_hol.ML --- a/src/HOL/Tools/Nitpick/nitpick_hol.ML +++ b/src/HOL/Tools/Nitpick/nitpick_hol.ML @@ -1,2429 +1,2428 @@ (* Title: HOL/Tools/Nitpick/nitpick_hol.ML Author: Jasmin Blanchette, TU Muenchen Copyright 2008, 2009, 2010 Auxiliary HOL-related functions used by Nitpick. *) signature NITPICK_HOL = sig type const_table = term list Symtab.table type special_fun = ((string * typ) * int list * term list) * (string * typ) type unrolled = (string * typ) * (string * typ) type wf_cache = ((string * typ) * (bool * bool)) list type hol_context = {thy: theory, ctxt: Proof.context, max_bisim_depth: int, boxes: (typ option * bool option) list, wfs: ((string * typ) option * bool option) list, user_axioms: bool option, debug: bool, whacks: term list, binary_ints: bool option, destroy_constrs: bool, specialize: bool, star_linear_preds: bool, total_consts: bool option, needs: term list option, tac_timeout: Time.time, evals: term list, case_names: (string * int) list, def_tables: const_table * const_table, nondef_table: const_table, nondefs: term list, simp_table: const_table Unsynchronized.ref, psimp_table: const_table, choice_spec_table: const_table, intro_table: const_table, ground_thm_table: term list Inttab.table, ersatz_table: (string * string) list, skolems: (string * string list) list Unsynchronized.ref, special_funs: special_fun list Unsynchronized.ref, unrolled_preds: unrolled list Unsynchronized.ref, wf_cache: wf_cache Unsynchronized.ref, constr_cache: (typ * (string * typ) list) list Unsynchronized.ref} datatype fixpoint_kind = Lfp | Gfp | NoFp datatype boxability = InConstr | InSel | InExpr | InPair | InFunLHS | InFunRHS1 | InFunRHS2 val name_sep : string val numeral_prefix : string val base_prefix : string val step_prefix : string val unrolled_prefix : string val ubfp_prefix : string val lbfp_prefix : string val quot_normal_prefix : string val skolem_prefix : string val special_prefix : string val uncurry_prefix : string val eval_prefix : string val iter_var_prefix : string val strip_first_name_sep : string -> string * string val original_name : string -> string val abs_var : indexname * typ -> term -> term val s_conj : term * term -> term val s_disj : term * term -> term val strip_any_connective : term -> term list * term val conjuncts_of : term -> term list val disjuncts_of : term -> term list val unarize_unbox_etc_type : typ -> typ val uniterize_unarize_unbox_etc_type : typ -> typ val string_for_type : Proof.context -> typ -> string val pretty_for_type : Proof.context -> typ -> Pretty.T val prefix_name : string -> string -> string val shortest_name : string -> string val short_name : string -> string val shorten_names_in_term : term -> term val strict_type_match : theory -> typ * typ -> bool val type_match : theory -> typ * typ -> bool val const_match : theory -> (string * typ) * (string * typ) -> bool val term_match : theory -> term * term -> bool val frac_from_term_pair : typ -> term -> term -> term val is_fun_type : typ -> bool val is_set_type : typ -> bool val is_fun_or_set_type : typ -> bool val is_set_like_type : typ -> bool val is_pair_type : typ -> bool val is_lfp_iterator_type : typ -> bool val is_gfp_iterator_type : typ -> bool val is_fp_iterator_type : typ -> bool val is_iterator_type : typ -> bool val is_boolean_type : typ -> bool val is_integer_type : typ -> bool val is_bit_type : typ -> bool val is_word_type : typ -> bool val is_integer_like_type : typ -> bool val is_number_type : Proof.context -> typ -> bool val is_higher_order_type : typ -> bool val elem_type : typ -> typ val pseudo_domain_type : typ -> typ val pseudo_range_type : typ -> typ val const_for_iterator_type : typ -> string * typ val strip_n_binders : int -> typ -> typ list * typ val nth_range_type : int -> typ -> typ val num_factors_in_type : typ -> int val curried_binder_types : typ -> typ list val mk_flat_tuple : typ -> term list -> term val dest_n_tuple : int -> term -> term list val is_codatatype : Proof.context -> typ -> bool val is_quot_type : Proof.context -> typ -> bool val is_pure_typedef : Proof.context -> typ -> bool val is_univ_typedef : Proof.context -> typ -> bool val is_data_type : Proof.context -> typ -> bool val is_record_get : theory -> string * typ -> bool val is_record_update : theory -> string * typ -> bool val is_abs_fun : Proof.context -> string * typ -> bool val is_rep_fun : Proof.context -> string * typ -> bool val is_quot_abs_fun : Proof.context -> string * typ -> bool val is_quot_rep_fun : Proof.context -> string * typ -> bool val mate_of_rep_fun : Proof.context -> string * typ -> string * typ val is_nonfree_constr : Proof.context -> string * typ -> bool val is_free_constr : Proof.context -> string * typ -> bool val is_constr : Proof.context -> string * typ -> bool val is_sel : string -> bool val is_sel_like_and_no_discr : string -> bool val box_type : hol_context -> boxability -> typ -> typ val binarize_nat_and_int_in_type : typ -> typ val binarize_nat_and_int_in_term : term -> term val discr_for_constr : string * typ -> string * typ val num_sels_for_constr_type : typ -> int val nth_sel_name_for_constr_name : string -> int -> string val nth_sel_for_constr : string * typ -> int -> string * typ val binarized_and_boxed_nth_sel_for_constr : hol_context -> bool -> string * typ -> int -> string * typ val sel_no_from_name : string -> int val close_form : term -> term val distinctness_formula : typ -> term list -> term val register_frac_type : string -> (string * string) list -> morphism -> Context.generic -> Context.generic val register_frac_type_global : string -> (string * string) list -> theory -> theory val unregister_frac_type : string -> morphism -> Context.generic -> Context.generic val unregister_frac_type_global : string -> theory -> theory val register_ersatz : (string * string) list -> morphism -> Context.generic -> Context.generic val register_ersatz_global : (string * string) list -> theory -> theory val register_codatatype : typ -> string -> (string * typ) list -> morphism -> Context.generic -> Context.generic val register_codatatype_global : typ -> string -> (string * typ) list -> theory -> theory val unregister_codatatype : typ -> morphism -> Context.generic -> Context.generic val unregister_codatatype_global : typ -> theory -> theory val binarized_and_boxed_data_type_constrs : hol_context -> bool -> typ -> (string * typ) list val constr_name_for_sel_like : string -> string val binarized_and_boxed_constr_for_sel : hol_context -> bool -> string * typ -> string * typ val card_of_type : (typ * int) list -> typ -> int val bounded_card_of_type : int -> int -> (typ * int) list -> typ -> int val bounded_exact_card_of_type : hol_context -> typ list -> int -> int -> (typ * int) list -> typ -> int val typical_card_of_type : typ -> int val is_finite_type : hol_context -> typ -> bool val is_special_eligible_arg : bool -> typ list -> term -> bool val s_let : typ list -> string -> int -> typ -> typ -> (term -> term) -> term -> term val s_betapply : typ list -> term * term -> term val s_betapplys : typ list -> term * term list -> term val discriminate_value : hol_context -> string * typ -> term -> term val select_nth_constr_arg : Proof.context -> string * typ -> term -> int -> typ -> term val construct_value : Proof.context -> string * typ -> term list -> term val coerce_term : hol_context -> typ list -> typ -> typ -> term -> term val special_bounds : term list -> (indexname * typ) list val is_funky_typedef : Proof.context -> typ -> bool val all_defs_of : theory -> (term * term) list -> term list val all_nondefs_of : Proof.context -> (term * term) list -> term list val arity_of_built_in_const : string * typ -> int option val is_built_in_const : string * typ -> bool val term_under_def : term -> term val case_const_names : Proof.context -> (string * int) list val unfold_defs_in_term : hol_context -> term -> term val const_def_tables : Proof.context -> (term * term) list -> term list -> const_table * const_table val const_nondef_table : term list -> const_table val const_simp_table : Proof.context -> (term * term) list -> const_table val const_psimp_table : Proof.context -> (term * term) list -> const_table val const_choice_spec_table : Proof.context -> (term * term) list -> const_table val inductive_intro_table : Proof.context -> (term * term) list -> const_table * const_table -> const_table val ground_theorem_table : theory -> term list Inttab.table val ersatz_table : Proof.context -> (string * string) list val add_simps : const_table Unsynchronized.ref -> string -> term list -> unit val inverse_axioms_for_rep_fun : Proof.context -> string * typ -> term list val optimized_typedef_axioms : Proof.context -> string * typ list -> term list val optimized_quot_type_axioms : Proof.context -> string * typ list -> term list val def_of_const : theory -> const_table * const_table -> string * typ -> term option val fixpoint_kind_of_rhs : term -> fixpoint_kind val fixpoint_kind_of_const : theory -> const_table * const_table -> string * typ -> fixpoint_kind val is_raw_inductive_pred : hol_context -> string * typ -> bool val is_constr_pattern : Proof.context -> term -> bool val is_constr_pattern_lhs : Proof.context -> term -> bool val is_constr_pattern_formula : Proof.context -> term -> bool val nondef_props_for_const : theory -> bool -> const_table -> string * typ -> term list val is_choice_spec_fun : hol_context -> string * typ -> bool val is_choice_spec_axiom : Proof.context -> const_table -> term -> bool val is_raw_equational_fun : hol_context -> string * typ -> bool val is_equational_fun : hol_context -> string * typ -> bool val codatatype_bisim_axioms : hol_context -> typ -> term list val is_well_founded_inductive_pred : hol_context -> string * typ -> bool val unrolled_inductive_pred_const : hol_context -> bool -> string * typ -> term val equational_fun_axioms : hol_context -> string * typ -> term list val is_equational_fun_surely_complete : hol_context -> string * typ -> bool val merged_type_var_table_for_terms : theory -> term list -> (sort * string) list val merge_type_vars_in_term : theory -> bool -> (sort * string) list -> term -> term val ground_types_in_type : hol_context -> bool -> typ -> typ list val ground_types_in_terms : hol_context -> bool -> term list -> typ list end; structure Nitpick_HOL : NITPICK_HOL = struct open Nitpick_Util type const_table = term list Symtab.table type special_fun = ((string * typ) * int list * term list) * (string * typ) type unrolled = (string * typ) * (string * typ) type wf_cache = ((string * typ) * (bool * bool)) list type hol_context = {thy: theory, ctxt: Proof.context, max_bisim_depth: int, boxes: (typ option * bool option) list, wfs: ((string * typ) option * bool option) list, user_axioms: bool option, debug: bool, whacks: term list, binary_ints: bool option, destroy_constrs: bool, specialize: bool, star_linear_preds: bool, total_consts: bool option, needs: term list option, tac_timeout: Time.time, evals: term list, case_names: (string * int) list, def_tables: const_table * const_table, nondef_table: const_table, nondefs: term list, simp_table: const_table Unsynchronized.ref, psimp_table: const_table, choice_spec_table: const_table, intro_table: const_table, ground_thm_table: term list Inttab.table, ersatz_table: (string * string) list, skolems: (string * string list) list Unsynchronized.ref, special_funs: special_fun list Unsynchronized.ref, unrolled_preds: unrolled list Unsynchronized.ref, wf_cache: wf_cache Unsynchronized.ref, constr_cache: (typ * (string * typ) list) list Unsynchronized.ref} datatype fixpoint_kind = Lfp | Gfp | NoFp datatype boxability = InConstr | InSel | InExpr | InPair | InFunLHS | InFunRHS1 | InFunRHS2 (* FIXME: Get rid of 'codatatypes' and related functionality *) structure Data = Generic_Data ( type T = {frac_types: (string * (string * string) list) list, ersatz_table: (string * string) list, codatatypes: (string * (string * (string * typ) list)) list} val empty = {frac_types = [], ersatz_table = [], codatatypes = []} val extend = I fun merge ({frac_types = fs1, ersatz_table = et1, codatatypes = cs1}, {frac_types = fs2, ersatz_table = et2, codatatypes = cs2}) : T = {frac_types = AList.merge (op =) (K true) (fs1, fs2), ersatz_table = AList.merge (op =) (K true) (et1, et2), codatatypes = AList.merge (op =) (K true) (cs1, cs2)} ) val name_sep = "$" val numeral_prefix = nitpick_prefix ^ "num" ^ name_sep val sel_prefix = nitpick_prefix ^ "sel" val discr_prefix = nitpick_prefix ^ "is" ^ name_sep val lfp_iterator_prefix = nitpick_prefix ^ "lfpit" ^ name_sep val gfp_iterator_prefix = nitpick_prefix ^ "gfpit" ^ name_sep val unrolled_prefix = nitpick_prefix ^ "unroll" ^ name_sep val base_prefix = nitpick_prefix ^ "base" ^ name_sep val step_prefix = nitpick_prefix ^ "step" ^ name_sep val ubfp_prefix = nitpick_prefix ^ "ubfp" ^ name_sep val lbfp_prefix = nitpick_prefix ^ "lbfp" ^ name_sep val quot_normal_prefix = nitpick_prefix ^ "qn" ^ name_sep val skolem_prefix = nitpick_prefix ^ "sk" val special_prefix = nitpick_prefix ^ "sp" val uncurry_prefix = nitpick_prefix ^ "unc" val eval_prefix = nitpick_prefix ^ "eval" val iter_var_prefix = "i" (** Constant/type information and term/type manipulation **) fun sel_prefix_for j = sel_prefix ^ string_of_int j ^ name_sep fun quot_normal_name_for_type ctxt T = quot_normal_prefix ^ YXML.content_of (Syntax.string_of_typ ctxt T) val strip_first_name_sep = Substring.full #> Substring.position name_sep ##> Substring.triml 1 #> apply2 Substring.string fun original_name s = if String.isPrefix nitpick_prefix s then case strip_first_name_sep s of (s1, "") => s1 | (_, s2) => original_name s2 else s fun s_conj (t1, \<^const>\True\) = t1 | s_conj (\<^const>\True\, t2) = t2 | s_conj (t1, t2) = if t1 = \<^const>\False\ orelse t2 = \<^const>\False\ then \<^const>\False\ else HOLogic.mk_conj (t1, t2) fun s_disj (t1, \<^const>\False\) = t1 | s_disj (\<^const>\False\, t2) = t2 | s_disj (t1, t2) = if t1 = \<^const>\True\ orelse t2 = \<^const>\True\ then \<^const>\True\ else HOLogic.mk_disj (t1, t2) fun strip_connective conn_t (t as (t0 $ t1 $ t2)) = if t0 = conn_t then strip_connective t0 t2 @ strip_connective t0 t1 else [t] | strip_connective _ t = [t] fun strip_any_connective (t as (t0 $ _ $ _)) = if t0 = \<^const>\HOL.conj\ orelse t0 = \<^const>\HOL.disj\ then (strip_connective t0 t, t0) else ([t], \<^const>\Not\) | strip_any_connective t = ([t], \<^const>\Not\) val conjuncts_of = strip_connective \<^const>\HOL.conj\ val disjuncts_of = strip_connective \<^const>\HOL.disj\ (* When you add constants to these lists, make sure to handle them in "Nitpick_Nut.nut_from_term", and perhaps in "Nitpick_Mono.consider_term" as well. *) val built_in_consts = [(\<^const_name>\Pure.all\, 1), (\<^const_name>\Pure.eq\, 2), (\<^const_name>\Pure.imp\, 2), (\<^const_name>\Pure.conjunction\, 2), (\<^const_name>\Trueprop\, 1), (\<^const_name>\Not\, 1), (\<^const_name>\False\, 0), (\<^const_name>\True\, 0), (\<^const_name>\All\, 1), (\<^const_name>\Ex\, 1), (\<^const_name>\HOL.eq\, 1), (\<^const_name>\HOL.conj\, 2), (\<^const_name>\HOL.disj\, 2), (\<^const_name>\HOL.implies\, 2), (\<^const_name>\If\, 3), (\<^const_name>\Let\, 2), (\<^const_name>\Pair\, 2), (\<^const_name>\fst\, 1), (\<^const_name>\snd\, 1), (\<^const_name>\Set.member\, 2), (\<^const_name>\Collect\, 1), (\<^const_name>\Id\, 0), (\<^const_name>\converse\, 1), (\<^const_name>\trancl\, 1), (\<^const_name>\relcomp\, 2), (\<^const_name>\finite\, 1), (\<^const_name>\unknown\, 0), (\<^const_name>\is_unknown\, 1), (\<^const_name>\safe_The\, 1), (\<^const_name>\Frac\, 0), (\<^const_name>\norm_frac\, 0), (\<^const_name>\Suc\, 0), (\<^const_name>\nat\, 0), (\<^const_name>\nat_gcd\, 0), (\<^const_name>\nat_lcm\, 0)] val built_in_typed_consts = [((\<^const_name>\zero_class.zero\, nat_T), 0), ((\<^const_name>\one_class.one\, nat_T), 0), ((\<^const_name>\plus_class.plus\, nat_T --> nat_T --> nat_T), 0), ((\<^const_name>\minus_class.minus\, nat_T --> nat_T --> nat_T), 0), ((\<^const_name>\times_class.times\, nat_T --> nat_T --> nat_T), 0), ((\<^const_name>\Rings.divide\, nat_T --> nat_T --> nat_T), 0), ((\<^const_name>\ord_class.less\, nat_T --> nat_T --> bool_T), 2), ((\<^const_name>\ord_class.less_eq\, nat_T --> nat_T --> bool_T), 2), ((\<^const_name>\of_nat\, nat_T --> int_T), 0), ((\<^const_name>\zero_class.zero\, int_T), 0), ((\<^const_name>\one_class.one\, int_T), 0), ((\<^const_name>\plus_class.plus\, int_T --> int_T --> int_T), 0), ((\<^const_name>\minus_class.minus\, int_T --> int_T --> int_T), 0), ((\<^const_name>\times_class.times\, int_T --> int_T --> int_T), 0), ((\<^const_name>\Rings.divide\, int_T --> int_T --> int_T), 0), ((\<^const_name>\uminus_class.uminus\, int_T --> int_T), 0), ((\<^const_name>\ord_class.less\, int_T --> int_T --> bool_T), 2), ((\<^const_name>\ord_class.less_eq\, int_T --> int_T --> bool_T), 2)] fun unarize_type \<^typ>\unsigned_bit word\ = nat_T | unarize_type \<^typ>\signed_bit word\ = int_T | unarize_type (Type (s, Ts as _ :: _)) = Type (s, map unarize_type Ts) | unarize_type T = T fun unarize_unbox_etc_type (Type (\<^type_name>\fun_box\, Ts)) = unarize_unbox_etc_type (Type (\<^type_name>\fun\, Ts)) | unarize_unbox_etc_type (Type (\<^type_name>\pair_box\, Ts)) = Type (\<^type_name>\prod\, map unarize_unbox_etc_type Ts) | unarize_unbox_etc_type \<^typ>\unsigned_bit word\ = nat_T | unarize_unbox_etc_type \<^typ>\signed_bit word\ = int_T | unarize_unbox_etc_type (Type (s, Ts as _ :: _)) = Type (s, map unarize_unbox_etc_type Ts) | unarize_unbox_etc_type T = T fun uniterize_type (Type (s, Ts as _ :: _)) = Type (s, map uniterize_type Ts) | uniterize_type \<^typ>\bisim_iterator\ = nat_T | uniterize_type T = T val uniterize_unarize_unbox_etc_type = uniterize_type o unarize_unbox_etc_type fun string_for_type ctxt = Syntax.string_of_typ ctxt o unarize_unbox_etc_type fun pretty_for_type ctxt = Syntax.pretty_typ ctxt o unarize_unbox_etc_type val prefix_name = Long_Name.qualify o Long_Name.base_name val shortest_name = Long_Name.base_name val prefix_abs_vars = Term.map_abs_vars o prefix_name fun short_name s = case space_explode name_sep s of [_] => s |> String.isPrefix nitpick_prefix s ? unprefix nitpick_prefix | ss => map shortest_name ss |> space_implode "_" fun shorten_names_in_type (Type (s, Ts)) = Type (short_name s, map shorten_names_in_type Ts) | shorten_names_in_type T = T val shorten_names_in_term = map_aterms (fn Const (s, T) => Const (short_name s, T) | t => t) #> map_types shorten_names_in_type fun strict_type_match thy (T1, T2) = (Sign.typ_match thy (T2, T1) Vartab.empty; true) handle Type.TYPE_MATCH => false fun type_match thy = strict_type_match thy o apply2 unarize_unbox_etc_type fun const_match thy ((s1, T1), (s2, T2)) = s1 = s2 andalso type_match thy (T1, T2) fun term_match thy (Const x1, Const x2) = const_match thy (x1, x2) | term_match thy (Free (s1, T1), Free (s2, T2)) = const_match thy ((shortest_name s1, T1), (shortest_name s2, T2)) | term_match _ (t1, t2) = t1 aconv t2 fun frac_from_term_pair T t1 t2 = case snd (HOLogic.dest_number t1) of 0 => HOLogic.mk_number T 0 | n1 => case snd (HOLogic.dest_number t2) of 1 => HOLogic.mk_number T n1 | n2 => Const (\<^const_name>\divide\, T --> T --> T) $ HOLogic.mk_number T n1 $ HOLogic.mk_number T n2 fun is_fun_type (Type (\<^type_name>\fun\, _)) = true | is_fun_type _ = false fun is_set_type (Type (\<^type_name>\set\, _)) = true | is_set_type _ = false val is_fun_or_set_type = is_fun_type orf is_set_type fun is_set_like_type (Type (\<^type_name>\fun\, [_, T'])) = (body_type T' = bool_T) | is_set_like_type (Type (\<^type_name>\set\, _)) = true | is_set_like_type _ = false fun is_pair_type (Type (\<^type_name>\prod\, _)) = true | is_pair_type _ = false fun is_lfp_iterator_type (Type (s, _)) = String.isPrefix lfp_iterator_prefix s | is_lfp_iterator_type _ = false fun is_gfp_iterator_type (Type (s, _)) = String.isPrefix gfp_iterator_prefix s | is_gfp_iterator_type _ = false val is_fp_iterator_type = is_lfp_iterator_type orf is_gfp_iterator_type fun is_iterator_type T = (T = \<^typ>\bisim_iterator\ orelse is_fp_iterator_type T) fun is_boolean_type T = (T = prop_T orelse T = bool_T) fun is_integer_type T = (T = nat_T orelse T = int_T) fun is_bit_type T = (T = \<^typ>\unsigned_bit\ orelse T = \<^typ>\signed_bit\) fun is_word_type (Type (\<^type_name>\word\, _)) = true | is_word_type _ = false val is_integer_like_type = is_iterator_type orf is_integer_type orf is_word_type fun is_frac_type ctxt (Type (s, [])) = s |> AList.defined (op =) (#frac_types (Data.get (Context.Proof ctxt))) | is_frac_type _ _ = false fun is_number_type ctxt = is_integer_like_type orf is_frac_type ctxt fun is_higher_order_type (Type (\<^type_name>\fun\, _)) = true | is_higher_order_type (Type (\<^type_name>\set\, _)) = true | is_higher_order_type (Type (_, Ts)) = exists is_higher_order_type Ts | is_higher_order_type _ = false fun elem_type (Type (\<^type_name>\set\, [T'])) = T' | elem_type T = raise TYPE ("Nitpick_HOL.elem_type", [T], []) fun pseudo_domain_type (Type (\<^type_name>\fun\, [T1, _])) = T1 | pseudo_domain_type T = elem_type T fun pseudo_range_type (Type (\<^type_name>\fun\, [_, T2])) = T2 | pseudo_range_type (Type (\<^type_name>\set\, _)) = bool_T | pseudo_range_type T = raise TYPE ("Nitpick_HOL.pseudo_range_type", [T], []) fun iterator_type_for_const gfp (s, T) = Type ((if gfp then gfp_iterator_prefix else lfp_iterator_prefix) ^ s, binder_types T) fun const_for_iterator_type (Type (s, Ts)) = (strip_first_name_sep s |> snd, Ts ---> bool_T) | const_for_iterator_type T = raise TYPE ("Nitpick_HOL.const_for_iterator_type", [T], []) fun strip_n_binders 0 T = ([], T) | strip_n_binders n (Type (\<^type_name>\fun\, [T1, T2])) = strip_n_binders (n - 1) T2 |>> cons T1 | strip_n_binders n (Type (\<^type_name>\fun_box\, Ts)) = strip_n_binders n (Type (\<^type_name>\fun\, Ts)) | strip_n_binders _ T = raise TYPE ("Nitpick_HOL.strip_n_binders", [T], []) val nth_range_type = snd oo strip_n_binders fun num_factors_in_type (Type (\<^type_name>\prod\, [T1, T2])) = fold (Integer.add o num_factors_in_type) [T1, T2] 0 | num_factors_in_type _ = 1 val curried_binder_types = maps HOLogic.flatten_tupleT o binder_types fun maybe_curried_binder_types T = (if is_pair_type (body_type T) then binder_types else curried_binder_types) T fun mk_flat_tuple _ [t] = t | mk_flat_tuple (Type (\<^type_name>\prod\, [T1, T2])) (t :: ts) = HOLogic.pair_const T1 T2 $ t $ (mk_flat_tuple T2 ts) | mk_flat_tuple T ts = raise TYPE ("Nitpick_HOL.mk_flat_tuple", [T], ts) fun dest_n_tuple 1 t = [t] | dest_n_tuple n t = HOLogic.dest_prod t ||> dest_n_tuple (n - 1) |> op :: fun typedef_info ctxt s = if is_frac_type ctxt (Type (s, [])) then SOME {abs_type = Type (s, []), rep_type = \<^typ>\int * int\, Abs_name = \<^const_name>\Abs_Frac\, Rep_name = \<^const_name>\Rep_Frac\, prop_of_Rep = \<^prop>\Rep_Frac x \ Collect Frac\ |> Logic.varify_global, Abs_inverse = NONE, Rep_inverse = NONE} else case Typedef.get_info ctxt s of (* When several entries are returned, it shouldn't matter much which one we take (according to Florian Haftmann). *) (* The "Logic.varifyT_global" calls are a temporary hack because these types's type variables sometimes clash with locally fixed type variables. Remove these calls once "Typedef" is fully localized. *) ({abs_type, rep_type, Abs_name, Rep_name, ...}, {Rep, Abs_inverse, Rep_inverse, ...}) :: _ => SOME {abs_type = Logic.varifyT_global abs_type, rep_type = Logic.varifyT_global rep_type, Abs_name = Abs_name, Rep_name = Rep_name, prop_of_Rep = Thm.prop_of Rep, Abs_inverse = SOME Abs_inverse, Rep_inverse = SOME Rep_inverse} | _ => NONE val is_raw_typedef = is_some oo typedef_info val is_raw_free_datatype = is_some oo Ctr_Sugar.ctr_sugar_of val is_interpreted_type = member (op =) [\<^type_name>\prod\, \<^type_name>\set\, \<^type_name>\bool\, \<^type_name>\nat\, \<^type_name>\int\, \<^type_name>\natural\, \<^type_name>\integer\] fun repair_constr_type (Type (_, Ts)) T = snd (dest_Const (Ctr_Sugar.mk_ctr Ts (Const (Name.uu, T)))) fun register_frac_type_generic frac_s ersaetze generic = let val {frac_types, ersatz_table, codatatypes} = Data.get generic val frac_types = AList.update (op =) (frac_s, ersaetze) frac_types in Data.put {frac_types = frac_types, ersatz_table = ersatz_table, codatatypes = codatatypes} generic end (* TODO: Consider morphism. *) fun register_frac_type frac_s ersaetze (_ : morphism) = register_frac_type_generic frac_s ersaetze val register_frac_type_global = Context.theory_map oo register_frac_type_generic fun unregister_frac_type_generic frac_s = register_frac_type_generic frac_s [] (* TODO: Consider morphism. *) fun unregister_frac_type frac_s (_ : morphism) = unregister_frac_type_generic frac_s val unregister_frac_type_global = Context.theory_map o unregister_frac_type_generic fun register_ersatz_generic ersatz generic = let val {frac_types, ersatz_table, codatatypes} = Data.get generic val ersatz_table = AList.merge (op =) (K true) (ersatz_table, ersatz) in Data.put {frac_types = frac_types, ersatz_table = ersatz_table, codatatypes = codatatypes} generic end (* TODO: Consider morphism. *) fun register_ersatz ersatz (_ : morphism) = register_ersatz_generic ersatz val register_ersatz_global = Context.theory_map o register_ersatz_generic fun register_codatatype_generic coT case_name constr_xs generic = let val {frac_types, ersatz_table, codatatypes} = Data.get generic val constr_xs = map (apsnd (repair_constr_type coT)) constr_xs val (co_s, coTs) = dest_Type coT val _ = if forall is_TFree coTs andalso not (has_duplicates (op =) coTs) andalso co_s <> \<^type_name>\fun\ andalso not (is_interpreted_type co_s) then () else raise TYPE ("Nitpick_HOL.register_codatatype_generic", [coT], []) val codatatypes = AList.update (op =) (co_s, (case_name, constr_xs)) codatatypes in Data.put {frac_types = frac_types, ersatz_table = ersatz_table, codatatypes = codatatypes} generic end (* TODO: Consider morphism. *) fun register_codatatype coT case_name constr_xs (_ : morphism) = register_codatatype_generic coT case_name constr_xs val register_codatatype_global = Context.theory_map ooo register_codatatype_generic fun unregister_codatatype_generic coT = register_codatatype_generic coT "" [] (* TODO: Consider morphism. *) fun unregister_codatatype coT (_ : morphism) = unregister_codatatype_generic coT val unregister_codatatype_global = Context.theory_map o unregister_codatatype_generic fun is_raw_codatatype ctxt s = Option.map #fp (BNF_FP_Def_Sugar.fp_sugar_of ctxt s) = SOME BNF_Util.Greatest_FP fun is_registered_codatatype ctxt s = not (null (these (Option.map snd (AList.lookup (op =) (#codatatypes (Data.get (Context.Proof ctxt))) s)))) fun is_codatatype ctxt (Type (s, _)) = is_raw_codatatype ctxt s orelse is_registered_codatatype ctxt s | is_codatatype _ _ = false fun is_registered_type ctxt (T as Type (s, _)) = is_frac_type ctxt T orelse is_registered_codatatype ctxt s | is_registered_type _ _ = false fun is_raw_quot_type ctxt (Type (s, _)) = is_some (Quotient_Info.lookup_quotients ctxt s) | is_raw_quot_type _ _ = false fun is_quot_type ctxt T = is_raw_quot_type ctxt T andalso not (is_registered_type ctxt T) andalso T <> \<^typ>\int\ fun is_pure_typedef ctxt (T as Type (s, _)) = is_frac_type ctxt T orelse (is_raw_typedef ctxt s andalso not (is_raw_free_datatype ctxt s orelse is_raw_quot_type ctxt T orelse is_codatatype ctxt T orelse is_integer_like_type T)) | is_pure_typedef _ _ = false fun is_univ_typedef ctxt (Type (s, _)) = (case typedef_info ctxt s of SOME {prop_of_Rep, ...} => let val t_opt = try (snd o HOLogic.dest_mem o HOLogic.dest_Trueprop) prop_of_Rep in case t_opt of SOME (Const (\<^const_name>\top\, _)) => true (* "Multiset.multiset" FIXME unchecked *) | SOME (Const (\<^const_name>\Collect\, _) $ Abs (_, _, Const (\<^const_name>\finite\, _) $ _)) => true (* "FinFun.finfun" FIXME unchecked *) | SOME (Const (\<^const_name>\Collect\, _) $ Abs (_, _, Const (\<^const_name>\Ex\, _) $ Abs (_, _, Const (\<^const_name>\finite\, _) $ _))) => true | _ => false end | NONE => false) | is_univ_typedef _ _ = false fun is_data_type ctxt (T as Type (s, _)) = (is_raw_typedef ctxt s orelse is_registered_type ctxt T orelse T = \<^typ>\ind\ orelse is_raw_quot_type ctxt T) andalso not (is_interpreted_type s) | is_data_type _ _ = false fun all_record_fields thy T = let val (recs, more) = Record.get_extT_fields thy T in recs @ more :: all_record_fields thy (snd more) end handle TYPE _ => [] val num_record_fields = Integer.add 1 o length o fst oo Record.get_extT_fields fun no_of_record_field thy s T1 = find_index (curry (op =) s o fst) (Record.get_extT_fields thy T1 ||> single |> op @) fun is_record_get thy (s, Type (\<^type_name>\fun\, [T1, _])) = exists (curry (op =) s o fst) (all_record_fields thy T1) | is_record_get _ _ = false fun is_record_update thy (s, T) = String.isSuffix Record.updateN s andalso exists (curry (op =) (unsuffix Record.updateN s) o fst) (all_record_fields thy (body_type T)) handle TYPE _ => false fun is_abs_fun ctxt (s, Type (\<^type_name>\fun\, [_, Type (s', _)])) = (case typedef_info ctxt s' of SOME {Abs_name, ...} => s = Abs_name | NONE => false) | is_abs_fun _ _ = false fun is_rep_fun ctxt (s, Type (\<^type_name>\fun\, [Type (s', _), _])) = (case typedef_info ctxt s' of SOME {Rep_name, ...} => s = Rep_name | NONE => false) | is_rep_fun _ _ = false fun is_quot_abs_fun ctxt (x as (_, Type (\<^type_name>\fun\, [_, abs_T as Type (s', _)]))) = try (Quotient_Term.absrep_const_chk ctxt Quotient_Term.AbsF) s' = SOME (Const x) andalso not (is_registered_type ctxt abs_T) | is_quot_abs_fun _ _ = false fun is_quot_rep_fun ctxt (s, Type (\<^type_name>\fun\, [abs_T as Type (abs_s, _), _])) = (case try (Quotient_Term.absrep_const_chk ctxt Quotient_Term.RepF) abs_s of SOME (Const (s', _)) => s = s' andalso not (is_registered_type ctxt abs_T) | _ => false) | is_quot_rep_fun _ _ = false fun mate_of_rep_fun ctxt (x as (_, Type (\<^type_name>\fun\, [T1 as Type (s', _), T2]))) = (case typedef_info ctxt s' of SOME {Abs_name, ...} => (Abs_name, Type (\<^type_name>\fun\, [T2, T1])) | NONE => raise TERM ("Nitpick_HOL.mate_of_rep_fun", [Const x])) | mate_of_rep_fun _ x = raise TERM ("Nitpick_HOL.mate_of_rep_fun", [Const x]) fun rep_type_for_quot_type ctxt (T as Type (s, _)) = let val thy = Proof_Context.theory_of ctxt val {qtyp, rtyp, ...} = the (Quotient_Info.lookup_quotients ctxt s) in instantiate_type thy qtyp T rtyp end | rep_type_for_quot_type _ T = raise TYPE ("Nitpick_HOL.rep_type_for_quot_type", [T], []) fun equiv_relation_for_quot_type thy (Type (s, Ts)) = let val {qtyp, equiv_rel, equiv_thm, ...} = the (Quotient_Info.lookup_quotients thy s) val partial = case Thm.prop_of equiv_thm of \<^const>\Trueprop\ $ (Const (\<^const_name>\equivp\, _) $ _) => false | \<^const>\Trueprop\ $ (Const (\<^const_name>\part_equivp\, _) $ _) => true | _ => raise NOT_SUPPORTED "Ill-formed quotient type equivalence \ \relation theorem" val Ts' = qtyp |> dest_Type |> snd in (subst_atomic_types (Ts' ~~ Ts) equiv_rel, partial) end | equiv_relation_for_quot_type _ T = raise TYPE ("Nitpick_HOL.equiv_relation_for_quot_type", [T], []) fun is_raw_free_datatype_constr ctxt (s, T) = case body_type T of dtT as Type (dt_s, _) => let val ctrs = case Ctr_Sugar.ctr_sugar_of ctxt dt_s of SOME {ctrs, ...} => map dest_Const ctrs | _ => [] in exists (fn (s', T') => s = s' andalso repair_constr_type dtT T' = T) ctrs end | _ => false fun is_registered_coconstr ctxt (s, T) = case body_type T of coT as Type (co_s, _) => let val ctrs = co_s |> AList.lookup (op =) (#codatatypes (Data.get (Context.Proof ctxt))) |> Option.map snd |> these in exists (fn (s', T') => s = s' andalso repair_constr_type coT T' = T) ctrs end | _ => false fun is_nonfree_constr ctxt (s, T) = member (op =) [\<^const_name>\FunBox\, \<^const_name>\PairBox\, \<^const_name>\Quot\, \<^const_name>\Zero_Rep\, \<^const_name>\Suc_Rep\] s orelse let val (x as (_, T)) = (s, unarize_unbox_etc_type T) in is_raw_free_datatype_constr ctxt x orelse (is_abs_fun ctxt x andalso is_pure_typedef ctxt (range_type T)) orelse is_registered_coconstr ctxt x end fun is_free_constr ctxt (s, T) = is_nonfree_constr ctxt (s, T) andalso let val (x as (_, T)) = (s, unarize_unbox_etc_type T) in not (is_abs_fun ctxt x) orelse is_univ_typedef ctxt (range_type T) end fun is_stale_constr ctxt (x as (s, T)) = is_registered_type ctxt (body_type T) andalso is_nonfree_constr ctxt x andalso not (s = \<^const_name>\Abs_Frac\ orelse is_registered_coconstr ctxt x) fun is_constr ctxt (x as (_, T)) = is_nonfree_constr ctxt x andalso not (is_interpreted_type (fst (dest_Type (unarize_type (body_type T))))) andalso not (is_stale_constr ctxt x) val is_sel = String.isPrefix discr_prefix orf String.isPrefix sel_prefix val is_sel_like_and_no_discr = String.isPrefix sel_prefix orf (member (op =) [\<^const_name>\fst\, \<^const_name>\snd\]) fun in_fun_lhs_for InConstr = InSel | in_fun_lhs_for _ = InFunLHS fun in_fun_rhs_for InConstr = InConstr | in_fun_rhs_for InSel = InSel | in_fun_rhs_for InFunRHS1 = InFunRHS2 | in_fun_rhs_for _ = InFunRHS1 fun is_boxing_worth_it (hol_ctxt : hol_context) boxy T = case T of Type (\<^type_name>\fun\, _) => (boxy = InPair orelse boxy = InFunLHS) andalso not (is_boolean_type (body_type T)) | Type (\<^type_name>\prod\, Ts) => boxy = InPair orelse boxy = InFunRHS1 orelse boxy = InFunRHS2 orelse ((boxy = InExpr orelse boxy = InFunLHS) andalso exists (is_boxing_worth_it hol_ctxt InPair) (map (box_type hol_ctxt InPair) Ts)) | _ => false and should_box_type (hol_ctxt as {thy, boxes, ...}) boxy z = case triple_lookup (type_match thy) boxes (Type z) of SOME (SOME box_me) => box_me | _ => is_boxing_worth_it hol_ctxt boxy (Type z) and box_type hol_ctxt boxy T = case T of Type (z as (\<^type_name>\fun\, [T1, T2])) => if boxy <> InConstr andalso boxy <> InSel andalso should_box_type hol_ctxt boxy z then Type (\<^type_name>\fun_box\, [box_type hol_ctxt InFunLHS T1, box_type hol_ctxt InFunRHS1 T2]) else box_type hol_ctxt (in_fun_lhs_for boxy) T1 --> box_type hol_ctxt (in_fun_rhs_for boxy) T2 | Type (z as (\<^type_name>\prod\, Ts)) => if boxy <> InConstr andalso boxy <> InSel andalso should_box_type hol_ctxt boxy z then Type (\<^type_name>\pair_box\, map (box_type hol_ctxt InSel) Ts) else Type (\<^type_name>\prod\, map (box_type hol_ctxt (if boxy = InConstr orelse boxy = InSel then boxy else InPair)) Ts) | _ => T fun binarize_nat_and_int_in_type \<^typ>\nat\ = \<^typ>\unsigned_bit word\ | binarize_nat_and_int_in_type \<^typ>\int\ = \<^typ>\signed_bit word\ | binarize_nat_and_int_in_type (Type (s, Ts)) = Type (s, map binarize_nat_and_int_in_type Ts) | binarize_nat_and_int_in_type T = T val binarize_nat_and_int_in_term = map_types binarize_nat_and_int_in_type fun discr_for_constr (s, T) = (discr_prefix ^ s, body_type T --> bool_T) fun num_sels_for_constr_type T = length (maybe_curried_binder_types T) fun nth_sel_name_for_constr_name s n = if s = \<^const_name>\Pair\ then if n = 0 then \<^const_name>\fst\ else \<^const_name>\snd\ else sel_prefix_for n ^ s fun nth_sel_for_constr x ~1 = discr_for_constr x | nth_sel_for_constr (s, T) n = (nth_sel_name_for_constr_name s n, body_type T --> nth (maybe_curried_binder_types T) n) fun binarized_and_boxed_nth_sel_for_constr hol_ctxt binarize = apsnd ((binarize ? binarize_nat_and_int_in_type) o box_type hol_ctxt InSel) oo nth_sel_for_constr fun sel_no_from_name s = if String.isPrefix discr_prefix s then ~1 else if String.isPrefix sel_prefix s then s |> unprefix sel_prefix |> Int.fromString |> the else if s = \<^const_name>\snd\ then 1 else 0 val close_form = let fun close_up zs zs' = fold (fn (z as ((s, _), T)) => fn t' => Logic.all_const T $ Abs (s, T, abstract_over (Var z, t'))) (take (length zs' - length zs) zs') fun aux zs (\<^const>\Pure.imp\ $ t1 $ t2) = let val zs' = Term.add_vars t1 zs in close_up zs zs' (Logic.mk_implies (t1, aux zs' t2)) end | aux zs t = close_up zs (Term.add_vars t zs) t in aux [] end fun distinctness_formula T = all_distinct_unordered_pairs_of #> map (fn (t1, t2) => \<^const>\Not\ $ (HOLogic.eq_const T $ t1 $ t2)) #> List.foldr (s_conj o swap) \<^const>\True\ fun zero_const T = Const (\<^const_name>\zero_class.zero\, T) fun suc_const T = Const (\<^const_name>\Suc\, T --> T) fun uncached_data_type_constrs ({ctxt, ...} : hol_context) (T as Type (s, _)) = if is_interpreted_type s then [] else (case AList.lookup (op =) (#codatatypes (Data.get (Context.Proof ctxt))) s of SOME (_, xs' as (_ :: _)) => map (apsnd (repair_constr_type T)) xs' | _ => if is_frac_type ctxt T then case typedef_info ctxt s of SOME {abs_type, rep_type, Abs_name, ...} => [(Abs_name, varify_and_instantiate_type ctxt abs_type T rep_type --> T)] | NONE => [] (* impossible *) else case Ctr_Sugar.ctr_sugar_of ctxt s of SOME {ctrs, ...} => map (apsnd (repair_constr_type T) o dest_Const) ctrs | NONE => if is_raw_quot_type ctxt T then [(\<^const_name>\Quot\, rep_type_for_quot_type ctxt T --> T)] else case typedef_info ctxt s of SOME {abs_type, rep_type, Abs_name, ...} => [(Abs_name, varify_and_instantiate_type ctxt abs_type T rep_type --> T)] | NONE => if T = \<^typ>\ind\ then [dest_Const \<^const>\Zero_Rep\, dest_Const \<^const>\Suc_Rep\] else []) | uncached_data_type_constrs _ _ = [] fun data_type_constrs (hol_ctxt as {constr_cache, ...}) T = case AList.lookup (op =) (!constr_cache) T of SOME xs => xs | NONE => let val xs = uncached_data_type_constrs hol_ctxt T in (Unsynchronized.change constr_cache (cons (T, xs)); xs) end fun binarized_and_boxed_data_type_constrs hol_ctxt binarize = map (apsnd ((binarize ? binarize_nat_and_int_in_type) o box_type hol_ctxt InConstr)) o data_type_constrs hol_ctxt fun constr_name_for_sel_like \<^const_name>\fst\ = \<^const_name>\Pair\ | constr_name_for_sel_like \<^const_name>\snd\ = \<^const_name>\Pair\ | constr_name_for_sel_like s' = original_name s' fun binarized_and_boxed_constr_for_sel hol_ctxt binarize (s', T') = let val s = constr_name_for_sel_like s' in AList.lookup (op =) (binarized_and_boxed_data_type_constrs hol_ctxt binarize (domain_type T')) s |> the |> pair s end fun card_of_type assigns (Type (\<^type_name>\fun\, [T1, T2])) = reasonable_power (card_of_type assigns T2) (card_of_type assigns T1) | card_of_type assigns (Type (\<^type_name>\prod\, [T1, T2])) = card_of_type assigns T1 * card_of_type assigns T2 | card_of_type assigns (Type (\<^type_name>\set\, [T'])) = reasonable_power 2 (card_of_type assigns T') | card_of_type _ (Type (\<^type_name>\itself\, _)) = 1 | card_of_type _ \<^typ>\prop\ = 2 | card_of_type _ \<^typ>\bool\ = 2 | card_of_type assigns T = case AList.lookup (op =) assigns T of SOME k => k | NONE => if T = \<^typ>\bisim_iterator\ then 0 else raise TYPE ("Nitpick_HOL.card_of_type", [T], []) fun bounded_card_of_type max default_card assigns (Type (\<^type_name>\fun\, [T1, T2])) = let val k1 = bounded_card_of_type max default_card assigns T1 val k2 = bounded_card_of_type max default_card assigns T2 in if k1 = max orelse k2 = max then max else Int.min (max, reasonable_power k2 k1) handle TOO_LARGE _ => max end | bounded_card_of_type max default_card assigns (Type (\<^type_name>\prod\, [T1, T2])) = let val k1 = bounded_card_of_type max default_card assigns T1 val k2 = bounded_card_of_type max default_card assigns T2 in if k1 = max orelse k2 = max then max else Int.min (max, k1 * k2) end | bounded_card_of_type max default_card assigns (Type (\<^type_name>\set\, [T'])) = bounded_card_of_type max default_card assigns (T' --> bool_T) | bounded_card_of_type max default_card assigns T = Int.min (max, if default_card = ~1 then card_of_type assigns T else card_of_type assigns T handle TYPE ("Nitpick_HOL.card_of_type", _, _) => default_card) (* Similar to "ATP_Util.tiny_card_of_type". *) fun bounded_exact_card_of_type hol_ctxt finitizable_dataTs max default_card assigns T = let fun aux avoid T = (if member (op =) avoid T then 0 else if member (op =) finitizable_dataTs T then raise SAME () else case T of Type (\<^type_name>\fun\, [T1, T2]) => (case (aux avoid T1, aux avoid T2) of (_, 1) => 1 | (0, _) => 0 | (_, 0) => 0 | (k1, k2) => if k1 >= max orelse k2 >= max then max else Int.min (max, reasonable_power k2 k1)) | Type (\<^type_name>\prod\, [T1, T2]) => (case (aux avoid T1, aux avoid T2) of (0, _) => 0 | (_, 0) => 0 | (k1, k2) => if k1 >= max orelse k2 >= max then max else Int.min (max, k1 * k2)) | Type (\<^type_name>\set\, [T']) => aux avoid (T' --> bool_T) | Type (\<^type_name>\itself\, _) => 1 | \<^typ>\prop\ => 2 | \<^typ>\bool\ => 2 | Type _ => (case data_type_constrs hol_ctxt T of [] => if is_integer_type T orelse is_bit_type T then 0 else raise SAME () | constrs => let val constr_cards = map (Integer.prod o map (aux (T :: avoid)) o binder_types o snd) constrs in if exists (curry (op =) 0) constr_cards then 0 else Int.min (max, Integer.sum constr_cards) end) | _ => raise SAME ()) handle SAME () => AList.lookup (op =) assigns T |> the_default default_card in Int.min (max, aux [] T) end val typical_atomic_card = 4 val typical_card_of_type = bounded_card_of_type 16777217 typical_atomic_card [] fun is_finite_type hol_ctxt T = bounded_exact_card_of_type hol_ctxt [] 1 2 [] T > 0 fun is_special_eligible_arg strict Ts t = case map snd (Term.add_vars t []) @ map (nth Ts) (loose_bnos t) of [] => true | bad_Ts => let val bad_Ts_cost = if strict then fold (curry (op *) o typical_card_of_type) bad_Ts 1 else fold (Integer.max o typical_card_of_type) bad_Ts 0 val T_cost = typical_card_of_type (fastype_of1 (Ts, t)) in (bad_Ts_cost, T_cost) |> (if strict then op < else op <=) end fun abs_var ((s, j), T) body = Abs (s, T, abstract_over (Var ((s, j), T), body)) fun let_var s = (nitpick_prefix ^ s, 999) val let_inline_threshold = 20 fun s_let Ts s n abs_T body_T f t = if (n - 1) * (size_of_term t - 1) <= let_inline_threshold orelse is_special_eligible_arg false Ts t then f t else let val z = (let_var s, abs_T) in Const (\<^const_name>\Let\, abs_T --> (abs_T --> body_T) --> body_T) $ t $ abs_var z (incr_boundvars 1 (f (Var z))) end fun loose_bvar1_count (Bound i, k) = if i = k then 1 else 0 | loose_bvar1_count (t1 $ t2, k) = loose_bvar1_count (t1, k) + loose_bvar1_count (t2, k) | loose_bvar1_count (Abs (_, _, t), k) = loose_bvar1_count (t, k + 1) | loose_bvar1_count _ = 0 fun s_betapply _ (t1 as Const (\<^const_name>\Pure.eq\, _) $ t1', t2) = if t1' aconv t2 then \<^prop>\True\ else t1 $ t2 | s_betapply _ (t1 as Const (\<^const_name>\HOL.eq\, _) $ t1', t2) = if t1' aconv t2 then \<^term>\True\ else t1 $ t2 | s_betapply _ (Const (\<^const_name>\If\, _) $ \<^const>\True\ $ t1', _) = t1' | s_betapply _ (Const (\<^const_name>\If\, _) $ \<^const>\False\ $ _, t2) = t2 | s_betapply Ts (Const (\<^const_name>\Let\, Type (_, [bound_T, Type (_, [_, body_T])])) $ t12 $ Abs (s, T, t13'), t2) = let val body_T' = range_type body_T in Const (\<^const_name>\Let\, bound_T --> (bound_T --> body_T') --> body_T') $ t12 $ Abs (s, T, s_betapply (T :: Ts) (t13', incr_boundvars 1 t2)) end | s_betapply Ts (t1 as Abs (s1, T1, t1'), t2) = (s_let Ts s1 (loose_bvar1_count (t1', 0)) T1 (fastype_of1 (T1 :: Ts, t1')) (curry betapply t1) t2 (* FIXME: fix all "s_betapply []" calls *) handle TERM _ => betapply (t1, t2) | General.Subscript => betapply (t1, t2)) | s_betapply _ (t1, t2) = t1 $ t2 fun s_betapplys Ts = Library.foldl (s_betapply Ts) fun s_beta_norm Ts t = let fun aux _ (Var _) = raise Same.SAME | aux Ts (Abs (s, T, t')) = Abs (s, T, aux (T :: Ts) t') | aux Ts ((t1 as Abs _) $ t2) = Same.commit (aux Ts) (s_betapply Ts (t1, t2)) | aux Ts (t1 $ t2) = ((case aux Ts t1 of t1 as Abs _ => Same.commit (aux Ts) (s_betapply Ts (t1, t2)) | t1 => t1 $ Same.commit (aux Ts) t2) handle Same.SAME => t1 $ aux Ts t2) | aux _ _ = raise Same.SAME in aux Ts t handle Same.SAME => t end fun discr_term_for_constr hol_ctxt (x as (s, T)) = let val dataT = body_type T in if s = \<^const_name>\Suc\ then Abs (Name.uu, dataT, \<^const>\Not\ $ HOLogic.mk_eq (zero_const dataT, Bound 0)) else if length (data_type_constrs hol_ctxt dataT) >= 2 then Const (discr_for_constr x) else Abs (Name.uu, dataT, \<^const>\True\) end fun discriminate_value (hol_ctxt as {ctxt, ...}) x t = case head_of t of Const x' => if x = x' then \<^const>\True\ else if is_nonfree_constr ctxt x' then \<^const>\False\ else s_betapply [] (discr_term_for_constr hol_ctxt x, t) | _ => s_betapply [] (discr_term_for_constr hol_ctxt x, t) fun nth_arg_sel_term_for_constr (x as (s, T)) n = let val (arg_Ts, dataT) = strip_type T in if dataT = nat_T then \<^term>\%n::nat. n - 1\ else if is_pair_type dataT then Const (nth_sel_for_constr x n) else let fun aux m (Type (\<^type_name>\prod\, [T1, T2])) = let val (m, t1) = aux m T1 val (m, t2) = aux m T2 in (m, HOLogic.mk_prod (t1, t2)) end | aux m T = (m + 1, Const (nth_sel_name_for_constr_name s m, dataT --> T) $ Bound 0) val m = fold (Integer.add o num_factors_in_type) (List.take (arg_Ts, n)) 0 in Abs ("x", dataT, aux m (nth arg_Ts n) |> snd) end end fun select_nth_constr_arg ctxt x t n res_T = (case strip_comb t of (Const x', args) => if x = x' then if is_free_constr ctxt x then nth args n else raise SAME () else if is_nonfree_constr ctxt x' then Const (\<^const_name>\unknown\, res_T) else raise SAME () | _ => raise SAME()) handle SAME () => s_betapply [] (nth_arg_sel_term_for_constr x n, t) fun construct_value _ x [] = Const x | construct_value ctxt (x as (s, _)) args = let val args = map Envir.eta_contract args in case hd args of Const (s', _) $ t => if is_sel_like_and_no_discr s' andalso constr_name_for_sel_like s' = s andalso forall (fn (n, t') => select_nth_constr_arg ctxt x t n dummyT = t') (index_seq 0 (length args) ~~ args) then t else list_comb (Const x, args) | _ => list_comb (Const x, args) end fun constr_expand (hol_ctxt as {ctxt, ...}) T t = (case head_of t of Const x => if is_nonfree_constr ctxt x then t else raise SAME () | _ => raise SAME ()) handle SAME () => let val x' as (_, T') = if is_pair_type T then let val (T1, T2) = HOLogic.dest_prodT T in (\<^const_name>\Pair\, T1 --> T2 --> T) end else data_type_constrs hol_ctxt T |> hd val arg_Ts = binder_types T' in list_comb (Const x', map2 (select_nth_constr_arg ctxt x' t) (index_seq 0 (length arg_Ts)) arg_Ts) end fun coerce_bound_no f j t = case t of t1 $ t2 => coerce_bound_no f j t1 $ coerce_bound_no f j t2 | Abs (s, T, t') => Abs (s, T, coerce_bound_no f (j + 1) t') | Bound j' => if j' = j then f t else t | _ => t fun coerce_bound_0_in_term hol_ctxt new_T old_T = old_T <> new_T ? coerce_bound_no (coerce_term hol_ctxt [new_T] old_T new_T) 0 and coerce_term (hol_ctxt as {ctxt, ...}) Ts new_T old_T t = if old_T = new_T then t else case (new_T, old_T) of (Type (new_s, new_Ts as [new_T1, new_T2]), Type (\<^type_name>\fun\, [old_T1, old_T2])) => (case eta_expand Ts t 1 of Abs (s, _, t') => Abs (s, new_T1, t' |> coerce_bound_0_in_term hol_ctxt new_T1 old_T1 |> coerce_term hol_ctxt (new_T1 :: Ts) new_T2 old_T2) |> Envir.eta_contract |> new_s <> \<^type_name>\fun\ ? construct_value ctxt (\<^const_name>\FunBox\, Type (\<^type_name>\fun\, new_Ts) --> new_T) o single | t' => raise TERM ("Nitpick_HOL.coerce_term", [t'])) | (Type (new_s, new_Ts as [new_T1, new_T2]), Type (old_s, old_Ts as [old_T1, old_T2])) => if old_s = \<^type_name>\fun_box\ orelse old_s = \<^type_name>\pair_box\ orelse old_s = \<^type_name>\prod\ then case constr_expand hol_ctxt old_T t of Const (old_s, _) $ t1 => if new_s = \<^type_name>\fun\ then coerce_term hol_ctxt Ts new_T (Type (\<^type_name>\fun\, old_Ts)) t1 else construct_value ctxt (old_s, Type (\<^type_name>\fun\, new_Ts) --> new_T) [coerce_term hol_ctxt Ts (Type (\<^type_name>\fun\, new_Ts)) (Type (\<^type_name>\fun\, old_Ts)) t1] | Const _ $ t1 $ t2 => construct_value ctxt (if new_s = \<^type_name>\prod\ then \<^const_name>\Pair\ else \<^const_name>\PairBox\, new_Ts ---> new_T) (@{map 3} (coerce_term hol_ctxt Ts) [new_T1, new_T2] [old_T1, old_T2] [t1, t2]) | t' => raise TERM ("Nitpick_HOL.coerce_term", [t']) else raise TYPE ("Nitpick_HOL.coerce_term", [new_T, old_T], [t]) | _ => raise TYPE ("Nitpick_HOL.coerce_term", [new_T, old_T], [t]) fun is_ground_term (t1 $ t2) = is_ground_term t1 andalso is_ground_term t2 | is_ground_term (Const _) = true | is_ground_term _ = false fun special_bounds ts = fold Term.add_vars ts [] |> sort (Term_Ord.fast_indexname_ord o apply2 fst) fun is_funky_typedef_name ctxt s = member (op =) [\<^type_name>\unit\, \<^type_name>\prod\, \<^type_name>\set\, \<^type_name>\Sum_Type.sum\, \<^type_name>\int\] s orelse is_frac_type ctxt (Type (s, [])) fun is_funky_typedef ctxt (Type (s, _)) = is_funky_typedef_name ctxt s | is_funky_typedef _ _ = false fun all_defs_of thy subst = let val def_names = thy |> Theory.defs_of |> Defs.all_specifications_of |> maps snd |> map_filter #def |> Ord_List.make fast_string_ord in Thm.all_axioms_of thy |> map (apsnd (subst_atomic subst o Thm.prop_of)) |> sort (fast_string_ord o apply2 fst) |> Ord_List.inter (fast_string_ord o apsnd fst) def_names |> map snd end (* Ideally we would check against "Complex_Main", not "Hilbert_Choice", but any theory will do as long as it contains all the "axioms" and "axiomatization" commands. *) fun is_built_in_theory thy_id = Context.subthy_id (thy_id, Context.theory_id \<^theory>\Hilbert_Choice\) fun all_nondefs_of ctxt subst = ctxt |> Spec_Rules.get - |> filter (Spec_Rules.is_unknown o fst) - |> maps (snd o snd) + |> filter (Spec_Rules.is_unknown o #rough_classification) + |> maps #rules |> filter_out (is_built_in_theory o Thm.theory_id) |> map (subst_atomic subst o Thm.prop_of) fun arity_of_built_in_const (s, T) = if s = \<^const_name>\If\ then if nth_range_type 3 T = \<^typ>\bool\ then NONE else SOME 3 else case AList.lookup (op =) built_in_consts s of SOME n => SOME n | NONE => case AList.lookup (op =) built_in_typed_consts (s, unarize_type T) of SOME n => SOME n | NONE => case s of \<^const_name>\zero_class.zero\ => if is_iterator_type T then SOME 0 else NONE | \<^const_name>\Suc\ => if is_iterator_type (domain_type T) then SOME 0 else NONE | _ => NONE val is_built_in_const = is_some o arity_of_built_in_const (* This function is designed to work for both real definition axioms and simplification rules (equational specifications). *) fun term_under_def t = case t of \<^const>\Pure.imp\ $ _ $ t2 => term_under_def t2 | Const (\<^const_name>\Pure.eq\, _) $ t1 $ _ => term_under_def t1 | \<^const>\Trueprop\ $ t1 => term_under_def t1 | Const (\<^const_name>\HOL.eq\, _) $ t1 $ _ => term_under_def t1 | Abs (_, _, t') => term_under_def t' | t1 $ _ => term_under_def t1 | _ => t (* Here we crucially rely on "specialize_type" performing a preorder traversal of the term, without which the wrong occurrence of a constant could be matched in the face of overloading. *) fun def_props_for_const thy table (x as (s, _)) = if is_built_in_const x then [] else these (Symtab.lookup table s) |> map_filter (try (specialize_type thy x)) |> filter (curry (op =) (Const x) o term_under_def) fun normalized_rhs_of t = let fun aux (v as Var _) (SOME t) = SOME (lambda v t) | aux (c as Const (\<^const_name>\Pure.type\, _)) (SOME t) = SOME (lambda c t) | aux _ _ = NONE val (lhs, rhs) = case t of Const (\<^const_name>\Pure.eq\, _) $ t1 $ t2 => (t1, t2) | \<^const>\Trueprop\ $ (Const (\<^const_name>\HOL.eq\, _) $ t1 $ t2) => (t1, t2) | _ => raise TERM ("Nitpick_HOL.normalized_rhs_of", [t]) val args = strip_comb lhs |> snd in fold_rev aux args (SOME rhs) end fun get_def_of_const thy table (x as (s, _)) = x |> def_props_for_const thy table |> List.last |> normalized_rhs_of |> Option.map (prefix_abs_vars s) handle List.Empty => NONE | TERM _ => NONE fun def_of_const_ext thy (unfold_table, fallback_table) (x as (s, _)) = if is_built_in_const x orelse original_name s <> s then NONE else case get_def_of_const thy unfold_table x of SOME def => SOME (true, def) | NONE => get_def_of_const thy fallback_table x |> Option.map (pair false) val def_of_const = Option.map snd ooo def_of_const_ext fun fixpoint_kind_of_rhs (Abs (_, _, t)) = fixpoint_kind_of_rhs t | fixpoint_kind_of_rhs (Const (\<^const_name>\lfp\, _) $ Abs _) = Lfp | fixpoint_kind_of_rhs (Const (\<^const_name>\gfp\, _) $ Abs _) = Gfp | fixpoint_kind_of_rhs _ = NoFp fun is_mutually_inductive_pred_def thy table t = let fun is_good_arg (Bound _) = true | is_good_arg (Const (s, _)) = s = \<^const_name>\True\ orelse s = \<^const_name>\False\ orelse s = \<^const_name>\undefined\ | is_good_arg _ = false in case t |> strip_abs_body |> strip_comb of (Const x, ts as (_ :: _)) => (case def_of_const thy table x of SOME t' => fixpoint_kind_of_rhs t' <> NoFp andalso forall is_good_arg ts | NONE => false) | _ => false end fun unfold_mutually_inductive_preds thy table = map_aterms (fn t as Const x => (case def_of_const thy table x of SOME t' => let val t' = Envir.eta_contract t' in if is_mutually_inductive_pred_def thy table t' then t' else t end | NONE => t) | t => t) fun case_const_names ctxt = map_filter (fn {casex = Const (s, T), ...} => (case rev (binder_types T) of [] => NONE | T :: Ts => if is_data_type ctxt T then SOME (s, length Ts) else NONE)) (Ctr_Sugar.ctr_sugars_of ctxt) @ map (apsnd length o snd) (#codatatypes (Data.get (Context.Proof ctxt))) fun fixpoint_kind_of_const thy table x = if is_built_in_const x then NoFp else fixpoint_kind_of_rhs (the (def_of_const thy table x)) handle Option.Option => NoFp fun is_raw_inductive_pred ({thy, def_tables, intro_table, ...} : hol_context) x = fixpoint_kind_of_const thy def_tables x <> NoFp andalso not (null (def_props_for_const thy intro_table x)) fun is_inductive_pred hol_ctxt (x as (s, _)) = String.isPrefix ubfp_prefix s orelse String.isPrefix lbfp_prefix s orelse is_raw_inductive_pred hol_ctxt x fun lhs_of_equation t = case t of Const (\<^const_name>\Pure.all\, _) $ Abs (_, _, t1) => lhs_of_equation t1 | Const (\<^const_name>\Pure.eq\, _) $ t1 $ _ => SOME t1 | \<^const>\Pure.imp\ $ _ $ t2 => lhs_of_equation t2 | \<^const>\Trueprop\ $ t1 => lhs_of_equation t1 | Const (\<^const_name>\All\, _) $ Abs (_, _, t1) => lhs_of_equation t1 | Const (\<^const_name>\HOL.eq\, _) $ t1 $ _ => SOME t1 | \<^const>\HOL.implies\ $ _ $ t2 => lhs_of_equation t2 | _ => NONE fun is_constr_pattern _ (Bound _) = true | is_constr_pattern _ (Var _) = true | is_constr_pattern ctxt t = case strip_comb t of (Const x, args) => is_nonfree_constr ctxt x andalso forall (is_constr_pattern ctxt) args | _ => false fun is_constr_pattern_lhs ctxt t = forall (is_constr_pattern ctxt) (snd (strip_comb t)) fun is_constr_pattern_formula ctxt t = case lhs_of_equation t of SOME t' => is_constr_pattern_lhs ctxt t' | NONE => false (* Similar to "specialize_type" but returns all matches rather than only the first (preorder) match. *) fun multi_specialize_type thy slack (s, T) t = let fun aux (Const (s', T')) ys = if s = s' then ys |> (if AList.defined (op =) ys T' then I else cons (T', Envir.subst_term_types (Sign.typ_match thy (T', T) Vartab.empty) t) handle Type.TYPE_MATCH => I | TERM _ => if slack then I else raise NOT_SUPPORTED ("too much polymorphism in axiom \"" ^ Syntax.string_of_term_global thy t ^ "\" involving " ^ quote s)) else ys | aux _ ys = ys in map snd (fold_aterms aux t []) end fun nondef_props_for_const thy slack table (x as (s, _)) = these (Symtab.lookup table s) |> maps (multi_specialize_type thy slack x) fun unvarify_term (t1 $ t2) = unvarify_term t1 $ unvarify_term t2 | unvarify_term (Var ((s, 0), T)) = Free (s, T) | unvarify_term (Abs (s, T, t')) = Abs (s, T, unvarify_term t') | unvarify_term t = t fun axiom_for_choice_spec ctxt = unvarify_term #> Object_Logic.atomize_term ctxt #> Choice_Specification.close_form #> HOLogic.mk_Trueprop fun is_choice_spec_fun ({thy, ctxt, def_tables, nondef_table, choice_spec_table, ...} : hol_context) x = case nondef_props_for_const thy true choice_spec_table x of [] => false | ts => case def_of_const thy def_tables x of SOME (Const (\<^const_name>\Eps\, _) $ _) => true | SOME _ => false | NONE => let val ts' = nondef_props_for_const thy true nondef_table x in length ts' = length ts andalso forall (fn t => exists (curry (op aconv) (axiom_for_choice_spec ctxt t)) ts') ts end fun is_choice_spec_axiom thy choice_spec_table t = Symtab.exists (exists (curry (op aconv) t o axiom_for_choice_spec thy) o snd) choice_spec_table fun is_raw_equational_fun ({thy, simp_table, psimp_table, ...} : hol_context) x = exists (fn table => not (null (def_props_for_const thy table x))) [!simp_table, psimp_table] fun is_equational_fun hol_ctxt = is_raw_equational_fun hol_ctxt orf is_inductive_pred hol_ctxt (** Constant unfolding **) fun constr_case_body ctxt Ts (func_t, (x as (_, T))) = let val arg_Ts = binder_types T in s_betapplys Ts (func_t, map2 (select_nth_constr_arg ctxt x (Bound 0)) (index_seq 0 (length arg_Ts)) arg_Ts) end fun add_constr_case res_T (body_t, guard_t) res_t = if res_T = bool_T then s_conj (HOLogic.mk_imp (guard_t, body_t), res_t) else Const (\<^const_name>\If\, bool_T --> res_T --> res_T --> res_T) $ guard_t $ body_t $ res_t fun optimized_case_def (hol_ctxt as {ctxt, ...}) Ts dataT res_T func_ts = let val xs = data_type_constrs hol_ctxt dataT val cases = func_ts ~~ xs |> map (fn (func_t, x) => (constr_case_body ctxt (dataT :: Ts) (incr_boundvars 1 func_t, x), discriminate_value hol_ctxt x (Bound 0))) |> AList.group (op aconv) |> map (apsnd (List.foldl s_disj \<^const>\False\)) |> sort (int_ord o apply2 (size_of_term o snd)) |> rev in if res_T = bool_T then if forall (member (op =) [\<^const>\False\, \<^const>\True\] o fst) cases then case cases of [(body_t, _)] => body_t | [_, (\<^const>\True\, head_t2)] => head_t2 | [_, (\<^const>\False\, head_t2)] => \<^const>\Not\ $ head_t2 | _ => raise BAD ("Nitpick_HOL.optimized_case_def", "impossible cases") else \<^const>\True\ |> fold_rev (add_constr_case res_T) cases else fst (hd cases) |> fold_rev (add_constr_case res_T) (tl cases) end |> absdummy dataT fun optimized_record_get (hol_ctxt as {thy, ctxt, ...}) s rec_T res_T t = let val constr_x = hd (data_type_constrs hol_ctxt rec_T) in case no_of_record_field thy s rec_T of ~1 => (case rec_T of Type (_, Ts as _ :: _) => let val rec_T' = List.last Ts val j = num_record_fields thy rec_T - 1 in select_nth_constr_arg ctxt constr_x t j res_T |> optimized_record_get hol_ctxt s rec_T' res_T end | _ => raise TYPE ("Nitpick_HOL.optimized_record_get", [rec_T], [])) | j => select_nth_constr_arg ctxt constr_x t j res_T end fun optimized_record_update (hol_ctxt as {thy, ctxt, ...}) s rec_T fun_t rec_t = let val constr_x as (_, constr_T) = hd (data_type_constrs hol_ctxt rec_T) val Ts = binder_types constr_T val n = length Ts val special_j = no_of_record_field thy s rec_T val ts = map2 (fn j => fn T => let val t = select_nth_constr_arg ctxt constr_x rec_t j T in if j = special_j then s_betapply [] (fun_t, t) else if j = n - 1 andalso special_j = ~1 then optimized_record_update hol_ctxt s (rec_T |> dest_Type |> snd |> List.last) fun_t t else t end) (index_seq 0 n) Ts in list_comb (Const constr_x, ts) end (* Prevents divergence in case of cyclic or infinite definition dependencies. *) val unfold_max_depth = 255 (* Inline definitions or define as an equational constant? Booleans tend to benefit more from inlining, due to the polarity analysis. (However, if "total_consts" is set, the polarity analysis is likely not to be so crucial.) *) val def_inline_threshold_for_booleans = 60 val def_inline_threshold_for_non_booleans = 20 fun unfold_defs_in_term (hol_ctxt as {thy, ctxt, whacks, total_consts, case_names, def_tables, ground_thm_table, ersatz_table, ...}) = let fun do_numeral depth Ts mult T some_t0 t1 t2 = (if is_number_type ctxt T then let val j = mult * HOLogic.dest_numeral t2 in if j = 1 then raise SAME () else let val s = numeral_prefix ^ signed_string_of_int j in if is_integer_like_type T then Const (s, T) else do_term depth Ts (Const (\<^const_name>\of_int\, int_T --> T) $ Const (s, int_T)) end end handle TERM _ => raise SAME () else raise SAME ()) handle SAME () => (case some_t0 of NONE => s_betapply [] (do_term depth Ts t1, do_term depth Ts t2) | SOME t0 => s_betapply [] (do_term depth Ts t0, s_betapply [] (do_term depth Ts t1, do_term depth Ts t2))) and do_term depth Ts t = case t of (t0 as Const (\<^const_name>\uminus\, _) $ ((t1 as Const (\<^const_name>\numeral\, Type (\<^type_name>\fun\, [_, ran_T]))) $ t2)) => do_numeral depth Ts ~1 ran_T (SOME t0) t1 t2 | (t1 as Const (\<^const_name>\numeral\, Type (\<^type_name>\fun\, [_, ran_T]))) $ t2 => do_numeral depth Ts 1 ran_T NONE t1 t2 | Const (\<^const_name>\refl_on\, T) $ Const (\<^const_name>\top\, _) $ t2 => do_const depth Ts t (\<^const_name>\refl'\, range_type T) [t2] | (t0 as Const (\<^const_name>\Sigma\, Type (_, [T1, Type (_, [T2, T3])]))) $ t1 $ (t2 as Abs (_, _, t2')) => if loose_bvar1 (t2', 0) then s_betapplys Ts (do_term depth Ts t0, map (do_term depth Ts) [t1, t2]) else do_term depth Ts (Const (\<^const_name>\prod\, T1 --> range_type T2 --> T3) $ t1 $ incr_boundvars ~1 t2') | Const (x as (\<^const_name>\distinct\, Type (\<^type_name>\fun\, [Type (\<^type_name>\list\, [T']), _]))) $ (t1 as _ $ _) => (t1 |> HOLogic.dest_list |> distinctness_formula T' handle TERM _ => do_const depth Ts t x [t1]) | Const (x as (\<^const_name>\If\, _)) $ t1 $ t2 $ t3 => if is_ground_term t1 andalso exists (Pattern.matches thy o rpair t1) (Inttab.lookup_list ground_thm_table (hash_term t1)) then do_term depth Ts t2 else do_const depth Ts t x [t1, t2, t3] | Const (\<^const_name>\Let\, _) $ t1 $ t2 => s_betapply Ts (apply2 (do_term depth Ts) (t2, t1)) | Const x => do_const depth Ts t x [] | t1 $ t2 => (case strip_comb t of (Const x, ts) => do_const depth Ts t x ts | _ => s_betapply [] (do_term depth Ts t1, do_term depth Ts t2)) | Bound _ => t | Abs (s, T, body) => Abs (s, T, do_term depth (T :: Ts) body) | _ => if member (term_match thy) whacks t then Const (\<^const_name>\unknown\, fastype_of1 (Ts, t)) else t and select_nth_constr_arg_with_args _ _ (x as (_, T)) [] n res_T = (Abs (Name.uu, body_type T, select_nth_constr_arg ctxt x (Bound 0) n res_T), []) | select_nth_constr_arg_with_args depth Ts x (t :: ts) n res_T = (select_nth_constr_arg ctxt x (do_term depth Ts t) n res_T, ts) and quot_rep_of depth Ts abs_T rep_T ts = select_nth_constr_arg_with_args depth Ts (\<^const_name>\Quot\, rep_T --> abs_T) ts 0 rep_T and do_const depth Ts t (x as (s, T)) ts = if member (term_match thy) whacks (Const x) then Const (\<^const_name>\unknown\, fastype_of1 (Ts, t)) else case AList.lookup (op =) ersatz_table s of SOME s' => do_const (depth + 1) Ts (list_comb (Const (s', T), ts)) (s', T) ts | NONE => let fun def_inline_threshold () = if is_boolean_type (body_type T) andalso total_consts <> SOME true then def_inline_threshold_for_booleans else def_inline_threshold_for_non_booleans val (const, ts) = if is_built_in_const x then (Const x, ts) else case AList.lookup (op =) case_names s of SOME n => if length ts < n then (do_term depth Ts (eta_expand Ts t (n - length ts)), []) else let val (dataT, res_T) = nth_range_type n T |> pairf domain_type range_type in (optimized_case_def hol_ctxt Ts dataT res_T (map (do_term depth Ts) (take n ts)), drop n ts) end | _ => if is_constr ctxt x then (Const x, ts) else if is_stale_constr ctxt x then raise NOT_SUPPORTED ("(non-co)constructors of codatatypes \ \(\"" ^ s ^ "\")") else if is_quot_abs_fun ctxt x then case T of Type (\<^type_name>\fun\, [rep_T, abs_T as Type (abs_s, _)]) => if is_interpreted_type abs_s then raise NOT_SUPPORTED ("abstraction function on " ^ quote abs_s) else (Abs (Name.uu, rep_T, Const (\<^const_name>\Quot\, rep_T --> abs_T) $ (Const (quot_normal_name_for_type ctxt abs_T, rep_T --> rep_T) $ Bound 0)), ts) else if is_quot_rep_fun ctxt x then case T of Type (\<^type_name>\fun\, [abs_T as Type (abs_s, _), rep_T]) => if is_interpreted_type abs_s then raise NOT_SUPPORTED ("representation function on " ^ quote abs_s) else quot_rep_of depth Ts abs_T rep_T ts else if is_record_get thy x then case length ts of 0 => (do_term depth Ts (eta_expand Ts t 1), []) | _ => (optimized_record_get hol_ctxt s (domain_type T) (range_type T) (do_term depth Ts (hd ts)), tl ts) else if is_record_update thy x then case length ts of 2 => (optimized_record_update hol_ctxt (unsuffix Record.updateN s) (nth_range_type 2 T) (do_term depth Ts (hd ts)) (do_term depth Ts (nth ts 1)), []) | n => (do_term depth Ts (eta_expand Ts t (2 - n)), []) else if is_abs_fun ctxt x andalso is_quot_type ctxt (range_type T) then let val abs_T = range_type T val rep_T = elem_type (domain_type T) val eps_fun = Const (\<^const_name>\Eps\, (rep_T --> bool_T) --> rep_T) val normal_fun = Const (quot_normal_name_for_type ctxt abs_T, rep_T --> rep_T) val abs_fun = Const (\<^const_name>\Quot\, rep_T --> abs_T) val pred = Abs (Name.uu, rep_T, Const (\<^const_name>\Set.member\, rep_T --> domain_type T --> bool_T) $ Bound 0 $ Bound 1) in (Abs (Name.uu, HOLogic.mk_setT rep_T, abs_fun $ (normal_fun $ (eps_fun $ pred))) |> do_term (depth + 1) Ts, ts) end else if is_rep_fun ctxt x then let val x' = mate_of_rep_fun ctxt x in if is_constr ctxt x' then select_nth_constr_arg_with_args depth Ts x' ts 0 (range_type T) else if is_quot_type ctxt (domain_type T) then let val abs_T = domain_type T val rep_T = elem_type (range_type T) val (rep_fun, _) = quot_rep_of depth Ts abs_T rep_T [] val (equiv_rel, _) = equiv_relation_for_quot_type ctxt abs_T in (Abs (Name.uu, abs_T, HOLogic.Collect_const rep_T $ (equiv_rel $ (rep_fun $ Bound 0))), ts) end else (Const x, ts) end else if is_equational_fun hol_ctxt x orelse is_choice_spec_fun hol_ctxt x then (Const x, ts) else case def_of_const_ext thy def_tables x of SOME (unfold, def) => if depth > unfold_max_depth then raise TOO_LARGE ("Nitpick_HOL.unfold_defs_in_term", "too many nested definitions (" ^ string_of_int depth ^ ") while expanding " ^ quote s) else if s = \<^const_name>\wfrec'\ then (do_term (depth + 1) Ts (s_betapplys Ts (def, ts)), []) else if not unfold andalso size_of_term def > def_inline_threshold () then (Const x, ts) else (do_term (depth + 1) Ts def, ts) | NONE => (Const x, ts) in s_betapplys Ts (const, map (do_term depth Ts) ts) |> s_beta_norm Ts end in do_term 0 [] end (** Axiom extraction/generation **) fun extensional_equal j T t1 t2 = if is_fun_type T then let val dom_T = pseudo_domain_type T val ran_T = pseudo_range_type T val var_t = Var (("x", j), dom_T) in extensional_equal (j + 1) ran_T (betapply (t1, var_t)) (betapply (t2, var_t)) end else Const (\<^const_name>\HOL.eq\, T --> T --> bool_T) $ t1 $ t2 (* FIXME: needed? *) fun equationalize_term ctxt tag t = let val j = maxidx_of_term t + 1 val (prems, concl) = Logic.strip_horn t in Logic.list_implies (prems, case concl of \<^const>\Trueprop\ $ (Const (\<^const_name>\HOL.eq\, Type (_, [T, _])) $ t1 $ t2) => \<^const>\Trueprop\ $ extensional_equal j T t1 t2 | \<^const>\Trueprop\ $ t' => \<^const>\Trueprop\ $ HOLogic.mk_eq (t', \<^const>\True\) | Const (\<^const_name>\Pure.eq\, Type (_, [T, _])) $ t1 $ t2 => \<^const>\Trueprop\ $ extensional_equal j T t1 t2 | _ => (warning ("Ignoring " ^ quote tag ^ " for non-equation " ^ quote (Syntax.string_of_term ctxt t)); raise SAME ())) |> SOME end handle SAME () => NONE fun pair_for_prop t = case term_under_def t of Const (s, _) => (s, t) | t' => raise TERM ("Nitpick_HOL.pair_for_prop", [t, t']) fun def_table_for ts subst = ts |> map (pair_for_prop o subst_atomic subst) |> AList.group (op =) |> Symtab.make fun const_def_tables ctxt subst ts = (def_table_for (map Thm.prop_of (rev (Named_Theorems.get ctxt \<^named_theorems>\nitpick_unfold\))) subst, fold (fn (s, t) => Symtab.map_default (s, []) (cons t)) (map pair_for_prop ts) Symtab.empty) fun paired_with_consts t = map (rpair t) (Term.add_const_names t []) fun const_nondef_table ts = fold (append o paired_with_consts) ts [] |> AList.group (op =) |> Symtab.make fun const_simp_table ctxt = def_table_for (map_filter (equationalize_term ctxt "nitpick_simp" o Thm.prop_of) (rev (Named_Theorems.get ctxt \<^named_theorems>\nitpick_simp\))) fun const_psimp_table ctxt = def_table_for (map_filter (equationalize_term ctxt "nitpick_psimp" o Thm.prop_of) (rev (Named_Theorems.get ctxt \<^named_theorems>\nitpick_psimp\))) fun const_choice_spec_table ctxt subst = map (subst_atomic subst o Thm.prop_of) (rev (Named_Theorems.get ctxt \<^named_theorems>\nitpick_choice_spec\)) |> const_nondef_table fun inductive_intro_table ctxt subst def_tables = let val thy = Proof_Context.theory_of ctxt in def_table_for - (maps (map (unfold_mutually_inductive_preds thy def_tables o Thm.prop_of) - o snd o snd) - (filter ((Spec_Rules.is_inductive orf Spec_Rules.is_co_inductive) o #1) - (Spec_Rules.get ctxt))) subst + (maps (map (unfold_mutually_inductive_preds thy def_tables o Thm.prop_of) o #rules) + (filter (Spec_Rules.is_relational o #rough_classification) + (Spec_Rules.get ctxt))) subst end fun ground_theorem_table thy = fold ((fn \<^const>\Trueprop\ $ t1 => is_ground_term t1 ? Inttab.map_default (hash_term t1, []) (cons t1) | _ => I) o Thm.prop_of o snd) (Global_Theory.all_thms_of thy true) Inttab.empty fun ersatz_table ctxt = #ersatz_table (Data.get (Context.Proof ctxt)) |> fold (append o snd) (#frac_types (Data.get (Context.Proof ctxt))) fun add_simps simp_table s eqs = Unsynchronized.change simp_table (Symtab.update (s, eqs @ these (Symtab.lookup (!simp_table) s))) fun inverse_axioms_for_rep_fun ctxt (x as (_, T)) = let val thy = Proof_Context.theory_of ctxt val abs_T = domain_type T in typedef_info ctxt (fst (dest_Type abs_T)) |> the |> pairf #Abs_inverse #Rep_inverse |> apply2 (specialize_type thy x o Thm.prop_of o the) ||> single |> op :: end fun optimized_typedef_axioms ctxt (abs_z as (abs_s, _)) = let val thy = Proof_Context.theory_of ctxt val abs_T = Type abs_z in if is_univ_typedef ctxt abs_T then [] else case typedef_info ctxt abs_s of SOME {abs_type, rep_type, Rep_name, prop_of_Rep, ...} => let val rep_T = varify_and_instantiate_type ctxt abs_type abs_T rep_type val rep_t = Const (Rep_name, abs_T --> rep_T) val set_t = prop_of_Rep |> HOLogic.dest_Trueprop |> specialize_type thy (dest_Const rep_t) |> HOLogic.dest_mem |> snd in [HOLogic.all_const abs_T $ Abs (Name.uu, abs_T, HOLogic.mk_mem (rep_t $ Bound 0, set_t)) |> HOLogic.mk_Trueprop] end | NONE => [] end fun optimized_quot_type_axioms ctxt abs_z = let val abs_T = Type abs_z val rep_T = rep_type_for_quot_type ctxt abs_T val (equiv_rel, partial) = equiv_relation_for_quot_type ctxt abs_T val a_var = Var (("a", 0), abs_T) val x_var = Var (("x", 0), rep_T) val y_var = Var (("y", 0), rep_T) val x = (\<^const_name>\Quot\, rep_T --> abs_T) val sel_a_t = select_nth_constr_arg ctxt x a_var 0 rep_T val normal_fun = Const (quot_normal_name_for_type ctxt abs_T, rep_T --> rep_T) val normal_x = normal_fun $ x_var val normal_y = normal_fun $ y_var val is_unknown_t = Const (\<^const_name>\is_unknown\, rep_T --> bool_T) in [Logic.mk_equals (normal_fun $ sel_a_t, sel_a_t), Logic.list_implies ([\<^const>\Not\ $ (is_unknown_t $ normal_x), \<^const>\Not\ $ (is_unknown_t $ normal_y), equiv_rel $ x_var $ y_var] |> map HOLogic.mk_Trueprop, Logic.mk_equals (normal_x, normal_y)), Logic.list_implies ([HOLogic.mk_Trueprop (\<^const>\Not\ $ (is_unknown_t $ normal_x)), HOLogic.mk_Trueprop (\<^const>\Not\ $ HOLogic.mk_eq (normal_x, x_var))], HOLogic.mk_Trueprop (equiv_rel $ x_var $ normal_x))] |> partial ? cons (HOLogic.mk_Trueprop (equiv_rel $ sel_a_t $ sel_a_t)) end fun codatatype_bisim_axioms (hol_ctxt as {ctxt, ...}) T = let val xs = data_type_constrs hol_ctxt T val pred_T = T --> bool_T val iter_T = \<^typ>\bisim_iterator\ val bisim_max = \<^const>\bisim_iterator_max\ val n_var = Var (("n", 0), iter_T) val n_var_minus_1 = Const (\<^const_name>\safe_The\, (iter_T --> bool_T) --> iter_T) $ Abs ("m", iter_T, HOLogic.eq_const iter_T $ (suc_const iter_T $ Bound 0) $ n_var) val x_var = Var (("x", 0), T) val y_var = Var (("y", 0), T) fun bisim_const T = Const (\<^const_name>\bisim\, [iter_T, T, T] ---> bool_T) fun nth_sub_bisim x n nth_T = (if is_codatatype ctxt nth_T then bisim_const nth_T $ n_var_minus_1 else HOLogic.eq_const nth_T) $ select_nth_constr_arg ctxt x x_var n nth_T $ select_nth_constr_arg ctxt x y_var n nth_T fun case_func (x as (_, T)) = let val arg_Ts = binder_types T val core_t = discriminate_value hol_ctxt x y_var :: map2 (nth_sub_bisim x) (index_seq 0 (length arg_Ts)) arg_Ts |> foldr1 s_conj in fold_rev absdummy arg_Ts core_t end in [HOLogic.mk_imp (HOLogic.mk_disj (HOLogic.eq_const iter_T $ n_var $ zero_const iter_T, s_betapply [] (optimized_case_def hol_ctxt [] T bool_T (map case_func xs), x_var)), bisim_const T $ n_var $ x_var $ y_var), HOLogic.eq_const pred_T $ (bisim_const T $ bisim_max $ x_var) $ Abs (Name.uu, T, HOLogic.mk_eq (x_var, Bound 0))] |> map HOLogic.mk_Trueprop end exception NO_TRIPLE of unit fun triple_for_intro_rule ctxt x t = let val prems = Logic.strip_imp_prems t |> map (Object_Logic.atomize_term ctxt) val concl = Logic.strip_imp_concl t |> Object_Logic.atomize_term ctxt val (main, side) = List.partition (exists_Const (curry (op =) x)) prems val is_good_head = curry (op =) (Const x) o head_of in if forall is_good_head main then (side, main, concl) else raise NO_TRIPLE () end val tuple_for_args = HOLogic.mk_tuple o snd o strip_comb fun wf_constraint_for rel side concl main = let val core = HOLogic.mk_mem (HOLogic.mk_prod (apply2 tuple_for_args (main, concl)), Var rel) val t = List.foldl HOLogic.mk_imp core side val vars = filter_out (curry (op =) rel) (Term.add_vars t []) in Library.foldl (fn (t', ((x, j), T)) => HOLogic.all_const T $ Abs (x, T, abstract_over (Var ((x, j), T), t'))) (t, vars) end fun wf_constraint_for_triple rel (side, main, concl) = map (wf_constraint_for rel side concl) main |> foldr1 s_conj fun terminates_by ctxt timeout goal tac = can (SINGLE (Classical.safe_tac ctxt) #> the #> SINGLE (DETERM_TIMEOUT timeout (tac ctxt (auto_tac ctxt))) #> the #> Goal.finish ctxt) goal val max_cached_wfs = 50 val cached_timeout = Synchronized.var "Nitpick_HOL.cached_timeout" Time.zeroTime val cached_wf_props = Synchronized.var "Nitpick_HOL.cached_wf_props" ([] : (term * bool) list) val termination_tacs = [Lexicographic_Order.lex_order_tac true, ScnpReconstruct.sizechange_tac] fun uncached_is_well_founded_inductive_pred ({thy, ctxt, debug, tac_timeout, intro_table, ...} : hol_context) (x as (_, T)) = case def_props_for_const thy intro_table x of [] => raise TERM ("Nitpick_HOL.uncached_is_well_founded_inductive", [Const x]) | intro_ts => (case map (triple_for_intro_rule ctxt x) intro_ts |> filter_out (null o #2) of [] => true | triples => let val binders_T = HOLogic.mk_tupleT (binder_types T) val rel_T = HOLogic.mk_setT (HOLogic.mk_prodT (binders_T, binders_T)) val j = fold Integer.max (map maxidx_of_term intro_ts) 0 + 1 val rel = (("R", j), rel_T) val prop = Const (\<^const_name>\wf\, rel_T --> bool_T) $ Var rel :: map (wf_constraint_for_triple rel) triples |> foldr1 s_conj |> HOLogic.mk_Trueprop val _ = if debug then writeln ("Wellfoundedness goal: " ^ Syntax.string_of_term ctxt prop) else () in if tac_timeout = Synchronized.value cached_timeout andalso length (Synchronized.value cached_wf_props) < max_cached_wfs then () else (Synchronized.change cached_wf_props (K []); Synchronized.change cached_timeout (K tac_timeout)); case AList.lookup (op =) (Synchronized.value cached_wf_props) prop of SOME wf => wf | NONE => let val goal = prop |> Thm.cterm_of ctxt |> Goal.init val wf = exists (terminates_by ctxt tac_timeout goal) termination_tacs in Synchronized.change cached_wf_props (cons (prop, wf)); wf end end) handle List.Empty => false | NO_TRIPLE () => false (* The type constraint below is a workaround for a Poly/ML crash. *) fun is_well_founded_inductive_pred (hol_ctxt as {thy, wfs, def_tables, wf_cache, ...} : hol_context) (x as (s, _)) = case triple_lookup (const_match thy) wfs x of SOME (SOME b) => b | _ => s = \<^const_name>\Nats\ orelse s = \<^const_name>\fold_graph'\ orelse case AList.lookup (op =) (!wf_cache) x of SOME (_, wf) => wf | NONE => let val gfp = (fixpoint_kind_of_const thy def_tables x = Gfp) val wf = uncached_is_well_founded_inductive_pred hol_ctxt x in Unsynchronized.change wf_cache (cons (x, (gfp, wf))); wf end fun ap_curry [_] _ t = t | ap_curry arg_Ts tuple_T t = let val n = length arg_Ts in fold_rev (Term.abs o pair "c") arg_Ts (incr_boundvars n t $ mk_flat_tuple tuple_T (map Bound (n - 1 downto 0))) end fun num_occs_of_bound_in_term j (t1 $ t2) = op + (apply2 (num_occs_of_bound_in_term j) (t1, t2)) | num_occs_of_bound_in_term j (Abs (_, _, t')) = num_occs_of_bound_in_term (j + 1) t' | num_occs_of_bound_in_term j (Bound j') = if j' = j then 1 else 0 | num_occs_of_bound_in_term _ _ = 0 val is_linear_inductive_pred_def = let fun do_disjunct j (Const (\<^const_name>\Ex\, _) $ Abs (_, _, t2)) = do_disjunct (j + 1) t2 | do_disjunct j t = case num_occs_of_bound_in_term j t of 0 => true | 1 => exists (curry (op =) (Bound j) o head_of) (conjuncts_of t) | _ => false fun do_lfp_def (Const (\<^const_name>\lfp\, _) $ t2) = let val (xs, body) = strip_abs t2 in case length xs of 1 => false | n => forall (do_disjunct (n - 1)) (disjuncts_of body) end | do_lfp_def _ = false in do_lfp_def o strip_abs_body end fun n_ptuple_paths 0 = [] | n_ptuple_paths 1 = [] | n_ptuple_paths n = [] :: map (cons 2) (n_ptuple_paths (n - 1)) val ap_n_split = HOLogic.mk_ptupleabs o n_ptuple_paths val linear_pred_base_and_step_rhss = let fun aux (Const (\<^const_name>\lfp\, _) $ t2) = let val (xs, body) = strip_abs t2 val arg_Ts = map snd (tl xs) val tuple_T = HOLogic.mk_tupleT arg_Ts val j = length arg_Ts fun repair_rec j (Const (\<^const_name>\Ex\, T1) $ Abs (s2, T2, t2')) = Const (\<^const_name>\Ex\, T1) $ Abs (s2, T2, repair_rec (j + 1) t2') | repair_rec j (\<^const>\HOL.conj\ $ t1 $ t2) = \<^const>\HOL.conj\ $ repair_rec j t1 $ repair_rec j t2 | repair_rec j t = let val (head, args) = strip_comb t in if head = Bound j then HOLogic.eq_const tuple_T $ Bound j $ mk_flat_tuple tuple_T args else t end val (nonrecs, recs) = List.partition (curry (op =) 0 o num_occs_of_bound_in_term j) (disjuncts_of body) val base_body = nonrecs |> List.foldl s_disj \<^const>\False\ val step_body = recs |> map (repair_rec j) |> List.foldl s_disj \<^const>\False\ in (fold_rev Term.abs (tl xs) (incr_bv (~1, j, base_body)) |> ap_n_split (length arg_Ts) tuple_T bool_T, Abs ("y", tuple_T, fold_rev Term.abs (tl xs) step_body |> ap_n_split (length arg_Ts) tuple_T bool_T)) end | aux t = raise TERM ("Nitpick_HOL.linear_pred_base_and_step_rhss.aux", [t]) in aux end fun predicatify T t = let val set_T = HOLogic.mk_setT T in Abs (Name.uu, T, Const (\<^const_name>\Set.member\, T --> set_T --> bool_T) $ Bound 0 $ incr_boundvars 1 t) end fun starred_linear_pred_const (hol_ctxt as {simp_table, ...}) (s, T) def = let val j = maxidx_of_term def + 1 val (outer, fp_app) = strip_abs def val outer_bounds = map Bound (length outer - 1 downto 0) val outer_vars = map (fn (s, T) => Var ((s, j), T)) outer val fp_app = subst_bounds (rev outer_vars, fp_app) val (outer_Ts, rest_T) = strip_n_binders (length outer) T val tuple_arg_Ts = strip_type rest_T |> fst val tuple_T = HOLogic.mk_tupleT tuple_arg_Ts val prod_T = HOLogic.mk_prodT (tuple_T, tuple_T) val set_T = HOLogic.mk_setT tuple_T val rel_T = HOLogic.mk_setT prod_T val pred_T = tuple_T --> bool_T val curried_T = tuple_T --> pred_T val uncurried_T = prod_T --> bool_T val (base_rhs, step_rhs) = linear_pred_base_and_step_rhss fp_app val base_x as (base_s, _) = (base_prefix ^ s, outer_Ts ---> pred_T) val base_eq = HOLogic.mk_eq (list_comb (Const base_x, outer_vars), base_rhs) |> HOLogic.mk_Trueprop val _ = add_simps simp_table base_s [base_eq] val step_x as (step_s, _) = (step_prefix ^ s, outer_Ts ---> curried_T) val step_eq = HOLogic.mk_eq (list_comb (Const step_x, outer_vars), step_rhs) |> HOLogic.mk_Trueprop val _ = add_simps simp_table step_s [step_eq] val image_const = Const (\<^const_name>\Image\, rel_T --> set_T --> set_T) val rtrancl_const = Const (\<^const_name>\rtrancl\, rel_T --> rel_T) val base_set = HOLogic.Collect_const tuple_T $ list_comb (Const base_x, outer_bounds) val step_set = HOLogic.Collect_const prod_T $ (Const (\<^const_name>\case_prod\, curried_T --> uncurried_T) $ list_comb (Const step_x, outer_bounds)) val image_set = image_const $ (rtrancl_const $ step_set) $ base_set |> predicatify tuple_T in fold_rev Term.abs outer (image_set |> ap_curry tuple_arg_Ts tuple_T) |> unfold_defs_in_term hol_ctxt end fun is_good_starred_linear_pred_type (Type (\<^type_name>\fun\, Ts)) = forall (not o (is_fun_or_set_type orf is_pair_type)) Ts | is_good_starred_linear_pred_type _ = false fun unrolled_inductive_pred_const (hol_ctxt as {thy, star_linear_preds, def_tables, simp_table, ...}) gfp (x as (s, T)) = let val iter_T = iterator_type_for_const gfp x val x' as (s', _) = (unrolled_prefix ^ s, iter_T --> T) val unrolled_const = Const x' $ zero_const iter_T val def = the (def_of_const thy def_tables x) in if is_equational_fun hol_ctxt x' then unrolled_const (* already done *) else if not gfp andalso star_linear_preds andalso is_linear_inductive_pred_def def andalso is_good_starred_linear_pred_type T then starred_linear_pred_const hol_ctxt x def else let val j = maxidx_of_term def + 1 val (outer, fp_app) = strip_abs def val outer_bounds = map Bound (length outer - 1 downto 0) val cur = Var ((iter_var_prefix, j + 1), iter_T) val next = suc_const iter_T $ cur val rhs = case fp_app of Const _ $ t => s_betapply [] (t, list_comb (Const x', next :: outer_bounds)) | _ => raise TERM ("Nitpick_HOL.unrolled_inductive_pred_const", [fp_app]) val (inner, naked_rhs) = strip_abs rhs val all = outer @ inner val bounds = map Bound (length all - 1 downto 0) val vars = map (fn (s, T) => Var ((s, j), T)) all val eq = HOLogic.mk_eq (list_comb (Const x', cur :: bounds), naked_rhs) |> HOLogic.mk_Trueprop |> curry subst_bounds (rev vars) val _ = add_simps simp_table s' [eq] in unrolled_const end end fun raw_inductive_pred_axiom ({thy, def_tables, ...} : hol_context) x = let val def = the (def_of_const thy def_tables x) val (outer, fp_app) = strip_abs def val outer_bounds = map Bound (length outer - 1 downto 0) val rhs = case fp_app of Const _ $ t => s_betapply [] (t, list_comb (Const x, outer_bounds)) | _ => raise TERM ("Nitpick_HOL.raw_inductive_pred_axiom", [fp_app]) val (inner, naked_rhs) = strip_abs rhs val all = outer @ inner val bounds = map Bound (length all - 1 downto 0) val j = maxidx_of_term def + 1 val vars = map (fn (s, T) => Var ((s, j), T)) all in HOLogic.mk_eq (list_comb (Const x, bounds), naked_rhs) |> HOLogic.mk_Trueprop |> curry subst_bounds (rev vars) end fun inductive_pred_axiom hol_ctxt (x as (s, T)) = if String.isPrefix ubfp_prefix s orelse String.isPrefix lbfp_prefix s then let val x' = (strip_first_name_sep s |> snd, T) in raw_inductive_pred_axiom hol_ctxt x' |> subst_atomic [(Const x', Const x)] end else raw_inductive_pred_axiom hol_ctxt x fun equational_fun_axioms (hol_ctxt as {thy, ctxt, def_tables, simp_table, psimp_table, ...}) x = case def_props_for_const thy (!simp_table) x of [] => (case def_props_for_const thy psimp_table x of [] => (if is_inductive_pred hol_ctxt x then [inductive_pred_axiom hol_ctxt x] else case def_of_const thy def_tables x of SOME def => \<^const>\Trueprop\ $ HOLogic.mk_eq (Const x, def) |> equationalize_term ctxt "" |> the |> single | NONE => []) | psimps => psimps) | simps => simps fun is_equational_fun_surely_complete hol_ctxt x = case equational_fun_axioms hol_ctxt x of [\<^const>\Trueprop\ $ (Const (\<^const_name>\HOL.eq\, _) $ t1 $ _)] => strip_comb t1 |> snd |> forall is_Var | _ => false (** Type preprocessing **) fun merged_type_var_table_for_terms thy ts = let fun add (s, S) table = table |> (case AList.lookup (Sign.subsort thy o swap) table S of SOME _ => I | NONE => filter_out (fn (S', _) => Sign.subsort thy (S, S')) #> cons (S, s)) val tfrees = [] |> fold Term.add_tfrees ts |> sort (string_ord o apply2 fst) in [] |> fold add tfrees |> rev end fun merge_type_vars_in_term thy merge_type_vars table = merge_type_vars ? map_types (map_atyps (fn TFree (_, S) => TFree (table |> find_first (fn (S', _) => Sign.subsort thy (S', S)) |> the |> swap) | T => T)) fun add_ground_types hol_ctxt binarize = let fun aux T accum = case T of Type (\<^type_name>\fun\, Ts) => fold aux Ts accum | Type (\<^type_name>\prod\, Ts) => fold aux Ts accum | Type (\<^type_name>\set\, Ts) => fold aux Ts accum | Type (\<^type_name>\itself\, [T1]) => aux T1 accum | Type (_, Ts) => if member (op =) (\<^typ>\prop\ :: \<^typ>\bool\ :: accum) T then accum else T :: accum |> fold aux (case binarized_and_boxed_data_type_constrs hol_ctxt binarize T of [] => Ts | xs => map snd xs) | _ => insert (op =) T accum in aux end fun ground_types_in_type hol_ctxt binarize T = add_ground_types hol_ctxt binarize T [] fun ground_types_in_terms hol_ctxt binarize ts = fold (fold_types (add_ground_types hol_ctxt binarize)) ts [] end; diff --git a/src/HOL/Tools/Nunchaku/nunchaku_collect.ML b/src/HOL/Tools/Nunchaku/nunchaku_collect.ML --- a/src/HOL/Tools/Nunchaku/nunchaku_collect.ML +++ b/src/HOL/Tools/Nunchaku/nunchaku_collect.ML @@ -1,1103 +1,1105 @@ (* Title: HOL/Tools/Nunchaku/nunchaku_collect.ML Author: Jasmin Blanchette, VU Amsterdam Copyright 2015, 2016, 2017 Collecting of Isabelle/HOL definitions etc. for Nunchaku. *) signature NUNCHAKU_COLLECT = sig val dest_co_datatype_case: Proof.context -> string * typ -> (string * typ) list type isa_type_spec = {abs_typ: typ, rep_typ: typ, wrt: term, abs: term, rep: term} type isa_co_data_spec = {typ: typ, ctrs: term list} type isa_const_spec = {const: term, props: term list} type isa_rec_spec = {const: term, props: term list, pat_complete: bool} type isa_consts_spec = {consts: term list, props: term list} datatype isa_command = ITVal of typ * (int option * int option) | ITypedef of isa_type_spec | IQuotient of isa_type_spec | ICoData of BNF_Util.fp_kind * isa_co_data_spec list | IVal of term | ICoPred of BNF_Util.fp_kind * bool * isa_const_spec list | IRec of isa_rec_spec list | ISpec of isa_consts_spec | IAxiom of term | IGoal of term | IEval of term type isa_problem = {commandss: isa_command list list, sound: bool, complete: bool} exception CYCLIC_DEPS of unit exception TOO_DEEP_DEPS of unit exception TOO_META of term exception UNEXPECTED_POLYMORPHISM of term exception UNEXPECTED_VAR of term exception UNSUPPORTED_FUNC of term val isa_problem_of_subgoal: Proof.context -> bool -> ((string * typ) option * bool option) list -> (term option * bool) list -> (typ option * (int option * int option)) list -> bool -> Time.time -> term list -> term list -> term -> term list * isa_problem val pat_completes_of_isa_problem: isa_problem -> term list val str_of_isa_problem: Proof.context -> isa_problem -> string end; structure Nunchaku_Collect : NUNCHAKU_COLLECT = struct open Nunchaku_Util; type isa_type_spec = {abs_typ: typ, rep_typ: typ, wrt: term, abs: term, rep: term}; type isa_co_data_spec = {typ: typ, ctrs: term list}; type isa_const_spec = {const: term, props: term list}; type isa_rec_spec = {const: term, props: term list, pat_complete: bool}; type isa_consts_spec = {consts: term list, props: term list}; datatype isa_command = ITVal of typ * (int option * int option) | ITypedef of isa_type_spec | IQuotient of isa_type_spec | ICoData of BNF_Util.fp_kind * isa_co_data_spec list | IVal of term | ICoPred of BNF_Util.fp_kind * bool * isa_const_spec list | IRec of isa_rec_spec list | ISpec of isa_consts_spec | IAxiom of term | IGoal of term | IEval of term; type isa_problem = {commandss: isa_command list list, sound: bool, complete: bool}; exception CYCLIC_DEPS of unit; exception TOO_DEEP_DEPS of unit; exception TOO_META of term; exception UNEXPECTED_POLYMORPHISM of term; exception UNEXPECTED_VAR of term; exception UNSUPPORTED_FUNC of term; fun str_of_and_list str_of_elem = map str_of_elem #> space_implode ("\nand "); val key_of_typ = let fun key_of (Type (s, [])) = s | key_of (Type (s, Ts)) = s ^ "(" ^ commas (map key_of Ts) ^ ")" | key_of (TFree (s, _)) = s; in prefix "y" o key_of end; fun key_of_const ctxt = let val thy = Proof_Context.theory_of ctxt; fun key_of (Const (x as (s, _))) = (case Sign.const_typargs thy x of [] => s | Ts => s ^ "(" ^ commas (map key_of_typ Ts) ^ ")") | key_of (Free (s, _)) = s; in prefix "t" o key_of end; val add_type_keys = fold_subtypes (insert (op =) o key_of_typ); fun add_aterm_keys ctxt t = if is_Const t orelse is_Free t then insert (op =) (key_of_const ctxt t) else I; fun add_keys ctxt t = fold_aterms (add_aterm_keys ctxt) t #> fold_types add_type_keys t; fun close_form except t = fold (fn ((s, i), T) => fn t' => HOLogic.all_const T $ Abs (s, T, abstract_over (Var ((s, i), T), t'))) (Term.add_vars t [] |> subtract (op =) except) t; (* "imp_conjL[symmetric]" is important for inductive predicates with multiple assumptions. *) val basic_defs = @{thms Ball_def[abs_def] Bex_def[abs_def] case_bool_if Ex1_def[abs_def] imp_conjL[symmetric, abs_def] Let_def[abs_def] rmember_def[symmetric, abs_def]}; fun unfold_basic_def ctxt = let val thy = Proof_Context.theory_of ctxt in Pattern.rewrite_term thy (map (Logic.dest_equals o Thm.prop_of) basic_defs) [] end; val has_polymorphism = exists_type (exists_subtype is_TVar); fun whack_term thy whacks = let fun whk t = if triple_lookup (term_match thy o swap) whacks t = SOME true then Const (\<^const_name>\unreachable\, fastype_of t) else (case t of u $ v => whk u $ whk v | Abs (s, T, u) => Abs (s, T, whk u) | _ => t); in whk end; fun preprocess_term_basic falsify ctxt whacks t = let val thy = Proof_Context.theory_of ctxt in if has_polymorphism t then raise UNEXPECTED_POLYMORPHISM t else t |> attach_typeS |> whack_term thy whacks |> Object_Logic.atomize_term ctxt |> tap (fn t' => fastype_of t' <> \<^typ>\prop\ orelse raise TOO_META t) |> falsify ? HOLogic.mk_not |> unfold_basic_def ctxt end; val check_closed = tap (fn t => null (Term.add_vars t []) orelse raise UNEXPECTED_VAR t); val preprocess_prop = close_form [] oooo preprocess_term_basic; val preprocess_closed_term = check_closed ooo preprocess_term_basic false; val is_type_builtin = member (op =) [\<^type_name>\bool\, \<^type_name>\fun\]; val is_const_builtin = member (op =) [\<^const_name>\All\, \<^const_name>\conj\, \<^const_name>\disj\, \<^const_name>\Eps\, \<^const_name>\HOL.eq\, \<^const_name>\Ex\, \<^const_name>\False\, \<^const_name>\If\, \<^const_name>\implies\, \<^const_name>\Not\, \<^const_name>\The\, \<^const_name>\The_unsafe\, \<^const_name>\True\]; datatype type_classification = Builtin | TVal | Typedef | Quotient | Co_Datatype; fun classify_type_name ctxt T_name = if is_type_builtin T_name then Builtin else if T_name = \<^type_name>\itself\ then Co_Datatype else (case BNF_FP_Def_Sugar.fp_sugar_of ctxt T_name of SOME _ => Co_Datatype | NONE => (case Ctr_Sugar.ctr_sugar_of ctxt T_name of SOME _ => Co_Datatype | NONE => (case Quotient_Info.lookup_quotients ctxt T_name of SOME _ => Quotient | NONE => if T_name = \<^type_name>\set\ then Typedef else (case Typedef.get_info ctxt T_name of _ :: _ => Typedef | [] => TVal)))); fun fp_kind_of_ctr_sugar_kind Ctr_Sugar.Codatatype = BNF_Util.Greatest_FP | fp_kind_of_ctr_sugar_kind _ = BNF_Util.Least_FP; fun mutual_co_datatypes_of ctxt (T_name, Ts) = (if T_name = \<^type_name>\itself\ then (BNF_Util.Least_FP, [\<^typ>\'a itself\], [[@{const Pure.type ('a)}]]) else let val (fp, ctr_sugars) = (case BNF_FP_Def_Sugar.fp_sugar_of ctxt T_name of SOME (fp_sugar as {fp, fp_res = {Ts, ...}, ...}) => (fp, (case Ts of [_] => [fp_sugar] | _ => map (the o BNF_FP_Def_Sugar.fp_sugar_of ctxt o fst o dest_Type) Ts) |> map (#ctr_sugar o #fp_ctr_sugar)) | NONE => (case Ctr_Sugar.ctr_sugar_of ctxt T_name of SOME (ctr_sugar as {kind, ...}) => (* Any freely constructed type that is not a codatatype is considered a datatype. This is sound (but incomplete) for model finding. *) (fp_kind_of_ctr_sugar_kind kind, [ctr_sugar]))); in (fp, map #T ctr_sugars, map #ctrs ctr_sugars) end) |> @{apply 3(2)} (map ((fn Type (s, _) => Type (s, Ts)))) |> @{apply 3(3)} (map (map (Ctr_Sugar.mk_ctr Ts))); fun typedef_of ctxt T_name = if T_name = \<^type_name>\set\ then let val A = Logic.varifyT_global \<^typ>\'a\; val absT = Type (\<^type_name>\set\, [A]); val repT = A --> HOLogic.boolT; val pred = Abs (Name.uu, repT, \<^const>\True\); val abs = Const (\<^const_name>\Collect\, repT --> absT); val rep = Const (\<^const_name>\rmember\, absT --> repT); in (absT, repT, pred, abs, rep) end else (case Typedef.get_info ctxt T_name of (* When several entries are returned, it shouldn't matter much which one we take (according to Florian Haftmann). The "Logic.varifyT_global" calls are a workaround because these types' variables sometimes clash with locally fixed type variables. *) ({abs_type, rep_type, Abs_name, Rep_name, ...}, {Rep, ...}) :: _ => let val absT = Logic.varifyT_global abs_type; val repT = Logic.varifyT_global rep_type; val set = Thm.prop_of Rep |> HOLogic.dest_Trueprop |> HOLogic.dest_mem |> snd; val pred = Abs (Name.uu, repT, HOLogic.mk_mem (Bound 0, set)); val abs = Const (Abs_name, repT --> absT); val rep = Const (Rep_name, absT --> repT); in (absT, repT, pred, abs, rep) end); fun quotient_of ctxt T_name = (case Quotient_Info.lookup_quotients ctxt T_name of SOME {equiv_rel, qtyp, rtyp, quot_thm, ...} => let val _ $ (_ $ _ $ abs $ rep) = Thm.prop_of quot_thm in (qtyp, rtyp, equiv_rel, abs, rep) end); fun is_co_datatype_ctr ctxt (s, T) = (case body_type T of Type (fpT_name, Ts) => classify_type_name ctxt fpT_name = Co_Datatype andalso let val ctrs = if fpT_name = \<^type_name>\itself\ then [Const (\<^const_name>\Pure.type\, \<^typ>\'a itself\)] else (case BNF_FP_Def_Sugar.fp_sugar_of ctxt fpT_name of SOME {fp_ctr_sugar = {ctr_sugar = {ctrs, ...}, ...}, ...} => ctrs | NONE => (case Ctr_Sugar.ctr_sugar_of ctxt fpT_name of SOME {ctrs, ...} => ctrs | _ => [])); fun is_right_ctr (t' as Const (s', _)) = s = s' andalso fastype_of (Ctr_Sugar.mk_ctr Ts t') = T; in exists is_right_ctr ctrs end | _ => false); fun dest_co_datatype_case ctxt (s, T) = let val thy = Proof_Context.theory_of ctxt in (case strip_fun_type (Sign.the_const_type thy s) of (gen_branch_Ts, gen_body_fun_T) => (case gen_body_fun_T of Type (\<^type_name>\fun\, [Type (fpT_name, _), _]) => if classify_type_name ctxt fpT_name = Co_Datatype then let val Type (_, fpTs) = domain_type (funpow (length gen_branch_Ts) range_type T); val (ctrs0, Const (case_name, _)) = (case BNF_FP_Def_Sugar.fp_sugar_of ctxt fpT_name of SOME {fp_ctr_sugar = {ctr_sugar = {ctrs, casex, ...}, ...}, ...} => (ctrs, casex) | NONE => (case Ctr_Sugar.ctr_sugar_of ctxt fpT_name of SOME {ctrs, casex, ...} => (ctrs, casex))); in if s = case_name then map (dest_Const o Ctr_Sugar.mk_ctr fpTs) ctrs0 else raise Fail "non-case" end else raise Fail "non-case")) end; val is_co_datatype_case = can o dest_co_datatype_case; fun is_quotient_abs ctxt (s, T) = (case T of Type (\<^type_name>\fun\, [_, Type (absT_name, _)]) => classify_type_name ctxt absT_name = Quotient andalso (case quotient_of ctxt absT_name of (_, _, _, Const (s', _), _) => s' = s) | _ => false); fun is_quotient_rep ctxt (s, T) = (case T of Type (\<^type_name>\fun\, [Type (absT_name, _), _]) => classify_type_name ctxt absT_name = Quotient andalso (case quotient_of ctxt absT_name of (_, _, _, _, Const (s', _)) => s' = s) | _ => false); fun is_maybe_typedef_abs ctxt absT_name s = if absT_name = \<^type_name>\set\ then s = \<^const_name>\Collect\ else (case try (typedef_of ctxt) absT_name of SOME (_, _, _, Const (s', _), _) => s' = s | NONE => false); fun is_maybe_typedef_rep ctxt absT_name s = if absT_name = \<^type_name>\set\ then s = \<^const_name>\rmember\ else (case try (typedef_of ctxt) absT_name of SOME (_, _, _, _, Const (s', _)) => s' = s | NONE => false); fun is_typedef_abs ctxt (s, T) = (case T of Type (\<^type_name>\fun\, [_, Type (absT_name, _)]) => classify_type_name ctxt absT_name = Typedef andalso is_maybe_typedef_abs ctxt absT_name s | _ => false); fun is_typedef_rep ctxt (s, T) = (case T of Type (\<^type_name>\fun\, [Type (absT_name, _), _]) => classify_type_name ctxt absT_name = Typedef andalso is_maybe_typedef_rep ctxt absT_name s | _ => false); fun is_stale_typedef_abs ctxt (s, T) = (case T of Type (\<^type_name>\fun\, [_, Type (absT_name, _)]) => classify_type_name ctxt absT_name <> Typedef andalso is_maybe_typedef_abs ctxt absT_name s | _ => false); fun is_stale_typedef_rep ctxt (s, T) = (case T of Type (\<^type_name>\fun\, [Type (absT_name, _), _]) => classify_type_name ctxt absT_name <> Typedef andalso is_maybe_typedef_rep ctxt absT_name s | _ => false); fun instantiate_constant_types_in_term ctxt csts target = let val thy = Proof_Context.theory_of ctxt; fun try_const _ _ (res as SOME _) = res | try_const (s', T') cst NONE = (case cst of Const (s, T) => if s = s' then SOME (Sign.typ_match thy (T', T) Vartab.empty) handle Type.TYPE_MATCH => NONE else NONE | _ => NONE); fun subst_for (Const x) = fold (try_const x) csts NONE | subst_for (t as Free _) = if member (op aconv) csts t then SOME Vartab.empty else NONE | subst_for (t1 $ t2) = (case subst_for t1 of SOME subst => SOME subst | NONE => subst_for t2) | subst_for (Abs (_, _, t')) = subst_for t' | subst_for _ = NONE; in (case subst_for target of SOME subst => Envir.subst_term_types subst target | NONE => raise Type.TYPE_MATCH) end; datatype card = One | Fin | Fin_or_Inf | Inf (* Similar to "ATP_Util.tiny_card_of_type". *) fun card_of_type ctxt = let fun max_card Inf _ = Inf | max_card _ Inf = Inf | max_card Fin_or_Inf _ = Fin_or_Inf | max_card _ Fin_or_Inf = Fin_or_Inf | max_card Fin _ = Fin | max_card _ Fin = Fin | max_card One One = One; fun card_of avoid T = if member (op =) avoid T then Inf else (case T of TFree _ => Fin_or_Inf | TVar _ => Inf | Type (\<^type_name>\fun\, [T1, T2]) => (case (card_of avoid T1, card_of avoid T2) of (_, One) => One | (k1, k2) => max_card k1 k2) | Type (\<^type_name>\prod\, [T1, T2]) => (case (card_of avoid T1, card_of avoid T2) of (k1, k2) => max_card k1 k2) | Type (\<^type_name>\set\, [T']) => card_of avoid (T' --> HOLogic.boolT) | Type (T_name, Ts) => (case try (mutual_co_datatypes_of ctxt) (T_name, Ts) of NONE => Inf | SOME (_, fpTs, ctrss) => (case ctrss of [[_]] => One | _ => Fin) |> fold (fold (fold (max_card o card_of (fpTs @ avoid)) o binder_types o fastype_of)) ctrss)); in card_of [] end; fun spec_rules_of ctxt (x as (s, T)) = let val thy = Proof_Context.theory_of ctxt; fun subst_of t0 = try (Sign.typ_match thy (fastype_of t0, T)) Vartab.empty; fun process_spec _ (res as SOME _) = res - | process_spec (classif, (ts0, ths as _ :: _)) NONE = + | process_spec {rough_classification = classif, terms = ts0, rules = ths as _ :: _, ...} NONE = (case get_first subst_of ts0 of SOME subst => (let val ts = map (Envir.subst_term_types subst) ts0; val poly_props = map Thm.prop_of ths; val props = map (instantiate_constant_types_in_term ctxt ts) poly_props; in if exists (exists (exists_type (exists_subtype is_TVar))) [ts, props] then NONE else SOME (classif, ts, props, poly_props) end handle Type.TYPE_MATCH => NONE) | NONE => NONE) | process_spec _ NONE = NONE; fun spec_rules () = Spec_Rules.retrieve ctxt (Const x) - |> sort (Spec_Rules.rough_classification_ord o apply2 fst); + |> sort (Spec_Rules.rough_classification_ord o apply2 #rough_classification); val specs = if s = \<^const_name>\The\ then - [(Spec_Rules.Unknown, ([Logic.varify_global \<^term>\The\], [@{thm theI_unique}]))] + [{name = "", rough_classification = Spec_Rules.Unknown, + terms = [Logic.varify_global \<^term>\The\], + rules = [@{thm theI_unique}]}] else if s = \<^const_name>\finite\ then let val card = card_of_type ctxt T in if card = Inf orelse card = Fin_or_Inf then spec_rules () else - [(Spec_Rules.equational, ([Logic.varify_global \<^term>\finite\], - [Skip_Proof.make_thm thy (Logic.varify_global \<^prop>\finite A = True\)]))] + [{name = "", rough_classification = Spec_Rules.equational, + terms = [Logic.varify_global \<^term>\finite\], + rules = [Skip_Proof.make_thm thy (Logic.varify_global \<^prop>\finite A = True\)]}] end else spec_rules (); in fold process_spec specs NONE end; fun lhs_of_equation (Const (\<^const_name>\Pure.eq\, _) $ t $ _) = t | lhs_of_equation (\<^const>\Trueprop\ $ (Const (\<^const_name>\HOL.eq\, _) $ t $ _)) = t; fun specialize_definition_type thy x def0 = let val def = specialize_type thy x def0; val lhs = lhs_of_equation def; in if exists_Const (curry (op =) x) lhs then def else raise Fail "cannot specialize" end; fun definition_of thy (x as (s, _)) = Defs.specifications_of (Theory.defs_of thy) (Defs.Const, s) |> map_filter #def |> map_filter (try (specialize_definition_type thy x o Thm.prop_of o Thm.axiom thy)) |> try hd; fun is_builtin_theory thy_id = Context.subthy_id (thy_id, Context.theory_id \<^theory>\Hilbert_Choice\); val orphan_axioms_of = Spec_Rules.get - #> filter (Spec_Rules.is_unknown o fst) - #> map snd - #> filter (null o fst) - #> maps snd + #> filter (Spec_Rules.is_unknown o #rough_classification) + #> filter (null o #terms) + #> maps #rules #> filter_out (is_builtin_theory o Thm.theory_id) #> map Thm.prop_of; fun keys_of _ (ITVal (T, _)) = [key_of_typ T] | keys_of _ (ITypedef {abs_typ, ...}) = [key_of_typ abs_typ] | keys_of _ (IQuotient {abs_typ, ...}) = [key_of_typ abs_typ] | keys_of _ (ICoData (_, specs)) = map (key_of_typ o #typ) specs | keys_of ctxt (IVal const) = [key_of_const ctxt const] | keys_of ctxt (ICoPred (_, _, specs)) = map (key_of_const ctxt o #const) specs | keys_of ctxt (IRec specs) = map (key_of_const ctxt o #const) specs | keys_of ctxt (ISpec {consts, ...}) = map (key_of_const ctxt) consts | keys_of _ (IAxiom _) = [] | keys_of _ (IGoal _) = [] | keys_of _ (IEval _) = []; fun co_data_spec_deps_of ctxt ({ctrs, ...} : isa_co_data_spec) = fold (add_keys ctxt) ctrs []; fun const_spec_deps_of ctxt consts props = fold (add_keys ctxt) props [] |> subtract (op =) (map (key_of_const ctxt) consts); fun consts_spec_deps_of ctxt {consts, props} = fold (add_keys ctxt) props [] |> subtract (op =) (map (key_of_const ctxt) consts); fun deps_of _ (ITVal _) = [] | deps_of ctxt (ITypedef {wrt, ...}) = add_keys ctxt wrt [] | deps_of ctxt (IQuotient {wrt, ...}) = add_keys ctxt wrt [] | deps_of ctxt (ICoData (_, specs)) = maps (co_data_spec_deps_of ctxt) specs | deps_of _ (IVal const) = add_type_keys (fastype_of const) [] | deps_of ctxt (ICoPred (_, _, specs)) = maps (const_spec_deps_of ctxt (map #const specs) o #props) specs | deps_of ctxt (IRec specs) = maps (const_spec_deps_of ctxt (map #const specs) o #props) specs | deps_of ctxt (ISpec spec) = consts_spec_deps_of ctxt spec | deps_of ctxt (IAxiom prop) = add_keys ctxt prop [] | deps_of ctxt (IGoal prop) = add_keys ctxt prop [] | deps_of ctxt (IEval t) = add_keys ctxt t []; fun consts_of_rec_or_spec (IRec specs) = map #const specs | consts_of_rec_or_spec (ISpec {consts, ...}) = consts; fun props_of_rec_or_spec (IRec specs) = maps #props specs | props_of_rec_or_spec (ISpec {props, ...}) = props; fun merge_two_rec_or_spec cmd cmd' = ISpec {consts = consts_of_rec_or_spec cmd @ consts_of_rec_or_spec cmd', props = props_of_rec_or_spec cmd @ props_of_rec_or_spec cmd'}; fun merge_two (ICoData (fp, specs)) (ICoData (fp', specs'), complete) = (ICoData (BNF_Util.case_fp fp fp fp', specs @ specs'), complete andalso fp = fp') | merge_two (IRec specs) (IRec specs', complete) = (IRec (specs @ specs'), complete) | merge_two (cmd as IRec _) (cmd' as ISpec _, complete) = (merge_two_rec_or_spec cmd cmd', complete) | merge_two (cmd as ISpec _) (cmd' as IRec _, complete) = (merge_two_rec_or_spec cmd cmd', complete) | merge_two (cmd as ISpec _) (cmd' as ISpec _, complete) = (merge_two_rec_or_spec cmd cmd', complete) | merge_two _ _ = raise CYCLIC_DEPS (); fun sort_isa_commands_topologically ctxt cmds = let fun normal_pairs [] = [] | normal_pairs (all as normal :: _) = map (rpair normal) all; fun add_node [] _ = I | add_node (normal :: _) cmd = Graph.new_node (normal, cmd); fun merge_scc (cmd :: cmds) complete = fold merge_two cmds (cmd, complete); fun sort_problem (cmds, complete) = let val keyss = map (keys_of ctxt) cmds; val normal_keys = Symtab.make (maps normal_pairs keyss); val normalize = Symtab.lookup normal_keys; fun add_deps [] _ = I | add_deps (normal :: _) cmd = let val deps = deps_of ctxt cmd |> map_filter normalize |> remove (op =) normal; in fold (fn dep => Graph.add_edge (dep, normal)) deps end; val cmd_of_key = the o AList.lookup (op =) (map hd keyss ~~ cmds); val G = Graph.empty |> fold2 add_node keyss cmds |> fold2 add_deps keyss cmds; val cmd_sccs = rev (Graph.strong_conn G) |> map (map cmd_of_key); in if exists (can (fn _ :: _ :: _ => ())) cmd_sccs then sort_problem (fold_map merge_scc cmd_sccs complete) else (Graph.schedule (K snd) G, complete) end; val typedecls = filter (can (fn ITVal _ => ())) cmds; val (mixed, complete) = (filter (can (fn ITypedef _ => () | IQuotient _ => () | ICoData _ => () | IVal _ => () | ICoPred _ => () | IRec _ => () | ISpec _ => ())) cmds, true) |> sort_problem; val axioms = filter (can (fn IAxiom _ => ())) cmds; val goals = filter (can (fn IGoal _ => ())) cmds; val evals = filter (can (fn IEval _ => ())) cmds; in (typedecls @ mixed @ axioms @ goals @ evals, complete) end; fun group_of (ITVal _) = 1 | group_of (ITypedef _) = 2 | group_of (IQuotient _) = 3 | group_of (ICoData _) = 4 | group_of (IVal _) = 5 | group_of (ICoPred _) = 6 | group_of (IRec _) = 7 | group_of (ISpec _) = 8 | group_of (IAxiom _) = 9 | group_of (IGoal _) = 10 | group_of (IEval _) = 11; fun group_isa_commands [] = [] | group_isa_commands [cmd] = [[cmd]] | group_isa_commands (cmd :: cmd' :: cmds) = let val (group :: groups) = group_isa_commands (cmd' :: cmds) in if group_of cmd = group_of cmd' then (cmd :: group) :: groups else [cmd] :: (group :: groups) end; fun defined_by (Const (\<^const_name>\All\, _) $ t) = defined_by t | defined_by (Abs (_, _, t)) = defined_by t | defined_by (\<^const>\implies\ $ _ $ u) = defined_by u | defined_by (Const (\<^const_name>\HOL.eq\, _) $ t $ _) = head_of t | defined_by t = head_of t; fun partition_props [_] props = SOME [props] | partition_props consts props = let val propss = map (fn const => filter (fn prop => defined_by prop aconv const) props) consts; in if eq_set (op aconv) (props, flat propss) andalso forall (not o null) propss then SOME propss else NONE end; fun hol_concl_head (Const (\<^const_name>\All\, _) $ Abs (_, _, t)) = hol_concl_head t | hol_concl_head (Const (\<^const_name>\implies\, _) $ _ $ t) = hol_concl_head t | hol_concl_head (t $ _) = hol_concl_head t | hol_concl_head t = t; fun is_inductive_set_intro t = (case hol_concl_head t of Const (\<^const_name>\rmember\, _) => true | _ => false); exception NO_TRIPLE of unit; fun triple_for_intro_rule ctxt x rule = let val (prems, concl) = Logic.strip_horn rule |>> map (Object_Logic.atomize_term ctxt) ||> Object_Logic.atomize_term ctxt; val (mains, sides) = List.partition (exists_Const (curry (op =) x)) prems; val is_right_head = curry (op aconv) (Const x) o head_of; in if forall is_right_head mains then (sides, mains, concl) else raise NO_TRIPLE () end; val tuple_for_args = HOLogic.mk_tuple o snd o strip_comb; fun wf_constraint_for rel sides concl mains = HOLogic.mk_mem (HOLogic.mk_prod (apply2 tuple_for_args (mains, concl)), Var rel) |> fold (curry HOLogic.mk_imp) sides |> close_form [rel]; fun wf_constraint_for_triple rel (sides, mains, concl) = map (wf_constraint_for rel sides concl) mains |> foldr1 HOLogic.mk_conj; fun terminates_by ctxt timeout goal tac = can (SINGLE (Classical.safe_tac ctxt) #> the #> SINGLE (DETERM_TIMEOUT timeout (tac ctxt (auto_tac ctxt))) #> the #> Goal.finish ctxt) goal; val max_cached_wfs = 50; val cached_timeout = Synchronized.var "Nunchaku_Collect.cached_timeout" Time.zeroTime; val cached_wf_props = Synchronized.var "Nunchaku_Collect.cached_wf_props" ([] : (term * bool) list); val termination_tacs = [Lexicographic_Order.lex_order_tac true, ScnpReconstruct.sizechange_tac]; fun is_wellfounded_inductive_predicate ctxt wfs debug wf_timeout const intros = let val thy = Proof_Context.theory_of ctxt; val Const (x as (_, T)) = head_of (HOLogic.dest_Trueprop (Logic.strip_imp_concl (hd intros))); in (case triple_lookup (const_match thy o swap) wfs (dest_Const const) of SOME (SOME wf) => wf | _ => (case map (triple_for_intro_rule ctxt x) intros |> filter_out (null o #2) of [] => true | triples => let val binders_T = HOLogic.mk_tupleT (binder_types T); val rel_T = HOLogic.mk_setT (HOLogic.mk_prodT (binders_T, binders_T)); val j = fold (Integer.max o maxidx_of_term) intros 0 + 1; val rel = (("R", j), rel_T); val prop = Const (\<^const_name>\wf\, rel_T --> HOLogic.boolT) $ Var rel :: map (wf_constraint_for_triple rel) triples |> foldr1 HOLogic.mk_conj |> HOLogic.mk_Trueprop; in if debug then writeln ("Wellfoundedness goal: " ^ Syntax.string_of_term ctxt prop) else (); if wf_timeout = Synchronized.value cached_timeout andalso length (Synchronized.value cached_wf_props) < max_cached_wfs then () else (Synchronized.change cached_wf_props (K []); Synchronized.change cached_timeout (K wf_timeout)); (case AList.lookup (op =) (Synchronized.value cached_wf_props) prop of SOME wf => wf | NONE => let val goal = Goal.init (Thm.cterm_of ctxt prop); val wf = exists (terminates_by ctxt wf_timeout goal) termination_tacs; in Synchronized.change cached_wf_props (cons (prop, wf)); wf end) end) handle List.Empty => false | NO_TRIPLE () => false) end; datatype lhs_pat = Only_Vars | Prim_Pattern of string | Any_Pattern; fun is_apparently_pat_complete ctxt props = let val is_Var_or_Bound = is_Var orf is_Bound; fun lhs_pat_of t = (case t of Const (\<^const_name>\All\, _) $ Abs (_, _, t) => lhs_pat_of t | Const (\<^const_name>\HOL.eq\, _) $ u $ _ => (case filter_out is_Var_or_Bound (snd (strip_comb u)) of [] => Only_Vars | [v] => (case strip_comb v of (cst as Const (_, T), args) => (case body_type T of Type (T_name, _) => if can (Ctr_Sugar.dest_ctr ctxt T_name) cst andalso forall is_Var_or_Bound args then Prim_Pattern T_name else Any_Pattern | _ => Any_Pattern) | _ => Any_Pattern) | _ => Any_Pattern) | _ => Any_Pattern); in (case map lhs_pat_of props of [] => false | pats as Prim_Pattern T_name :: _ => forall (can (fn Prim_Pattern _ => ())) pats andalso length pats = length (#ctrs (the (Ctr_Sugar.ctr_sugar_of ctxt T_name))) | pats => forall (curry (op =) Only_Vars) pats) end; (* Prevents divergence in case of cyclic or infinite axiom dependencies. *) val axioms_max_depth = 255 fun isa_problem_of_subgoal ctxt falsify wfs whacks cards debug wf_timeout evals0 some_assms0 subgoal0 = let val thy = Proof_Context.theory_of ctxt; fun card_of T = (case triple_lookup (typ_match thy o swap) cards T of NONE => (NONE, NONE) | SOME (c1, c2) => (if c1 = SOME 1 then NONE else c1, c2)); fun axioms_of_class class = #axioms (Axclass.get_info thy class) handle ERROR _ => []; fun monomorphize_class_axiom T t = (case Term.add_tvars t [] of [] => t | [(x, S)] => Envir.subst_term_types (Vartab.make [(x, (S, T))]) t); fun consider_sort depth T S (seens as (seenS, seenT, seen), problem) = if member (op =) seenS S then (seens, problem) else if depth > axioms_max_depth then raise TOO_DEEP_DEPS () else let val seenS = S :: seenS; val seens = (seenS, seenT, seen); val supers = Sign.complete_sort thy S; val axioms0 = maps (map Thm.prop_of o axioms_of_class) supers; val axioms = map (preprocess_prop false ctxt whacks o monomorphize_class_axiom T) axioms0; in (seens, map IAxiom axioms @ problem) |> fold (consider_term (depth + 1)) axioms end and consider_type depth T = (case T of Type (s, Ts) => if is_type_builtin s then fold (consider_type depth) Ts else consider_non_builtin_type depth T | _ => consider_non_builtin_type depth T) and consider_non_builtin_type depth T (seens as (seenS, seenT, seen), problem) = if member (op =) seenT T then (seens, problem) else let val seenT = T :: seenT; val seens = (seenS, seenT, seen); fun consider_typedef_or_quotient itypedef_or_quotient tuple_of s = let val (T0, repT0, wrt0, abs0, rep0) = tuple_of ctxt s; val tyenv = Sign.typ_match thy (T0, T) Vartab.empty; val substT = Envir.subst_type tyenv; val subst = Envir.subst_term_types tyenv; val repT = substT repT0; val wrt = preprocess_prop false ctxt whacks (subst wrt0); val abs = subst abs0; val rep = subst rep0; in apsnd (cons (itypedef_or_quotient {abs_typ = T, rep_typ = repT, wrt = wrt, abs = abs, rep = rep})) #> consider_term (depth + 1) wrt end; in (seens, problem) |> (case T of TFree (_, S) => apsnd (cons (ITVal (T, card_of T))) #> consider_sort depth T S | TVar (_, S) => consider_sort depth T S | Type (s, Ts) => fold (consider_type depth) Ts #> (case classify_type_name ctxt s of Co_Datatype => let val (fp, fpTs, ctrss) = mutual_co_datatypes_of ctxt (s, Ts); val specs = map2 (fn T => fn ctrs => {typ = T, ctrs = ctrs}) fpTs ctrss; in (fn ((seenS, seenT, seen), problem) => ((seenS, union (op =) fpTs seenT, seen), ICoData (fp, specs) :: problem)) #> fold (fold (consider_type (depth + 1) o fastype_of)) ctrss end | Typedef => consider_typedef_or_quotient ITypedef typedef_of s | Quotient => consider_typedef_or_quotient IQuotient quotient_of s | TVal => apsnd (cons (ITVal (T, card_of T))))) end and consider_term depth t = (case t of t1 $ t2 => fold (consider_term depth) [t1, t2] | Var (_, T) => consider_type depth T | Bound _ => I | Abs (_, T, t') => consider_term depth t' #> consider_type depth T | _ => (fn (seens as (seenS, seenT, seen), problem) => if member (op aconv) seen t then (seens, problem) else if depth > axioms_max_depth then raise TOO_DEEP_DEPS () else let val seen = t :: seen; val seens = (seenS, seenT, seen); in (case t of Const (x as (s, T)) => (if is_const_builtin s orelse is_co_datatype_ctr ctxt x orelse is_co_datatype_case ctxt x orelse is_quotient_abs ctxt x orelse is_quotient_rep ctxt x orelse is_typedef_abs ctxt x orelse is_typedef_rep ctxt x then (seens, problem) else if is_stale_typedef_abs ctxt x orelse is_stale_typedef_rep ctxt x then raise UNSUPPORTED_FUNC t else (case spec_rules_of ctxt x of SOME (classif, consts, props0, poly_props) => let val props = map (preprocess_prop false ctxt whacks) props0; fun def_or_spec () = (case definition_of thy x of SOME eq0 => let val eq = preprocess_prop false ctxt whacks eq0 in ([eq], [IRec [{const = t, props = [eq], pat_complete = true}]]) end | NONE => (props, [ISpec {consts = consts, props = props}])); val (props', cmds) = if null props then ([], map IVal consts) else if Spec_Rules.is_equational classif then (case partition_props consts props of SOME propss => (props, [IRec (map2 (fn const => fn props => {const = const, props = props, pat_complete = is_apparently_pat_complete ctxt props}) consts propss)]) | NONE => def_or_spec ()) - else if (Spec_Rules.is_inductive orf Spec_Rules.is_co_inductive) classif + else if Spec_Rules.is_relational classif then if is_inductive_set_intro (hd props) then def_or_spec () else (case partition_props consts props of SOME propss => (props, [ICoPred (if Spec_Rules.is_inductive classif then BNF_Util.Least_FP else BNF_Util.Greatest_FP, length consts = 1 andalso is_wellfounded_inductive_predicate ctxt wfs debug wf_timeout (the_single consts) poly_props, map2 (fn const => fn props => {const = const, props = props}) consts propss)]) | NONE => def_or_spec ()) else def_or_spec (); in ((seenS, seenT, union (op aconv) consts seen), cmds @ problem) |> fold (consider_term (depth + 1)) props' end | NONE => (case definition_of thy x of SOME eq0 => let val eq = preprocess_prop false ctxt whacks eq0 in (seens, IRec [{const = t, props = [eq], pat_complete = true}] :: problem) |> consider_term (depth + 1) eq end | NONE => (seens, IVal t :: problem)))) |> consider_type depth T | Free (_, T) => (seens, IVal t :: problem) |> consider_type depth T) end)); val (poly_axioms, mono_axioms0) = orphan_axioms_of ctxt |> List.partition has_polymorphism; fun implicit_evals_of pol (\<^const>\Not\ $ t) = implicit_evals_of (not pol) t | implicit_evals_of pol (\<^const>\implies\ $ t $ u) = (case implicit_evals_of pol u of [] => implicit_evals_of (not pol) t | ts => ts) | implicit_evals_of pol (\<^const>\conj\ $ t $ u) = union (op aconv) (implicit_evals_of pol t) (implicit_evals_of pol u) | implicit_evals_of pol (\<^const>\disj\ $ t $ u) = union (op aconv) (implicit_evals_of pol t) (implicit_evals_of pol u) | implicit_evals_of false (Const (\<^const_name>\HOL.eq\, _) $ t $ u) = distinct (op aconv) [t, u] | implicit_evals_of true (Const (\<^const_name>\HOL.eq\, _) $ t $ _) = [t] | implicit_evals_of _ _ = []; val mono_axioms_and_some_assms = map (preprocess_prop false ctxt whacks) (mono_axioms0 @ some_assms0); val subgoal = preprocess_prop falsify ctxt whacks subgoal0; val implicit_evals = implicit_evals_of true subgoal; val evals = map (preprocess_closed_term ctxt whacks) evals0; val seens = ([], [], []); val (commandss, complete) = (seens, map IAxiom mono_axioms_and_some_assms @ [IGoal subgoal] @ map IEval (implicit_evals @ evals)) |> fold (consider_term 0) (subgoal :: evals @ mono_axioms_and_some_assms) |> snd |> rev (* prettier *) |> sort_isa_commands_topologically ctxt |>> group_isa_commands; in (poly_axioms, {commandss = commandss, sound = true, complete = complete}) end; fun add_pat_complete_of_command cmd = (case cmd of ICoPred (_, _, specs) => union (op =) (map #const specs) | IRec specs => union (op =) (map_filter (try (fn {const, pat_complete = true, ...} => const)) specs) | _ => I); fun pat_completes_of_isa_problem {commandss, ...} = fold (fold add_pat_complete_of_command) commandss []; fun str_of_isa_term_with_type ctxt t = Syntax.string_of_term ctxt t ^ " : " ^ Syntax.string_of_typ ctxt (fastype_of t); fun is_triv_wrt (Abs (_, _, body)) = is_triv_wrt body | is_triv_wrt \<^const>\True\ = true | is_triv_wrt _ = false; fun str_of_isa_type_spec ctxt {abs_typ, rep_typ, wrt, abs, rep} = Syntax.string_of_typ ctxt abs_typ ^ " := " ^ Syntax.string_of_typ ctxt rep_typ ^ (if is_triv_wrt wrt then "" else "\n wrt " ^ Syntax.string_of_term ctxt wrt) ^ "\n abstract " ^ Syntax.string_of_term ctxt abs ^ "\n concrete " ^ Syntax.string_of_term ctxt rep; fun str_of_isa_co_data_spec ctxt {typ, ctrs} = Syntax.string_of_typ ctxt typ ^ " :=\n " ^ space_implode "\n| " (map (str_of_isa_term_with_type ctxt) ctrs); fun str_of_isa_const_spec ctxt {const, props} = str_of_isa_term_with_type ctxt const ^ " :=\n " ^ space_implode ";\n " (map (Syntax.string_of_term ctxt) props); fun str_of_isa_rec_spec ctxt {const, props, pat_complete} = str_of_isa_term_with_type ctxt const ^ (if pat_complete then " [pat_complete]" else "") ^ " :=\n " ^ space_implode ";\n " (map (Syntax.string_of_term ctxt) props); fun str_of_isa_consts_spec ctxt {consts, props} = space_implode " and\n " (map (str_of_isa_term_with_type ctxt) consts) ^ " :=\n " ^ space_implode ";\n " (map (Syntax.string_of_term ctxt) props); fun str_of_isa_card NONE = "" | str_of_isa_card (SOME k) = signed_string_of_int k; fun str_of_isa_cards_suffix (NONE, NONE) = "" | str_of_isa_cards_suffix (c1, c2) = " " ^ str_of_isa_card c1 ^ "-" ^ str_of_isa_card c2; fun str_of_isa_command ctxt (ITVal (T, cards)) = "type " ^ Syntax.string_of_typ ctxt T ^ str_of_isa_cards_suffix cards | str_of_isa_command ctxt (ITypedef spec) = "typedef " ^ str_of_isa_type_spec ctxt spec | str_of_isa_command ctxt (IQuotient spec) = "quotient " ^ str_of_isa_type_spec ctxt spec | str_of_isa_command ctxt (ICoData (fp, specs)) = BNF_Util.case_fp fp "data" "codata" ^ " " ^ str_of_and_list (str_of_isa_co_data_spec ctxt) specs | str_of_isa_command ctxt (IVal t) = "val " ^ str_of_isa_term_with_type ctxt t | str_of_isa_command ctxt (ICoPred (fp, wf, specs)) = BNF_Util.case_fp fp "pred" "copred" ^ " " ^ (if wf then "[wf] " else "") ^ str_of_and_list (str_of_isa_const_spec ctxt) specs | str_of_isa_command ctxt (IRec specs) = "rec " ^ str_of_and_list (str_of_isa_rec_spec ctxt) specs | str_of_isa_command ctxt (ISpec spec) = "spec " ^ str_of_isa_consts_spec ctxt spec | str_of_isa_command ctxt (IAxiom prop) = "axiom " ^ Syntax.string_of_term ctxt prop | str_of_isa_command ctxt (IGoal prop) = "goal " ^ Syntax.string_of_term ctxt prop | str_of_isa_command ctxt (IEval t) = "eval " ^ Syntax.string_of_term ctxt t; fun str_of_isa_problem ctxt {commandss, sound, complete} = map (cat_lines o map (suffix "." o str_of_isa_command ctxt)) commandss |> space_implode "\n\n" |> suffix "\n" |> prefix ("# " ^ (if sound then "sound" else "unsound") ^ "\n") |> prefix ("# " ^ (if complete then "complete" else "incomplete") ^ "\n"); end; diff --git a/src/HOL/Tools/Old_Datatype/old_primrec.ML b/src/HOL/Tools/Old_Datatype/old_primrec.ML --- a/src/HOL/Tools/Old_Datatype/old_primrec.ML +++ b/src/HOL/Tools/Old_Datatype/old_primrec.ML @@ -1,318 +1,319 @@ (* Title: HOL/Tools/Old_Datatype/old_primrec.ML Author: Norbert Voelker, FernUni Hagen Author: Stefan Berghofer, TU Muenchen Author: Florian Haftmann, TU Muenchen Primitive recursive functions on datatypes. *) signature OLD_PRIMREC = sig val primrec: bool -> (binding * typ option * mixfix) list -> Specification.multi_specs -> local_theory -> {types: string list, result: term list * thm list} * local_theory val primrec_cmd: bool -> (binding * string option * mixfix) list -> Specification.multi_specs_cmd -> local_theory -> {types: string list, result: term list * thm list} * local_theory val primrec_global: bool -> (binding * typ option * mixfix) list -> Specification.multi_specs -> theory -> (term list * thm list) * theory val primrec_overloaded: bool -> (string * (string * typ) * bool) list -> (binding * typ option * mixfix) list -> Specification.multi_specs -> theory -> (term list * thm list) * theory val primrec_simple: bool -> ((binding * typ) * mixfix) list -> term list -> local_theory -> {prefix: string, types: string list, result: term list * thm list} * local_theory end; structure Old_Primrec : OLD_PRIMREC = struct exception PrimrecError of string * term option; fun primrec_error msg = raise PrimrecError (msg, NONE); fun primrec_error_eqn msg eqn = raise PrimrecError (msg, SOME eqn); (* preprocessing of equations *) fun process_eqn is_fixed spec rec_fns = let val (vs, Ts) = split_list (strip_qnt_vars \<^const_name>\Pure.all\ spec); val body = strip_qnt_body \<^const_name>\Pure.all\ spec; val (vs', _) = fold_map Name.variant vs (Name.make_context (fold_aterms (fn Free (v, _) => insert (op =) v | _ => I) body [])); val eqn = curry subst_bounds (map2 (curry Free) vs' Ts |> rev) body; val (lhs, rhs) = HOLogic.dest_eq (HOLogic.dest_Trueprop eqn) handle TERM _ => primrec_error "not a proper equation"; val (recfun, args) = strip_comb lhs; val fname = (case recfun of Free (v, _) => if is_fixed v then v else primrec_error "illegal head of function equation" | _ => primrec_error "illegal head of function equation"); val (ls', rest) = chop_prefix is_Free args; val (middle, rs') = chop_suffix is_Free rest; val rpos = length ls'; val (constr, cargs') = if null middle then primrec_error "constructor missing" else strip_comb (hd middle); val (cname, T) = dest_Const constr handle TERM _ => primrec_error "ill-formed constructor"; val (tname, _) = dest_Type (body_type T) handle TYPE _ => primrec_error "cannot determine datatype associated with function" val (ls, cargs, rs) = (map dest_Free ls', map dest_Free cargs', map dest_Free rs') handle TERM _ => primrec_error "illegal argument in pattern"; val lfrees = ls @ rs @ cargs; fun check_vars _ [] = () | check_vars s vars = primrec_error (s ^ commas_quote (map fst vars)) eqn; in if length middle > 1 then primrec_error "more than one non-variable in pattern" else (check_vars "repeated variable names in pattern: " (duplicates (op =) lfrees); check_vars "extra variables on rhs: " (Term.add_frees rhs [] |> subtract (op =) lfrees |> filter_out (is_fixed o fst)); (case AList.lookup (op =) rec_fns fname of NONE => (fname, (tname, rpos, [(cname, (ls, cargs, rs, rhs, eqn))])) :: rec_fns | SOME (_, rpos', eqns) => if AList.defined (op =) eqns cname then primrec_error "constructor already occurred as pattern" else if rpos <> rpos' then primrec_error "position of recursive argument inconsistent" else AList.update (op =) (fname, (tname, rpos, (cname, (ls, cargs, rs, rhs, eqn)) :: eqns)) rec_fns)) end handle PrimrecError (msg, NONE) => primrec_error_eqn msg spec; fun process_fun descr eqns (i, fname) (fnames, fnss) = let val (_, (tname, _, constrs)) = nth descr i; (* substitute "fname ls x rs" by "y ls rs" for (x, (_, y)) in subs *) fun subst [] t fs = (t, fs) | subst subs (Abs (a, T, t)) fs = fs |> subst subs t |-> (fn t' => pair (Abs (a, T, t'))) | subst subs (t as (_ $ _)) fs = let val (f, ts) = strip_comb t; in if is_Free f andalso member (fn ((v, _), (w, _)) => v = w) eqns (dest_Free f) then let val (fname', _) = dest_Free f; val (_, rpos, _) = the (AList.lookup (op =) eqns fname'); val (ls, rs) = chop rpos ts val (x', rs') = (case rs of x' :: rs => (x', rs) | [] => primrec_error ("not enough arguments in recursive application\n" ^ "of function " ^ quote fname' ^ " on rhs")); val (x, xs) = strip_comb x'; in (case AList.lookup (op =) subs x of NONE => fs |> fold_map (subst subs) ts |-> (fn ts' => pair (list_comb (f, ts'))) | SOME (i', y) => fs |> fold_map (subst subs) (xs @ ls @ rs') ||> process_fun descr eqns (i', fname') |-> (fn ts' => pair (list_comb (y, ts')))) end else fs |> fold_map (subst subs) (f :: ts) |-> (fn f' :: ts' => pair (list_comb (f', ts'))) end | subst _ t fs = (t, fs); (* translate rec equations into function arguments suitable for rec comb *) fun trans eqns (cname, cargs) (fnames', fnss', fns) = (case AList.lookup (op =) eqns cname of NONE => (warning ("No equation for constructor " ^ quote cname ^ "\nin definition of function " ^ quote fname); (fnames', fnss', (Const (\<^const_name>\undefined\, dummyT)) :: fns)) | SOME (ls, cargs', rs, rhs, eq) => let val recs = filter (Old_Datatype_Aux.is_rec_type o snd) (cargs' ~~ cargs); val rargs = map fst recs; val subs = map (rpair dummyT o fst) (rev (Term.rename_wrt_term rhs rargs)); val (rhs', (fnames'', fnss'')) = subst (map2 (fn (x, y) => fn z => (Free x, (Old_Datatype_Aux.body_index y, Free z))) recs subs) rhs (fnames', fnss') handle PrimrecError (s, NONE) => primrec_error_eqn s eq in (fnames'', fnss'', fold_rev absfree (cargs' @ subs @ ls @ rs) rhs' :: fns) end) in (case AList.lookup (op =) fnames i of NONE => if exists (fn (_, v) => fname = v) fnames then primrec_error ("inconsistent functions for datatype " ^ quote tname) else let val (_, _, eqns) = the (AList.lookup (op =) eqns fname); val (fnames', fnss', fns) = fold_rev (trans eqns) constrs ((i, fname) :: fnames, fnss, []) in (fnames', (i, (fname, #1 (snd (hd eqns)), fns)) :: fnss') end | SOME fname' => if fname = fname' then (fnames, fnss) else primrec_error ("inconsistent functions for datatype " ^ quote tname)) end; (* prepare functions needed for definitions *) fun get_fns fns ((i : int, (tname, _, constrs)), rec_name) (fs, defs) = (case AList.lookup (op =) fns i of NONE => let val dummy_fns = map (fn (_, cargs) => Const (\<^const_name>\undefined\, replicate (length cargs + length (filter Old_Datatype_Aux.is_rec_type cargs)) dummyT ---> HOLogic.unitT)) constrs; val _ = warning ("No function definition for datatype " ^ quote tname) in (dummy_fns @ fs, defs) end | SOME (fname, ls, fs') => (fs' @ fs, (fname, ls, rec_name) :: defs)); (* make definition *) fun make_def ctxt fixes fs (fname, ls, rec_name) = let val SOME (var, varT) = get_first (fn ((b, T), mx: mixfix) => if Binding.name_of b = fname then SOME ((b, mx), T) else NONE) fixes; val def_name = Thm.def_name (Long_Name.base_name fname); val raw_rhs = fold_rev (fn T => fn t => Abs ("", T, t)) (map snd ls @ [dummyT]) (list_comb (Const (rec_name, dummyT), fs @ map Bound (0 :: (length ls downto 1)))) val rhs = singleton (Syntax.check_terms ctxt) (Type.constraint varT raw_rhs); in (var, ((Binding.concealed (Binding.name def_name), []): Attrib.binding, rhs)) end; (* find datatypes which contain all datatypes in tnames' *) fun find_dts _ _ [] = [] | find_dts dt_info tnames' (tname :: tnames) = (case Symtab.lookup dt_info tname of NONE => primrec_error (quote tname ^ " is not a datatype") | SOME (dt : Old_Datatype_Aux.info) => if subset (op =) (tnames', map (#1 o snd) (#descr dt)) then (tname, dt) :: (find_dts dt_info tnames' tnames) else find_dts dt_info tnames' tnames); (* distill primitive definition(s) from primrec specification *) fun distill ctxt fixes eqs = let val eqns = fold_rev (process_eqn (fn v => Variable.is_fixed ctxt v orelse exists (fn ((w, _), _) => v = Binding.name_of w) fixes)) eqs []; val tnames = distinct (op =) (map (#1 o snd) eqns); val dts = find_dts (Old_Datatype_Data.get_all (Proof_Context.theory_of ctxt)) tnames tnames; val main_fns = map (fn (tname, {index, ...}) => (index, (fst o the o find_first (fn (_, x) => #1 x = tname)) eqns)) dts; val {descr, rec_names, rec_rewrites, ...} = if null dts then primrec_error ("datatypes " ^ commas_quote tnames ^ "\nare not mutually recursive") else snd (hd dts); val (fnames, fnss) = fold_rev (process_fun descr eqns) main_fns ([], []); val (fs, raw_defs) = fold_rev (get_fns fnss) (descr ~~ rec_names) ([], []); val defs = map (make_def ctxt fixes fs) raw_defs; val names = map snd fnames; val names_eqns = map fst eqns; val _ = if eq_set (op =) (names, names_eqns) then () else primrec_error ("functions " ^ commas_quote names_eqns ^ "\nare not mutually recursive"); val rec_rewrites' = map mk_meta_eq rec_rewrites; val prefix = space_implode "_" (map (Long_Name.base_name o #1) raw_defs); fun prove ctxt defs = let val frees = fold (Variable.add_free_names ctxt) eqs []; val rewrites = rec_rewrites' @ map (snd o snd) defs; in map (fn eq => Goal.prove ctxt frees [] eq (fn {context = ctxt', ...} => EVERY [rewrite_goals_tac ctxt' rewrites, resolve_tac ctxt' [refl] 1])) eqs end; in ((prefix, tnames, (fs, defs)), prove) end handle PrimrecError (msg, some_eqn) => error ("Primrec definition error:\n" ^ msg ^ (case some_eqn of SOME eqn => "\nin\n" ^ quote (Syntax.string_of_term ctxt eqn) | NONE => "")); (* primrec definition *) fun primrec_simple int fixes ts lthy = let val ((prefix, tnames, (_, defs)), prove) = distill lthy fixes ts; in lthy |> fold_map Local_Theory.define defs |> tap (uncurry (BNF_FP_Rec_Sugar_Util.print_def_consts int)) |-> (fn defs => `(fn lthy => {prefix = prefix, types = tnames, result = (map fst defs, prove lthy defs)})) end; local fun gen_primrec prep_spec int raw_fixes raw_spec lthy = let val (fixes, spec) = fst (prep_spec raw_fixes raw_spec lthy); + val spec_name = Local_Theory.full_name lthy (Binding.conglomerate (map (#1 o #1) fixes)); fun attr_bindings prefix = map (fn ((b, attrs), _) => (Binding.qualify false prefix b, attrs)) spec; fun simp_attr_binding prefix = (Binding.qualify true prefix (Binding.name "simps"), @{attributes [simp, nitpick_simp]}); in lthy |> primrec_simple int fixes (map snd spec) |-> (fn {prefix, types, result = (ts, simps)} => - Spec_Rules.add (Spec_Rules.equational_primrec types) (ts, simps) + Spec_Rules.add spec_name (Spec_Rules.equational_primrec types) ts simps #> fold_map Local_Theory.note (attr_bindings prefix ~~ map single simps) #-> (fn simps' => Local_Theory.note (simp_attr_binding prefix, maps snd simps') #-> (fn (_, simps'') => Code.declare_default_eqns (map (rpair true) simps'') #> pair {types = types, result = (ts, simps'')}))) end; in val primrec = gen_primrec Specification.check_multi_specs; val primrec_cmd = gen_primrec Specification.read_multi_specs; end; fun primrec_global int fixes specs thy = let val lthy = Named_Target.theory_init thy; val ({result = (ts, simps), ...}, lthy') = primrec int fixes specs lthy; val simps' = Proof_Context.export lthy' lthy simps; in ((ts, simps'), Local_Theory.exit_global lthy') end; fun primrec_overloaded int ops fixes specs thy = let val lthy = Overloading.overloading ops thy; val ({result = (ts, simps), ...}, lthy') = primrec int fixes specs lthy; val simps' = Proof_Context.export lthy' lthy simps; in ((ts, simps'), Local_Theory.exit_global lthy') end; end; diff --git a/src/HOL/Tools/Predicate_Compile/predicate_compile_data.ML b/src/HOL/Tools/Predicate_Compile/predicate_compile_data.ML --- a/src/HOL/Tools/Predicate_Compile/predicate_compile_data.ML +++ b/src/HOL/Tools/Predicate_Compile/predicate_compile_data.ML @@ -1,300 +1,300 @@ (* Title: HOL/Tools/Predicate_Compile/predicate_compile_data.ML Author: Lukas Bulwahn, TU Muenchen Book-keeping datastructure for the predicate compiler. *) signature PREDICATE_COMPILE_DATA = sig val ignore_consts : string list -> theory -> theory val keep_functions : string list -> theory -> theory val keep_function : theory -> string -> bool val processed_specs : theory -> string -> (string * thm list) list option val store_processed_specs : (string * (string * thm list) list) -> theory -> theory val get_specification : Predicate_Compile_Aux.options -> theory -> term -> thm list val obtain_specification_graph : Predicate_Compile_Aux.options -> theory -> term -> thm list Term_Graph.T val normalize_equation : theory -> thm -> thm end; structure Predicate_Compile_Data : PREDICATE_COMPILE_DATA = struct open Predicate_Compile_Aux; structure Data = Theory_Data ( type T = {ignore_consts : unit Symtab.table, keep_functions : unit Symtab.table, processed_specs : ((string * thm list) list) Symtab.table}; val empty = {ignore_consts = Symtab.empty, keep_functions = Symtab.empty, processed_specs = Symtab.empty}; val extend = I; fun merge ({ignore_consts = c1, keep_functions = k1, processed_specs = s1}, {ignore_consts = c2, keep_functions = k2, processed_specs = s2}) = {ignore_consts = Symtab.merge (K true) (c1, c2), keep_functions = Symtab.merge (K true) (k1, k2), processed_specs = Symtab.merge (K true) (s1, s2)} ); fun mk_data (c, k, s) = {ignore_consts = c, keep_functions = k, processed_specs = s} fun map_data f {ignore_consts = c, keep_functions = k, processed_specs = s} = mk_data (f (c, k, s)) fun ignore_consts cs = Data.map (map_data (@{apply 3(1)} (fold (fn c => Symtab.insert (op =) (c, ())) cs))) fun keep_functions cs = Data.map (map_data (@{apply 3(2)} (fold (fn c => Symtab.insert (op =) (c, ())) cs))) fun keep_function thy = Symtab.defined (#keep_functions (Data.get thy)) fun processed_specs thy = Symtab.lookup (#processed_specs (Data.get thy)) fun store_processed_specs (constname, specs) = Data.map (map_data (@{apply 3(3)} (Symtab.update_new (constname, specs)))) fun defining_term_of_introrule_term t = let val _ $ u = Logic.strip_imp_concl t in fst (strip_comb u) end (* in case pred of Const (c, T) => c | _ => raise TERM ("defining_const_of_introrule_term failed: Not a constant", [t]) end *) val defining_term_of_introrule = defining_term_of_introrule_term o Thm.prop_of fun defining_const_of_introrule th = (case defining_term_of_introrule th of Const (c, _) => c | _ => raise TERM ("defining_const_of_introrule failed: Not a constant", [Thm.prop_of th])) (*TODO*) fun is_introlike_term _ = true val is_introlike = is_introlike_term o Thm.prop_of fun check_equation_format_term (t as (Const (\<^const_name>\Pure.eq\, _) $ u $ _)) = (case strip_comb u of (Const (_, T), args) => if (length (binder_types T) = length args) then true else raise TERM ("check_equation_format_term failed: Number of arguments mismatch", [t]) | _ => raise TERM ("check_equation_format_term failed: Not a constant", [t])) | check_equation_format_term t = raise TERM ("check_equation_format_term failed: Not an equation", [t]) val check_equation_format = check_equation_format_term o Thm.prop_of fun defining_term_of_equation_term (Const (\<^const_name>\Pure.eq\, _) $ u $ _) = fst (strip_comb u) | defining_term_of_equation_term t = raise TERM ("defining_const_of_equation_term failed: Not an equation", [t]) val defining_term_of_equation = defining_term_of_equation_term o Thm.prop_of fun defining_const_of_equation th = (case defining_term_of_equation th of Const (c, _) => c | _ => raise TERM ("defining_const_of_equation failed: Not a constant", [Thm.prop_of th])) (* Normalizing equations *) fun mk_meta_equation th = (case Thm.prop_of th of Const (\<^const_name>\Trueprop\, _) $ (Const (\<^const_name>\HOL.eq\, _) $ _ $ _) => th RS @{thm eq_reflection} | _ => th) val meta_fun_cong = @{lemma "\f :: 'a::{} \ 'b::{}.f == g ==> f x == g x" by simp} fun full_fun_cong_expand th = let val (f, args) = strip_comb (fst (Logic.dest_equals (Thm.prop_of th))) val i = length (binder_types (fastype_of f)) - length args in funpow i (fn th => th RS meta_fun_cong) th end; fun declare_names s xs ctxt = let val res = Name.invent_names ctxt s xs in (res, fold Name.declare (map fst res) ctxt) end fun split_all_pairs thy th = let val ctxt = Proof_Context.init_global thy (* FIXME proper context!? *) val ((_, [th']), _) = Variable.import true [th] ctxt val t = Thm.prop_of th' val frees = Term.add_frees t [] val freenames = Term.add_free_names t [] val nctxt = Name.make_context freenames fun mk_tuple_rewrites (x, T) nctxt = let val Ts = HOLogic.flatten_tupleT T val (xTs, nctxt') = declare_names x Ts nctxt val paths = HOLogic.flat_tupleT_paths T in ((Free (x, T), HOLogic.mk_ptuple paths T (map Free xTs)), nctxt') end val (rewr, _) = fold_map mk_tuple_rewrites frees nctxt val t' = Pattern.rewrite_term thy rewr [] t val th'' = Goal.prove ctxt (Term.add_free_names t' []) [] t' (fn _ => ALLGOALS (Skip_Proof.cheat_tac ctxt)) val th''' = Local_Defs.unfold0 ctxt [@{thm split_conv}, @{thm fst_conv}, @{thm snd_conv}] th'' in th''' end; fun inline_equations thy th = let val ctxt = Proof_Context.init_global thy val inline_defs = Named_Theorems.get ctxt \<^named_theorems>\code_pred_inline\ val th' = Simplifier.full_simplify (put_simpset HOL_basic_ss ctxt addsimps inline_defs) th (*val _ = print_step options ("Inlining " ^ (Syntax.string_of_term_global thy (prop_of th)) ^ "with " ^ (commas (map ((Syntax.string_of_term_global thy) o prop_of) inline_defs)) ^" to " ^ (Syntax.string_of_term_global thy (prop_of th')))*) in th' end fun normalize_equation thy th = mk_meta_equation th |> full_fun_cong_expand |> split_all_pairs thy |> tap check_equation_format |> inline_equations thy fun normalize_intros thy th = split_all_pairs thy th |> inline_equations thy fun normalize thy th = if is_equationlike th then normalize_equation thy th else normalize_intros thy th fun get_specification options thy t = let (*val (c, T) = dest_Const t val t = Const (Axclass.unoverload_const thy (c, T), T)*) val _ = if show_steps options then tracing ("getting specification of " ^ Syntax.string_of_term_global thy t ^ " with type " ^ Syntax.string_of_typ_global thy (fastype_of t)) else () val ctxt = Proof_Context.init_global thy fun filtering th = if is_equationlike th andalso defining_const_of_equation (normalize_equation thy th) = fst (dest_Const t) then SOME (normalize_equation thy th) else if is_introlike th andalso defining_const_of_introrule th = fst (dest_Const t) then SOME th else NONE fun filter_defs ths = map_filter filtering (map (normalize thy o Thm.transfer thy) ths) val spec = (case filter_defs (Named_Theorems.get ctxt \<^named_theorems>\code_pred_def\) of [] => (case Spec_Rules.retrieve ctxt t of [] => error ("No specification for " ^ Syntax.string_of_term_global thy t) - | ((_, (_, ths)) :: _) => filter_defs ths) + | ({rules = ths, ...} :: _) => filter_defs ths) | ths => ths) val _ = if show_intermediate_results options then tracing ("Specification for " ^ (Syntax.string_of_term_global thy t) ^ ":\n" ^ commas (map (Thm.string_of_thm_global thy) spec)) else () in spec end val logic_operator_names = [\<^const_name>\Pure.eq\, \<^const_name>\Pure.imp\, \<^const_name>\Trueprop\, \<^const_name>\Not\, \<^const_name>\HOL.eq\, \<^const_name>\HOL.implies\, \<^const_name>\All\, \<^const_name>\Ex\, \<^const_name>\HOL.conj\, \<^const_name>\HOL.disj\] fun special_cases (c, _) = member (op =) [\<^const_name>\Product_Type.Unity\, \<^const_name>\False\, \<^const_name>\Suc\, \<^const_name>\Nat.zero_nat_inst.zero_nat\, \<^const_name>\Nat.one_nat_inst.one_nat\, \<^const_name>\Orderings.less\, \<^const_name>\Orderings.less_eq\, \<^const_name>\Groups.zero\, \<^const_name>\Groups.one\, \<^const_name>\Groups.plus\, \<^const_name>\Nat.ord_nat_inst.less_eq_nat\, \<^const_name>\Nat.ord_nat_inst.less_nat\, (* FIXME @{const_name number_nat_inst.number_of_nat}, *) \<^const_name>\Num.Bit0\, \<^const_name>\Num.Bit1\, \<^const_name>\Num.One\, \<^const_name>\Int.zero_int_inst.zero_int\, \<^const_name>\List.filter\, \<^const_name>\HOL.If\, \<^const_name>\Groups.minus\] c fun obtain_specification_graph options thy t = let val ctxt = Proof_Context.init_global thy fun is_nondefining_const (c, _) = member (op =) logic_operator_names c fun has_code_pred_intros (c, _) = can (Core_Data.intros_of ctxt) c fun case_consts (c, _) = is_some (Ctr_Sugar.ctr_sugar_of_case ctxt c) fun is_datatype_constructor (x as (_, T)) = (case body_type T of Type (Tcon, _) => can (Ctr_Sugar.dest_ctr ctxt Tcon) (Const x) | _ => false) fun defiants_of specs = fold (Term.add_consts o Thm.prop_of) specs [] |> filter_out is_datatype_constructor |> filter_out is_nondefining_const |> filter_out has_code_pred_intros |> filter_out case_consts |> filter_out special_cases |> filter_out (fn (c, _) => Symtab.defined (#ignore_consts (Data.get thy)) c) |> map (fn (c, _) => (c, Sign.the_const_constraint thy c)) |> map Const (* |> filter is_defining_constname*) fun extend t gr = if can (Term_Graph.get_node gr) t then gr else let val specs = get_specification options thy t (*val _ = print_specification options thy constname specs*) val us = defiants_of specs in gr |> Term_Graph.new_node (t, specs) |> fold extend us |> fold (fn u => Term_Graph.add_edge (t, u)) us end in extend t Term_Graph.empty end; end diff --git a/src/HOL/Tools/Sledgehammer/sledgehammer_fact.ML b/src/HOL/Tools/Sledgehammer/sledgehammer_fact.ML --- a/src/HOL/Tools/Sledgehammer/sledgehammer_fact.ML +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_fact.ML @@ -1,567 +1,567 @@ (* Title: HOL/Tools/Sledgehammer/sledgehammer_fact.ML Author: Jia Meng, Cambridge University Computer Laboratory and NICTA Author: Jasmin Blanchette, TU Muenchen Sledgehammer fact handling. *) signature SLEDGEHAMMER_FACT = sig type status = ATP_Problem_Generate.status type stature = ATP_Problem_Generate.stature type raw_fact = ((unit -> string) * stature) * thm type fact = (string * stature) * thm type fact_override = {add : (Facts.ref * Token.src list) list, del : (Facts.ref * Token.src list) list, only : bool} val instantiate_inducts : bool Config.T val no_fact_override : fact_override val fact_of_ref : Proof.context -> Keyword.keywords -> thm list -> status Termtab.table -> Facts.ref * Token.src list -> ((string * stature) * thm) list val cartouche_thm : Proof.context -> thm -> string val is_blacklisted_or_something : Proof.context -> bool -> string -> bool val clasimpset_rule_table_of : Proof.context -> status Termtab.table val build_name_tables : (thm -> string) -> ('a * thm) list -> string Symtab.table * string Symtab.table val fact_distinct : (term * term -> bool) -> ('a * thm) list -> ('a * thm) list val maybe_instantiate_inducts : Proof.context -> term list -> term -> (((unit -> string) * 'a) * thm) list -> (((unit -> string) * 'a) * thm) list val fact_of_raw_fact : raw_fact -> fact val is_useful_unnamed_local_fact : Proof.context -> thm -> bool val all_facts : Proof.context -> bool -> bool -> Keyword.keywords -> thm list -> thm list -> status Termtab.table -> raw_fact list val nearly_all_facts : Proof.context -> bool -> fact_override -> Keyword.keywords -> status Termtab.table -> thm list -> term list -> term -> raw_fact list val drop_duplicate_facts : raw_fact list -> raw_fact list end; structure Sledgehammer_Fact : SLEDGEHAMMER_FACT = struct open ATP_Util open ATP_Problem_Generate open Sledgehammer_Util type raw_fact = ((unit -> string) * stature) * thm type fact = (string * stature) * thm type fact_override = {add : (Facts.ref * Token.src list) list, del : (Facts.ref * Token.src list) list, only : bool} val local_thisN = Long_Name.localN ^ Long_Name.separator ^ Auto_Bind.thisN (* gracefully handle huge background theories *) val max_facts_for_duplicates = 50000 val max_facts_for_complex_check = 25000 val max_simps_for_clasimpset = 10000 (* experimental feature *) val instantiate_inducts = Attrib.setup_config_bool \<^binding>\sledgehammer_instantiate_inducts\ (K false) val no_fact_override = {add = [], del = [], only = false} fun needs_quoting keywords s = Keyword.is_literal keywords s orelse exists (not o Symbol_Pos.is_identifier) (Long_Name.explode s) fun make_name keywords multi j name = (name |> needs_quoting keywords name ? quote) ^ (if multi then "(" ^ string_of_int j ^ ")" else "") fun explode_interval _ (Facts.FromTo (i, j)) = i upto j | explode_interval max (Facts.From i) = i upto i + max - 1 | explode_interval _ (Facts.Single i) = [i] fun is_rec_eq lhs = Term.exists_subterm (curry (op =) (head_of lhs)) fun is_rec_def (\<^const>\Trueprop\ $ t) = is_rec_def t | is_rec_def (\<^const>\Pure.imp\ $ _ $ t2) = is_rec_def t2 | is_rec_def (Const (\<^const_name>\Pure.eq\, _) $ t1 $ t2) = is_rec_eq t1 t2 | is_rec_def (Const (\<^const_name>\HOL.eq\, _) $ t1 $ t2) = is_rec_eq t1 t2 | is_rec_def _ = false fun is_assum assms th = exists (fn ct => Thm.prop_of th aconv Thm.term_of ct) assms fun is_chained chained = member Thm.eq_thm_prop chained fun scope_of_thm global assms chained th = if is_chained chained th then Chained else if global then Global else if is_assum assms th then Assum else Local val may_be_induction = exists_subterm (fn Var (_, Type (\<^type_name>\fun\, [_, T])) => body_type T = \<^typ>\bool\ | _ => false) (* TODO: get rid of *) fun normalize_vars t = let fun normT (Type (s, Ts)) = fold_map normT Ts #>> curry Type s | normT (TVar (z as (_, S))) = (fn ((knownT, nT), accum) => (case find_index (equal z) knownT of ~1 => (TVar ((Name.uu, nT), S), ((z :: knownT, nT + 1), accum)) | j => (TVar ((Name.uu, nT - j - 1), S), ((knownT, nT), accum)))) | normT (T as TFree _) = pair T fun norm (t $ u) = norm t ##>> norm u #>> op $ | norm (Const (s, T)) = normT T #>> curry Const s | norm (Var (z as (_, T))) = normT T #> (fn (T, (accumT, (known, n))) => (case find_index (equal z) known of ~1 => (Var ((Name.uu, n), T), (accumT, (z :: known, n + 1))) | j => (Var ((Name.uu, n - j - 1), T), (accumT, (known, n))))) | norm (Abs (_, T, t)) = norm t ##>> normT T #>> (fn (t, T) => Abs (Name.uu, T, t)) | norm (Bound j) = pair (Bound j) | norm (Free (s, T)) = normT T #>> curry Free s in fst (norm t (([], 0), ([], 0))) end fun status_of_thm css name th = if Termtab.is_empty css then General else let val t = Thm.prop_of th in (* FIXME: use structured name *) if String.isSubstring ".induct" name andalso may_be_induction t then Induction else let val t = normalize_vars t in (case Termtab.lookup css t of SOME status => status | NONE => let val concl = Logic.strip_imp_concl t in (case try (HOLogic.dest_eq o HOLogic.dest_Trueprop) concl of SOME lrhss => let val prems = Logic.strip_imp_prems t val t' = Logic.list_implies (prems, Logic.mk_equals lrhss) in Termtab.lookup css t' |> the_default General end | NONE => General) end) end end fun stature_of_thm global assms chained css name th = (scope_of_thm global assms chained th, status_of_thm css name th) fun fact_of_ref ctxt keywords chained css (xthm as (xref, args)) = let val ths = Attrib.eval_thms ctxt [xthm] val bracket = implode (map (enclose "[" "]" o Pretty.unformatted_string_of o Token.pretty_src ctxt) args) fun nth_name j = (case xref of Facts.Fact s => cartouche (simplify_spaces (YXML.content_of s)) ^ bracket | Facts.Named (("", _), _) => "[" ^ bracket ^ "]" | Facts.Named ((name, _), NONE) => make_name keywords (length ths > 1) (j + 1) name ^ bracket | Facts.Named ((name, _), SOME intervals) => make_name keywords true (nth (maps (explode_interval (length ths)) intervals) j) name ^ bracket) fun add_nth th (j, rest) = let val name = nth_name j in (j + 1, ((name, stature_of_thm false [] chained css name th), th) :: rest) end in (0, []) |> fold add_nth ths |> snd end (* Reject theorems with names like "List.filter.filter_list_def" or "Accessible_Part.acc.defs", as these are definitions arising from packages. *) fun is_package_def s = let val ss = Long_Name.explode s in length ss > 2 andalso not (hd ss = "local") andalso exists (fn suf => String.isSuffix suf s) ["_case_def", "_rec_def", "_size_def", "_size_overloaded_def"] end (* FIXME: put other record thms here, or declare as "no_atp" *) fun multi_base_blacklist ctxt ho_atp = ["defs", "select_defs", "update_defs", "split", "splits", "split_asm", "ext_cases", "eq.simps", "eq.refl", "nchotomy", "case_cong", "case_cong_weak", "nat_of_char_simps", "nibble.simps", "nibble.distinct"] |> not (ho_atp orelse Config.get ctxt instantiate_inducts) ? append ["induct", "inducts"] |> map (prefix Long_Name.separator) (* The maximum apply depth of any "metis" call in "Metis_Examples" (back in 2007) was 11. *) val max_apply_depth = 18 fun apply_depth (f $ t) = Int.max (apply_depth f, apply_depth t + 1) | apply_depth (Abs (_, _, t)) = apply_depth t | apply_depth _ = 0 fun is_too_complex t = apply_depth t > max_apply_depth (* FIXME: Ad hoc list *) val technical_prefixes = ["ATP", "Code_Evaluation", "Datatype", "Enum", "Lazy_Sequence", "Limited_Sequence", "Meson", "Metis", "Nitpick", "Quickcheck_Random", "Quickcheck_Exhaustive", "Quickcheck_Narrowing", "Random_Sequence", "Sledgehammer", "SMT"] |> map (suffix Long_Name.separator) fun is_technical_const s = exists (fn pref => String.isPrefix pref s) technical_prefixes (* FIXME: make more reliable *) val sep_class_sep = Long_Name.separator ^ "class" ^ Long_Name.separator fun is_low_level_class_const s = s = \<^const_name>\equal_class.equal\ orelse String.isSubstring sep_class_sep s val sep_that = Long_Name.separator ^ Auto_Bind.thatN val skolem_thesis = Name.skolem Auto_Bind.thesisN fun is_that_fact th = exists_subterm (fn Free (s, _) => s = skolem_thesis | _ => false) (Thm.prop_of th) andalso String.isSuffix sep_that (Thm.get_name_hint th) datatype interest = Deal_Breaker | Interesting | Boring fun combine_interests Deal_Breaker _ = Deal_Breaker | combine_interests _ Deal_Breaker = Deal_Breaker | combine_interests Interesting _ = Interesting | combine_interests _ Interesting = Interesting | combine_interests Boring Boring = Boring val type_has_top_sort = exists_subtype (fn TFree (_, []) => true | TVar (_, []) => true | _ => false) fun is_likely_tautology_too_meta_or_too_technical th = let fun is_interesting_subterm (Const (s, _)) = not (member (op =) atp_widely_irrelevant_consts s) | is_interesting_subterm (Free _) = true | is_interesting_subterm _ = false fun interest_of_bool t = if exists_Const ((is_technical_const o fst) orf (is_low_level_class_const o fst) orf type_has_top_sort o snd) t then Deal_Breaker else if exists_type (exists_subtype (curry (op =) \<^typ>\prop\)) t orelse not (exists_subterm is_interesting_subterm t) then Boring else Interesting fun interest_of_prop _ (\<^const>\Trueprop\ $ t) = interest_of_bool t | interest_of_prop Ts (\<^const>\Pure.imp\ $ t $ u) = combine_interests (interest_of_prop Ts t) (interest_of_prop Ts u) | interest_of_prop Ts (Const (\<^const_name>\Pure.all\, _) $ Abs (_, T, t)) = if type_has_top_sort T then Deal_Breaker else interest_of_prop (T :: Ts) t | interest_of_prop Ts ((t as Const (\<^const_name>\Pure.all\, _)) $ u) = interest_of_prop Ts (t $ eta_expand Ts u 1) | interest_of_prop _ (Const (\<^const_name>\Pure.eq\, _) $ t $ u) = combine_interests (interest_of_bool t) (interest_of_bool u) | interest_of_prop _ _ = Deal_Breaker val t = Thm.prop_of th in (interest_of_prop [] t <> Interesting andalso not (Thm.eq_thm_prop (@{thm ext}, th))) orelse is_that_fact th end fun is_blacklisted_or_something ctxt ho_atp = let val blist = multi_base_blacklist ctxt ho_atp in fn name => is_package_def name orelse exists (fn s => String.isSuffix s name) blist end (* This is a terrible hack. Free variables are sometimes coded as "M__" when they are displayed as "M" and we want to avoid clashes with these. But sometimes it's even worse: "Ma__" encodes "M". So we simply reserve all prefixes of all free variables. In the worse case scenario, where the fact won't be resolved correctly, the user can fix it manually, e.g., by giving a name to the offending fact. *) fun all_prefixes_of s = map (fn i => String.extract (s, 0, SOME i)) (1 upto size s - 1) fun close_form t = (t, [] |> Term.add_free_names t |> maps all_prefixes_of) |> fold (fn ((s, i), T) => fn (t', taken) => let val s' = singleton (Name.variant_list taken) s in ((if fastype_of t' = HOLogic.boolT then HOLogic.all_const else Logic.all_const) T $ Abs (s', T, abstract_over (Var ((s, i), T), t')), s' :: taken) end) (Term.add_vars t [] |> sort_by (fst o fst)) |> fst fun cartouche_term ctxt = close_form #> hackish_string_of_term ctxt #> cartouche fun cartouche_thm ctxt = cartouche_term ctxt o Thm.prop_of (* TODO: rewrite to use nets and/or to reuse existing data structures *) fun clasimpset_rule_table_of ctxt = let val simps = ctxt |> simpset_of |> dest_ss |> #simps in if length simps >= max_simps_for_clasimpset then Termtab.empty else let fun add stature th = Termtab.update (normalize_vars (Thm.prop_of th), stature) val {safeIs, (* safeEs, *) unsafeIs, (* unsafeEs, *) ...} = ctxt |> claset_of |> Classical.rep_cs val intros = map #1 (Item_Net.content safeIs @ Item_Net.content unsafeIs) (* Add once it is used: val elims = Item_Net.content safeEs @ Item_Net.content unsafeEs |> map Classical.classical_rule *) val specs = Spec_Rules.get ctxt val (rec_defs, nonrec_defs) = specs - |> filter (Spec_Rules.is_equational o fst) - |> maps (snd o snd) + |> filter (Spec_Rules.is_equational o #rough_classification) + |> maps #rules |> List.partition (is_rec_def o Thm.prop_of) val spec_intros = specs - |> filter ((Spec_Rules.is_inductive orf Spec_Rules.is_co_inductive) o fst) - |> maps (snd o snd) + |> filter (Spec_Rules.is_relational o #rough_classification) + |> maps #rules in Termtab.empty |> fold (add Simp o snd) simps |> fold (add Rec_Def) rec_defs |> fold (add Non_Rec_Def) nonrec_defs (* Add once it is used: |> fold (add Elim) elims *) |> fold (add Intro) intros |> fold (add Inductive) spec_intros end end fun normalize_eq (\<^const>\Trueprop\ $ (t as (t0 as Const (\<^const_name>\HOL.eq\, _)) $ t1 $ t2)) = if is_less_equal (Term_Ord.fast_term_ord (t1, t2)) then t else t0 $ t2 $ t1 | normalize_eq (\<^const>\Trueprop\ $ (t as \<^const>\Not\ $ ((t0 as Const (\<^const_name>\HOL.eq\, _)) $ t1 $ t2))) = if is_less_equal (Term_Ord.fast_term_ord (t1, t2)) then t else HOLogic.mk_not (t0 $ t2 $ t1) | normalize_eq (Const (\<^const_name>\Pure.eq\, Type (_, [T, _])) $ t1 $ t2) = (if is_less_equal (Term_Ord.fast_term_ord (t1, t2)) then (t1, t2) else (t2, t1)) |> (fn (t1, t2) => HOLogic.eq_const T $ t1 $ t2) | normalize_eq t = t fun if_thm_before th th' = if Context.subthy_id (apply2 Thm.theory_id (th, th')) then th else th' (* Hack: Conflate the facts about a class as seen from the outside with the corresponding low-level facts, so that MaSh can learn from the low-level proofs. *) fun un_class_ify s = (case first_field "_class" s of SOME (pref, suf) => [s, pref ^ suf] | NONE => [s]) fun build_name_tables name_of facts = let fun cons_thm (_, th) = Termtab.cons_list (normalize_vars (normalize_eq (Thm.prop_of th)), th) fun add_plain canon alias = Symtab.update (Thm.get_name_hint alias, name_of (if_thm_before canon alias)) fun add_plains (_, aliases as canon :: _) = fold (add_plain canon) aliases fun add_inclass (name, target) = fold (fn s => Symtab.update (s, target)) (un_class_ify name) val prop_tab = fold cons_thm facts Termtab.empty val plain_name_tab = Termtab.fold add_plains prop_tab Symtab.empty val inclass_name_tab = Symtab.fold add_inclass plain_name_tab Symtab.empty in (plain_name_tab, inclass_name_tab) end fun fact_distinct eq facts = fold (fn (i, fact as (_, th)) => Net.insert_term_safe (eq o apply2 (normalize_eq o Thm.prop_of o snd o snd)) (normalize_eq (Thm.prop_of th), (i, fact))) (tag_list 0 facts) Net.empty |> Net.entries |> sort (int_ord o apply2 fst) |> map snd fun struct_induct_rule_on th = (case Logic.strip_horn (Thm.prop_of th) of (prems, \<^const>\Trueprop\ $ ((p as Var ((p_name, 0), _)) $ (a as Var (_, ind_T)))) => if not (is_TVar ind_T) andalso length prems > 1 andalso exists (exists_subterm (curry (op aconv) p)) prems andalso not (exists (exists_subterm (curry (op aconv) a)) prems) then SOME (p_name, ind_T) else NONE | _ => NONE) val instantiate_induct_timeout = seconds 0.01 fun instantiate_induct_rule ctxt concl_prop p_name ((name, stature), th) ind_x = let fun varify_noninducts (t as Free (s, T)) = if (s, T) = ind_x orelse can dest_funT T then t else Var ((s, 0), T) | varify_noninducts t = t val p_inst = concl_prop |> map_aterms varify_noninducts |> close_form |> lambda (Free ind_x) |> hackish_string_of_term ctxt in ((fn () => name () ^ "[where " ^ p_name ^ " = " ^ quote p_inst ^ "]", stature), th |> Rule_Insts.read_instantiate ctxt [(((p_name, 0), Position.none), p_inst)] []) end fun type_match thy (T1, T2) = (Sign.typ_match thy (T2, T1) Vartab.empty; true) handle Type.TYPE_MATCH => false fun instantiate_if_induct_rule ctxt stmt stmt_xs (ax as (_, th)) = (case struct_induct_rule_on th of SOME (p_name, ind_T) => let val thy = Proof_Context.theory_of ctxt in stmt_xs |> filter (fn (_, T) => type_match thy (T, ind_T)) |> map_filter (try (Timeout.apply instantiate_induct_timeout (instantiate_induct_rule ctxt stmt p_name ax))) end | NONE => [ax]) fun external_frees t = [] |> Term.add_frees t |> filter_out (Name.is_internal o fst) fun maybe_instantiate_inducts ctxt hyp_ts concl_t = if Config.get ctxt instantiate_inducts then let val ind_stmt = (hyp_ts |> filter_out (null o external_frees), concl_t) |> Logic.list_implies |> Object_Logic.atomize_term ctxt val ind_stmt_xs = external_frees ind_stmt in maps (instantiate_if_induct_rule ctxt ind_stmt ind_stmt_xs) end else I fun fact_of_raw_fact ((name, stature), th) = ((name (), stature), th) fun fact_count facts = Facts.fold_static (K (Integer.add 1)) facts 0 fun is_useful_unnamed_local_fact ctxt = let val thy = Proof_Context.theory_of ctxt val global_facts = Global_Theory.facts_of thy val local_facts = Proof_Context.facts_of ctxt val named_locals = Facts.dest_static true [global_facts] local_facts |> maps (map (normalize_eq o Thm.prop_of) o snd) in fn th => not (Thm.has_name_hint th) andalso not (member (op aconv) named_locals (normalize_eq (Thm.prop_of th))) end fun all_facts ctxt generous ho_atp keywords add_ths chained css = let val thy = Proof_Context.theory_of ctxt val transfer = Global_Theory.transfer_theories thy val global_facts = Global_Theory.facts_of thy val is_too_complex = if generous orelse fact_count global_facts >= max_facts_for_complex_check then K false else is_too_complex val local_facts = Proof_Context.facts_of ctxt val assms = Assumption.all_assms_of ctxt val named_locals = Facts.dest_static true [global_facts] local_facts val unnamed_locals = Facts.props local_facts |> map #1 |> filter (is_useful_unnamed_local_fact ctxt) |> map (pair "" o single) val full_space = Name_Space.merge (Facts.space_of global_facts, Facts.space_of local_facts) val is_blacklisted_or_something = is_blacklisted_or_something ctxt ho_atp fun add_facts global foldx facts = foldx (fn (name0, ths) => fn accum => if name0 <> "" andalso (Long_Name.is_hidden (Facts.intern facts name0) orelse ((Facts.is_concealed facts name0 orelse (not generous andalso is_blacklisted_or_something name0)) andalso forall (not o member Thm.eq_thm_prop add_ths) ths)) then accum else let val n = length ths val multi = n > 1 fun check_thms a = (case try (Proof_Context.get_thms ctxt) a of NONE => false | SOME ths' => eq_list Thm.eq_thm_prop (ths, ths')) in snd (fold_rev (fn th0 => fn (j, accum) => let val th = transfer th0 in (j - 1, if not (member Thm.eq_thm_prop add_ths th) andalso (is_likely_tautology_too_meta_or_too_technical th orelse is_too_complex (Thm.prop_of th)) then accum else let fun get_name () = if name0 = "" orelse name0 = local_thisN then cartouche_thm ctxt th else let val short_name = Facts.extern ctxt facts name0 in if check_thms short_name then short_name else let val long_name = Name_Space.extern ctxt full_space name0 in if check_thms long_name then long_name else name0 end end |> make_name keywords multi j val stature = stature_of_thm global assms chained css name0 th val new = ((get_name, stature), th) in (if multi then apsnd else apfst) (cons new) accum end) end) ths (n, accum)) end) in (* The single-theorem names go before the multiple-theorem ones (e.g., "xxx" vs. "xxx(3)"), so that single names are preferred when both are available. *) ([], []) |> add_facts false fold local_facts (unnamed_locals @ named_locals) |> add_facts true Facts.fold_static global_facts global_facts |> op @ end fun nearly_all_facts ctxt ho_atp {add, del, only} keywords css chained hyp_ts concl_t = if only andalso null add then [] else let val chained = chained |> maps (fn th => insert Thm.eq_thm_prop (zero_var_indexes th) [th]) in (if only then maps (map (fn ((name, stature), th) => ((K name, stature), th)) o fact_of_ref ctxt keywords chained css) add else let val (add, del) = apply2 (Attrib.eval_thms ctxt) (add, del) val facts = all_facts ctxt false ho_atp keywords add chained css |> filter_out ((member Thm.eq_thm_prop del orf (Named_Theorems.member ctxt \<^named_theorems>\no_atp\ andf not o member Thm.eq_thm_prop add)) o snd) in facts end) |> maybe_instantiate_inducts ctxt hyp_ts concl_t end fun drop_duplicate_facts facts = let val num_facts = length facts in facts |> num_facts <= max_facts_for_duplicates ? fact_distinct (op aconv) end end; diff --git a/src/HOL/Tools/inductive.ML b/src/HOL/Tools/inductive.ML --- a/src/HOL/Tools/inductive.ML +++ b/src/HOL/Tools/inductive.ML @@ -1,1317 +1,1318 @@ (* Title: HOL/Tools/inductive.ML Author: Lawrence C Paulson, Cambridge University Computer Laboratory Author: Stefan Berghofer and Markus Wenzel, TU Muenchen (Co)Inductive Definition module for HOL. Features: * least or greatest fixedpoints * mutually recursive definitions * definitions involving arbitrary monotone operators * automatically proves introduction and elimination rules Introduction rules have the form [| M Pj ti, ..., Q x, ... |] ==> Pk t where M is some monotone operator (usually the identity) Q x is any side condition on the free variables ti, t are any terms Pj, Pk are two of the predicates being defined in mutual recursion *) signature INDUCTIVE = sig type result = {preds: term list, elims: thm list, raw_induct: thm, induct: thm, inducts: thm list, intrs: thm list, eqs: thm list} val transform_result: morphism -> result -> result type info = {names: string list, coind: bool} * result val the_inductive: Proof.context -> term -> info val the_inductive_global: Proof.context -> string -> info val print_inductives: bool -> Proof.context -> unit val get_monos: Proof.context -> thm list val mono_add: attribute val mono_del: attribute val mk_cases_tac: Proof.context -> tactic val mk_cases: Proof.context -> term -> thm val inductive_forall_def: thm val rulify: Proof.context -> thm -> thm val inductive_cases: (Attrib.binding * term list) list -> local_theory -> (string * thm list) list * local_theory val inductive_cases_cmd: (Attrib.binding * string list) list -> local_theory -> (string * thm list) list * local_theory val ind_cases_rules: Proof.context -> string list -> (binding * string option * mixfix) list -> thm list val inductive_simps: (Attrib.binding * term list) list -> local_theory -> (string * thm list) list * local_theory val inductive_simps_cmd: (Attrib.binding * string list) list -> local_theory -> (string * thm list) list * local_theory type flags = {quiet_mode: bool, verbose: bool, alt_name: binding, coind: bool, no_elim: bool, no_ind: bool, skip_mono: bool} val add_inductive: flags -> ((binding * typ) * mixfix) list -> (string * typ) list -> (Attrib.binding * term) list -> thm list -> local_theory -> result * local_theory val add_inductive_cmd: bool -> bool -> (binding * string option * mixfix) list -> (binding * string option * mixfix) list -> Specification.multi_specs_cmd -> (Facts.ref * Token.src list) list -> local_theory -> result * local_theory val arities_of: thm -> (string * int) list val params_of: thm -> term list val partition_rules: thm -> thm list -> (string * thm list) list val partition_rules': thm -> (thm * 'a) list -> (string * (thm * 'a) list) list val unpartition_rules: thm list -> (string * 'a list) list -> 'a list val infer_intro_vars: theory -> thm -> int -> thm list -> term list list val inductive_internals: bool Config.T val select_disj_tac: Proof.context -> int -> int -> int -> tactic type add_ind_def = flags -> term list -> (Attrib.binding * term) list -> thm list -> term list -> (binding * mixfix) list -> local_theory -> result * local_theory - val declare_rules: binding -> bool -> bool -> string list -> term list -> + val declare_rules: binding -> bool -> bool -> string -> string list -> term list -> thm list -> binding list -> Token.src list list -> (thm * string list * int) list -> thm list -> thm -> local_theory -> thm list * thm list * thm list * thm * thm list * local_theory val add_ind_def: add_ind_def val gen_add_inductive: add_ind_def -> flags -> ((binding * typ) * mixfix) list -> (string * typ) list -> (Attrib.binding * term) list -> thm list -> local_theory -> result * local_theory val gen_add_inductive_cmd: add_ind_def -> bool -> bool -> (binding * string option * mixfix) list -> (binding * string option * mixfix) list -> Specification.multi_specs_cmd -> (Facts.ref * Token.src list) list -> local_theory -> result * local_theory val gen_ind_decl: add_ind_def -> bool -> (local_theory -> local_theory) parser end; structure Inductive: INDUCTIVE = struct (** theory context references **) val inductive_forall_def = @{thm HOL.induct_forall_def}; val inductive_conj_def = @{thm HOL.induct_conj_def}; val inductive_conj = @{thms induct_conj}; val inductive_atomize = @{thms induct_atomize}; val inductive_rulify = @{thms induct_rulify}; val inductive_rulify_fallback = @{thms induct_rulify_fallback}; val simp_thms1 = map mk_meta_eq @{lemma "(\ True) = False" "(\ False) = True" "(True \ P) = P" "(False \ P) = True" "(P \ True) = P" "(True \ P) = P" by (fact simp_thms)+}; val simp_thms2 = map mk_meta_eq [@{thm inf_fun_def}, @{thm inf_bool_def}] @ simp_thms1; val simp_thms3 = @{thms le_rel_bool_arg_iff if_False if_True conj_ac le_fun_def le_bool_def sup_fun_def sup_bool_def simp_thms if_bool_eq_disj all_simps ex_simps imp_conjL}; (** misc utilities **) val inductive_internals = Attrib.setup_config_bool \<^binding>\inductive_internals\ (K false); fun message quiet_mode s = if quiet_mode then () else writeln s; fun clean_message ctxt quiet_mode s = if Config.get ctxt quick_and_dirty then () else message quiet_mode s; fun coind_prefix true = "co" | coind_prefix false = ""; fun log (b: int) m n = if m >= n then 0 else 1 + log b (b * m) n; fun make_bool_args f g [] i = [] | make_bool_args f g (x :: xs) i = (if i mod 2 = 0 then f x else g x) :: make_bool_args f g xs (i div 2); fun make_bool_args' xs = make_bool_args (K \<^term>\False\) (K \<^term>\True\) xs; fun arg_types_of k c = drop k (binder_types (fastype_of c)); fun find_arg T x [] = raise Fail "find_arg" | find_arg T x ((p as (_, (SOME _, _))) :: ps) = apsnd (cons p) (find_arg T x ps) | find_arg T x ((p as (U, (NONE, y))) :: ps) = if (T: typ) = U then (y, (U, (SOME x, y)) :: ps) else apsnd (cons p) (find_arg T x ps); fun make_args Ts xs = map (fn (T, (NONE, ())) => Const (\<^const_name>\undefined\, T) | (_, (SOME t, ())) => t) (fold (fn (t, T) => snd o find_arg T t) xs (map (rpair (NONE, ())) Ts)); fun make_args' Ts xs Us = fst (fold_map (fn T => find_arg T ()) Us (Ts ~~ map (pair NONE) xs)); fun dest_predicate cs params t = let val k = length params; val (c, ts) = strip_comb t; val (xs, ys) = chop k ts; val i = find_index (fn c' => c' = c) cs; in if xs = params andalso i >= 0 then SOME (c, i, ys, chop (length ys) (arg_types_of k c)) else NONE end; fun mk_names a 0 = [] | mk_names a 1 = [a] | mk_names a n = map (fn i => a ^ string_of_int i) (1 upto n); fun select_disj_tac ctxt = let fun tacs 1 1 = [] | tacs _ 1 = [resolve_tac ctxt @{thms disjI1}] | tacs n i = resolve_tac ctxt @{thms disjI2} :: tacs (n - 1) (i - 1); in fn n => fn i => EVERY' (tacs n i) end; (** context data **) type result = {preds: term list, elims: thm list, raw_induct: thm, induct: thm, inducts: thm list, intrs: thm list, eqs: thm list}; fun transform_result phi {preds, elims, raw_induct: thm, induct, inducts, intrs, eqs} = let val term = Morphism.term phi; val thm = Morphism.thm phi; val fact = Morphism.fact phi; in {preds = map term preds, elims = fact elims, raw_induct = thm raw_induct, induct = thm induct, inducts = fact inducts, intrs = fact intrs, eqs = fact eqs} end; type info = {names: string list, coind: bool} * result; val empty_infos = Item_Net.init (op = o apply2 (#names o fst)) (#preds o snd) val empty_equations = Item_Net.init Thm.eq_thm_prop (single o fst o HOLogic.dest_eq o HOLogic.dest_Trueprop o Thm.prop_of); datatype data = Data of {infos: info Item_Net.T, monos: thm list, equations: thm Item_Net.T}; fun make_data (infos, monos, equations) = Data {infos = infos, monos = monos, equations = equations}; structure Data = Generic_Data ( type T = data; val empty = make_data (empty_infos, [], empty_equations); val extend = I; fun merge (Data {infos = infos1, monos = monos1, equations = equations1}, Data {infos = infos2, monos = monos2, equations = equations2}) = make_data (Item_Net.merge (infos1, infos2), Thm.merge_thms (monos1, monos2), Item_Net.merge (equations1, equations2)); ); fun map_data f = Data.map (fn Data {infos, monos, equations} => make_data (f (infos, monos, equations))); fun rep_data ctxt = Data.get (Context.Proof ctxt) |> (fn Data rep => rep); fun print_inductives verbose ctxt = let val {infos, monos, ...} = rep_data ctxt; val space = Consts.space_of (Proof_Context.consts_of ctxt); val consts = Item_Net.content infos |> maps (fn ({names, ...}, result) => map (rpair result) names) in [Pretty.block (Pretty.breaks (Pretty.str "(co)inductives:" :: map (Pretty.mark_str o #1) (Name_Space.markup_entries verbose ctxt space consts))), Pretty.big_list "monotonicity rules:" (map (Thm.pretty_thm_item ctxt) monos)] end |> Pretty.writeln_chunks; (* inductive info *) fun the_inductive ctxt term = Item_Net.retrieve (#infos (rep_data ctxt)) term |> the_single |> apsnd (transform_result (Morphism.transfer_morphism' ctxt)) fun the_inductive_global ctxt name = #infos (rep_data ctxt) |> Item_Net.content |> filter (fn ({names, ...}, _) => member op = names name) |> the_single |> apsnd (transform_result (Morphism.transfer_morphism' ctxt)) fun put_inductives info = map_data (fn (infos, monos, equations) => (Item_Net.update (apsnd (transform_result Morphism.trim_context_morphism) info) infos, monos, equations)); (* monotonicity rules *) fun get_monos ctxt = #monos (rep_data ctxt) |> map (Thm.transfer' ctxt); fun mk_mono ctxt thm = let fun eq_to_mono thm' = thm' RS (thm' RS @{thm eq_to_mono}); fun dest_less_concl thm = dest_less_concl (thm RS @{thm le_funD}) handle THM _ => thm RS @{thm le_boolD} in (case Thm.concl_of thm of Const (\<^const_name>\Pure.eq\, _) $ _ $ _ => eq_to_mono (HOLogic.mk_obj_eq thm) | _ $ (Const (\<^const_name>\HOL.eq\, _) $ _ $ _) => eq_to_mono thm | _ $ (Const (\<^const_name>\Orderings.less_eq\, _) $ _ $ _) => dest_less_concl (Seq.hd (REPEAT (FIRSTGOAL (resolve_tac ctxt [@{thm le_funI}, @{thm le_boolI'}])) thm)) | _ => thm) end handle THM _ => error ("Bad monotonicity theorem:\n" ^ Thm.string_of_thm ctxt thm); val mono_add = Thm.declaration_attribute (fn thm => fn context => map_data (fn (infos, monos, equations) => (infos, Thm.add_thm (Thm.trim_context (mk_mono (Context.proof_of context) thm)) monos, equations)) context); val mono_del = Thm.declaration_attribute (fn thm => fn context => map_data (fn (infos, monos, equations) => (infos, Thm.del_thm (mk_mono (Context.proof_of context) thm) monos, equations)) context); val _ = Theory.setup (Attrib.setup \<^binding>\mono\ (Attrib.add_del mono_add mono_del) "declaration of monotonicity rule"); (* equations *) fun retrieve_equations ctxt = Item_Net.retrieve (#equations (rep_data ctxt)) #> map (Thm.transfer' ctxt); val equation_add_permissive = Thm.declaration_attribute (fn thm => map_data (fn (infos, monos, equations) => (infos, monos, perhaps (try (Item_Net.update (Thm.trim_context thm))) equations))); (** process rules **) local fun err_in_rule ctxt name t msg = error (cat_lines ["Ill-formed introduction rule " ^ Binding.print name, Syntax.string_of_term ctxt t, msg]); fun err_in_prem ctxt name t p msg = error (cat_lines ["Ill-formed premise", Syntax.string_of_term ctxt p, "in introduction rule " ^ Binding.print name, Syntax.string_of_term ctxt t, msg]); val bad_concl = "Conclusion of introduction rule must be an inductive predicate"; val bad_ind_occ = "Inductive predicate occurs in argument of inductive predicate"; val bad_app = "Inductive predicate must be applied to parameter(s) "; fun atomize_term thy = Raw_Simplifier.rewrite_term thy inductive_atomize []; in fun check_rule ctxt cs params ((binding, att), rule) = let val params' = Term.variant_frees rule (Logic.strip_params rule); val frees = rev (map Free params'); val concl = subst_bounds (frees, Logic.strip_assums_concl rule); val prems = map (curry subst_bounds frees) (Logic.strip_assums_hyp rule); val rule' = Logic.list_implies (prems, concl); val aprems = map (atomize_term (Proof_Context.theory_of ctxt)) prems; val arule = fold_rev (Logic.all o Free) params' (Logic.list_implies (aprems, concl)); fun check_ind err t = (case dest_predicate cs params t of NONE => err (bad_app ^ commas (map (Syntax.string_of_term ctxt) params)) | SOME (_, _, ys, _) => if exists (fn c => exists (fn t => Logic.occs (c, t)) ys) cs then err bad_ind_occ else ()); fun check_prem' prem t = if member (op =) cs (head_of t) then check_ind (err_in_prem ctxt binding rule prem) t else (case t of Abs (_, _, t) => check_prem' prem t | t $ u => (check_prem' prem t; check_prem' prem u) | _ => ()); fun check_prem (prem, aprem) = if can HOLogic.dest_Trueprop aprem then check_prem' prem prem else err_in_prem ctxt binding rule prem "Non-atomic premise"; val _ = (case concl of Const (\<^const_name>\Trueprop\, _) $ t => if member (op =) cs (head_of t) then (check_ind (err_in_rule ctxt binding rule') t; List.app check_prem (prems ~~ aprems)) else err_in_rule ctxt binding rule' bad_concl | _ => err_in_rule ctxt binding rule' bad_concl); in ((binding, att), arule) end; fun rulify ctxt = hol_simplify ctxt inductive_conj #> hol_simplify ctxt inductive_rulify #> hol_simplify ctxt inductive_rulify_fallback #> Simplifier.norm_hhf ctxt; end; (** proofs for (co)inductive predicates **) (* prove monotonicity *) fun prove_mono quiet_mode skip_mono predT fp_fun monos ctxt = (message (quiet_mode orelse skip_mono andalso Config.get ctxt quick_and_dirty) " Proving monotonicity ..."; (if skip_mono then Goal.prove_sorry else Goal.prove_future) ctxt [] [] (HOLogic.mk_Trueprop (Const (\<^const_name>\Orderings.mono\, (predT --> predT) --> HOLogic.boolT) $ fp_fun)) (fn _ => EVERY [resolve_tac ctxt @{thms monoI} 1, REPEAT (resolve_tac ctxt [@{thm le_funI}, @{thm le_boolI'}] 1), REPEAT (FIRST [assume_tac ctxt 1, resolve_tac ctxt (map (mk_mono ctxt) monos @ get_monos ctxt) 1, eresolve_tac ctxt @{thms le_funE} 1, dresolve_tac ctxt @{thms le_boolD} 1])])); (* prove introduction rules *) fun prove_intrs quiet_mode coind mono fp_def k intr_ts rec_preds_defs ctxt ctxt' = let val _ = clean_message ctxt quiet_mode " Proving the introduction rules ..."; val unfold = funpow k (fn th => th RS fun_cong) (mono RS (fp_def RS (if coind then @{thm def_gfp_unfold} else @{thm def_lfp_unfold}))); val rules = [refl, TrueI, @{lemma "\ False" by (rule notI)}, exI, conjI]; val intrs = map_index (fn (i, intr) => Goal.prove_sorry ctxt [] [] intr (fn _ => EVERY [rewrite_goals_tac ctxt rec_preds_defs, resolve_tac ctxt [unfold RS iffD2] 1, select_disj_tac ctxt (length intr_ts) (i + 1) 1, (*Not ares_tac, since refl must be tried before any equality assumptions; backtracking may occur if the premises have extra variables!*) DEPTH_SOLVE_1 (resolve_tac ctxt rules 1 APPEND assume_tac ctxt 1)]) |> singleton (Proof_Context.export ctxt ctxt')) intr_ts in (intrs, unfold) end; (* prove elimination rules *) fun prove_elims quiet_mode cs params intr_ts intr_names unfold rec_preds_defs ctxt ctxt''' = let val _ = clean_message ctxt quiet_mode " Proving the elimination rules ..."; val ([pname], ctxt') = Variable.variant_fixes ["P"] ctxt; val P = HOLogic.mk_Trueprop (Free (pname, HOLogic.boolT)); fun dest_intr r = (the (dest_predicate cs params (HOLogic.dest_Trueprop (Logic.strip_assums_concl r))), Logic.strip_assums_hyp r, Logic.strip_params r); val intrs = map dest_intr intr_ts ~~ intr_names; val rules1 = [disjE, exE, FalseE]; val rules2 = [conjE, FalseE, @{lemma "\ True \ R" by (rule notE [OF _ TrueI])}]; fun prove_elim c = let val Ts = arg_types_of (length params) c; val (anames, ctxt'') = Variable.variant_fixes (mk_names "a" (length Ts)) ctxt'; val frees = map Free (anames ~~ Ts); fun mk_elim_prem ((_, _, us, _), ts, params') = Logic.list_all (params', Logic.list_implies (map (HOLogic.mk_Trueprop o HOLogic.mk_eq) (frees ~~ us) @ ts, P)); val c_intrs = filter (equal c o #1 o #1 o #1) intrs; val prems = HOLogic.mk_Trueprop (list_comb (c, params @ frees)) :: map mk_elim_prem (map #1 c_intrs) in (Goal.prove_sorry ctxt'' [] prems P (fn {context = ctxt4, prems} => EVERY [cut_tac (hd prems) 1, rewrite_goals_tac ctxt4 rec_preds_defs, dresolve_tac ctxt4 [unfold RS iffD1] 1, REPEAT (FIRSTGOAL (eresolve_tac ctxt4 rules1)), REPEAT (FIRSTGOAL (eresolve_tac ctxt4 rules2)), EVERY (map (fn prem => DEPTH_SOLVE_1 (assume_tac ctxt4 1 ORELSE resolve_tac ctxt [rewrite_rule ctxt4 rec_preds_defs prem, conjI] 1)) (tl prems))]) |> singleton (Proof_Context.export ctxt'' ctxt'''), map #2 c_intrs, length Ts) end in map prove_elim cs end; (* prove simplification equations *) fun prove_eqs quiet_mode cs params intr_ts intrs (elims: (thm * bstring list * int) list) ctxt ctxt'' = (* FIXME ctxt'' ?? *) let val _ = clean_message ctxt quiet_mode " Proving the simplification rules ..."; fun dest_intr r = (the (dest_predicate cs params (HOLogic.dest_Trueprop (Logic.strip_assums_concl r))), Logic.strip_assums_hyp r, Logic.strip_params r); val intr_ts' = map dest_intr intr_ts; fun prove_eq c (elim: thm * 'a * 'b) = let val Ts = arg_types_of (length params) c; val (anames, ctxt') = Variable.variant_fixes (mk_names "a" (length Ts)) ctxt; val frees = map Free (anames ~~ Ts); val c_intrs = filter (equal c o #1 o #1 o #1) (intr_ts' ~~ intrs); fun mk_intr_conj (((_, _, us, _), ts, params'), _) = let fun list_ex ([], t) = t | list_ex ((a, T) :: vars, t) = HOLogic.exists_const T $ Abs (a, T, list_ex (vars, t)); val conjs = map2 (curry HOLogic.mk_eq) frees us @ map HOLogic.dest_Trueprop ts; in list_ex (params', if null conjs then \<^term>\True\ else foldr1 HOLogic.mk_conj conjs) end; val lhs = list_comb (c, params @ frees); val rhs = if null c_intrs then \<^term>\False\ else foldr1 HOLogic.mk_disj (map mk_intr_conj c_intrs); val eq = HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs)); fun prove_intr1 (i, _) = Subgoal.FOCUS_PREMS (fn {context = ctxt'', params, prems, ...} => select_disj_tac ctxt'' (length c_intrs) (i + 1) 1 THEN EVERY (replicate (length params) (resolve_tac ctxt'' @{thms exI} 1)) THEN (if null prems then resolve_tac ctxt'' @{thms TrueI} 1 else let val (prems', last_prem) = split_last prems; in EVERY (map (fn prem => (resolve_tac ctxt'' @{thms conjI} 1 THEN resolve_tac ctxt'' [prem] 1)) prems') THEN resolve_tac ctxt'' [last_prem] 1 end)) ctxt' 1; fun prove_intr2 (((_, _, us, _), ts, params'), intr) = EVERY (replicate (length params') (eresolve_tac ctxt' @{thms exE} 1)) THEN (if null ts andalso null us then resolve_tac ctxt' [intr] 1 else EVERY (replicate (length ts + length us - 1) (eresolve_tac ctxt' @{thms conjE} 1)) THEN Subgoal.FOCUS_PREMS (fn {context = ctxt'', prems, ...} => let val (eqs, prems') = chop (length us) prems; val rew_thms = map (fn th => th RS @{thm eq_reflection}) eqs; in rewrite_goal_tac ctxt'' rew_thms 1 THEN resolve_tac ctxt'' [intr] 1 THEN EVERY (map (fn p => resolve_tac ctxt'' [p] 1) prems') end) ctxt' 1); in Goal.prove_sorry ctxt' [] [] eq (fn _ => resolve_tac ctxt' @{thms iffI} 1 THEN eresolve_tac ctxt' [#1 elim] 1 THEN EVERY (map_index prove_intr1 c_intrs) THEN (if null c_intrs then eresolve_tac ctxt' @{thms FalseE} 1 else let val (c_intrs', last_c_intr) = split_last c_intrs in EVERY (map (fn ci => eresolve_tac ctxt' @{thms disjE} 1 THEN prove_intr2 ci) c_intrs') THEN prove_intr2 last_c_intr end)) |> rulify ctxt' |> singleton (Proof_Context.export ctxt' ctxt'') end; in map2 prove_eq cs elims end; (* derivation of simplified elimination rules *) local (*delete needless equality assumptions*) val refl_thin = Goal.prove_global \<^theory>\HOL\ [] [] \<^prop>\\P. a = a \ P \ P\ (fn {context = ctxt, ...} => assume_tac ctxt 1); val elim_rls = [asm_rl, FalseE, refl_thin, conjE, exE]; fun elim_tac ctxt = REPEAT o eresolve_tac ctxt elim_rls; fun simp_case_tac ctxt i = EVERY' [elim_tac ctxt, asm_full_simp_tac ctxt, elim_tac ctxt, REPEAT o bound_hyp_subst_tac ctxt] i; in fun mk_cases_tac ctxt = ALLGOALS (simp_case_tac ctxt) THEN prune_params_tac ctxt; fun mk_cases ctxt prop = let fun err msg = error (Pretty.string_of (Pretty.block [Pretty.str msg, Pretty.fbrk, Syntax.pretty_term ctxt prop])); val elims = Induct.find_casesP ctxt prop; val cprop = Thm.cterm_of ctxt prop; fun mk_elim rl = Thm.implies_intr cprop (Tactic.rule_by_tactic ctxt (mk_cases_tac ctxt) (Thm.assume cprop RS rl)) |> singleton (Proof_Context.export (Proof_Context.augment prop ctxt) ctxt); in (case get_first (try mk_elim) elims of SOME r => r | NONE => err "Proposition not an inductive predicate:") end; end; (* inductive_cases *) fun gen_inductive_cases prep_att prep_prop args lthy = let val thmss = map snd args |> burrow (grouped 10 Par_List.map_independent (mk_cases lthy o prep_prop lthy)); val facts = map2 (fn ((a, atts), _) => fn thms => ((a, map (prep_att lthy) atts), [(thms, [])])) args thmss; in lthy |> Local_Theory.notes facts end; val inductive_cases = gen_inductive_cases (K I) Syntax.check_prop; val inductive_cases_cmd = gen_inductive_cases Attrib.check_src Syntax.read_prop; (* ind_cases *) fun ind_cases_rules ctxt raw_props raw_fixes = let val (props, ctxt') = Specification.read_props raw_props raw_fixes ctxt; val rules = Proof_Context.export ctxt' ctxt (map (mk_cases ctxt') props); in rules end; val _ = Theory.setup (Method.setup \<^binding>\ind_cases\ (Scan.lift (Scan.repeat1 Parse.prop -- Parse.for_fixes) >> (fn (props, fixes) => fn ctxt => Method.erule ctxt 0 (ind_cases_rules ctxt props fixes))) "case analysis for inductive definitions, based on simplified elimination rule"); (* derivation of simplified equation *) fun mk_simp_eq ctxt prop = let val thy = Proof_Context.theory_of ctxt; val ctxt' = Proof_Context.augment prop ctxt; val lhs_of = fst o HOLogic.dest_eq o HOLogic.dest_Trueprop o Thm.prop_of; val substs = retrieve_equations ctxt (HOLogic.dest_Trueprop prop) |> map_filter (fn eq => SOME (Pattern.match thy (lhs_of eq, HOLogic.dest_Trueprop prop) (Vartab.empty, Vartab.empty), eq) handle Pattern.MATCH => NONE); val (subst, eq) = (case substs of [s] => s | _ => error ("equations matching pattern " ^ Syntax.string_of_term ctxt prop ^ " is not unique")); val inst = map (fn v => (fst v, Thm.cterm_of ctxt' (Envir.subst_term subst (Var v)))) (Term.add_vars (lhs_of eq) []); in infer_instantiate ctxt' inst eq |> Conv.fconv_rule (Conv.arg_conv (Conv.arg_conv (Simplifier.full_rewrite ctxt'))) |> singleton (Proof_Context.export ctxt' ctxt) end (* inductive simps *) fun gen_inductive_simps prep_att prep_prop args lthy = let val facts = args |> map (fn ((a, atts), props) => ((a, map (prep_att lthy) atts), map (Thm.no_attributes o single o mk_simp_eq lthy o prep_prop lthy) props)); in lthy |> Local_Theory.notes facts end; val inductive_simps = gen_inductive_simps (K I) Syntax.check_prop; val inductive_simps_cmd = gen_inductive_simps Attrib.check_src Syntax.read_prop; (* prove induction rule *) fun prove_indrule quiet_mode cs argTs bs xs rec_const params intr_ts mono fp_def rec_preds_defs ctxt ctxt''' = (* FIXME ctxt''' ?? *) let val _ = clean_message ctxt quiet_mode " Proving the induction rule ..."; (* predicates for induction rule *) val (pnames, ctxt') = Variable.variant_fixes (mk_names "P" (length cs)) ctxt; val preds = map2 (curry Free) pnames (map (fn c => arg_types_of (length params) c ---> HOLogic.boolT) cs); (* transform an introduction rule into a premise for induction rule *) fun mk_ind_prem r = let fun subst s = (case dest_predicate cs params s of SOME (_, i, ys, (_, Ts)) => let val k = length Ts; val bs = map Bound (k - 1 downto 0); val P = list_comb (nth preds i, map (incr_boundvars k) ys @ bs); val Q = fold_rev Term.abs (mk_names "x" k ~~ Ts) (HOLogic.mk_binop \<^const_name>\HOL.induct_conj\ (list_comb (incr_boundvars k s, bs), P)); in (Q, case Ts of [] => SOME (s, P) | _ => NONE) end | NONE => (case s of t $ u => (fst (subst t) $ fst (subst u), NONE) | Abs (a, T, t) => (Abs (a, T, fst (subst t)), NONE) | _ => (s, NONE))); fun mk_prem s prems = (case subst s of (_, SOME (t, u)) => t :: u :: prems | (t, _) => t :: prems); val SOME (_, i, ys, _) = dest_predicate cs params (HOLogic.dest_Trueprop (Logic.strip_assums_concl r)); in fold_rev (Logic.all o Free) (Logic.strip_params r) (Logic.list_implies (map HOLogic.mk_Trueprop (fold_rev mk_prem (map HOLogic.dest_Trueprop (Logic.strip_assums_hyp r)) []), HOLogic.mk_Trueprop (list_comb (nth preds i, ys)))) end; val ind_prems = map mk_ind_prem intr_ts; (* make conclusions for induction rules *) val Tss = map (binder_types o fastype_of) preds; val (xnames, ctxt'') = Variable.variant_fixes (mk_names "x" (length (flat Tss))) ctxt'; val mutual_ind_concl = HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj (map (fn (((xnames, Ts), c), P) => let val frees = map Free (xnames ~~ Ts) in HOLogic.mk_imp (list_comb (c, params @ frees), list_comb (P, frees)) end) (unflat Tss xnames ~~ Tss ~~ cs ~~ preds))); (* make predicate for instantiation of abstract induction rule *) val ind_pred = fold_rev lambda (bs @ xs) (foldr1 HOLogic.mk_conj (map_index (fn (i, P) => fold_rev (curry HOLogic.mk_imp) (make_bool_args HOLogic.mk_not I bs i) (list_comb (P, make_args' argTs xs (binder_types (fastype_of P))))) preds)); val ind_concl = HOLogic.mk_Trueprop (HOLogic.mk_binrel \<^const_name>\Orderings.less_eq\ (rec_const, ind_pred)); val raw_fp_induct = mono RS (fp_def RS @{thm def_lfp_induct}); val induct = Goal.prove_sorry ctxt'' [] ind_prems ind_concl (fn {context = ctxt3, prems} => EVERY [rewrite_goals_tac ctxt3 [inductive_conj_def], DETERM (resolve_tac ctxt3 [raw_fp_induct] 1), REPEAT (resolve_tac ctxt3 [@{thm le_funI}, @{thm le_boolI}] 1), rewrite_goals_tac ctxt3 simp_thms2, (*This disjE separates out the introduction rules*) REPEAT (FIRSTGOAL (eresolve_tac ctxt3 [disjE, exE, FalseE])), (*Now break down the individual cases. No disjE here in case some premise involves disjunction.*) REPEAT (FIRSTGOAL (eresolve_tac ctxt3 [conjE] ORELSE' bound_hyp_subst_tac ctxt3)), REPEAT (FIRSTGOAL (resolve_tac ctxt3 [conjI, impI] ORELSE' (eresolve_tac ctxt3 [notE] THEN' assume_tac ctxt3))), EVERY (map (fn prem => DEPTH_SOLVE_1 (assume_tac ctxt3 1 ORELSE resolve_tac ctxt3 [rewrite_rule ctxt3 (inductive_conj_def :: rec_preds_defs @ simp_thms2) prem, conjI, refl] 1)) prems)]); val lemma = Goal.prove_sorry ctxt'' [] [] (Logic.mk_implies (ind_concl, mutual_ind_concl)) (fn {context = ctxt3, ...} => EVERY [rewrite_goals_tac ctxt3 rec_preds_defs, REPEAT (EVERY [REPEAT (resolve_tac ctxt3 [conjI, impI] 1), REPEAT (eresolve_tac ctxt3 [@{thm le_funE}, @{thm le_boolE}] 1), assume_tac ctxt3 1, rewrite_goals_tac ctxt3 simp_thms1, assume_tac ctxt3 1])]); in singleton (Proof_Context.export ctxt'' ctxt''') (induct RS lemma) end; (* prove coinduction rule *) fun If_const T = Const (\<^const_name>\If\, HOLogic.boolT --> T --> T --> T); fun mk_If p t f = let val T = fastype_of t in If_const T $ p $ t $ f end; fun prove_coindrule quiet_mode preds cs argTs bs xs params intr_ts mono fp_def rec_preds_defs ctxt ctxt''' = (* FIXME ctxt''' ?? *) let val _ = clean_message ctxt quiet_mode " Proving the coinduction rule ..."; val n = length cs; val (ns, xss) = map_split (fn pred => make_args' argTs xs (arg_types_of (length params) pred) |> `length) preds; val xTss = map (map fastype_of) xss; val (Rs_names, names_ctxt) = Variable.variant_fixes (mk_names "X" n) ctxt; val Rs = map2 (fn name => fn Ts => Free (name, Ts ---> \<^typ>\bool\)) Rs_names xTss; val Rs_applied = map2 (curry list_comb) Rs xss; val preds_applied = map2 (curry list_comb) (map (fn p => list_comb (p, params)) preds) xss; val abstract_list = fold_rev (absfree o dest_Free); val bss = map (make_bool_args (fn b => HOLogic.mk_eq (b, \<^term>\False\)) (fn b => HOLogic.mk_eq (b, \<^term>\True\)) bs) (0 upto n - 1); val eq_undefinedss = map (fn ys => map (fn x => HOLogic.mk_eq (x, Const (\<^const_name>\undefined\, fastype_of x))) (subtract (op =) ys xs)) xss; val R = @{fold 3} (fn bs => fn eqs => fn R => fn t => if null bs andalso null eqs then R else mk_If (Library.foldr1 HOLogic.mk_conj (bs @ eqs)) R t) bss eq_undefinedss Rs_applied \<^term>\False\ |> abstract_list (bs @ xs); fun subst t = (case dest_predicate cs params t of SOME (_, i, ts, (_, Us)) => let val l = length Us; val bs = map Bound (l - 1 downto 0); val args = map (incr_boundvars l) ts @ bs in HOLogic.mk_disj (list_comb (nth Rs i, args), list_comb (nth preds i, params @ args)) |> fold_rev absdummy Us end | NONE => (case t of t1 $ t2 => subst t1 $ subst t2 | Abs (x, T, u) => Abs (x, T, subst u) | _ => t)); fun mk_coind_prem r = let val SOME (_, i, ts, (Ts, _)) = dest_predicate cs params (HOLogic.dest_Trueprop (Logic.strip_assums_concl r)); val ps = map HOLogic.mk_eq (make_args' argTs xs Ts ~~ ts) @ map (subst o HOLogic.dest_Trueprop) (Logic.strip_assums_hyp r); in (i, fold_rev (fn (x, T) => fn P => HOLogic.exists_const T $ Abs (x, T, P)) (Logic.strip_params r) (if null ps then \<^term>\True\ else foldr1 HOLogic.mk_conj ps)) end; fun mk_prem i Ps = Logic.mk_implies ((nth Rs_applied i, Library.foldr1 HOLogic.mk_disj Ps) |> @{apply 2} HOLogic.mk_Trueprop) |> fold_rev Logic.all (nth xss i); val prems = map mk_coind_prem intr_ts |> AList.group (op =) |> sort (int_ord o apply2 fst) |> map (uncurry mk_prem); val concl = @{map 3} (fn xs => Ctr_Sugar_Util.list_all_free xs oo curry HOLogic.mk_imp) xss Rs_applied preds_applied |> Library.foldr1 HOLogic.mk_conj |> HOLogic.mk_Trueprop; val pred_defs_sym = if null rec_preds_defs then [] else map2 (fn n => fn thm => funpow n (fn thm => thm RS @{thm meta_fun_cong}) thm RS @{thm Pure.symmetric}) ns rec_preds_defs; val simps = simp_thms3 @ pred_defs_sym; val simprocs = [Simplifier.the_simproc ctxt "HOL.defined_All"]; val simplify = asm_full_simplify (Ctr_Sugar_Util.ss_only simps ctxt addsimprocs simprocs); val coind = (mono RS (fp_def RS @{thm def_coinduct})) |> infer_instantiate' ctxt [SOME (Thm.cterm_of ctxt R)] |> simplify; fun idx_of t = find_index (fn R => R = the_single (subtract (op =) (preds @ params) (map Free (Term.add_frees t [])))) Rs; val coind_concls = HOLogic.dest_Trueprop (Thm.concl_of coind) |> HOLogic.dest_conj |> map (fn t => (idx_of t, t)) |> sort (int_ord o @{apply 2} fst) |> map snd; val reorder_bound_goals = map_filter (fn (t, u) => if t aconv u then NONE else SOME (HOLogic.mk_Trueprop (HOLogic.mk_eq (t, u)))) ((HOLogic.dest_Trueprop concl |> HOLogic.dest_conj) ~~ coind_concls); val reorder_bound_thms = map (fn goal => Goal.prove_sorry ctxt [] [] goal (fn {context = ctxt, prems = _} => HEADGOAL (EVERY' [resolve_tac ctxt [iffI], REPEAT_DETERM o resolve_tac ctxt [allI, impI], REPEAT_DETERM o dresolve_tac ctxt [spec], eresolve_tac ctxt [mp], assume_tac ctxt, REPEAT_DETERM o resolve_tac ctxt [allI, impI], REPEAT_DETERM o dresolve_tac ctxt [spec], eresolve_tac ctxt [mp], assume_tac ctxt]))) reorder_bound_goals; val coinduction = Goal.prove_sorry ctxt [] prems concl (fn {context = ctxt, prems = CIH} => HEADGOAL (full_simp_tac (Ctr_Sugar_Util.ss_only (simps @ reorder_bound_thms) ctxt addsimprocs simprocs) THEN' resolve_tac ctxt [coind]) THEN ALLGOALS (REPEAT_ALL_NEW (REPEAT_DETERM o resolve_tac ctxt [allI, impI, conjI] THEN' REPEAT_DETERM o eresolve_tac ctxt [exE, conjE] THEN' dresolve_tac ctxt (map simplify CIH) THEN' REPEAT_DETERM o (assume_tac ctxt ORELSE' eresolve_tac ctxt [conjE] ORELSE' dresolve_tac ctxt [spec, mp])))) in coinduction |> length cs = 1 ? (Object_Logic.rulify ctxt #> rotate_prems ~1) |> singleton (Proof_Context.export names_ctxt ctxt''') end (** specification of (co)inductive predicates **) fun mk_ind_def quiet_mode skip_mono alt_name coind cs intr_ts monos params cnames_syn lthy = let val fp_name = if coind then \<^const_name>\Inductive.gfp\ else \<^const_name>\Inductive.lfp\; val argTs = fold (combine (op =) o arg_types_of (length params)) cs []; val k = log 2 1 (length cs); val predT = replicate k HOLogic.boolT ---> argTs ---> HOLogic.boolT; val p :: xs = map Free (Variable.variant_frees lthy intr_ts (("p", predT) :: (mk_names "x" (length argTs) ~~ argTs))); val bs = map Free (Variable.variant_frees lthy (p :: xs @ intr_ts) (map (rpair HOLogic.boolT) (mk_names "b" k))); fun subst t = (case dest_predicate cs params t of SOME (_, i, ts, (Ts, Us)) => let val l = length Us; val zs = map Bound (l - 1 downto 0); in fold_rev (Term.abs o pair "z") Us (list_comb (p, make_bool_args' bs i @ make_args argTs ((map (incr_boundvars l) ts ~~ Ts) @ (zs ~~ Us)))) end | NONE => (case t of t1 $ t2 => subst t1 $ subst t2 | Abs (x, T, u) => Abs (x, T, subst u) | _ => t)); (* transform an introduction rule into a conjunction *) (* [| p_i t; ... |] ==> p_j u *) (* is transformed into *) (* b_j & x_j = u & p b_j t & ... *) fun transform_rule r = let val SOME (_, i, ts, (Ts, _)) = dest_predicate cs params (HOLogic.dest_Trueprop (Logic.strip_assums_concl r)); val ps = make_bool_args HOLogic.mk_not I bs i @ map HOLogic.mk_eq (make_args' argTs xs Ts ~~ ts) @ map (subst o HOLogic.dest_Trueprop) (Logic.strip_assums_hyp r); in fold_rev (fn (x, T) => fn P => HOLogic.exists_const T $ Abs (x, T, P)) (Logic.strip_params r) (if null ps then \<^term>\True\ else foldr1 HOLogic.mk_conj ps) end; (* make a disjunction of all introduction rules *) val fp_fun = fold_rev lambda (p :: bs @ xs) (if null intr_ts then \<^term>\False\ else foldr1 HOLogic.mk_disj (map transform_rule intr_ts)); (* add definition of recursive predicates to theory *) val is_auxiliary = length cs > 1; val rec_binding = if Binding.is_empty alt_name then Binding.conglomerate (map #1 cnames_syn) else alt_name; val rec_name = Binding.name_of rec_binding; val internals = Config.get lthy inductive_internals; val ((rec_const, (_, fp_def)), lthy') = lthy |> is_auxiliary ? Proof_Context.concealed |> Local_Theory.define ((rec_binding, case cnames_syn of [(_, mx)] => mx | _ => NoSyn), ((Thm.make_def_binding internals rec_binding, @{attributes [nitpick_unfold]}), fold_rev lambda params (Const (fp_name, (predT --> predT) --> predT) $ fp_fun))) ||> Proof_Context.restore_naming lthy; val fp_def' = Simplifier.rewrite (put_simpset HOL_basic_ss lthy' addsimps [fp_def]) (Thm.cterm_of lthy' (list_comb (rec_const, params))); val specs = if is_auxiliary then map_index (fn (i, ((b, mx), c)) => let val Ts = arg_types_of (length params) c; val xs = map Free (Variable.variant_frees lthy' intr_ts (mk_names "x" (length Ts) ~~ Ts)); in ((b, mx), ((Thm.make_def_binding internals b, []), fold_rev lambda (params @ xs) (list_comb (rec_const, params @ make_bool_args' bs i @ make_args argTs (xs ~~ Ts))))) end) (cnames_syn ~~ cs) else []; val (consts_defs, lthy'') = lthy' |> fold_map Local_Theory.define specs; val preds = (case cs of [_] => [rec_const] | _ => map #1 consts_defs); val (_, ctxt'') = Variable.add_fixes (map (fst o dest_Free) params) lthy''; val mono = prove_mono quiet_mode skip_mono predT fp_fun monos ctxt''; val (_, lthy''') = lthy'' |> Local_Theory.note ((if internals then Binding.qualify true rec_name (Binding.name "mono") else Binding.empty, []), Proof_Context.export ctxt'' lthy'' [mono]); in (lthy''', Proof_Context.transfer (Proof_Context.theory_of lthy''') ctxt'', rec_binding, mono, fp_def', map (#2 o #2) consts_defs, list_comb (rec_const, params), preds, argTs, bs, xs) end; -fun declare_rules rec_binding coind no_ind cnames +fun declare_rules rec_binding coind no_ind spec_name cnames preds intrs intr_bindings intr_atts elims eqs raw_induct lthy = let val rec_name = Binding.name_of rec_binding; fun rec_qualified qualified = Binding.qualify qualified rec_name; val intr_names = map Binding.name_of intr_bindings; val ind_case_names = if forall (equal "") intr_names then [] else [Attrib.case_names intr_names]; val induct = if coind then (raw_induct, [Attrib.case_names [rec_name], Attrib.case_conclusion (rec_name, intr_names), Attrib.consumes (1 - Thm.nprems_of raw_induct), Attrib.internal (K (Induct.coinduct_pred (hd cnames)))]) else if no_ind orelse length cnames > 1 then (raw_induct, ind_case_names @ [Attrib.consumes (~ (Thm.nprems_of raw_induct))]) else (raw_induct RSN (2, rev_mp), ind_case_names @ [Attrib.consumes (~ (Thm.nprems_of raw_induct))]); val (intrs', lthy1) = lthy |> - Spec_Rules.add - (if coind then Spec_Rules.Co_Inductive else Spec_Rules.Inductive) (preds, intrs) |> + Spec_Rules.add spec_name + (if coind then Spec_Rules.Co_Inductive else Spec_Rules.Inductive) preds intrs |> Local_Theory.notes (map (rec_qualified false) intr_bindings ~~ intr_atts ~~ map (fn th => [([th], @{attributes [Pure.intro?]})]) intrs) |>> map (hd o snd); val (((_, elims'), (_, [induct'])), lthy2) = lthy1 |> Local_Theory.note ((rec_qualified true (Binding.name "intros"), []), intrs') ||>> fold_map (fn (name, (elim, cases, k)) => Local_Theory.note ((Binding.qualify true (Long_Name.base_name name) (Binding.name "cases"), ((if forall (equal "") cases then [] else [Attrib.case_names cases]) @ [Attrib.consumes (1 - Thm.nprems_of elim), Attrib.constraints k, Attrib.internal (K (Induct.cases_pred name))] @ @{attributes [Pure.elim?]})), [elim]) #> apfst (hd o snd)) (if null elims then [] else cnames ~~ elims) ||>> Local_Theory.note ((rec_qualified true (Binding.name (coind_prefix coind ^ "induct")), #2 induct), [rulify lthy1 (#1 induct)]); val (eqs', lthy3) = lthy2 |> fold_map (fn (name, eq) => Local_Theory.note ((Binding.qualify true (Long_Name.base_name name) (Binding.name "simps"), [Attrib.internal (K equation_add_permissive)]), [eq]) #> apfst (hd o snd)) (if null eqs then [] else (cnames ~~ eqs)) val (inducts, lthy4) = if no_ind orelse coind then ([], lthy3) else let val inducts = cnames ~~ Project_Rule.projects lthy3 (1 upto length cnames) induct' in lthy3 |> Local_Theory.notes [((rec_qualified true (Binding.name "inducts"), []), inducts |> map (fn (name, th) => ([th], ind_case_names @ [Attrib.consumes (1 - Thm.nprems_of th), Attrib.internal (K (Induct.induct_pred name))])))] |>> snd o hd end; in (intrs', elims', eqs', induct', inducts, lthy4) end; type flags = {quiet_mode: bool, verbose: bool, alt_name: binding, coind: bool, no_elim: bool, no_ind: bool, skip_mono: bool}; type add_ind_def = flags -> term list -> (Attrib.binding * term) list -> thm list -> term list -> (binding * mixfix) list -> local_theory -> result * local_theory; fun add_ind_def {quiet_mode, verbose, alt_name, coind, no_elim, no_ind, skip_mono} cs intros monos params cnames_syn lthy = let val _ = null cnames_syn andalso error "No inductive predicates given"; val names = map (Binding.name_of o fst) cnames_syn; val _ = message (quiet_mode andalso not verbose) ("Proofs for " ^ coind_prefix coind ^ "inductive predicate(s) " ^ commas_quote names); + val spec_name = Local_Theory.full_name lthy (Binding.conglomerate (map #1 cnames_syn)); val cnames = map (Local_Theory.full_name lthy o #1) cnames_syn; (* FIXME *) val ((intr_names, intr_atts), intr_ts) = apfst split_list (split_list (map (check_rule lthy cs params) intros)); val (lthy1, lthy2, rec_binding, mono, fp_def, rec_preds_defs, rec_const, preds, argTs, bs, xs) = mk_ind_def quiet_mode skip_mono alt_name coind cs intr_ts monos params cnames_syn lthy; val (intrs, unfold) = prove_intrs quiet_mode coind mono fp_def (length bs + length xs) intr_ts rec_preds_defs lthy2 lthy1; val elims = if no_elim then [] else prove_elims quiet_mode cs params intr_ts (map Binding.name_of intr_names) unfold rec_preds_defs lthy2 lthy1; val raw_induct = zero_var_indexes (if no_ind then Drule.asm_rl else if coind then prove_coindrule quiet_mode preds cs argTs bs xs params intr_ts mono fp_def rec_preds_defs lthy2 lthy1 else prove_indrule quiet_mode cs argTs bs xs rec_const params intr_ts mono fp_def rec_preds_defs lthy2 lthy1); val eqs = if no_elim then [] else prove_eqs quiet_mode cs params intr_ts intrs elims lthy2 lthy1; val elims' = map (fn (th, ns, i) => (rulify lthy1 th, ns, i)) elims; val intrs' = map (rulify lthy1) intrs; val (intrs'', elims'', eqs', induct, inducts, lthy3) = declare_rules rec_binding coind no_ind - cnames preds intrs' intr_names intr_atts elims' eqs raw_induct lthy1; + spec_name cnames preds intrs' intr_names intr_atts elims' eqs raw_induct lthy1; val result = {preds = preds, intrs = intrs'', elims = elims'', raw_induct = rulify lthy3 raw_induct, induct = induct, inducts = inducts, eqs = eqs'}; val lthy4 = lthy3 |> Local_Theory.declaration {syntax = false, pervasive = false} (fn phi => let val result' = transform_result phi result; in put_inductives ({names = cnames, coind = coind}, result') end); in (result, lthy4) end; (* external interfaces *) fun gen_add_inductive mk_def flags cnames_syn pnames spec monos lthy = let (* abbrevs *) val (_, ctxt1) = Variable.add_fixes (map (Binding.name_of o fst o fst) cnames_syn) lthy; fun get_abbrev ((name, atts), t) = if can (Logic.strip_assums_concl #> Logic.dest_equals) t then let val _ = Binding.is_empty name andalso null atts orelse error "Abbreviations may not have names or attributes"; val ((x, T), rhs) = Local_Defs.abs_def (snd (Local_Defs.cert_def ctxt1 (K []) t)); val var = (case find_first (fn ((c, _), _) => Binding.name_of c = x) cnames_syn of NONE => error ("Undeclared head of abbreviation " ^ quote x) | SOME ((b, T'), mx) => if T <> T' then error ("Bad type specification for abbreviation " ^ quote x) else (b, mx)); in SOME (var, rhs) end else NONE; val abbrevs = map_filter get_abbrev spec; val bs = map (Binding.name_of o fst o fst) abbrevs; (* predicates *) val pre_intros = filter_out (is_some o get_abbrev) spec; val cnames_syn' = filter_out (member (op =) bs o Binding.name_of o fst o fst) cnames_syn; val cs = map (Free o apfst Binding.name_of o fst) cnames_syn'; val ps = map Free pnames; val (_, ctxt2) = lthy |> Variable.add_fixes (map (Binding.name_of o fst o fst) cnames_syn'); val ctxt3 = ctxt2 |> fold (snd oo Local_Defs.fixed_abbrev) abbrevs; val expand = Assumption.export_term ctxt3 lthy #> Proof_Context.cert_term lthy; fun close_rule r = fold (Logic.all o Free) (fold_aterms (fn t as Free (v as (s, _)) => if Variable.is_fixed ctxt1 s orelse member (op =) ps t then I else insert (op =) v | _ => I) r []) r; val intros = map (apsnd (Syntax.check_term lthy #> close_rule #> expand)) pre_intros; val preds = map (fn ((c, _), mx) => (c, mx)) cnames_syn'; in lthy |> mk_def flags cs intros monos ps preds ||> fold (snd oo Local_Theory.abbrev Syntax.mode_default) abbrevs end; fun gen_add_inductive_cmd mk_def verbose coind cnames_syn pnames_syn intro_srcs raw_monos lthy = let val ((vars, intrs), _) = lthy |> Proof_Context.set_mode Proof_Context.mode_abbrev |> Specification.read_multi_specs (cnames_syn @ pnames_syn) intro_srcs; val (cs, ps) = chop (length cnames_syn) vars; val monos = Attrib.eval_thms lthy raw_monos; val flags = {quiet_mode = false, verbose = verbose, alt_name = Binding.empty, coind = coind, no_elim = false, no_ind = false, skip_mono = false}; in lthy |> gen_add_inductive mk_def flags cs (map (apfst Binding.name_of o fst) ps) intrs monos end; val add_inductive = gen_add_inductive add_ind_def; val add_inductive_cmd = gen_add_inductive_cmd add_ind_def; (* read off arities of inductive predicates from raw induction rule *) fun arities_of induct = map (fn (_ $ t $ u) => (fst (dest_Const (head_of t)), length (snd (strip_comb u)))) (HOLogic.dest_conj (HOLogic.dest_Trueprop (Thm.concl_of induct))); (* read off parameters of inductive predicate from raw induction rule *) fun params_of induct = let val (_ $ t $ u :: _) = HOLogic.dest_conj (HOLogic.dest_Trueprop (Thm.concl_of induct)); val (_, ts) = strip_comb t; val (_, us) = strip_comb u; in List.take (ts, length ts - length us) end; val pname_of_intr = Thm.concl_of #> HOLogic.dest_Trueprop #> head_of #> dest_Const #> fst; (* partition introduction rules according to predicate name *) fun gen_partition_rules f induct intros = fold_rev (fn r => AList.map_entry op = (pname_of_intr (f r)) (cons r)) intros (map (rpair [] o fst) (arities_of induct)); val partition_rules = gen_partition_rules I; fun partition_rules' induct = gen_partition_rules fst induct; fun unpartition_rules intros xs = fold_map (fn r => AList.map_entry_yield op = (pname_of_intr r) (fn x :: xs => (x, xs)) #>> the) intros xs |> fst; (* infer order of variables in intro rules from order of quantifiers in elim rule *) fun infer_intro_vars thy elim arity intros = let val _ :: cases = Thm.prems_of elim; val used = map (fst o fst) (Term.add_vars (Thm.prop_of elim) []); fun mtch (t, u) = let val params = Logic.strip_params t; val vars = map (Var o apfst (rpair 0)) (Name.variant_list used (map fst params) ~~ map snd params); val ts = map (curry subst_bounds (rev vars)) (List.drop (Logic.strip_assums_hyp t, arity)); val us = Logic.strip_imp_prems u; val tab = fold (Pattern.first_order_match thy) (ts ~~ us) (Vartab.empty, Vartab.empty); in map (Envir.subst_term tab) vars end in map (mtch o apsnd Thm.prop_of) (cases ~~ intros) end; (** outer syntax **) fun gen_ind_decl mk_def coind = Parse.vars -- Parse.for_fixes -- Scan.optional Parse_Spec.where_multi_specs [] -- Scan.optional (\<^keyword>\monos\ |-- Parse.!!! Parse.thms1) [] >> (fn (((preds, params), specs), monos) => (snd o gen_add_inductive_cmd mk_def true coind preds params specs monos)); val ind_decl = gen_ind_decl add_ind_def; val _ = Outer_Syntax.local_theory \<^command_keyword>\inductive\ "define inductive predicates" (ind_decl false); val _ = Outer_Syntax.local_theory \<^command_keyword>\coinductive\ "define coinductive predicates" (ind_decl true); val _ = Outer_Syntax.local_theory \<^command_keyword>\inductive_cases\ "create simplified instances of elimination rules" (Parse.and_list1 Parse_Spec.simple_specs >> (snd oo inductive_cases_cmd)); val _ = Outer_Syntax.local_theory \<^command_keyword>\inductive_simps\ "create simplification rules for inductive predicates" (Parse.and_list1 Parse_Spec.simple_specs >> (snd oo inductive_simps_cmd)); val _ = Outer_Syntax.command \<^command_keyword>\print_inductives\ "print (co)inductive definitions and monotonicity rules" (Parse.opt_bang >> (fn b => Toplevel.keep (print_inductives b o Toplevel.context_of))); end; diff --git a/src/HOL/Tools/inductive_set.ML b/src/HOL/Tools/inductive_set.ML --- a/src/HOL/Tools/inductive_set.ML +++ b/src/HOL/Tools/inductive_set.ML @@ -1,560 +1,561 @@ (* Title: HOL/Tools/inductive_set.ML Author: Stefan Berghofer, TU Muenchen Wrapper for defining inductive sets using package for inductive predicates, including infrastructure for converting between predicates and sets. *) signature INDUCTIVE_SET = sig val to_set_att: thm list -> attribute val to_pred_att: thm list -> attribute val to_pred : thm list -> Context.generic -> thm -> thm val pred_set_conv_att: attribute val add_inductive: Inductive.flags -> ((binding * typ) * mixfix) list -> (string * typ) list -> (Attrib.binding * term) list -> thm list -> local_theory -> Inductive.result * local_theory val add_inductive_cmd: bool -> bool -> (binding * string option * mixfix) list -> (binding * string option * mixfix) list -> Specification.multi_specs_cmd -> (Facts.ref * Token.src list) list -> local_theory -> Inductive.result * local_theory val mono_add: attribute val mono_del: attribute end; structure Inductive_Set: INDUCTIVE_SET = struct (***********************************************************************************) (* simplifies (%x y. (x, y) : S & P x y) to (%x y. (x, y) : S Int {(x, y). P x y}) *) (* and (%x y. (x, y) : S | P x y) to (%x y. (x, y) : S Un {(x, y). P x y}) *) (* used for converting "strong" (co)induction rules *) (***********************************************************************************) val anyt = Free ("t", TFree ("'t", [])); fun strong_ind_simproc tab = Simplifier.make_simproc \<^context> "strong_ind" {lhss = [\<^term>\x::'a::{}\], proc = fn _ => fn ctxt => fn ct => let fun close p t f = let val vs = Term.add_vars t [] in Thm.instantiate' [] (rev (map (SOME o Thm.cterm_of ctxt o Var) vs)) (p (fold (Logic.all o Var) vs t) f) end; fun mkop \<^const_name>\HOL.conj\ T x = SOME (Const (\<^const_name>\Lattices.inf\, T --> T --> T), x) | mkop \<^const_name>\HOL.disj\ T x = SOME (Const (\<^const_name>\Lattices.sup\, T --> T --> T), x) | mkop _ _ _ = NONE; fun mk_collect p T t = let val U = HOLogic.dest_setT T in HOLogic.Collect_const U $ HOLogic.mk_ptupleabs (HOLogic.flat_tuple_paths p) U HOLogic.boolT t end; fun decomp (Const (s, _) $ ((m as Const (\<^const_name>\Set.member\, Type (_, [_, Type (_, [T, _])]))) $ p $ S) $ u) = mkop s T (m, p, S, mk_collect p T (head_of u)) | decomp (Const (s, _) $ u $ ((m as Const (\<^const_name>\Set.member\, Type (_, [_, Type (_, [T, _])]))) $ p $ S)) = mkop s T (m, p, mk_collect p T (head_of u), S) | decomp _ = NONE; val simp = full_simp_tac (put_simpset HOL_basic_ss ctxt addsimps @{thms mem_Collect_eq case_prod_conv}) 1; fun mk_rew t = (case strip_abs_vars t of [] => NONE | xs => (case decomp (strip_abs_body t) of NONE => NONE | SOME (bop, (m, p, S, S')) => SOME (close (Goal.prove ctxt [] []) (Logic.mk_equals (t, fold_rev Term.abs xs (m $ p $ (bop $ S $ S')))) (K (EVERY [resolve_tac ctxt [eq_reflection] 1, REPEAT (resolve_tac ctxt @{thms ext} 1), resolve_tac ctxt @{thms iffI} 1, EVERY [eresolve_tac ctxt @{thms conjE} 1, resolve_tac ctxt @{thms IntI} 1, simp, simp, eresolve_tac ctxt @{thms IntE} 1, resolve_tac ctxt @{thms conjI} 1, simp, simp] ORELSE EVERY [eresolve_tac ctxt @{thms disjE} 1, resolve_tac ctxt @{thms UnI1} 1, simp, resolve_tac ctxt @{thms UnI2} 1, simp, eresolve_tac ctxt @{thms UnE} 1, resolve_tac ctxt @{thms disjI1} 1, simp, resolve_tac ctxt @{thms disjI2} 1, simp]]))) handle ERROR _ => NONE)) in (case strip_comb (Thm.term_of ct) of (h as Const (name, _), ts) => if Symtab.defined tab name then let val rews = map mk_rew ts in if forall is_none rews then NONE else SOME (fold (fn th1 => fn th2 => Thm.combination th2 th1) (map2 (fn SOME r => K r | NONE => Thm.reflexive o Thm.cterm_of ctxt) rews ts) (Thm.reflexive (Thm.cterm_of ctxt h))) end else NONE | _ => NONE) end}; (* only eta contract terms occurring as arguments of functions satisfying p *) fun eta_contract p = let fun eta b (Abs (a, T, body)) = (case eta b body of body' as (f $ Bound 0) => if Term.is_dependent f orelse not b then Abs (a, T, body') else incr_boundvars ~1 f | body' => Abs (a, T, body')) | eta b (t $ u) = eta b t $ eta (p (head_of t)) u | eta b t = t in eta false end; fun eta_contract_thm ctxt p = Conv.fconv_rule (Conv.then_conv (Thm.beta_conversion true, fn ct => Thm.transitive (Thm.eta_conversion ct) (Thm.symmetric (Thm.eta_conversion (Thm.cterm_of ctxt (eta_contract p (Thm.term_of ct))))))); (***********************************************************) (* rules for converting between predicate and set notation *) (* *) (* rules for converting predicates to sets have the form *) (* P (%x y. (x, y) : s) = (%x y. (x, y) : S s) *) (* *) (* rules for converting sets to predicates have the form *) (* S {(x, y). p x y} = {(x, y). P p x y} *) (* *) (* where s and p are parameters *) (***********************************************************) structure Data = Generic_Data ( type T = {(* rules for converting predicates to sets *) to_set_simps: thm list, (* rules for converting sets to predicates *) to_pred_simps: thm list, (* arities of functions of type t set => ... => u set *) set_arities: (typ * (int list list option list * int list list option)) list Symtab.table, (* arities of functions of type (t => ... => bool) => u => ... => bool *) pred_arities: (typ * (int list list option list * int list list option)) list Symtab.table}; val empty = {to_set_simps = [], to_pred_simps = [], set_arities = Symtab.empty, pred_arities = Symtab.empty}; val extend = I; fun merge ({to_set_simps = to_set_simps1, to_pred_simps = to_pred_simps1, set_arities = set_arities1, pred_arities = pred_arities1}, {to_set_simps = to_set_simps2, to_pred_simps = to_pred_simps2, set_arities = set_arities2, pred_arities = pred_arities2}) : T = {to_set_simps = Thm.merge_thms (to_set_simps1, to_set_simps2), to_pred_simps = Thm.merge_thms (to_pred_simps1, to_pred_simps2), set_arities = Symtab.merge_list (op =) (set_arities1, set_arities2), pred_arities = Symtab.merge_list (op =) (pred_arities1, pred_arities2)}; ); fun name_type_of (Free p) = SOME p | name_type_of (Const p) = SOME p | name_type_of _ = NONE; fun map_type f (Free (s, T)) = Free (s, f T) | map_type f (Var (ixn, T)) = Var (ixn, f T) | map_type f _ = error "map_type"; fun find_most_specific is_inst f eq xs T = find_first (fn U => is_inst (T, f U) andalso forall (fn U' => eq (f U, f U') orelse not (is_inst (T, f U') andalso is_inst (f U', f U))) xs) xs; fun lookup_arity thy arities (s, T) = case Symtab.lookup arities s of NONE => NONE | SOME xs => find_most_specific (Sign.typ_instance thy) fst (op =) xs T; fun lookup_rule thy f rules = find_most_specific (swap #> Pattern.matches thy) (f #> fst) (op aconv) rules; fun infer_arities thy arities (optf, t) fs = case strip_comb t of (Abs (_, _, u), []) => infer_arities thy arities (NONE, u) fs | (Abs _, _) => infer_arities thy arities (NONE, Envir.beta_norm t) fs | (u, ts) => (case Option.map (lookup_arity thy arities) (name_type_of u) of SOME (SOME (_, (arity, _))) => (fold (infer_arities thy arities) (arity ~~ List.take (ts, length arity)) fs handle General.Subscript => error "infer_arities: bad term") | _ => fold (infer_arities thy arities) (map (pair NONE) ts) (case optf of NONE => fs | SOME f => AList.update op = (u, the_default f (Option.map (fn g => inter (op =) g f) (AList.lookup op = fs u))) fs)); (**************************************************************) (* derive the to_pred equation from the to_set equation *) (* *) (* 1. instantiate each set parameter with {(x, y). p x y} *) (* 2. apply %P. {(x, y). P x y} to both sides of the equation *) (* 3. simplify *) (**************************************************************) fun mk_to_pred_inst ctxt fs = map (fn (x, ps) => let val (Ts, T) = strip_type (fastype_of x); val U = HOLogic.dest_setT T; val x' = map_type (K (Ts @ HOLogic.strip_ptupleT ps U ---> HOLogic.boolT)) x; in (dest_Var x, Thm.cterm_of ctxt (fold_rev (Term.abs o pair "x") Ts (HOLogic.Collect_const U $ HOLogic.mk_ptupleabs ps U HOLogic.boolT (list_comb (x', map Bound (length Ts - 1 downto 0)))))) end) fs; fun mk_to_pred_eq ctxt p fs optfs' T thm = let val insts = mk_to_pred_inst ctxt fs; val thm' = Thm.instantiate ([], insts) thm; val thm'' = (case optfs' of NONE => thm' RS sym | SOME fs' => let val U = HOLogic.dest_setT (body_type T); val Ts = HOLogic.strip_ptupleT fs' U; val arg_cong' = Thm.incr_indexes (Thm.maxidx_of thm + 1) arg_cong; val (Var (arg_cong_f, _), _) = arg_cong' |> Thm.concl_of |> dest_comb |> snd |> strip_comb |> snd |> hd |> dest_comb; in thm' RS (infer_instantiate ctxt [(arg_cong_f, Thm.cterm_of ctxt (Abs ("P", Ts ---> HOLogic.boolT, HOLogic.Collect_const U $ HOLogic.mk_ptupleabs fs' U HOLogic.boolT (Bound 0))))] arg_cong' RS sym) end) in Simplifier.simplify (put_simpset HOL_basic_ss ctxt addsimps @{thms mem_Collect_eq case_prod_conv} addsimprocs [\<^simproc>\Collect_mem\]) thm'' |> zero_var_indexes |> eta_contract_thm ctxt (equal p) end; (**** declare rules for converting predicates to sets ****) exception Malformed of string; fun add context thm (tab as {to_set_simps, to_pred_simps, set_arities, pred_arities}) = (case Thm.prop_of thm of Const (\<^const_name>\Trueprop\, _) $ (Const (\<^const_name>\HOL.eq\, Type (_, [T, _])) $ lhs $ rhs) => (case body_type T of \<^typ>\bool\ => let val thy = Context.theory_of context; val ctxt = Context.proof_of context; fun factors_of t fs = case strip_abs_body t of Const (\<^const_name>\Set.member\, _) $ u $ S => if is_Free S orelse is_Var S then let val ps = HOLogic.flat_tuple_paths u in (SOME ps, (S, ps) :: fs) end else (NONE, fs) | _ => (NONE, fs); val (h, ts) = strip_comb lhs val (pfs, fs) = fold_map factors_of ts []; val ((h', ts'), fs') = (case rhs of Abs _ => (case strip_abs_body rhs of Const (\<^const_name>\Set.member\, _) $ u $ S => (strip_comb S, SOME (HOLogic.flat_tuple_paths u)) | _ => raise Malformed "member symbol on right-hand side expected") | _ => (strip_comb rhs, NONE)) in case (name_type_of h, name_type_of h') of (SOME (s, T), SOME (s', T')) => if exists (fn (U, _) => Sign.typ_instance thy (T', U) andalso Sign.typ_instance thy (U, T')) (Symtab.lookup_list set_arities s') then (if Context_Position.is_really_visible ctxt then warning ("Ignoring conversion rule for operator " ^ s') else (); tab) else {to_set_simps = Thm.trim_context thm :: to_set_simps, to_pred_simps = Thm.trim_context (mk_to_pred_eq ctxt h fs fs' T' thm) :: to_pred_simps, set_arities = Symtab.insert_list op = (s', (T', (map (AList.lookup op = fs) ts', fs'))) set_arities, pred_arities = Symtab.insert_list op = (s, (T, (pfs, fs'))) pred_arities} | _ => raise Malformed "set / predicate constant expected" end | _ => raise Malformed "equation between predicates expected") | _ => raise Malformed "equation expected") handle Malformed msg => let val ctxt = Context.proof_of context val _ = if Context_Position.is_really_visible ctxt then warning ("Ignoring malformed set / predicate conversion rule: " ^ msg ^ "\n" ^ Thm.string_of_thm ctxt thm) else (); in tab end; val pred_set_conv_att = Thm.declaration_attribute (fn thm => fn ctxt => Data.map (add ctxt thm) ctxt); (**** convert theorem in set notation to predicate notation ****) fun is_pred tab t = case Option.map (Symtab.lookup tab o fst) (name_type_of t) of SOME (SOME _) => true | _ => false; fun to_pred_simproc rules = let val rules' = map mk_meta_eq rules in Simplifier.make_simproc \<^context> "to_pred" {lhss = [anyt], proc = fn _ => fn ctxt => fn ct => lookup_rule (Proof_Context.theory_of ctxt) (Thm.prop_of #> Logic.dest_equals) rules' (Thm.term_of ct)} end; fun to_pred_proc thy rules t = case lookup_rule thy I rules t of NONE => NONE | SOME (lhs, rhs) => SOME (Envir.subst_term (Pattern.match thy (lhs, t) (Vartab.empty, Vartab.empty)) rhs); fun to_pred thms context thm = let val thy = Context.theory_of context; val ctxt = Context.proof_of context; val {to_pred_simps, set_arities, pred_arities, ...} = fold (add context) thms (Data.get context); val fs = filter (is_Var o fst) (infer_arities thy set_arities (NONE, Thm.prop_of thm) []); (* instantiate each set parameter with {(x, y). p x y} *) val insts = mk_to_pred_inst ctxt fs in thm |> Thm.instantiate ([], insts) |> Simplifier.full_simplify (put_simpset HOL_basic_ss ctxt addsimprocs [to_pred_simproc (@{thm mem_Collect_eq} :: @{thm case_prod_conv} :: map (Thm.transfer thy) to_pred_simps)]) |> eta_contract_thm ctxt (is_pred pred_arities) |> Rule_Cases.save thm end; val to_pred_att = Thm.rule_attribute [] o to_pred; (**** convert theorem in predicate notation to set notation ****) fun to_set thms context thm = let val thy = Context.theory_of context; val ctxt = Context.proof_of context; val {to_set_simps, pred_arities, ...} = fold (add context) thms (Data.get context); val fs = filter (is_Var o fst) (infer_arities thy pred_arities (NONE, Thm.prop_of thm) []); (* instantiate each predicate parameter with %x y. (x, y) : s *) val insts = map (fn (x, ps) => let val Ts = binder_types (fastype_of x); val l = length Ts; val k = length ps; val (Rs, Us) = chop (l - k - 1) Ts; val T = HOLogic.mk_ptupleT ps Us; val x' = map_type (K (Rs ---> HOLogic.mk_setT T)) x in (dest_Var x, Thm.cterm_of ctxt (fold_rev (Term.abs o pair "x") Ts (HOLogic.mk_mem (HOLogic.mk_ptuple ps T (map Bound (k downto 0)), list_comb (x', map Bound (l - 1 downto k + 1)))))) end) fs; in thm |> Thm.instantiate ([], insts) |> Simplifier.full_simplify (put_simpset HOL_basic_ss ctxt addsimps to_set_simps addsimprocs [strong_ind_simproc pred_arities, \<^simproc>\Collect_mem\]) |> Rule_Cases.save thm end; val to_set_att = Thm.rule_attribute [] o to_set; (**** definition of inductive sets ****) fun add_ind_set_def {quiet_mode, verbose, alt_name, coind, no_elim, no_ind, skip_mono} cs intros monos params cnames_syn lthy = let val thy = Proof_Context.theory_of lthy; val {set_arities, pred_arities, to_pred_simps, ...} = Data.get (Context.Proof lthy); fun infer (Abs (_, _, t)) = infer t | infer (Const (\<^const_name>\Set.member\, _) $ t $ u) = infer_arities thy set_arities (SOME (HOLogic.flat_tuple_paths t), u) | infer (t $ u) = infer t #> infer u | infer _ = I; val new_arities = filter_out (fn (x as Free (_, T), _) => member (op =) params x andalso length (binder_types T) > 0 | _ => false) (fold (snd #> infer) intros []); val params' = map (fn x => (case AList.lookup op = new_arities x of SOME fs => let val T = HOLogic.dest_setT (fastype_of x); val Ts = HOLogic.strip_ptupleT fs T; val x' = map_type (K (Ts ---> HOLogic.boolT)) x in (x, (x', (HOLogic.Collect_const T $ HOLogic.mk_ptupleabs fs T HOLogic.boolT x', fold_rev (Term.abs o pair "x") Ts (HOLogic.mk_mem (HOLogic.mk_ptuple fs T (map Bound (length fs downto 0)), x))))) end | NONE => (x, (x, (x, x))))) params; val (params1, (params2, params3)) = params' |> map snd |> split_list ||> split_list; val paramTs = map fastype_of params; (* equations for converting sets to predicates *) val ((cs', cs_info), eqns) = cs |> map (fn c as Free (s, T) => let val fs = the_default [] (AList.lookup op = new_arities c); val (Us, U) = strip_type T |> apsnd HOLogic.dest_setT; val _ = Us = paramTs orelse error (Pretty.string_of (Pretty.chunks [Pretty.str "Argument types", Pretty.block (Pretty.commas (map (Syntax.pretty_typ lthy) Us)), Pretty.str ("of " ^ s ^ " do not agree with types"), Pretty.block (Pretty.commas (map (Syntax.pretty_typ lthy) paramTs)), Pretty.str "of declared parameters"])); val Ts = HOLogic.strip_ptupleT fs U; val c' = Free (s ^ "p", map fastype_of params1 @ Ts ---> HOLogic.boolT) in ((c', (fs, U, Ts)), (list_comb (c, params2), HOLogic.Collect_const U $ HOLogic.mk_ptupleabs fs U HOLogic.boolT (list_comb (c', params1)))) end) |> split_list |>> split_list; val eqns' = eqns @ map (Thm.prop_of #> HOLogic.dest_Trueprop #> HOLogic.dest_eq) (@{thm mem_Collect_eq} :: @{thm case_prod_conv} :: to_pred_simps); (* predicate version of the introduction rules *) val intros' = map (fn (name_atts, t) => (name_atts, t |> map_aterms (fn u => (case AList.lookup op = params' u of SOME (_, (u', _)) => u' | NONE => u)) |> Pattern.rewrite_term thy [] [to_pred_proc thy eqns'] |> eta_contract (member op = cs' orf is_pred pred_arities))) intros; val cnames_syn' = map (fn (b, _) => (Binding.suffix_name "p" b, NoSyn)) cnames_syn; val monos' = map (to_pred [] (Context.Proof lthy)) monos; val ({preds, intrs, elims, raw_induct, eqs, ...}, lthy1) = Inductive.add_ind_def {quiet_mode = quiet_mode, verbose = verbose, alt_name = Binding.empty, coind = coind, no_elim = no_elim, no_ind = no_ind, skip_mono = skip_mono} cs' intros' monos' params1 cnames_syn' lthy; (* define inductive sets using previously defined predicates *) val (defs, lthy2) = lthy1 |> fold_map Local_Theory.define (map (fn (((b, mx), (fs, U, _)), p) => ((b, mx), ((Thm.def_binding b, []), fold_rev lambda params (HOLogic.Collect_const U $ HOLogic.mk_ptupleabs fs U HOLogic.boolT (list_comb (p, params3)))))) (cnames_syn ~~ cs_info ~~ preds)); (* prove theorems for converting predicate to set notation *) val lthy3 = fold (fn (((p, c as Free (s, _)), (fs, U, Ts)), (_, (_, def))) => fn lthy => let val conv_thm = Goal.prove lthy (map (fst o dest_Free) params) [] (HOLogic.mk_Trueprop (HOLogic.mk_eq (list_comb (p, params3), fold_rev (Term.abs o pair "x") Ts (HOLogic.mk_mem (HOLogic.mk_ptuple fs U (map Bound (length fs downto 0)), list_comb (c, params)))))) (K (REPEAT (resolve_tac lthy @{thms ext} 1) THEN simp_tac (put_simpset HOL_basic_ss lthy addsimps [def, @{thm mem_Collect_eq}, @{thm case_prod_conv}]) 1)) in lthy |> Local_Theory.note ((Binding.name (s ^ "p_" ^ s ^ "_eq"), [Attrib.internal (K pred_set_conv_att)]), [conv_thm]) |> snd end) (preds ~~ cs ~~ cs_info ~~ defs) lthy2; (* convert theorems to set notation *) val rec_name = if Binding.is_empty alt_name then Binding.conglomerate (map #1 cnames_syn) else alt_name; val cnames = map (Local_Theory.full_name lthy3 o #1) cnames_syn; (* FIXME *) + val spec_name = Local_Theory.full_name lthy3 (Binding.conglomerate (map #1 cnames_syn)); val (intr_names, intr_atts) = split_list (map fst intros); val raw_induct' = to_set [] (Context.Proof lthy3) raw_induct; val (intrs', elims', eqs', induct, inducts, lthy4) = - Inductive.declare_rules rec_name coind no_ind cnames (map fst defs) + Inductive.declare_rules rec_name coind no_ind spec_name cnames (map fst defs) (map (to_set [] (Context.Proof lthy3)) intrs) intr_names intr_atts (map (fn th => (to_set [] (Context.Proof lthy3) th, map (fst o fst) (fst (Rule_Cases.get th)), Rule_Cases.get_constraints th)) elims) (map (to_set [] (Context.Proof lthy3)) eqs) raw_induct' lthy3; in ({intrs = intrs', elims = elims', induct = induct, inducts = inducts, raw_induct = raw_induct', preds = map fst defs, eqs = eqs'}, lthy4) end; val add_inductive = Inductive.gen_add_inductive add_ind_set_def; val add_inductive_cmd = Inductive.gen_add_inductive_cmd add_ind_set_def; fun mono_att att = Thm.declaration_attribute (fn thm => fn context => Thm.attribute_declaration att (to_pred [] context thm) context); val mono_add = mono_att Inductive.mono_add; val mono_del = mono_att Inductive.mono_del; (** package setup **) (* attributes *) val _ = Theory.setup (Attrib.setup \<^binding>\pred_set_conv\ (Scan.succeed pred_set_conv_att) "declare rules for converting between predicate and set notation" #> Attrib.setup \<^binding>\to_set\ (Attrib.thms >> to_set_att) "convert rule to set notation" #> Attrib.setup \<^binding>\to_pred\ (Attrib.thms >> to_pred_att) "convert rule to predicate notation" #> Attrib.setup \<^binding>\mono_set\ (Attrib.add_del mono_add mono_del) "declare of monotonicity rule for set operators"); (* commands *) val ind_set_decl = Inductive.gen_ind_decl add_ind_set_def; val _ = Outer_Syntax.local_theory \<^command_keyword>\inductive_set\ "define inductive sets" (ind_set_decl false); val _ = Outer_Syntax.local_theory \<^command_keyword>\coinductive_set\ "define coinductive sets" (ind_set_decl true); end; diff --git a/src/HOL/Tools/record.ML b/src/HOL/Tools/record.ML --- a/src/HOL/Tools/record.ML +++ b/src/HOL/Tools/record.ML @@ -1,2426 +1,2425 @@ (* Title: HOL/Tools/record.ML Author: Wolfgang Naraschewski, TU Muenchen Author: Markus Wenzel, TU Muenchen Author: Norbert Schirmer, TU Muenchen Author: Thomas Sewell, NICTA Extensible records with structural subtyping. *) signature RECORD = sig val type_abbr: bool Config.T val type_as_fields: bool Config.T val timing: bool Config.T type info = {args: (string * sort) list, parent: (typ list * string) option, fields: (string * typ) list, extension: (string * typ list), ext_induct: thm, ext_inject: thm, ext_surjective: thm, ext_split: thm, ext_def: thm, select_convs: thm list, update_convs: thm list, select_defs: thm list, update_defs: thm list, fold_congs: thm list, unfold_congs: thm list, splits: thm list, defs: thm list, surjective: thm, equality: thm, induct_scheme: thm, induct: thm, cases_scheme: thm, cases: thm, simps: thm list, iffs: thm list} val get_info: theory -> string -> info option val the_info: theory -> string -> info val get_hierarchy: theory -> (string * typ list) -> (string * ((string * sort) * typ) list) list val add_record: {overloaded: bool} -> (string * sort) list * binding -> (typ list * string) option -> (binding * typ * mixfix) list -> theory -> theory val last_extT: typ -> (string * typ list) option val dest_recTs: typ -> (string * typ list) list val get_extT_fields: theory -> typ -> (string * typ) list * (string * typ) val get_recT_fields: theory -> typ -> (string * typ) list * (string * typ) val get_parent: theory -> string -> (typ list * string) option val get_extension: theory -> string -> (string * typ list) option val get_extinjects: theory -> thm list val get_simpset: theory -> simpset val simproc: simproc val eq_simproc: simproc val upd_simproc: simproc val split_simproc: (term -> int) -> simproc val ex_sel_eq_simproc: simproc val split_tac: Proof.context -> int -> tactic val split_simp_tac: Proof.context -> thm list -> (term -> int) -> int -> tactic val split_wrapper: string * (Proof.context -> wrapper) val pretty_recT: Proof.context -> typ -> Pretty.T val string_of_record: Proof.context -> string -> string val codegen: bool Config.T val updateN: string val ext_typeN: string val extN: string end; signature ISO_TUPLE_SUPPORT = sig val add_iso_tuple_type: {overloaded: bool} -> binding * (string * sort) list -> typ * typ -> theory -> (term * term) * theory val mk_cons_tuple: term * term -> term val dest_cons_tuple: term -> term * term val iso_tuple_intros_tac: Proof.context -> int -> tactic end; structure Iso_Tuple_Support: ISO_TUPLE_SUPPORT = struct val isoN = "_Tuple_Iso"; val iso_tuple_intro = @{thm isomorphic_tuple_intro}; val iso_tuple_intros = Tactic.build_net @{thms isomorphic_tuple.intros}; val tuple_iso_tuple = (\<^const_name>\Record.tuple_iso_tuple\, @{thm tuple_iso_tuple}); structure Iso_Tuple_Thms = Theory_Data ( type T = thm Symtab.table; val empty = Symtab.make [tuple_iso_tuple]; val extend = I; fun merge data = Symtab.merge Thm.eq_thm_prop data; (* FIXME handle Symtab.DUP ?? *) ); fun get_typedef_info tyco vs (({rep_type, Abs_name, ...}, {Rep_inject, Abs_inverse, ... }) : Typedef.info) thy = let val exists_thm = UNIV_I |> Thm.instantiate' [SOME (Thm.global_ctyp_of thy (Logic.varifyT_global rep_type))] []; val proj_constr = Abs_inverse OF [exists_thm]; val absT = Type (tyco, map TFree vs); in thy |> pair (tyco, ((Rep_inject, proj_constr), Const (Abs_name, rep_type --> absT), absT)) end fun do_typedef overloaded raw_tyco repT raw_vs thy = let val ctxt = Proof_Context.init_global thy |> Variable.declare_typ repT; val vs = map (Proof_Context.check_tfree ctxt) raw_vs; in thy |> Named_Target.theory_map_result (apsnd o Typedef.transform_info) (Typedef.add_typedef overloaded (raw_tyco, vs, NoSyn) (HOLogic.mk_UNIV repT) NONE (fn ctxt' => resolve_tac ctxt' [UNIV_witness] 1)) |-> (fn (tyco, info) => get_typedef_info tyco vs info) end; fun mk_cons_tuple (left, right) = let val (leftT, rightT) = (fastype_of left, fastype_of right); val prodT = HOLogic.mk_prodT (leftT, rightT); val isomT = Type (\<^type_name>\tuple_isomorphism\, [prodT, leftT, rightT]); in Const (\<^const_name>\Record.iso_tuple_cons\, isomT --> leftT --> rightT --> prodT) $ Const (fst tuple_iso_tuple, isomT) $ left $ right end; fun dest_cons_tuple (Const (\<^const_name>\Record.iso_tuple_cons\, _) $ Const _ $ t $ u) = (t, u) | dest_cons_tuple t = raise TERM ("dest_cons_tuple", [t]); fun add_iso_tuple_type overloaded (b, alphas) (leftT, rightT) thy = let val repT = HOLogic.mk_prodT (leftT, rightT); val ((_, ((rep_inject, abs_inverse), absC, absT)), typ_thy) = thy |> do_typedef overloaded b repT alphas ||> Sign.add_path (Binding.name_of b); (*FIXME proper prefixing instead*) val typ_ctxt = Proof_Context.init_global typ_thy; (*construct a type and body for the isomorphism constant by instantiating the theorem to which the definition will be applied*) val intro_inst = rep_inject RS infer_instantiate typ_ctxt [(("abst", 0), Thm.cterm_of typ_ctxt absC)] iso_tuple_intro; val (_, body) = Logic.dest_equals (List.last (Thm.prems_of intro_inst)); val isomT = fastype_of body; val isom_binding = Binding.suffix_name isoN b; val isom_name = Sign.full_name typ_thy isom_binding; val isom = Const (isom_name, isomT); val ([isom_def], cdef_thy) = typ_thy |> Sign.declare_const_global ((isom_binding, isomT), NoSyn) |> snd |> Global_Theory.add_defs false [((Binding.concealed (Thm.def_binding isom_binding), Logic.mk_equals (isom, body)), [])]; val iso_tuple = isom_def RS (abs_inverse RS (rep_inject RS iso_tuple_intro)); val cons = Const (\<^const_name>\Record.iso_tuple_cons\, isomT --> leftT --> rightT --> absT); val thm_thy = cdef_thy |> Iso_Tuple_Thms.map (Symtab.insert Thm.eq_thm_prop (isom_name, iso_tuple)) |> Sign.restore_naming thy in ((isom, cons $ isom), thm_thy) end; fun iso_tuple_intros_tac ctxt = resolve_from_net_tac ctxt iso_tuple_intros THEN' CSUBGOAL (fn (cgoal, i) => let val goal = Thm.term_of cgoal; val isthms = Iso_Tuple_Thms.get (Proof_Context.theory_of ctxt); fun err s t = raise TERM ("iso_tuple_intros_tac: " ^ s, [t]); val goal' = Envir.beta_eta_contract goal; val is = (case goal' of Const (\<^const_name>\Trueprop\, _) $ (Const (\<^const_name>\isomorphic_tuple\, _) $ Const is) => is | _ => err "unexpected goal format" goal'); val isthm = (case Symtab.lookup isthms (#1 is) of SOME isthm => isthm | NONE => err "no thm found for constant" (Const is)); in resolve_tac ctxt [isthm] i end); end; structure Record: RECORD = struct val surject_assistI = @{thm iso_tuple_surjective_proof_assistI}; val surject_assist_idE = @{thm iso_tuple_surjective_proof_assist_idE}; val updacc_accessor_eqE = @{thm update_accessor_accessor_eqE}; val updacc_updator_eqE = @{thm update_accessor_updator_eqE}; val updacc_eq_idI = @{thm iso_tuple_update_accessor_eq_assist_idI}; val updacc_eq_triv = @{thm iso_tuple_update_accessor_eq_assist_triv}; val updacc_foldE = @{thm update_accessor_congruence_foldE}; val updacc_unfoldE = @{thm update_accessor_congruence_unfoldE}; val updacc_noopE = @{thm update_accessor_noopE}; val updacc_noop_compE = @{thm update_accessor_noop_compE}; val updacc_cong_idI = @{thm update_accessor_cong_assist_idI}; val updacc_cong_triv = @{thm update_accessor_cong_assist_triv}; val updacc_cong_from_eq = @{thm iso_tuple_update_accessor_cong_from_eq}; val codegen = Attrib.setup_config_bool \<^binding>\record_codegen\ (K true); (** name components **) val rN = "r"; val wN = "w"; val moreN = "more"; val schemeN = "_scheme"; val ext_typeN = "_ext"; val inner_typeN = "_inner"; val extN ="_ext"; val updateN = "_update"; val makeN = "make"; val fields_selN = "fields"; val extendN = "extend"; val truncateN = "truncate"; (*** utilities ***) fun varifyT idx = map_type_tfree (fn (a, S) => TVar ((a, idx), S)); (* timing *) val timing = Attrib.setup_config_bool \<^binding>\record_timing\ (K false); fun timeit_msg ctxt s x = if Config.get ctxt timing then (warning s; timeit x) else x (); fun timing_msg ctxt s = if Config.get ctxt timing then warning s else (); (* syntax *) val Trueprop = HOLogic.mk_Trueprop; infix 0 :== ===; infixr 0 ==>; val op :== = Misc_Legacy.mk_defpair; val op === = Trueprop o HOLogic.mk_eq; val op ==> = Logic.mk_implies; (* constructor *) fun mk_ext (name, T) ts = let val Ts = map fastype_of ts in list_comb (Const (suffix extN name, Ts ---> T), ts) end; (* selector *) fun mk_selC sT (c, T) = (c, sT --> T); fun mk_sel s (c, T) = let val sT = fastype_of s in Const (mk_selC sT (c, T)) $ s end; (* updates *) fun mk_updC sfx sT (c, T) = (suffix sfx c, (T --> T) --> sT --> sT); fun mk_upd' sfx c v sT = let val vT = domain_type (fastype_of v); in Const (mk_updC sfx sT (c, vT)) $ v end; fun mk_upd sfx c v s = mk_upd' sfx c v (fastype_of s) $ s; (* types *) fun dest_recT (typ as Type (c_ext_type, Ts as (_ :: _))) = (case try (unsuffix ext_typeN) c_ext_type of NONE => raise TYPE ("Record.dest_recT", [typ], []) | SOME c => ((c, Ts), List.last Ts)) | dest_recT typ = raise TYPE ("Record.dest_recT", [typ], []); val is_recT = can dest_recT; fun dest_recTs T = let val ((c, Ts), U) = dest_recT T in (c, Ts) :: dest_recTs U end handle TYPE _ => []; fun last_extT T = let val ((c, Ts), U) = dest_recT T in (case last_extT U of NONE => SOME (c, Ts) | SOME l => SOME l) end handle TYPE _ => NONE; fun rec_id i T = let val rTs = dest_recTs T; val rTs' = if i < 0 then rTs else take i rTs; in implode (map #1 rTs') end; (*** extend theory by record definition ***) (** record info **) (* type info and parent_info *) type info = {args: (string * sort) list, parent: (typ list * string) option, fields: (string * typ) list, extension: (string * typ list), ext_induct: thm, ext_inject: thm, ext_surjective: thm, ext_split: thm, ext_def: thm, select_convs: thm list, update_convs: thm list, select_defs: thm list, update_defs: thm list, fold_congs: thm list, (* potentially used in L4.verified *) unfold_congs: thm list, (* potentially used in L4.verified *) splits: thm list, defs: thm list, surjective: thm, equality: thm, induct_scheme: thm, induct: thm, cases_scheme: thm, cases: thm, simps: thm list, iffs: thm list}; fun make_info args parent fields extension ext_induct ext_inject ext_surjective ext_split ext_def select_convs update_convs select_defs update_defs fold_congs unfold_congs splits defs surjective equality induct_scheme induct cases_scheme cases simps iffs : info = {args = args, parent = parent, fields = fields, extension = extension, ext_induct = ext_induct, ext_inject = ext_inject, ext_surjective = ext_surjective, ext_split = ext_split, ext_def = ext_def, select_convs = select_convs, update_convs = update_convs, select_defs = select_defs, update_defs = update_defs, fold_congs = fold_congs, unfold_congs = unfold_congs, splits = splits, defs = defs, surjective = surjective, equality = equality, induct_scheme = induct_scheme, induct = induct, cases_scheme = cases_scheme, cases = cases, simps = simps, iffs = iffs}; type parent_info = {name: string, fields: (string * typ) list, extension: (string * typ list), induct_scheme: thm, ext_def: thm}; fun make_parent_info name fields extension ext_def induct_scheme : parent_info = {name = name, fields = fields, extension = extension, ext_def = ext_def, induct_scheme = induct_scheme}; (* theory data *) type data = {records: info Symtab.table, sel_upd: {selectors: (int * bool) Symtab.table, updates: string Symtab.table, simpset: simpset, defset: simpset}, equalities: thm Symtab.table, extinjects: thm list, extsplit: thm Symtab.table, (*maps extension name to split rule*) splits: (thm * thm * thm * thm) Symtab.table, (*!!, ALL, EX - split-equalities, induct rule*) extfields: (string * typ) list Symtab.table, (*maps extension to its fields*) fieldext: (string * typ list) Symtab.table}; (*maps field to its extension*) fun make_data records sel_upd equalities extinjects extsplit splits extfields fieldext = {records = records, sel_upd = sel_upd, equalities = equalities, extinjects=extinjects, extsplit = extsplit, splits = splits, extfields = extfields, fieldext = fieldext }: data; structure Data = Theory_Data ( type T = data; val empty = make_data Symtab.empty {selectors = Symtab.empty, updates = Symtab.empty, simpset = HOL_basic_ss, defset = HOL_basic_ss} Symtab.empty [] Symtab.empty Symtab.empty Symtab.empty Symtab.empty; val extend = I; fun merge ({records = recs1, sel_upd = {selectors = sels1, updates = upds1, simpset = ss1, defset = ds1}, equalities = equalities1, extinjects = extinjects1, extsplit = extsplit1, splits = splits1, extfields = extfields1, fieldext = fieldext1}, {records = recs2, sel_upd = {selectors = sels2, updates = upds2, simpset = ss2, defset = ds2}, equalities = equalities2, extinjects = extinjects2, extsplit = extsplit2, splits = splits2, extfields = extfields2, fieldext = fieldext2}) = make_data (Symtab.merge (K true) (recs1, recs2)) {selectors = Symtab.merge (K true) (sels1, sels2), updates = Symtab.merge (K true) (upds1, upds2), simpset = Simplifier.merge_ss (ss1, ss2), defset = Simplifier.merge_ss (ds1, ds2)} (Symtab.merge Thm.eq_thm_prop (equalities1, equalities2)) (Thm.merge_thms (extinjects1, extinjects2)) (Symtab.merge Thm.eq_thm_prop (extsplit1, extsplit2)) (Symtab.merge (fn ((a, b, c, d), (w, x, y, z)) => Thm.eq_thm (a, w) andalso Thm.eq_thm (b, x) andalso Thm.eq_thm (c, y) andalso Thm.eq_thm (d, z)) (splits1, splits2)) (Symtab.merge (K true) (extfields1, extfields2)) (Symtab.merge (K true) (fieldext1, fieldext2)); ); (* access 'records' *) val get_info = Symtab.lookup o #records o Data.get; fun the_info thy name = (case get_info thy name of SOME info => info | NONE => error ("Unknown record type " ^ quote name)); fun put_record name info = Data.map (fn {records, sel_upd, equalities, extinjects, extsplit, splits, extfields, fieldext} => make_data (Symtab.update (name, info) records) sel_upd equalities extinjects extsplit splits extfields fieldext); (* access 'sel_upd' *) val get_sel_upd = #sel_upd o Data.get; val is_selector = Symtab.defined o #selectors o get_sel_upd; val get_updates = Symtab.lookup o #updates o get_sel_upd; val get_simpset = #simpset o get_sel_upd; val get_sel_upd_defs = #defset o get_sel_upd; fun get_update_details u thy = let val sel_upd = get_sel_upd thy in (case Symtab.lookup (#updates sel_upd) u of SOME s => let val SOME (dep, ismore) = Symtab.lookup (#selectors sel_upd) s in SOME (s, dep, ismore) end | NONE => NONE) end; fun put_sel_upd names more depth simps defs thy = let val ctxt0 = Proof_Context.init_global thy; val all = names @ [more]; val sels = map (rpair (depth, false)) names @ [(more, (depth, true))]; val upds = map (suffix updateN) all ~~ all; val {records, sel_upd = {selectors, updates, simpset, defset}, equalities, extinjects, extsplit, splits, extfields, fieldext} = Data.get thy; val data = make_data records {selectors = fold Symtab.update_new sels selectors, updates = fold Symtab.update_new upds updates, simpset = simpset_map ctxt0 (fn ctxt => ctxt addsimps simps) simpset, defset = simpset_map ctxt0 (fn ctxt => ctxt addsimps defs) defset} equalities extinjects extsplit splits extfields fieldext; in Data.put data thy end; (* access 'equalities' *) fun add_equalities name thm = Data.map (fn {records, sel_upd, equalities, extinjects, extsplit, splits, extfields, fieldext} => make_data records sel_upd (Symtab.update_new (name, thm) equalities) extinjects extsplit splits extfields fieldext); val get_equalities = Symtab.lookup o #equalities o Data.get; (* access 'extinjects' *) fun add_extinjects thm = Data.map (fn {records, sel_upd, equalities, extinjects, extsplit, splits, extfields, fieldext} => make_data records sel_upd equalities (insert Thm.eq_thm_prop thm extinjects) extsplit splits extfields fieldext); val get_extinjects = rev o #extinjects o Data.get; (* access 'extsplit' *) fun add_extsplit name thm = Data.map (fn {records, sel_upd, equalities, extinjects, extsplit, splits, extfields, fieldext} => make_data records sel_upd equalities extinjects (Symtab.update_new (name, thm) extsplit) splits extfields fieldext); (* access 'splits' *) fun add_splits name thmP = Data.map (fn {records, sel_upd, equalities, extinjects, extsplit, splits, extfields, fieldext} => make_data records sel_upd equalities extinjects extsplit (Symtab.update_new (name, thmP) splits) extfields fieldext); val get_splits = Symtab.lookup o #splits o Data.get; (* parent/extension of named record *) val get_parent = (Option.join o Option.map #parent) oo (Symtab.lookup o #records o Data.get); val get_extension = Option.map #extension oo (Symtab.lookup o #records o Data.get); (* access 'extfields' *) fun add_extfields name fields = Data.map (fn {records, sel_upd, equalities, extinjects, extsplit, splits, extfields, fieldext} => make_data records sel_upd equalities extinjects extsplit splits (Symtab.update_new (name, fields) extfields) fieldext); val get_extfields = Symtab.lookup o #extfields o Data.get; fun get_extT_fields thy T = let val ((name, Ts), moreT) = dest_recT T; val recname = let val (nm :: _ :: rst) = rev (Long_Name.explode name) (* FIXME !? *) in Long_Name.implode (rev (nm :: rst)) end; val varifyT = varifyT (maxidx_of_typs (moreT :: Ts) + 1); val {records, extfields, ...} = Data.get thy; val (fields, (more, _)) = split_last (Symtab.lookup_list extfields name); val args = map varifyT (snd (#extension (the (Symtab.lookup records recname)))); val subst = fold (Sign.typ_match thy) (#1 (split_last args) ~~ #1 (split_last Ts)) Vartab.empty; val fields' = map (apsnd (Envir.norm_type subst o varifyT)) fields; in (fields', (more, moreT)) end; fun get_recT_fields thy T = let val (root_fields, (root_more, root_moreT)) = get_extT_fields thy T; val (rest_fields, rest_more) = if is_recT root_moreT then get_recT_fields thy root_moreT else ([], (root_more, root_moreT)); in (root_fields @ rest_fields, rest_more) end; (* access 'fieldext' *) fun add_fieldext extname_types fields = Data.map (fn {records, sel_upd, equalities, extinjects, extsplit, splits, extfields, fieldext} => let val fieldext' = fold (fn field => Symtab.update_new (field, extname_types)) fields fieldext; in make_data records sel_upd equalities extinjects extsplit splits extfields fieldext' end); val get_fieldext = Symtab.lookup o #fieldext o Data.get; (* parent records *) local fun add_parents _ NONE = I | add_parents thy (SOME (types, name)) = let fun err msg = error (msg ^ " parent record " ^ quote name); val {args, parent, ...} = (case get_info thy name of SOME info => info | NONE => err "Unknown"); val _ = if length types <> length args then err "Bad number of arguments for" else (); fun bad_inst ((x, S), T) = if Sign.of_sort thy (T, S) then NONE else SOME x val bads = map_filter bad_inst (args ~~ types); val _ = null bads orelse err ("Ill-sorted instantiation of " ^ commas bads ^ " in"); val inst = args ~~ types; val subst = Term.map_type_tfree (the o AList.lookup (op =) inst); val parent' = Option.map (apfst (map subst)) parent; in cons (name, inst) #> add_parents thy parent' end; in fun get_hierarchy thy (name, types) = add_parents thy (SOME (types, name)) []; fun get_parent_info thy parent = add_parents thy parent [] |> map (fn (name, inst) => let val subst = Term.map_type_tfree (the o AList.lookup (op =) inst); val {fields, extension, induct_scheme, ext_def, ...} = the_info thy name; val fields' = map (apsnd subst) fields; val extension' = apsnd (map subst) extension; in make_parent_info name fields' extension' ext_def induct_scheme end); end; (** concrete syntax for records **) (* parse translations *) local fun split_args (field :: fields) ((name, arg) :: fargs) = if can (unsuffix name) field then let val (args, rest) = split_args fields fargs in (arg :: args, rest) end else raise Fail ("expecting field " ^ quote field ^ " but got " ^ quote name) | split_args [] (fargs as (_ :: _)) = ([], fargs) | split_args (_ :: _) [] = raise Fail "expecting more fields" | split_args _ _ = ([], []); fun field_type_tr ((Const (\<^syntax_const>\_field_type\, _) $ Const (name, _) $ arg)) = (name, arg) | field_type_tr t = raise TERM ("field_type_tr", [t]); fun field_types_tr (Const (\<^syntax_const>\_field_types\, _) $ t $ u) = field_type_tr t :: field_types_tr u | field_types_tr t = [field_type_tr t]; fun record_field_types_tr more ctxt t = let val thy = Proof_Context.theory_of ctxt; fun err msg = raise TERM ("Error in record-type input: " ^ msg, [t]); fun mk_ext (fargs as (name, _) :: _) = (case get_fieldext thy (Proof_Context.intern_const ctxt name) of SOME (ext, alphas) => (case get_extfields thy ext of SOME fields => let val (fields', _) = split_last fields; val types = map snd fields'; val (args, rest) = split_args (map fst fields') fargs handle Fail msg => err msg; val argtypes = Syntax.check_typs ctxt (map Syntax_Phases.decode_typ args); val varifyT = varifyT (fold Term.maxidx_typ argtypes ~1 + 1); val vartypes = map varifyT types; val subst = Type.raw_matches (vartypes, argtypes) Vartab.empty handle Type.TYPE_MATCH => err "type is no proper record (extension)"; val alphas' = map (Syntax_Phases.term_of_typ ctxt o Envir.norm_type subst o varifyT) (#1 (split_last alphas)); val more' = mk_ext rest; in list_comb (Syntax.const (Lexicon.mark_type (suffix ext_typeN ext)), alphas' @ [more']) end | NONE => err ("no fields defined for " ^ quote ext)) | NONE => err (quote name ^ " is no proper field")) | mk_ext [] = more; in mk_ext (field_types_tr t) end; fun record_type_tr ctxt [t] = record_field_types_tr (Syntax.const \<^type_syntax>\unit\) ctxt t | record_type_tr _ ts = raise TERM ("record_type_tr", ts); fun record_type_scheme_tr ctxt [t, more] = record_field_types_tr more ctxt t | record_type_scheme_tr _ ts = raise TERM ("record_type_scheme_tr", ts); fun field_tr ((Const (\<^syntax_const>\_field\, _) $ Const (name, _) $ arg)) = (name, arg) | field_tr t = raise TERM ("field_tr", [t]); fun fields_tr (Const (\<^syntax_const>\_fields\, _) $ t $ u) = field_tr t :: fields_tr u | fields_tr t = [field_tr t]; fun record_fields_tr more ctxt t = let val thy = Proof_Context.theory_of ctxt; fun err msg = raise TERM ("Error in record input: " ^ msg, [t]); fun mk_ext (fargs as (name, _) :: _) = (case get_fieldext thy (Proof_Context.intern_const ctxt name) of SOME (ext, _) => (case get_extfields thy ext of SOME fields => let val (args, rest) = split_args (map fst (fst (split_last fields))) fargs handle Fail msg => err msg; val more' = mk_ext rest; in list_comb (Syntax.const (Lexicon.mark_const (ext ^ extN)), args @ [more']) end | NONE => err ("no fields defined for " ^ quote ext)) | NONE => err (quote name ^ " is no proper field")) | mk_ext [] = more; in mk_ext (fields_tr t) end; fun record_tr ctxt [t] = record_fields_tr (Syntax.const \<^const_syntax>\Unity\) ctxt t | record_tr _ ts = raise TERM ("record_tr", ts); fun record_scheme_tr ctxt [t, more] = record_fields_tr more ctxt t | record_scheme_tr _ ts = raise TERM ("record_scheme_tr", ts); fun field_update_tr (Const (\<^syntax_const>\_field_update\, _) $ Const (name, _) $ arg) = Syntax.const (suffix updateN name) $ Abs (Name.uu_, dummyT, arg) | field_update_tr t = raise TERM ("field_update_tr", [t]); fun field_updates_tr (Const (\<^syntax_const>\_field_updates\, _) $ t $ u) = field_update_tr t :: field_updates_tr u | field_updates_tr t = [field_update_tr t]; fun record_update_tr [t, u] = fold (curry op $) (field_updates_tr u) t | record_update_tr ts = raise TERM ("record_update_tr", ts); in val _ = Theory.setup (Sign.parse_translation [(\<^syntax_const>\_record_update\, K record_update_tr), (\<^syntax_const>\_record\, record_tr), (\<^syntax_const>\_record_scheme\, record_scheme_tr), (\<^syntax_const>\_record_type\, record_type_tr), (\<^syntax_const>\_record_type_scheme\, record_type_scheme_tr)]); end; (* print translations *) val type_abbr = Attrib.setup_config_bool \<^binding>\record_type_abbr\ (K true); val type_as_fields = Attrib.setup_config_bool \<^binding>\record_type_as_fields\ (K true); local (* FIXME early extern (!??) *) (* FIXME Syntax.free (??) *) fun field_type_tr' (c, t) = Syntax.const \<^syntax_const>\_field_type\ $ Syntax.const c $ t; fun field_types_tr' (t, u) = Syntax.const \<^syntax_const>\_field_types\ $ t $ u; fun record_type_tr' ctxt t = let val thy = Proof_Context.theory_of ctxt; val T = Syntax_Phases.decode_typ t; val varifyT = varifyT (Term.maxidx_of_typ T + 1); fun strip_fields T = (case T of Type (ext, args as _ :: _) => (case try (unsuffix ext_typeN) ext of SOME ext' => (case get_extfields thy ext' of SOME (fields as (x, _) :: _) => (case get_fieldext thy x of SOME (_, alphas) => (let val (f :: fs, _) = split_last fields; val fields' = apfst (Proof_Context.extern_const ctxt) f :: map (apfst Long_Name.base_name) fs; val (args', more) = split_last args; val alphavars = map varifyT (#1 (split_last alphas)); val subst = Type.raw_matches (alphavars, args') Vartab.empty; val fields'' = (map o apsnd) (Envir.norm_type subst o varifyT) fields'; in fields'' @ strip_fields more end handle Type.TYPE_MATCH => [("", T)]) | _ => [("", T)]) | _ => [("", T)]) | _ => [("", T)]) | _ => [("", T)]); val (fields, (_, moreT)) = split_last (strip_fields T); val _ = null fields andalso raise Match; val u = foldr1 field_types_tr' (map (field_type_tr' o apsnd (Syntax_Phases.term_of_typ ctxt)) fields); in if not (Config.get ctxt type_as_fields) orelse null fields then raise Match else if moreT = HOLogic.unitT then Syntax.const \<^syntax_const>\_record_type\ $ u else Syntax.const \<^syntax_const>\_record_type_scheme\ $ u $ Syntax_Phases.term_of_typ ctxt moreT end; (*try to reconstruct the record name type abbreviation from the (nested) extension types*) fun record_type_abbr_tr' abbr alphas zeta last_ext schemeT ctxt tm = let val T = Syntax_Phases.decode_typ tm; val varifyT = varifyT (maxidx_of_typ T + 1); fun mk_type_abbr subst name args = let val abbrT = Type (name, map (varifyT o TFree) args) in Syntax_Phases.term_of_typ ctxt (Envir.norm_type subst abbrT) end; fun match rT T = Type.raw_match (varifyT rT, T) Vartab.empty; in if Config.get ctxt type_abbr then (case last_extT T of SOME (name, _) => if name = last_ext then let val subst = match schemeT T in if HOLogic.is_unitT (Envir.norm_type subst (varifyT (TFree zeta))) then mk_type_abbr subst abbr alphas else mk_type_abbr subst (suffix schemeN abbr) (alphas @ [zeta]) end handle Type.TYPE_MATCH => record_type_tr' ctxt tm else raise Match (*give print translation of specialised record a chance*) | _ => raise Match) else record_type_tr' ctxt tm end; in fun record_ext_type_tr' name = let val ext_type_name = Lexicon.mark_type (suffix ext_typeN name); fun tr' ctxt ts = record_type_tr' ctxt (list_comb (Syntax.const ext_type_name, ts)); in (ext_type_name, tr') end; fun record_ext_type_abbr_tr' abbr alphas zeta last_ext schemeT name = let val ext_type_name = Lexicon.mark_type (suffix ext_typeN name); fun tr' ctxt ts = record_type_abbr_tr' abbr alphas zeta last_ext schemeT ctxt (list_comb (Syntax.const ext_type_name, ts)); in (ext_type_name, tr') end; end; local (* FIXME Syntax.free (??) *) fun field_tr' (c, t) = Syntax.const \<^syntax_const>\_field\ $ Syntax.const c $ t; fun fields_tr' (t, u) = Syntax.const \<^syntax_const>\_fields\ $ t $ u; fun record_tr' ctxt t = let val thy = Proof_Context.theory_of ctxt; fun strip_fields t = (case strip_comb t of (Const (ext, _), args as (_ :: _)) => (case try (Lexicon.unmark_const o unsuffix extN) ext of SOME ext' => (case get_extfields thy ext' of SOME fields => (let val (f :: fs, _) = split_last (map fst fields); val fields' = Proof_Context.extern_const ctxt f :: map Long_Name.base_name fs; val (args', more) = split_last args; in (fields' ~~ args') @ strip_fields more end handle ListPair.UnequalLengths => [("", t)]) | NONE => [("", t)]) | NONE => [("", t)]) | _ => [("", t)]); val (fields, (_, more)) = split_last (strip_fields t); val _ = null fields andalso raise Match; val u = foldr1 fields_tr' (map field_tr' fields); in (case more of Const (\<^const_syntax>\Unity\, _) => Syntax.const \<^syntax_const>\_record\ $ u | _ => Syntax.const \<^syntax_const>\_record_scheme\ $ u $ more) end; in fun record_ext_tr' name = let val ext_name = Lexicon.mark_const (name ^ extN); fun tr' ctxt ts = record_tr' ctxt (list_comb (Syntax.const ext_name, ts)); in (ext_name, tr') end; end; local fun dest_update ctxt c = (case try Lexicon.unmark_const c of SOME d => try (unsuffix updateN) (Proof_Context.extern_const ctxt d) | NONE => NONE); fun field_updates_tr' ctxt (tm as Const (c, _) $ k $ u) = (case dest_update ctxt c of SOME name => (case try Syntax_Trans.const_abs_tr' k of SOME t => apfst (cons (Syntax.const \<^syntax_const>\_field_update\ $ Syntax.free name $ t)) (field_updates_tr' ctxt u) | NONE => ([], tm)) | NONE => ([], tm)) | field_updates_tr' _ tm = ([], tm); fun record_update_tr' ctxt tm = (case field_updates_tr' ctxt tm of ([], _) => raise Match | (ts, u) => Syntax.const \<^syntax_const>\_record_update\ $ u $ foldr1 (fn (v, w) => Syntax.const \<^syntax_const>\_field_updates\ $ v $ w) (rev ts)); in fun field_update_tr' name = let val update_name = Lexicon.mark_const (name ^ updateN); fun tr' ctxt [t, u] = record_update_tr' ctxt (Syntax.const update_name $ t $ u) | tr' _ _ = raise Match; in (update_name, tr') end; end; (** record simprocs **) fun is_sel_upd_pair thy (Const (s, _)) (Const (u, t')) = (case get_updates thy u of SOME u_name => u_name = s | NONE => raise TERM ("is_sel_upd_pair: not update", [Const (u, t')])); fun mk_comp_id f = let val T = range_type (fastype_of f) in HOLogic.mk_comp (Const (\<^const_name>\Fun.id\, T --> T), f) end; fun get_upd_funs (upd $ _ $ t) = upd :: get_upd_funs t | get_upd_funs _ = []; fun get_accupd_simps ctxt term defset = let val thy = Proof_Context.theory_of ctxt; val (acc, [body]) = strip_comb term; val upd_funs = sort_distinct Term_Ord.fast_term_ord (get_upd_funs body); fun get_simp upd = let (* FIXME fresh "f" (!?) *) val T = domain_type (fastype_of upd); val lhs = HOLogic.mk_comp (acc, upd $ Free ("f", T)); val rhs = if is_sel_upd_pair thy acc upd then HOLogic.mk_comp (Free ("f", T), acc) else mk_comp_id acc; val prop = lhs === rhs; val othm = Goal.prove ctxt [] [] prop (fn {context = ctxt', ...} => simp_tac (put_simpset defset ctxt') 1 THEN REPEAT_DETERM (Iso_Tuple_Support.iso_tuple_intros_tac ctxt' 1) THEN TRY (simp_tac (put_simpset HOL_ss ctxt' addsimps @{thms id_apply id_o o_id}) 1)); val dest = if is_sel_upd_pair thy acc upd then @{thm o_eq_dest} else @{thm o_eq_id_dest}; in Drule.export_without_context (othm RS dest) end; in map get_simp upd_funs end; fun get_updupd_simp ctxt defset u u' comp = let (* FIXME fresh "f" (!?) *) val f = Free ("f", domain_type (fastype_of u)); val f' = Free ("f'", domain_type (fastype_of u')); val lhs = HOLogic.mk_comp (u $ f, u' $ f'); val rhs = if comp then u $ HOLogic.mk_comp (f, f') else HOLogic.mk_comp (u' $ f', u $ f); val prop = lhs === rhs; val othm = Goal.prove ctxt [] [] prop (fn {context = ctxt', ...} => simp_tac (put_simpset defset ctxt') 1 THEN REPEAT_DETERM (Iso_Tuple_Support.iso_tuple_intros_tac ctxt' 1) THEN TRY (simp_tac (put_simpset HOL_ss ctxt' addsimps @{thms id_apply}) 1)); val dest = if comp then @{thm o_eq_dest_lhs} else @{thm o_eq_dest}; in Drule.export_without_context (othm RS dest) end; fun get_updupd_simps ctxt term defset = let val upd_funs = get_upd_funs term; val cname = fst o dest_Const; fun getswap u u' = get_updupd_simp ctxt defset u u' (cname u = cname u'); fun build_swaps_to_eq _ [] swaps = swaps | build_swaps_to_eq upd (u :: us) swaps = let val key = (cname u, cname upd); val newswaps = if Symreltab.defined swaps key then swaps else Symreltab.insert (K true) (key, getswap u upd) swaps; in if cname u = cname upd then newswaps else build_swaps_to_eq upd us newswaps end; fun swaps_needed [] _ _ swaps = map snd (Symreltab.dest swaps) | swaps_needed (u :: us) prev seen swaps = if Symtab.defined seen (cname u) then swaps_needed us prev seen (build_swaps_to_eq u prev swaps) else swaps_needed us (u :: prev) (Symtab.insert (K true) (cname u, ()) seen) swaps; in swaps_needed upd_funs [] Symtab.empty Symreltab.empty end; fun prove_unfold_defs thy ex_simps ex_simprs prop = let val ctxt = Proof_Context.init_global thy; val defset = get_sel_upd_defs thy; val prop' = Envir.beta_eta_contract prop; val (lhs, _) = Logic.dest_equals (Logic.strip_assums_concl prop'); val (_, args) = strip_comb lhs; val simps = (if length args = 1 then get_accupd_simps else get_updupd_simps) ctxt lhs defset; in Goal.prove ctxt [] [] prop' (fn {context = ctxt', ...} => simp_tac (put_simpset HOL_basic_ss ctxt' addsimps (simps @ @{thms K_record_comp})) 1 THEN TRY (simp_tac (put_simpset HOL_basic_ss ctxt' addsimps ex_simps addsimprocs ex_simprs) 1)) end; local fun eq (s1: string) (s2: string) = (s1 = s2); fun has_field extfields f T = exists (fn (eN, _) => exists (eq f o fst) (Symtab.lookup_list extfields eN)) (dest_recTs T); fun K_skeleton n (T as Type (_, [_, kT])) (b as Bound i) (Abs (x, xT, t)) = if null (loose_bnos t) then ((n, kT), (Abs (x, xT, Bound (i + 1)))) else ((n, T), b) | K_skeleton n T b _ = ((n, T), b); in (* simproc *) (* Simplify selections of an record update: (1) S (S_update k r) = k (S r) (2) S (X_update k r) = S r The simproc skips multiple updates at once, eg: S (X_update x (Y_update y (S_update k r))) = k (S r) But be careful in (2) because of the extensibility of records. - If S is a more-selector we have to make sure that the update on component X does not affect the selected subrecord. - If X is a more-selector we have to make sure that S is not in the updated subrecord. *) val simproc = Simplifier.make_simproc \<^context> "record" {lhss = [\<^term>\x::'a::{}\], proc = fn _ => fn ctxt => fn ct => let val thy = Proof_Context.theory_of ctxt; val t = Thm.term_of ct; in (case t of (sel as Const (s, Type (_, [_, rangeS]))) $ ((upd as Const (u, Type (_, [_, Type (_, [rT, _])]))) $ k $ r) => if is_selector thy s andalso is_some (get_updates thy u) then let val {sel_upd = {updates, ...}, extfields, ...} = Data.get thy; fun mk_eq_terms ((upd as Const (u, Type(_, [kT, _]))) $ k $ r) = (case Symtab.lookup updates u of NONE => NONE | SOME u_name => if u_name = s then (case mk_eq_terms r of NONE => let val rv = ("r", rT); val rb = Bound 0; val (kv, kb) = K_skeleton "k" kT (Bound 1) k; in SOME (upd $ kb $ rb, kb $ (sel $ rb), [kv, rv]) end | SOME (trm, trm', vars) => let val (kv, kb) = K_skeleton "k" kT (Bound (length vars)) k; in SOME (upd $ kb $ trm, kb $ trm', kv :: vars) end) else if has_field extfields u_name rangeS orelse has_field extfields s (domain_type kT) then NONE else (case mk_eq_terms r of SOME (trm, trm', vars) => let val (kv, kb) = K_skeleton "k" kT (Bound (length vars)) k in SOME (upd $ kb $ trm, trm', kv :: vars) end | NONE => let val rv = ("r", rT); val rb = Bound 0; val (kv, kb) = K_skeleton "k" kT (Bound 1) k; in SOME (upd $ kb $ rb, sel $ rb, [kv, rv]) end)) | mk_eq_terms _ = NONE; in (case mk_eq_terms (upd $ k $ r) of SOME (trm, trm', vars) => SOME (prove_unfold_defs thy [] [] (Logic.list_all (vars, Logic.mk_equals (sel $ trm, trm')))) | NONE => NONE) end else NONE | _ => NONE) end}; fun get_upd_acc_cong_thm upd acc thy ss = let val ctxt = Proof_Context.init_global thy; val prop = infer_instantiate ctxt [(("upd", 0), Thm.cterm_of ctxt upd), (("ac", 0), Thm.cterm_of ctxt acc)] updacc_cong_triv |> Thm.concl_of; in Goal.prove ctxt [] [] prop (fn {context = ctxt', ...} => simp_tac (put_simpset ss ctxt') 1 THEN REPEAT_DETERM (Iso_Tuple_Support.iso_tuple_intros_tac ctxt' 1) THEN TRY (resolve_tac ctxt' [updacc_cong_idI] 1)) end; (* upd_simproc *) (*Simplify multiple updates: (1) "N_update y (M_update g (N_update x (M_update f r))) = (N_update (y o x) (M_update (g o f) r))" (2) "r(|M:= M r|) = r" In both cases "more" updates complicate matters: for this reason we omit considering further updates if doing so would introduce both a more update and an update to a field within it.*) val upd_simproc = Simplifier.make_simproc \<^context> "record_upd" {lhss = [\<^term>\x::'a::{}\], proc = fn _ => fn ctxt => fn ct => let val thy = Proof_Context.theory_of ctxt; val t = Thm.term_of ct; (*We can use more-updators with other updators as long as none of the other updators go deeper than any more updator. min here is the depth of the deepest other updator, max the depth of the shallowest more updator.*) fun include_depth (dep, true) (min, max) = if min <= dep then SOME (min, if dep <= max orelse max = ~1 then dep else max) else NONE | include_depth (dep, false) (min, max) = if dep <= max orelse max = ~1 then SOME (if min <= dep then dep else min, max) else NONE; fun getupdseq (term as (upd as Const (u, _)) $ f $ tm) min max = (case get_update_details u thy of SOME (s, dep, ismore) => (case include_depth (dep, ismore) (min, max) of SOME (min', max') => let val (us, bs, _) = getupdseq tm min' max' in ((upd, s, f) :: us, bs, fastype_of term) end | NONE => ([], term, HOLogic.unitT)) | NONE => ([], term, HOLogic.unitT)) | getupdseq term _ _ = ([], term, HOLogic.unitT); val (upds, base, baseT) = getupdseq t 0 ~1; fun is_upd_noop s (Abs (n, T, Const (s', T') $ tm')) tm = if s = s' andalso null (loose_bnos tm') andalso subst_bound (HOLogic.unit, tm') = tm then (true, Abs (n, T, Const (s', T') $ Bound 1)) else (false, HOLogic.unit) | is_upd_noop _ _ _ = (false, HOLogic.unit); fun get_noop_simps (upd as Const _) (Abs (_, _, (acc as Const _) $ _)) = let val ss = get_sel_upd_defs thy; val uathm = get_upd_acc_cong_thm upd acc thy ss; in [Drule.export_without_context (uathm RS updacc_noopE), Drule.export_without_context (uathm RS updacc_noop_compE)] end; (*If f is constant then (f o g) = f. We know that K_skeleton only returns constant abstractions thus when we see an abstraction we can discard inner updates.*) fun add_upd (f as Abs _) _ = [f] | add_upd f fs = (f :: fs); (*mk_updterm returns (orig-term-skeleton, simplified-skeleton, variables, duplicate-updates, simp-flag, noop-simps) where duplicate-updates is a table used to pass upward the list of update functions which can be composed into an update above them, simp-flag indicates whether any simplification was achieved, and noop-simps are used for eliminating case (2) defined above*) fun mk_updterm ((upd as Const (u, T), s, f) :: upds) above term = let val (lhs, rhs, vars, dups, simp, noops) = mk_updterm upds (Symtab.update (u, ()) above) term; val (fvar, skelf) = K_skeleton (Long_Name.base_name s) (domain_type T) (Bound (length vars)) f; val (isnoop, skelf') = is_upd_noop s f term; val funT = domain_type T; fun mk_comp_local (f, f') = Const (\<^const_name>\Fun.comp\, funT --> funT --> funT) $ f $ f'; in if isnoop then (upd $ skelf' $ lhs, rhs, vars, Symtab.update (u, []) dups, true, if Symtab.defined noops u then noops else Symtab.update (u, get_noop_simps upd skelf') noops) else if Symtab.defined above u then (upd $ skelf $ lhs, rhs, fvar :: vars, Symtab.map_default (u, []) (add_upd skelf) dups, true, noops) else (case Symtab.lookup dups u of SOME fs => (upd $ skelf $ lhs, upd $ foldr1 mk_comp_local (add_upd skelf fs) $ rhs, fvar :: vars, dups, true, noops) | NONE => (upd $ skelf $ lhs, upd $ skelf $ rhs, fvar :: vars, dups, simp, noops)) end | mk_updterm [] _ _ = (Bound 0, Bound 0, [("r", baseT)], Symtab.empty, false, Symtab.empty) | mk_updterm us _ _ = raise TERM ("mk_updterm match", map (fn (x, _, _) => x) us); val (lhs, rhs, vars, _, simp, noops) = mk_updterm upds Symtab.empty base; val noops' = maps snd (Symtab.dest noops); in if simp then SOME (prove_unfold_defs thy noops' [simproc] (Logic.list_all (vars, Logic.mk_equals (lhs, rhs)))) else NONE end}; end; (* eq_simproc *) (*Look up the most specific record-equality. Note on efficiency: Testing equality of records boils down to the test of equality of all components. Therefore the complexity is: #components * complexity for single component. Especially if a record has a lot of components it may be better to split up the record first and do simplification on that (split_simp_tac). e.g. r(|lots of updates|) = x eq_simproc split_simp_tac Complexity: #components * #updates #updates *) val eq_simproc = Simplifier.make_simproc \<^context> "record_eq" {lhss = [\<^term>\r = s\], proc = fn _ => fn ctxt => fn ct => (case Thm.term_of ct of Const (\<^const_name>\HOL.eq\, Type (_, [T, _])) $ _ $ _ => (case rec_id ~1 T of "" => NONE | name => (case get_equalities (Proof_Context.theory_of ctxt) name of NONE => NONE | SOME thm => SOME (thm RS @{thm Eq_TrueI}))) | _ => NONE)}; (* split_simproc *) (*Split quantified occurrences of records, for which P holds. P can peek on the subterm starting at the quantified occurrence of the record (including the quantifier): P t = 0: do not split P t = ~1: completely split P t > 0: split up to given bound of record extensions.*) fun split_simproc P = Simplifier.make_simproc \<^context> "record_split" {lhss = [\<^term>\x::'a::{}\], proc = fn _ => fn ctxt => fn ct => (case Thm.term_of ct of Const (quantifier, Type (_, [Type (_, [T, _]), _])) $ _ => if quantifier = \<^const_name>\Pure.all\ orelse quantifier = \<^const_name>\All\ orelse quantifier = \<^const_name>\Ex\ then (case rec_id ~1 T of "" => NONE | _ => let val split = P (Thm.term_of ct) in if split <> 0 then (case get_splits (Proof_Context.theory_of ctxt) (rec_id split T) of NONE => NONE | SOME (all_thm, All_thm, Ex_thm, _) => SOME (case quantifier of \<^const_name>\Pure.all\ => all_thm | \<^const_name>\All\ => All_thm RS @{thm eq_reflection} | \<^const_name>\Ex\ => Ex_thm RS @{thm eq_reflection} | _ => raise Fail "split_simproc")) else NONE end) else NONE | _ => NONE)}; val ex_sel_eq_simproc = Simplifier.make_simproc \<^context> "ex_sel_eq" {lhss = [\<^term>\Ex t\], proc = fn _ => fn ctxt => fn ct => let val thy = Proof_Context.theory_of ctxt; val t = Thm.term_of ct; fun mkeq (lr, Teq, (sel, Tsel), x) i = if is_selector thy sel then let val x' = if not (Term.is_dependent x) then Free ("x" ^ string_of_int i, range_type Tsel) else raise TERM ("", [x]); val sel' = Const (sel, Tsel) $ Bound 0; val (l, r) = if lr then (sel', x') else (x', sel'); in Const (\<^const_name>\HOL.eq\, Teq) $ l $ r end else raise TERM ("", [Const (sel, Tsel)]); fun dest_sel_eq (Const (\<^const_name>\HOL.eq\, Teq) $ (Const (sel, Tsel) $ Bound 0) $ X) = (true, Teq, (sel, Tsel), X) | dest_sel_eq (Const (\<^const_name>\HOL.eq\, Teq) $ X $ (Const (sel, Tsel) $ Bound 0)) = (false, Teq, (sel, Tsel), X) | dest_sel_eq _ = raise TERM ("", []); in (case t of Const (\<^const_name>\Ex\, Tex) $ Abs (s, T, t) => (let val eq = mkeq (dest_sel_eq t) 0; val prop = Logic.list_all ([("r", T)], Logic.mk_equals (Const (\<^const_name>\Ex\, Tex) $ Abs (s, T, eq), \<^term>\True\)); in SOME (Goal.prove_sorry_global thy [] [] prop (fn _ => simp_tac (put_simpset (get_simpset thy) ctxt addsimps @{thms simp_thms} addsimprocs [split_simproc (K ~1)]) 1)) end handle TERM _ => NONE) | _ => NONE) end}; (* split_simp_tac *) (*Split (and simplify) all records in the goal for which P holds. For quantified occurrences of a record P can peek on the whole subterm (including the quantifier); for free variables P can only peek on the variable itself. P t = 0: do not split P t = ~1: completely split P t > 0: split up to given bound of record extensions.*) fun split_simp_tac ctxt thms P = CSUBGOAL (fn (cgoal, i) => let val thy = Proof_Context.theory_of ctxt; val goal = Thm.term_of cgoal; val frees = filter (is_recT o #2) (Term.add_frees goal []); val has_rec = exists_Const (fn (s, Type (_, [Type (_, [T, _]), _])) => (s = \<^const_name>\Pure.all\ orelse s = \<^const_name>\All\ orelse s = \<^const_name>\Ex\) andalso is_recT T | _ => false); fun mk_split_free_tac free induct_thm i = let val _ $ (_ $ Var (r, _)) = Thm.concl_of induct_thm; val thm = infer_instantiate ctxt [(r, Thm.cterm_of ctxt free)] induct_thm; in simp_tac (put_simpset HOL_basic_ss ctxt addsimps @{thms induct_atomize}) i THEN resolve_tac ctxt [thm] i THEN simp_tac (put_simpset HOL_basic_ss ctxt addsimps @{thms induct_rulify}) i end; val split_frees_tacs = frees |> map_filter (fn (x, T) => (case rec_id ~1 T of "" => NONE | _ => let val free = Free (x, T); val split = P free; in if split <> 0 then (case get_splits thy (rec_id split T) of NONE => NONE | SOME (_, _, _, induct_thm) => SOME (mk_split_free_tac free induct_thm i)) else NONE end)); val simprocs = if has_rec goal then [split_simproc P] else []; val thms' = @{thms o_apply K_record_comp} @ thms; in EVERY split_frees_tacs THEN full_simp_tac (put_simpset (get_simpset thy) ctxt addsimps thms' addsimprocs simprocs) i end); (* split_tac *) (*Split all records in the goal, which are quantified by !! or ALL.*) fun split_tac ctxt = CSUBGOAL (fn (cgoal, i) => let val goal = Thm.term_of cgoal; val has_rec = exists_Const (fn (s, Type (_, [Type (_, [T, _]), _])) => (s = \<^const_name>\Pure.all\ orelse s = \<^const_name>\All\) andalso is_recT T | _ => false); fun is_all (Const (\<^const_name>\Pure.all\, _) $ _) = ~1 | is_all (Const (\<^const_name>\All\, _) $ _) = ~1 | is_all _ = 0; in if has_rec goal then full_simp_tac (put_simpset HOL_basic_ss ctxt addsimprocs [split_simproc is_all]) i else no_tac end); val _ = Theory.setup (map_theory_simpset (fn ctxt => ctxt addsimprocs [simproc, upd_simproc, eq_simproc])); (* wrapper *) val split_name = "record_split_tac"; val split_wrapper = (split_name, fn ctxt => fn tac => split_tac ctxt ORELSE' tac); (** theory extender interface **) (* attributes *) fun case_names_fields x = Rule_Cases.case_names ["fields"] x; fun induct_type_global name = [case_names_fields, Induct.induct_type name]; fun cases_type_global name = [case_names_fields, Induct.cases_type name]; (* tactics *) (*Do case analysis / induction according to rule on last parameter of ith subgoal (or on s if there are no parameters). Instatiation of record variable (and predicate) in rule is calculated to avoid problems with higher order unification.*) fun try_param_tac ctxt s rule = CSUBGOAL (fn (cgoal, i) => let val g = Thm.term_of cgoal; val params = Logic.strip_params g; val concl = HOLogic.dest_Trueprop (Logic.strip_assums_concl g); val rule' = Thm.lift_rule cgoal rule; val (P, ys) = strip_comb (HOLogic.dest_Trueprop (Logic.strip_assums_concl (Thm.prop_of rule'))); (*ca indicates if rule is a case analysis or induction rule*) val (x, ca) = (case rev (drop (length params) ys) of [] => (head_of (fst (HOLogic.dest_eq (HOLogic.dest_Trueprop (hd (rev (Logic.strip_assums_hyp (hd (Thm.prems_of rule')))))))), true) | [x] => (head_of x, false)); val rule'' = infer_instantiate ctxt (map (apsnd (Thm.cterm_of ctxt)) (case rev params of [] => (case AList.lookup (op =) (Term.add_frees g []) s of NONE => error "try_param_tac: no such variable" | SOME T => [(#1 (dest_Var P), if ca then concl else lambda (Free (s, T)) concl), (#1 (dest_Var x), Free (s, T))]) | (_, T) :: _ => [(#1 (dest_Var P), fold_rev Term.abs params (if ca then concl else incr_boundvars 1 (Abs (s, T, concl)))), (#1 (dest_Var x), fold_rev Term.abs params (Bound 0))])) rule'; in compose_tac ctxt (false, rule'', Thm.nprems_of rule) i end); fun extension_definition overloaded name fields alphas zeta moreT more vars thy = let val ctxt = Proof_Context.init_global thy; val base_name = Long_Name.base_name name; val fieldTs = map snd fields; val fields_moreTs = fieldTs @ [moreT]; val alphas_zeta = alphas @ [zeta]; val ext_binding = Binding.name (suffix extN base_name); val ext_name = suffix extN name; val ext_tyco = suffix ext_typeN name; val extT = Type (ext_tyco, map TFree alphas_zeta); val ext_type = fields_moreTs ---> extT; (* the tree of new types that will back the record extension *) val mktreeV = Balanced_Tree.make Iso_Tuple_Support.mk_cons_tuple; fun mk_iso_tuple (left, right) (thy, i) = let val suff = if i = 0 then ext_typeN else inner_typeN ^ string_of_int i; val ((_, cons), thy') = thy |> Iso_Tuple_Support.add_iso_tuple_type overloaded (Binding.suffix_name suff (Binding.name base_name), alphas_zeta) (fastype_of left, fastype_of right); in (cons $ left $ right, (thy', i + 1)) end; (*trying to create a 1-element iso_tuple will fail, and is pointless anyway*) fun mk_even_iso_tuple [arg] = pair arg | mk_even_iso_tuple args = mk_iso_tuple (Iso_Tuple_Support.dest_cons_tuple (mktreeV args)); fun build_meta_tree_type i thy vars more = let val len = length vars in if len < 1 then raise TYPE ("meta_tree_type args too short", [], vars) else if len > 16 then let fun group16 [] = [] | group16 xs = take 16 xs :: group16 (drop 16 xs); val vars' = group16 vars; val (composites, (thy', i')) = fold_map mk_even_iso_tuple vars' (thy, i); in build_meta_tree_type i' thy' composites more end else let val (term, (thy', _)) = mk_iso_tuple (mktreeV vars, more) (thy, 0) in (term, thy') end end; val _ = timing_msg ctxt "record extension preparing definitions"; (* 1st stage part 1: introduce the tree of new types *) val (ext_body, typ_thy) = timeit_msg ctxt "record extension nested type def:" (fn () => build_meta_tree_type 1 thy vars more); (* prepare declarations and definitions *) (* 1st stage part 2: define the ext constant *) fun mk_ext args = list_comb (Const (ext_name, ext_type), args); val ext_spec = Logic.mk_equals (mk_ext (vars @ [more]), ext_body); val ([ext_def], defs_thy) = timeit_msg ctxt "record extension constructor def:" (fn () => typ_thy |> Sign.declare_const_global ((ext_binding, ext_type), NoSyn) |> snd |> Global_Theory.add_defs false [((Thm.def_binding ext_binding, ext_spec), [])]); val defs_ctxt = Proof_Context.init_global defs_thy; (* prepare propositions *) val _ = timing_msg ctxt "record extension preparing propositions"; val vars_more = vars @ [more]; val variants = map (fn Free (x, _) => x) vars_more; val ext = mk_ext vars_more; val s = Free (rN, extT); val P = Free (singleton (Name.variant_list variants) "P", extT --> HOLogic.boolT); val inject_prop = (* FIXME local x x' *) let val vars_more' = map (fn (Free (x, T)) => Free (x ^ "'", T)) vars_more in HOLogic.mk_conj (HOLogic.eq_const extT $ mk_ext vars_more $ mk_ext vars_more', \<^term>\True\) === foldr1 HOLogic.mk_conj (map HOLogic.mk_eq (vars_more ~~ vars_more') @ [\<^term>\True\]) end; val induct_prop = (fold_rev Logic.all vars_more (Trueprop (P $ ext)), Trueprop (P $ s)); val split_meta_prop = (* FIXME local P *) let val P = Free (singleton (Name.variant_list variants) "P", extT --> propT) in Logic.mk_equals (Logic.all s (P $ s), fold_rev Logic.all vars_more (P $ ext)) end; val inject = timeit_msg ctxt "record extension inject proof:" (fn () => simplify (put_simpset HOL_ss defs_ctxt) (Goal.prove_sorry_global defs_thy [] [] inject_prop (fn {context = ctxt, ...} => simp_tac (put_simpset HOL_basic_ss ctxt addsimps [ext_def]) 1 THEN REPEAT_DETERM (resolve_tac ctxt @{thms refl_conj_eq} 1 ORELSE Iso_Tuple_Support.iso_tuple_intros_tac ctxt 1 ORELSE resolve_tac ctxt [refl] 1)))); (*We need a surjection property r = (| f = f r, g = g r ... |) to prove other theorems. We haven't given names to the accessors f, g etc yet however, so we generate an ext structure with free variables as all arguments and allow the introduction tactic to operate on it as far as it can. We then use Drule.export_without_context to convert the free variables into unifiable variables and unify them with (roughly) the definition of the accessor.*) val surject = timeit_msg ctxt "record extension surjective proof:" (fn () => let val start = infer_instantiate defs_ctxt [(("y", 0), Thm.cterm_of defs_ctxt ext)] surject_assist_idE; val tactic1 = simp_tac (put_simpset HOL_basic_ss defs_ctxt addsimps [ext_def]) 1 THEN REPEAT_ALL_NEW (Iso_Tuple_Support.iso_tuple_intros_tac defs_ctxt) 1; val tactic2 = REPEAT (resolve_tac defs_ctxt [surject_assistI] 1 THEN resolve_tac defs_ctxt [refl] 1); val [halfway] = Seq.list_of (tactic1 start); val [surject] = Seq.list_of (tactic2 (Drule.export_without_context halfway)); in surject end); val split_meta = timeit_msg ctxt "record extension split_meta proof:" (fn () => Goal.prove_sorry_global defs_thy [] [] split_meta_prop (fn {context = ctxt, ...} => EVERY1 [resolve_tac ctxt @{thms equal_intr_rule}, Goal.norm_hhf_tac ctxt, eresolve_tac ctxt @{thms meta_allE}, assume_tac ctxt, resolve_tac ctxt [@{thm prop_subst} OF [surject]], REPEAT o eresolve_tac ctxt @{thms meta_allE}, assume_tac ctxt])); val induct = timeit_msg ctxt "record extension induct proof:" (fn () => let val (assm, concl) = induct_prop in Goal.prove_sorry_global defs_thy [] [assm] concl (fn {context = ctxt, prems, ...} => cut_tac (split_meta RS Drule.equal_elim_rule2) 1 THEN resolve_tac ctxt prems 2 THEN asm_simp_tac (put_simpset HOL_ss ctxt) 1) end); val ([(_, [induct']), (_, [inject']), (_, [surjective']), (_, [split_meta'])], thm_thy) = defs_thy |> Global_Theory.note_thmss "" [((Binding.name "ext_induct", []), [([induct], [])]), ((Binding.name "ext_inject", []), [([inject], [])]), ((Binding.name "ext_surjective", []), [([surject], [])]), ((Binding.name "ext_split", []), [([split_meta], [])])]; in (((ext_name, ext_type), (ext_tyco, alphas_zeta), extT, induct', inject', surjective', split_meta', ext_def), thm_thy) end; fun chunks [] [] = [] | chunks [] xs = [xs] | chunks (l :: ls) xs = take l xs :: chunks ls (drop l xs); fun chop_last [] = error "chop_last: list should not be empty" | chop_last [x] = ([], x) | chop_last (x :: xs) = let val (tl, l) = chop_last xs in (x :: tl, l) end; fun subst_last _ [] = error "subst_last: list should not be empty" | subst_last s [_] = [s] | subst_last s (x :: xs) = x :: subst_last s xs; (* mk_recordT *) (*build up the record type from the current extension tpye extT and a list of parent extensions, starting with the root of the record hierarchy*) fun mk_recordT extT = fold_rev (fn (parent, Ts) => fn T => Type (parent, subst_last T Ts)) extT; (* code generation *) fun mk_random_eq tyco vs extN Ts = let (* FIXME local i etc. *) val size = \<^term>\i::natural\; fun termifyT T = HOLogic.mk_prodT (T, \<^typ>\unit \ term\); val T = Type (tyco, map TFree vs); val Tm = termifyT T; val params = Name.invent_names Name.context "x" Ts; val lhs = HOLogic.mk_random T size; val tc = HOLogic.mk_return Tm \<^typ>\Random.seed\ (HOLogic.mk_valtermify_app extN params T); val rhs = HOLogic.mk_ST (map (fn (v, T') => ((HOLogic.mk_random T' size, \<^typ>\Random.seed\), SOME (v, termifyT T'))) params) tc \<^typ>\Random.seed\ (SOME Tm, \<^typ>\Random.seed\); in (lhs, rhs) end fun mk_full_exhaustive_eq tyco vs extN Ts = let (* FIXME local i etc. *) val size = \<^term>\i::natural\; fun termifyT T = HOLogic.mk_prodT (T, \<^typ>\unit \ term\); val T = Type (tyco, map TFree vs); val test_function = Free ("f", termifyT T --> \<^typ>\(bool \ term list) option\); val params = Name.invent_names Name.context "x" Ts; fun full_exhaustiveT T = (termifyT T --> \<^typ>\(bool \ Code_Evaluation.term list) option\) --> \<^typ>\natural\ --> \<^typ>\(bool \ Code_Evaluation.term list) option\; fun mk_full_exhaustive T = Const (\<^const_name>\Quickcheck_Exhaustive.full_exhaustive_class.full_exhaustive\, full_exhaustiveT T); val lhs = mk_full_exhaustive T $ test_function $ size; val tc = test_function $ (HOLogic.mk_valtermify_app extN params T); val rhs = fold_rev (fn (v, T) => fn cont => mk_full_exhaustive T $ (lambda (Free (v, termifyT T)) cont) $ size) params tc; in (lhs, rhs) end; fun instantiate_sort_record (sort, mk_eq) tyco vs extN Ts thy = let val eq = HOLogic.mk_Trueprop (HOLogic.mk_eq (mk_eq tyco vs extN Ts)); in thy |> Class.instantiation ([tyco], vs, sort) |> `(fn lthy => Syntax.check_term lthy eq) |-> (fn eq => Specification.definition NONE [] [] ((Binding.concealed Binding.empty, []), eq)) |> snd |> Class.prove_instantiation_exit (fn ctxt => Class.intro_classes_tac ctxt []) end; fun ensure_sort_record (sort, mk_eq) ext_tyco vs extN Ts thy = let val algebra = Sign.classes_of thy; val has_inst = Sorts.has_instance algebra ext_tyco sort; in if has_inst then thy else (case Quickcheck_Common.perhaps_constrain thy (map (rpair sort) Ts) vs of SOME constrain => instantiate_sort_record (sort, mk_eq) ext_tyco (map constrain vs) extN ((map o map_atyps) (fn TFree v => TFree (constrain v)) Ts) thy | NONE => thy) end; fun add_code ext_tyco vs extT ext simps inject thy = if Config.get_global thy codegen then let val eq = HOLogic.mk_Trueprop (HOLogic.mk_eq (Const (\<^const_name>\HOL.equal\, extT --> extT --> HOLogic.boolT), Const (\<^const_name>\HOL.eq\, extT --> extT --> HOLogic.boolT))); fun tac ctxt eq_def = Class.intro_classes_tac ctxt [] THEN rewrite_goals_tac ctxt [Simpdata.mk_eq eq_def] THEN ALLGOALS (resolve_tac ctxt @{thms refl}); fun mk_eq ctxt eq_def = rewrite_rule ctxt [Axclass.unoverload ctxt (Thm.symmetric (Simpdata.mk_eq eq_def))] inject; fun mk_eq_refl ctxt = @{thm equal_refl} |> Thm.instantiate ([((("'a", 0), \<^sort>\equal\), Thm.ctyp_of ctxt (Logic.varifyT_global extT))], []) |> Axclass.unoverload ctxt; val ensure_random_record = ensure_sort_record (\<^sort>\random\, mk_random_eq); val ensure_exhaustive_record = ensure_sort_record (\<^sort>\full_exhaustive\, mk_full_exhaustive_eq); fun add_code eq_def thy = let val ctxt = Proof_Context.init_global thy; in thy |> Code.declare_default_eqns_global [(mk_eq (Proof_Context.init_global thy) eq_def, true), (mk_eq_refl (Proof_Context.init_global thy), false)] end; in thy |> Code.declare_datatype_global [ext] |> Code.declare_default_eqns_global (map (rpair true) simps) |> Class.instantiation ([ext_tyco], vs, [HOLogic.class_equal]) |> `(fn lthy => Syntax.check_term lthy eq) |-> (fn eq => Specification.definition NONE [] [] (Binding.empty_atts, eq)) |-> (fn (_, (_, eq_def)) => Class.prove_instantiation_exit_result Morphism.thm tac eq_def) |-> add_code |> ensure_random_record ext_tyco vs (fst ext) (binder_types (snd ext)) |> ensure_exhaustive_record ext_tyco vs (fst ext) (binder_types (snd ext)) end else thy; fun add_ctr_sugar ctr exhaust inject sel_thms = Ctr_Sugar.default_register_ctr_sugar_global (K true) {kind = Ctr_Sugar.Record, T = body_type (fastype_of ctr), ctrs = [ctr], casex = Term.dummy, discs = [], selss = [], exhaust = exhaust, nchotomy = Drule.dummy_thm, injects = [inject], distincts = [], case_thms = [], case_cong = Drule.dummy_thm, case_cong_weak = Drule.dummy_thm, case_distribs = [], split = Drule.dummy_thm, split_asm = Drule.dummy_thm, disc_defs = [], disc_thmss = [], discIs = [], disc_eq_cases = [], sel_defs = [], sel_thmss = [sel_thms], distinct_discsss = [], exhaust_discs = [], exhaust_sels = [], collapses = [], expands = [], split_sels = [], split_sel_asms = [], case_eq_ifs = []}; fun lhs_of_equation (Const (\<^const_name>\Pure.eq\, _) $ t $ _) = t | lhs_of_equation (\<^const>\Trueprop\ $ (Const (\<^const_name>\HOL.eq\, _) $ t $ _)) = t; fun add_spec_rule rule = - let val head = head_of (lhs_of_equation (Thm.prop_of rule)) in - Spec_Rules.add_global Spec_Rules.equational ([head], [rule]) - end; + let val head = head_of (lhs_of_equation (Thm.prop_of rule)) + in Spec_Rules.add_global "" Spec_Rules.equational [head] [rule] end; (* definition *) fun definition overloaded (alphas, binding) parent (parents: parent_info list) raw_fields thy0 = let val ctxt0 = Proof_Context.init_global thy0; val prefix = Binding.name_of binding; val name = Sign.full_name thy0 binding; val full = Sign.full_name_path thy0 prefix; val bfields = map (fn (x, T, _) => (x, T)) raw_fields; val field_syntax = map #3 raw_fields; val parent_fields = maps #fields parents; val parent_chunks = map (length o #fields) parents; val parent_names = map fst parent_fields; val parent_types = map snd parent_fields; val parent_fields_len = length parent_fields; val parent_variants = Name.variant_list [moreN, rN, rN ^ "'", wN] (map Long_Name.base_name parent_names); val parent_vars = map2 (curry Free) parent_variants parent_types; val parent_len = length parents; val fields = map (apfst full) bfields; val names = map fst fields; val types = map snd fields; val alphas_fields = fold Term.add_tfreesT types []; val alphas_ext = inter (op =) alphas_fields alphas; val len = length fields; val variants = Name.variant_list (moreN :: rN :: (rN ^ "'") :: wN :: parent_variants) (map (Binding.name_of o fst) bfields); val vars = map2 (curry Free) variants types; val named_vars = names ~~ vars; val idxms = 0 upto len; val all_fields = parent_fields @ fields; val all_types = parent_types @ types; val all_variants = parent_variants @ variants; val all_vars = parent_vars @ vars; val all_named_vars = (parent_names ~~ parent_vars) @ named_vars; val zeta = (singleton (Name.variant_list (map #1 alphas)) "'z", \<^sort>\type\); val moreT = TFree zeta; val more = Free (moreN, moreT); val full_moreN = full (Binding.name moreN); val bfields_more = bfields @ [(Binding.name moreN, moreT)]; val fields_more = fields @ [(full_moreN, moreT)]; val named_vars_more = named_vars @ [(full_moreN, more)]; val all_vars_more = all_vars @ [more]; val all_named_vars_more = all_named_vars @ [(full_moreN, more)]; (* 1st stage: ext_thy *) val extension_name = full binding; val ((ext, (ext_tyco, vs), extT, ext_induct, ext_inject, ext_surjective, ext_split, ext_def), ext_thy) = thy0 |> Sign.qualified_path false binding |> extension_definition overloaded extension_name fields alphas_ext zeta moreT more vars; val ext_ctxt = Proof_Context.init_global ext_thy; val _ = timing_msg ext_ctxt "record preparing definitions"; val Type extension_scheme = extT; val extension_name = unsuffix ext_typeN (fst extension_scheme); val extension = let val (n, Ts) = extension_scheme in (n, subst_last HOLogic.unitT Ts) end; val extension_names = map (unsuffix ext_typeN o fst o #extension) parents @ [extension_name]; val extension_id = implode extension_names; fun rec_schemeT n = mk_recordT (map #extension (drop n parents)) extT; val rec_schemeT0 = rec_schemeT 0; fun recT n = let val (c, Ts) = extension in mk_recordT (map #extension (drop n parents)) (Type (c, subst_last HOLogic.unitT Ts)) end; val recT0 = recT 0; fun mk_rec args n = let val (args', more) = chop_last args; fun mk_ext' ((name, T), args) more = mk_ext (name, T) (args @ [more]); fun build Ts = fold_rev mk_ext' (drop n ((extension_names ~~ Ts) ~~ chunks parent_chunks args')) more; in if more = HOLogic.unit then build (map_range recT (parent_len + 1)) else build (map_range rec_schemeT (parent_len + 1)) end; val r_rec0 = mk_rec all_vars_more 0; val r_rec_unit0 = mk_rec (all_vars @ [HOLogic.unit]) 0; fun r n = Free (rN, rec_schemeT n); val r0 = r 0; fun r_unit n = Free (rN, recT n); val r_unit0 = r_unit 0; (* print translations *) val record_ext_type_abbr_tr's = let val trname = hd extension_names; val last_ext = unsuffix ext_typeN (fst extension); in [record_ext_type_abbr_tr' name alphas zeta last_ext rec_schemeT0 trname] end; val record_ext_type_tr's = let (*avoid conflict with record_type_abbr_tr's*) val trnames = if parent_len > 0 then [extension_name] else []; in map record_ext_type_tr' trnames end; val print_translation = map field_update_tr' (full_moreN :: names) @ [record_ext_tr' extension_name] @ record_ext_type_tr's @ record_ext_type_abbr_tr's; (* prepare declarations *) val sel_decls = map (mk_selC rec_schemeT0 o apfst Binding.name_of) bfields_more; val upd_decls = map (mk_updC updateN rec_schemeT0 o apfst Binding.name_of) bfields_more; val make_decl = (makeN, all_types ---> recT0); val fields_decl = (fields_selN, types ---> Type extension); val extend_decl = (extendN, recT0 --> moreT --> rec_schemeT0); val truncate_decl = (truncateN, rec_schemeT0 --> recT0); (* prepare definitions *) val ext_defs = ext_def :: map #ext_def parents; (*Theorems from the iso_tuple intros. By unfolding ext_defs from r_rec0 we create a tree of constructor calls (many of them Pair, but others as well). The introduction rules for update_accessor_eq_assist can unify two different ways on these constructors. If we take the complete result sequence of running a the introduction tactic, we get one theorem for each upd/acc pair, from which we can derive the bodies of our selector and updator and their convs.*) val (accessor_thms, updator_thms, upd_acc_cong_assists) = timeit_msg ext_ctxt "record getting tree access/updates:" (fn () => let val r_rec0_Vars = let (*pick variable indices of 1 to avoid possible variable collisions with existing variables in updacc_eq_triv*) fun to_Var (Free (c, T)) = Var ((c, 1), T); in mk_rec (map to_Var all_vars_more) 0 end; val init_thm = infer_instantiate ext_ctxt [(("v", 0), Thm.cterm_of ext_ctxt r_rec0), (("v'", 0), Thm.cterm_of ext_ctxt r_rec0_Vars)] updacc_eq_triv; val terminal = resolve_tac ext_ctxt [updacc_eq_idI] 1 THEN resolve_tac ext_ctxt [refl] 1; val tactic = simp_tac (put_simpset HOL_basic_ss ext_ctxt addsimps ext_defs) 1 THEN REPEAT (Iso_Tuple_Support.iso_tuple_intros_tac ext_ctxt 1 ORELSE terminal); val updaccs = Seq.list_of (tactic init_thm); in (updaccs RL [updacc_accessor_eqE], updaccs RL [updacc_updator_eqE], updaccs RL [updacc_cong_from_eq]) end); fun lastN xs = drop parent_fields_len xs; (*selectors*) fun mk_sel_spec ((c, T), thm) = let val (acc $ arg, _) = HOLogic.dest_eq (HOLogic.dest_Trueprop (Envir.beta_eta_contract (Thm.concl_of thm))); val _ = if arg aconv r_rec0 then () else raise TERM ("mk_sel_spec: different arg", [arg]); in Const (mk_selC rec_schemeT0 (c, T)) :== acc end; val sel_specs = map mk_sel_spec (fields_more ~~ lastN accessor_thms); (*updates*) fun mk_upd_spec ((c, T), thm) = let val (upd $ _ $ arg, _) = HOLogic.dest_eq (HOLogic.dest_Trueprop (Envir.beta_eta_contract (Thm.concl_of thm))); val _ = if arg aconv r_rec0 then () else raise TERM ("mk_sel_spec: different arg", [arg]); in Const (mk_updC updateN rec_schemeT0 (c, T)) :== upd end; val upd_specs = map mk_upd_spec (fields_more ~~ lastN updator_thms); (*derived operations*) val make_spec = list_comb (Const (full (Binding.name makeN), all_types ---> recT0), all_vars) :== mk_rec (all_vars @ [HOLogic.unit]) 0; val fields_spec = list_comb (Const (full (Binding.name fields_selN), types ---> Type extension), vars) :== mk_rec (all_vars @ [HOLogic.unit]) parent_len; val extend_spec = Const (full (Binding.name extendN), recT0 --> moreT --> rec_schemeT0) $ r_unit0 $ more :== mk_rec ((map (mk_sel r_unit0) all_fields) @ [more]) 0; val truncate_spec = Const (full (Binding.name truncateN), rec_schemeT0 --> recT0) $ r0 :== mk_rec ((map (mk_sel r0) all_fields) @ [HOLogic.unit]) 0; (* 2st stage: defs_thy *) val (((sel_defs, upd_defs), derived_defs), defs_thy) = timeit_msg ext_ctxt "record trfuns/tyabbrs/selectors/updates/make/fields/extend/truncate defs:" (fn () => ext_thy |> Sign.print_translation print_translation |> Sign.restore_naming thy0 |> Typedecl.abbrev_global (binding, map #1 alphas, NoSyn) recT0 |> snd |> Typedecl.abbrev_global (Binding.suffix_name schemeN binding, map #1 (alphas @ [zeta]), NoSyn) rec_schemeT0 |> snd |> Sign.qualified_path false binding |> fold (fn ((x, T), mx) => snd o Sign.declare_const_global ((Binding.name x, T), mx)) (sel_decls ~~ (field_syntax @ [NoSyn])) |> fold (fn (x, T) => snd o Sign.declare_const_global ((Binding.name x, T), NoSyn)) (upd_decls @ [make_decl, fields_decl, extend_decl, truncate_decl]) |> (Global_Theory.add_defs false o map (Thm.no_attributes o apfst (Binding.concealed o Binding.name))) sel_specs ||>> (Global_Theory.add_defs false o map (Thm.no_attributes o apfst (Binding.concealed o Binding.name))) upd_specs ||>> (Global_Theory.add_defs false o map (Thm.no_attributes o apfst (Binding.concealed o Binding.name))) [make_spec, fields_spec, extend_spec, truncate_spec]); val defs_ctxt = Proof_Context.init_global defs_thy; (* prepare propositions *) val _ = timing_msg defs_ctxt "record preparing propositions"; val P = Free (singleton (Name.variant_list all_variants) "P", rec_schemeT0 --> HOLogic.boolT); val C = Free (singleton (Name.variant_list all_variants) "C", HOLogic.boolT); val P_unit = Free (singleton (Name.variant_list all_variants) "P", recT0 --> HOLogic.boolT); (*selectors*) val sel_conv_props = map (fn (c, x as Free (_, T)) => mk_sel r_rec0 (c, T) === x) named_vars_more; (*updates*) fun mk_upd_prop i (c, T) = let val x' = Free (singleton (Name.variant_list all_variants) (Long_Name.base_name c ^ "'"), T --> T); val n = parent_fields_len + i; val args' = nth_map n (K (x' $ nth all_vars_more n)) all_vars_more; in mk_upd updateN c x' r_rec0 === mk_rec args' 0 end; val upd_conv_props = map2 mk_upd_prop idxms fields_more; (*induct*) val induct_scheme_prop = fold_rev Logic.all all_vars_more (Trueprop (P $ r_rec0)) ==> Trueprop (P $ r0); val induct_prop = (fold_rev Logic.all all_vars (Trueprop (P_unit $ r_rec_unit0)), Trueprop (P_unit $ r_unit0)); (*surjective*) val surjective_prop = let val args = map (fn (c, Free (_, T)) => mk_sel r0 (c, T)) all_named_vars_more in r0 === mk_rec args 0 end; (*cases*) val cases_scheme_prop = (fold_rev Logic.all all_vars_more ((r0 === r_rec0) ==> Trueprop C), Trueprop C); val cases_prop = fold_rev Logic.all all_vars ((r_unit0 === r_rec_unit0) ==> Trueprop C) ==> Trueprop C; (*split*) val split_meta_prop = let val P = Free (singleton (Name.variant_list all_variants) "P", rec_schemeT0 --> propT); in Logic.mk_equals (Logic.all r0 (P $ r0), fold_rev Logic.all all_vars_more (P $ r_rec0)) end; val split_object_prop = let val ALL = fold_rev (fn (v, T) => fn t => HOLogic.mk_all (v, T, t)) in ALL [dest_Free r0] (P $ r0) === ALL (map dest_Free all_vars_more) (P $ r_rec0) end; val split_ex_prop = let val EX = fold_rev (fn (v, T) => fn t => HOLogic.mk_exists (v, T, t)) in EX [dest_Free r0] (P $ r0) === EX (map dest_Free all_vars_more) (P $ r_rec0) end; (*equality*) val equality_prop = let val s' = Free (rN ^ "'", rec_schemeT0); fun mk_sel_eq (c, Free (_, T)) = mk_sel r0 (c, T) === mk_sel s' (c, T); val seleqs = map mk_sel_eq all_named_vars_more; in Logic.all r0 (Logic.all s' (Logic.list_implies (seleqs, r0 === s'))) end; (* 3rd stage: thms_thy *) val record_ss = get_simpset defs_thy; val sel_upd_ctxt = put_simpset record_ss defs_ctxt addsimps (sel_defs @ accessor_thms @ upd_defs @ updator_thms); val (sel_convs, upd_convs) = timeit_msg defs_ctxt "record sel_convs/upd_convs proof:" (fn () => grouped 10 Par_List.map (fn prop => Goal.prove_sorry_global defs_thy [] [] prop (fn _ => ALLGOALS (asm_full_simp_tac sel_upd_ctxt))) (sel_conv_props @ upd_conv_props)) |> chop (length sel_conv_props); val (fold_congs, unfold_congs) = timeit_msg defs_ctxt "record upd fold/unfold congs:" (fn () => let val symdefs = map Thm.symmetric (sel_defs @ upd_defs); val fold_ctxt = put_simpset HOL_basic_ss defs_ctxt addsimps symdefs; val ua_congs = map (Drule.export_without_context o simplify fold_ctxt) upd_acc_cong_assists; in (ua_congs RL [updacc_foldE], ua_congs RL [updacc_unfoldE]) end); val parent_induct = Option.map #induct_scheme (try List.last parents); val induct_scheme = timeit_msg defs_ctxt "record induct_scheme proof:" (fn () => Goal.prove_sorry_global defs_thy [] [] induct_scheme_prop (fn {context = ctxt, ...} => EVERY [case parent_induct of NONE => all_tac | SOME ind => try_param_tac ctxt rN ind 1, try_param_tac ctxt rN ext_induct 1, asm_simp_tac (put_simpset HOL_basic_ss ctxt) 1])); val induct = timeit_msg defs_ctxt "record induct proof:" (fn () => Goal.prove_sorry_global defs_thy [] [#1 induct_prop] (#2 induct_prop) (fn {context = ctxt, prems, ...} => try_param_tac ctxt rN induct_scheme 1 THEN try_param_tac ctxt "more" @{thm unit.induct} 1 THEN resolve_tac ctxt prems 1)); val surjective = timeit_msg defs_ctxt "record surjective proof:" (fn () => Goal.prove_sorry_global defs_thy [] [] surjective_prop (fn {context = ctxt, ...} => EVERY [resolve_tac ctxt [surject_assist_idE] 1, simp_tac (put_simpset HOL_basic_ss ctxt addsimps ext_defs) 1, REPEAT (Iso_Tuple_Support.iso_tuple_intros_tac ctxt 1 ORELSE (resolve_tac ctxt [surject_assistI] 1 THEN simp_tac (put_simpset (get_sel_upd_defs defs_thy) ctxt addsimps (sel_defs @ @{thms o_assoc id_apply id_o o_id})) 1))])); val cases_scheme = timeit_msg defs_ctxt "record cases_scheme proof:" (fn () => Goal.prove_sorry_global defs_thy [] [#1 cases_scheme_prop] (#2 cases_scheme_prop) (fn {context = ctxt, prems, ...} => resolve_tac ctxt prems 1 THEN resolve_tac ctxt [surjective] 1)); val cases = timeit_msg defs_ctxt "record cases proof:" (fn () => Goal.prove_sorry_global defs_thy [] [] cases_prop (fn {context = ctxt, ...} => try_param_tac ctxt rN cases_scheme 1 THEN ALLGOALS (asm_full_simp_tac (put_simpset HOL_basic_ss ctxt addsimps @{thms unit_all_eq1})))); val split_meta = timeit_msg defs_ctxt "record split_meta proof:" (fn () => Goal.prove_sorry_global defs_thy [] [] split_meta_prop (fn {context = ctxt', ...} => EVERY1 [resolve_tac ctxt' @{thms equal_intr_rule}, Goal.norm_hhf_tac ctxt', eresolve_tac ctxt' @{thms meta_allE}, assume_tac ctxt', resolve_tac ctxt' [@{thm prop_subst} OF [surjective]], REPEAT o eresolve_tac ctxt' @{thms meta_allE}, assume_tac ctxt'])); val split_object = timeit_msg defs_ctxt "record split_object proof:" (fn () => Goal.prove_sorry_global defs_thy [] [] split_object_prop (fn {context = ctxt, ...} => resolve_tac ctxt [@{lemma "Trueprop A \ Trueprop B \ A = B" by (rule iffI) unfold}] 1 THEN rewrite_goals_tac ctxt @{thms atomize_all [symmetric]} THEN resolve_tac ctxt [split_meta] 1)); val split_ex = timeit_msg defs_ctxt "record split_ex proof:" (fn () => Goal.prove_sorry_global defs_thy [] [] split_ex_prop (fn {context = ctxt, ...} => simp_tac (put_simpset HOL_basic_ss ctxt addsimps (@{lemma "\x. P x \ \ (\x. \ P x)" by simp} :: @{thms not_not Not_eq_iff})) 1 THEN resolve_tac ctxt [split_object] 1)); val equality = timeit_msg defs_ctxt "record equality proof:" (fn () => Goal.prove_sorry_global defs_thy [] [] equality_prop (fn {context = ctxt, ...} => asm_full_simp_tac (put_simpset record_ss ctxt addsimps (split_meta :: sel_convs)) 1)); val ([(_, sel_convs'), (_, upd_convs'), (_, sel_defs'), (_, upd_defs'), (_, fold_congs'), (_, unfold_congs'), (_, splits' as [split_meta', split_object', split_ex']), (_, derived_defs'), (_, [surjective']), (_, [equality']), (_, [induct_scheme']), (_, [induct']), (_, [cases_scheme']), (_, [cases'])], thms_thy) = defs_thy |> Code.declare_default_eqns_global (map (rpair true) derived_defs) |> Global_Theory.note_thmss "" [((Binding.name "select_convs", []), [(sel_convs, [])]), ((Binding.name "update_convs", []), [(upd_convs, [])]), ((Binding.name "select_defs", []), [(sel_defs, [])]), ((Binding.name "update_defs", []), [(upd_defs, [])]), ((Binding.name "fold_congs", []), [(fold_congs, [])]), ((Binding.name "unfold_congs", []), [(unfold_congs, [])]), ((Binding.name "splits", []), [([split_meta, split_object, split_ex], [])]), ((Binding.name "defs", []), [(derived_defs, [])]), ((Binding.name "surjective", []), [([surjective], [])]), ((Binding.name "equality", []), [([equality], [])]), ((Binding.name "induct_scheme", induct_type_global (suffix schemeN name)), [([induct_scheme], [])]), ((Binding.name "induct", induct_type_global name), [([induct], [])]), ((Binding.name "cases_scheme", cases_type_global (suffix schemeN name)), [([cases_scheme], [])]), ((Binding.name "cases", cases_type_global name), [([cases], [])])]; val sel_upd_simps = sel_convs' @ upd_convs'; val sel_upd_defs = sel_defs' @ upd_defs'; val depth = parent_len + 1; val ([(_, simps'), (_, iffs')], thms_thy') = thms_thy |> Global_Theory.note_thmss "" [((Binding.name "simps", [Simplifier.simp_add]), [(sel_upd_simps, [])]), ((Binding.name "iffs", [iff_add]), [([ext_inject], [])])]; val info = make_info alphas parent fields extension ext_induct ext_inject ext_surjective ext_split ext_def sel_convs' upd_convs' sel_defs' upd_defs' fold_congs' unfold_congs' splits' derived_defs' surjective' equality' induct_scheme' induct' cases_scheme' cases' simps' iffs'; val final_thy = thms_thy' |> put_record name info |> put_sel_upd names full_moreN depth sel_upd_simps sel_upd_defs |> add_equalities extension_id equality' |> add_extinjects ext_inject |> add_extsplit extension_name ext_split |> add_splits extension_id (split_meta', split_object', split_ex', induct_scheme') |> add_extfields extension_name (fields @ [(full_moreN, moreT)]) |> add_fieldext (extension_name, snd extension) names |> add_code ext_tyco vs extT ext simps' ext_inject |> add_ctr_sugar (Const ext) cases_scheme' ext_inject sel_convs' |> fold add_spec_rule (sel_convs' @ upd_convs' @ derived_defs') |> Sign.restore_naming thy0; in final_thy end; (* add_record *) local fun read_parent NONE ctxt = (NONE, ctxt) | read_parent (SOME raw_T) ctxt = (case Proof_Context.read_typ_abbrev ctxt raw_T of Type (name, Ts) => (SOME (Ts, name), fold Variable.declare_typ Ts ctxt) | T => error ("Bad parent record specification: " ^ Syntax.string_of_typ ctxt T)); fun read_fields raw_fields ctxt = let val Ts = Syntax.read_typs ctxt (map (fn (_, raw_T, _) => raw_T) raw_fields); val fields = map2 (fn (x, _, mx) => fn T => (x, T, mx)) raw_fields Ts; val ctxt' = fold Variable.declare_typ Ts ctxt; in (fields, ctxt') end; in fun add_record overloaded (params, binding) raw_parent raw_fields thy = let val ctxt = Proof_Context.init_global thy; fun cert_typ T = Type.no_tvars (Proof_Context.cert_typ ctxt T) handle TYPE (msg, _, _) => error msg; (* specification *) val parent = Option.map (apfst (map cert_typ)) raw_parent handle ERROR msg => cat_error msg ("The error(s) above occurred in parent record specification"); val parent_args = (case parent of SOME (Ts, _) => Ts | NONE => []); val parents = get_parent_info thy parent; val bfields = raw_fields |> map (fn (x, raw_T, mx) => (x, cert_typ raw_T, mx) handle ERROR msg => cat_error msg ("The error(s) above occurred in record field " ^ Binding.print x)); (* errors *) val name = Sign.full_name thy binding; val err_dup_record = if is_none (get_info thy name) then [] else ["Duplicate definition of record " ^ quote name]; val spec_frees = fold Term.add_tfreesT (parent_args @ map #2 bfields) []; val err_extra_frees = (case subtract (op =) params spec_frees of [] => [] | extras => ["Extra free type variable(s) " ^ commas (map (Syntax.string_of_typ ctxt o TFree) extras)]); val err_no_fields = if null bfields then ["No fields present"] else []; val err_dup_fields = (case duplicates Binding.eq_name (map #1 bfields) of [] => [] | dups => ["Duplicate field(s) " ^ commas (map Binding.print dups)]); val err_bad_fields = if forall (not_equal moreN o Binding.name_of o #1) bfields then [] else ["Illegal field name " ^ quote moreN]; val errs = err_dup_record @ err_extra_frees @ err_no_fields @ err_dup_fields @ err_bad_fields; val _ = if null errs then () else error (cat_lines errs); in thy |> definition overloaded (params, binding) parent parents bfields end handle ERROR msg => cat_error msg ("Failed to define record " ^ Binding.print binding); fun add_record_cmd overloaded (raw_params, binding) raw_parent raw_fields thy = let val ctxt = Proof_Context.init_global thy; val params = map (apsnd (Typedecl.read_constraint ctxt)) raw_params; val ctxt1 = fold (Variable.declare_typ o TFree) params ctxt; val (parent, ctxt2) = read_parent raw_parent ctxt1; val (fields, ctxt3) = read_fields raw_fields ctxt2; val params' = map (Proof_Context.check_tfree ctxt3) params; in thy |> add_record overloaded (params', binding) parent fields end; end; (* printing *) local fun the_parent_recT (Type (parent, [Type (_, [unit as Type (_,[])])])) = Type (parent, [unit]) | the_parent_recT (Type (extT, [T])) = Type (extT, [the_parent_recT T]) | the_parent_recT T = raise TYPE ("Not a unit record scheme with parent: ", [T], []) in fun pretty_recT ctxt typ = let val thy = Proof_Context.theory_of ctxt val (fs, (_, moreT)) = get_recT_fields thy typ val _ = if moreT = HOLogic.unitT then () else raise TYPE ("Not a unit record scheme: ", [typ], []) val parent = if length (dest_recTs typ) >= 2 then SOME (the_parent_recT typ) else NONE val pfs = case parent of SOME p => fst (get_recT_fields thy p) | NONE => [] val fs' = drop (length pfs) fs fun pretty_field (name, typ) = Pretty.block [ Syntax.pretty_term ctxt (Const (name, typ)), Pretty.brk 1, Pretty.str "::", Pretty.brk 1, Syntax.pretty_typ ctxt typ ] in Pretty.block (Library.separate (Pretty.brk 1) ([Pretty.keyword1 "record", Syntax.pretty_typ ctxt typ, Pretty.str "="] @ (case parent of SOME p => [Syntax.pretty_typ ctxt p, Pretty.str "+"] | NONE => [])) @ Pretty.fbrk :: Pretty.fbreaks (map pretty_field fs')) end end fun string_of_record ctxt s = let val T = Syntax.read_typ ctxt s in Pretty.string_of (pretty_recT ctxt T) handle TYPE _ => error ("Unknown record: " ^ Syntax.string_of_typ ctxt T) end val print_record = let fun print_item string_of (modes, arg) = Toplevel.keep (fn state => Print_Mode.with_modes modes (fn () => Output.writeln (string_of state arg)) ()); in print_item (string_of_record o Toplevel.context_of) end (* outer syntax *) val _ = Outer_Syntax.command \<^command_keyword>\record\ "define extensible record" (Parse_Spec.overloaded -- (Parse.type_args_constrained -- Parse.binding) -- (\<^keyword>\=\ |-- Scan.option (Parse.typ --| \<^keyword>\+\) -- Scan.repeat1 Parse.const_binding) >> (fn ((overloaded, x), (y, z)) => Toplevel.theory (add_record_cmd {overloaded = overloaded} x y z))); val opt_modes = Scan.optional (\<^keyword>\(\ |-- Parse.!!! (Scan.repeat1 Parse.name --| \<^keyword>\)\)) [] val _ = Outer_Syntax.command \<^command_keyword>\print_record\ "print record definiton" (opt_modes -- Parse.typ >> print_record); end diff --git a/src/Pure/Isar/generic_target.ML b/src/Pure/Isar/generic_target.ML --- a/src/Pure/Isar/generic_target.ML +++ b/src/Pure/Isar/generic_target.ML @@ -1,437 +1,437 @@ (* Title: Pure/Isar/generic_target.ML Author: Makarius Author: Florian Haftmann, TU Muenchen Common target infrastructure. *) signature GENERIC_TARGET = sig (*auxiliary*) val export_abbrev: Proof.context -> (term -> term) -> term -> term * ((string * sort) list * (term list * term list)) val check_mixfix: Proof.context -> binding * (string * sort) list -> mixfix -> mixfix val check_mixfix_global: binding * bool -> mixfix -> mixfix (*background primitives*) val background_foundation: ((binding * typ) * mixfix) * (binding * term) -> term list * term list -> local_theory -> (term * thm) * local_theory val background_declaration: declaration -> local_theory -> local_theory val background_abbrev: binding * term -> term list -> local_theory -> (term * term) * local_theory (*nested local theories primitives*) val standard_facts: local_theory -> Proof.context -> Attrib.fact list -> Attrib.fact list val standard_notes: (int * int -> bool) -> string -> Attrib.fact list -> local_theory -> local_theory val standard_declaration: (int * int -> bool) -> (morphism -> Context.generic -> Context.generic) -> local_theory -> local_theory val standard_const: (int * int -> bool) -> Syntax.mode -> (binding * mixfix) * term -> local_theory -> local_theory (*lifting target primitives to local theory operations*) val define: (((binding * typ) * mixfix) * (binding * term) -> term list * term list -> local_theory -> (term * thm) * local_theory) -> bool -> (binding * mixfix) * (Attrib.binding * term) -> local_theory -> (term * (string * thm)) * local_theory val notes: (string -> Attrib.fact list -> Attrib.fact list -> local_theory -> local_theory) -> string -> Attrib.fact list -> local_theory -> (string * thm list) list * local_theory val abbrev: (Syntax.mode -> binding * mixfix -> term -> term list * term list -> local_theory -> local_theory) -> Syntax.mode -> (binding * mixfix) * term -> local_theory -> (term * term) * local_theory (*theory target primitives*) val theory_target_foundation: ((binding * typ) * mixfix) * (binding * term) -> term list * term list -> local_theory -> (term * thm) * local_theory val theory_target_notes: string -> Attrib.fact list -> Attrib.fact list -> local_theory -> local_theory val theory_target_abbrev: Syntax.mode -> (binding * mixfix) -> term -> term list * term list -> local_theory -> local_theory (*theory target operations*) val theory_abbrev: Syntax.mode -> (binding * mixfix) * term -> local_theory -> (term * term) * local_theory val theory_declaration: declaration -> local_theory -> local_theory val theory_registration: Locale.registration -> local_theory -> local_theory (*locale target primitives*) val locale_target_notes: string -> string -> Attrib.fact list -> Attrib.fact list -> local_theory -> local_theory val locale_target_abbrev: string -> Syntax.mode -> (binding * mixfix) -> term -> term list * term list -> local_theory -> local_theory val locale_target_declaration: string -> bool -> declaration -> local_theory -> local_theory val locale_target_const: string -> (morphism -> bool) -> Syntax.mode -> (binding * mixfix) * term -> local_theory -> local_theory (*locale operations*) val locale_abbrev: string -> Syntax.mode -> (binding * mixfix) * term -> local_theory -> (term * term) * local_theory val locale_declaration: string -> {syntax: bool, pervasive: bool} -> declaration -> local_theory -> local_theory val locale_const: string -> Syntax.mode -> (binding * mixfix) * term -> local_theory -> local_theory val locale_dependency: string -> Locale.registration -> local_theory -> local_theory (*initialisation*) val init: {background_naming: Name_Space.naming, setup: theory -> Proof.context, conclude: local_theory -> local_theory} -> Local_Theory.operations -> theory -> local_theory end structure Generic_Target: GENERIC_TARGET = struct (** consts **) fun export_abbrev lthy preprocess rhs = let val thy_ctxt = Proof_Context.init_global (Proof_Context.theory_of lthy); val rhs' = rhs |> Assumption.export_term lthy (Local_Theory.target_of lthy) |> preprocess; val term_params = map Free (sort (Variable.fixed_ord lthy o apply2 #1) (Variable.add_fixed lthy rhs' [])); val u = fold_rev lambda term_params rhs'; val global_rhs = singleton (Variable.polymorphic thy_ctxt) u; val extra_tfrees = subtract (op =) (Term.add_tfreesT (Term.fastype_of u) []) (Term.add_tfrees u []); val type_params = map (Logic.mk_type o TFree) extra_tfrees; in (global_rhs, (extra_tfrees, (type_params, term_params))) end; fun check_mixfix ctxt (b, extra_tfrees) mx = if null extra_tfrees then mx else (if Context_Position.is_visible ctxt then warning ("Additional type variable(s) in specification of " ^ Binding.print b ^ ": " ^ commas (map (Syntax.string_of_typ ctxt o TFree) (sort_by #1 extra_tfrees)) ^ (if Mixfix.is_empty mx then "" else "\nDropping mixfix syntax " ^ Pretty.string_of (Mixfix.pretty_mixfix mx))) else (); NoSyn); fun check_mixfix_global (b, no_params) mx = if no_params orelse Mixfix.is_empty mx then mx else (warning ("Dropping global mixfix syntax: " ^ Binding.print b ^ " " ^ Pretty.string_of (Mixfix.pretty_mixfix mx)); NoSyn); fun same_const (Const (c, _), Const (c', _)) = c = c' | same_const (t $ _, t' $ _) = same_const (t, t') | same_const (_, _) = false; fun const_decl phi_pred prmode ((b, mx), rhs) phi context = if phi_pred phi then let val b' = Morphism.binding phi b; val rhs' = Morphism.term phi rhs; val same_shape = Term.aconv_untyped (rhs, rhs'); val same_stem = same_shape orelse same_const (rhs, rhs'); val const_alias = if same_shape then (case rhs' of Const (c, T) => let val thy = Context.theory_of context; val ctxt = Context.proof_of context; in (case Type_Infer_Context.const_type ctxt c of SOME T' => if Sign.typ_equiv thy (T, T') then SOME c else NONE | NONE => NONE) end | _ => NONE) else NONE; in (case const_alias of SOME c => context |> Context.mapping (Sign.const_alias b' c) (Proof_Context.const_alias b' c) |> Morphism.form (Proof_Context.generic_notation true prmode [(rhs', mx)]) | NONE => context |> Proof_Context.generic_add_abbrev Print_Mode.internal (b', Term.close_schematic_term rhs') |-> (fn (const as Const (c, _), _) => same_stem ? (Proof_Context.generic_revert_abbrev (#1 prmode) c #> same_shape ? Morphism.form (Proof_Context.generic_notation true prmode [(const, mx)])))) end else context; (** background primitives **) fun background_foundation (((b, U), mx), (b_def, rhs)) (type_params, term_params) lthy = let val params = type_params @ term_params; val mx' = check_mixfix_global (b, null params) mx; val (const, lthy2) = lthy |> Local_Theory.background_theory_result (Sign.declare_const lthy ((b, U), mx')); val lhs = Term.list_comb (const, params); val ((_, def), lthy3) = lthy2 |> Local_Theory.background_theory_result (Thm.add_def (Proof_Context.defs_context lthy2) false false (Thm.def_binding_optional b b_def, Logic.mk_equals (lhs, rhs))); in ((lhs, def), lthy3) end; fun background_declaration decl lthy = let - val theory_decl = + fun theory_decl context = Local_Theory.standard_form lthy - (Proof_Context.init_global (Proof_Context.theory_of lthy)) decl; + (Proof_Context.init_global (Context.theory_of context)) decl context; in Local_Theory.background_theory (Context.theory_map theory_decl) lthy end; fun background_abbrev (b, global_rhs) params = Local_Theory.background_theory_result (Sign.add_abbrev Print_Mode.internal (b, global_rhs)) #>> apply2 (fn t => Term.list_comb (Logic.unvarify_global t, params)) (** nested local theories primitives **) fun standard_facts lthy ctxt = Attrib.transform_facts (Local_Theory.standard_morphism lthy ctxt); fun standard_notes pred kind facts lthy = Local_Theory.map_contexts (fn level => fn ctxt => if pred (Local_Theory.level lthy, level) then Attrib.local_notes kind (standard_facts lthy ctxt facts) ctxt |> snd else ctxt) lthy; fun standard_declaration pred decl lthy = Local_Theory.map_contexts (fn level => fn ctxt => if pred (Local_Theory.level lthy, level) then Context.proof_map (Local_Theory.standard_form lthy ctxt decl) ctxt else ctxt) lthy; fun standard_const pred prmode ((b, mx), rhs) = standard_declaration pred (const_decl (K true) prmode ((b, mx), rhs)); (** lifting target primitives to local theory operations **) (* define *) fun define foundation internal ((b, mx), ((b_def, atts), rhs)) lthy = let val thy_ctxt = Proof_Context.init_global (Proof_Context.theory_of lthy); (*term and type parameters*) val ((defs, _), rhs') = Thm.cterm_of lthy rhs |> Local_Defs.export_cterm lthy thy_ctxt ||> Thm.term_of; val xs = Variable.add_fixed lthy rhs' []; val T = Term.fastype_of rhs; val tfreesT = Term.add_tfreesT T (fold (Term.add_tfreesT o #2) xs []); val extra_tfrees = rev (subtract (op =) tfreesT (Term.add_tfrees rhs [])); val mx' = check_mixfix lthy (b, extra_tfrees) mx; val type_params = map (Logic.mk_type o TFree) extra_tfrees; val term_params = map Free (sort (Variable.fixed_ord lthy o apply2 #1) xs); val params = type_params @ term_params; val U = map Term.fastype_of params ---> T; (*foundation*) val ((lhs', global_def), lthy2) = lthy |> foundation (((b, U), mx'), (b_def, rhs')) (type_params, term_params); (*local definition*) val ([(lhs, (_, local_def))], lthy3) = lthy2 |> Context_Position.set_visible false |> Local_Defs.define [((b, NoSyn), (Binding.empty_atts, lhs'))] ||> Context_Position.restore_visible lthy2; (*result*) val def = Thm.transitive local_def global_def |> Local_Defs.contract lthy3 defs (Thm.cterm_of lthy3 (Logic.mk_equals (lhs, rhs))); val ([(res_name, [res])], lthy4) = lthy3 |> Local_Theory.notes [((if internal then Binding.empty else b_def, atts), [([def], [])])]; in ((lhs, (res_name, res)), lthy4) end; (* notes *) local fun import_export_proof ctxt (name, raw_th) = let val thy_ctxt = Proof_Context.init_global (Proof_Context.theory_of ctxt); (*export assumes/defines*) val th = Goal.norm_result ctxt raw_th; val ((defs, asms), th') = Local_Defs.export ctxt thy_ctxt th; val asms' = map (rewrite_rule ctxt (Drule.norm_hhf_eqs @ defs)) asms; (*export fixes*) val tfrees = map TFree (Thm.fold_terms Term.add_tfrees th' []); val frees = map Free (Thm.fold_terms Term.add_frees th' []); val (th'' :: vs) = (th' :: map (Drule.mk_term o Thm.cterm_of ctxt) (map Logic.mk_type tfrees @ frees)) |> Variable.export ctxt thy_ctxt |> Drule.zero_var_indexes_list; (*thm definition*) val result = Global_Theory.name_thm Global_Theory.official1 name th''; (*import fixes*) val (tvars, vars) = chop (length tfrees) (map (Thm.term_of o Drule.dest_term) vs) |>> map Logic.dest_type; val instT = map_filter (fn (TVar v, T) => SOME (v, T) | _ => NONE) (tvars ~~ tfrees); val inst = map_filter (fn (Var (xi, T), t) => SOME ((xi, Term_Subst.instantiateT instT T), Thm.cterm_of ctxt (Term.map_types (Term_Subst.instantiateT instT) t)) | _ => NONE) (vars ~~ frees); val result' = Thm.instantiate (map (apsnd (Thm.ctyp_of ctxt)) instT, inst) result; (*import assumes/defines*) val result'' = (fold (curry op COMP) asms' result' handle THM _ => raise THM ("Failed to re-import result", 0, result' :: asms')) |> Local_Defs.contract ctxt defs (Thm.cprop_of th) |> Goal.norm_result ctxt |> Global_Theory.name_thm Global_Theory.unofficial2 name; in (result'', result) end; fun bind_name lthy b = (Local_Theory.full_name lthy b, Binding.default_pos_of b); fun map_facts f = map (apsnd (map (apfst (map f)))); in fun notes target_notes kind facts lthy = let val facts' = facts |> map (fn (a, bs) => (a, Global_Theory.burrow_fact (Global_Theory.name_multi (bind_name lthy (fst a))) bs)) |> map_facts (import_export_proof lthy); val local_facts = map_facts #1 facts'; val global_facts = map_facts #2 facts'; in lthy |> target_notes kind global_facts (Attrib.partial_evaluation lthy local_facts) |> Attrib.local_notes kind local_facts end; end; (* abbrev *) fun abbrev target_abbrev prmode ((b, mx), rhs) lthy = let val (global_rhs, (extra_tfrees, (type_params, term_params))) = export_abbrev lthy I rhs; val mx' = check_mixfix lthy (b, extra_tfrees) mx; in lthy |> target_abbrev prmode (b, mx') global_rhs (type_params, term_params) |> Context_Position.set_visible false |> Proof_Context.add_abbrev Print_Mode.internal (b, rhs) |> snd |> Local_Defs.fixed_abbrev ((b, NoSyn), rhs) ||> Context_Position.restore_visible lthy end; (** theory target primitives **) fun theory_target_foundation (((b, U), mx), (b_def, rhs)) (type_params, term_params) = background_foundation (((b, U), mx), (b_def, rhs)) (type_params, term_params) #-> (fn (lhs, def) => standard_const (op <>) Syntax.mode_default ((b, mx), lhs) #> pair (lhs, def)); fun theory_target_notes kind global_facts local_facts = Local_Theory.background_theory (Attrib.global_notes kind global_facts #> snd) #> standard_notes (op <>) kind local_facts; fun theory_target_abbrev prmode (b, mx) global_rhs params = Local_Theory.background_theory_result (Sign.add_abbrev (#1 prmode) (b, global_rhs) #-> (fn (lhs, _) => (* FIXME type_params!? *) Sign.notation true prmode [(lhs, check_mixfix_global (b, null (snd params)) mx)] #> pair lhs)) #-> (fn lhs => standard_const (op <>) prmode ((b, if null (snd params) then NoSyn else mx), Term.list_comb (Logic.unvarify_global lhs, snd params))); (** theory operations **) val theory_abbrev = abbrev theory_target_abbrev; fun theory_declaration decl = background_declaration decl #> standard_declaration (K true) decl; val theory_registration = Local_Theory.raw_theory o Locale.add_registration_theory; (** locale target primitives **) fun locale_target_notes locale kind global_facts local_facts = Local_Theory.background_theory (Attrib.global_notes kind (Attrib.map_facts (K []) global_facts) #> snd) #> (fn lthy => lthy |> Local_Theory.target (fn ctxt => ctxt |> Locale.add_facts locale kind (standard_facts lthy ctxt local_facts))) #> standard_notes (fn (this, other) => other <> 0 andalso this <> other) kind local_facts; fun locale_target_declaration locale syntax decl lthy = lthy |> Local_Theory.target (fn ctxt => ctxt |> Locale.add_declaration locale syntax (Morphism.transform (Local_Theory.standard_morphism lthy ctxt) decl)); fun locale_target_const locale phi_pred prmode ((b, mx), rhs) = locale_target_declaration locale true (const_decl phi_pred prmode ((b, mx), rhs)) (** locale operations **) fun locale_declaration locale {syntax, pervasive} decl = pervasive ? background_declaration decl #> locale_target_declaration locale syntax decl #> standard_declaration (fn (_, other) => other <> 0) decl; fun locale_const locale prmode ((b, mx), rhs) = locale_target_const locale (K true) prmode ((b, mx), rhs) #> standard_const (fn (this, other) => other <> 0 andalso this <> other) prmode ((b, mx), rhs); fun locale_dependency locale registration = Local_Theory.raw_theory (Locale.add_dependency locale registration) #> Locale.add_registration_local_theory registration; (** locale abbreviations **) fun locale_target_abbrev locale prmode (b, mx) global_rhs params = background_abbrev (b, global_rhs) (snd params) #-> (fn (lhs, _) => locale_const locale prmode ((b, mx), lhs)); fun locale_abbrev locale = abbrev (locale_target_abbrev locale); (** initialisation **) fun init {background_naming, setup, conclude} operations thy = thy |> Sign.change_begin |> setup |> Local_Theory.init {background_naming = background_naming, exit = conclude #> Local_Theory.target_of #> Sign.change_end_local} operations; end; diff --git a/src/Pure/Isar/spec_rules.ML b/src/Pure/Isar/spec_rules.ML --- a/src/Pure/Isar/spec_rules.ML +++ b/src/Pure/Isar/spec_rules.ML @@ -1,131 +1,146 @@ (* Title: Pure/Isar/spec_rules.ML Author: Makarius Rules that characterize specifications, with rough classification. NB: In the face of arbitrary morphisms, the original shape of specifications may get lost. *) signature SPEC_RULES = sig datatype recursion = Primrec of string list | Recdef | Primcorec of string list | Corec | Unknown_Recursion val recursion_ord: recursion ord datatype rough_classification = Equational of recursion | Inductive | Co_Inductive | Unknown val rough_classification_ord: rough_classification ord val equational_primrec: string list -> rough_classification val equational_recdef: rough_classification val equational_primcorec: string list -> rough_classification val equational_corec: rough_classification val equational: rough_classification val is_equational: rough_classification -> bool val is_inductive: rough_classification -> bool val is_co_inductive: rough_classification -> bool + val is_relational: rough_classification -> bool val is_unknown: rough_classification -> bool - type spec = rough_classification * (term list * thm list) + type spec = + {name: string, rough_classification: rough_classification, terms: term list, rules: thm list} val get: Proof.context -> spec list val get_global: theory -> spec list val retrieve: Proof.context -> term -> spec list val retrieve_global: theory -> term -> spec list - val add: rough_classification -> term list * thm list -> local_theory -> local_theory - val add_global: rough_classification -> term list * thm list -> theory -> theory + val add: string -> rough_classification -> term list -> thm list -> local_theory -> local_theory + val add_global: string -> rough_classification -> term list -> thm list -> theory -> theory end; structure Spec_Rules: SPEC_RULES = struct (* recursion *) datatype recursion = Primrec of string list | Recdef | Primcorec of string list | Corec | Unknown_Recursion; val recursion_index = fn Primrec _ => 0 | Recdef => 1 | Primcorec _ => 2 | Corec => 3 | Unknown_Recursion => 4; fun recursion_ord (Primrec Ts1, Primrec Ts2) = list_ord fast_string_ord (Ts1, Ts2) | recursion_ord (Primcorec Ts1, Primcorec Ts2) = list_ord fast_string_ord (Ts1, Ts2) | recursion_ord rs = int_ord (apply2 recursion_index rs); (* rough classification *) datatype rough_classification = Equational of recursion | Inductive | Co_Inductive | Unknown; fun rough_classification_ord (Equational r1, Equational r2) = recursion_ord (r1, r2) | rough_classification_ord cs = int_ord (apply2 (fn Equational _ => 0 | Inductive => 1 | Co_Inductive => 2 | Unknown => 3) cs); val equational_primrec = Equational o Primrec; val equational_recdef = Equational Recdef; val equational_primcorec = Equational o Primcorec; val equational_corec = Equational Corec; val equational = Equational Unknown_Recursion; val is_equational = fn Equational _ => true | _ => false; val is_inductive = fn Inductive => true | _ => false; val is_co_inductive = fn Co_Inductive => true | _ => false; +val is_relational = is_inductive orf is_co_inductive; val is_unknown = fn Unknown => true | _ => false; (* rules *) -type spec = rough_classification * (term list * thm list); +type spec = + {name: string, rough_classification: rough_classification, terms: term list, rules: thm list}; + +fun eq_spec (specs: spec * spec) = + (op =) (apply2 #name specs) andalso + is_equal (rough_classification_ord (apply2 #rough_classification specs)) andalso + eq_list (op aconv) (apply2 #terms specs) andalso + eq_list Thm.eq_thm_prop (apply2 #rules specs); + +fun map_spec_rules f ({name, rough_classification, terms, rules}: spec) : spec = + {name = name, rough_classification = rough_classification, terms = terms, rules = map f rules}; structure Rules = Generic_Data ( type T = spec Item_Net.T; - val empty : T = - Item_Net.init - (fn ((c1, (ts1, ths1)), (c2, (ts2, ths2))) => - is_equal (rough_classification_ord (c1, c2)) andalso - eq_list (op aconv) (ts1, ts2) andalso - eq_list Thm.eq_thm_prop (ths1, ths2)) - (#1 o #2); + val empty : T = Item_Net.init eq_spec #terms; val extend = I; val merge = Item_Net.merge; ); (* get *) fun get_generic context = let val thy = Context.theory_of context; val transfer = Global_Theory.transfer_theories thy; - in Item_Net.content (Rules.get context) |> (map o apsnd o apsnd o map) transfer end; + in + Item_Net.content (Rules.get context) + |> (map o map_spec_rules) transfer + end; val get = get_generic o Context.Proof; val get_global = get_generic o Context.Theory; (* retrieve *) fun retrieve_generic context = Item_Net.retrieve (Rules.get context) - #> (map o apsnd o apsnd o map) (Thm.transfer'' context); + #> (map o map_spec_rules) (Thm.transfer'' context); val retrieve = retrieve_generic o Context.Proof; val retrieve_global = retrieve_generic o Context.Theory; (* add *) -fun add class (ts, ths) lthy = - let - val cts = map (Thm.cterm_of lthy) ts; - in +fun add name rough_classification terms rules lthy = + let val thms0 = map Thm.trim_context (map (Drule.mk_term o Thm.cterm_of lthy) terms @ rules) in lthy |> Local_Theory.declaration {syntax = false, pervasive = true} - (fn phi => + (fn phi => fn context => let - val (ts', ths') = - Morphism.fact phi (map Drule.mk_term cts @ ths) - |> chop (length cts) + val (terms', rules') = + map (Thm.transfer (Context.theory_of context)) thms0 + |> Morphism.fact phi + |> chop (length terms) |>> map (Thm.term_of o Drule.dest_term) ||> map Thm.trim_context; - in Rules.map (Item_Net.update (class, (ts', ths'))) end) + in + context |> (Rules.map o Item_Net.update) + {name = name, rough_classification = rough_classification, + terms = terms', rules = rules'} + end) end; -fun add_global class spec = - Context.theory_map (Rules.map (Item_Net.update (class, (apsnd o map) Thm.trim_context spec))); +fun add_global name rough_classification terms rules = + (Context.theory_map o Rules.map o Item_Net.update) + {name = name, rough_classification = rough_classification, + terms = terms, rules = map Thm.trim_context rules}; end; diff --git a/src/Pure/Isar/specification.ML b/src/Pure/Isar/specification.ML --- a/src/Pure/Isar/specification.ML +++ b/src/Pure/Isar/specification.ML @@ -1,472 +1,474 @@ (* Title: Pure/Isar/specification.ML Author: Makarius Derived local theory specifications --- with type-inference and toplevel polymorphism. *) signature SPECIFICATION = sig val read_props: string list -> (binding * string option * mixfix) list -> Proof.context -> term list * Proof.context val check_spec_open: (binding * typ option * mixfix) list -> (binding * typ option * mixfix) list -> term list -> term -> Proof.context -> ((binding * typ option * mixfix) list * string list * (string -> Position.T list) * term) * Proof.context val read_spec_open: (binding * string option * mixfix) list -> (binding * string option * mixfix) list -> string list -> string -> Proof.context -> ((binding * typ option * mixfix) list * string list * (string -> Position.T list) * term) * Proof.context type multi_specs = ((Attrib.binding * term) * term list * (binding * typ option * mixfix) list) list type multi_specs_cmd = ((Attrib.binding * string) * string list * (binding * string option * mixfix) list) list val check_multi_specs: (binding * typ option * mixfix) list -> multi_specs -> Proof.context -> (((binding * typ) * mixfix) list * (Attrib.binding * term) list) * Proof.context val read_multi_specs: (binding * string option * mixfix) list -> multi_specs_cmd -> Proof.context -> (((binding * typ) * mixfix) list * (Attrib.binding * term) list) * Proof.context val axiomatization: (binding * typ option * mixfix) list -> (binding * typ option * mixfix) list -> term list -> (Attrib.binding * term) list -> theory -> (term list * thm list) * theory val axiomatization_cmd: (binding * string option * mixfix) list -> (binding * string option * mixfix) list -> string list -> (Attrib.binding * string) list -> theory -> (term list * thm list) * theory val axiom: Attrib.binding * term -> theory -> thm * theory val definition: (binding * typ option * mixfix) option -> (binding * typ option * mixfix) list -> term list -> Attrib.binding * term -> local_theory -> (term * (string * thm)) * local_theory val definition': (binding * typ option * mixfix) option -> (binding * typ option * mixfix) list -> term list -> Attrib.binding * term -> bool -> local_theory -> (term * (string * thm)) * local_theory val definition_cmd: (binding * string option * mixfix) option -> (binding * string option * mixfix) list -> string list -> Attrib.binding * string -> bool -> local_theory -> (term * (string * thm)) * local_theory val abbreviation: Syntax.mode -> (binding * typ option * mixfix) option -> (binding * typ option * mixfix) list -> term -> bool -> local_theory -> local_theory val abbreviation_cmd: Syntax.mode -> (binding * string option * mixfix) option -> (binding * string option * mixfix) list -> string -> bool -> local_theory -> local_theory val alias: binding * string -> local_theory -> local_theory val alias_cmd: binding * (xstring * Position.T) -> local_theory -> local_theory val type_alias: binding * string -> local_theory -> local_theory val type_alias_cmd: binding * (xstring * Position.T) -> local_theory -> local_theory val type_notation: bool -> Syntax.mode -> (typ * mixfix) list -> local_theory -> local_theory val type_notation_cmd: bool -> Syntax.mode -> (string * mixfix) list -> local_theory -> local_theory val notation: bool -> Syntax.mode -> (term * mixfix) list -> local_theory -> local_theory val notation_cmd: bool -> Syntax.mode -> (string * mixfix) list -> local_theory -> local_theory val theorems: string -> (Attrib.binding * Attrib.thms) list -> (binding * typ option * mixfix) list -> bool -> local_theory -> (string * thm list) list * local_theory val theorems_cmd: string -> (Attrib.binding * (Facts.ref * Token.src list) list) list -> (binding * string option * mixfix) list -> bool -> local_theory -> (string * thm list) list * local_theory val theorem: bool -> string -> Method.text option -> (thm list list -> local_theory -> local_theory) -> Attrib.binding -> string list -> Element.context_i list -> Element.statement_i -> bool -> local_theory -> Proof.state val theorem_cmd: bool -> string -> Method.text option -> (thm list list -> local_theory -> local_theory) -> Attrib.binding -> (xstring * Position.T) list -> Element.context list -> Element.statement -> bool -> local_theory -> Proof.state val schematic_theorem: bool -> string -> Method.text option -> (thm list list -> local_theory -> local_theory) -> Attrib.binding -> string list -> Element.context_i list -> Element.statement_i -> bool -> local_theory -> Proof.state val schematic_theorem_cmd: bool -> string -> Method.text option -> (thm list list -> local_theory -> local_theory) -> Attrib.binding -> (xstring * Position.T) list -> Element.context list -> Element.statement -> bool -> local_theory -> Proof.state end; structure Specification: SPECIFICATION = struct (* prepare propositions *) fun read_props raw_props raw_fixes ctxt = let val (_, ctxt1) = ctxt |> Proof_Context.add_fixes_cmd raw_fixes; val props1 = map (Syntax.parse_prop ctxt1) raw_props; val (props2, ctxt2) = ctxt1 |> fold_map Variable.fix_dummy_patterns props1; val props3 = Syntax.check_props ctxt2 props2; val ctxt3 = ctxt2 |> fold Variable.declare_term props3; in (props3, ctxt3) end; (* prepare specification *) fun get_positions ctxt x = let fun get Cs (Const ("_type_constraint_", C) $ t) = get (C :: Cs) t | get Cs (Free (y, T)) = if x = y then map_filter Term_Position.decode_positionT (T :: map (Type.constraint_type ctxt) Cs) else [] | get _ (t $ u) = get [] t @ get [] u | get _ (Abs (_, _, t)) = get [] t | get _ _ = []; in get [] end; local fun prep_decls prep_var raw_vars ctxt = let val (vars, ctxt') = fold_map prep_var raw_vars ctxt; val (xs, ctxt'') = ctxt' |> Context_Position.set_visible false |> Proof_Context.add_fixes vars ||> Context_Position.restore_visible ctxt'; val _ = Context_Position.reports ctxt'' (map (Binding.pos_of o #1) vars ~~ map (Variable.markup_entity_def ctxt'' ##> Properties.remove Markup.kindN) xs); in ((vars, xs), ctxt'') end; fun close_form ctxt ys prems concl = let val xs = rev (fold (Variable.add_free_names ctxt) (prems @ [concl]) (rev ys)); val pos_props = Logic.strip_imp_concl concl :: Logic.strip_imp_prems concl @ prems; fun get_pos x = maps (get_positions ctxt x) pos_props; val _ = Context_Position.reports ctxt (maps (Syntax_Phases.reports_of_scope o get_pos) xs); in Logic.close_prop_constraint (Variable.default_type ctxt) (xs ~~ xs) prems concl end; fun dummy_frees ctxt xs tss = let val names = Variable.names_of ((fold o fold) Variable.declare_term tss ctxt) |> fold Name.declare xs; val (tss', _) = (fold_map o fold_map) Term.free_dummy_patterns tss names; in tss' end; fun prep_spec_open prep_var parse_prop raw_vars raw_params raw_prems raw_concl ctxt = let val ((vars, xs), vars_ctxt) = prep_decls prep_var raw_vars ctxt; val (ys, params_ctxt) = vars_ctxt |> fold_map prep_var raw_params |-> Proof_Context.add_fixes; val props = map (parse_prop params_ctxt) (raw_concl :: raw_prems) |> singleton (dummy_frees params_ctxt (xs @ ys)); val concl :: prems = Syntax.check_props params_ctxt props; val spec = Logic.list_implies (prems, concl); val spec_ctxt = Variable.declare_term spec params_ctxt; fun get_pos x = maps (get_positions spec_ctxt x) props; in ((vars, xs, get_pos, spec), spec_ctxt) end; fun prep_specs prep_var parse_prop prep_att raw_vars raw_specss ctxt = let val ((vars, xs), vars_ctxt) = prep_decls prep_var raw_vars ctxt; val propss0 = raw_specss |> map (fn ((_, raw_concl), raw_prems, raw_params) => let val (ys, ctxt') = vars_ctxt |> fold_map prep_var raw_params |-> Proof_Context.add_fixes in (ys, map (pair ctxt') (raw_concl :: raw_prems)) end); val props = burrow (grouped 10 Par_List.map_independent (uncurry parse_prop)) (map #2 propss0) |> dummy_frees vars_ctxt xs |> map2 (fn (ys, _) => fn concl :: prems => close_form vars_ctxt ys prems concl) propss0; val specs = Syntax.check_props vars_ctxt props; val specs_ctxt = vars_ctxt |> fold Variable.declare_term specs; val ps = specs_ctxt |> fold_map Proof_Context.inferred_param xs |> fst; val params = map2 (fn (b, _, mx) => fn (_, T) => ((b, T), mx)) vars ps; val name_atts: Attrib.binding list = map (fn ((name, atts), _) => (name, map (prep_att ctxt) atts)) (map #1 raw_specss); in ((params, name_atts ~~ specs), specs_ctxt) end; in val check_spec_open = prep_spec_open Proof_Context.cert_var (K I); val read_spec_open = prep_spec_open Proof_Context.read_var Syntax.parse_prop; type multi_specs = ((Attrib.binding * term) * term list * (binding * typ option * mixfix) list) list; type multi_specs_cmd = ((Attrib.binding * string) * string list * (binding * string option * mixfix) list) list; fun check_multi_specs xs specs = prep_specs Proof_Context.cert_var (K I) (K I) xs specs; fun read_multi_specs xs specs = prep_specs Proof_Context.read_var Syntax.parse_prop Attrib.check_src xs specs; end; (* axiomatization -- within global theory *) fun gen_axioms prep_stmt prep_att raw_decls raw_fixes raw_prems raw_concls thy = let (*specification*) val ({vars, propss = [prems, concls], ...}, vars_ctxt) = Proof_Context.init_global thy |> prep_stmt (raw_decls @ raw_fixes) ((map o map) (rpair []) [raw_prems, map snd raw_concls]); val (decls, fixes) = chop (length raw_decls) vars; val frees = rev ((fold o fold) (Variable.add_frees vars_ctxt) [prems, concls] []) |> map (fn (x, T) => (x, Free (x, T))); val close = Logic.close_prop (map #2 fixes @ frees) prems; val specs = map ((apsnd o map) (prep_att vars_ctxt) o fst) raw_concls ~~ map close concls; (*consts*) val (consts, consts_thy) = thy |> fold_map (fn ((b, _, mx), (_, t)) => Theory.specify_const ((b, Term.type_of t), mx)) decls; val subst = Term.subst_atomic (map (#2 o #2) decls ~~ consts); (*axioms*) val (axioms, axioms_thy) = (specs, consts_thy) |-> fold_map (fn ((b, atts), prop) => Thm.add_axiom_global (b, subst prop) #>> (fn (_, th) => ((b, atts), [([th], [])]))); (*facts*) val (facts, facts_lthy) = axioms_thy |> Named_Target.theory_init - |> Spec_Rules.add Spec_Rules.Unknown (consts, maps (maps #1 o #2) axioms) + |> Spec_Rules.add "" Spec_Rules.Unknown consts (maps (maps #1 o #2) axioms) |> Local_Theory.notes axioms; in ((consts, map (the_single o #2) facts), Local_Theory.exit_global facts_lthy) end; val axiomatization = gen_axioms Proof_Context.cert_stmt (K I); val axiomatization_cmd = gen_axioms Proof_Context.read_stmt Attrib.check_src; fun axiom (b, ax) = axiomatization [] [] [] [(b, ax)] #>> (hd o snd); (* definition *) fun gen_def prep_spec prep_att raw_var raw_params raw_prems ((a, raw_atts), raw_spec) int lthy = let val atts = map (prep_att lthy) raw_atts; val ((vars, xs, get_pos, spec), _) = lthy |> prep_spec (the_list raw_var) raw_params raw_prems raw_spec; val (((x, T), rhs), prove) = Local_Defs.derived_def lthy get_pos {conditional = true} spec; val _ = Name.reject_internal (x, []); val (b, mx) = (case (vars, xs) of ([], []) => (Binding.make (x, (case get_pos x of [] => Position.none | p :: _ => p)), NoSyn) | ([(b, _, mx)], [y]) => if x = y then (b, mx) else error ("Head of definition " ^ quote x ^ " differs from declaration " ^ quote y ^ Position.here (Binding.pos_of b))); + val const_name = Local_Theory.full_name lthy b; + val name = Thm.def_binding_optional b a; val ((lhs, (_, raw_th)), lthy2) = lthy |> Local_Theory.define_internal ((b, mx), ((Binding.suffix_name "_raw" name, []), rhs)); val th = prove lthy2 raw_th; - val lthy3 = lthy2 |> Spec_Rules.add Spec_Rules.equational ([lhs], [th]); + val lthy3 = lthy2 |> Spec_Rules.add const_name Spec_Rules.equational [lhs] [th]; val ([(def_name, [th'])], lthy4) = lthy3 |> Local_Theory.notes [((name, atts), [([th], [])])]; val lthy5 = lthy4 |> Code.declare_default_eqns [(th', true)]; val lhs' = Morphism.term (Local_Theory.target_morphism lthy5) lhs; val _ = Proof_Display.print_consts int (Position.thread_data ()) lthy5 (member (op =) (Term.add_frees lhs' [])) [(x, T)]; in ((lhs, (def_name, th')), lthy5) end; val definition' = gen_def check_spec_open (K I); fun definition xs ys As B = definition' xs ys As B false; val definition_cmd = gen_def read_spec_open Attrib.check_src; (* abbreviation *) fun gen_abbrev prep_spec mode raw_var raw_params raw_spec int lthy = let val lthy1 = lthy |> Proof_Context.set_syntax_mode mode; val ((vars, xs, get_pos, spec), _) = lthy |> Proof_Context.set_mode Proof_Context.mode_abbrev |> prep_spec (the_list raw_var) raw_params [] raw_spec; val ((x, T), rhs) = Local_Defs.abs_def (#2 (Local_Defs.cert_def lthy1 get_pos spec)); val _ = Name.reject_internal (x, []); val (b, mx) = (case (vars, xs) of ([], []) => (Binding.make (x, (case get_pos x of [] => Position.none | p :: _ => p)), NoSyn) | ([(b, _, mx)], [y]) => if x = y then (b, mx) else error ("Head of abbreviation " ^ quote x ^ " differs from declaration " ^ quote y ^ Position.here (Binding.pos_of b))); val lthy2 = lthy1 |> Local_Theory.abbrev mode ((b, mx), rhs) |> snd |> Proof_Context.restore_syntax_mode lthy; val _ = Proof_Display.print_consts int (Position.thread_data ()) lthy2 (K false) [(x, T)]; in lthy2 end; val abbreviation = gen_abbrev check_spec_open; val abbreviation_cmd = gen_abbrev read_spec_open; (* alias *) fun gen_alias decl check (b, arg) lthy = let val (c, reports) = check {proper = true, strict = false} lthy arg; val _ = Position.reports reports; in decl b c lthy end; val alias = gen_alias Local_Theory.const_alias (K (K (fn c => (c, [])))); val alias_cmd = gen_alias Local_Theory.const_alias (fn flags => fn ctxt => fn (c, pos) => apfst (#1 o dest_Const) (Proof_Context.check_const flags ctxt (c, [pos]))); val type_alias = gen_alias Local_Theory.type_alias (K (K (fn c => (c, [])))); val type_alias_cmd = gen_alias Local_Theory.type_alias (apfst (#1 o dest_Type) ooo Proof_Context.check_type_name); (* notation *) local fun gen_type_notation prep_type add mode args lthy = lthy |> Local_Theory.type_notation add mode (map (apfst (prep_type lthy)) args); fun gen_notation prep_const add mode args lthy = lthy |> Local_Theory.notation add mode (map (apfst (prep_const lthy)) args); in val type_notation = gen_type_notation (K I); val type_notation_cmd = gen_type_notation (Proof_Context.read_type_name {proper = true, strict = false}); val notation = gen_notation (K I); val notation_cmd = gen_notation (Proof_Context.read_const {proper = false, strict = false}); end; (* fact statements *) local fun gen_theorems prep_fact prep_att add_fixes kind raw_facts raw_fixes int lthy = let val facts = raw_facts |> map (fn ((name, atts), bs) => ((name, map (prep_att lthy) atts), bs |> map (fn (b, more_atts) => (prep_fact lthy b, map (prep_att lthy) more_atts)))); val (_, ctxt') = add_fixes raw_fixes lthy; val facts' = facts |> Attrib.partial_evaluation ctxt' |> Attrib.transform_facts (Proof_Context.export_morphism ctxt' lthy); val (res, lthy') = lthy |> Local_Theory.notes_kind kind facts'; val _ = Proof_Display.print_results int (Position.thread_data ()) lthy' ((kind, ""), res); in (res, lthy') end; in val theorems = gen_theorems (K I) (K I) Proof_Context.add_fixes; val theorems_cmd = gen_theorems Proof_Context.get_fact Attrib.check_src Proof_Context.add_fixes_cmd; end; (* complex goal statements *) local fun prep_statement prep_att prep_stmt raw_elems raw_stmt ctxt = let val (stmt, elems_ctxt) = prep_stmt raw_elems raw_stmt ctxt; val prems = Assumption.local_prems_of elems_ctxt ctxt; val stmt_ctxt = fold (fold (Proof_Context.augment o fst) o snd) stmt elems_ctxt; in (case raw_stmt of Element.Shows _ => let val stmt' = Attrib.map_specs (map prep_att) stmt in (([], prems, stmt', NONE), stmt_ctxt) end | Element.Obtains raw_obtains => let val asms_ctxt = stmt_ctxt |> fold (fn ((name, _), asm) => snd o Proof_Context.add_assms Assumption.assume_export [((name, [Context_Rules.intro_query NONE]), asm)]) stmt; val that = Assumption.local_prems_of asms_ctxt stmt_ctxt; val ([(_, that')], that_ctxt) = asms_ctxt |> Proof_Context.set_stmt true |> Proof_Context.note_thmss "" [((Binding.name Auto_Bind.thatN, []), [(that, [])])] ||> Proof_Context.restore_stmt asms_ctxt; val stmt' = [(Binding.empty_atts, [(#2 (#1 (Obtain.obtain_thesis ctxt)), [])])]; in ((Obtain.obtains_attribs raw_obtains, prems, stmt', SOME that'), that_ctxt) end) end; fun gen_theorem schematic bundle_includes prep_att prep_stmt long kind before_qed after_qed (name, raw_atts) raw_includes raw_elems raw_concl int lthy = let val _ = Local_Theory.assert lthy; val elems = raw_elems |> map (Element.map_ctxt_attrib (prep_att lthy)); val ((more_atts, prems, stmt, facts), goal_ctxt) = lthy |> bundle_includes raw_includes |> prep_statement (prep_att lthy) prep_stmt elems raw_concl; val atts = more_atts @ map (prep_att lthy) raw_atts; val pos = Position.thread_data (); fun after_qed' results goal_ctxt' = let val results' = burrow (map (Goal.norm_result lthy) o Proof_Context.export goal_ctxt' lthy) results; val (res, lthy') = if forall (Binding.is_empty_atts o fst) stmt then (map (pair "") results', lthy) else Local_Theory.notes_kind kind (map2 (fn (b, _) => fn ths => (b, [(ths, [])])) stmt results') lthy; val lthy'' = if Binding.is_empty_atts (name, atts) then (Proof_Display.print_results int pos lthy' ((kind, ""), res); lthy') else let val ([(res_name, _)], lthy'') = Local_Theory.notes_kind kind [((name, atts), [(maps #2 res, [])])] lthy'; val _ = Proof_Display.print_results int pos lthy' ((kind, res_name), res); in lthy'' end; in after_qed results' lthy'' end; val prems_name = if long then Auto_Bind.assmsN else Auto_Bind.thatN; in goal_ctxt |> not (null prems) ? (Proof_Context.note_thmss "" [((Binding.name prems_name, []), [(prems, [])])] #> snd) |> Proof.theorem before_qed after_qed' (map snd stmt) |> (case facts of NONE => I | SOME ths => Proof.refine_insert ths) |> tap (fn state => not schematic andalso Proof.schematic_goal state andalso error "Illegal schematic goal statement") end; in val theorem = gen_theorem false Bundle.includes (K I) Expression.cert_statement; val theorem_cmd = gen_theorem false Bundle.includes_cmd Attrib.check_src Expression.read_statement; val schematic_theorem = gen_theorem true Bundle.includes (K I) Expression.cert_statement; val schematic_theorem_cmd = gen_theorem true Bundle.includes_cmd Attrib.check_src Expression.read_statement; end; end; diff --git a/src/Pure/Proof/extraction.ML b/src/Pure/Proof/extraction.ML --- a/src/Pure/Proof/extraction.ML +++ b/src/Pure/Proof/extraction.ML @@ -1,860 +1,862 @@ (* Title: Pure/Proof/extraction.ML Author: Stefan Berghofer, TU Muenchen Extraction of programs from proofs. *) signature EXTRACTION = sig val set_preprocessor : (theory -> Proofterm.proof -> Proofterm.proof) -> theory -> theory val add_realizes_eqns_i : ((term * term) list * (term * term)) list -> theory -> theory val add_realizes_eqns : string list -> theory -> theory val add_typeof_eqns_i : ((term * term) list * (term * term)) list -> theory -> theory val add_typeof_eqns : string list -> theory -> theory val add_realizers_i : (string * (string list * term * Proofterm.proof)) list -> theory -> theory val add_realizers : (thm * (string list * string * string)) list -> theory -> theory val add_expand_thm : bool -> thm -> theory -> theory val add_types : (xstring * ((term -> term option) list * (term -> typ -> term -> typ -> term) option)) list -> theory -> theory val extract : (thm * string list) list -> theory -> theory val nullT : typ val nullt : term val mk_typ : typ -> term val etype_of : theory -> string list -> typ list -> term -> typ val realizes_of: theory -> string list -> term -> term -> term val abs_corr_shyps: theory -> thm -> string list -> term list -> Proofterm.proof -> Proofterm.proof end; structure Extraction : EXTRACTION = struct (**** tools ****) val typ = Simple_Syntax.read_typ; val add_syntax = Sign.root_path #> Sign.add_types_global [(Binding.make ("Type", \<^here>), 0, NoSyn), (Binding.make ("Null", \<^here>), 0, NoSyn)] #> Sign.add_consts [(Binding.make ("typeof", \<^here>), typ "'b \ Type", NoSyn), (Binding.make ("Type", \<^here>), typ "'a itself \ Type", NoSyn), (Binding.make ("Null", \<^here>), typ "Null", NoSyn), (Binding.make ("realizes", \<^here>), typ "'a \ 'b \ 'b", NoSyn)]; val nullT = Type ("Null", []); val nullt = Const ("Null", nullT); fun mk_typ T = Const ("Type", Term.itselfT T --> Type ("Type", [])) $ Logic.mk_type T; fun typeof_proc defaultS vs (Const ("typeof", _) $ u) = SOME (mk_typ (case strip_comb u of (Var ((a, i), _), _) => if member (op =) vs a then TFree ("'" ^ a ^ ":" ^ string_of_int i, defaultS) else nullT | (Free (a, _), _) => if member (op =) vs a then TFree ("'" ^ a, defaultS) else nullT | _ => nullT)) | typeof_proc _ _ _ = NONE; fun rlz_proc (Const ("realizes", Type (_, [Type ("Null", []), _])) $ _ $ t) = SOME t | rlz_proc (Const ("realizes", Type (_, [T, _])) $ r $ t) = (case strip_comb t of (Var (ixn, U), ts) => SOME (list_comb (Var (ixn, T --> U), r :: ts)) | (Free (s, U), ts) => SOME (list_comb (Free (s, T --> U), r :: ts)) | _ => NONE) | rlz_proc _ = NONE; val unpack_ixn = apfst implode o apsnd (fst o read_int o tl) o chop_prefix (fn s => s <> ":") o raw_explode; type rules = {next: int, rs: ((term * term) list * (term * term)) list, net: (int * ((term * term) list * (term * term))) Net.net}; val empty_rules : rules = {next = 0, rs = [], net = Net.empty}; fun add_rule (r as (_, (lhs, _))) ({next, rs, net} : rules) = {next = next - 1, rs = r :: rs, net = Net.insert_term (K false) (Envir.eta_contract lhs, (next, r)) net}; fun merge_rules ({next, rs = rs1, net} : rules) ({rs = rs2, ...} : rules) = fold_rev add_rule (subtract (op =) rs1 rs2) {next = next, rs = rs1, net = net}; fun condrew thy rules procs = let fun rew tm = Pattern.rewrite_term thy [] (condrew' :: procs) tm and condrew' tm = let val cache = Unsynchronized.ref ([] : (term * term) list); fun lookup f x = (case AList.lookup (op =) (!cache) x of NONE => let val y = f x in (cache := (x, y) :: !cache; y) end | SOME y => y); in get_first (fn (_, (prems, (tm1, tm2))) => let fun ren t = the_default t (Term.rename_abs tm1 tm t); val inc = Logic.incr_indexes ([], [], maxidx_of_term tm + 1); val env as (Tenv, tenv) = Pattern.match thy (inc tm1, tm) (Vartab.empty, Vartab.empty); val prems' = map (apply2 (Envir.subst_term env o inc o ren)) prems; val env' = Envir.Envir {maxidx = fold (fn (t, u) => Term.maxidx_term t #> Term.maxidx_term u) prems' ~1, tenv = tenv, tyenv = Tenv}; val env'' = fold (Pattern.unify (Context.Theory thy) o apply2 (lookup rew)) prems' env'; in SOME (Envir.norm_term env'' (inc (ren tm2))) end handle Pattern.MATCH => NONE | Pattern.Unif => NONE) (sort (int_ord o apply2 fst) (Net.match_term rules (Envir.eta_contract tm))) end; in rew end; val change_types = Proofterm.change_types o SOME; fun extr_name s vs = Long_Name.append "extr" (space_implode "_" (s :: vs)); fun corr_name s vs = extr_name s vs ^ "_correctness"; fun msg d s = writeln (Symbol.spaces d ^ s); fun vars_of t = map Var (rev (Term.add_vars t [])); fun frees_of t = map Free (rev (Term.add_frees t [])); fun vfs_of t = vars_of t @ frees_of t; val mkabs = fold_rev (fn v => fn t => Abs ("x", fastype_of v, abstract_over (v, t))); val mkabsp = fold_rev (fn t => fn prf => AbsP ("H", SOME t, prf)); fun strip_abs 0 t = t | strip_abs n (Abs (_, _, t)) = strip_abs (n-1) t | strip_abs _ _ = error "strip_abs: not an abstraction"; val prf_subst_TVars = Proofterm.map_proof_types o typ_subst_TVars; fun relevant_vars types prop = List.foldr (fn (Var ((a, _), T), vs) => (case body_type T of Type (s, _) => if member (op =) types s then a :: vs else vs | _ => vs) | (_, vs) => vs) [] (vars_of prop); fun tname_of (Type (s, _)) = s | tname_of _ = ""; fun get_var_type t = let val vs = Term.add_vars t []; val fs = Term.add_frees t []; in fn Var (ixn, _) => (case AList.lookup (op =) vs ixn of NONE => error "get_var_type: no such variable in term" | SOME T => Var (ixn, T)) | Free (s, _) => (case AList.lookup (op =) fs s of NONE => error "get_var_type: no such variable in term" | SOME T => Free (s, T)) | _ => error "get_var_type: not a variable" end; fun read_term ctxt T s = let val ctxt' = ctxt |> Proof_Context.set_defsort [] |> Config.put Type_Infer.object_logic false |> Config.put Type_Infer_Context.const_sorts false; val parse = if T = propT then Syntax.parse_prop else Syntax.parse_term; in parse ctxt' s |> Type.constraint T |> Syntax.check_term ctxt' end; fun make_proof_body prf = let val (oracles, thms) = ([prf], ([], [])) |-> Proofterm.fold_proof_atoms false (fn Oracle (name, prop, _) => apfst (cons (name, SOME prop)) | PThm (header, thm_body) => apsnd (cons (Proofterm.make_thm header thm_body)) | _ => I); val body = PBody {oracles = Ord_List.make Proofterm.oracle_ord oracles, thms = Ord_List.make Proofterm.thm_ord thms, proof = prf}; in Proofterm.thm_body body end; (**** theory data ****) (* theory data *) structure ExtractionData = Theory_Data ( type T = {realizes_eqns : rules, typeof_eqns : rules, types : (string * ((term -> term option) list * (term -> typ -> term -> typ -> term) option)) list, realizers : (string list * (term * proof)) list Symtab.table, defs : thm list, expand : string list, prep : (theory -> proof -> proof) option} val empty = {realizes_eqns = empty_rules, typeof_eqns = empty_rules, types = [], realizers = Symtab.empty, defs = [], expand = [], prep = NONE}; val extend = I; fun merge ({realizes_eqns = realizes_eqns1, typeof_eqns = typeof_eqns1, types = types1, realizers = realizers1, defs = defs1, expand = expand1, prep = prep1}, {realizes_eqns = realizes_eqns2, typeof_eqns = typeof_eqns2, types = types2, realizers = realizers2, defs = defs2, expand = expand2, prep = prep2}) : T = {realizes_eqns = merge_rules realizes_eqns1 realizes_eqns2, typeof_eqns = merge_rules typeof_eqns1 typeof_eqns2, types = AList.merge (op =) (K true) (types1, types2), realizers = Symtab.merge_list (eq_set (op =) o apply2 #1) (realizers1, realizers2), defs = Library.merge Thm.eq_thm (defs1, defs2), expand = Library.merge (op =) (expand1, expand2), prep = if is_some prep1 then prep1 else prep2}; ); fun read_condeq thy = let val ctxt' = Proof_Context.init_global (add_syntax thy) in fn s => let val t = Logic.varify_global (read_term ctxt' propT s) in (map Logic.dest_equals (Logic.strip_imp_prems t), Logic.dest_equals (Logic.strip_imp_concl t)) handle TERM _ => error ("Not a (conditional) meta equality:\n" ^ s) end end; (** preprocessor **) fun set_preprocessor prep thy = let val {realizes_eqns, typeof_eqns, types, realizers, defs, expand, ...} = ExtractionData.get thy in ExtractionData.put {realizes_eqns = realizes_eqns, typeof_eqns = typeof_eqns, types = types, realizers = realizers, defs = defs, expand = expand, prep = SOME prep} thy end; (** equations characterizing realizability **) fun gen_add_realizes_eqns prep_eq eqns thy = let val {realizes_eqns, typeof_eqns, types, realizers, defs, expand, prep} = ExtractionData.get thy; in ExtractionData.put {realizes_eqns = fold_rev add_rule (map (prep_eq thy) eqns) realizes_eqns, typeof_eqns = typeof_eqns, types = types, realizers = realizers, defs = defs, expand = expand, prep = prep} thy end val add_realizes_eqns_i = gen_add_realizes_eqns (K I); val add_realizes_eqns = gen_add_realizes_eqns read_condeq; (** equations characterizing type of extracted program **) fun gen_add_typeof_eqns prep_eq eqns thy = let val {realizes_eqns, typeof_eqns, types, realizers, defs, expand, prep} = ExtractionData.get thy; val eqns' = map (prep_eq thy) eqns in ExtractionData.put {realizes_eqns = realizes_eqns, realizers = realizers, typeof_eqns = fold_rev add_rule eqns' typeof_eqns, types = types, defs = defs, expand = expand, prep = prep} thy end val add_typeof_eqns_i = gen_add_typeof_eqns (K I); val add_typeof_eqns = gen_add_typeof_eqns read_condeq; fun thaw (T as TFree (a, S)) = if exists_string (fn s => s = ":") a then TVar (unpack_ixn a, S) else T | thaw (Type (a, Ts)) = Type (a, map thaw Ts) | thaw T = T; fun freeze (TVar ((a, i), S)) = TFree (a ^ ":" ^ string_of_int i, S) | freeze (Type (a, Ts)) = Type (a, map freeze Ts) | freeze T = T; fun freeze_thaw f x = map_types thaw (f (map_types freeze x)); fun etype_of thy vs Ts t = let val {typeof_eqns, ...} = ExtractionData.get thy; fun err () = error ("Unable to determine type of extracted program for\n" ^ Syntax.string_of_term_global thy t) in (case strip_abs_body (freeze_thaw (condrew thy (#net typeof_eqns) [typeof_proc [] vs]) (fold (Term.abs o pair "x") Ts (Const ("typeof", fastype_of1 (Ts, t) --> Type ("Type", [])) $ t))) of Const ("Type", _) $ u => (Logic.dest_type u handle TERM _ => err ()) | _ => err ()) end; (** realizers for axioms / theorems, together with correctness proofs **) fun gen_add_realizers prep_rlz rs thy = let val {realizes_eqns, typeof_eqns, types, realizers, defs, expand, prep} = ExtractionData.get thy in ExtractionData.put {realizes_eqns = realizes_eqns, typeof_eqns = typeof_eqns, types = types, realizers = fold (Symtab.cons_list o prep_rlz thy) rs realizers, defs = defs, expand = expand, prep = prep} thy end fun prep_realizer thy = let val {realizes_eqns, typeof_eqns, defs, types, ...} = ExtractionData.get thy; val procs = maps (fst o snd) types; val rtypes = map fst types; val eqns = Net.merge (K false) (#net realizes_eqns, #net typeof_eqns); val thy' = add_syntax thy; val ctxt' = Proof_Context.init_global thy'; val rd = Proof_Syntax.read_proof thy' true false; in fn (thm, (vs, s1, s2)) => let val name = Thm.derivation_name thm; val _ = name <> "" orelse error "add_realizers: unnamed theorem"; val prop = Thm.unconstrainT thm |> Thm.prop_of |> Pattern.rewrite_term thy' (map (Logic.dest_equals o Thm.prop_of) defs) []; val vars = vars_of prop; val vars' = filter_out (fn v => member (op =) rtypes (tname_of (body_type (fastype_of v)))) vars; val shyps = maps (fn Var ((x, i), _) => if member (op =) vs x then Logic.mk_of_sort (TVar (("'" ^ x, i), []), Sign.defaultS thy') else []) vars; val T = etype_of thy' vs [] prop; val (T', thw) = Type.legacy_freeze_thaw_type (if T = nullT then nullT else map fastype_of vars' ---> T); val t = map_types thw (read_term ctxt' T' s1); val r' = freeze_thaw (condrew thy' eqns (procs @ [typeof_proc [] vs, rlz_proc])) (Const ("realizes", T --> propT --> propT) $ (if T = nullT then t else list_comb (t, vars')) $ prop); val r = Logic.list_implies (shyps, fold_rev Logic.all (map (get_var_type r') vars) r'); val prf = Proofterm.reconstruct_proof thy' r (rd s2); in (name, (vs, (t, prf))) end end; val add_realizers_i = gen_add_realizers (fn _ => fn (name, (vs, t, prf)) => (name, (vs, (t, prf)))); val add_realizers = gen_add_realizers prep_realizer; fun realizes_of thy vs t prop = let val thy' = add_syntax thy; val {realizes_eqns, typeof_eqns, defs, types, ...} = ExtractionData.get thy'; val procs = maps (rev o fst o snd) types; val eqns = Net.merge (K false) (#net realizes_eqns, #net typeof_eqns); val prop' = Pattern.rewrite_term thy' (map (Logic.dest_equals o Thm.prop_of) defs) [] prop; in freeze_thaw (condrew thy' eqns (procs @ [typeof_proc [] vs, rlz_proc])) (Const ("realizes", fastype_of t --> propT --> propT) $ t $ prop') end; fun abs_corr_shyps thy thm vs xs prf = let val S = Sign.defaultS thy; val (ucontext, prop') = Logic.unconstrainT (Thm.shyps_of thm) (Thm.prop_of thm); val atyps = fold_types (fold_atyps (insert (op =))) (Thm.prop_of thm) []; val Ts = map_filter (fn ((v, i), _) => if member (op =) vs v then SOME (TVar (("'" ^ v, i), [])) else NONE) (rev (Term.add_vars prop' [])); val cs = maps (fn T => map (pair T) S) Ts; val constraints' = map Logic.mk_of_class cs; fun typ_map T = Type.strip_sorts (map_atyps (fn U => if member (op =) atyps U then (#atyp_map ucontext) U else U) T); fun mk_hyp (T, c) = Hyp (Logic.mk_of_class (typ_map T, c)); val xs' = map (map_types typ_map) xs in prf |> Same.commit (Proofterm.map_proof_same (map_types typ_map) typ_map mk_hyp) |> fold_rev Proofterm.implies_intr_proof' (map snd (#constraints ucontext)) |> fold_rev Proofterm.forall_intr_proof' xs' |> fold_rev Proofterm.implies_intr_proof' constraints' end; (** expanding theorems / definitions **) fun add_expand_thm is_def thm thy = let val {realizes_eqns, typeof_eqns, types, realizers, defs, expand, prep} = ExtractionData.get thy; val name = Thm.derivation_name thm; val _ = name <> "" orelse error "add_expand_thm: unnamed theorem"; in thy |> ExtractionData.put (if is_def then {realizes_eqns = realizes_eqns, typeof_eqns = add_rule ([], Logic.dest_equals (map_types Type.strip_sorts (Thm.prop_of (Drule.abs_def thm)))) typeof_eqns, types = types, realizers = realizers, defs = insert Thm.eq_thm_prop (Thm.trim_context thm) defs, expand = expand, prep = prep} else {realizes_eqns = realizes_eqns, typeof_eqns = typeof_eqns, types = types, realizers = realizers, defs = defs, expand = insert (op =) name expand, prep = prep}) end; fun extraction_expand is_def = Thm.declaration_attribute (fn th => Context.mapping (add_expand_thm is_def th) I); (** types with computational content **) fun add_types tys thy = ExtractionData.map (fn {realizes_eqns, typeof_eqns, types, realizers, defs, expand, prep} => {realizes_eqns = realizes_eqns, typeof_eqns = typeof_eqns, types = fold (AList.update (op =) o apfst (Sign.intern_type thy)) tys types, realizers = realizers, defs = defs, expand = expand, prep = prep}) thy; (** Pure setup **) val _ = Theory.setup (add_types [("prop", ([], NONE))] #> add_typeof_eqns ["(typeof (PROP P)) \ (Type (TYPE(Null))) \ \ \ (typeof (PROP Q)) \ (Type (TYPE('Q))) \ \ \ (typeof (PROP P \ PROP Q)) \ (Type (TYPE('Q)))", "(typeof (PROP Q)) \ (Type (TYPE(Null))) \ \ \ (typeof (PROP P \ PROP Q)) \ (Type (TYPE(Null)))", "(typeof (PROP P)) \ (Type (TYPE('P))) \ \ \ (typeof (PROP Q)) \ (Type (TYPE('Q))) \ \ \ (typeof (PROP P \ PROP Q)) \ (Type (TYPE('P \ 'Q)))", "(\x. typeof (PROP P (x))) \ (\x. Type (TYPE(Null))) \ \ \ (typeof (\x. PROP P (x))) \ (Type (TYPE(Null)))", "(\x. typeof (PROP P (x))) \ (\x. Type (TYPE('P))) \ \ \ (typeof (\x::'a. PROP P (x))) \ (Type (TYPE('a \ 'P)))", "(\x. typeof (f (x))) \ (\x. Type (TYPE('f))) \ \ \ (typeof (f)) \ (Type (TYPE('f)))"] #> add_realizes_eqns ["(typeof (PROP P)) \ (Type (TYPE(Null))) \ \ \ (realizes (r) (PROP P \ PROP Q)) \ \ \ (PROP realizes (Null) (PROP P) \ PROP realizes (r) (PROP Q))", "(typeof (PROP P)) \ (Type (TYPE('P))) \ \ \ (typeof (PROP Q)) \ (Type (TYPE(Null))) \ \ \ (realizes (r) (PROP P \ PROP Q)) \ \ \ (\x::'P. PROP realizes (x) (PROP P) \ PROP realizes (Null) (PROP Q))", "(realizes (r) (PROP P \ PROP Q)) \ \ \ (\x. PROP realizes (x) (PROP P) \ PROP realizes (r (x)) (PROP Q))", "(\x. typeof (PROP P (x))) \ (\x. Type (TYPE(Null))) \ \ \ (realizes (r) (\x. PROP P (x))) \ \ \ (\x. PROP realizes (Null) (PROP P (x)))", "(realizes (r) (\x. PROP P (x))) \ \ \ (\x. PROP realizes (r (x)) (PROP P (x)))"] #> Attrib.setup \<^binding>\extraction_expand\ (Scan.succeed (extraction_expand false)) "specify theorems to be expanded during extraction" #> Attrib.setup \<^binding>\extraction_expand_def\ (Scan.succeed (extraction_expand true)) "specify definitions to be expanded during extraction"); (**** extract program ****) val dummyt = Const ("dummy", dummyT); fun extract thm_vss thy = let val thy' = add_syntax thy; val {realizes_eqns, typeof_eqns, types, realizers, defs, expand, prep} = ExtractionData.get thy; val procs = maps (rev o fst o snd) types; val rtypes = map fst types; val typroc = typeof_proc []; fun expand_name ({name, ...}: Proofterm.thm_header) = if name = "" orelse member (op =) expand name then SOME "" else NONE; val prep = the_default (K I) prep thy' o Proof_Rewrite_Rules.elim_defs thy' false (map (Thm.transfer thy) defs) o Proofterm.expand_proof thy' expand_name; val rrews = Net.merge (K false) (#net realizes_eqns, #net typeof_eqns); fun find_inst prop Ts ts vs = let val rvs = relevant_vars rtypes prop; val vars = vars_of prop; val n = Int.min (length vars, length ts); fun add_args (Var ((a, i), _), t) (vs', tye) = if member (op =) rvs a then let val T = etype_of thy' vs Ts t in if T = nullT then (vs', tye) else (a :: vs', (("'" ^ a, i), T) :: tye) end else (vs', tye) in fold_rev add_args (take n vars ~~ take n ts) ([], []) end; fun mk_shyps tye = maps (fn (ixn, _) => Logic.mk_of_sort (TVar (ixn, []), Sign.defaultS thy)) tye; fun mk_sprfs cs tye = maps (fn (_, T) => Proof_Rewrite_Rules.expand_of_sort_proof thy' (map SOME cs) (T, Sign.defaultS thy)) tye; fun find (vs: string list) = Option.map snd o find_first (curry (eq_set (op =)) vs o fst); fun find' (s: string) = map_filter (fn (s', x) => if s = s' then SOME x else NONE); fun app_rlz_rews Ts vs t = strip_abs (length Ts) (freeze_thaw (condrew thy' rrews (procs @ [typroc vs, rlz_proc])) (fold (Term.abs o pair "x") Ts t)); fun realizes_null vs prop = app_rlz_rews [] vs (Const ("realizes", nullT --> propT --> propT) $ nullt $ prop); fun corr d vs ts Ts hs cs _ (PBound i) _ defs = (PBound i, defs) | corr d vs ts Ts hs cs t (Abst (s, SOME T, prf)) (Abst (_, _, prf')) defs = let val (corr_prf, defs') = corr d vs [] (T :: Ts) (dummyt :: hs) cs (case t of SOME (Abs (_, _, u)) => SOME u | _ => NONE) prf (Proofterm.incr_pboundvars 1 0 prf') defs in (Abst (s, SOME T, corr_prf), defs') end | corr d vs ts Ts hs cs t (AbsP (s, SOME prop, prf)) (AbsP (_, _, prf')) defs = let val T = etype_of thy' vs Ts prop; val u = if T = nullT then (case t of SOME u => SOME (incr_boundvars 1 u) | NONE => NONE) else (case t of SOME (Abs (_, _, u)) => SOME u | _ => NONE); val (corr_prf, defs') = corr d vs [] (T :: Ts) (prop :: hs) (prop :: cs) u (Proofterm.incr_pboundvars 0 1 prf) (Proofterm.incr_pboundvars 0 1 prf') defs; val rlz = Const ("realizes", T --> propT --> propT) in ( if T = nullT then AbsP ("R", SOME (app_rlz_rews Ts vs (rlz $ nullt $ prop)), Proofterm.prf_subst_bounds [nullt] corr_prf) else Abst (s, SOME T, AbsP ("R", SOME (app_rlz_rews (T :: Ts) vs (rlz $ Bound 0 $ incr_boundvars 1 prop)), corr_prf)), defs') end | corr d vs ts Ts hs cs t' (prf % SOME t) (prf' % _) defs = let val (Us, T) = strip_type (fastype_of1 (Ts, t)); val (corr_prf, defs') = corr d vs (t :: ts) Ts hs cs (if member (op =) rtypes (tname_of T) then t' else (case t' of SOME (u $ _) => SOME u | _ => NONE)) prf prf' defs; val u = if not (member (op =) rtypes (tname_of T)) then t else let val eT = etype_of thy' vs Ts t; val (r, Us') = if eT = nullT then (nullt, Us) else (Bound (length Us), eT :: Us); val u = list_comb (incr_boundvars (length Us') t, map Bound (length Us - 1 downto 0)); val u' = (case AList.lookup (op =) types (tname_of T) of SOME ((_, SOME f)) => f r eT u T | _ => Const ("realizes", eT --> T --> T) $ r $ u) in app_rlz_rews Ts vs (fold_rev (Term.abs o pair "x") Us' u') end in (corr_prf % SOME u, defs') end | corr d vs ts Ts hs cs t (prf1 %% prf2) (prf1' %% prf2') defs = let val prop = Proofterm.prop_of' hs prf2'; val T = etype_of thy' vs Ts prop; val (f, u, defs1) = if T = nullT then (t, NONE, defs) else (case t of SOME (f $ u) => (SOME f, SOME u, defs) | _ => let val (u, defs1) = extr d vs [] Ts hs prf2' defs in (NONE, SOME u, defs1) end) val ((corr_prf1, corr_prf2), defs2) = defs1 |> corr d vs [] Ts hs cs f prf1 prf1' ||>> corr d vs [] Ts hs cs u prf2 prf2'; in if T = nullT then (corr_prf1 %% corr_prf2, defs2) else (corr_prf1 % u %% corr_prf2, defs2) end | corr d vs ts Ts hs cs _ (prf0 as PThm (thm_header as {types = SOME Ts', ...}, thm_body)) _ defs = let val {pos, theory_name, name, prop, ...} = thm_header; val prf = Proofterm.thm_body_proof_open thm_body; val (vs', tye) = find_inst prop Ts ts vs; val shyps = mk_shyps tye; val sprfs = mk_sprfs cs tye; val tye' = (map fst (Term.add_tvars prop [] |> rev) ~~ Ts') @ tye; val T = etype_of thy' vs' [] prop; val defs' = if T = nullT then defs else snd (extr d vs ts Ts hs prf0 defs) in if T = nullT andalso realizes_null vs' prop aconv prop then (prf0, defs) else (case Symtab.lookup realizers name of NONE => (case find vs' (find' name defs') of NONE => let val _ = T = nullT orelse error "corr: internal error"; val _ = msg d ("Building correctness proof for " ^ quote name ^ (if null vs' then "" else " (relevant variables: " ^ commas_quote vs' ^ ")")); val prf' = prep (Proofterm.reconstruct_proof thy' prop prf); val (corr_prf0, defs'') = corr (d + 1) vs' [] [] [] (rev shyps) NONE prf' prf' defs'; val corr_prf = mkabsp shyps corr_prf0; val corr_prop = Proofterm.prop_of corr_prf; val corr_header = Proofterm.thm_header (serial ()) pos theory_name (corr_name name vs') corr_prop (SOME (map TVar (Term.add_tvars corr_prop [] |> rev))); val corr_prf' = Proofterm.proof_combP (Proofterm.proof_combt (PThm (corr_header, make_proof_body corr_prf), vfs_of corr_prop), map PBound (length shyps - 1 downto 0)) |> fold_rev Proofterm.forall_intr_proof' (map (get_var_type corr_prop) (vfs_of prop)) |> mkabsp shyps in (Proofterm.proof_combP (prf_subst_TVars tye' corr_prf', sprfs), (name, (vs', ((nullt, nullt), (corr_prf, corr_prf')))) :: defs'') end | SOME (_, (_, prf')) => (Proofterm.proof_combP (prf_subst_TVars tye' prf', sprfs), defs')) | SOME rs => (case find vs' rs of SOME (_, prf') => (Proofterm.proof_combP (prf_subst_TVars tye' prf', sprfs), defs') | NONE => error ("corr: no realizer for instance of theorem " ^ quote name ^ ":\n" ^ Syntax.string_of_term_global thy' (Envir.beta_norm (Proofterm.prop_of (Proofterm.proof_combt (prf0, ts))))))) end | corr d vs ts Ts hs cs _ (prf0 as PAxm (s, prop, SOME Ts')) _ defs = let val (vs', tye) = find_inst prop Ts ts vs; val tye' = (map fst (Term.add_tvars prop [] |> rev) ~~ Ts') @ tye in if etype_of thy' vs' [] prop = nullT andalso realizes_null vs' prop aconv prop then (prf0, defs) else case find vs' (Symtab.lookup_list realizers s) of SOME (_, prf) => (Proofterm.proof_combP (prf_subst_TVars tye' prf, mk_sprfs cs tye), defs) | NONE => error ("corr: no realizer for instance of axiom " ^ quote s ^ ":\n" ^ Syntax.string_of_term_global thy' (Envir.beta_norm (Proofterm.prop_of (Proofterm.proof_combt (prf0, ts))))) end | corr d vs ts Ts hs _ _ _ _ defs = error "corr: bad proof" and extr d vs ts Ts hs (PBound i) defs = (Bound i, defs) | extr d vs ts Ts hs (Abst (s, SOME T, prf)) defs = let val (t, defs') = extr d vs [] (T :: Ts) (dummyt :: hs) (Proofterm.incr_pboundvars 1 0 prf) defs in (Abs (s, T, t), defs') end | extr d vs ts Ts hs (AbsP (s, SOME t, prf)) defs = let val T = etype_of thy' vs Ts t; val (t, defs') = extr d vs [] (T :: Ts) (t :: hs) (Proofterm.incr_pboundvars 0 1 prf) defs in (if T = nullT then subst_bound (nullt, t) else Abs (s, T, t), defs') end | extr d vs ts Ts hs (prf % SOME t) defs = let val (u, defs') = extr d vs (t :: ts) Ts hs prf defs in (if member (op =) rtypes (tname_of (body_type (fastype_of1 (Ts, t)))) then u else u $ t, defs') end | extr d vs ts Ts hs (prf1 %% prf2) defs = let val (f, defs') = extr d vs [] Ts hs prf1 defs; val prop = Proofterm.prop_of' hs prf2; val T = etype_of thy' vs Ts prop in if T = nullT then (f, defs') else let val (t, defs'') = extr d vs [] Ts hs prf2 defs' in (f $ t, defs'') end end | extr d vs ts Ts hs (prf0 as PThm (thm_header as {types = SOME Ts', ...}, thm_body)) defs = let val {pos, theory_name, name = s, prop, ...} = thm_header; val prf = Proofterm.thm_body_proof_open thm_body; val (vs', tye) = find_inst prop Ts ts vs; val shyps = mk_shyps tye; val tye' = (map fst (Term.add_tvars prop [] |> rev) ~~ Ts') @ tye in case Symtab.lookup realizers s of NONE => (case find vs' (find' s defs) of NONE => let val _ = msg d ("Extracting " ^ quote s ^ (if null vs' then "" else " (relevant variables: " ^ commas_quote vs' ^ ")")); val prf' = prep (Proofterm.reconstruct_proof thy' prop prf); val (t, defs') = extr (d + 1) vs' [] [] [] prf' defs; val (corr_prf, defs'') = corr (d + 1) vs' [] [] [] (rev shyps) (SOME t) prf' prf' defs'; val nt = Envir.beta_norm t; val args = filter_out (fn v => member (op =) rtypes (tname_of (body_type (fastype_of v)))) (vfs_of prop); val args' = filter (fn v => Logic.occs (v, nt)) args; val t' = mkabs args' nt; val T = fastype_of t'; val cname = extr_name s vs'; val c = Const (cname, T); val u = mkabs args (list_comb (c, args')); val eqn = Logic.mk_equals (c, t'); val rlz = Const ("realizes", fastype_of nt --> propT --> propT); val lhs = app_rlz_rews [] vs' (rlz $ nt $ prop); val rhs = app_rlz_rews [] vs' (rlz $ list_comb (c, args') $ prop); val f = app_rlz_rews [] vs' (Abs ("x", T, rlz $ list_comb (Bound 0, args') $ prop)); val corr_prf' = mkabsp shyps (change_types [] Proofterm.equal_elim_axm %> lhs %> rhs %% (change_types [propT] Proofterm.symmetric_axm %> rhs %> lhs %% (change_types [T, propT] Proofterm.combination_axm %> f %> f %> c %> t' %% (change_types [T --> propT] Proofterm.reflexive_axm %> f) %% PAxm (Thm.def_name cname, eqn, SOME (map TVar (Term.add_tvars eqn [] |> rev))))) %% corr_prf); val corr_prop = Proofterm.prop_of corr_prf'; val corr_header = Proofterm.thm_header (serial ()) pos theory_name (corr_name s vs') corr_prop (SOME (map TVar (Term.add_tvars corr_prop [] |> rev))); val corr_prf'' = Proofterm.proof_combP (Proofterm.proof_combt (PThm (corr_header, make_proof_body corr_prf), vfs_of corr_prop), map PBound (length shyps - 1 downto 0)) |> fold_rev Proofterm.forall_intr_proof' (map (get_var_type corr_prop) (vfs_of prop)) |> mkabsp shyps in (subst_TVars tye' u, (s, (vs', ((t', u), (corr_prf', corr_prf'')))) :: defs'') end | SOME ((_, u), _) => (subst_TVars tye' u, defs)) | SOME rs => (case find vs' rs of SOME (t, _) => (subst_TVars tye' t, defs) | NONE => error ("extr: no realizer for instance of theorem " ^ quote s ^ ":\n" ^ Syntax.string_of_term_global thy' (Envir.beta_norm (Proofterm.prop_of (Proofterm.proof_combt (prf0, ts)))))) end | extr d vs ts Ts hs (prf0 as PAxm (s, prop, SOME Ts')) defs = let val (vs', tye) = find_inst prop Ts ts vs; val tye' = (map fst (Term.add_tvars prop [] |> rev) ~~ Ts') @ tye in case find vs' (Symtab.lookup_list realizers s) of SOME (t, _) => (subst_TVars tye' t, defs) | NONE => error ("extr: no realizer for instance of axiom " ^ quote s ^ ":\n" ^ Syntax.string_of_term_global thy' (Envir.beta_norm (Proofterm.prop_of (Proofterm.proof_combt (prf0, ts))))) end | extr d vs ts Ts hs _ defs = error "extr: bad proof"; fun prep_thm vs raw_thm = let val thm = Thm.transfer thy raw_thm; val prop = Thm.prop_of thm; val prf = Thm.proof_of thm; val name = Thm.derivation_name thm; val _ = name <> "" orelse error "extraction: unnamed theorem"; val _ = etype_of thy' vs [] prop <> nullT orelse error ("theorem " ^ quote name ^ " has no computational content") in Proofterm.reconstruct_proof thy' prop prf end; val defs = fold (fn (thm, vs) => snd o (extr 0 vs [] [] [] o prep_thm vs) thm) thm_vss []; fun add_def (s, (vs, ((t, u)))) thy = let val ft = Type.legacy_freeze t; val fu = Type.legacy_freeze u; val head = head_of (strip_abs_body fu); + val b = Binding.qualified_name (extr_name s vs); + val const_name = Sign.full_name thy b; in thy - |> Sign.add_consts [(Binding.qualified_name (extr_name s vs), fastype_of ft, NoSyn)] + |> Sign.add_consts [(b, fastype_of ft, NoSyn)] |> Global_Theory.add_defs false [((Binding.qualified_name (Thm.def_name (extr_name s vs)), Logic.mk_equals (head, ft)), [])] |-> (fn [def_thm] => - Spec_Rules.add_global Spec_Rules.equational ([head], [def_thm]) + Spec_Rules.add_global const_name Spec_Rules.equational [head] [def_thm] #> Code.declare_default_eqns_global [(def_thm, true)]) end; fun add_corr (s, (vs, prf)) thy = let val corr_prop = Proofterm.prop_of prf; in thy |> Global_Theory.store_thm (Binding.qualified_name (corr_name s vs), Thm.varifyT_global (funpow (length (vars_of corr_prop)) (Thm.forall_elim_var 0) (Thm.forall_intr_frees (Proof_Checker.thm_of_proof thy (fst (Proofterm.freeze_thaw_prf prf)))))) |> snd end; fun add_def_and_corr (s, (vs, ((t, u), (prf, _)))) thy = if is_none (Sign.const_type thy (extr_name s vs)) then thy |> not (t = nullt) ? add_def (s, (vs, ((t, u)))) |> add_corr (s, (vs, prf)) else thy; in thy |> Sign.root_path |> fold_rev add_def_and_corr defs |> Sign.restore_naming thy end; val etype_of = etype_of o add_syntax; end; diff --git a/src/Pure/Thy/export_theory.ML b/src/Pure/Thy/export_theory.ML --- a/src/Pure/Thy/export_theory.ML +++ b/src/Pure/Thy/export_theory.ML @@ -1,407 +1,408 @@ (* Title: Pure/Thy/export_theory.ML Author: Makarius Export foundational theory content and locale/class structure. *) signature EXPORT_THEORY = sig val setup_presentation: (Thy_Info.presentation_context -> theory -> unit) -> unit val export_body: theory -> string -> XML.body -> unit end; structure Export_Theory: EXPORT_THEORY = struct (* approximative syntax *) val get_syntax = Syntax.get_approx o Proof_Context.syn_of; fun get_syntax_type ctxt = get_syntax ctxt o Lexicon.mark_type; fun get_syntax_const ctxt = get_syntax ctxt o Lexicon.mark_const; fun get_syntax_fixed ctxt = get_syntax ctxt o Lexicon.mark_fixed; fun get_syntax_param ctxt loc x = let val thy = Proof_Context.theory_of ctxt in if Class.is_class thy loc then (case AList.lookup (op =) (Class.these_params thy [loc]) x of NONE => NONE | SOME (_, (c, _)) => get_syntax_const ctxt c) else get_syntax_fixed ctxt x end; val encode_syntax = XML.Encode.variant [fn NONE => ([], []), fn SOME (Syntax.Prefix delim) => ([delim], []), fn SOME (Syntax.Infix {assoc, delim, pri}) => let val ass = (case assoc of Printer.No_Assoc => 0 | Printer.Left_Assoc => 1 | Printer.Right_Assoc => 2); open XML.Encode Term_XML.Encode; in ([], triple int string int (ass, delim, pri)) end]; (* free variables: not declared in the context *) val is_free = not oo Name.is_declared; fun add_frees used = fold_aterms (fn Free (x, T) => is_free used x ? insert (op =) (x, T) | _ => I); fun add_tfrees used = (fold_types o fold_atyps) (fn TFree (a, S) => is_free used a ? insert (op =) (a, S) | _ => I); (* spec rules *) fun primrec_types ctxt const = Spec_Rules.retrieve ctxt (Const const) |> get_first - (fn (Spec_Rules.Equational (Spec_Rules.Primrec types), _) => SOME (types, false) - | (Spec_Rules.Equational (Spec_Rules.Primcorec types), _) => SOME (types, true) - | _ => NONE) + (#rough_classification #> + (fn Spec_Rules.Equational (Spec_Rules.Primrec types) => SOME (types, false) + | Spec_Rules.Equational (Spec_Rules.Primcorec types) => SOME (types, true) + | _ => NONE)) |> the_default ([], false); (* locales content *) fun locale_content thy loc = let val ctxt = Locale.init loc thy; val args = Locale.params_of thy loc |> map (fn ((x, T), _) => ((x, T), get_syntax_param ctxt loc x)); val axioms = let val (asm, defs) = Locale.specification_of thy loc; val cprops = map (Thm.cterm_of ctxt) (the_list asm @ defs); val (intro1, intro2) = Locale.intros_of thy loc; val intros_tac = Method.try_intros_tac ctxt (the_list intro1 @ the_list intro2) []; val res = Goal.init (Conjunction.mk_conjunction_balanced cprops) |> (ALLGOALS Goal.conjunction_tac THEN intros_tac) |> try Seq.hd; in (case res of SOME goal => Thm.prems_of goal | NONE => raise Fail ("Cannot unfold locale " ^ quote loc)) end; val typargs = rev (fold Term.add_tfrees (map (Free o #1) args @ axioms) []); in {typargs = typargs, args = args, axioms = axioms} end; fun get_locales thy = Locale.get_locales thy |> map_filter (fn loc => if Experiment.is_experiment thy loc then NONE else SOME (loc, ())); fun get_dependencies prev_thys thy = Locale.dest_dependencies prev_thys thy |> map_filter (fn dep => if Experiment.is_experiment thy (#source dep) orelse Experiment.is_experiment thy (#target dep) then NONE else let val (type_params, params) = Locale.parameters_of thy (#source dep); val typargs = fold (Term.add_tfreesT o #2 o #1) params type_params; val substT = typargs |> map_filter (fn v => let val T = TFree v; val T' = Morphism.typ (#morphism dep) T; in if T = T' then NONE else SOME (v, T') end); val subst = params |> map_filter (fn (v, _) => let val t = Free v; val t' = Morphism.term (#morphism dep) t; in if t aconv t' then NONE else SOME (v, t') end); in SOME (dep, (substT, subst)) end); (* general setup *) fun setup_presentation f = Theory.setup (Thy_Info.add_presentation (fn context => fn thy => if Options.bool (#options context) "export_theory" then f context thy else ())); fun export_body thy name body = if XML.is_empty_body body then () else Export.export thy (Path.binding0 (Path.make ["theory", name])) body; (* presentation *) val _ = setup_presentation (fn {adjust_pos, ...} => fn thy => let val parents = Theory.parents_of thy; val rep_tsig = Type.rep_tsig (Sign.tsig_of thy); val thy_ctxt = Proof_Context.init_global thy; (* entities *) fun make_entity_markup name xname pos serial = let val props = Position.offset_properties_of (adjust_pos pos) @ Position.id_properties_of pos @ Markup.serial_properties serial; in (Markup.entityN, (Markup.nameN, name) :: (Markup.xnameN, xname) :: props) end; fun entity_markup space name = let val xname = Name_Space.extern_shortest thy_ctxt space name; val {serial, pos, ...} = Name_Space.the_entry space name; in make_entity_markup name xname pos serial end; fun export_entities export_name export get_space decls = let val parent_spaces = map get_space parents; val space = get_space thy; in (decls, []) |-> fold (fn (name, decl) => if exists (fn space => Name_Space.declared space name) parent_spaces then I else (case export name decl of NONE => I | SOME body => cons (#serial (Name_Space.the_entry space name), XML.Elem (entity_markup space name, body)))) |> sort (int_ord o apply2 #1) |> map #2 |> export_body thy export_name end; (* types *) val encode_type = let open XML.Encode Term_XML.Encode in triple encode_syntax (list string) (option typ) end; fun export_type c (Type.LogicalType n) = SOME (encode_type (get_syntax_type thy_ctxt c, Name.invent Name.context Name.aT n, NONE)) | export_type c (Type.Abbreviation (args, U, false)) = SOME (encode_type (get_syntax_type thy_ctxt c, args, SOME U)) | export_type _ _ = NONE; val _ = export_entities "types" export_type Sign.type_space (Name_Space.dest_table (#types rep_tsig)); (* consts *) val consts = Sign.consts_of thy; val encode_term = Term_XML.Encode.term consts; val encode_const = let open XML.Encode Term_XML.Encode in pair encode_syntax (pair (list string) (pair typ (pair (option encode_term) (pair bool (pair (list string) bool))))) end; fun export_const c (T, abbrev) = let val syntax = get_syntax_const thy_ctxt c; val U = Logic.unvarifyT_global T; val U0 = Type.strip_sorts U; val recursion = primrec_types thy_ctxt (c, U); val abbrev' = abbrev |> Option.map (Proofterm.standard_vars_term Name.context #> map_types Type.strip_sorts); val args = map (#1 o dest_TFree) (Consts.typargs consts (c, U0)); val propositional = Object_Logic.is_propositional thy_ctxt (Term.body_type U0); in encode_const (syntax, (args, (U0, (abbrev', (propositional, recursion))))) end; val _ = export_entities "consts" (SOME oo export_const) Sign.const_space (#constants (Consts.dest consts)); (* axioms *) fun standard_prop used extra_shyps raw_prop raw_proof = let val (prop, proof) = Proofterm.standard_vars used (raw_prop, raw_proof); val args = rev (add_frees used prop []); val typargs = rev (add_tfrees used prop []); val used_typargs = fold (Name.declare o #1) typargs used; val sorts = Name.invent used_typargs Name.aT (length extra_shyps) ~~ extra_shyps; in ((sorts @ typargs, args, prop), proof) end; val encode_prop = let open XML.Encode Term_XML.Encode in triple (list (pair string sort)) (list (pair string typ)) encode_term end; fun encode_axiom used prop = encode_prop (#1 (standard_prop used [] prop NONE)); val _ = export_entities "axioms" (K (SOME o encode_axiom Name.context)) Theory.axiom_space (Theory.all_axioms_of thy); (* theorems and proof terms *) val clean_thm = Thm.check_hyps (Context.Theory thy) #> Thm.strip_shyps; val lookup_thm_id = Global_Theory.lookup_thm_id thy; fun expand_name thm_id (header: Proofterm.thm_header) = if #serial header = #serial thm_id then "" else (case lookup_thm_id (Proofterm.thm_header_id header) of NONE => "" | SOME thm_name => Thm_Name.print thm_name); fun entity_markup_thm (serial, (name, i)) = let val space = Facts.space_of (Global_Theory.facts_of thy); val xname = Name_Space.extern_shortest thy_ctxt space name; val {pos, ...} = Name_Space.the_entry space name; in make_entity_markup (Thm_Name.print (name, i)) (Thm_Name.print (xname, i)) pos serial end; fun encode_thm thm_id raw_thm = let val deps = map (Thm_Name.print o #2) (Thm_Deps.thm_deps thy [raw_thm]); val thm = clean_thm (Thm.unconstrainT raw_thm); val proof0 = if Proofterm.export_standard_enabled () then Proof_Syntax.standard_proof_of {full = true, expand_name = SOME o expand_name thm_id} thm else if Proofterm.export_enabled () then Thm.reconstruct_proof_of thm else MinProof; val (prop, SOME proof) = standard_prop Name.context (Thm.extra_shyps thm) (Thm.full_prop_of thm) (SOME proof0); val _ = Thm.expose_proofs thy [thm]; in (prop, deps, proof) |> let open XML.Encode Term_XML.Encode; val encode_proof = Proofterm.encode_standard_proof consts; in triple encode_prop (list string) encode_proof end end; fun export_thm (thm_id, thm_name) = let val markup = entity_markup_thm (#serial thm_id, thm_name); val thm = Global_Theory.get_thm_name thy (thm_name, Position.none); in XML.Elem (markup, encode_thm thm_id thm) end; val _ = export_body thy "thms" (map export_thm (Global_Theory.dest_thm_names thy)); (* type classes *) val encode_class = let open XML.Encode Term_XML.Encode in pair (list (pair string typ)) (list (encode_axiom Name.context)) end; fun export_class name = (case try (Axclass.get_info thy) name of NONE => ([], []) | SOME {params, axioms, ...} => (params, map (Thm.plain_prop_of o clean_thm) axioms)) |> encode_class |> SOME; val _ = export_entities "classes" (fn name => fn () => export_class name) Sign.class_space (map (rpair ()) (Graph.keys (Sorts.classes_of (#2 (#classes rep_tsig))))); (* sort algebra *) local val prop = encode_axiom Name.context o Logic.varify_global; val encode_classrel = let open XML.Encode in list (pair prop (pair string string)) end; val encode_arities = let open XML.Encode Term_XML.Encode in list (pair prop (triple string (list sort) string)) end; in val export_classrel = maps (fn (c, cs) => map (pair c) cs) #> map (`Logic.mk_classrel) #> encode_classrel; val export_arities = map (`Logic.mk_arity) #> encode_arities; val {classrel, arities} = Sorts.dest_algebra (map (#2 o #classes o Type.rep_tsig o Sign.tsig_of) parents) (#2 (#classes rep_tsig)); end; val _ = if null classrel then () else export_body thy "classrel" (export_classrel classrel); val _ = if null arities then () else export_body thy "arities" (export_arities arities); (* locales *) fun encode_locale used = let open XML.Encode Term_XML.Encode in triple (list (pair string sort)) (list (pair (pair string typ) encode_syntax)) (list (encode_axiom used)) end; fun export_locale loc = let val {typargs, args, axioms} = locale_content thy loc; val used = fold Name.declare (map #1 typargs @ map (#1 o #1) args) Name.context; in encode_locale used (typargs, args, axioms) end handle ERROR msg => cat_error msg ("The error(s) above occurred in locale " ^ quote (Locale.markup_name thy_ctxt loc)); val _ = export_entities "locales" (fn loc => fn () => SOME (export_locale loc)) Locale.locale_space (get_locales thy); (* locale dependencies *) fun encode_locale_dependency (dep: Locale.locale_dependency, subst) = (#source dep, (#target dep, (#prefix dep, subst))) |> let open XML.Encode Term_XML.Encode; val encode_subst = pair (list (pair (pair string sort) typ)) (list (pair (pair string typ) (term consts))); in pair string (pair string (pair (list (pair string bool)) encode_subst)) end; val _ = get_dependencies parents thy |> map_index (fn (i, dep) => let val xname = string_of_int (i + 1); val name = Long_Name.implode [Context.theory_name thy, xname]; val markup = make_entity_markup name xname (#pos (#1 dep)) (#serial (#1 dep)); val body = encode_locale_dependency dep; in XML.Elem (markup, body) end) |> export_body thy "locale_dependencies"; (* constdefs *) val constdefs = Defs.dest_constdefs (map Theory.defs_of (Theory.parents_of thy)) (Theory.defs_of thy) |> sort_by #1; val encode_constdefs = let open XML.Encode in list (pair string string) end; val _ = if null constdefs then () else export_body thy "constdefs" (encode_constdefs constdefs); (* parents *) val _ = Export.export thy \<^path_binding>\theory/parents\ (XML.Encode.string (cat_lines (map Context.theory_long_name parents))); in () end); end; diff --git a/src/Pure/assumption.ML b/src/Pure/assumption.ML --- a/src/Pure/assumption.ML +++ b/src/Pure/assumption.ML @@ -1,155 +1,151 @@ (* Title: Pure/assumption.ML Author: Makarius Context assumptions, parameterized by export rules. *) signature ASSUMPTION = sig type export = bool -> cterm list -> (thm -> thm) * (term -> term) val assume_export: export val presume_export: export val assume: Proof.context -> cterm -> thm val assume_hyps: cterm -> Proof.context -> thm * Proof.context val all_assms_of: Proof.context -> cterm list val all_prems_of: Proof.context -> thm list val local_assms_of: Proof.context -> Proof.context -> cterm list val local_prems_of: Proof.context -> Proof.context -> thm list val add_assms: export -> cterm list -> Proof.context -> thm list * Proof.context val add_assumes: cterm list -> Proof.context -> thm list * Proof.context val export: bool -> Proof.context -> Proof.context -> thm -> thm val export_term: Proof.context -> Proof.context -> term -> term val export_morphism: Proof.context -> Proof.context -> morphism end; structure Assumption: ASSUMPTION = struct (** basic rules **) type export = bool -> cterm list -> (thm -> thm) * (term -> term); (* [A] : B -------- #A \ B *) fun assume_export is_goal asms = (if is_goal then Drule.implies_intr_protected asms else Drule.implies_intr_list asms, fn t => t); (* [A] : B ------- A \ B *) fun presume_export _ = assume_export false; fun assume ctxt = Raw_Simplifier.norm_hhf ctxt o Thm.assume; fun assume_hyps ct ctxt = let val (th, ctxt') = Thm.assume_hyps ct ctxt in (Raw_Simplifier.norm_hhf ctxt' th, ctxt') end; (** local context data **) datatype data = Data of {assms: (export * cterm list) list, (*assumes: A \ _*) prems: thm list}; (*prems: A |- norm_hhf A*) fun make_data (assms, prems) = Data {assms = assms, prems = prems}; val empty_data = make_data ([], []); structure Data = Proof_Data ( type T = data; fun init _ = empty_data; ); fun map_data f = Data.map (fn Data {assms, prems} => make_data (f (assms, prems))); fun rep_data ctxt = Data.get ctxt |> (fn Data rep => rep); (* all assumptions *) val all_assumptions_of = #assms o rep_data; val all_assms_of = maps #2 o all_assumptions_of; val all_prems_of = #prems o rep_data; (* local assumptions *) local fun drop_prefix eq (args as (x :: xs, y :: ys)) = if eq (x, y) then drop_prefix eq (xs, ys) else args | drop_prefix _ args = args; fun check_result ctxt kind term_of res = (case res of ([], rest) => rest | (bad :: _, _) => raise Fail ("Outer context disagrees on " ^ kind ^ ": " ^ Syntax.string_of_term ctxt (term_of bad))); in fun local_assumptions_of inner outer = drop_prefix (eq_snd (eq_list Thm.aconvc)) (apply2 all_assumptions_of (outer, inner)) |>> maps #2 |> check_result outer "assumption" Thm.term_of; val local_assms_of = maps #2 oo local_assumptions_of; fun local_prems_of inner outer = drop_prefix Thm.eq_thm_prop (apply2 all_prems_of (outer, inner)) |> check_result outer "premise" Thm.prop_of; end; (* add assumptions *) fun add_assms export new_asms ctxt = let val (new_prems, ctxt') = fold_map assume_hyps new_asms ctxt in ctxt' |> map_data (fn (asms, prems) => (asms @ [(export, new_asms)], prems @ new_prems)) |> pair new_prems end; val add_assumes = add_assms assume_export; (* export *) -fun normalize ctxt0 th0 = - let val (ctxt, th) = Thm.join_transfer_context (ctxt0, th0) - in Raw_Simplifier.norm_hhf_protect ctxt th end; - fun export is_goal inner outer = - normalize inner #> + Raw_Simplifier.norm_hhf_protect inner #> fold_rev (fn (e, As) => #1 (e is_goal As)) (local_assumptions_of inner outer) #> - normalize outer; + Raw_Simplifier.norm_hhf_protect outer; fun export_term inner outer = fold_rev (fn (e, As) => #2 (e false As)) (local_assumptions_of inner outer); fun export_morphism inner outer = let val thm = export false inner outer; val term = export_term inner outer; val typ = Logic.type_map term; in Morphism.transfer_morphism' inner $> Morphism.transfer_morphism' outer $> Morphism.morphism "Assumption.export" {binding = [], typ = [typ], term = [term], fact = [map thm]} end; end; diff --git a/src/Pure/raw_simplifier.ML b/src/Pure/raw_simplifier.ML --- a/src/Pure/raw_simplifier.ML +++ b/src/Pure/raw_simplifier.ML @@ -1,1460 +1,1459 @@ (* Title: Pure/raw_simplifier.ML Author: Tobias Nipkow and Stefan Berghofer, TU Muenchen Higher-order Simplification. *) infix 4 addsimps delsimps addsimprocs delsimprocs setloop addloop delloop setSSolver addSSolver setSolver addSolver; signature BASIC_RAW_SIMPLIFIER = sig val simp_depth_limit: int Config.T val simp_trace_depth_limit: int Config.T val simp_debug: bool Config.T val simp_trace: bool Config.T type cong_name = bool * string type rrule val mk_rrules: Proof.context -> thm list -> rrule list val eq_rrule: rrule * rrule -> bool type proc type solver val mk_solver: string -> (Proof.context -> int -> tactic) -> solver type simpset val empty_ss: simpset val merge_ss: simpset * simpset -> simpset val dest_ss: simpset -> {simps: (string * thm) list, procs: (string * term list) list, congs: (cong_name * thm) list, weak_congs: cong_name list, loopers: string list, unsafe_solvers: string list, safe_solvers: string list} type simproc val eq_simproc: simproc * simproc -> bool val cert_simproc: theory -> string -> {lhss: term list, proc: morphism -> Proof.context -> cterm -> thm option} -> simproc val transform_simproc: morphism -> simproc -> simproc val simpset_of: Proof.context -> simpset val put_simpset: simpset -> Proof.context -> Proof.context val simpset_map: Proof.context -> (Proof.context -> Proof.context) -> simpset -> simpset val map_theory_simpset: (Proof.context -> Proof.context) -> theory -> theory val empty_simpset: Proof.context -> Proof.context val clear_simpset: Proof.context -> Proof.context val addsimps: Proof.context * thm list -> Proof.context val delsimps: Proof.context * thm list -> Proof.context val addsimprocs: Proof.context * simproc list -> Proof.context val delsimprocs: Proof.context * simproc list -> Proof.context val setloop: Proof.context * (Proof.context -> int -> tactic) -> Proof.context val addloop: Proof.context * (string * (Proof.context -> int -> tactic)) -> Proof.context val delloop: Proof.context * string -> Proof.context val setSSolver: Proof.context * solver -> Proof.context val addSSolver: Proof.context * solver -> Proof.context val setSolver: Proof.context * solver -> Proof.context val addSolver: Proof.context * solver -> Proof.context val rewrite_rule: Proof.context -> thm list -> thm -> thm val rewrite_goals_rule: Proof.context -> thm list -> thm -> thm val rewrite_goals_tac: Proof.context -> thm list -> tactic val rewrite_goal_tac: Proof.context -> thm list -> int -> tactic val prune_params_tac: Proof.context -> tactic val fold_rule: Proof.context -> thm list -> thm -> thm val fold_goals_tac: Proof.context -> thm list -> tactic val norm_hhf: Proof.context -> thm -> thm val norm_hhf_protect: Proof.context -> thm -> thm end; signature RAW_SIMPLIFIER = sig include BASIC_RAW_SIMPLIFIER exception SIMPLIFIER of string * thm list type trace_ops val set_trace_ops: trace_ops -> theory -> theory val internal_ss: simpset -> {congs: (cong_name * thm) list * cong_name list, procs: proc Net.net, mk_rews: {mk: Proof.context -> thm -> thm list, mk_cong: Proof.context -> thm -> thm, mk_sym: Proof.context -> thm -> thm option, mk_eq_True: Proof.context -> thm -> thm option, reorient: Proof.context -> term list -> term -> term -> bool}, term_ord: term ord, subgoal_tac: Proof.context -> int -> tactic, loop_tacs: (string * (Proof.context -> int -> tactic)) list, solvers: solver list * solver list} val map_ss: (Proof.context -> Proof.context) -> Context.generic -> Context.generic val prems_of: Proof.context -> thm list val add_simp: thm -> Proof.context -> Proof.context val del_simp: thm -> Proof.context -> Proof.context val flip_simp: thm -> Proof.context -> Proof.context val init_simpset: thm list -> Proof.context -> Proof.context val add_eqcong: thm -> Proof.context -> Proof.context val del_eqcong: thm -> Proof.context -> Proof.context val add_cong: thm -> Proof.context -> Proof.context val del_cong: thm -> Proof.context -> Proof.context val mksimps: Proof.context -> thm -> thm list val set_mksimps: (Proof.context -> thm -> thm list) -> Proof.context -> Proof.context val set_mkcong: (Proof.context -> thm -> thm) -> Proof.context -> Proof.context val set_mksym: (Proof.context -> thm -> thm option) -> Proof.context -> Proof.context val set_mkeqTrue: (Proof.context -> thm -> thm option) -> Proof.context -> Proof.context val set_term_ord: term ord -> Proof.context -> Proof.context val set_subgoaler: (Proof.context -> int -> tactic) -> Proof.context -> Proof.context val solver: Proof.context -> solver -> int -> tactic val default_mk_sym: Proof.context -> thm -> thm option val add_prems: thm list -> Proof.context -> Proof.context val set_reorient: (Proof.context -> term list -> term -> term -> bool) -> Proof.context -> Proof.context val set_solvers: solver list -> Proof.context -> Proof.context val rewrite_cterm: bool * bool * bool -> (Proof.context -> thm -> thm option) -> Proof.context -> conv val rewrite_term: theory -> thm list -> (term -> term option) list -> term -> term val rewrite_thm: bool * bool * bool -> (Proof.context -> thm -> thm option) -> Proof.context -> thm -> thm val generic_rewrite_goal_tac: bool * bool * bool -> (Proof.context -> tactic) -> Proof.context -> int -> tactic val rewrite: Proof.context -> bool -> thm list -> conv end; structure Raw_Simplifier: RAW_SIMPLIFIER = struct (** datatype simpset **) (* congruence rules *) type cong_name = bool * string; fun cong_name (Const (a, _)) = SOME (true, a) | cong_name (Free (a, _)) = SOME (false, a) | cong_name _ = NONE; (* rewrite rules *) type rrule = {thm: thm, (*the rewrite rule*) name: string, (*name of theorem from which rewrite rule was extracted*) lhs: term, (*the left-hand side*) elhs: cterm, (*the eta-contracted lhs*) extra: bool, (*extra variables outside of elhs*) fo: bool, (*use first-order matching*) perm: bool}; (*the rewrite rule is permutative*) fun trim_context_rrule ({thm, name, lhs, elhs, extra, fo, perm}: rrule) = {thm = Thm.trim_context thm, name = name, lhs = lhs, elhs = Thm.trim_context_cterm elhs, extra = extra, fo = fo, perm = perm}; (* Remarks: - elhs is used for matching, lhs only for preservation of bound variable names; - fo is set iff either elhs is first-order (no Var is applied), in which case fo-matching is complete, or elhs is not a pattern, in which case there is nothing better to do; *) fun eq_rrule ({thm = thm1, ...}: rrule, {thm = thm2, ...}: rrule) = Thm.eq_thm_prop (thm1, thm2); (* FIXME: it seems that the conditions on extra variables are too liberal if prems are nonempty: does solving the prems really guarantee instantiation of all its Vars? Better: a dynamic check each time a rule is applied. *) fun rewrite_rule_extra_vars prems elhs erhs = let val elhss = elhs :: prems; val tvars = fold Term.add_tvars elhss []; val vars = fold Term.add_vars elhss []; in erhs |> Term.exists_type (Term.exists_subtype (fn TVar v => not (member (op =) tvars v) | _ => false)) orelse erhs |> Term.exists_subterm (fn Var v => not (member (op =) vars v) | _ => false) end; fun rrule_extra_vars elhs thm = rewrite_rule_extra_vars [] (Thm.term_of elhs) (Thm.full_prop_of thm); fun mk_rrule2 {thm, name, lhs, elhs, perm} = let val t = Thm.term_of elhs; val fo = Pattern.first_order t orelse not (Pattern.pattern t); val extra = rrule_extra_vars elhs thm; in {thm = thm, name = name, lhs = lhs, elhs = elhs, extra = extra, fo = fo, perm = perm} end; (*simple test for looping rewrite rules and stupid orientations*) fun default_reorient ctxt prems lhs rhs = rewrite_rule_extra_vars prems lhs rhs orelse is_Var (head_of lhs) orelse (* turns t = x around, which causes a headache if x is a local variable - usually it is very useful :-( is_Free rhs andalso not(is_Free lhs) andalso not(Logic.occs(rhs,lhs)) andalso not(exists_subterm is_Var lhs) orelse *) exists (fn t => Logic.occs (lhs, t)) (rhs :: prems) orelse null prems andalso Pattern.matches (Proof_Context.theory_of ctxt) (lhs, rhs) (*the condition "null prems" is necessary because conditional rewrites with extra variables in the conditions may terminate although the rhs is an instance of the lhs; example: ?m < ?n \ f ?n \ f ?m *) orelse is_Const lhs andalso not (is_Const rhs); (* simplification procedures *) datatype proc = Proc of {name: string, lhs: term, proc: Proof.context -> cterm -> thm option, stamp: stamp}; fun eq_proc (Proc {stamp = stamp1, ...}, Proc {stamp = stamp2, ...}) = stamp1 = stamp2; (* solvers *) datatype solver = Solver of {name: string, solver: Proof.context -> int -> tactic, id: stamp}; fun mk_solver name solver = Solver {name = name, solver = solver, id = stamp ()}; fun solver_name (Solver {name, ...}) = name; fun solver ctxt (Solver {solver = tac, ...}) = tac ctxt; fun eq_solver (Solver {id = id1, ...}, Solver {id = id2, ...}) = (id1 = id2); (* simplification sets *) (*A simpset contains data required during conversion: rules: discrimination net of rewrite rules; prems: current premises; depth: simp_depth and exceeded flag; congs: association list of congruence rules and a list of `weak' congruence constants. A congruence is `weak' if it avoids normalization of some argument. procs: discrimination net of simplification procedures (functions that prove rewrite rules on the fly); mk_rews: mk: turn simplification thms into rewrite rules; mk_cong: prepare congruence rules; mk_sym: turn \ around; mk_eq_True: turn P into P \ True; term_ord: for ordered rewriting;*) datatype simpset = Simpset of {rules: rrule Net.net, prems: thm list, depth: int * bool Unsynchronized.ref} * {congs: (cong_name * thm) list * cong_name list, procs: proc Net.net, mk_rews: {mk: Proof.context -> thm -> thm list, mk_cong: Proof.context -> thm -> thm, mk_sym: Proof.context -> thm -> thm option, mk_eq_True: Proof.context -> thm -> thm option, reorient: Proof.context -> term list -> term -> term -> bool}, term_ord: term ord, subgoal_tac: Proof.context -> int -> tactic, loop_tacs: (string * (Proof.context -> int -> tactic)) list, solvers: solver list * solver list}; fun internal_ss (Simpset (_, ss2)) = ss2; fun make_ss1 (rules, prems, depth) = {rules = rules, prems = prems, depth = depth}; fun map_ss1 f {rules, prems, depth} = make_ss1 (f (rules, prems, depth)); fun make_ss2 (congs, procs, mk_rews, term_ord, subgoal_tac, loop_tacs, solvers) = {congs = congs, procs = procs, mk_rews = mk_rews, term_ord = term_ord, subgoal_tac = subgoal_tac, loop_tacs = loop_tacs, solvers = solvers}; fun map_ss2 f {congs, procs, mk_rews, term_ord, subgoal_tac, loop_tacs, solvers} = make_ss2 (f (congs, procs, mk_rews, term_ord, subgoal_tac, loop_tacs, solvers)); fun make_simpset (args1, args2) = Simpset (make_ss1 args1, make_ss2 args2); fun dest_ss (Simpset ({rules, ...}, {congs, procs, loop_tacs, solvers, ...})) = {simps = Net.entries rules |> map (fn {name, thm, ...} => (name, thm)), procs = Net.entries procs |> map (fn Proc {name, lhs, stamp, ...} => ((name, lhs), stamp)) |> partition_eq (eq_snd op =) |> map (fn ps => (fst (fst (hd ps)), map (snd o fst) ps)), congs = #1 congs, weak_congs = #2 congs, loopers = map fst loop_tacs, unsafe_solvers = map solver_name (#1 solvers), safe_solvers = map solver_name (#2 solvers)}; (* empty *) fun init_ss depth mk_rews term_ord subgoal_tac solvers = make_simpset ((Net.empty, [], depth), (([], []), Net.empty, mk_rews, term_ord, subgoal_tac, [], solvers)); fun default_mk_sym _ th = SOME (th RS Drule.symmetric_thm); val empty_ss = init_ss (0, Unsynchronized.ref false) {mk = fn _ => fn th => if can Logic.dest_equals (Thm.concl_of th) then [th] else [], mk_cong = K I, mk_sym = default_mk_sym, mk_eq_True = K (K NONE), reorient = default_reorient} Term_Ord.term_ord (K (K no_tac)) ([], []); (* merge *) (*NOTE: ignores some fields of 2nd simpset*) fun merge_ss (ss1, ss2) = if pointer_eq (ss1, ss2) then ss1 else let val Simpset ({rules = rules1, prems = prems1, depth = depth1}, {congs = (congs1, weak1), procs = procs1, mk_rews, term_ord, subgoal_tac, loop_tacs = loop_tacs1, solvers = (unsafe_solvers1, solvers1)}) = ss1; val Simpset ({rules = rules2, prems = prems2, depth = depth2}, {congs = (congs2, weak2), procs = procs2, mk_rews = _, term_ord = _, subgoal_tac = _, loop_tacs = loop_tacs2, solvers = (unsafe_solvers2, solvers2)}) = ss2; val rules' = Net.merge eq_rrule (rules1, rules2); val prems' = Thm.merge_thms (prems1, prems2); val depth' = if #1 depth1 < #1 depth2 then depth2 else depth1; val congs' = merge (Thm.eq_thm_prop o apply2 #2) (congs1, congs2); val weak' = merge (op =) (weak1, weak2); val procs' = Net.merge eq_proc (procs1, procs2); val loop_tacs' = AList.merge (op =) (K true) (loop_tacs1, loop_tacs2); val unsafe_solvers' = merge eq_solver (unsafe_solvers1, unsafe_solvers2); val solvers' = merge eq_solver (solvers1, solvers2); in make_simpset ((rules', prems', depth'), ((congs', weak'), procs', mk_rews, term_ord, subgoal_tac, loop_tacs', (unsafe_solvers', solvers'))) end; (** context data **) structure Simpset = Generic_Data ( type T = simpset; val empty = empty_ss; val extend = I; val merge = merge_ss; ); val simpset_of = Simpset.get o Context.Proof; fun map_simpset f = Context.proof_map (Simpset.map f); fun map_simpset1 f = map_simpset (fn Simpset (ss1, ss2) => Simpset (map_ss1 f ss1, ss2)); fun map_simpset2 f = map_simpset (fn Simpset (ss1, ss2) => Simpset (ss1, map_ss2 f ss2)); fun simpset_map ctxt f ss = ctxt |> map_simpset (K ss) |> f |> Context.Proof |> Simpset.get; fun put_simpset ss = map_simpset (K ss); val empty_simpset = put_simpset empty_ss; fun map_theory_simpset f thy = let val ctxt' = f (Proof_Context.init_global thy); val thy' = Proof_Context.theory_of ctxt'; in Context.theory_map (Simpset.map (K (simpset_of ctxt'))) thy' end; fun map_ss f = Context.mapping (map_theory_simpset (f o Context_Position.not_really)) f; val clear_simpset = map_simpset (fn Simpset ({depth, ...}, {mk_rews, term_ord, subgoal_tac, solvers, ...}) => init_ss depth mk_rews term_ord subgoal_tac solvers); (* simp depth *) (* The simp_depth_limit is meant to abort infinite recursion of the simplifier early but should not terminate "normal" executions. As of 2017, 25 would suffice; 40 builds in a safety margin. *) val simp_depth_limit = Config.declare_int ("simp_depth_limit", \<^here>) (K 40); val simp_trace_depth_limit = Config.declare_int ("simp_trace_depth_limit", \<^here>) (K 1); fun inc_simp_depth ctxt = ctxt |> map_simpset1 (fn (rules, prems, (depth, exceeded)) => (rules, prems, (depth + 1, if depth = Config.get ctxt simp_trace_depth_limit then Unsynchronized.ref false else exceeded))); fun simp_depth ctxt = let val Simpset ({depth = (depth, _), ...}, _) = simpset_of ctxt in depth end; (* diagnostics *) exception SIMPLIFIER of string * thm list; val simp_debug = Config.declare_bool ("simp_debug", \<^here>) (K false); val simp_trace = Config.declare_bool ("simp_trace", \<^here>) (K false); fun cond_warning ctxt msg = if Context_Position.is_really_visible ctxt then warning (msg ()) else (); fun cond_tracing' ctxt flag msg = if Config.get ctxt flag then let val Simpset ({depth = (depth, exceeded), ...}, _) = simpset_of ctxt; val depth_limit = Config.get ctxt simp_trace_depth_limit; in if depth > depth_limit then if ! exceeded then () else (tracing "simp_trace_depth_limit exceeded!"; exceeded := true) else (tracing (enclose "[" "]" (string_of_int depth) ^ msg ()); exceeded := false) end else (); fun cond_tracing ctxt = cond_tracing' ctxt simp_trace; fun print_term ctxt s t = s ^ "\n" ^ Syntax.string_of_term ctxt t; fun print_thm ctxt s (name, th) = print_term ctxt (if name = "" then s else s ^ " " ^ quote name ^ ":") (Thm.full_prop_of th); (** simpset operations **) (* prems *) fun prems_of ctxt = let val Simpset ({prems, ...}, _) = simpset_of ctxt in prems end; fun add_prems ths = map_simpset1 (fn (rules, prems, depth) => (rules, ths @ prems, depth)); (* maintain simp rules *) fun del_rrule loud (rrule as {thm, elhs, ...}) ctxt = ctxt |> map_simpset1 (fn (rules, prems, depth) => (Net.delete_term eq_rrule (Thm.term_of elhs, rrule) rules, prems, depth)) handle Net.DELETE => (if not loud then () else cond_warning ctxt (fn () => print_thm ctxt "Rewrite rule not in simpset:" ("", thm)); ctxt); fun insert_rrule (rrule as {thm, name, ...}) ctxt = (cond_tracing ctxt (fn () => print_thm ctxt "Adding rewrite rule" (name, thm)); ctxt |> map_simpset1 (fn (rules, prems, depth) => let val rrule2 as {elhs, ...} = mk_rrule2 rrule; val rules' = Net.insert_term eq_rrule (Thm.term_of elhs, trim_context_rrule rrule2) rules; in (rules', prems, depth) end) handle Net.INSERT => (cond_warning ctxt (fn () => print_thm ctxt "Ignoring duplicate rewrite rule:" ("", thm)); ctxt)); local fun vperm (Var _, Var _) = true | vperm (Abs (_, _, s), Abs (_, _, t)) = vperm (s, t) | vperm (t1 $ t2, u1 $ u2) = vperm (t1, u1) andalso vperm (t2, u2) | vperm (t, u) = (t = u); fun var_perm (t, u) = vperm (t, u) andalso eq_set (op =) (Term.add_vars t [], Term.add_vars u []); in fun decomp_simp thm = let val prop = Thm.prop_of thm; val prems = Logic.strip_imp_prems prop; val concl = Drule.strip_imp_concl (Thm.cprop_of thm); val (lhs, rhs) = Thm.dest_equals concl handle TERM _ => raise SIMPLIFIER ("Rewrite rule not a meta-equality", [thm]); val elhs = Thm.dest_arg (Thm.cprop_of (Thm.eta_conversion lhs)); val erhs = Envir.eta_contract (Thm.term_of rhs); val perm = var_perm (Thm.term_of elhs, erhs) andalso not (Thm.term_of elhs aconv erhs) andalso not (is_Var (Thm.term_of elhs)); in (prems, Thm.term_of lhs, elhs, Thm.term_of rhs, perm) end; end; fun decomp_simp' thm = let val (_, lhs, _, rhs, _) = decomp_simp thm in if Thm.nprems_of thm > 0 then raise SIMPLIFIER ("Bad conditional rewrite rule", [thm]) else (lhs, rhs) end; fun mk_eq_True ctxt (thm, name) = let val Simpset (_, {mk_rews = {mk_eq_True, ...}, ...}) = simpset_of ctxt in (case mk_eq_True ctxt thm of NONE => [] | SOME eq_True => let val (_, lhs, elhs, _, _) = decomp_simp eq_True; in [{thm = eq_True, name = name, lhs = lhs, elhs = elhs, perm = false}] end) end; (*create the rewrite rule and possibly also the eq_True variant, in case there are extra vars on the rhs*) fun rrule_eq_True ctxt thm name lhs elhs rhs thm2 = let val rrule = {thm = thm, name = name, lhs = lhs, elhs = elhs, perm = false} in if rewrite_rule_extra_vars [] lhs rhs then mk_eq_True ctxt (thm2, name) @ [rrule] else [rrule] end; fun mk_rrule ctxt (thm, name) = let val (prems, lhs, elhs, rhs, perm) = decomp_simp thm in if perm then [{thm = thm, name = name, lhs = lhs, elhs = elhs, perm = true}] else (*weak test for loops*) if rewrite_rule_extra_vars prems lhs rhs orelse is_Var (Thm.term_of elhs) then mk_eq_True ctxt (thm, name) else rrule_eq_True ctxt thm name lhs elhs rhs thm end |> map (fn {thm, name, lhs, elhs, perm} => {thm = Thm.trim_context thm, name = name, lhs = lhs, elhs = Thm.trim_context_cterm elhs, perm = perm}); fun orient_rrule ctxt (thm, name) = let val (prems, lhs, elhs, rhs, perm) = decomp_simp thm; val Simpset (_, {mk_rews = {reorient, mk_sym, ...}, ...}) = simpset_of ctxt; in if perm then [{thm = thm, name = name, lhs = lhs, elhs = elhs, perm = true}] else if reorient ctxt prems lhs rhs then if reorient ctxt prems rhs lhs then mk_eq_True ctxt (thm, name) else (case mk_sym ctxt thm of NONE => [] | SOME thm' => let val (_, lhs', elhs', rhs', _) = decomp_simp thm' in rrule_eq_True ctxt thm' name lhs' elhs' rhs' thm end) else rrule_eq_True ctxt thm name lhs elhs rhs thm end; fun extract_rews ctxt sym thms = let val Simpset (_, {mk_rews = {mk, ...}, ...}) = simpset_of ctxt; val mk = if sym then fn ctxt => fn th => (mk ctxt th) RL [Drule.symmetric_thm] else mk in maps (fn thm => map (rpair (Thm.get_name_hint thm)) (mk ctxt thm)) thms end; fun extract_safe_rrules ctxt thm = maps (orient_rrule ctxt) (extract_rews ctxt false [thm]); fun mk_rrules ctxt thms = let val rews = extract_rews ctxt false thms val raw_rrules = flat (map (mk_rrule ctxt) rews) in map mk_rrule2 raw_rrules end (* add/del rules explicitly *) local fun comb_simps ctxt comb mk_rrule sym thms = let val rews = extract_rews ctxt sym (map (Thm.transfer' ctxt) thms); in fold (fold comb o mk_rrule) rews ctxt end; (* This code checks if the symetric version of a rule is already in the simpset. However, the variable names in the two versions of the rule may differ. Thus the current test modulo eq_rrule is too weak to be useful and needs to be refined. fun present ctxt rules (rrule as {thm, elhs, ...}) = (Net.insert_term eq_rrule (Thm.term_of elhs, trim_context_rrule rrule) rules; false) handle Net.INSERT => (cond_warning ctxt (fn () => print_thm ctxt "Symmetric rewrite rule already in simpset:" ("", thm)); true); fun sym_present ctxt thms = let val rews = extract_rews ctxt true (map (Thm.transfer' ctxt) thms); val rrules = map mk_rrule2 (flat(map (mk_rrule ctxt) rews)) val Simpset({rules, ...},_) = simpset_of ctxt in exists (present ctxt rules) rrules end *) in fun ctxt addsimps thms = comb_simps ctxt insert_rrule (mk_rrule ctxt) false thms; fun addsymsimps ctxt thms = comb_simps ctxt insert_rrule (mk_rrule ctxt) true thms; fun ctxt delsimps thms = comb_simps ctxt (del_rrule true) (map mk_rrule2 o mk_rrule ctxt) false thms; fun delsimps_quiet ctxt thms = comb_simps ctxt (del_rrule false) (map mk_rrule2 o mk_rrule ctxt) false thms; fun add_simp thm ctxt = ctxt addsimps [thm]; (* with check for presence of symmetric version: if sym_present ctxt [thm] then (cond_warning ctxt (fn () => print_thm ctxt "Ignoring rewrite rule:" ("", thm)); ctxt) else ctxt addsimps [thm]; *) fun del_simp thm ctxt = ctxt delsimps [thm]; fun flip_simp thm ctxt = addsymsimps (delsimps_quiet ctxt [thm]) [thm]; end; fun init_simpset thms ctxt = ctxt |> Context_Position.set_visible false |> empty_simpset |> fold add_simp thms |> Context_Position.restore_visible ctxt; (* congs *) local fun is_full_cong_prems [] [] = true | is_full_cong_prems [] _ = false | is_full_cong_prems (p :: prems) varpairs = (case Logic.strip_assums_concl p of Const ("Pure.eq", _) $ lhs $ rhs => let val (x, xs) = strip_comb lhs and (y, ys) = strip_comb rhs in is_Var x andalso forall is_Bound xs andalso not (has_duplicates (op =) xs) andalso xs = ys andalso member (op =) varpairs (x, y) andalso is_full_cong_prems prems (remove (op =) (x, y) varpairs) end | _ => false); fun is_full_cong thm = let val prems = Thm.prems_of thm and concl = Thm.concl_of thm; val (lhs, rhs) = Logic.dest_equals concl; val (f, xs) = strip_comb lhs and (g, ys) = strip_comb rhs; in f = g andalso not (has_duplicates (op =) (xs @ ys)) andalso length xs = length ys andalso is_full_cong_prems prems (xs ~~ ys) end; fun mk_cong ctxt = let val Simpset (_, {mk_rews = {mk_cong = f, ...}, ...}) = simpset_of ctxt in f ctxt end; in fun add_eqcong thm ctxt = ctxt |> map_simpset2 (fn (congs, procs, mk_rews, term_ord, subgoal_tac, loop_tacs, solvers) => let val (lhs, _) = Logic.dest_equals (Thm.concl_of thm) handle TERM _ => raise SIMPLIFIER ("Congruence not a meta-equality", [thm]); (*val lhs = Envir.eta_contract lhs;*) val a = the (cong_name (head_of lhs)) handle Option.Option => raise SIMPLIFIER ("Congruence must start with a constant or free variable", [thm]); val (xs, weak) = congs; val xs' = AList.update (op =) (a, Thm.trim_context thm) xs; val weak' = if is_full_cong thm then weak else a :: weak; in ((xs', weak'), procs, mk_rews, term_ord, subgoal_tac, loop_tacs, solvers) end); fun del_eqcong thm ctxt = ctxt |> map_simpset2 (fn (congs, procs, mk_rews, term_ord, subgoal_tac, loop_tacs, solvers) => let val (lhs, _) = Logic.dest_equals (Thm.concl_of thm) handle TERM _ => raise SIMPLIFIER ("Congruence not a meta-equality", [thm]); (*val lhs = Envir.eta_contract lhs;*) val a = the (cong_name (head_of lhs)) handle Option.Option => raise SIMPLIFIER ("Congruence must start with a constant", [thm]); val (xs, _) = congs; val xs' = filter_out (fn (x : cong_name, _) => x = a) xs; val weak' = xs' |> map_filter (fn (a, th) => if is_full_cong th then NONE else SOME a); in ((xs', weak'), procs, mk_rews, term_ord, subgoal_tac, loop_tacs, solvers) end); fun add_cong thm ctxt = add_eqcong (mk_cong ctxt thm) ctxt; fun del_cong thm ctxt = del_eqcong (mk_cong ctxt thm) ctxt; end; (* simprocs *) datatype simproc = Simproc of {name: string, lhss: term list, proc: morphism -> Proof.context -> cterm -> thm option, stamp: stamp}; fun eq_simproc (Simproc {stamp = stamp1, ...}, Simproc {stamp = stamp2, ...}) = stamp1 = stamp2; fun cert_simproc thy name {lhss, proc} = Simproc {name = name, lhss = map (Sign.cert_term thy) lhss, proc = proc, stamp = stamp ()}; fun transform_simproc phi (Simproc {name, lhss, proc, stamp}) = Simproc {name = name, lhss = map (Morphism.term phi) lhss, proc = Morphism.transform phi proc, stamp = stamp}; local fun add_proc (proc as Proc {name, lhs, ...}) ctxt = (cond_tracing ctxt (fn () => print_term ctxt ("Adding simplification procedure " ^ quote name ^ " for") lhs); ctxt |> map_simpset2 (fn (congs, procs, mk_rews, term_ord, subgoal_tac, loop_tacs, solvers) => (congs, Net.insert_term eq_proc (lhs, proc) procs, mk_rews, term_ord, subgoal_tac, loop_tacs, solvers)) handle Net.INSERT => (cond_warning ctxt (fn () => "Ignoring duplicate simplification procedure " ^ quote name); ctxt)); fun del_proc (proc as Proc {name, lhs, ...}) ctxt = ctxt |> map_simpset2 (fn (congs, procs, mk_rews, term_ord, subgoal_tac, loop_tacs, solvers) => (congs, Net.delete_term eq_proc (lhs, proc) procs, mk_rews, term_ord, subgoal_tac, loop_tacs, solvers)) handle Net.DELETE => (cond_warning ctxt (fn () => "Simplification procedure " ^ quote name ^ " not in simpset"); ctxt); fun prep_procs (Simproc {name, lhss, proc, stamp}) = lhss |> map (fn lhs => Proc {name = name, lhs = lhs, proc = Morphism.form proc, stamp = stamp}); in fun ctxt addsimprocs ps = fold (fold add_proc o prep_procs) ps ctxt; fun ctxt delsimprocs ps = fold (fold del_proc o prep_procs) ps ctxt; end; (* mk_rews *) local fun map_mk_rews f = map_simpset2 (fn (congs, procs, mk_rews, term_ord, subgoal_tac, loop_tacs, solvers) => let val {mk, mk_cong, mk_sym, mk_eq_True, reorient} = mk_rews; val (mk', mk_cong', mk_sym', mk_eq_True', reorient') = f (mk, mk_cong, mk_sym, mk_eq_True, reorient); val mk_rews' = {mk = mk', mk_cong = mk_cong', mk_sym = mk_sym', mk_eq_True = mk_eq_True', reorient = reorient'}; in (congs, procs, mk_rews', term_ord, subgoal_tac, loop_tacs, solvers) end); in fun mksimps ctxt = let val Simpset (_, {mk_rews = {mk, ...}, ...}) = simpset_of ctxt in mk ctxt end; fun set_mksimps mk = map_mk_rews (fn (_, mk_cong, mk_sym, mk_eq_True, reorient) => (mk, mk_cong, mk_sym, mk_eq_True, reorient)); fun set_mkcong mk_cong = map_mk_rews (fn (mk, _, mk_sym, mk_eq_True, reorient) => (mk, mk_cong, mk_sym, mk_eq_True, reorient)); fun set_mksym mk_sym = map_mk_rews (fn (mk, mk_cong, _, mk_eq_True, reorient) => (mk, mk_cong, mk_sym, mk_eq_True, reorient)); fun set_mkeqTrue mk_eq_True = map_mk_rews (fn (mk, mk_cong, mk_sym, _, reorient) => (mk, mk_cong, mk_sym, mk_eq_True, reorient)); fun set_reorient reorient = map_mk_rews (fn (mk, mk_cong, mk_sym, mk_eq_True, _) => (mk, mk_cong, mk_sym, mk_eq_True, reorient)); end; (* term_ord *) fun set_term_ord term_ord = map_simpset2 (fn (congs, procs, mk_rews, _, subgoal_tac, loop_tacs, solvers) => (congs, procs, mk_rews, term_ord, subgoal_tac, loop_tacs, solvers)); (* tactics *) fun set_subgoaler subgoal_tac = map_simpset2 (fn (congs, procs, mk_rews, term_ord, _, loop_tacs, solvers) => (congs, procs, mk_rews, term_ord, subgoal_tac, loop_tacs, solvers)); fun ctxt setloop tac = ctxt |> map_simpset2 (fn (congs, procs, mk_rews, term_ord, subgoal_tac, _, solvers) => (congs, procs, mk_rews, term_ord, subgoal_tac, [("", tac)], solvers)); fun ctxt addloop (name, tac) = ctxt |> map_simpset2 (fn (congs, procs, mk_rews, term_ord, subgoal_tac, loop_tacs, solvers) => (congs, procs, mk_rews, term_ord, subgoal_tac, AList.update (op =) (name, tac) loop_tacs, solvers)); fun ctxt delloop name = ctxt |> map_simpset2 (fn (congs, procs, mk_rews, term_ord, subgoal_tac, loop_tacs, solvers) => (congs, procs, mk_rews, term_ord, subgoal_tac, (if AList.defined (op =) loop_tacs name then () else cond_warning ctxt (fn () => "No such looper in simpset: " ^ quote name); AList.delete (op =) name loop_tacs), solvers)); fun ctxt setSSolver solver = ctxt |> map_simpset2 (fn (congs, procs, mk_rews, term_ord, subgoal_tac, loop_tacs, (unsafe_solvers, _)) => (congs, procs, mk_rews, term_ord, subgoal_tac, loop_tacs, (unsafe_solvers, [solver]))); fun ctxt addSSolver solver = ctxt |> map_simpset2 (fn (congs, procs, mk_rews, term_ord, subgoal_tac, loop_tacs, (unsafe_solvers, solvers)) => (congs, procs, mk_rews, term_ord, subgoal_tac, loop_tacs, (unsafe_solvers, insert eq_solver solver solvers))); fun ctxt setSolver solver = ctxt |> map_simpset2 (fn (congs, procs, mk_rews, term_ord, subgoal_tac, loop_tacs, (_, solvers)) => (congs, procs, mk_rews, term_ord, subgoal_tac, loop_tacs, ([solver], solvers))); fun ctxt addSolver solver = ctxt |> map_simpset2 (fn (congs, procs, mk_rews, term_ord, subgoal_tac, loop_tacs, (unsafe_solvers, solvers)) => (congs, procs, mk_rews, term_ord, subgoal_tac, loop_tacs, (insert eq_solver solver unsafe_solvers, solvers))); fun set_solvers solvers = map_simpset2 (fn (congs, procs, mk_rews, term_ord, subgoal_tac, loop_tacs, _) => (congs, procs, mk_rews, term_ord, subgoal_tac, loop_tacs, (solvers, solvers))); (* trace operations *) type trace_ops = {trace_invoke: {depth: int, term: term} -> Proof.context -> Proof.context, trace_apply: {unconditional: bool, term: term, thm: thm, rrule: rrule} -> Proof.context -> (Proof.context -> (thm * term) option) -> (thm * term) option}; structure Trace_Ops = Theory_Data ( type T = trace_ops; val empty: T = {trace_invoke = fn _ => fn ctxt => ctxt, trace_apply = fn _ => fn ctxt => fn cont => cont ctxt}; val extend = I; fun merge (trace_ops, _) = trace_ops; ); val set_trace_ops = Trace_Ops.put; val trace_ops = Trace_Ops.get o Proof_Context.theory_of; fun trace_invoke args ctxt = #trace_invoke (trace_ops ctxt) args ctxt; fun trace_apply args ctxt = #trace_apply (trace_ops ctxt) args ctxt; (** rewriting **) (* Uses conversions, see: L C Paulson, A higher-order implementation of rewriting, Science of Computer Programming 3 (1983), pages 119-149. *) fun check_conv ctxt msg thm thm' = let val thm'' = Thm.transitive thm thm' handle THM _ => let val nthm' = Thm.transitive (Thm.symmetric (Drule.beta_eta_conversion (Thm.lhs_of thm'))) thm' in Thm.transitive thm nthm' handle THM _ => let val nthm = Thm.transitive thm (Drule.beta_eta_conversion (Thm.rhs_of thm)) in Thm.transitive nthm nthm' end end val _ = if msg then cond_tracing ctxt (fn () => print_thm ctxt "SUCCEEDED" ("", thm')) else (); in SOME thm'' end handle THM _ => let val _ $ _ $ prop0 = Thm.prop_of thm; val _ = cond_tracing ctxt (fn () => print_thm ctxt "Proved wrong theorem (bad subgoaler?)" ("", thm') ^ "\n" ^ print_term ctxt "Should have proved:" prop0); in NONE end; (* mk_procrule *) fun mk_procrule ctxt thm = let val (prems, lhs, elhs, rhs, _) = decomp_simp thm val thm' = Thm.close_derivation \<^here> thm; in if rewrite_rule_extra_vars prems lhs rhs then (cond_warning ctxt (fn () => print_thm ctxt "Extra vars on rhs:" ("", thm)); []) else [mk_rrule2 {thm = thm', name = "", lhs = lhs, elhs = elhs, perm = false}] end; (* rewritec: conversion to apply the meta simpset to a term *) (*Since the rewriting strategy is bottom-up, we avoid re-normalizing already normalized terms by carrying around the rhs of the rewrite rule just applied. This is called the `skeleton'. It is decomposed in parallel with the term. Once a Var is encountered, the corresponding term is already in normal form. skel0 is a dummy skeleton that is to enforce complete normalization.*) val skel0 = Bound 0; (*Use rhs as skeleton only if the lhs does not contain unnormalized bits. The latter may happen iff there are weak congruence rules for constants in the lhs.*) fun uncond_skel ((_, weak), (lhs, rhs)) = if null weak then rhs (*optimization*) else if exists_subterm (fn Const (a, _) => member (op =) weak (true, a) | Free (a, _) => member (op =) weak (false, a) | _ => false) lhs then skel0 else rhs; (*Behaves like unconditional rule if rhs does not contain vars not in the lhs. Otherwise those vars may become instantiated with unnormalized terms while the premises are solved.*) fun cond_skel (args as (_, (lhs, rhs))) = if subset (op =) (Term.add_vars rhs [], Term.add_vars lhs []) then uncond_skel args else skel0; (* Rewriting -- we try in order: (1) beta reduction (2) unconditional rewrite rules (3) conditional rewrite rules (4) simplification procedures IMPORTANT: rewrite rules must not introduce new Vars or TVars! *) fun rewritec (prover, maxt) ctxt t = let val thy = Proof_Context.theory_of ctxt; val Simpset ({rules, ...}, {congs, procs, term_ord, ...}) = simpset_of ctxt; val eta_thm = Thm.eta_conversion t; val eta_t' = Thm.rhs_of eta_thm; val eta_t = Thm.term_of eta_t'; fun rew rrule = let val {thm = thm0, name, lhs, elhs = elhs0, extra, fo, perm} = rrule; val thm = Thm.transfer thy thm0; val elhs = Thm.transfer_cterm thy elhs0; val prop = Thm.prop_of thm; val (rthm, elhs') = if maxt = ~1 orelse not extra then (thm, elhs) else (Thm.incr_indexes (maxt + 1) thm, Thm.incr_indexes_cterm (maxt + 1) elhs); val insts = if fo then Thm.first_order_match (elhs', eta_t') else Thm.match (elhs', eta_t'); val thm' = Thm.instantiate insts (Thm.rename_boundvars lhs eta_t rthm); val prop' = Thm.prop_of thm'; val unconditional = (Logic.count_prems prop' = 0); val (lhs', rhs') = Logic.dest_equals (Logic.strip_imp_concl prop'); val trace_args = {unconditional = unconditional, term = eta_t, thm = thm', rrule = rrule}; in if perm andalso is_greater_equal (term_ord (rhs', lhs')) then (cond_tracing ctxt (fn () => print_thm ctxt "Cannot apply permutative rewrite rule" (name, thm) ^ "\n" ^ print_thm ctxt "Term does not become smaller:" ("", thm')); NONE) else (cond_tracing ctxt (fn () => print_thm ctxt "Applying instance of rewrite rule" (name, thm)); if unconditional then (cond_tracing ctxt (fn () => print_thm ctxt "Rewriting:" ("", thm')); trace_apply trace_args ctxt (fn ctxt' => let val lr = Logic.dest_equals prop; val SOME thm'' = check_conv ctxt' false eta_thm thm'; in SOME (thm'', uncond_skel (congs, lr)) end)) else (cond_tracing ctxt (fn () => print_thm ctxt "Trying to rewrite:" ("", thm')); if simp_depth ctxt > Config.get ctxt simp_depth_limit then (cond_tracing ctxt (fn () => "simp_depth_limit exceeded - giving up"); NONE) else trace_apply trace_args ctxt (fn ctxt' => (case prover ctxt' thm' of NONE => (cond_tracing ctxt' (fn () => print_thm ctxt' "FAILED" ("", thm')); NONE) | SOME thm2 => (case check_conv ctxt' true eta_thm thm2 of NONE => NONE | SOME thm2' => let val concl = Logic.strip_imp_concl prop; val lr = Logic.dest_equals concl; in SOME (thm2', cond_skel (congs, lr)) end))))) end; fun rews [] = NONE | rews (rrule :: rrules) = let val opt = rew rrule handle Pattern.MATCH => NONE in (case opt of NONE => rews rrules | some => some) end; fun sort_rrules rrs = let fun is_simple ({thm, ...}: rrule) = (case Thm.prop_of thm of Const ("Pure.eq", _) $ _ $ _ => true | _ => false); fun sort [] (re1, re2) = re1 @ re2 | sort (rr :: rrs) (re1, re2) = if is_simple rr then sort rrs (rr :: re1, re2) else sort rrs (re1, rr :: re2); in sort rrs ([], []) end; fun proc_rews [] = NONE | proc_rews (Proc {name, proc, lhs, ...} :: ps) = if Pattern.matches (Proof_Context.theory_of ctxt) (lhs, Thm.term_of t) then (cond_tracing' ctxt simp_debug (fn () => print_term ctxt ("Trying procedure " ^ quote name ^ " on:") eta_t); (case proc ctxt eta_t' of NONE => (cond_tracing' ctxt simp_debug (fn () => "FAILED"); proc_rews ps) | SOME raw_thm => (cond_tracing ctxt (fn () => print_thm ctxt ("Procedure " ^ quote name ^ " produced rewrite rule:") ("", raw_thm)); (case rews (mk_procrule ctxt raw_thm) of NONE => (cond_tracing ctxt (fn () => print_term ctxt ("IGNORED result of simproc " ^ quote name ^ " -- does not match") (Thm.term_of t)); proc_rews ps) | some => some)))) else proc_rews ps; in (case eta_t of Abs _ $ _ => SOME (Thm.transitive eta_thm (Thm.beta_conversion false eta_t'), skel0) | _ => (case rews (sort_rrules (Net.match_term rules eta_t)) of NONE => proc_rews (Net.match_term procs eta_t) | some => some)) end; (* conversion to apply a congruence rule to a term *) fun congc prover ctxt maxt cong t = let val rthm = Thm.incr_indexes (maxt + 1) cong; val rlhs = fst (Thm.dest_equals (Drule.strip_imp_concl (Thm.cprop_of rthm))); val insts = Thm.match (rlhs, t) (* Thm.match can raise Pattern.MATCH; is handled when congc is called *) val thm' = Thm.instantiate insts (Thm.rename_boundvars (Thm.term_of rlhs) (Thm.term_of t) rthm); val _ = cond_tracing ctxt (fn () => print_thm ctxt "Applying congruence rule:" ("", thm')); fun err (msg, thm) = (cond_tracing ctxt (fn () => print_thm ctxt msg ("", thm)); NONE); in (case prover thm' of NONE => err ("Congruence proof failed. Could not prove", thm') | SOME thm2 => (case check_conv ctxt true (Drule.beta_eta_conversion t) thm2 of NONE => err ("Congruence proof failed. Should not have proved", thm2) | SOME thm2' => if op aconv (apply2 Thm.term_of (Thm.dest_equals (Thm.cprop_of thm2'))) then NONE else SOME thm2')) end; val vA = (("A", 0), propT); val vB = (("B", 0), propT); val vC = (("C", 0), propT); fun transitive1 NONE NONE = NONE | transitive1 (SOME thm1) NONE = SOME thm1 | transitive1 NONE (SOME thm2) = SOME thm2 | transitive1 (SOME thm1) (SOME thm2) = SOME (Thm.transitive thm1 thm2); fun transitive2 thm = transitive1 (SOME thm); fun transitive3 thm = transitive1 thm o SOME; fun bottomc ((simprem, useprem, mutsimp), prover, maxidx) = let fun botc skel ctxt t = if is_Var skel then NONE else (case subc skel ctxt t of some as SOME thm1 => (case rewritec (prover, maxidx) ctxt (Thm.rhs_of thm1) of SOME (thm2, skel2) => transitive2 (Thm.transitive thm1 thm2) (botc skel2 ctxt (Thm.rhs_of thm2)) | NONE => some) | NONE => (case rewritec (prover, maxidx) ctxt t of SOME (thm2, skel2) => transitive2 thm2 (botc skel2 ctxt (Thm.rhs_of thm2)) | NONE => NONE)) and try_botc ctxt t = (case botc skel0 ctxt t of SOME trec1 => trec1 | NONE => Thm.reflexive t) and subc skel ctxt t0 = let val Simpset (_, {congs, ...}) = simpset_of ctxt in (case Thm.term_of t0 of Abs (a, T, _) => let val (v, ctxt') = Variable.next_bound (a, T) ctxt; val b = #1 (Term.dest_Free v); val (v', t') = Thm.dest_abs (SOME b) t0; val b' = #1 (Term.dest_Free (Thm.term_of v')); val _ = if b <> b' then warning ("Bad Simplifier context: renamed bound variable " ^ quote b ^ " to " ^ quote b' ^ Position.here (Position.thread_data ())) else (); val skel' = (case skel of Abs (_, _, sk) => sk | _ => skel0); in (case botc skel' ctxt' t' of SOME thm => SOME (Thm.abstract_rule a v' thm) | NONE => NONE) end | t $ _ => (case t of Const ("Pure.imp", _) $ _ => impc t0 ctxt | Abs _ => let val thm = Thm.beta_conversion false t0 in (case subc skel0 ctxt (Thm.rhs_of thm) of NONE => SOME thm | SOME thm' => SOME (Thm.transitive thm thm')) end | _ => let fun appc () = let val (tskel, uskel) = (case skel of tskel $ uskel => (tskel, uskel) | _ => (skel0, skel0)); val (ct, cu) = Thm.dest_comb t0; in (case botc tskel ctxt ct of SOME thm1 => (case botc uskel ctxt cu of SOME thm2 => SOME (Thm.combination thm1 thm2) | NONE => SOME (Thm.combination thm1 (Thm.reflexive cu))) | NONE => (case botc uskel ctxt cu of SOME thm1 => SOME (Thm.combination (Thm.reflexive ct) thm1) | NONE => NONE)) end; val (h, ts) = strip_comb t; in (case cong_name h of SOME a => (case AList.lookup (op =) (fst congs) a of NONE => appc () | SOME cong => (*post processing: some partial applications h t1 ... tj, j <= length ts, may be a redex. Example: map (\x. x) = (\xs. xs) wrt map_cong*) (let val thm = congc (prover ctxt) ctxt maxidx cong t0; val t = the_default t0 (Option.map Thm.rhs_of thm); val (cl, cr) = Thm.dest_comb t val dVar = Var(("", 0), dummyT) val skel = list_comb (h, replicate (length ts) dVar) in (case botc skel ctxt cl of NONE => thm | SOME thm' => transitive3 thm (Thm.combination thm' (Thm.reflexive cr))) end handle Pattern.MATCH => appc ())) | _ => appc ()) end) | _ => NONE) end and impc ct ctxt = if mutsimp then mut_impc0 [] ct [] [] ctxt else nonmut_impc ct ctxt and rules_of_prem prem ctxt = if maxidx_of_term (Thm.term_of prem) <> ~1 then (cond_tracing ctxt (fn () => print_term ctxt "Cannot add premise as rewrite rule because it contains (type) unknowns:" (Thm.term_of prem)); (([], NONE), ctxt)) else let val (asm, ctxt') = Thm.assume_hyps prem ctxt in ((extract_safe_rrules ctxt' asm, SOME asm), ctxt') end and add_rrules (rrss, asms) ctxt = (fold o fold) insert_rrule rrss ctxt |> add_prems (map_filter I asms) and disch r prem eq = let val (lhs, rhs) = Thm.dest_equals (Thm.cprop_of eq); val eq' = Thm.implies_elim (Thm.instantiate ([], [(vA, prem), (vB, lhs), (vC, rhs)]) Drule.imp_cong) (Thm.implies_intr prem eq); in if not r then eq' else let val (prem', concl) = Thm.dest_implies lhs; val (prem'', _) = Thm.dest_implies rhs; in Thm.transitive (Thm.transitive (Thm.instantiate ([], [(vA, prem'), (vB, prem), (vC, concl)]) Drule.swap_prems_eq) eq') (Thm.instantiate ([], [(vA, prem), (vB, prem''), (vC, concl)]) Drule.swap_prems_eq) end end and rebuild [] _ _ _ _ eq = eq | rebuild (prem :: prems) concl (_ :: rrss) (_ :: asms) ctxt eq = let val ctxt' = add_rrules (rev rrss, rev asms) ctxt; val concl' = Drule.mk_implies (prem, the_default concl (Option.map Thm.rhs_of eq)); val dprem = Option.map (disch false prem); in (case rewritec (prover, maxidx) ctxt' concl' of NONE => rebuild prems concl' rrss asms ctxt (dprem eq) | SOME (eq', _) => transitive2 (fold (disch false) prems (the (transitive3 (dprem eq) eq'))) (mut_impc0 (rev prems) (Thm.rhs_of eq') (rev rrss) (rev asms) ctxt)) end and mut_impc0 prems concl rrss asms ctxt = let val prems' = strip_imp_prems concl; val ((rrss', asms'), ctxt') = fold_map rules_of_prem prems' ctxt |>> split_list; in mut_impc (prems @ prems') (strip_imp_concl concl) (rrss @ rrss') (asms @ asms') [] [] [] [] ctxt' ~1 ~1 end and mut_impc [] concl [] [] prems' rrss' asms' eqns ctxt changed k = transitive1 (fold (fn (eq1, prem) => fn eq2 => transitive1 eq1 (Option.map (disch false prem) eq2)) (eqns ~~ prems') NONE) (if changed > 0 then mut_impc (rev prems') concl (rev rrss') (rev asms') [] [] [] [] ctxt ~1 changed else rebuild prems' concl rrss' asms' ctxt (botc skel0 (add_rrules (rev rrss', rev asms') ctxt) concl)) | mut_impc (prem :: prems) concl (rrs :: rrss) (asm :: asms) prems' rrss' asms' eqns ctxt changed k = (case (if k = 0 then NONE else botc skel0 (add_rrules (rev rrss' @ rrss, rev asms' @ asms) ctxt) prem) of NONE => mut_impc prems concl rrss asms (prem :: prems') (rrs :: rrss') (asm :: asms') (NONE :: eqns) ctxt changed (if k = 0 then 0 else k - 1) | SOME eqn => let val prem' = Thm.rhs_of eqn; val tprems = map Thm.term_of prems; val i = 1 + fold Integer.max (map (fn p => find_index (fn q => q aconv p) tprems) (Thm.hyps_of eqn)) ~1; val ((rrs', asm'), ctxt') = rules_of_prem prem' ctxt; in mut_impc prems concl rrss asms (prem' :: prems') (rrs' :: rrss') (asm' :: asms') (SOME (fold_rev (disch true) (take i prems) (Drule.imp_cong_rule eqn (Thm.reflexive (Drule.list_implies (drop i prems, concl))))) :: eqns) ctxt' (length prems') ~1 end) (*legacy code -- only for backwards compatibility*) and nonmut_impc ct ctxt = let val (prem, conc) = Thm.dest_implies ct; val thm1 = if simprem then botc skel0 ctxt prem else NONE; val prem1 = the_default prem (Option.map Thm.rhs_of thm1); val ctxt1 = if not useprem then ctxt else let val ((rrs, asm), ctxt') = rules_of_prem prem1 ctxt in add_rrules ([rrs], [asm]) ctxt' end; in (case botc skel0 ctxt1 conc of NONE => (case thm1 of NONE => NONE | SOME thm1' => SOME (Drule.imp_cong_rule thm1' (Thm.reflexive conc))) | SOME thm2 => let val thm2' = disch false prem1 thm2 in (case thm1 of NONE => SOME thm2' | SOME thm1' => SOME (Thm.transitive (Drule.imp_cong_rule thm1' (Thm.reflexive conc)) thm2')) end) end; in try_botc end; (* Meta-rewriting: rewrites t to u and returns the theorem t \ u *) (* Parameters: mode = (simplify A, use A in simplifying B, use prems of B (if B is again a meta-impl.) to simplify A) when simplifying A \ B prover: how to solve premises in conditional rewrites and congruences *) fun rewrite_cterm mode prover raw_ctxt raw_ct = let val thy = Proof_Context.theory_of raw_ctxt; val ct = raw_ct |> Thm.transfer_cterm thy |> Thm.adjust_maxidx_cterm ~1; val maxidx = Thm.maxidx_of_cterm ct; val ctxt = raw_ctxt |> Context_Position.set_visible false |> inc_simp_depth |> (fn ctxt => trace_invoke {depth = simp_depth ctxt, term = Thm.term_of ct} ctxt); val _ = cond_tracing ctxt (fn () => print_term ctxt "SIMPLIFIER INVOKED ON THE FOLLOWING TERM:" (Thm.term_of ct)); in ct |> bottomc (mode, Option.map (Drule.flexflex_unique (SOME ctxt)) oo prover, maxidx) ctxt |> Thm.solve_constraints end; val simple_prover = SINGLE o (fn ctxt => ALLGOALS (resolve_tac ctxt (prems_of ctxt))); fun rewrite _ _ [] = Thm.reflexive | rewrite ctxt full thms = rewrite_cterm (full, false, false) simple_prover (init_simpset thms ctxt); fun rewrite_rule ctxt = Conv.fconv_rule o rewrite ctxt true; (*simple term rewriting -- no proof*) fun rewrite_term thy rules procs = Pattern.rewrite_term thy (map decomp_simp' rules) procs; fun rewrite_thm mode prover ctxt = Conv.fconv_rule (rewrite_cterm mode prover ctxt); (*Rewrite the subgoals of a proof state (represented by a theorem)*) fun rewrite_goals_rule ctxt thms th = Conv.fconv_rule (Conv.prems_conv ~1 (rewrite_cterm (true, true, true) simple_prover (init_simpset thms ctxt))) th; (** meta-rewriting tactics **) (*Rewrite all subgoals*) fun rewrite_goals_tac ctxt defs = PRIMITIVE (rewrite_goals_rule ctxt defs); (*Rewrite one subgoal*) fun generic_rewrite_goal_tac mode prover_tac ctxt i thm = if 0 < i andalso i <= Thm.nprems_of thm then Seq.single (Conv.gconv_rule (rewrite_cterm mode (SINGLE o prover_tac) ctxt) i thm) else Seq.empty; fun rewrite_goal_tac ctxt thms = generic_rewrite_goal_tac (true, false, false) (K no_tac) (init_simpset thms ctxt); (*Prunes all redundant parameters from the proof state by rewriting.*) fun prune_params_tac ctxt = rewrite_goals_tac ctxt [Drule.triv_forall_equality]; (* for folding definitions, handling critical pairs *) (*The depth of nesting in a term*) fun term_depth (Abs (_, _, t)) = 1 + term_depth t | term_depth (f $ t) = 1 + Int.max (term_depth f, term_depth t) | term_depth _ = 0; val lhs_of_thm = #1 o Logic.dest_equals o Thm.prop_of; (*folding should handle critical pairs! E.g. K \ Inl 0, S \ Inr (Inl 0) Returns longest lhs first to avoid folding its subexpressions.*) fun sort_lhs_depths defs = let val keylist = AList.make (term_depth o lhs_of_thm) defs val keys = sort_distinct (rev_order o int_ord) (map #2 keylist) in map (AList.find (op =) keylist) keys end; val rev_defs = sort_lhs_depths o map Thm.symmetric; fun fold_rule ctxt defs = fold (rewrite_rule ctxt) (rev_defs defs); fun fold_goals_tac ctxt defs = EVERY (map (rewrite_goals_tac ctxt) (rev_defs defs)); (* HHF normal form: \ before \, outermost \ generalized *) local -fun gen_norm_hhf ss ctxt = - Thm.transfer' ctxt #> - (fn th => - if Drule.is_norm_hhf (Thm.prop_of th) then th - else - Conv.fconv_rule - (rewrite_cterm (true, false, false) (K (K NONE)) (put_simpset ss ctxt)) th) #> - Thm.adjust_maxidx_thm ~1 #> - Variable.gen_all ctxt; +fun gen_norm_hhf ss ctxt0 th0 = + let + val (ctxt, th) = Thm.join_transfer_context (ctxt0, th0); + val th' = + if Drule.is_norm_hhf (Thm.prop_of th) then th + else + Conv.fconv_rule (rewrite_cterm (true, false, false) (K (K NONE)) (put_simpset ss ctxt)) th; + in th' |> Thm.adjust_maxidx_thm ~1 |> Variable.gen_all ctxt end; val hhf_ss = Context.the_local_context () |> init_simpset Drule.norm_hhf_eqs |> simpset_of; val hhf_protect_ss = Context.the_local_context () |> init_simpset Drule.norm_hhf_eqs |> add_eqcong Drule.protect_cong |> simpset_of; in val norm_hhf = gen_norm_hhf hhf_ss; val norm_hhf_protect = gen_norm_hhf hhf_protect_ss; end; end; structure Basic_Meta_Simplifier: BASIC_RAW_SIMPLIFIER = Raw_Simplifier; open Basic_Meta_Simplifier; diff --git a/src/Pure/thm.ML b/src/Pure/thm.ML --- a/src/Pure/thm.ML +++ b/src/Pure/thm.ML @@ -1,2345 +1,2345 @@ (* Title: Pure/thm.ML Author: Lawrence C Paulson, Cambridge University Computer Laboratory Author: Makarius The very core of Isabelle's Meta Logic: certified types and terms, derivations, theorems, inference rules (including lifting and resolution), oracles. *) infix 0 RS RSN; signature BASIC_THM = sig type ctyp type cterm exception CTERM of string * cterm list type thm type conv = cterm -> thm exception THM of string * int * thm list val RSN: thm * (int * thm) -> thm val RS: thm * thm -> thm end; signature THM = sig include BASIC_THM (*certified types*) val typ_of: ctyp -> typ val global_ctyp_of: theory -> typ -> ctyp val ctyp_of: Proof.context -> typ -> ctyp val dest_ctyp: ctyp -> ctyp list val dest_ctypN: int -> ctyp -> ctyp val dest_ctyp0: ctyp -> ctyp val dest_ctyp1: ctyp -> ctyp val make_ctyp: ctyp -> ctyp list -> ctyp (*certified terms*) val term_of: cterm -> term val typ_of_cterm: cterm -> typ val ctyp_of_cterm: cterm -> ctyp val maxidx_of_cterm: cterm -> int val global_cterm_of: theory -> term -> cterm val cterm_of: Proof.context -> term -> cterm val renamed_term: term -> cterm -> cterm val dest_comb: cterm -> cterm * cterm val dest_fun: cterm -> cterm val dest_arg: cterm -> cterm val dest_fun2: cterm -> cterm val dest_arg1: cterm -> cterm val dest_abs: string option -> cterm -> cterm * cterm val rename_tvar: indexname -> ctyp -> ctyp val var: indexname * ctyp -> cterm val apply: cterm -> cterm -> cterm val lambda_name: string * cterm -> cterm -> cterm val lambda: cterm -> cterm -> cterm val adjust_maxidx_cterm: int -> cterm -> cterm val incr_indexes_cterm: int -> cterm -> cterm val match: cterm * cterm -> ((indexname * sort) * ctyp) list * ((indexname * typ) * cterm) list val first_order_match: cterm * cterm -> ((indexname * sort) * ctyp) list * ((indexname * typ) * cterm) list (*theorems*) val fold_terms: (term -> 'a -> 'a) -> thm -> 'a -> 'a val fold_atomic_ctyps: (ctyp -> 'a -> 'a) -> thm -> 'a -> 'a val fold_atomic_cterms: (cterm -> 'a -> 'a) -> thm -> 'a -> 'a val terms_of_tpairs: (term * term) list -> term list val full_prop_of: thm -> term val theory_id: thm -> Context.theory_id val theory_name: thm -> string val maxidx_of: thm -> int val maxidx_thm: thm -> int -> int val shyps_of: thm -> sort Ord_List.T val hyps_of: thm -> term list val prop_of: thm -> term val tpairs_of: thm -> (term * term) list val concl_of: thm -> term val prems_of: thm -> term list val nprems_of: thm -> int val no_prems: thm -> bool val major_prem_of: thm -> term val cprop_of: thm -> cterm val cprem_of: thm -> int -> cterm val cconcl_of: thm -> cterm val cprems_of: thm -> cterm list val chyps_of: thm -> cterm list exception CONTEXT of string * ctyp list * cterm list * thm list * Context.generic option val theory_of_cterm: cterm -> theory val theory_of_thm: thm -> theory val trim_context_ctyp: ctyp -> ctyp val trim_context_cterm: cterm -> cterm val transfer_ctyp: theory -> ctyp -> ctyp val transfer_cterm: theory -> cterm -> cterm val transfer: theory -> thm -> thm val transfer': Proof.context -> thm -> thm val transfer'': Context.generic -> thm -> thm val join_transfer: theory -> thm -> thm val join_transfer_context: Proof.context * thm -> Proof.context * thm val renamed_prop: term -> thm -> thm val weaken: cterm -> thm -> thm val weaken_sorts: sort list -> cterm -> cterm val extra_shyps: thm -> sort list val proof_bodies_of: thm list -> proof_body list val proof_body_of: thm -> proof_body val proof_of: thm -> proof val reconstruct_proof_of: thm -> Proofterm.proof val consolidate: thm list -> unit val expose_proofs: theory -> thm list -> unit val expose_proof: theory -> thm -> unit val future: thm future -> cterm -> thm val thm_deps: thm -> Proofterm.thm Ord_List.T val derivation_closed: thm -> bool val derivation_name: thm -> string val derivation_id: thm -> Proofterm.thm_id option val raw_derivation_name: thm -> string val expand_name: thm -> Proofterm.thm_header -> string option val name_derivation: string * Position.T -> thm -> thm val close_derivation: Position.T -> thm -> thm val trim_context: thm -> thm val axiom: theory -> string -> thm val all_axioms_of: theory -> (string * thm) list val get_tags: thm -> Properties.T val map_tags: (Properties.T -> Properties.T) -> thm -> thm val norm_proof: thm -> thm val adjust_maxidx_thm: int -> thm -> thm (*type classes*) val the_classrel: theory -> class * class -> thm val the_arity: theory -> string * sort list * class -> thm val classrel_proof: theory -> class * class -> proof val arity_proof: theory -> string * sort list * class -> proof (*oracles*) val add_oracle: binding * ('a -> cterm) -> theory -> (string * ('a -> thm)) * theory val oracle_space: theory -> Name_Space.T val pretty_oracle: Proof.context -> string -> Pretty.T val extern_oracles: bool -> Proof.context -> (Markup.T * xstring) list val check_oracle: Proof.context -> xstring * Position.T -> string (*inference rules*) val assume: cterm -> thm val implies_intr: cterm -> thm -> thm val implies_elim: thm -> thm -> thm val forall_intr: cterm -> thm -> thm val forall_elim: cterm -> thm -> thm val reflexive: cterm -> thm val symmetric: thm -> thm val transitive: thm -> thm -> thm val beta_conversion: bool -> conv val eta_conversion: conv val eta_long_conversion: conv val abstract_rule: string -> cterm -> thm -> thm val combination: thm -> thm -> thm val equal_intr: thm -> thm -> thm val equal_elim: thm -> thm -> thm val solve_constraints: thm -> thm val flexflex_rule: Proof.context option -> thm -> thm Seq.seq val generalize: string list * string list -> int -> thm -> thm val generalize_cterm: string list * string list -> int -> cterm -> cterm val generalize_ctyp: string list -> int -> ctyp -> ctyp val instantiate: ((indexname * sort) * ctyp) list * ((indexname * typ) * cterm) list -> thm -> thm val instantiate_cterm: ((indexname * sort) * ctyp) list * ((indexname * typ) * cterm) list -> cterm -> cterm val trivial: cterm -> thm val of_class: ctyp * class -> thm val strip_shyps: thm -> thm val unconstrainT: thm -> thm val varifyT_global': (string * sort) list -> thm -> ((string * sort) * indexname) list * thm val varifyT_global: thm -> thm val legacy_freezeT: thm -> thm val plain_prop_of: thm -> term val dest_state: thm * int -> (term * term) list * term list * term * term val lift_rule: cterm -> thm -> thm val incr_indexes: int -> thm -> thm val assumption: Proof.context option -> int -> thm -> thm Seq.seq val eq_assumption: int -> thm -> thm val rotate_rule: int -> int -> thm -> thm val permute_prems: int -> int -> thm -> thm val bicompose: Proof.context option -> {flatten: bool, match: bool, incremented: bool} -> bool * thm * int -> int -> thm -> thm Seq.seq val biresolution: Proof.context option -> bool -> (bool * thm) list -> int -> thm -> thm Seq.seq val thynames_of_arity: theory -> string * class -> string list val add_classrel: thm -> theory -> theory val add_arity: thm -> theory -> theory end; structure Thm: THM = struct (*** Certified terms and types ***) (** certified types **) datatype ctyp = Ctyp of {cert: Context.certificate, T: typ, maxidx: int, sorts: sort Ord_List.T}; fun typ_of (Ctyp {T, ...}) = T; fun global_ctyp_of thy raw_T = let val T = Sign.certify_typ thy raw_T; val maxidx = Term.maxidx_of_typ T; val sorts = Sorts.insert_typ T []; in Ctyp {cert = Context.Certificate thy, T = T, maxidx = maxidx, sorts = sorts} end; val ctyp_of = global_ctyp_of o Proof_Context.theory_of; fun dest_ctyp (Ctyp {cert, T = Type (_, Ts), maxidx, sorts}) = map (fn T => Ctyp {cert = cert, T = T, maxidx = maxidx, sorts = sorts}) Ts | dest_ctyp cT = raise TYPE ("dest_ctyp", [typ_of cT], []); fun dest_ctypN n (Ctyp {cert, T, maxidx, sorts}) = let fun err () = raise TYPE ("dest_ctypN", [T], []) in (case T of Type (_, Ts) => Ctyp {cert = cert, T = nth Ts n handle General.Subscript => err (), maxidx = maxidx, sorts = sorts} | _ => err ()) end; val dest_ctyp0 = dest_ctypN 0; val dest_ctyp1 = dest_ctypN 1; fun join_certificate_ctyp (Ctyp {cert, ...}) cert0 = Context.join_certificate (cert0, cert); fun union_sorts_ctyp (Ctyp {sorts, ...}) sorts0 = Sorts.union sorts0 sorts; fun maxidx_ctyp (Ctyp {maxidx, ...}) maxidx0 = Int.max (maxidx0, maxidx); fun make_ctyp (Ctyp {cert, T, maxidx = _, sorts = _}) cargs = let val As = map typ_of cargs; fun err () = raise TYPE ("make_ctyp", T :: As, []); in (case T of Type (a, args) => Ctyp { cert = fold join_certificate_ctyp cargs cert, maxidx = fold maxidx_ctyp cargs ~1, sorts = fold union_sorts_ctyp cargs [], T = if length args = length cargs then Type (a, As) else err ()} | _ => err ()) end; (** certified terms **) (*certified terms with checked typ, maxidx, and sorts*) datatype cterm = Cterm of {cert: Context.certificate, t: term, T: typ, maxidx: int, sorts: sort Ord_List.T}; exception CTERM of string * cterm list; fun term_of (Cterm {t, ...}) = t; fun typ_of_cterm (Cterm {T, ...}) = T; fun ctyp_of_cterm (Cterm {cert, T, maxidx, sorts, ...}) = Ctyp {cert = cert, T = T, maxidx = maxidx, sorts = sorts}; fun maxidx_of_cterm (Cterm {maxidx, ...}) = maxidx; fun global_cterm_of thy tm = let val (t, T, maxidx) = Sign.certify_term thy tm; val sorts = Sorts.insert_term t []; in Cterm {cert = Context.Certificate thy, t = t, T = T, maxidx = maxidx, sorts = sorts} end; val cterm_of = global_cterm_of o Proof_Context.theory_of; fun join_certificate0 (Cterm {cert = cert1, ...}, Cterm {cert = cert2, ...}) = Context.join_certificate (cert1, cert2); fun renamed_term t' (Cterm {cert, t, T, maxidx, sorts}) = if t aconv t' then Cterm {cert = cert, t = t', T = T, maxidx = maxidx, sorts = sorts} else raise TERM ("renamed_term: terms disagree", [t, t']); (* destructors *) fun dest_comb (Cterm {t = c $ a, T, cert, maxidx, sorts}) = let val A = Term.argument_type_of c 0 in (Cterm {t = c, T = A --> T, cert = cert, maxidx = maxidx, sorts = sorts}, Cterm {t = a, T = A, cert = cert, maxidx = maxidx, sorts = sorts}) end | dest_comb ct = raise CTERM ("dest_comb", [ct]); fun dest_fun (Cterm {t = c $ _, T, cert, maxidx, sorts}) = let val A = Term.argument_type_of c 0 in Cterm {t = c, T = A --> T, cert = cert, maxidx = maxidx, sorts = sorts} end | dest_fun ct = raise CTERM ("dest_fun", [ct]); fun dest_arg (Cterm {t = c $ a, T = _, cert, maxidx, sorts}) = let val A = Term.argument_type_of c 0 in Cterm {t = a, T = A, cert = cert, maxidx = maxidx, sorts = sorts} end | dest_arg ct = raise CTERM ("dest_arg", [ct]); fun dest_fun2 (Cterm {t = c $ _ $ _, T, cert, maxidx, sorts}) = let val A = Term.argument_type_of c 0; val B = Term.argument_type_of c 1; in Cterm {t = c, T = A --> B --> T, cert = cert, maxidx = maxidx, sorts = sorts} end | dest_fun2 ct = raise CTERM ("dest_fun2", [ct]); fun dest_arg1 (Cterm {t = c $ a $ _, T = _, cert, maxidx, sorts}) = let val A = Term.argument_type_of c 0 in Cterm {t = a, T = A, cert = cert, maxidx = maxidx, sorts = sorts} end | dest_arg1 ct = raise CTERM ("dest_arg1", [ct]); fun dest_abs a (Cterm {t = Abs (x, T, t), T = Type ("fun", [_, U]), cert, maxidx, sorts}) = let val (y', t') = Term.dest_abs (the_default x a, T, t) in (Cterm {t = Free (y', T), T = T, cert = cert, maxidx = maxidx, sorts = sorts}, Cterm {t = t', T = U, cert = cert, maxidx = maxidx, sorts = sorts}) end | dest_abs _ ct = raise CTERM ("dest_abs", [ct]); (* constructors *) fun rename_tvar (a, i) (Ctyp {cert, T, maxidx, sorts}) = let val S = (case T of TFree (_, S) => S | TVar (_, S) => S | _ => raise TYPE ("rename_tvar: no variable", [T], [])); val _ = if i < 0 then raise TYPE ("rename_tvar: bad index", [TVar ((a, i), S)], []) else (); in Ctyp {cert = cert, T = TVar ((a, i), S), maxidx = Int.max (i, maxidx), sorts = sorts} end; fun var ((x, i), Ctyp {cert, T, maxidx, sorts}) = if i < 0 then raise TERM ("var: bad index", [Var ((x, i), T)]) else Cterm {cert = cert, t = Var ((x, i), T), T = T, maxidx = Int.max (i, maxidx), sorts = sorts}; fun apply (cf as Cterm {t = f, T = Type ("fun", [dty, rty]), maxidx = maxidx1, sorts = sorts1, ...}) (cx as Cterm {t = x, T, maxidx = maxidx2, sorts = sorts2, ...}) = if T = dty then Cterm {cert = join_certificate0 (cf, cx), t = f $ x, T = rty, maxidx = Int.max (maxidx1, maxidx2), sorts = Sorts.union sorts1 sorts2} else raise CTERM ("apply: types don't agree", [cf, cx]) | apply cf cx = raise CTERM ("apply: first arg is not a function", [cf, cx]); fun lambda_name (x, ct1 as Cterm {t = t1, T = T1, maxidx = maxidx1, sorts = sorts1, ...}) (ct2 as Cterm {t = t2, T = T2, maxidx = maxidx2, sorts = sorts2, ...}) = let val t = Term.lambda_name (x, t1) t2 in Cterm {cert = join_certificate0 (ct1, ct2), t = t, T = T1 --> T2, maxidx = Int.max (maxidx1, maxidx2), sorts = Sorts.union sorts1 sorts2} end; fun lambda t u = lambda_name ("", t) u; (* indexes *) fun adjust_maxidx_cterm i (ct as Cterm {cert, t, T, maxidx, sorts}) = if maxidx = i then ct else if maxidx < i then Cterm {maxidx = i, cert = cert, t = t, T = T, sorts = sorts} else Cterm {maxidx = Int.max (maxidx_of_term t, i), cert = cert, t = t, T = T, sorts = sorts}; fun incr_indexes_cterm i (ct as Cterm {cert, t, T, maxidx, sorts}) = if i < 0 then raise CTERM ("negative increment", [ct]) else if i = 0 then ct else Cterm {cert = cert, t = Logic.incr_indexes ([], [], i) t, T = Logic.incr_tvar i T, maxidx = maxidx + i, sorts = sorts}; (*** Derivations and Theorems ***) (* sort constraints *) type constraint = {theory: theory, typ: typ, sort: sort}; local val constraint_ord : constraint ord = Context.theory_id_ord o apply2 (Context.theory_id o #theory) <<< Term_Ord.typ_ord o apply2 #typ <<< Term_Ord.sort_ord o apply2 #sort; val smash_atyps = map_atyps (fn TVar (_, S) => Term.aT S | TFree (_, S) => Term.aT S | T => T); in val union_constraints = Ord_List.union constraint_ord; fun insert_constraints thy (T, S) = let val ignored = S = [] orelse (case T of TFree (_, S') => S = S' | TVar (_, S') => S = S' | _ => false); in if ignored then I else Ord_List.insert constraint_ord {theory = thy, typ = smash_atyps T, sort = S} end; fun insert_constraints_env thy env = let val tyenv = Envir.type_env env; fun insert ([], _) = I | insert (S, T) = insert_constraints thy (Envir.norm_type tyenv T, S); in tyenv |> Vartab.fold (insert o #2) end; end; (* datatype thm *) datatype thm = Thm of deriv * (*derivation*) {cert: Context.certificate, (*background theory certificate*) tags: Properties.T, (*additional annotations/comments*) maxidx: int, (*maximum index of any Var or TVar*) constraints: constraint Ord_List.T, (*implicit proof obligations for sort constraints*) shyps: sort Ord_List.T, (*sort hypotheses*) hyps: term Ord_List.T, (*hypotheses*) tpairs: (term * term) list, (*flex-flex pairs*) prop: term} (*conclusion*) and deriv = Deriv of {promises: (serial * thm future) Ord_List.T, body: Proofterm.proof_body}; type conv = cterm -> thm; (*errors involving theorems*) exception THM of string * int * thm list; fun rep_thm (Thm (_, args)) = args; fun fold_terms f (Thm (_, {tpairs, prop, hyps, ...})) = fold (fn (t, u) => f t #> f u) tpairs #> f prop #> fold f hyps; fun fold_atomic_ctyps f (th as Thm (_, {cert, maxidx, shyps, ...})) = let fun ctyp T = Ctyp {cert = cert, T = T, maxidx = maxidx, sorts = shyps} in (fold_terms o fold_types o fold_atyps) (f o ctyp) th end; fun fold_atomic_cterms f (th as Thm (_, {cert, maxidx, shyps, ...})) = let fun cterm t T = Cterm {cert = cert, t = t, T = T, maxidx = maxidx, sorts = shyps} in (fold_terms o fold_aterms) (fn t as Const (_, T) => f (cterm t T) | t as Free (_, T) => f (cterm t T) | t as Var (_, T) => f (cterm t T) | _ => I) th end; fun terms_of_tpairs tpairs = fold_rev (fn (t, u) => cons t o cons u) tpairs []; fun eq_tpairs ((t, u), (t', u')) = t aconv t' andalso u aconv u'; fun union_tpairs ts us = Library.merge eq_tpairs (ts, us); val maxidx_tpairs = fold (fn (t, u) => Term.maxidx_term t #> Term.maxidx_term u); fun attach_tpairs tpairs prop = Logic.list_implies (map Logic.mk_equals tpairs, prop); fun full_prop_of (Thm (_, {tpairs, prop, ...})) = attach_tpairs tpairs prop; val union_hyps = Ord_List.union Term_Ord.fast_term_ord; val insert_hyps = Ord_List.insert Term_Ord.fast_term_ord; val remove_hyps = Ord_List.remove Term_Ord.fast_term_ord; fun join_certificate1 (Cterm {cert = cert1, ...}, Thm (_, {cert = cert2, ...})) = Context.join_certificate (cert1, cert2); fun join_certificate2 (Thm (_, {cert = cert1, ...}), Thm (_, {cert = cert2, ...})) = Context.join_certificate (cert1, cert2); (* basic components *) val cert_of = #cert o rep_thm; val theory_id = Context.certificate_theory_id o cert_of; val theory_name = Context.theory_id_name o theory_id; val maxidx_of = #maxidx o rep_thm; fun maxidx_thm th i = Int.max (maxidx_of th, i); val shyps_of = #shyps o rep_thm; val hyps_of = #hyps o rep_thm; val prop_of = #prop o rep_thm; val tpairs_of = #tpairs o rep_thm; val concl_of = Logic.strip_imp_concl o prop_of; val prems_of = Logic.strip_imp_prems o prop_of; val nprems_of = Logic.count_prems o prop_of; fun no_prems th = nprems_of th = 0; fun major_prem_of th = (case prems_of th of prem :: _ => Logic.strip_assums_concl prem | [] => raise THM ("major_prem_of: rule with no premises", 0, [th])); fun cprop_of (Thm (_, {cert, maxidx, shyps, prop, ...})) = Cterm {cert = cert, maxidx = maxidx, T = propT, t = prop, sorts = shyps}; fun cprem_of (th as Thm (_, {cert, maxidx, shyps, prop, ...})) i = Cterm {cert = cert, maxidx = maxidx, T = propT, sorts = shyps, t = Logic.nth_prem (i, prop) handle TERM _ => raise THM ("cprem_of", i, [th])}; fun cconcl_of (th as Thm (_, {cert, maxidx, shyps, ...})) = Cterm {cert = cert, maxidx = maxidx, T = propT, sorts = shyps, t = concl_of th}; fun cprems_of (th as Thm (_, {cert, maxidx, shyps, ...})) = map (fn t => Cterm {cert = cert, maxidx = maxidx, T = propT, sorts = shyps, t = t}) (prems_of th); fun chyps_of (Thm (_, {cert, shyps, hyps, ...})) = map (fn t => Cterm {cert = cert, maxidx = ~1, T = propT, sorts = shyps, t = t}) hyps; (* implicit theory context *) exception CONTEXT of string * ctyp list * cterm list * thm list * Context.generic option; fun theory_of_cterm (ct as Cterm {cert, ...}) = Context.certificate_theory cert handle ERROR msg => raise CONTEXT (msg, [], [ct], [], NONE); fun theory_of_thm th = Context.certificate_theory (cert_of th) handle ERROR msg => raise CONTEXT (msg, [], [], [th], NONE); fun trim_context_ctyp cT = (case cT of Ctyp {cert = Context.Certificate_Id _, ...} => cT | Ctyp {cert = Context.Certificate thy, T, maxidx, sorts} => Ctyp {cert = Context.Certificate_Id (Context.theory_id thy), T = T, maxidx = maxidx, sorts = sorts}); fun trim_context_cterm ct = (case ct of Cterm {cert = Context.Certificate_Id _, ...} => ct | Cterm {cert = Context.Certificate thy, t, T, maxidx, sorts} => Cterm {cert = Context.Certificate_Id (Context.theory_id thy), t = t, T = T, maxidx = maxidx, sorts = sorts}); fun trim_context_thm th = (case th of Thm (_, {constraints = _ :: _, ...}) => raise THM ("trim_context: pending sort constraints", 0, [th]) | Thm (_, {cert = Context.Certificate_Id _, ...}) => th | Thm (der, {cert = Context.Certificate thy, tags, maxidx, constraints = [], shyps, hyps, tpairs, prop}) => Thm (der, {cert = Context.Certificate_Id (Context.theory_id thy), tags = tags, maxidx = maxidx, constraints = [], shyps = shyps, hyps = hyps, tpairs = tpairs, prop = prop})); fun transfer_ctyp thy' cT = let val Ctyp {cert, T, maxidx, sorts} = cT; val _ = Context.subthy_id (Context.certificate_theory_id cert, Context.theory_id thy') orelse raise CONTEXT ("Cannot transfer: not a super theory", [cT], [], [], SOME (Context.Theory thy')); val cert' = Context.join_certificate (Context.Certificate thy', cert); in if Context.eq_certificate (cert, cert') then cT else Ctyp {cert = cert', T = T, maxidx = maxidx, sorts = sorts} end; fun transfer_cterm thy' ct = let val Cterm {cert, t, T, maxidx, sorts} = ct; val _ = Context.subthy_id (Context.certificate_theory_id cert, Context.theory_id thy') orelse raise CONTEXT ("Cannot transfer: not a super theory", [], [ct], [], SOME (Context.Theory thy')); val cert' = Context.join_certificate (Context.Certificate thy', cert); in if Context.eq_certificate (cert, cert') then ct else Cterm {cert = cert', t = t, T = T, maxidx = maxidx, sorts = sorts} end; fun transfer thy' th = let val Thm (der, {cert, tags, maxidx, constraints, shyps, hyps, tpairs, prop}) = th; val _ = Context.subthy_id (Context.certificate_theory_id cert, Context.theory_id thy') orelse raise CONTEXT ("Cannot transfer: not a super theory", [], [], [th], SOME (Context.Theory thy')); val cert' = Context.join_certificate (Context.Certificate thy', cert); in if Context.eq_certificate (cert, cert') then th else Thm (der, {cert = cert', tags = tags, maxidx = maxidx, constraints = constraints, shyps = shyps, hyps = hyps, tpairs = tpairs, prop = prop}) end; val transfer' = transfer o Proof_Context.theory_of; val transfer'' = transfer o Context.theory_of; fun join_transfer thy th = if Context.subthy_id (Context.theory_id thy, theory_id th) then th else transfer thy th; fun join_transfer_context (ctxt, th) = - if Context.subthy_id (Context.theory_id (Proof_Context.theory_of ctxt), theory_id th) then - (Context.raw_transfer (theory_of_thm th) ctxt, th) - else (ctxt, transfer' ctxt th); + if Context.subthy_id (theory_id th, Context.theory_id (Proof_Context.theory_of ctxt)) + then (ctxt, transfer' ctxt th) + else (Context.raw_transfer (theory_of_thm th) ctxt, th); (* matching *) local fun gen_match match (ct1 as Cterm {t = t1, sorts = sorts1, ...}, ct2 as Cterm {t = t2, sorts = sorts2, maxidx = maxidx2, ...}) = let val cert = join_certificate0 (ct1, ct2); val thy = Context.certificate_theory cert handle ERROR msg => raise CONTEXT (msg, [], [ct1, ct2], [], NONE); val (Tinsts, tinsts) = match thy (t1, t2) (Vartab.empty, Vartab.empty); val sorts = Sorts.union sorts1 sorts2; fun mk_cTinst ((a, i), (S, T)) = (((a, i), S), Ctyp {T = T, cert = cert, maxidx = maxidx2, sorts = sorts}); fun mk_ctinst ((x, i), (U, t)) = let val T = Envir.subst_type Tinsts U in (((x, i), T), Cterm {t = t, T = T, cert = cert, maxidx = maxidx2, sorts = sorts}) end; in (Vartab.fold (cons o mk_cTinst) Tinsts [], Vartab.fold (cons o mk_ctinst) tinsts []) end; in val match = gen_match Pattern.match; val first_order_match = gen_match Pattern.first_order_match; end; (*implicit alpha-conversion*) fun renamed_prop prop' (Thm (der, {cert, tags, maxidx, constraints, shyps, hyps, tpairs, prop})) = if prop aconv prop' then Thm (der, {cert = cert, tags = tags, maxidx = maxidx, constraints = constraints, shyps = shyps, hyps = hyps, tpairs = tpairs, prop = prop'}) else raise TERM ("renamed_prop: props disagree", [prop, prop']); fun make_context ths NONE cert = (Context.Theory (Context.certificate_theory cert) handle ERROR msg => raise CONTEXT (msg, [], [], ths, NONE)) | make_context ths (SOME ctxt) cert = let val thy_id = Context.certificate_theory_id cert; val thy_id' = Context.theory_id (Proof_Context.theory_of ctxt); in if Context.subthy_id (thy_id, thy_id') then Context.Proof ctxt else raise CONTEXT ("Bad context", [], [], ths, SOME (Context.Proof ctxt)) end; fun make_context_certificate ths opt_ctxt cert = let val context = make_context ths opt_ctxt cert; val cert' = Context.Certificate (Context.theory_of context); in (context, cert') end; (*explicit weakening: maps |- B to A |- B*) fun weaken raw_ct th = let val ct as Cterm {t = A, T, sorts, maxidx = maxidxA, ...} = adjust_maxidx_cterm ~1 raw_ct; val Thm (der, {tags, maxidx, constraints, shyps, hyps, tpairs, prop, ...}) = th; in if T <> propT then raise THM ("weaken: assumptions must have type prop", 0, []) else if maxidxA <> ~1 then raise THM ("weaken: assumptions may not contain schematic variables", maxidxA, []) else Thm (der, {cert = join_certificate1 (ct, th), tags = tags, maxidx = maxidx, constraints = constraints, shyps = Sorts.union sorts shyps, hyps = insert_hyps A hyps, tpairs = tpairs, prop = prop}) end; fun weaken_sorts raw_sorts ct = let val Cterm {cert, t, T, maxidx, sorts} = ct; val thy = theory_of_cterm ct; val more_sorts = Sorts.make (map (Sign.certify_sort thy) raw_sorts); val sorts' = Sorts.union sorts more_sorts; in Cterm {cert = cert, t = t, T = T, maxidx = maxidx, sorts = sorts'} end; (*dangling sort constraints of a thm*) fun extra_shyps (th as Thm (_, {shyps, ...})) = Sorts.subtract (fold_terms Sorts.insert_term th []) shyps; (** derivations and promised proofs **) fun make_deriv promises oracles thms proof = Deriv {promises = promises, body = PBody {oracles = oracles, thms = thms, proof = proof}}; val empty_deriv = make_deriv [] [] [] MinProof; (* inference rules *) val promise_ord: (serial * thm future) ord = fn ((i, _), (j, _)) => int_ord (j, i); fun bad_proofs i = error ("Illegal level of detail for proof objects: " ^ string_of_int i); fun deriv_rule2 f (Deriv {promises = ps1, body = PBody {oracles = oracles1, thms = thms1, proof = prf1}}) (Deriv {promises = ps2, body = PBody {oracles = oracles2, thms = thms2, proof = prf2}}) = let val ps = Ord_List.union promise_ord ps1 ps2; val oracles = Proofterm.unions_oracles [oracles1, oracles2]; val thms = Proofterm.unions_thms [thms1, thms2]; val prf = (case ! Proofterm.proofs of 2 => f prf1 prf2 | 1 => MinProof | 0 => MinProof | i => bad_proofs i); in make_deriv ps oracles thms prf end; fun deriv_rule1 f = deriv_rule2 (K f) empty_deriv; fun deriv_rule0 make_prf = if ! Proofterm.proofs <= 1 then empty_deriv else deriv_rule1 I (make_deriv [] [] [] (make_prf ())); fun deriv_rule_unconditional f (Deriv {promises, body = PBody {oracles, thms, proof}}) = make_deriv promises oracles thms (f proof); (* fulfilled proofs *) fun raw_promises_of (Thm (Deriv {promises, ...}, _)) = promises; fun join_promises [] = () | join_promises promises = join_promises_of (Future.joins (map snd promises)) and join_promises_of thms = join_promises (Ord_List.make promise_ord (maps raw_promises_of thms)); fun fulfill_body (th as Thm (Deriv {promises, body}, _)) = let val fulfilled_promises = map #1 promises ~~ map fulfill_body (Future.joins (map #2 promises)) in Proofterm.fulfill_norm_proof (theory_of_thm th) fulfilled_promises body end; fun proof_bodies_of thms = (join_promises_of thms; map fulfill_body thms); val proof_body_of = singleton proof_bodies_of; val proof_of = Proofterm.proof_of o proof_body_of; fun reconstruct_proof_of thm = Proofterm.reconstruct_proof (theory_of_thm thm) (prop_of thm) (proof_of thm); val consolidate = ignore o proof_bodies_of; fun expose_proofs thy thms = if Proofterm.export_proof_boxes_required thy then Proofterm.export_proof_boxes (proof_bodies_of (map (transfer thy) thms)) else (); fun expose_proof thy = expose_proofs thy o single; (* future rule *) fun future_result i orig_cert orig_shyps orig_prop thm = let fun err msg = raise THM ("future_result: " ^ msg, 0, [thm]); val Thm (Deriv {promises, ...}, {cert, constraints, shyps, hyps, tpairs, prop, ...}) = thm; val _ = Context.eq_certificate (cert, orig_cert) orelse err "bad theory"; val _ = prop aconv orig_prop orelse err "bad prop"; val _ = null constraints orelse err "bad sort constraints"; val _ = null tpairs orelse err "bad flex-flex constraints"; val _ = null hyps orelse err "bad hyps"; val _ = Sorts.subset (shyps, orig_shyps) orelse err "bad shyps"; val _ = forall (fn (j, _) => i <> j) promises orelse err "bad dependencies"; val _ = join_promises promises; in thm end; fun future future_thm ct = let val Cterm {cert = cert, t = prop, T, maxidx, sorts} = ct; val _ = T <> propT andalso raise CTERM ("future: prop expected", [ct]); val _ = if Proofterm.proofs_enabled () then raise CTERM ("future: proof terms enabled", [ct]) else (); val i = serial (); val future = future_thm |> Future.map (future_result i cert sorts prop); in Thm (make_deriv [(i, future)] [] [] MinProof, {cert = cert, tags = [], maxidx = maxidx, constraints = [], shyps = sorts, hyps = [], tpairs = [], prop = prop}) end; (** Axioms **) fun axiom thy name = (case Name_Space.lookup (Theory.axiom_table thy) name of SOME prop => let val der = deriv_rule0 (fn () => Proofterm.axm_proof name prop); val cert = Context.Certificate thy; val maxidx = maxidx_of_term prop; val shyps = Sorts.insert_term prop []; in Thm (der, {cert = cert, tags = [], maxidx = maxidx, constraints = [], shyps = shyps, hyps = [], tpairs = [], prop = prop}) end | NONE => raise THEORY ("No axiom " ^ quote name, [thy])); fun all_axioms_of thy = map (fn (name, _) => (name, axiom thy name)) (Theory.all_axioms_of thy); (* tags *) val get_tags = #tags o rep_thm; fun map_tags f (Thm (der, {cert, tags, maxidx, constraints, shyps, hyps, tpairs, prop})) = Thm (der, {cert = cert, tags = f tags, maxidx = maxidx, constraints = constraints, shyps = shyps, hyps = hyps, tpairs = tpairs, prop = prop}); (* technical adjustments *) fun norm_proof (th as Thm (der, args)) = Thm (deriv_rule1 (Proofterm.rew_proof (theory_of_thm th)) der, args); fun adjust_maxidx_thm i (th as Thm (der, {cert, tags, maxidx, constraints, shyps, hyps, tpairs, prop})) = if maxidx = i then th else if maxidx < i then Thm (der, {maxidx = i, cert = cert, tags = tags, constraints = constraints, shyps = shyps, hyps = hyps, tpairs = tpairs, prop = prop}) else Thm (der, {maxidx = Int.max (maxidx_tpairs tpairs (maxidx_of_term prop), i), cert = cert, tags = tags, constraints = constraints, shyps = shyps, hyps = hyps, tpairs = tpairs, prop = prop}); (*** Theory data ***) (* type classes *) structure Aritytab = Table( type key = string * sort list * class; val ord = fast_string_ord o apply2 #1 <<< fast_string_ord o apply2 #3 <<< list_ord Term_Ord.sort_ord o apply2 #2; ); datatype classes = Classes of {classrels: thm Symreltab.table, arities: (thm * string * serial) Aritytab.table}; fun make_classes (classrels, arities) = Classes {classrels = classrels, arities = arities}; val empty_classes = make_classes (Symreltab.empty, Aritytab.empty); (*see Theory.at_begin hook for transitive closure of classrels and arity completion*) fun merge_classes (Classes {classrels = classrels1, arities = arities1}, Classes {classrels = classrels2, arities = arities2}) = let val classrels' = Symreltab.merge (K true) (classrels1, classrels2); val arities' = Aritytab.merge (K true) (arities1, arities2); in make_classes (classrels', arities') end; (* data *) structure Data = Theory_Data ( type T = unit Name_Space.table * (*oracles: authentic derivation names*) classes; (*type classes within the logic*) val empty : T = (Name_Space.empty_table "oracle", empty_classes); val extend = I; fun merge ((oracles1, sorts1), (oracles2, sorts2)) : T = (Name_Space.merge_tables (oracles1, oracles2), merge_classes (sorts1, sorts2)); ); val get_oracles = #1 o Data.get; val map_oracles = Data.map o apfst; val get_classes = (fn (_, Classes args) => args) o Data.get; val get_classrels = #classrels o get_classes; val get_arities = #arities o get_classes; fun map_classes f = (Data.map o apsnd) (fn Classes {classrels, arities} => make_classes (f (classrels, arities))); fun map_classrels f = map_classes (fn (classrels, arities) => (f classrels, arities)); fun map_arities f = map_classes (fn (classrels, arities) => (classrels, f arities)); (* type classes *) fun the_classrel thy (c1, c2) = (case Symreltab.lookup (get_classrels thy) (c1, c2) of SOME thm => transfer thy thm | NONE => error ("Unproven class relation " ^ Syntax.string_of_classrel (Proof_Context.init_global thy) [c1, c2])); fun the_arity thy (a, Ss, c) = (case Aritytab.lookup (get_arities thy) (a, Ss, c) of SOME (thm, _, _) => transfer thy thm | NONE => error ("Unproven type arity " ^ Syntax.string_of_arity (Proof_Context.init_global thy) (a, Ss, [c]))); val classrel_proof = proof_of oo the_classrel; val arity_proof = proof_of oo the_arity; (* solve sort constraints by pro-forma proof *) local fun union_digest (oracles1, thms1) (oracles2, thms2) = (Proofterm.unions_oracles [oracles1, oracles2], Proofterm.unions_thms [thms1, thms2]); fun thm_digest (Thm (Deriv {body = PBody {oracles, thms, ...}, ...}, _)) = (oracles, thms); fun constraint_digest ({theory = thy, typ, sort, ...}: constraint) = Sorts.of_sort_derivation (Sign.classes_of thy) {class_relation = fn _ => fn _ => fn (digest, c1) => fn c2 => if c1 = c2 then ([], []) else union_digest digest (thm_digest (the_classrel thy (c1, c2))), type_constructor = fn (a, _) => fn dom => fn c => let val arity_digest = thm_digest (the_arity thy (a, (map o map) #2 dom, c)) in (fold o fold) (union_digest o #1) dom arity_digest end, type_variable = fn T => map (pair ([], [])) (Type.sort_of_atyp T)} (typ, sort); in fun solve_constraints (thm as Thm (_, {constraints = [], ...})) = thm | solve_constraints (thm as Thm (der, args)) = let val {cert, tags, maxidx, constraints, shyps, hyps, tpairs, prop} = args; val thy = Context.certificate_theory cert; val bad_thys = constraints |> map_filter (fn {theory = thy', ...} => if Context.eq_thy (thy, thy') then NONE else SOME thy'); val () = if null bad_thys then () else raise THEORY ("solve_constraints: bad theories for theorem\n" ^ Syntax.string_of_term_global thy (prop_of thm), thy :: bad_thys); val Deriv {promises, body = PBody {oracles, thms, proof}} = der; val (oracles', thms') = (oracles, thms) |> fold (fold union_digest o constraint_digest) constraints; val body' = PBody {oracles = oracles', thms = thms', proof = proof}; in Thm (Deriv {promises = promises, body = body'}, {constraints = [], cert = cert, tags = tags, maxidx = maxidx, shyps = shyps, hyps = hyps, tpairs = tpairs, prop = prop}) end; end; (*** Closed theorems with official name ***) (*non-deterministic, depends on unknown promises*) fun derivation_closed (Thm (Deriv {body, ...}, _)) = Proofterm.compact_proof (Proofterm.proof_of body); (*non-deterministic, depends on unknown promises*) fun raw_derivation_name (Thm (Deriv {body, ...}, {shyps, hyps, prop, ...})) = Proofterm.get_approximative_name shyps hyps prop (Proofterm.proof_of body); fun expand_name (Thm (Deriv {body, ...}, {shyps, hyps, prop, ...})) = let val self_id = (case Proofterm.get_identity shyps hyps prop (Proofterm.proof_of body) of NONE => K false | SOME {serial, ...} => fn (header: Proofterm.thm_header) => serial = #serial header); fun expand header = if self_id header orelse #name header = "" then SOME "" else NONE; in expand end; (*deterministic name of finished proof*) fun derivation_name (thm as Thm (_, {shyps, hyps, prop, ...})) = Proofterm.get_approximative_name shyps hyps prop (proof_of thm); (*identified PThm node*) fun derivation_id (thm as Thm (_, {shyps, hyps, prop, ...})) = Proofterm.get_id shyps hyps prop (proof_of thm); (*dependencies of PThm node*) fun thm_deps (thm as Thm (Deriv {promises = [], body = PBody {thms, ...}, ...}, _)) = (case (derivation_id thm, thms) of (SOME {serial = i, ...}, [(j, thm_node)]) => if i = j then Proofterm.thm_node_thms thm_node else thms | _ => thms) | thm_deps thm = raise THM ("thm_deps: bad promises", 0, [thm]); fun name_derivation name_pos = solve_constraints #> (fn thm as Thm (der, args) => let val thy = theory_of_thm thm; val Deriv {promises, body} = der; val {shyps, hyps, prop, tpairs, ...} = args; val _ = null tpairs orelse raise THM ("name_derivation: bad flex-flex constraints", 0, [thm]); val ps = map (apsnd (Future.map fulfill_body)) promises; val (pthm, proof) = Proofterm.thm_proof thy (classrel_proof thy) (arity_proof thy) name_pos shyps hyps prop ps body; val der' = make_deriv [] [] [pthm] proof; in Thm (der', args) end); fun close_derivation pos = solve_constraints #> (fn thm => if not (null (tpairs_of thm)) orelse derivation_closed thm then thm else name_derivation ("", pos) thm); val trim_context = solve_constraints #> trim_context_thm; (*** Oracles ***) fun add_oracle (b, oracle_fn) thy = let val (name, oracles') = Name_Space.define (Context.Theory thy) true (b, ()) (get_oracles thy); val thy' = map_oracles (K oracles') thy; fun invoke_oracle arg = let val Cterm {cert = cert2, t = prop, T, maxidx, sorts} = oracle_fn arg in if T <> propT then raise THM ("Oracle's result must have type prop: " ^ name, 0, []) else let val (oracle, prf) = (case ! Proofterm.proofs of 2 => ((name, SOME prop), Proofterm.oracle_proof name prop) | 1 => ((name, SOME prop), MinProof) | 0 => ((name, NONE), MinProof) | i => bad_proofs i); in Thm (make_deriv [] [oracle] [] prf, {cert = Context.join_certificate (Context.Certificate thy', cert2), tags = [], maxidx = maxidx, constraints = [], shyps = sorts, hyps = [], tpairs = [], prop = prop}) end end; in ((name, invoke_oracle), thy') end; val oracle_space = Name_Space.space_of_table o get_oracles; fun pretty_oracle ctxt = Name_Space.pretty ctxt (oracle_space (Proof_Context.theory_of ctxt)); fun extern_oracles verbose ctxt = map #1 (Name_Space.markup_table verbose ctxt (get_oracles (Proof_Context.theory_of ctxt))); fun check_oracle ctxt = Name_Space.check (Context.Proof ctxt) (get_oracles (Proof_Context.theory_of ctxt)) #> #1; (*** Meta rules ***) (** primitive rules **) (*The assumption rule A |- A*) fun assume raw_ct = let val Cterm {cert, t = prop, T, maxidx, sorts} = adjust_maxidx_cterm ~1 raw_ct in if T <> propT then raise THM ("assume: prop", 0, []) else if maxidx <> ~1 then raise THM ("assume: variables", maxidx, []) else Thm (deriv_rule0 (fn () => Proofterm.Hyp prop), {cert = cert, tags = [], maxidx = ~1, constraints = [], shyps = sorts, hyps = [prop], tpairs = [], prop = prop}) end; (*Implication introduction [A] : B ------- A \ B *) fun implies_intr (ct as Cterm {t = A, T, maxidx = maxidx1, sorts, ...}) (th as Thm (der, {maxidx = maxidx2, hyps, constraints, shyps, tpairs, prop, ...})) = if T <> propT then raise THM ("implies_intr: assumptions must have type prop", 0, [th]) else Thm (deriv_rule1 (Proofterm.implies_intr_proof A) der, {cert = join_certificate1 (ct, th), tags = [], maxidx = Int.max (maxidx1, maxidx2), constraints = constraints, shyps = Sorts.union sorts shyps, hyps = remove_hyps A hyps, tpairs = tpairs, prop = Logic.mk_implies (A, prop)}); (*Implication elimination A \ B A ------------ B *) fun implies_elim thAB thA = let val Thm (derA, {maxidx = maxidx1, hyps = hypsA, constraints = constraintsA, shyps = shypsA, tpairs = tpairsA, prop = propA, ...}) = thA and Thm (der, {maxidx = maxidx2, hyps, constraints, shyps, tpairs, prop, ...}) = thAB; fun err () = raise THM ("implies_elim: major premise", 0, [thAB, thA]); in (case prop of Const ("Pure.imp", _) $ A $ B => if A aconv propA then Thm (deriv_rule2 (curry Proofterm.%%) der derA, {cert = join_certificate2 (thAB, thA), tags = [], maxidx = Int.max (maxidx1, maxidx2), constraints = union_constraints constraintsA constraints, shyps = Sorts.union shypsA shyps, hyps = union_hyps hypsA hyps, tpairs = union_tpairs tpairsA tpairs, prop = B}) else err () | _ => err ()) end; (*Forall introduction. The Free or Var x must not be free in the hypotheses. [x] : A ------ \x. A *) fun forall_intr (ct as Cterm {maxidx = maxidx1, t = x, T, sorts, ...}) (th as Thm (der, {maxidx = maxidx2, constraints, shyps, hyps, tpairs, prop, ...})) = let fun result a = Thm (deriv_rule1 (Proofterm.forall_intr_proof (a, x) NONE) der, {cert = join_certificate1 (ct, th), tags = [], maxidx = Int.max (maxidx1, maxidx2), constraints = constraints, shyps = Sorts.union sorts shyps, hyps = hyps, tpairs = tpairs, prop = Logic.all_const T $ Abs (a, T, abstract_over (x, prop))}); fun check_occs a x ts = if exists (fn t => Logic.occs (x, t)) ts then raise THM ("forall_intr: variable " ^ quote a ^ " free in assumptions", 0, [th]) else (); in (case x of Free (a, _) => (check_occs a x hyps; check_occs a x (terms_of_tpairs tpairs); result a) | Var ((a, _), _) => (check_occs a x (terms_of_tpairs tpairs); result a) | _ => raise THM ("forall_intr: not a variable", 0, [th])) end; (*Forall elimination \x. A ------ A[t/x] *) fun forall_elim (ct as Cterm {t, T, maxidx = maxidx1, sorts, ...}) (th as Thm (der, {maxidx = maxidx2, constraints, shyps, hyps, tpairs, prop, ...})) = (case prop of Const ("Pure.all", Type ("fun", [Type ("fun", [qary, _]), _])) $ A => if T <> qary then raise THM ("forall_elim: type mismatch", 0, [th]) else Thm (deriv_rule1 (Proofterm.% o rpair (SOME t)) der, {cert = join_certificate1 (ct, th), tags = [], maxidx = Int.max (maxidx1, maxidx2), constraints = constraints, shyps = Sorts.union sorts shyps, hyps = hyps, tpairs = tpairs, prop = Term.betapply (A, t)}) | _ => raise THM ("forall_elim: not quantified", 0, [th])); (* Equality *) (*Reflexivity t \ t *) fun reflexive (Cterm {cert, t, T = _, maxidx, sorts}) = Thm (deriv_rule0 (fn () => Proofterm.reflexive_proof), {cert = cert, tags = [], maxidx = maxidx, constraints = [], shyps = sorts, hyps = [], tpairs = [], prop = Logic.mk_equals (t, t)}); (*Symmetry t \ u ------ u \ t *) fun symmetric (th as Thm (der, {cert, maxidx, constraints, shyps, hyps, tpairs, prop, ...})) = (case prop of (eq as Const ("Pure.eq", _)) $ t $ u => Thm (deriv_rule1 Proofterm.symmetric_proof der, {cert = cert, tags = [], maxidx = maxidx, constraints = constraints, shyps = shyps, hyps = hyps, tpairs = tpairs, prop = eq $ u $ t}) | _ => raise THM ("symmetric", 0, [th])); (*Transitivity t1 \ u u \ t2 ------------------ t1 \ t2 *) fun transitive th1 th2 = let val Thm (der1, {maxidx = maxidx1, hyps = hyps1, constraints = constraints1, shyps = shyps1, tpairs = tpairs1, prop = prop1, ...}) = th1 and Thm (der2, {maxidx = maxidx2, hyps = hyps2, constraints = constraints2, shyps = shyps2, tpairs = tpairs2, prop = prop2, ...}) = th2; fun err msg = raise THM ("transitive: " ^ msg, 0, [th1, th2]); in case (prop1, prop2) of ((eq as Const ("Pure.eq", Type (_, [U, _]))) $ t1 $ u, Const ("Pure.eq", _) $ u' $ t2) => if not (u aconv u') then err "middle term" else Thm (deriv_rule2 (Proofterm.transitive_proof U u) der1 der2, {cert = join_certificate2 (th1, th2), tags = [], maxidx = Int.max (maxidx1, maxidx2), constraints = union_constraints constraints1 constraints2, shyps = Sorts.union shyps1 shyps2, hyps = union_hyps hyps1 hyps2, tpairs = union_tpairs tpairs1 tpairs2, prop = eq $ t1 $ t2}) | _ => err "premises" end; (*Beta-conversion (\x. t) u \ t[u/x] fully beta-reduces the term if full = true *) fun beta_conversion full (Cterm {cert, t, T = _, maxidx, sorts}) = let val t' = if full then Envir.beta_norm t else (case t of Abs (_, _, bodt) $ u => subst_bound (u, bodt) | _ => raise THM ("beta_conversion: not a redex", 0, [])); in Thm (deriv_rule0 (fn () => Proofterm.reflexive_proof), {cert = cert, tags = [], maxidx = maxidx, constraints = [], shyps = sorts, hyps = [], tpairs = [], prop = Logic.mk_equals (t, t')}) end; fun eta_conversion (Cterm {cert, t, T = _, maxidx, sorts}) = Thm (deriv_rule0 (fn () => Proofterm.reflexive_proof), {cert = cert, tags = [], maxidx = maxidx, constraints = [], shyps = sorts, hyps = [], tpairs = [], prop = Logic.mk_equals (t, Envir.eta_contract t)}); fun eta_long_conversion (Cterm {cert, t, T = _, maxidx, sorts}) = Thm (deriv_rule0 (fn () => Proofterm.reflexive_proof), {cert = cert, tags = [], maxidx = maxidx, constraints = [], shyps = sorts, hyps = [], tpairs = [], prop = Logic.mk_equals (t, Envir.eta_long [] t)}); (*The abstraction rule. The Free or Var x must not be free in the hypotheses. The bound variable will be named "a" (since x will be something like x320) t \ u -------------- \x. t \ \x. u *) fun abstract_rule a (Cterm {t = x, T, sorts, ...}) (th as Thm (der, {cert, maxidx, hyps, constraints, shyps, tpairs, prop, ...})) = let val (t, u) = Logic.dest_equals prop handle TERM _ => raise THM ("abstract_rule: premise not an equality", 0, [th]); val result = Thm (deriv_rule1 (Proofterm.abstract_rule_proof (a, x)) der, {cert = cert, tags = [], maxidx = maxidx, constraints = constraints, shyps = Sorts.union sorts shyps, hyps = hyps, tpairs = tpairs, prop = Logic.mk_equals (Abs (a, T, abstract_over (x, t)), Abs (a, T, abstract_over (x, u)))}); fun check_occs a x ts = if exists (fn t => Logic.occs (x, t)) ts then raise THM ("abstract_rule: variable " ^ quote a ^ " free in assumptions", 0, [th]) else (); in (case x of Free (a, _) => (check_occs a x hyps; check_occs a x (terms_of_tpairs tpairs); result) | Var ((a, _), _) => (check_occs a x (terms_of_tpairs tpairs); result) | _ => raise THM ("abstract_rule: not a variable", 0, [th])) end; (*The combination rule f \ g t \ u ------------- f t \ g u *) fun combination th1 th2 = let val Thm (der1, {maxidx = maxidx1, constraints = constraints1, shyps = shyps1, hyps = hyps1, tpairs = tpairs1, prop = prop1, ...}) = th1 and Thm (der2, {maxidx = maxidx2, constraints = constraints2, shyps = shyps2, hyps = hyps2, tpairs = tpairs2, prop = prop2, ...}) = th2; fun chktypes fT tT = (case fT of Type ("fun", [T1, _]) => if T1 <> tT then raise THM ("combination: types", 0, [th1, th2]) else () | _ => raise THM ("combination: not function type", 0, [th1, th2])); in (case (prop1, prop2) of (Const ("Pure.eq", Type ("fun", [fT, _])) $ f $ g, Const ("Pure.eq", Type ("fun", [tT, _])) $ t $ u) => (chktypes fT tT; Thm (deriv_rule2 (Proofterm.combination_proof f g t u) der1 der2, {cert = join_certificate2 (th1, th2), tags = [], maxidx = Int.max (maxidx1, maxidx2), constraints = union_constraints constraints1 constraints2, shyps = Sorts.union shyps1 shyps2, hyps = union_hyps hyps1 hyps2, tpairs = union_tpairs tpairs1 tpairs2, prop = Logic.mk_equals (f $ t, g $ u)})) | _ => raise THM ("combination: premises", 0, [th1, th2])) end; (*Equality introduction A \ B B \ A ---------------- A \ B *) fun equal_intr th1 th2 = let val Thm (der1, {maxidx = maxidx1, constraints = constraints1, shyps = shyps1, hyps = hyps1, tpairs = tpairs1, prop = prop1, ...}) = th1 and Thm (der2, {maxidx = maxidx2, constraints = constraints2, shyps = shyps2, hyps = hyps2, tpairs = tpairs2, prop = prop2, ...}) = th2; fun err msg = raise THM ("equal_intr: " ^ msg, 0, [th1, th2]); in (case (prop1, prop2) of (Const("Pure.imp", _) $ A $ B, Const("Pure.imp", _) $ B' $ A') => if A aconv A' andalso B aconv B' then Thm (deriv_rule2 (Proofterm.equal_intr_proof A B) der1 der2, {cert = join_certificate2 (th1, th2), tags = [], maxidx = Int.max (maxidx1, maxidx2), constraints = union_constraints constraints1 constraints2, shyps = Sorts.union shyps1 shyps2, hyps = union_hyps hyps1 hyps2, tpairs = union_tpairs tpairs1 tpairs2, prop = Logic.mk_equals (A, B)}) else err "not equal" | _ => err "premises") end; (*The equal propositions rule A \ B A --------- B *) fun equal_elim th1 th2 = let val Thm (der1, {maxidx = maxidx1, constraints = constraints1, shyps = shyps1, hyps = hyps1, tpairs = tpairs1, prop = prop1, ...}) = th1 and Thm (der2, {maxidx = maxidx2, constraints = constraints2, shyps = shyps2, hyps = hyps2, tpairs = tpairs2, prop = prop2, ...}) = th2; fun err msg = raise THM ("equal_elim: " ^ msg, 0, [th1, th2]); in (case prop1 of Const ("Pure.eq", _) $ A $ B => if prop2 aconv A then Thm (deriv_rule2 (Proofterm.equal_elim_proof A B) der1 der2, {cert = join_certificate2 (th1, th2), tags = [], maxidx = Int.max (maxidx1, maxidx2), constraints = union_constraints constraints1 constraints2, shyps = Sorts.union shyps1 shyps2, hyps = union_hyps hyps1 hyps2, tpairs = union_tpairs tpairs1 tpairs2, prop = B}) else err "not equal" | _ => err "major premise") end; (**** Derived rules ****) (*Smash unifies the list of term pairs leaving no flex-flex pairs. Instantiates the theorem and deletes trivial tpairs. Resulting sequence may contain multiple elements if the tpairs are not all flex-flex.*) fun flexflex_rule opt_ctxt = solve_constraints #> (fn th => let val Thm (der, {cert, maxidx, constraints, shyps, hyps, tpairs, prop, ...}) = th; val (context, cert') = make_context_certificate [th] opt_ctxt cert; in Unify.smash_unifiers context tpairs (Envir.empty maxidx) |> Seq.map (fn env => if Envir.is_empty env then th else let val tpairs' = tpairs |> map (apply2 (Envir.norm_term env)) (*remove trivial tpairs, of the form t \ t*) |> filter_out (op aconv); val der' = deriv_rule1 (Proofterm.norm_proof' env) der; val constraints' = insert_constraints_env (Context.certificate_theory cert') env constraints; val prop' = Envir.norm_term env prop; val maxidx = maxidx_tpairs tpairs' (maxidx_of_term prop'); val shyps = Envir.insert_sorts env shyps; in Thm (der', {cert = cert', tags = [], maxidx = maxidx, constraints = constraints', shyps = shyps, hyps = hyps, tpairs = tpairs', prop = prop'}) end) end); (*Generalization of fixed variables A -------------------- A[?'a/'a, ?x/x, ...] *) fun generalize ([], []) _ th = th | generalize (tfrees, frees) idx th = let val Thm (der, {cert, maxidx, constraints, shyps, hyps, tpairs, prop, ...}) = th; val _ = idx <= maxidx andalso raise THM ("generalize: bad index", idx, [th]); val bad_type = if null tfrees then K false else Term.exists_subtype (fn TFree (a, _) => member (op =) tfrees a | _ => false); fun bad_term (Free (x, T)) = bad_type T orelse member (op =) frees x | bad_term (Var (_, T)) = bad_type T | bad_term (Const (_, T)) = bad_type T | bad_term (Abs (_, T, t)) = bad_type T orelse bad_term t | bad_term (t $ u) = bad_term t orelse bad_term u | bad_term (Bound _) = false; val _ = exists bad_term hyps andalso raise THM ("generalize: variable free in assumptions", 0, [th]); val generalize = Term_Subst.generalize (tfrees, frees) idx; val prop' = generalize prop; val tpairs' = map (apply2 generalize) tpairs; val maxidx' = maxidx_tpairs tpairs' (maxidx_of_term prop'); in Thm (deriv_rule1 (Proofterm.generalize_proof (tfrees, frees) idx prop) der, {cert = cert, tags = [], maxidx = maxidx', constraints = constraints, shyps = shyps, hyps = hyps, tpairs = tpairs', prop = prop'}) end; fun generalize_cterm ([], []) _ ct = ct | generalize_cterm (tfrees, frees) idx (ct as Cterm {cert, t, T, maxidx, sorts}) = if idx <= maxidx then raise CTERM ("generalize_cterm: bad index", [ct]) else Cterm {cert = cert, sorts = sorts, T = Term_Subst.generalizeT tfrees idx T, t = Term_Subst.generalize (tfrees, frees) idx t, maxidx = Int.max (maxidx, idx)}; fun generalize_ctyp [] _ cT = cT | generalize_ctyp tfrees idx (Ctyp {cert, T, maxidx, sorts}) = if idx <= maxidx then raise CTERM ("generalize_ctyp: bad index", []) else Ctyp {cert = cert, sorts = sorts, T = Term_Subst.generalizeT tfrees idx T, maxidx = Int.max (maxidx, idx)}; (*Instantiation of schematic variables A -------------------- A[t1/v1, ..., tn/vn] *) local fun pretty_typing thy t T = Pretty.block [Syntax.pretty_term_global thy t, Pretty.str " ::", Pretty.brk 1, Syntax.pretty_typ_global thy T]; fun add_inst (v as (_, T), cu) (cert, sorts) = let val Cterm {t = u, T = U, cert = cert2, sorts = sorts_u, maxidx = maxidx_u, ...} = cu; val cert' = Context.join_certificate (cert, cert2); val sorts' = Sorts.union sorts_u sorts; in if T = U then ((v, (u, maxidx_u)), (cert', sorts')) else let val msg = (case cert' of Context.Certificate thy' => Pretty.string_of (Pretty.block [Pretty.str "instantiate: type conflict", Pretty.fbrk, pretty_typing thy' (Var v) T, Pretty.fbrk, pretty_typing thy' u U]) | Context.Certificate_Id _ => "instantiate: type conflict"); in raise TYPE (msg, [T, U], [Var v, u]) end end; fun add_instT (v as (_, S), cU) (cert, sorts) = let val Ctyp {T = U, cert = cert2, sorts = sorts_U, maxidx = maxidx_U, ...} = cU; val cert' = Context.join_certificate (cert, cert2); val thy' = Context.certificate_theory cert' handle ERROR msg => raise CONTEXT (msg, [cU], [], [], NONE); val sorts' = Sorts.union sorts_U sorts; in if Sign.of_sort thy' (U, S) then ((v, (U, maxidx_U)), (cert', sorts')) else raise TYPE ("Type not of sort " ^ Syntax.string_of_sort_global thy' S, [U], []) end; in (*Left-to-right replacements: ctpairs = [..., (vi, ti), ...]. Instantiates distinct Vars by terms of same type. Does NOT normalize the resulting theorem!*) fun instantiate ([], []) th = th | instantiate (instT, inst) th = let val Thm (der, {cert, hyps, constraints, shyps, tpairs, prop, ...}) = th; val (inst', (instT', (cert', shyps'))) = (cert, shyps) |> fold_map add_inst inst ||> fold_map add_instT instT handle CONTEXT (msg, cTs, cts, ths, context) => raise CONTEXT (msg, cTs, cts, th :: ths, context); val subst = Term_Subst.instantiate_maxidx (instT', inst'); val (prop', maxidx1) = subst prop ~1; val (tpairs', maxidx') = fold_map (fn (t, u) => fn i => subst t i ||>> subst u) tpairs maxidx1; val thy' = Context.certificate_theory cert'; val constraints' = fold (fn ((_, S), (T, _)) => insert_constraints thy' (T, S)) instT' constraints; in Thm (deriv_rule1 (fn d => Proofterm.instantiate (map (apsnd #1) instT', map (apsnd #1) inst') d) der, {cert = cert', tags = [], maxidx = maxidx', constraints = constraints', shyps = shyps', hyps = hyps, tpairs = tpairs', prop = prop'}) |> solve_constraints end handle TYPE (msg, _, _) => raise THM (msg, 0, [th]); fun instantiate_cterm ([], []) ct = ct | instantiate_cterm (instT, inst) ct = let val Cterm {cert, t, T, sorts, ...} = ct; val (inst', (instT', (cert', sorts'))) = (cert, sorts) |> fold_map add_inst inst ||> fold_map add_instT instT; val subst = Term_Subst.instantiate_maxidx (instT', inst'); val substT = Term_Subst.instantiateT_maxidx instT'; val (t', maxidx1) = subst t ~1; val (T', maxidx') = substT T maxidx1; in Cterm {cert = cert', t = t', T = T', sorts = sorts', maxidx = maxidx'} end handle TYPE (msg, _, _) => raise CTERM (msg, [ct]); end; (*The trivial implication A \ A, justified by assume and forall rules. A can contain Vars, not so for assume!*) fun trivial (Cterm {cert, t = A, T, maxidx, sorts}) = if T <> propT then raise THM ("trivial: the term must have type prop", 0, []) else Thm (deriv_rule0 (fn () => Proofterm.trivial_proof), {cert = cert, tags = [], maxidx = maxidx, constraints = [], shyps = sorts, hyps = [], tpairs = [], prop = Logic.mk_implies (A, A)}); (*Axiom-scheme reflecting signature contents T :: c ------------------- OFCLASS(T, c_class) *) fun of_class (cT, raw_c) = let val Ctyp {cert, T, ...} = cT; val thy = Context.certificate_theory cert handle ERROR msg => raise CONTEXT (msg, [cT], [], [], NONE); val c = Sign.certify_class thy raw_c; val Cterm {t = prop, maxidx, sorts, ...} = global_cterm_of thy (Logic.mk_of_class (T, c)); in if Sign.of_sort thy (T, [c]) then Thm (deriv_rule0 (fn () => Proofterm.OfClass (T, c)), {cert = cert, tags = [], maxidx = maxidx, constraints = insert_constraints thy (T, [c]) [], shyps = sorts, hyps = [], tpairs = [], prop = prop}) else raise THM ("of_class: type not of class " ^ Syntax.string_of_sort_global thy [c], 0, []) end |> solve_constraints; (*Remove extra sorts that are witnessed by type signature information*) fun strip_shyps (thm as Thm (_, {shyps = [], ...})) = thm | strip_shyps (thm as Thm (der, {cert, tags, maxidx, constraints, shyps, hyps, tpairs, prop})) = let val thy = theory_of_thm thm; val algebra = Sign.classes_of thy; val present = (fold_terms o fold_types o fold_atyps_sorts) (insert (eq_fst op =)) thm []; val extra = fold (Sorts.remove_sort o #2) present shyps; val witnessed = Sign.witness_sorts thy present extra; val extra' = fold (Sorts.remove_sort o #2) witnessed extra |> Sorts.minimal_sorts algebra; val shyps' = fold (Sorts.insert_sort o #2) present extra'; in Thm (deriv_rule_unconditional (Proofterm.strip_shyps_proof algebra present witnessed extra') der, {cert = cert, tags = tags, maxidx = maxidx, constraints = constraints, shyps = shyps', hyps = hyps, tpairs = tpairs, prop = prop}) end; (*Internalize sort constraints of type variables*) val unconstrainT = solve_constraints #> (fn thm as Thm (der, args) => let val Deriv {promises, body} = der; val {cert, shyps, hyps, tpairs, prop, ...} = args; val thy = theory_of_thm thm; fun err msg = raise THM ("unconstrainT: " ^ msg, 0, [thm]); val _ = null hyps orelse err "bad hyps"; val _ = null tpairs orelse err "bad flex-flex constraints"; val tfrees = rev (Term.add_tfree_names prop []); val _ = null tfrees orelse err ("illegal free type variables " ^ commas_quote tfrees); val ps = map (apsnd (Future.map fulfill_body)) promises; val (pthm, proof) = Proofterm.unconstrain_thm_proof thy (classrel_proof thy) (arity_proof thy) shyps prop ps body; val der' = make_deriv [] [] [pthm] proof; val prop' = Proofterm.thm_node_prop (#2 pthm); in Thm (der', {cert = cert, tags = [], maxidx = maxidx_of_term prop', constraints = [], shyps = [[]], (*potentially redundant*) hyps = [], tpairs = [], prop = prop'}) end); (*Replace all TFrees not fixed or in the hyps by new TVars*) fun varifyT_global' fixed (Thm (der, {cert, maxidx, constraints, shyps, hyps, tpairs, prop, ...})) = let val tfrees = fold Term.add_tfrees hyps fixed; val prop1 = attach_tpairs tpairs prop; val (al, prop2) = Type.varify_global tfrees prop1; val (ts, prop3) = Logic.strip_prems (length tpairs, [], prop2); in (al, Thm (deriv_rule1 (Proofterm.varify_proof prop tfrees) der, {cert = cert, tags = [], maxidx = Int.max (0, maxidx), constraints = constraints, shyps = shyps, hyps = hyps, tpairs = rev (map Logic.dest_equals ts), prop = prop3})) end; val varifyT_global = #2 o varifyT_global' []; (*Replace all TVars by TFrees that are often new*) fun legacy_freezeT (Thm (der, {cert, constraints, shyps, hyps, tpairs, prop, ...})) = let val prop1 = attach_tpairs tpairs prop; val prop2 = Type.legacy_freeze prop1; val (ts, prop3) = Logic.strip_prems (length tpairs, [], prop2); in Thm (deriv_rule1 (Proofterm.legacy_freezeT prop1) der, {cert = cert, tags = [], maxidx = maxidx_of_term prop2, constraints = constraints, shyps = shyps, hyps = hyps, tpairs = rev (map Logic.dest_equals ts), prop = prop3}) end; fun plain_prop_of raw_thm = let val thm = strip_shyps raw_thm; fun err msg = raise THM ("plain_prop_of: " ^ msg, 0, [thm]); in if not (null (hyps_of thm)) then err "theorem may not contain hypotheses" else if not (null (extra_shyps thm)) then err "theorem may not contain sort hypotheses" else if not (null (tpairs_of thm)) then err "theorem may not contain flex-flex pairs" else prop_of thm end; (*** Inference rules for tactics ***) (*Destruct proof state into constraints, other goals, goal(i), rest *) fun dest_state (state as Thm (_, {prop,tpairs,...}), i) = (case Logic.strip_prems(i, [], prop) of (B::rBs, C) => (tpairs, rev rBs, B, C) | _ => raise THM("dest_state", i, [state])) handle TERM _ => raise THM("dest_state", i, [state]); (*Prepare orule for resolution by lifting it over the parameters and assumptions of goal.*) fun lift_rule goal orule = let val Cterm {t = gprop, T, maxidx = gmax, sorts, ...} = goal; val inc = gmax + 1; val lift_abs = Logic.lift_abs inc gprop; val lift_all = Logic.lift_all inc gprop; val Thm (der, {maxidx, constraints, shyps, hyps, tpairs, prop, ...}) = orule; val (As, B) = Logic.strip_horn prop; in if T <> propT then raise THM ("lift_rule: the term must have type prop", 0, []) else Thm (deriv_rule1 (Proofterm.lift_proof gprop inc prop) der, {cert = join_certificate1 (goal, orule), tags = [], maxidx = maxidx + inc, constraints = constraints, shyps = Sorts.union shyps sorts, (*sic!*) hyps = hyps, tpairs = map (apply2 lift_abs) tpairs, prop = Logic.list_implies (map lift_all As, lift_all B)}) end; fun incr_indexes i (thm as Thm (der, {cert, maxidx, constraints, shyps, hyps, tpairs, prop, ...})) = if i < 0 then raise THM ("negative increment", 0, [thm]) else if i = 0 then thm else Thm (deriv_rule1 (Proofterm.incr_indexes i) der, {cert = cert, tags = [], maxidx = maxidx + i, constraints = constraints, shyps = shyps, hyps = hyps, tpairs = map (apply2 (Logic.incr_indexes ([], [], i))) tpairs, prop = Logic.incr_indexes ([], [], i) prop}); (*Solve subgoal Bi of proof state B1...Bn/C by assumption. *) fun assumption opt_ctxt i state = let val Thm (der, {cert, maxidx, constraints, shyps, hyps, ...}) = state; val (context, cert') = make_context_certificate [state] opt_ctxt cert; val (tpairs, Bs, Bi, C) = dest_state (state, i); fun newth n (env, tpairs) = let val normt = Envir.norm_term env; fun assumption_proof prf = Proofterm.assumption_proof (map normt Bs) (normt Bi) n prf; in Thm (deriv_rule1 (assumption_proof #> not (Envir.is_empty env) ? Proofterm.norm_proof' env) der, {tags = [], maxidx = Envir.maxidx_of env, constraints = insert_constraints_env (Context.certificate_theory cert') env constraints, shyps = Envir.insert_sorts env shyps, hyps = hyps, tpairs = if Envir.is_empty env then tpairs else map (apply2 normt) tpairs, prop = if Envir.is_empty env then Logic.list_implies (Bs, C) (*avoid wasted normalizations*) else normt (Logic.list_implies (Bs, C)) (*normalize the new rule fully*), cert = cert'}) end; val (close, asms, concl) = Logic.assum_problems (~1, Bi); val concl' = close concl; fun addprfs [] _ = Seq.empty | addprfs (asm :: rest) n = Seq.make (fn () => Seq.pull (Seq.mapp (newth n) (if Term.could_unify (asm, concl) then (Unify.unifiers (context, Envir.empty maxidx, (close asm, concl') :: tpairs)) else Seq.empty) (addprfs rest (n + 1)))) in addprfs asms 1 end; (*Solve subgoal Bi of proof state B1...Bn/C by assumption. Checks if Bi's conclusion is alpha/eta-convertible to one of its assumptions*) fun eq_assumption i state = let val Thm (der, {cert, maxidx, constraints, shyps, hyps, ...}) = state; val (tpairs, Bs, Bi, C) = dest_state (state, i); val (_, asms, concl) = Logic.assum_problems (~1, Bi); in (case find_index (fn asm => Envir.aeconv (asm, concl)) asms of ~1 => raise THM ("eq_assumption", 0, [state]) | n => Thm (deriv_rule1 (Proofterm.assumption_proof Bs Bi (n + 1)) der, {cert = cert, tags = [], maxidx = maxidx, constraints = constraints, shyps = shyps, hyps = hyps, tpairs = tpairs, prop = Logic.list_implies (Bs, C)})) end; (*For rotate_tac: fast rotation of assumptions of subgoal i*) fun rotate_rule k i state = let val Thm (der, {cert, maxidx, constraints, shyps, hyps, ...}) = state; val (tpairs, Bs, Bi, C) = dest_state (state, i); val params = Term.strip_all_vars Bi; val rest = Term.strip_all_body Bi; val asms = Logic.strip_imp_prems rest val concl = Logic.strip_imp_concl rest; val n = length asms; val m = if k < 0 then n + k else k; val Bi' = if 0 = m orelse m = n then Bi else if 0 < m andalso m < n then let val (ps, qs) = chop m asms in Logic.list_all (params, Logic.list_implies (qs @ ps, concl)) end else raise THM ("rotate_rule", k, [state]); in Thm (deriv_rule1 (Proofterm.rotate_proof Bs Bi' params asms m) der, {cert = cert, tags = [], maxidx = maxidx, constraints = constraints, shyps = shyps, hyps = hyps, tpairs = tpairs, prop = Logic.list_implies (Bs @ [Bi'], C)}) end; (*Rotates a rule's premises to the left by k, leaving the first j premises unchanged. Does nothing if k=0 or if k equals n-j, where n is the number of premises. Useful with eresolve_tac and underlies defer_tac*) fun permute_prems j k rl = let val Thm (der, {cert, maxidx, constraints, shyps, hyps, tpairs, prop, ...}) = rl; val prems = Logic.strip_imp_prems prop and concl = Logic.strip_imp_concl prop; val moved_prems = List.drop (prems, j) and fixed_prems = List.take (prems, j) handle General.Subscript => raise THM ("permute_prems: j", j, [rl]); val n_j = length moved_prems; val m = if k < 0 then n_j + k else k; val (prems', prop') = if 0 = m orelse m = n_j then (prems, prop) else if 0 < m andalso m < n_j then let val (ps, qs) = chop m moved_prems; val prems' = fixed_prems @ qs @ ps; in (prems', Logic.list_implies (prems', concl)) end else raise THM ("permute_prems: k", k, [rl]); in Thm (deriv_rule1 (Proofterm.permute_prems_proof prems' j m) der, {cert = cert, tags = [], maxidx = maxidx, constraints = constraints, shyps = shyps, hyps = hyps, tpairs = tpairs, prop = prop'}) end; (* strip_apply f B A strips off all assumptions/parameters from A introduced by lifting over B, and applies f to remaining part of A*) fun strip_apply f = let fun strip (Const ("Pure.imp", _) $ _ $ B1) (Const ("Pure.imp", _) $ A2 $ B2) = Logic.mk_implies (A2, strip B1 B2) | strip ((c as Const ("Pure.all", _)) $ Abs (_, _, t1)) ( Const ("Pure.all", _) $ Abs (a, T, t2)) = c $ Abs (a, T, strip t1 t2) | strip _ A = f A in strip end; fun strip_lifted (Const ("Pure.imp", _) $ _ $ B1) (Const ("Pure.imp", _) $ _ $ B2) = strip_lifted B1 B2 | strip_lifted (Const ("Pure.all", _) $ Abs (_, _, t1)) (Const ("Pure.all", _) $ Abs (_, _, t2)) = strip_lifted t1 t2 | strip_lifted _ A = A; (*Use the alist to rename all bound variables and some unknowns in a term dpairs = current disagreement pairs; tpairs = permanent ones (flexflex); Preserves unknowns in tpairs and on lhs of dpairs. *) fun rename_bvs [] _ _ _ _ = K I | rename_bvs al dpairs tpairs B As = let val add_var = fold_aterms (fn Var ((x, _), _) => insert (op =) x | _ => I); val vids = [] |> fold (add_var o fst) dpairs |> fold (add_var o fst) tpairs |> fold (add_var o snd) tpairs; val vids' = fold (add_var o strip_lifted B) As []; (*unknowns appearing elsewhere be preserved!*) val al' = distinct ((op =) o apply2 fst) (filter_out (fn (x, y) => not (member (op =) vids' x) orelse member (op =) vids x orelse member (op =) vids y) al); val unchanged = filter_out (AList.defined (op =) al') vids'; fun del_clashing clash xs _ [] qs = if clash then del_clashing false xs xs qs [] else qs | del_clashing clash xs ys ((p as (x, y)) :: ps) qs = if member (op =) ys y then del_clashing true (x :: xs) (x :: ys) ps qs else del_clashing clash xs (y :: ys) ps (p :: qs); val al'' = del_clashing false unchanged unchanged al' []; fun rename (t as Var ((x, i), T)) = (case AList.lookup (op =) al'' x of SOME y => Var ((y, i), T) | NONE => t) | rename (Abs (x, T, t)) = Abs (the_default x (AList.lookup (op =) al x), T, rename t) | rename (f $ t) = rename f $ rename t | rename t = t; fun strip_ren f Ai = f rename B Ai in strip_ren end; (*Function to rename bounds/unknowns in the argument, lifted over B*) fun rename_bvars dpairs = rename_bvs (fold_rev Term.match_bvars dpairs []) dpairs; (*** RESOLUTION ***) (** Lifting optimizations **) (*strip off pairs of assumptions/parameters in parallel -- they are identical because of lifting*) fun strip_assums2 (Const("Pure.imp", _) $ _ $ B1, Const("Pure.imp", _) $ _ $ B2) = strip_assums2 (B1,B2) | strip_assums2 (Const("Pure.all",_)$Abs(a,T,t1), Const("Pure.all",_)$Abs(_,_,t2)) = let val (B1,B2) = strip_assums2 (t1,t2) in (Abs(a,T,B1), Abs(a,T,B2)) end | strip_assums2 BB = BB; (*Faster normalization: skip assumptions that were lifted over*) fun norm_term_skip env 0 t = Envir.norm_term env t | norm_term_skip env n (Const ("Pure.all", _) $ Abs (a, T, t)) = let val T' = Envir.norm_type (Envir.type_env env) T (*Must instantiate types of parameters because they are flattened; this could be a NEW parameter*) in Logic.all_const T' $ Abs (a, T', norm_term_skip env n t) end | norm_term_skip env n (Const ("Pure.imp", _) $ A $ B) = Logic.mk_implies (A, norm_term_skip env (n - 1) B) | norm_term_skip _ _ _ = error "norm_term_skip: too few assumptions??"; (*unify types of schematic variables (non-lifted case)*) fun unify_var_types context (th1, th2) env = let fun unify_vars (T :: Us) = fold (fn U => Pattern.unify_types context (T, U)) Us | unify_vars _ = I; val add_vars = full_prop_of #> fold_aterms (fn Var v => Vartab.insert_list (op =) v | _ => I); val vars = Vartab.empty |> add_vars th1 |> add_vars th2; in SOME (Vartab.fold (unify_vars o #2) vars env) end handle Pattern.Unif => NONE; (*Composition of object rule r=(A1...Am/B) with proof state s=(B1...Bn/C) Unifies B with Bi, replacing subgoal i (1 <= i <= n) If match then forbid instantiations in proof state If lifted then shorten the dpair using strip_assums2. If eres_flg then simultaneously proves A1 by assumption. nsubgoal is the number of new subgoals (written m above). Curried so that resolution calls dest_state only once. *) local exception COMPOSE in fun bicompose_aux opt_ctxt {flatten, match, incremented} (state, (stpairs, Bs, Bi, C), lifted) (eres_flg, orule, nsubgoal) = let val Thm (sder, {maxidx=smax, constraints = constraints2, shyps = shyps2, hyps = hyps2, ...}) = state and Thm (rder, {maxidx=rmax, constraints = constraints1, shyps = shyps1, hyps = hyps1, tpairs=rtpairs, prop=rprop,...}) = orule (*How many hyps to skip over during normalization*) and nlift = Logic.count_prems (strip_all_body Bi) + (if eres_flg then ~1 else 0) val (context, cert) = make_context_certificate [state, orule] opt_ctxt (join_certificate2 (state, orule)); (*Add new theorem with prop = "\Bs; As\ \ C" to thq*) fun addth A (As, oldAs, rder', n) ((env, tpairs), thq) = let val normt = Envir.norm_term env; (*perform minimal copying here by examining env*) val (ntpairs, normp) = if Envir.is_empty env then (tpairs, (Bs @ As, C)) else let val ntps = map (apply2 normt) tpairs in if Envir.above env smax then (*no assignments in state; normalize the rule only*) if lifted then (ntps, (Bs @ map (norm_term_skip env nlift) As, C)) else (ntps, (Bs @ map normt As, C)) else if match then raise COMPOSE else (*normalize the new rule fully*) (ntps, (map normt (Bs @ As), normt C)) end val constraints' = union_constraints constraints1 constraints2 |> insert_constraints_env (Context.certificate_theory cert) env; fun bicompose_proof prf1 prf2 = Proofterm.bicompose_proof flatten (map normt Bs) (map normt As) A oldAs n (nlift+1) prf1 prf2 val th = Thm (deriv_rule2 (if Envir.is_empty env then bicompose_proof else if Envir.above env smax then bicompose_proof o Proofterm.norm_proof' env else Proofterm.norm_proof' env oo bicompose_proof) rder' sder, {tags = [], maxidx = Envir.maxidx_of env, constraints = constraints', shyps = Envir.insert_sorts env (Sorts.union shyps1 shyps2), hyps = union_hyps hyps1 hyps2, tpairs = ntpairs, prop = Logic.list_implies normp, cert = cert}) in Seq.cons th thq end handle COMPOSE => thq; val (rAs,B) = Logic.strip_prems(nsubgoal, [], rprop) handle TERM _ => raise THM("bicompose: rule", 0, [orule,state]); (*Modify assumptions, deleting n-th if n>0 for e-resolution*) fun newAs(As0, n, dpairs, tpairs) = let val (As1, rder') = if not lifted then (As0, rder) else let val rename = rename_bvars dpairs tpairs B As0 in (map (rename strip_apply) As0, deriv_rule1 (Proofterm.map_proof_terms (rename K) I) rder) end; in (map (if flatten then (Logic.flatten_params n) else I) As1, As1, rder', n) handle TERM _ => raise THM("bicompose: 1st premise", 0, [orule]) end; val BBi = if lifted then strip_assums2(B,Bi) else (B,Bi); val dpairs = BBi :: (rtpairs@stpairs); (*elim-resolution: try each assumption in turn*) fun eres _ [] = raise THM ("bicompose: no premises", 0, [orule, state]) | eres env (A1 :: As) = let val A = SOME A1; val (close, asms, concl) = Logic.assum_problems (nlift + 1, A1); val concl' = close concl; fun tryasms [] _ = Seq.empty | tryasms (asm :: rest) n = if Term.could_unify (asm, concl) then let val asm' = close asm in (case Seq.pull (Unify.unifiers (context, env, (asm', concl') :: dpairs)) of NONE => tryasms rest (n + 1) | cell as SOME ((_, tpairs), _) => Seq.it_right (addth A (newAs (As, n, [BBi, (concl', asm')], tpairs))) (Seq.make (fn () => cell), Seq.make (fn () => Seq.pull (tryasms rest (n + 1))))) end else tryasms rest (n + 1); in tryasms asms 1 end; (*ordinary resolution*) fun res env = (case Seq.pull (Unify.unifiers (context, env, dpairs)) of NONE => Seq.empty | cell as SOME ((_, tpairs), _) => Seq.it_right (addth NONE (newAs (rev rAs, 0, [BBi], tpairs))) (Seq.make (fn () => cell), Seq.empty)); val env0 = Envir.empty (Int.max (rmax, smax)); in (case if incremented then SOME env0 else unify_var_types context (state, orule) env0 of NONE => Seq.empty | SOME env => if eres_flg then eres env (rev rAs) else res env) end; end; fun bicompose opt_ctxt flags arg i state = bicompose_aux opt_ctxt flags (state, dest_state (state,i), false) arg; (*Quick test whether rule is resolvable with the subgoal with hyps Hs and conclusion B. If eres_flg then checks 1st premise of rule also*) fun could_bires (Hs, B, eres_flg, rule) = let fun could_reshyp (A1::_) = exists (fn H => Term.could_unify (A1, H)) Hs | could_reshyp [] = false; (*no premise -- illegal*) in Term.could_unify(concl_of rule, B) andalso (not eres_flg orelse could_reshyp (prems_of rule)) end; (*Bi-resolution of a state with a list of (flag,rule) pairs. Puts the rule above: rule/state. Renames vars in the rules. *) fun biresolution opt_ctxt match brules i state = let val (stpairs, Bs, Bi, C) = dest_state(state,i); val lift = lift_rule (cprem_of state i); val B = Logic.strip_assums_concl Bi; val Hs = Logic.strip_assums_hyp Bi; val compose = bicompose_aux opt_ctxt {flatten = true, match = match, incremented = true} (state, (stpairs, Bs, Bi, C), true); fun res [] = Seq.empty | res ((eres_flg, rule)::brules) = if Config.get_generic (make_context [state] opt_ctxt (cert_of state)) Pattern.unify_trace_failure orelse could_bires (Hs, B, eres_flg, rule) then Seq.make (*delay processing remainder till needed*) (fn()=> SOME(compose (eres_flg, lift rule, nprems_of rule), res brules)) else res brules in Seq.flat (res brules) end; (*Resolution: exactly one resolvent must be produced*) fun tha RSN (i, thb) = (case Seq.chop 2 (biresolution NONE false [(false, tha)] i thb) of ([th], _) => solve_constraints th | ([], _) => raise THM ("RSN: no unifiers", i, [tha, thb]) | _ => raise THM ("RSN: multiple unifiers", i, [tha, thb])); (*Resolution: P \ Q, Q \ R gives P \ R*) fun tha RS thb = tha RSN (1,thb); (**** Type classes ****) fun standard_tvars thm = let val thy = theory_of_thm thm; val tvars = rev (Term.add_tvars (prop_of thm) []); val names = Name.invent Name.context Name.aT (length tvars); val tinst = map2 (fn (ai, S) => fn b => ((ai, S), global_ctyp_of thy (TVar ((b, 0), S)))) tvars names; in instantiate (tinst, []) thm end (* class relations *) val is_classrel = Symreltab.defined o get_classrels; fun complete_classrels thy = let fun complete (c, (_, (all_preds, all_succs))) (finished1, thy1) = let fun compl c1 c2 (finished2, thy2) = if is_classrel thy2 (c1, c2) then (finished2, thy2) else (false, thy2 |> (map_classrels o Symreltab.update) ((c1, c2), (the_classrel thy2 (c1, c) RS the_classrel thy2 (c, c2)) |> standard_tvars |> close_derivation \<^here> |> tap (expose_proof thy2) |> trim_context)); val proven = is_classrel thy1; val preds = Graph.Keys.fold (fn c1 => proven (c1, c) ? cons c1) all_preds []; val succs = Graph.Keys.fold (fn c2 => proven (c, c2) ? cons c2) all_succs []; in fold_product compl preds succs (finished1, thy1) end; in (case Graph.fold complete (Sorts.classes_of (Sign.classes_of thy)) (true, thy) of (true, _) => NONE | (_, thy') => SOME thy') end; (* type arities *) fun thynames_of_arity thy (a, c) = (get_arities thy, []) |-> Aritytab.fold (fn ((a', _, c'), (_, name, ser)) => (a = a' andalso c = c') ? cons (name, ser)) |> sort (int_ord o apply2 #2) |> map #1; fun insert_arity_completions thy ((t, Ss, c), (th, thy_name, ser)) (finished, arities) = let val completions = Sign.super_classes thy c |> map_filter (fn c1 => if Aritytab.defined arities (t, Ss, c1) then NONE else let val th1 = (th RS the_classrel thy (c, c1)) |> standard_tvars |> close_derivation \<^here> |> tap (expose_proof thy) |> trim_context; in SOME ((t, Ss, c1), (th1, thy_name, ser)) end); val finished' = finished andalso null completions; val arities' = fold Aritytab.update completions arities; in (finished', arities') end; fun complete_arities thy = let val arities = get_arities thy; val (finished, arities') = Aritytab.fold (insert_arity_completions thy) arities (true, get_arities thy); in if finished then NONE else SOME (map_arities (K arities') thy) end; val _ = Theory.setup (Theory.at_begin complete_classrels #> Theory.at_begin complete_arities); (* primitive rules *) fun add_classrel raw_th thy = let val th = strip_shyps (transfer thy raw_th); val th' = th |> unconstrainT |> tap (expose_proof thy) |> trim_context; val prop = plain_prop_of th; val (c1, c2) = Logic.dest_classrel prop; in thy |> Sign.primitive_classrel (c1, c2) |> map_classrels (Symreltab.update ((c1, c2), th')) |> perhaps complete_classrels |> perhaps complete_arities end; fun add_arity raw_th thy = let val th = strip_shyps (transfer thy raw_th); val th' = th |> unconstrainT |> tap (expose_proof thy) |> trim_context; val prop = plain_prop_of th; val (t, Ss, c) = Logic.dest_arity prop; val ar = ((t, Ss, c), (th', Context.theory_name thy, serial ())); in thy |> Sign.primitive_arity (t, Ss, [c]) |> map_arities (Aritytab.update ar #> curry (insert_arity_completions thy ar) true #> #2) end; end; structure Basic_Thm: BASIC_THM = Thm; open Basic_Thm;