author | wenzelm |
Sat, 30 Dec 2023 12:12:43 +0100 | |
changeset 79387 | 25fa3bc05a51 |
parent 79386 | bd52ab785b7b |
child 79389 | 10925576fbb4 |
permissions | -rw-r--r-- |
250 | 1 |
(* Title: Pure/thm.ML |
2 |
Author: Lawrence C Paulson, Cambridge University Computer Laboratory |
|
29269
5c25a2012975
moved term order operations to structure TermOrd (cf. Pure/term_ord.ML);
wenzelm
parents:
29003
diff
changeset
|
3 |
Author: Makarius |
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
4 |
|
16425
2427be27cc60
accomodate identification of type Sign.sg and theory;
wenzelm
parents:
16352
diff
changeset
|
5 |
The very core of Isabelle's Meta Logic: certified types and terms, |
59589 | 6 |
derivations, theorems, inference rules (including lifting and |
28321
9f4499bf9384
type thm: fully internal derivation, no longer exported;
wenzelm
parents:
28290
diff
changeset
|
7 |
resolution), oracles. |
0 | 8 |
*) |
9 |
||
70456
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
10 |
infix 0 RS RSN; |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
11 |
|
6089 | 12 |
signature BASIC_THM = |
59589 | 13 |
sig |
59582 | 14 |
type ctyp |
15 |
type cterm |
|
16 |
exception CTERM of string * cterm list |
|
17 |
type thm |
|
18 |
type conv = cterm -> thm |
|
19 |
exception THM of string * int * thm list |
|
70456
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
20 |
val RSN: thm * (int * thm) -> thm |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
21 |
val RS: thm * thm -> thm |
59582 | 22 |
end; |
23 |
||
24 |
signature THM = |
|
25 |
sig |
|
26 |
include BASIC_THM |
|
1160 | 27 |
(*certified types*) |
16425
2427be27cc60
accomodate identification of type Sign.sg and theory;
wenzelm
parents:
16352
diff
changeset
|
28 |
val typ_of: ctyp -> typ |
59621
291934bac95e
Thm.cterm_of and Thm.ctyp_of operate on local context;
wenzelm
parents:
59591
diff
changeset
|
29 |
val global_ctyp_of: theory -> typ -> ctyp |
291934bac95e
Thm.cterm_of and Thm.ctyp_of operate on local context;
wenzelm
parents:
59591
diff
changeset
|
30 |
val ctyp_of: Proof.context -> typ -> ctyp |
59582 | 31 |
val dest_ctyp: ctyp -> ctyp list |
70159 | 32 |
val dest_ctypN: int -> ctyp -> ctyp |
33 |
val dest_ctyp0: ctyp -> ctyp |
|
34 |
val dest_ctyp1: ctyp -> ctyp |
|
70156 | 35 |
val make_ctyp: ctyp -> ctyp list -> ctyp |
1160 | 36 |
(*certified terms*) |
16425
2427be27cc60
accomodate identification of type Sign.sg and theory;
wenzelm
parents:
16352
diff
changeset
|
37 |
val term_of: cterm -> term |
59586 | 38 |
val typ_of_cterm: cterm -> typ |
39 |
val ctyp_of_cterm: cterm -> ctyp |
|
40 |
val maxidx_of_cterm: cterm -> int |
|
59621
291934bac95e
Thm.cterm_of and Thm.ctyp_of operate on local context;
wenzelm
parents:
59591
diff
changeset
|
41 |
val global_cterm_of: theory -> term -> cterm |
291934bac95e
Thm.cterm_of and Thm.ctyp_of operate on local context;
wenzelm
parents:
59591
diff
changeset
|
42 |
val cterm_of: Proof.context -> term -> cterm |
59969
bcccad156236
explicitly checked alpha conversion -- actual renaming happens outside kernel;
wenzelm
parents:
59917
diff
changeset
|
43 |
val renamed_term: term -> cterm -> cterm |
74270 | 44 |
val fast_term_ord: cterm ord |
45 |
val term_ord: cterm ord |
|
59582 | 46 |
val dest_comb: cterm -> cterm * cterm |
47 |
val dest_fun: cterm -> cterm |
|
48 |
val dest_arg: cterm -> cterm |
|
49 |
val dest_fun2: cterm -> cterm |
|
50 |
val dest_arg1: cterm -> cterm |
|
74525
c960bfcb91db
discontinued Term.dest_abs / Logic.dest_all, which are officially superseded by Variable.dest_abs etc., but there are also Term.dest_abs_global to recover existing tools easily;
wenzelm
parents:
74518
diff
changeset
|
51 |
val dest_abs_fresh: string -> cterm -> cterm * cterm |
c960bfcb91db
discontinued Term.dest_abs / Logic.dest_all, which are officially superseded by Variable.dest_abs etc., but there are also Term.dest_abs_global to recover existing tools easily;
wenzelm
parents:
74518
diff
changeset
|
52 |
val dest_abs_global: cterm -> cterm * cterm |
60952
762cb38a3147
produce certified vars without access to theory_of_thm, and without context;
wenzelm
parents:
60951
diff
changeset
|
53 |
val rename_tvar: indexname -> ctyp -> ctyp |
60951
b70c4db3874f
produce certified vars without access to theory_of_thm, and without context;
wenzelm
parents:
60949
diff
changeset
|
54 |
val var: indexname * ctyp -> cterm |
59582 | 55 |
val apply: cterm -> cterm -> cterm |
56 |
val lambda_name: string * cterm -> cterm -> cterm |
|
57 |
val lambda: cterm -> cterm -> cterm |
|
58 |
val adjust_maxidx_cterm: int -> cterm -> cterm |
|
59 |
val incr_indexes_cterm: int -> cterm -> cterm |
|
74282 | 60 |
val match: cterm * cterm -> ctyp TVars.table * cterm Vars.table |
61 |
val first_order_match: cterm * cterm -> ctyp TVars.table * cterm Vars.table |
|
28321
9f4499bf9384
type thm: fully internal derivation, no longer exported;
wenzelm
parents:
28290
diff
changeset
|
62 |
(*theorems*) |
74241
eb265f54e3ce
more efficient operations: traverse hyps only when required;
wenzelm
parents:
74235
diff
changeset
|
63 |
val fold_terms: {hyps: bool} -> (term -> 'a -> 'a) -> thm -> 'a -> 'a |
74244 | 64 |
val fold_atomic_ctyps: {hyps: bool} -> (typ -> bool) -> (ctyp -> 'a -> 'a) -> thm -> 'a -> 'a |
65 |
val fold_atomic_cterms: {hyps: bool} -> (term -> bool) -> (cterm -> 'a -> 'a) -> thm -> 'a -> 'a |
|
59582 | 66 |
val terms_of_tpairs: (term * term) list -> term list |
67 |
val full_prop_of: thm -> term |
|
65458 | 68 |
val theory_id: thm -> Context.theory_id |
77889
5db014c36f42
clarified signature: explicitly distinguish theory_base_name vs. theory_long_name;
wenzelm
parents:
77877
diff
changeset
|
69 |
val theory_name: {long: bool} -> thm -> string |
5db014c36f42
clarified signature: explicitly distinguish theory_base_name vs. theory_long_name;
wenzelm
parents:
77877
diff
changeset
|
70 |
val theory_long_name: thm -> string |
5db014c36f42
clarified signature: explicitly distinguish theory_base_name vs. theory_long_name;
wenzelm
parents:
77877
diff
changeset
|
71 |
val theory_base_name: thm -> string |
59582 | 72 |
val maxidx_of: thm -> int |
73 |
val maxidx_thm: thm -> int -> int |
|
77869 | 74 |
val shyps_of: thm -> sort Ord_List.T |
77863
760515c45864
revert b43ee37926a9 due to problems with AFP/PAPP_Impossibility;
wenzelm
parents:
77827
diff
changeset
|
75 |
val hyps_of: thm -> term list |
16425
2427be27cc60
accomodate identification of type Sign.sg and theory;
wenzelm
parents:
16352
diff
changeset
|
76 |
val prop_of: thm -> term |
59582 | 77 |
val tpairs_of: thm -> (term * term) list |
16656 | 78 |
val concl_of: thm -> term |
16425
2427be27cc60
accomodate identification of type Sign.sg and theory;
wenzelm
parents:
16352
diff
changeset
|
79 |
val prems_of: thm -> term list |
2427be27cc60
accomodate identification of type Sign.sg and theory;
wenzelm
parents:
16352
diff
changeset
|
80 |
val nprems_of: thm -> int |
59582 | 81 |
val no_prems: thm -> bool |
82 |
val major_prem_of: thm -> term |
|
16425
2427be27cc60
accomodate identification of type Sign.sg and theory;
wenzelm
parents:
16352
diff
changeset
|
83 |
val cprop_of: thm -> cterm |
18145 | 84 |
val cprem_of: thm -> int -> cterm |
69101
991a3feaf270
more direct implementation of distinct_subgoals_tac -- potentially more efficient;
wenzelm
parents:
68692
diff
changeset
|
85 |
val cconcl_of: thm -> cterm |
991a3feaf270
more direct implementation of distinct_subgoals_tac -- potentially more efficient;
wenzelm
parents:
68692
diff
changeset
|
86 |
val cprems_of: thm -> cterm list |
60949 | 87 |
val chyps_of: thm -> cterm list |
74270 | 88 |
val thm_ord: thm ord |
61051 | 89 |
exception CONTEXT of string * ctyp list * cterm list * thm list * Context.generic option |
90 |
val theory_of_cterm: cterm -> theory |
|
91 |
val theory_of_thm: thm -> theory |
|
67697 | 92 |
val trim_context_ctyp: ctyp -> ctyp |
61051 | 93 |
val trim_context_cterm: cterm -> cterm |
70156 | 94 |
val transfer_ctyp: theory -> ctyp -> ctyp |
78135 | 95 |
val transfer_ctyp': Proof.context -> ctyp -> ctyp |
96 |
val transfer_ctyp'': Context.generic -> ctyp -> ctyp |
|
61051 | 97 |
val transfer_cterm: theory -> cterm -> cterm |
78135 | 98 |
val transfer_cterm': Proof.context -> cterm -> cterm |
99 |
val transfer_cterm'': Context.generic -> cterm -> cterm |
|
38709 | 100 |
val transfer: theory -> thm -> thm |
67649 | 101 |
val transfer': Proof.context -> thm -> thm |
102 |
val transfer'': Context.generic -> thm -> thm |
|
70310
c82f59c47aaf
clarified transfer_morphism: implicit join_certificate, e.g. relevant for complex cascades of morphisms such as class locale interpretation;
wenzelm
parents:
70159
diff
changeset
|
103 |
val join_transfer: theory -> thm -> thm |
70313 | 104 |
val join_transfer_context: Proof.context * thm -> Proof.context * thm |
59969
bcccad156236
explicitly checked alpha conversion -- actual renaming happens outside kernel;
wenzelm
parents:
59917
diff
changeset
|
105 |
val renamed_prop: term -> thm -> thm |
38709 | 106 |
val weaken: cterm -> thm -> thm |
77869 | 107 |
val weaken_sorts: sort list -> cterm -> cterm |
44333
cc53ce50f738
reverted to join_bodies/join_proofs based on fold_body_thms to regain performance (escpecially of HOL-Proofs) -- see also aa9c1e9ef2ce and 4e2abb045eac;
wenzelm
parents:
44331
diff
changeset
|
108 |
val proof_bodies_of: thm list -> proof_body list |
32725 | 109 |
val proof_body_of: thm -> proof_body |
110 |
val proof_of: thm -> proof |
|
71088 | 111 |
val reconstruct_proof_of: thm -> Proofterm.proof |
66168 | 112 |
val consolidate: thm list -> unit |
71011 | 113 |
val expose_proofs: theory -> thm list -> unit |
71017
c85efa2be619
expose derivations more thoroughly, notably for locale/class reasoning;
wenzelm
parents:
71012
diff
changeset
|
114 |
val expose_proof: theory -> thm -> unit |
32725 | 115 |
val future: thm future -> cterm -> thm |
77866 | 116 |
val thm_deps: thm -> Proofterm.thm Ord_List.T |
77869 | 117 |
val extra_shyps: thm -> sort list |
71527 | 118 |
val strip_shyps: thm -> thm |
64568
a504a3dec35a
more careful derivation_closed / close_derivation;
wenzelm
parents:
63858
diff
changeset
|
119 |
val derivation_closed: thm -> bool |
36744
6e1f3d609a68
renamed Thm.get_name -> Thm.derivation_name and Thm.put_name -> Thm.name_derivation, to emphasize the true nature of these operations;
wenzelm
parents:
36742
diff
changeset
|
120 |
val derivation_name: thm -> string |
70554 | 121 |
val derivation_id: thm -> Proofterm.thm_id option |
70543
33749040b6f8
clarified derivation_name vs. raw_derivation_name;
wenzelm
parents:
70517
diff
changeset
|
122 |
val raw_derivation_name: thm -> string |
70915
bd4d37edfee4
clarified expand_proof/expand_name: allow more detailed control via thm_header;
wenzelm
parents:
70908
diff
changeset
|
123 |
val expand_name: thm -> Proofterm.thm_header -> string option |
70494 | 124 |
val name_derivation: string * Position.T -> thm -> thm |
125 |
val close_derivation: Position.T -> thm -> thm |
|
70480
1a1b7d7f24bb
explicit check of left-over constraints from different theory, e.g. due to lack of Thm.trim_context;
wenzelm
parents:
70475
diff
changeset
|
126 |
val trim_context: thm -> thm |
28675
fb68c0767004
renamed get_axiom_i to axiom, removed obsolete get_axiom;
wenzelm
parents:
28648
diff
changeset
|
127 |
val axiom: theory -> string -> thm |
70923
98d9b78b7f47
clarified axiom_table: uniform space (e.g. like consts), e.g. relevant for export of HOL-ex.Join_Theory;
wenzelm
parents:
70915
diff
changeset
|
128 |
val all_axioms_of: theory -> (string * thm) list |
28017 | 129 |
val get_tags: thm -> Properties.T |
130 |
val map_tags: (Properties.T -> Properties.T) -> thm -> thm |
|
23781
ab793a6ddf9f
Added function norm_proof for normalizing the proof term
berghofe
parents:
23657
diff
changeset
|
131 |
val norm_proof: thm -> thm |
20261 | 132 |
val adjust_maxidx_thm: int -> thm -> thm |
70458 | 133 |
(*type classes*) |
134 |
val the_classrel: theory -> class * class -> thm |
|
135 |
val the_arity: theory -> string * sort list * class -> thm |
|
136 |
val classrel_proof: theory -> class * class -> proof |
|
137 |
val arity_proof: theory -> string * sort list * class -> proof |
|
70454 | 138 |
(*oracles*) |
139 |
val add_oracle: binding * ('a -> cterm) -> theory -> (string * ('a -> thm)) * theory |
|
70560 | 140 |
val oracle_space: theory -> Name_Space.T |
141 |
val pretty_oracle: Proof.context -> string -> Pretty.T |
|
70454 | 142 |
val extern_oracles: bool -> Proof.context -> (Markup.T * xstring) list |
70565 | 143 |
val check_oracle: Proof.context -> xstring * Position.T -> string |
59589 | 144 |
(*inference rules*) |
38709 | 145 |
val assume: cterm -> thm |
146 |
val implies_intr: cterm -> thm -> thm |
|
147 |
val implies_elim: thm -> thm -> thm |
|
148 |
val forall_intr: cterm -> thm -> thm |
|
149 |
val forall_elim: cterm -> thm -> thm |
|
150 |
val reflexive: cterm -> thm |
|
151 |
val symmetric: thm -> thm |
|
152 |
val transitive: thm -> thm -> thm |
|
153 |
val beta_conversion: bool -> conv |
|
154 |
val eta_conversion: conv |
|
155 |
val eta_long_conversion: conv |
|
156 |
val abstract_rule: string -> cterm -> thm -> thm |
|
157 |
val combination: thm -> thm -> thm |
|
158 |
val equal_intr: thm -> thm -> thm |
|
159 |
val equal_elim: thm -> thm -> thm |
|
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
160 |
val solve_constraints: thm -> thm |
58950
d07464875dd4
optional proof context for unify operations, for the sake of proper local options;
wenzelm
parents:
58946
diff
changeset
|
161 |
val flexflex_rule: Proof.context option -> thm -> thm Seq.seq |
74266 | 162 |
val generalize: Names.set * Names.set -> int -> thm -> thm |
163 |
val generalize_cterm: Names.set * Names.set -> int -> cterm -> cterm |
|
164 |
val generalize_ctyp: Names.set -> int -> ctyp -> ctyp |
|
74282 | 165 |
val instantiate: ctyp TVars.table * cterm Vars.table -> thm -> thm |
74577
d4829a7333e2
clarified instantiation: local beta reduction after substitution, as for Envir.expand_term_defs;
wenzelm
parents:
74561
diff
changeset
|
166 |
val instantiate_beta: ctyp TVars.table * cterm Vars.table -> thm -> thm |
74282 | 167 |
val instantiate_cterm: ctyp TVars.table * cterm Vars.table -> cterm -> cterm |
74577
d4829a7333e2
clarified instantiation: local beta reduction after substitution, as for Envir.expand_term_defs;
wenzelm
parents:
74561
diff
changeset
|
168 |
val instantiate_beta_cterm: ctyp TVars.table * cterm Vars.table -> cterm -> cterm |
38709 | 169 |
val trivial: cterm -> thm |
36330
0584e203960e
renamed Drule.unconstrainTs to Thm.unconstrain_allTs to accomdate the version by krauss/schropp;
wenzelm
parents:
35986
diff
changeset
|
170 |
val of_class: ctyp * class -> thm |
36768
46be86127972
just one version of Thm.unconstrainT, which affects all variables;
wenzelm
parents:
36744
diff
changeset
|
171 |
val unconstrainT: thm -> thm |
79134 | 172 |
val varifyT_global': TFrees.set -> thm -> ((string * sort) * (indexname * sort)) list * thm |
38709 | 173 |
val varifyT_global: thm -> thm |
36615
88756a5a92fc
renamed Thm.freezeT to Thm.legacy_freezeT -- it is based on Type.legacy_freeze;
wenzelm
parents:
36614
diff
changeset
|
174 |
val legacy_freezeT: thm -> thm |
70456
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
175 |
val plain_prop_of: thm -> term |
79365 | 176 |
val get_zproof_serials: theory -> serial list |
79362
2187de552bd4
clarified stored data: actual thm allows to replay zproofs in a modular manner;
wenzelm
parents:
79335
diff
changeset
|
177 |
val get_zproof: theory -> serial -> {name: Thm_Name.T * Position.T, thm: thm} option |
79329 | 178 |
val store_zproof: Thm_Name.T * Position.T -> thm -> theory -> thm * theory |
59969
bcccad156236
explicitly checked alpha conversion -- actual renaming happens outside kernel;
wenzelm
parents:
59917
diff
changeset
|
179 |
val dest_state: thm * int -> (term * term) list * term list * term * term |
38709 | 180 |
val lift_rule: cterm -> thm -> thm |
181 |
val incr_indexes: int -> thm -> thm |
|
58950
d07464875dd4
optional proof context for unify operations, for the sake of proper local options;
wenzelm
parents:
58946
diff
changeset
|
182 |
val assumption: Proof.context option -> int -> thm -> thm Seq.seq |
31945 | 183 |
val eq_assumption: int -> thm -> thm |
184 |
val rotate_rule: int -> int -> thm -> thm |
|
185 |
val permute_prems: int -> int -> thm -> thm |
|
58950
d07464875dd4
optional proof context for unify operations, for the sake of proper local options;
wenzelm
parents:
58946
diff
changeset
|
186 |
val bicompose: Proof.context option -> {flatten: bool, match: bool, incremented: bool} -> |
52223
5bb6ae8acb87
tuned signature -- more explicit flags for low-level Thm.bicompose;
wenzelm
parents:
52222
diff
changeset
|
187 |
bool * thm * int -> int -> thm -> thm Seq.seq |
58950
d07464875dd4
optional proof context for unify operations, for the sake of proper local options;
wenzelm
parents:
58946
diff
changeset
|
188 |
val biresolution: Proof.context option -> bool -> (bool * thm) list -> int -> thm -> thm Seq.seq |
77891 | 189 |
val theory_names_of_arity: {long: bool} -> theory -> string * class -> string list |
70456
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
190 |
val add_classrel: thm -> theory -> theory |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
191 |
val add_arity: thm -> theory -> theory |
6089 | 192 |
end; |
193 |
||
32590
95f4f08f950f
replaced opaque signature matching by plain old abstype (again, cf. ac4498f95d1c) -- this recovers pretty printing in SML/NJ and Poly/ML 5.3;
wenzelm
parents:
32198
diff
changeset
|
194 |
structure Thm: THM = |
0 | 195 |
struct |
250 | 196 |
|
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
197 |
(*** Certified terms and types ***) |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
198 |
|
250 | 199 |
(** certified types **) |
200 |
||
77869 | 201 |
datatype ctyp = Ctyp of {cert: Context.certificate, T: typ, maxidx: int, sorts: sort Ord_List.T}; |
250 | 202 |
|
203 |
fun typ_of (Ctyp {T, ...}) = T; |
|
204 |
||
59621
291934bac95e
Thm.cterm_of and Thm.ctyp_of operate on local context;
wenzelm
parents:
59591
diff
changeset
|
205 |
fun global_ctyp_of thy raw_T = |
24143
90a9a6fe0d01
replaced Theory.self_ref by Theory.check_thy, which now produces a checked ref;
wenzelm
parents:
23781
diff
changeset
|
206 |
let |
90a9a6fe0d01
replaced Theory.self_ref by Theory.check_thy, which now produces a checked ref;
wenzelm
parents:
23781
diff
changeset
|
207 |
val T = Sign.certify_typ thy raw_T; |
90a9a6fe0d01
replaced Theory.self_ref by Theory.check_thy, which now produces a checked ref;
wenzelm
parents:
23781
diff
changeset
|
208 |
val maxidx = Term.maxidx_of_typ T; |
77869 | 209 |
val sorts = Sorts.insert_typ T []; |
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
210 |
in Ctyp {cert = Context.Certificate thy, T = T, maxidx = maxidx, sorts = sorts} end; |
250 | 211 |
|
59621
291934bac95e
Thm.cterm_of and Thm.ctyp_of operate on local context;
wenzelm
parents:
59591
diff
changeset
|
212 |
val ctyp_of = global_ctyp_of o Proof_Context.theory_of; |
291934bac95e
Thm.cterm_of and Thm.ctyp_of operate on local context;
wenzelm
parents:
59591
diff
changeset
|
213 |
|
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
214 |
fun dest_ctyp (Ctyp {cert, T = Type (_, Ts), maxidx, sorts}) = |
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
215 |
map (fn T => Ctyp {cert = cert, T = T, maxidx = maxidx, sorts = sorts}) Ts |
16679 | 216 |
| dest_ctyp cT = raise TYPE ("dest_ctyp", [typ_of cT], []); |
15087 | 217 |
|
70159 | 218 |
fun dest_ctypN n (Ctyp {cert, T, maxidx, sorts}) = |
219 |
let fun err () = raise TYPE ("dest_ctypN", [T], []) in |
|
70153
8a23083ac011
prefer exception TYPE, e.g. when used within conversion;
wenzelm
parents:
70150
diff
changeset
|
220 |
(case T of |
8a23083ac011
prefer exception TYPE, e.g. when used within conversion;
wenzelm
parents:
70150
diff
changeset
|
221 |
Type (_, Ts) => |
70159 | 222 |
Ctyp {cert = cert, T = nth Ts n handle General.Subscript => err (), |
70153
8a23083ac011
prefer exception TYPE, e.g. when used within conversion;
wenzelm
parents:
70150
diff
changeset
|
223 |
maxidx = maxidx, sorts = sorts} |
8a23083ac011
prefer exception TYPE, e.g. when used within conversion;
wenzelm
parents:
70150
diff
changeset
|
224 |
| _ => err ()) |
8a23083ac011
prefer exception TYPE, e.g. when used within conversion;
wenzelm
parents:
70150
diff
changeset
|
225 |
end; |
70150 | 226 |
|
70159 | 227 |
val dest_ctyp0 = dest_ctypN 0; |
228 |
val dest_ctyp1 = dest_ctypN 1; |
|
229 |
||
70156 | 230 |
fun join_certificate_ctyp (Ctyp {cert, ...}) cert0 = Context.join_certificate (cert0, cert); |
77869 | 231 |
fun union_sorts_ctyp (Ctyp {sorts, ...}) sorts0 = Sorts.union sorts0 sorts; |
70156 | 232 |
fun maxidx_ctyp (Ctyp {maxidx, ...}) maxidx0 = Int.max (maxidx0, maxidx); |
233 |
||
234 |
fun make_ctyp (Ctyp {cert, T, maxidx = _, sorts = _}) cargs = |
|
235 |
let |
|
236 |
val As = map typ_of cargs; |
|
237 |
fun err () = raise TYPE ("make_ctyp", T :: As, []); |
|
238 |
in |
|
239 |
(case T of |
|
240 |
Type (a, args) => |
|
241 |
Ctyp { |
|
242 |
cert = fold join_certificate_ctyp cargs cert, |
|
243 |
maxidx = fold maxidx_ctyp cargs ~1, |
|
77869 | 244 |
sorts = fold union_sorts_ctyp cargs [], |
70156 | 245 |
T = if length args = length cargs then Type (a, As) else err ()} |
246 |
| _ => err ()) |
|
247 |
end; |
|
248 |
||
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
249 |
|
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
250 |
|
250 | 251 |
(** certified terms **) |
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
252 |
|
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
253 |
(*certified terms with checked typ, maxidx, and sorts*) |
70453
492cb3aaa562
simplified module structure: back to plain datatype (see 95f4f08f950f and 70019ab5e57f);
wenzelm
parents:
70404
diff
changeset
|
254 |
datatype cterm = |
77869 | 255 |
Cterm of {cert: Context.certificate, t: term, T: typ, maxidx: int, sorts: sort Ord_List.T}; |
16425
2427be27cc60
accomodate identification of type Sign.sg and theory;
wenzelm
parents:
16352
diff
changeset
|
256 |
|
22584 | 257 |
exception CTERM of string * cterm list; |
16679 | 258 |
|
250 | 259 |
fun term_of (Cterm {t, ...}) = t; |
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
260 |
|
59586 | 261 |
fun typ_of_cterm (Cterm {T, ...}) = T; |
262 |
||
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
263 |
fun ctyp_of_cterm (Cterm {cert, T, maxidx, sorts, ...}) = |
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
264 |
Ctyp {cert = cert, T = T, maxidx = maxidx, sorts = sorts}; |
2671 | 265 |
|
59586 | 266 |
fun maxidx_of_cterm (Cterm {maxidx, ...}) = maxidx; |
267 |
||
59621
291934bac95e
Thm.cterm_of and Thm.ctyp_of operate on local context;
wenzelm
parents:
59591
diff
changeset
|
268 |
fun global_cterm_of thy tm = |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
269 |
let |
18969 | 270 |
val (t, T, maxidx) = Sign.certify_term thy tm; |
77869 | 271 |
val sorts = Sorts.insert_term t []; |
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
272 |
in Cterm {cert = Context.Certificate thy, t = t, T = T, maxidx = maxidx, sorts = sorts} end; |
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
273 |
|
59621
291934bac95e
Thm.cterm_of and Thm.ctyp_of operate on local context;
wenzelm
parents:
59591
diff
changeset
|
274 |
val cterm_of = global_cterm_of o Proof_Context.theory_of; |
291934bac95e
Thm.cterm_of and Thm.ctyp_of operate on local context;
wenzelm
parents:
59591
diff
changeset
|
275 |
|
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
276 |
fun join_certificate0 (Cterm {cert = cert1, ...}, Cterm {cert = cert2, ...}) = |
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
277 |
Context.join_certificate (cert1, cert2); |
60315 | 278 |
|
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
279 |
fun renamed_term t' (Cterm {cert, t, T, maxidx, sorts}) = |
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
280 |
if t aconv t' then Cterm {cert = cert, t = t', T = T, maxidx = maxidx, sorts = sorts} |
59969
bcccad156236
explicitly checked alpha conversion -- actual renaming happens outside kernel;
wenzelm
parents:
59917
diff
changeset
|
281 |
else raise TERM ("renamed_term: terms disagree", [t, t']); |
bcccad156236
explicitly checked alpha conversion -- actual renaming happens outside kernel;
wenzelm
parents:
59917
diff
changeset
|
282 |
|
74270 | 283 |
val fast_term_ord = Term_Ord.fast_term_ord o apply2 term_of; |
284 |
val term_ord = Term_Ord.term_ord o apply2 term_of; |
|
285 |
||
20580
6fb75df09253
added dest_arg, i.e. a tuned version of #2 o dest_comb;
wenzelm
parents:
20548
diff
changeset
|
286 |
|
22909 | 287 |
(* destructors *) |
288 |
||
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
289 |
fun dest_comb (Cterm {t = c $ a, T, cert, maxidx, sorts}) = |
22909 | 290 |
let val A = Term.argument_type_of c 0 in |
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
291 |
(Cterm {t = c, T = A --> T, cert = cert, maxidx = maxidx, sorts = sorts}, |
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
292 |
Cterm {t = a, T = A, cert = cert, maxidx = maxidx, sorts = sorts}) |
1493
e936723cb94d
added dest_comb, dest_abs and mk_prop for manipulating cterms
clasohm
parents:
1460
diff
changeset
|
293 |
end |
22584 | 294 |
| dest_comb ct = raise CTERM ("dest_comb", [ct]); |
1493
e936723cb94d
added dest_comb, dest_abs and mk_prop for manipulating cterms
clasohm
parents:
1460
diff
changeset
|
295 |
|
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
296 |
fun dest_fun (Cterm {t = c $ _, T, cert, maxidx, sorts}) = |
22909 | 297 |
let val A = Term.argument_type_of c 0 |
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
298 |
in Cterm {t = c, T = A --> T, cert = cert, maxidx = maxidx, sorts = sorts} end |
22909 | 299 |
| dest_fun ct = raise CTERM ("dest_fun", [ct]); |
300 |
||
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
301 |
fun dest_arg (Cterm {t = c $ a, T = _, cert, maxidx, sorts}) = |
22909 | 302 |
let val A = Term.argument_type_of c 0 |
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
303 |
in Cterm {t = a, T = A, cert = cert, maxidx = maxidx, sorts = sorts} end |
22584 | 304 |
| dest_arg ct = raise CTERM ("dest_arg", [ct]); |
20580
6fb75df09253
added dest_arg, i.e. a tuned version of #2 o dest_comb;
wenzelm
parents:
20548
diff
changeset
|
305 |
|
22909 | 306 |
|
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
307 |
fun dest_fun2 (Cterm {t = c $ _ $ _, T, cert, maxidx, sorts}) = |
22909 | 308 |
let |
309 |
val A = Term.argument_type_of c 0; |
|
310 |
val B = Term.argument_type_of c 1; |
|
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
311 |
in Cterm {t = c, T = A --> B --> T, cert = cert, maxidx = maxidx, sorts = sorts} end |
22909 | 312 |
| dest_fun2 ct = raise CTERM ("dest_fun2", [ct]); |
313 |
||
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
314 |
fun dest_arg1 (Cterm {t = c $ a $ _, T = _, cert, maxidx, sorts}) = |
22909 | 315 |
let val A = Term.argument_type_of c 0 |
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
316 |
in Cterm {t = a, T = A, cert = cert, maxidx = maxidx, sorts = sorts} end |
22909 | 317 |
| dest_arg1 ct = raise CTERM ("dest_arg1", [ct]); |
20673 | 318 |
|
74525
c960bfcb91db
discontinued Term.dest_abs / Logic.dest_all, which are officially superseded by Variable.dest_abs etc., but there are also Term.dest_abs_global to recover existing tools easily;
wenzelm
parents:
74518
diff
changeset
|
319 |
fun gen_dest_abs dest ct = |
c960bfcb91db
discontinued Term.dest_abs / Logic.dest_all, which are officially superseded by Variable.dest_abs etc., but there are also Term.dest_abs_global to recover existing tools easily;
wenzelm
parents:
74518
diff
changeset
|
320 |
(case ct of |
c960bfcb91db
discontinued Term.dest_abs / Logic.dest_all, which are officially superseded by Variable.dest_abs etc., but there are also Term.dest_abs_global to recover existing tools easily;
wenzelm
parents:
74518
diff
changeset
|
321 |
Cterm {t = t as Abs _, T = Type ("fun", [_, U]), cert, maxidx, sorts} => |
c960bfcb91db
discontinued Term.dest_abs / Logic.dest_all, which are officially superseded by Variable.dest_abs etc., but there are also Term.dest_abs_global to recover existing tools easily;
wenzelm
parents:
74518
diff
changeset
|
322 |
let |
c960bfcb91db
discontinued Term.dest_abs / Logic.dest_all, which are officially superseded by Variable.dest_abs etc., but there are also Term.dest_abs_global to recover existing tools easily;
wenzelm
parents:
74518
diff
changeset
|
323 |
val ((x', T), t') = dest t; |
c960bfcb91db
discontinued Term.dest_abs / Logic.dest_all, which are officially superseded by Variable.dest_abs etc., but there are also Term.dest_abs_global to recover existing tools easily;
wenzelm
parents:
74518
diff
changeset
|
324 |
val v = Cterm {t = Free (x', T), T = T, cert = cert, maxidx = maxidx, sorts = sorts}; |
c960bfcb91db
discontinued Term.dest_abs / Logic.dest_all, which are officially superseded by Variable.dest_abs etc., but there are also Term.dest_abs_global to recover existing tools easily;
wenzelm
parents:
74518
diff
changeset
|
325 |
val body = Cterm {t = t', T = U, cert = cert, maxidx = maxidx, sorts = sorts}; |
c960bfcb91db
discontinued Term.dest_abs / Logic.dest_all, which are officially superseded by Variable.dest_abs etc., but there are also Term.dest_abs_global to recover existing tools easily;
wenzelm
parents:
74518
diff
changeset
|
326 |
in (v, body) end |
c960bfcb91db
discontinued Term.dest_abs / Logic.dest_all, which are officially superseded by Variable.dest_abs etc., but there are also Term.dest_abs_global to recover existing tools easily;
wenzelm
parents:
74518
diff
changeset
|
327 |
| _ => raise CTERM ("dest_abs", [ct])); |
74518 | 328 |
|
74525
c960bfcb91db
discontinued Term.dest_abs / Logic.dest_all, which are officially superseded by Variable.dest_abs etc., but there are also Term.dest_abs_global to recover existing tools easily;
wenzelm
parents:
74518
diff
changeset
|
329 |
val dest_abs_fresh = gen_dest_abs o Term.dest_abs_fresh; |
c960bfcb91db
discontinued Term.dest_abs / Logic.dest_all, which are officially superseded by Variable.dest_abs etc., but there are also Term.dest_abs_global to recover existing tools easily;
wenzelm
parents:
74518
diff
changeset
|
330 |
val dest_abs_global = gen_dest_abs Term.dest_abs_global; |
1493
e936723cb94d
added dest_comb, dest_abs and mk_prop for manipulating cterms
clasohm
parents:
1460
diff
changeset
|
331 |
|
22909 | 332 |
|
333 |
(* constructors *) |
|
334 |
||
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
335 |
fun rename_tvar (a, i) (Ctyp {cert, T, maxidx, sorts}) = |
60952
762cb38a3147
produce certified vars without access to theory_of_thm, and without context;
wenzelm
parents:
60951
diff
changeset
|
336 |
let |
762cb38a3147
produce certified vars without access to theory_of_thm, and without context;
wenzelm
parents:
60951
diff
changeset
|
337 |
val S = |
762cb38a3147
produce certified vars without access to theory_of_thm, and without context;
wenzelm
parents:
60951
diff
changeset
|
338 |
(case T of |
762cb38a3147
produce certified vars without access to theory_of_thm, and without context;
wenzelm
parents:
60951
diff
changeset
|
339 |
TFree (_, S) => S |
762cb38a3147
produce certified vars without access to theory_of_thm, and without context;
wenzelm
parents:
60951
diff
changeset
|
340 |
| TVar (_, S) => S |
762cb38a3147
produce certified vars without access to theory_of_thm, and without context;
wenzelm
parents:
60951
diff
changeset
|
341 |
| _ => raise TYPE ("rename_tvar: no variable", [T], [])); |
762cb38a3147
produce certified vars without access to theory_of_thm, and without context;
wenzelm
parents:
60951
diff
changeset
|
342 |
val _ = if i < 0 then raise TYPE ("rename_tvar: bad index", [TVar ((a, i), S)], []) else (); |
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
343 |
in Ctyp {cert = cert, T = TVar ((a, i), S), maxidx = Int.max (i, maxidx), sorts = sorts} end; |
60952
762cb38a3147
produce certified vars without access to theory_of_thm, and without context;
wenzelm
parents:
60951
diff
changeset
|
344 |
|
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
345 |
fun var ((x, i), Ctyp {cert, T, maxidx, sorts}) = |
60951
b70c4db3874f
produce certified vars without access to theory_of_thm, and without context;
wenzelm
parents:
60949
diff
changeset
|
346 |
if i < 0 then raise TERM ("var: bad index", [Var ((x, i), T)]) |
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
347 |
else Cterm {cert = cert, t = Var ((x, i), T), T = T, maxidx = Int.max (i, maxidx), sorts = sorts}; |
60951
b70c4db3874f
produce certified vars without access to theory_of_thm, and without context;
wenzelm
parents:
60949
diff
changeset
|
348 |
|
46497
89ccf66aa73d
renamed Thm.capply to Thm.apply, and Thm.cabs to Thm.lambda in conformance with similar operations in structure Term and Logic;
wenzelm
parents:
46475
diff
changeset
|
349 |
fun apply |
16656 | 350 |
(cf as Cterm {t = f, T = Type ("fun", [dty, rty]), maxidx = maxidx1, sorts = sorts1, ...}) |
351 |
(cx as Cterm {t = x, T, maxidx = maxidx2, sorts = sorts2, ...}) = |
|
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
352 |
if T = dty then |
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
353 |
Cterm {cert = join_certificate0 (cf, cx), |
16656 | 354 |
t = f $ x, |
355 |
T = rty, |
|
356 |
maxidx = Int.max (maxidx1, maxidx2), |
|
77869 | 357 |
sorts = Sorts.union sorts1 sorts2} |
46497
89ccf66aa73d
renamed Thm.capply to Thm.apply, and Thm.cabs to Thm.lambda in conformance with similar operations in structure Term and Logic;
wenzelm
parents:
46475
diff
changeset
|
358 |
else raise CTERM ("apply: types don't agree", [cf, cx]) |
89ccf66aa73d
renamed Thm.capply to Thm.apply, and Thm.cabs to Thm.lambda in conformance with similar operations in structure Term and Logic;
wenzelm
parents:
46475
diff
changeset
|
359 |
| apply cf cx = raise CTERM ("apply: first arg is not a function", [cf, cx]); |
250 | 360 |
|
46497
89ccf66aa73d
renamed Thm.capply to Thm.apply, and Thm.cabs to Thm.lambda in conformance with similar operations in structure Term and Logic;
wenzelm
parents:
46475
diff
changeset
|
361 |
fun lambda_name |
32198 | 362 |
(x, ct1 as Cterm {t = t1, T = T1, maxidx = maxidx1, sorts = sorts1, ...}) |
16656 | 363 |
(ct2 as Cterm {t = t2, T = T2, maxidx = maxidx2, sorts = sorts2, ...}) = |
32198 | 364 |
let val t = Term.lambda_name (x, t1) t2 in |
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
365 |
Cterm {cert = join_certificate0 (ct1, ct2), |
16656 | 366 |
t = t, T = T1 --> T2, |
367 |
maxidx = Int.max (maxidx1, maxidx2), |
|
77869 | 368 |
sorts = Sorts.union sorts1 sorts2} |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
369 |
end; |
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
370 |
|
46497
89ccf66aa73d
renamed Thm.capply to Thm.apply, and Thm.cabs to Thm.lambda in conformance with similar operations in structure Term and Logic;
wenzelm
parents:
46475
diff
changeset
|
371 |
fun lambda t u = lambda_name ("", t) u; |
32198 | 372 |
|
20580
6fb75df09253
added dest_arg, i.e. a tuned version of #2 o dest_comb;
wenzelm
parents:
20548
diff
changeset
|
373 |
|
22909 | 374 |
(* indexes *) |
375 |
||
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
376 |
fun adjust_maxidx_cterm i (ct as Cterm {cert, t, T, maxidx, sorts}) = |
20580
6fb75df09253
added dest_arg, i.e. a tuned version of #2 o dest_comb;
wenzelm
parents:
20548
diff
changeset
|
377 |
if maxidx = i then ct |
6fb75df09253
added dest_arg, i.e. a tuned version of #2 o dest_comb;
wenzelm
parents:
20548
diff
changeset
|
378 |
else if maxidx < i then |
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
379 |
Cterm {maxidx = i, cert = cert, t = t, T = T, sorts = sorts} |
20580
6fb75df09253
added dest_arg, i.e. a tuned version of #2 o dest_comb;
wenzelm
parents:
20548
diff
changeset
|
380 |
else |
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
381 |
Cterm {maxidx = Int.max (maxidx_of_term t, i), cert = cert, t = t, T = T, sorts = sorts}; |
20580
6fb75df09253
added dest_arg, i.e. a tuned version of #2 o dest_comb;
wenzelm
parents:
20548
diff
changeset
|
382 |
|
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
383 |
fun incr_indexes_cterm i (ct as Cterm {cert, t, T, maxidx, sorts}) = |
22909 | 384 |
if i < 0 then raise CTERM ("negative increment", [ct]) |
385 |
else if i = 0 then ct |
|
79232 | 386 |
else Cterm {cert = cert, t = Logic.incr_indexes ([], i) t, |
22909 | 387 |
T = Logic.incr_tvar i T, maxidx = maxidx + i, sorts = sorts}; |
388 |
||
389 |
||
2509 | 390 |
|
28321
9f4499bf9384
type thm: fully internal derivation, no longer exported;
wenzelm
parents:
28290
diff
changeset
|
391 |
(*** Derivations and Theorems ***) |
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
392 |
|
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
393 |
(* sort constraints *) |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
394 |
|
70480
1a1b7d7f24bb
explicit check of left-over constraints from different theory, e.g. due to lack of Thm.trim_context;
wenzelm
parents:
70475
diff
changeset
|
395 |
type constraint = {theory: theory, typ: typ, sort: sort}; |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
396 |
|
77868 | 397 |
local |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
398 |
|
77868 | 399 |
val constraint_ord : constraint ord = |
400 |
Context.theory_id_ord o apply2 (Context.theory_id o #theory) |
|
401 |
||| Term_Ord.typ_ord o apply2 #typ |
|
402 |
||| Term_Ord.sort_ord o apply2 #sort; |
|
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
403 |
|
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
404 |
val smash_atyps = |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
405 |
map_atyps (fn TVar (_, S) => Term.aT S | TFree (_, S) => Term.aT S | T => T); |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
406 |
|
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
407 |
in |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
408 |
|
77868 | 409 |
val union_constraints = Ord_List.union constraint_ord; |
410 |
||
79304 | 411 |
fun insert_constraints _ (_, []) = I |
412 |
| insert_constraints thy (T, S) = |
|
413 |
let |
|
414 |
val ignored = |
|
415 |
(case T of |
|
416 |
TFree (_, S') => S = S' |
|
417 |
| TVar (_, S') => S = S' |
|
418 |
| _ => false); |
|
419 |
in |
|
420 |
if ignored then I |
|
421 |
else Ord_List.insert constraint_ord {theory = thy, typ = smash_atyps T, sort = S} |
|
422 |
end; |
|
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
423 |
|
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
424 |
fun insert_constraints_env thy env = |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
425 |
let |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
426 |
val tyenv = Envir.type_env env; |
79305 | 427 |
val normT = Envir.norm_type tyenv; |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
428 |
fun insert ([], _) = I |
79305 | 429 |
| insert (S, T) = insert_constraints thy (normT T, S); |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
430 |
in tyenv |> Vartab.fold (insert o #2) end; |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
431 |
|
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
432 |
end; |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
433 |
|
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
434 |
|
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
435 |
(* datatype thm *) |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
436 |
|
70453
492cb3aaa562
simplified module structure: back to plain datatype (see 95f4f08f950f and 70019ab5e57f);
wenzelm
parents:
70404
diff
changeset
|
437 |
datatype thm = Thm of |
40124 | 438 |
deriv * (*derivation*) |
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
439 |
{cert: Context.certificate, (*background theory certificate*) |
40124 | 440 |
tags: Properties.T, (*additional annotations/comments*) |
441 |
maxidx: int, (*maximum index of any Var or TVar*) |
|
77868 | 442 |
constraints: constraint Ord_List.T, (*implicit proof obligations for sort constraints*) |
77869 | 443 |
shyps: sort Ord_List.T, (*sort hypotheses*) |
77863
760515c45864
revert b43ee37926a9 due to problems with AFP/PAPP_Impossibility;
wenzelm
parents:
77827
diff
changeset
|
444 |
hyps: term Ord_List.T, (*hypotheses*) |
40124 | 445 |
tpairs: (term * term) list, (*flex-flex pairs*) |
446 |
prop: term} (*conclusion*) |
|
28624 | 447 |
and deriv = Deriv of |
77873 | 448 |
{promises: (serial * thm future) Ord_List.T, |
70453
492cb3aaa562
simplified module structure: back to plain datatype (see 95f4f08f950f and 70019ab5e57f);
wenzelm
parents:
70404
diff
changeset
|
449 |
body: Proofterm.proof_body}; |
0 | 450 |
|
23601 | 451 |
type conv = cterm -> thm; |
452 |
||
16725 | 453 |
(*errors involving theorems*) |
454 |
exception THM of string * int * thm list; |
|
13658
c9ad3e64ddcf
Changed handling of flex-flex constraints: now stored in separate
berghofe
parents:
13642
diff
changeset
|
455 |
|
28321
9f4499bf9384
type thm: fully internal derivation, no longer exported;
wenzelm
parents:
28290
diff
changeset
|
456 |
fun rep_thm (Thm (_, args)) = args; |
0 | 457 |
|
74241
eb265f54e3ce
more efficient operations: traverse hyps only when required;
wenzelm
parents:
74235
diff
changeset
|
458 |
fun fold_terms h f (Thm (_, {tpairs, prop, hyps, ...})) = |
77863
760515c45864
revert b43ee37926a9 due to problems with AFP/PAPP_Impossibility;
wenzelm
parents:
77827
diff
changeset
|
459 |
fold (fn (t, u) => f t #> f u) tpairs #> f prop #> #hyps h ? fold f hyps; |
31947
7daee3bed3af
clarified strip_shyps: proper type witnesses for present sorts;
wenzelm
parents:
31945
diff
changeset
|
460 |
|
74244 | 461 |
fun fold_atomic_ctyps h g f (th as Thm (_, {cert, maxidx, shyps, ...})) = |
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
462 |
let fun ctyp T = Ctyp {cert = cert, T = T, maxidx = maxidx, sorts = shyps} |
74244 | 463 |
in (fold_terms h o fold_types o fold_atyps) (fn T => if g T then f (ctyp T) else I) th end; |
60952
762cb38a3147
produce certified vars without access to theory_of_thm, and without context;
wenzelm
parents:
60951
diff
changeset
|
464 |
|
74244 | 465 |
fun fold_atomic_cterms h g f (th as Thm (_, {cert, maxidx, shyps, ...})) = |
466 |
let |
|
467 |
fun cterm t T = Cterm {cert = cert, t = t, T = T, maxidx = maxidx, sorts = shyps}; |
|
468 |
fun apply t T = if g t then f (cterm t T) else I; |
|
469 |
in |
|
74241
eb265f54e3ce
more efficient operations: traverse hyps only when required;
wenzelm
parents:
74235
diff
changeset
|
470 |
(fold_terms h o fold_aterms) |
74244 | 471 |
(fn t as Const (_, T) => apply t T |
472 |
| t as Free (_, T) => apply t T |
|
473 |
| t as Var (_, T) => apply t T |
|
60818 | 474 |
| _ => I) th |
475 |
end; |
|
476 |
||
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
477 |
|
16725 | 478 |
fun terms_of_tpairs tpairs = fold_rev (fn (t, u) => cons t o cons u) tpairs []; |
479 |
||
480 |
fun eq_tpairs ((t, u), (t', u')) = t aconv t' andalso u aconv u'; |
|
18944 | 481 |
fun union_tpairs ts us = Library.merge eq_tpairs (ts, us); |
16884
1678a796b6b2
tuned instantiate (avoid subst_atomic, subst_atomic_types);
wenzelm
parents:
16847
diff
changeset
|
482 |
val maxidx_tpairs = fold (fn (t, u) => Term.maxidx_term t #> Term.maxidx_term u); |
16725 | 483 |
|
484 |
fun attach_tpairs tpairs prop = |
|
485 |
Logic.list_implies (map Logic.mk_equals tpairs, prop); |
|
486 |
||
28321
9f4499bf9384
type thm: fully internal derivation, no longer exported;
wenzelm
parents:
28290
diff
changeset
|
487 |
fun full_prop_of (Thm (_, {tpairs, prop, ...})) = attach_tpairs tpairs prop; |
16945 | 488 |
|
70456
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
489 |
|
77863
760515c45864
revert b43ee37926a9 due to problems with AFP/PAPP_Impossibility;
wenzelm
parents:
77827
diff
changeset
|
490 |
val union_hyps = Ord_List.union Term_Ord.fast_term_ord; |
760515c45864
revert b43ee37926a9 due to problems with AFP/PAPP_Impossibility;
wenzelm
parents:
77827
diff
changeset
|
491 |
val insert_hyps = Ord_List.insert Term_Ord.fast_term_ord; |
760515c45864
revert b43ee37926a9 due to problems with AFP/PAPP_Impossibility;
wenzelm
parents:
77827
diff
changeset
|
492 |
val remove_hyps = Ord_List.remove Term_Ord.fast_term_ord; |
760515c45864
revert b43ee37926a9 due to problems with AFP/PAPP_Impossibility;
wenzelm
parents:
77827
diff
changeset
|
493 |
|
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
494 |
fun join_certificate1 (Cterm {cert = cert1, ...}, Thm (_, {cert = cert2, ...})) = |
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
495 |
Context.join_certificate (cert1, cert2); |
16945 | 496 |
|
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
497 |
fun join_certificate2 (Thm (_, {cert = cert1, ...}), Thm (_, {cert = cert2, ...})) = |
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
498 |
Context.join_certificate (cert1, cert2); |
16945 | 499 |
|
0 | 500 |
|
22365 | 501 |
(* basic components *) |
16135 | 502 |
|
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
503 |
val cert_of = #cert o rep_thm; |
65458 | 504 |
val theory_id = Context.certificate_theory_id o cert_of; |
77889
5db014c36f42
clarified signature: explicitly distinguish theory_base_name vs. theory_long_name;
wenzelm
parents:
77877
diff
changeset
|
505 |
|
5db014c36f42
clarified signature: explicitly distinguish theory_base_name vs. theory_long_name;
wenzelm
parents:
77877
diff
changeset
|
506 |
fun theory_name long = Context.theory_id_name long o theory_id; |
5db014c36f42
clarified signature: explicitly distinguish theory_base_name vs. theory_long_name;
wenzelm
parents:
77877
diff
changeset
|
507 |
val theory_long_name = theory_name {long = true}; |
5db014c36f42
clarified signature: explicitly distinguish theory_base_name vs. theory_long_name;
wenzelm
parents:
77877
diff
changeset
|
508 |
val theory_base_name = theory_name {long = false}; |
61050 | 509 |
|
28321
9f4499bf9384
type thm: fully internal derivation, no longer exported;
wenzelm
parents:
28290
diff
changeset
|
510 |
val maxidx_of = #maxidx o rep_thm; |
19910 | 511 |
fun maxidx_thm th i = Int.max (maxidx_of th, i); |
61039 | 512 |
val shyps_of = #shyps o rep_thm; |
28321
9f4499bf9384
type thm: fully internal derivation, no longer exported;
wenzelm
parents:
28290
diff
changeset
|
513 |
val hyps_of = #hyps o rep_thm; |
9f4499bf9384
type thm: fully internal derivation, no longer exported;
wenzelm
parents:
28290
diff
changeset
|
514 |
val prop_of = #prop o rep_thm; |
9f4499bf9384
type thm: fully internal derivation, no longer exported;
wenzelm
parents:
28290
diff
changeset
|
515 |
val tpairs_of = #tpairs o rep_thm; |
0 | 516 |
|
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
517 |
val concl_of = Logic.strip_imp_concl o prop_of; |
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
518 |
val prems_of = Logic.strip_imp_prems o prop_of; |
21576 | 519 |
val nprems_of = Logic.count_prems o prop_of; |
74509 | 520 |
val no_prems = Logic.no_prems o prop_of; |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
521 |
|
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
522 |
fun major_prem_of th = |
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
523 |
(case prems_of th of |
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
524 |
prem :: _ => Logic.strip_assums_concl prem |
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
525 |
| [] => raise THM ("major_prem_of: rule with no premises", 0, [th])); |
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
526 |
|
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
527 |
fun cprop_of (Thm (_, {cert, maxidx, shyps, prop, ...})) = |
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
528 |
Cterm {cert = cert, maxidx = maxidx, T = propT, t = prop, sorts = shyps}; |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
529 |
|
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
530 |
fun cprem_of (th as Thm (_, {cert, maxidx, shyps, prop, ...})) i = |
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
531 |
Cterm {cert = cert, maxidx = maxidx, T = propT, sorts = shyps, |
18145 | 532 |
t = Logic.nth_prem (i, prop) handle TERM _ => raise THM ("cprem_of", i, [th])}; |
18035 | 533 |
|
69101
991a3feaf270
more direct implementation of distinct_subgoals_tac -- potentially more efficient;
wenzelm
parents:
68692
diff
changeset
|
534 |
fun cconcl_of (th as Thm (_, {cert, maxidx, shyps, ...})) = |
991a3feaf270
more direct implementation of distinct_subgoals_tac -- potentially more efficient;
wenzelm
parents:
68692
diff
changeset
|
535 |
Cterm {cert = cert, maxidx = maxidx, T = propT, sorts = shyps, t = concl_of th}; |
991a3feaf270
more direct implementation of distinct_subgoals_tac -- potentially more efficient;
wenzelm
parents:
68692
diff
changeset
|
536 |
|
991a3feaf270
more direct implementation of distinct_subgoals_tac -- potentially more efficient;
wenzelm
parents:
68692
diff
changeset
|
537 |
fun cprems_of (th as Thm (_, {cert, maxidx, shyps, ...})) = |
991a3feaf270
more direct implementation of distinct_subgoals_tac -- potentially more efficient;
wenzelm
parents:
68692
diff
changeset
|
538 |
map (fn t => Cterm {cert = cert, maxidx = maxidx, T = propT, sorts = shyps, t = t}) |
991a3feaf270
more direct implementation of distinct_subgoals_tac -- potentially more efficient;
wenzelm
parents:
68692
diff
changeset
|
539 |
(prems_of th); |
991a3feaf270
more direct implementation of distinct_subgoals_tac -- potentially more efficient;
wenzelm
parents:
68692
diff
changeset
|
540 |
|
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
541 |
fun chyps_of (Thm (_, {cert, shyps, hyps, ...})) = |
77863
760515c45864
revert b43ee37926a9 due to problems with AFP/PAPP_Impossibility;
wenzelm
parents:
77827
diff
changeset
|
542 |
map (fn t => Cterm {cert = cert, maxidx = ~1, T = propT, sorts = shyps, t = t}) hyps; |
60949 | 543 |
|
61051 | 544 |
|
74270 | 545 |
(* thm order: ignores theory context! *) |
546 |
||
547 |
val thm_ord = |
|
74645 | 548 |
pointer_eq_ord |
77870 | 549 |
(Term_Ord.fast_term_ord o apply2 prop_of |
550 |
||| list_ord (prod_ord Term_Ord.fast_term_ord Term_Ord.fast_term_ord) o apply2 tpairs_of |
|
551 |
||| list_ord Term_Ord.fast_term_ord o apply2 hyps_of |
|
552 |
||| list_ord Term_Ord.sort_ord o apply2 shyps_of); |
|
74270 | 553 |
|
554 |
||
61051 | 555 |
(* implicit theory context *) |
556 |
||
557 |
exception CONTEXT of string * ctyp list * cterm list * thm list * Context.generic option; |
|
558 |
||
559 |
fun theory_of_cterm (ct as Cterm {cert, ...}) = |
|
560 |
Context.certificate_theory cert |
|
561 |
handle ERROR msg => raise CONTEXT (msg, [], [ct], [], NONE); |
|
562 |
||
563 |
fun theory_of_thm th = |
|
564 |
Context.certificate_theory (cert_of th) |
|
565 |
handle ERROR msg => raise CONTEXT (msg, [], [], [th], NONE); |
|
566 |
||
67697 | 567 |
fun trim_context_ctyp cT = |
568 |
(case cT of |
|
569 |
Ctyp {cert = Context.Certificate_Id _, ...} => cT |
|
570 |
| Ctyp {cert = Context.Certificate thy, T, maxidx, sorts} => |
|
571 |
Ctyp {cert = Context.Certificate_Id (Context.theory_id thy), |
|
572 |
T = T, maxidx = maxidx, sorts = sorts}); |
|
573 |
||
61051 | 574 |
fun trim_context_cterm ct = |
575 |
(case ct of |
|
576 |
Cterm {cert = Context.Certificate_Id _, ...} => ct |
|
577 |
| Cterm {cert = Context.Certificate thy, t, T, maxidx, sorts} => |
|
578 |
Cterm {cert = Context.Certificate_Id (Context.theory_id thy), |
|
579 |
t = t, T = T, maxidx = maxidx, sorts = sorts}); |
|
580 |
||
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
581 |
fun trim_context_thm th = |
77868 | 582 |
(case th of |
583 |
Thm (_, {constraints = _ :: _, ...}) => |
|
584 |
raise THM ("trim_context: pending sort constraints", 0, [th]) |
|
585 |
| Thm (_, {cert = Context.Certificate_Id _, ...}) => th |
|
586 |
| Thm (der, |
|
587 |
{cert = Context.Certificate thy, tags, maxidx, constraints = [], shyps, hyps, |
|
588 |
tpairs, prop}) => |
|
589 |
Thm (der, |
|
590 |
{cert = Context.Certificate_Id (Context.theory_id thy), |
|
591 |
tags = tags, maxidx = maxidx, constraints = [], shyps = shyps, hyps = hyps, |
|
592 |
tpairs = tpairs, prop = prop})); |
|
61048 | 593 |
|
70156 | 594 |
fun transfer_ctyp thy' cT = |
595 |
let |
|
596 |
val Ctyp {cert, T, maxidx, sorts} = cT; |
|
597 |
val _ = |
|
598 |
Context.subthy_id (Context.certificate_theory_id cert, Context.theory_id thy') orelse |
|
599 |
raise CONTEXT ("Cannot transfer: not a super theory", [cT], [], [], |
|
600 |
SOME (Context.Theory thy')); |
|
601 |
val cert' = Context.join_certificate (Context.Certificate thy', cert); |
|
602 |
in |
|
603 |
if Context.eq_certificate (cert, cert') then cT |
|
604 |
else Ctyp {cert = cert', T = T, maxidx = maxidx, sorts = sorts} |
|
605 |
end; |
|
606 |
||
78135 | 607 |
val transfer_ctyp' = transfer_ctyp o Proof_Context.theory_of; |
608 |
val transfer_ctyp'' = transfer_ctyp o Context.theory_of; |
|
609 |
||
61051 | 610 |
fun transfer_cterm thy' ct = |
3895 | 611 |
let |
61051 | 612 |
val Cterm {cert, t, T, maxidx, sorts} = ct; |
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
613 |
val _ = |
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
614 |
Context.subthy_id (Context.certificate_theory_id cert, Context.theory_id thy') orelse |
61051 | 615 |
raise CONTEXT ("Cannot transfer: not a super theory", [], [ct], [], |
616 |
SOME (Context.Theory thy')); |
|
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
617 |
val cert' = Context.join_certificate (Context.Certificate thy', cert); |
3895 | 618 |
in |
61051 | 619 |
if Context.eq_certificate (cert, cert') then ct |
620 |
else Cterm {cert = cert', t = t, T = T, maxidx = maxidx, sorts = sorts} |
|
621 |
end; |
|
622 |
||
78135 | 623 |
val transfer_cterm' = transfer_cterm o Proof_Context.theory_of; |
624 |
val transfer_cterm'' = transfer_cterm o Context.theory_of; |
|
625 |
||
61051 | 626 |
fun transfer thy' th = |
627 |
let |
|
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
628 |
val Thm (der, {cert, tags, maxidx, constraints, shyps, hyps, tpairs, prop}) = th; |
61051 | 629 |
val _ = |
630 |
Context.subthy_id (Context.certificate_theory_id cert, Context.theory_id thy') orelse |
|
631 |
raise CONTEXT ("Cannot transfer: not a super theory", [], [], [th], |
|
632 |
SOME (Context.Theory thy')); |
|
633 |
val cert' = Context.join_certificate (Context.Certificate thy', cert); |
|
634 |
in |
|
635 |
if Context.eq_certificate (cert, cert') then th |
|
16945 | 636 |
else |
28321
9f4499bf9384
type thm: fully internal derivation, no longer exported;
wenzelm
parents:
28290
diff
changeset
|
637 |
Thm (der, |
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
638 |
{cert = cert', |
21646
c07b5b0e8492
thm/prf: separate official name vs. additional tags;
wenzelm
parents:
21576
diff
changeset
|
639 |
tags = tags, |
16945 | 640 |
maxidx = maxidx, |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
641 |
constraints = constraints, |
16945 | 642 |
shyps = shyps, |
643 |
hyps = hyps, |
|
644 |
tpairs = tpairs, |
|
28321
9f4499bf9384
type thm: fully internal derivation, no longer exported;
wenzelm
parents:
28290
diff
changeset
|
645 |
prop = prop}) |
3895 | 646 |
end; |
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
647 |
|
67649 | 648 |
val transfer' = transfer o Proof_Context.theory_of; |
649 |
val transfer'' = transfer o Context.theory_of; |
|
650 |
||
70310
c82f59c47aaf
clarified transfer_morphism: implicit join_certificate, e.g. relevant for complex cascades of morphisms such as class locale interpretation;
wenzelm
parents:
70159
diff
changeset
|
651 |
fun join_transfer thy th = |
71553
cf2406e654cf
more robust: proper transfer if Context.eq_thy_id;
wenzelm
parents:
71530
diff
changeset
|
652 |
(Context.subthy_id (theory_id th, Context.theory_id thy) ? transfer thy) th; |
70310
c82f59c47aaf
clarified transfer_morphism: implicit join_certificate, e.g. relevant for complex cascades of morphisms such as class locale interpretation;
wenzelm
parents:
70159
diff
changeset
|
653 |
|
70313 | 654 |
fun join_transfer_context (ctxt, th) = |
71177 | 655 |
if Context.subthy_id (theory_id th, Context.theory_id (Proof_Context.theory_of ctxt)) |
656 |
then (ctxt, transfer' ctxt th) |
|
657 |
else (Context.raw_transfer (theory_of_thm th) ctxt, th); |
|
70313 | 658 |
|
61051 | 659 |
|
660 |
(* matching *) |
|
661 |
||
662 |
local |
|
663 |
||
664 |
fun gen_match match |
|
665 |
(ct1 as Cterm {t = t1, sorts = sorts1, ...}, |
|
666 |
ct2 as Cterm {t = t2, sorts = sorts2, maxidx = maxidx2, ...}) = |
|
667 |
let |
|
668 |
val cert = join_certificate0 (ct1, ct2); |
|
669 |
val thy = Context.certificate_theory cert |
|
670 |
handle ERROR msg => raise CONTEXT (msg, [], [ct1, ct2], [], NONE); |
|
671 |
val (Tinsts, tinsts) = match thy (t1, t2) (Vartab.empty, Vartab.empty); |
|
77869 | 672 |
val sorts = Sorts.union sorts1 sorts2; |
61051 | 673 |
fun mk_cTinst ((a, i), (S, T)) = |
674 |
(((a, i), S), Ctyp {T = T, cert = cert, maxidx = maxidx2, sorts = sorts}); |
|
675 |
fun mk_ctinst ((x, i), (U, t)) = |
|
676 |
let val T = Envir.subst_type Tinsts U in |
|
677 |
(((x, i), T), Cterm {t = t, T = T, cert = cert, maxidx = maxidx2, sorts = sorts}) |
|
678 |
end; |
|
74282 | 679 |
in |
680 |
(TVars.build (Vartab.fold (TVars.add o mk_cTinst) Tinsts), |
|
681 |
Vars.build (Vartab.fold (Vars.add o mk_ctinst) tinsts)) |
|
682 |
end; |
|
61051 | 683 |
|
684 |
in |
|
685 |
||
686 |
val match = gen_match Pattern.match; |
|
687 |
val first_order_match = gen_match Pattern.first_order_match; |
|
688 |
||
689 |
end; |
|
690 |
||
691 |
||
59969
bcccad156236
explicitly checked alpha conversion -- actual renaming happens outside kernel;
wenzelm
parents:
59917
diff
changeset
|
692 |
(*implicit alpha-conversion*) |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
693 |
fun renamed_prop prop' (Thm (der, {cert, tags, maxidx, constraints, shyps, hyps, tpairs, prop})) = |
59969
bcccad156236
explicitly checked alpha conversion -- actual renaming happens outside kernel;
wenzelm
parents:
59917
diff
changeset
|
694 |
if prop aconv prop' then |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
695 |
Thm (der, {cert = cert, tags = tags, maxidx = maxidx, constraints = constraints, shyps = shyps, |
59969
bcccad156236
explicitly checked alpha conversion -- actual renaming happens outside kernel;
wenzelm
parents:
59917
diff
changeset
|
696 |
hyps = hyps, tpairs = tpairs, prop = prop'}) |
bcccad156236
explicitly checked alpha conversion -- actual renaming happens outside kernel;
wenzelm
parents:
59917
diff
changeset
|
697 |
else raise TERM ("renamed_prop: props disagree", [prop, prop']); |
bcccad156236
explicitly checked alpha conversion -- actual renaming happens outside kernel;
wenzelm
parents:
59917
diff
changeset
|
698 |
|
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
699 |
fun make_context ths NONE cert = |
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
700 |
(Context.Theory (Context.certificate_theory cert) |
61051 | 701 |
handle ERROR msg => raise CONTEXT (msg, [], [], ths, NONE)) |
61045
c7a7f063704a
clarified exceptions: avoid interference of formal context failure with regular rule application failure (which is routinely handled in user-space);
wenzelm
parents:
61044
diff
changeset
|
702 |
| make_context ths (SOME ctxt) cert = |
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
703 |
let |
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
704 |
val thy_id = Context.certificate_theory_id cert; |
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
705 |
val thy_id' = Context.theory_id (Proof_Context.theory_of ctxt); |
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
706 |
in |
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
707 |
if Context.subthy_id (thy_id, thy_id') then Context.Proof ctxt |
61051 | 708 |
else raise CONTEXT ("Bad context", [], [], ths, SOME (Context.Proof ctxt)) |
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
709 |
end; |
58950
d07464875dd4
optional proof context for unify operations, for the sake of proper local options;
wenzelm
parents:
58946
diff
changeset
|
710 |
|
64981
ea6199b23dfa
proper background certificate from make_context, which can be a super-theory of the direct join (amending d07464875dd4);
wenzelm
parents:
64574
diff
changeset
|
711 |
fun make_context_certificate ths opt_ctxt cert = |
ea6199b23dfa
proper background certificate from make_context, which can be a super-theory of the direct join (amending d07464875dd4);
wenzelm
parents:
64574
diff
changeset
|
712 |
let |
ea6199b23dfa
proper background certificate from make_context, which can be a super-theory of the direct join (amending d07464875dd4);
wenzelm
parents:
64574
diff
changeset
|
713 |
val context = make_context ths opt_ctxt cert; |
ea6199b23dfa
proper background certificate from make_context, which can be a super-theory of the direct join (amending d07464875dd4);
wenzelm
parents:
64574
diff
changeset
|
714 |
val cert' = Context.Certificate (Context.theory_of context); |
ea6199b23dfa
proper background certificate from make_context, which can be a super-theory of the direct join (amending d07464875dd4);
wenzelm
parents:
64574
diff
changeset
|
715 |
in (context, cert') end; |
ea6199b23dfa
proper background certificate from make_context, which can be a super-theory of the direct join (amending d07464875dd4);
wenzelm
parents:
64574
diff
changeset
|
716 |
|
16945 | 717 |
(*explicit weakening: maps |- B to A |- B*) |
718 |
fun weaken raw_ct th = |
|
719 |
let |
|
20261 | 720 |
val ct as Cterm {t = A, T, sorts, maxidx = maxidxA, ...} = adjust_maxidx_cterm ~1 raw_ct; |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
721 |
val Thm (der, {tags, maxidx, constraints, shyps, hyps, tpairs, prop, ...}) = th; |
16945 | 722 |
in |
723 |
if T <> propT then |
|
724 |
raise THM ("weaken: assumptions must have type prop", 0, []) |
|
725 |
else if maxidxA <> ~1 then |
|
726 |
raise THM ("weaken: assumptions may not contain schematic variables", maxidxA, []) |
|
727 |
else |
|
28321
9f4499bf9384
type thm: fully internal derivation, no longer exported;
wenzelm
parents:
28290
diff
changeset
|
728 |
Thm (der, |
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
729 |
{cert = join_certificate1 (ct, th), |
21646
c07b5b0e8492
thm/prf: separate official name vs. additional tags;
wenzelm
parents:
21576
diff
changeset
|
730 |
tags = tags, |
16945 | 731 |
maxidx = maxidx, |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
732 |
constraints = constraints, |
77869 | 733 |
shyps = Sorts.union sorts shyps, |
77863
760515c45864
revert b43ee37926a9 due to problems with AFP/PAPP_Impossibility;
wenzelm
parents:
77827
diff
changeset
|
734 |
hyps = insert_hyps A hyps, |
16945 | 735 |
tpairs = tpairs, |
28321
9f4499bf9384
type thm: fully internal derivation, no longer exported;
wenzelm
parents:
28290
diff
changeset
|
736 |
prop = prop}) |
16945 | 737 |
end; |
16656 | 738 |
|
77869 | 739 |
fun weaken_sorts raw_sorts ct = |
28624 | 740 |
let |
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
741 |
val Cterm {cert, t, T, maxidx, sorts} = ct; |
61050 | 742 |
val thy = theory_of_cterm ct; |
77869 | 743 |
val more_sorts = Sorts.make (map (Sign.certify_sort thy) raw_sorts); |
744 |
val sorts' = Sorts.union sorts more_sorts; |
|
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
745 |
in Cterm {cert = cert, t = t, T = T, maxidx = maxidx, sorts = sorts'} end; |
28624 | 746 |
|
28321
9f4499bf9384
type thm: fully internal derivation, no longer exported;
wenzelm
parents:
28290
diff
changeset
|
747 |
|
9f4499bf9384
type thm: fully internal derivation, no longer exported;
wenzelm
parents:
28290
diff
changeset
|
748 |
|
32725 | 749 |
(** derivations and promised proofs **) |
28321
9f4499bf9384
type thm: fully internal derivation, no longer exported;
wenzelm
parents:
28290
diff
changeset
|
750 |
|
79262 | 751 |
fun make_deriv0 promises body = Deriv {promises = promises, body = body}; |
752 |
||
79220 | 753 |
fun make_deriv promises oracles thms zboxes zproof proof = |
79262 | 754 |
make_deriv0 promises |
755 |
(PBody {oracles = oracles, thms = thms, zboxes = zboxes, zproof = zproof, proof = proof}); |
|
28321
9f4499bf9384
type thm: fully internal derivation, no longer exported;
wenzelm
parents:
28290
diff
changeset
|
756 |
|
79279 | 757 |
val empty_deriv = make_deriv [] [] [] [] ZDummy MinProof; |
28321
9f4499bf9384
type thm: fully internal derivation, no longer exported;
wenzelm
parents:
28290
diff
changeset
|
758 |
|
28330 | 759 |
|
28354 | 760 |
(* inference rules *) |
28321
9f4499bf9384
type thm: fully internal derivation, no longer exported;
wenzelm
parents:
28290
diff
changeset
|
761 |
|
77873 | 762 |
val promise_ord: (serial * thm future) ord = fn ((i, _), (j, _)) => int_ord (j, i); |
763 |
||
79221 | 764 |
fun deriv_rule2 zproof proof |
765 |
(Deriv {promises = ps1, body = PBody body1}) |
|
766 |
(Deriv {promises = ps2, body = PBody body2}) = |
|
28321
9f4499bf9384
type thm: fully internal derivation, no longer exported;
wenzelm
parents:
28290
diff
changeset
|
767 |
let |
79221 | 768 |
val ps' = Ord_List.union promise_ord ps1 ps2; |
79114 | 769 |
|
79220 | 770 |
val {oracles = oracles1, thms = thms1, zboxes = zboxes1, zproof = zprf1, proof = prf1} = body1; |
771 |
val {oracles = oracles2, thms = thms2, zboxes = zboxes2, zproof = zprf2, proof = prf2} = body2; |
|
79114 | 772 |
|
79221 | 773 |
val oracles' = Proofterm.union_oracles oracles1 oracles2; |
774 |
val thms' = Proofterm.union_thms thms1 thms2; |
|
79263 | 775 |
val zboxes' = ZTerm.union_zboxes zboxes1 zboxes2; |
79219
8b371e684acf
clarified signature: more explicit get_proofs_level with bounds check;
wenzelm
parents:
79212
diff
changeset
|
776 |
|
8b371e684acf
clarified signature: more explicit get_proofs_level with bounds check;
wenzelm
parents:
79212
diff
changeset
|
777 |
val proofs = Proofterm.get_proofs_level (); |
79221 | 778 |
val zproof' = if Proofterm.zproof_enabled proofs then zproof zprf1 zprf2 else ZDummy; |
779 |
val proof' = if Proofterm.proof_enabled proofs then proof prf1 prf2 else MinProof; |
|
780 |
in make_deriv ps' oracles' thms' zboxes' zproof' proof' end; |
|
28321
9f4499bf9384
type thm: fully internal derivation, no longer exported;
wenzelm
parents:
28290
diff
changeset
|
781 |
|
79221 | 782 |
fun deriv_rule1 zproof proof = deriv_rule2 (K zproof) (K proof) empty_deriv; |
70812
3ae7949ef059
tuned -- allow slightly more expensive atomic proofs;
wenzelm
parents:
70603
diff
changeset
|
783 |
|
79221 | 784 |
fun deriv_rule0 zproof proof = |
79219
8b371e684acf
clarified signature: more explicit get_proofs_level with bounds check;
wenzelm
parents:
79212
diff
changeset
|
785 |
let val proofs = Proofterm.get_proofs_level () in |
79113
5109e4b2a292
pro-forma support for optional zproof: no proper content yet;
wenzelm
parents:
78135
diff
changeset
|
786 |
if Proofterm.proof_enabled proofs orelse Proofterm.zproof_enabled proofs then |
79279 | 787 |
deriv_rule1 I I (make_deriv [] [] [] [] |
79221 | 788 |
(if Proofterm.zproof_enabled proofs then zproof () else ZDummy) |
789 |
(if Proofterm.proof_enabled proofs then proof () else MinProof)) |
|
79113
5109e4b2a292
pro-forma support for optional zproof: no proper content yet;
wenzelm
parents:
78135
diff
changeset
|
790 |
else empty_deriv |
5109e4b2a292
pro-forma support for optional zproof: no proper content yet;
wenzelm
parents:
78135
diff
changeset
|
791 |
end; |
28321
9f4499bf9384
type thm: fully internal derivation, no longer exported;
wenzelm
parents:
28290
diff
changeset
|
792 |
|
1238 | 793 |
|
32725 | 794 |
(* fulfilled proofs *) |
795 |
||
77873 | 796 |
fun raw_promises_of (Thm (Deriv {promises, ...}, _)) = promises; |
44331 | 797 |
|
798 |
fun join_promises [] = () |
|
799 |
| join_promises promises = join_promises_of (Future.joins (map snd promises)) |
|
77873 | 800 |
and join_promises_of thms = join_promises (Ord_List.make promise_ord (maps raw_promises_of thms)); |
32725 | 801 |
|
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
802 |
fun fulfill_body (th as Thm (Deriv {promises, body}, _)) = |
77873 | 803 |
let val fulfilled_promises = map #1 promises ~~ map fulfill_body (Future.joins (map #2 promises)) |
804 |
in Proofterm.fulfill_norm_proof (theory_of_thm th) fulfilled_promises body end; |
|
32725 | 805 |
|
64574
1134e4d5e5b7
consolidate nested thms with persistent result, for improved performance;
wenzelm
parents:
64573
diff
changeset
|
806 |
fun proof_bodies_of thms = (join_promises_of thms; map fulfill_body thms); |
44333
cc53ce50f738
reverted to join_bodies/join_proofs based on fold_body_thms to regain performance (escpecially of HOL-Proofs) -- see also aa9c1e9ef2ce and 4e2abb045eac;
wenzelm
parents:
44331
diff
changeset
|
807 |
val proof_body_of = singleton proof_bodies_of; |
44331 | 808 |
val proof_of = Proofterm.proof_of o proof_body_of; |
32725 | 809 |
|
71088 | 810 |
fun reconstruct_proof_of thm = |
811 |
Proofterm.reconstruct_proof (theory_of_thm thm) (prop_of thm) (proof_of thm); |
|
812 |
||
66168 | 813 |
val consolidate = ignore o proof_bodies_of; |
32725 | 814 |
|
71011 | 815 |
fun expose_proofs thy thms = |
816 |
if Proofterm.export_proof_boxes_required thy then |
|
71018
d32ed8927a42
more robust expose_proofs corresponding to register_proofs/consolidate_theory;
wenzelm
parents:
71017
diff
changeset
|
817 |
Proofterm.export_proof_boxes (proof_bodies_of (map (transfer thy) thms)) |
71011 | 818 |
else (); |
819 |
||
71017
c85efa2be619
expose derivations more thoroughly, notably for locale/class reasoning;
wenzelm
parents:
71012
diff
changeset
|
820 |
fun expose_proof thy = expose_proofs thy o single; |
c85efa2be619
expose derivations more thoroughly, notably for locale/class reasoning;
wenzelm
parents:
71012
diff
changeset
|
821 |
|
32725 | 822 |
|
823 |
(* future rule *) |
|
824 |
||
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
825 |
fun future_result i orig_cert orig_shyps orig_prop thm = |
32725 | 826 |
let |
36613
f3157c288aca
simplified primitive Thm.future: more direct theory check, do not hardwire strip_shyps here;
wenzelm
parents:
36330
diff
changeset
|
827 |
fun err msg = raise THM ("future_result: " ^ msg, 0, [thm]); |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
828 |
val Thm (Deriv {promises, ...}, {cert, constraints, shyps, hyps, tpairs, prop, ...}) = thm; |
36613
f3157c288aca
simplified primitive Thm.future: more direct theory check, do not hardwire strip_shyps here;
wenzelm
parents:
36330
diff
changeset
|
829 |
|
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
830 |
val _ = Context.eq_certificate (cert, orig_cert) orelse err "bad theory"; |
32725 | 831 |
val _ = prop aconv orig_prop orelse err "bad prop"; |
77868 | 832 |
val _ = null constraints orelse err "bad sort constraints"; |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
833 |
val _ = null tpairs orelse err "bad flex-flex constraints"; |
77863
760515c45864
revert b43ee37926a9 due to problems with AFP/PAPP_Impossibility;
wenzelm
parents:
77827
diff
changeset
|
834 |
val _ = null hyps orelse err "bad hyps"; |
77869 | 835 |
val _ = Sorts.subset (shyps, orig_shyps) orelse err "bad shyps"; |
77873 | 836 |
val _ = forall (fn (j, _) => i <> j) promises orelse err "bad dependencies"; |
837 |
val _ = join_promises promises; |
|
32725 | 838 |
in thm end; |
839 |
||
840 |
fun future future_thm ct = |
|
841 |
let |
|
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
842 |
val Cterm {cert = cert, t = prop, T, maxidx, sorts} = ct; |
32725 | 843 |
val _ = T <> propT andalso raise CTERM ("future: prop expected", [ct]); |
70398 | 844 |
val _ = |
79113
5109e4b2a292
pro-forma support for optional zproof: no proper content yet;
wenzelm
parents:
78135
diff
changeset
|
845 |
if Proofterm.any_proofs_enabled () |
70398 | 846 |
then raise CTERM ("future: proof terms enabled", [ct]) else (); |
32725 | 847 |
|
848 |
val i = serial (); |
|
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
849 |
val future = future_thm |> Future.map (future_result i cert sorts prop); |
32725 | 850 |
in |
79279 | 851 |
Thm (make_deriv [(i, future)] [] [] [] ZDummy MinProof, |
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
852 |
{cert = cert, |
32725 | 853 |
tags = [], |
854 |
maxidx = maxidx, |
|
77868 | 855 |
constraints = [], |
32725 | 856 |
shyps = sorts, |
77863
760515c45864
revert b43ee37926a9 due to problems with AFP/PAPP_Impossibility;
wenzelm
parents:
77827
diff
changeset
|
857 |
hyps = [], |
32725 | 858 |
tpairs = [], |
859 |
prop = prop}) |
|
860 |
end; |
|
861 |
||
862 |
||
1238 | 863 |
|
1529 | 864 |
(** Axioms **) |
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
865 |
|
70923
98d9b78b7f47
clarified axiom_table: uniform space (e.g. like consts), e.g. relevant for export of HOL-ex.Join_Theory;
wenzelm
parents:
70915
diff
changeset
|
866 |
fun axiom thy name = |
98d9b78b7f47
clarified axiom_table: uniform space (e.g. like consts), e.g. relevant for export of HOL-ex.Join_Theory;
wenzelm
parents:
70915
diff
changeset
|
867 |
(case Name_Space.lookup (Theory.axiom_table thy) name of |
98d9b78b7f47
clarified axiom_table: uniform space (e.g. like consts), e.g. relevant for export of HOL-ex.Join_Theory;
wenzelm
parents:
70915
diff
changeset
|
868 |
SOME prop => |
98d9b78b7f47
clarified axiom_table: uniform space (e.g. like consts), e.g. relevant for export of HOL-ex.Join_Theory;
wenzelm
parents:
70915
diff
changeset
|
869 |
let |
79221 | 870 |
fun zproof () = ZTerm.axiom_proof thy name prop; |
871 |
fun proof () = Proofterm.axm_proof name prop; |
|
70923
98d9b78b7f47
clarified axiom_table: uniform space (e.g. like consts), e.g. relevant for export of HOL-ex.Join_Theory;
wenzelm
parents:
70915
diff
changeset
|
872 |
val cert = Context.Certificate thy; |
98d9b78b7f47
clarified axiom_table: uniform space (e.g. like consts), e.g. relevant for export of HOL-ex.Join_Theory;
wenzelm
parents:
70915
diff
changeset
|
873 |
val maxidx = maxidx_of_term prop; |
77869 | 874 |
val shyps = Sorts.insert_term prop []; |
70923
98d9b78b7f47
clarified axiom_table: uniform space (e.g. like consts), e.g. relevant for export of HOL-ex.Join_Theory;
wenzelm
parents:
70915
diff
changeset
|
875 |
in |
79221 | 876 |
Thm (deriv_rule0 zproof proof, |
70923
98d9b78b7f47
clarified axiom_table: uniform space (e.g. like consts), e.g. relevant for export of HOL-ex.Join_Theory;
wenzelm
parents:
70915
diff
changeset
|
877 |
{cert = cert, tags = [], maxidx = maxidx, |
77868 | 878 |
constraints = [], shyps = shyps, hyps = [], tpairs = [], prop = prop}) |
70923
98d9b78b7f47
clarified axiom_table: uniform space (e.g. like consts), e.g. relevant for export of HOL-ex.Join_Theory;
wenzelm
parents:
70915
diff
changeset
|
879 |
end |
98d9b78b7f47
clarified axiom_table: uniform space (e.g. like consts), e.g. relevant for export of HOL-ex.Join_Theory;
wenzelm
parents:
70915
diff
changeset
|
880 |
| NONE => raise THEORY ("No axiom " ^ quote name, [thy])); |
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
881 |
|
70923
98d9b78b7f47
clarified axiom_table: uniform space (e.g. like consts), e.g. relevant for export of HOL-ex.Join_Theory;
wenzelm
parents:
70915
diff
changeset
|
882 |
fun all_axioms_of thy = |
98d9b78b7f47
clarified axiom_table: uniform space (e.g. like consts), e.g. relevant for export of HOL-ex.Join_Theory;
wenzelm
parents:
70915
diff
changeset
|
883 |
map (fn (name, _) => (name, axiom thy name)) (Theory.all_axioms_of thy); |
776
df8f91c0e57c
improved axioms_of: returns thms as the manual says;
wenzelm
parents:
721
diff
changeset
|
884 |
|
6089 | 885 |
|
28804
5d3b1df16353
refined notion of derivation, consiting of promises and proof_body;
wenzelm
parents:
28675
diff
changeset
|
886 |
(* tags *) |
6089 | 887 |
|
21646
c07b5b0e8492
thm/prf: separate official name vs. additional tags;
wenzelm
parents:
21576
diff
changeset
|
888 |
val get_tags = #tags o rep_thm; |
6089 | 889 |
|
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
890 |
fun map_tags f (Thm (der, {cert, tags, maxidx, constraints, shyps, hyps, tpairs, prop})) = |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
891 |
Thm (der, {cert = cert, tags = f tags, maxidx = maxidx, constraints = constraints, |
28321
9f4499bf9384
type thm: fully internal derivation, no longer exported;
wenzelm
parents:
28290
diff
changeset
|
892 |
shyps = shyps, hyps = hyps, tpairs = tpairs, prop = prop}); |
0 | 893 |
|
894 |
||
43795
ca5896a836ba
recovered some runtime sharing from d6b6c74a8bcf, without the global memory bottleneck;
wenzelm
parents:
43761
diff
changeset
|
895 |
(* technical adjustments *) |
ca5896a836ba
recovered some runtime sharing from d6b6c74a8bcf, without the global memory bottleneck;
wenzelm
parents:
43761
diff
changeset
|
896 |
|
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
897 |
fun norm_proof (th as Thm (der, args)) = |
79221 | 898 |
Thm (deriv_rule1 I (Proofterm.rew_proof (theory_of_thm th)) der, args); |
23781
ab793a6ddf9f
Added function norm_proof for normalizing the proof term
berghofe
parents:
23657
diff
changeset
|
899 |
|
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
900 |
fun adjust_maxidx_thm i |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
901 |
(th as Thm (der, {cert, tags, maxidx, constraints, shyps, hyps, tpairs, prop})) = |
20261 | 902 |
if maxidx = i then th |
903 |
else if maxidx < i then |
|
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
904 |
Thm (der, {maxidx = i, cert = cert, tags = tags, constraints = constraints, shyps = shyps, |
28321
9f4499bf9384
type thm: fully internal derivation, no longer exported;
wenzelm
parents:
28290
diff
changeset
|
905 |
hyps = hyps, tpairs = tpairs, prop = prop}) |
20261 | 906 |
else |
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
907 |
Thm (der, {maxidx = Int.max (maxidx_tpairs tpairs (maxidx_of_term prop), i), |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
908 |
cert = cert, tags = tags, constraints = constraints, shyps = shyps, |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
909 |
hyps = hyps, tpairs = tpairs, prop = prop}); |
564 | 910 |
|
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
911 |
|
2509 | 912 |
|
70454 | 913 |
(*** Theory data ***) |
914 |
||
70458 | 915 |
(* type classes *) |
916 |
||
70465 | 917 |
structure Aritytab = |
918 |
Table( |
|
919 |
type key = string * sort list * class; |
|
920 |
val ord = |
|
921 |
fast_string_ord o apply2 #1 |
|
73860 | 922 |
||| fast_string_ord o apply2 #3 |
923 |
||| list_ord Term_Ord.sort_ord o apply2 #2; |
|
70465 | 924 |
); |
925 |
||
70458 | 926 |
datatype classes = Classes of |
70456
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
927 |
{classrels: thm Symreltab.table, |
70475
98b6da301e13
backed out changeset 1b8858f4c393: odd problems e.g. in CAVA_LTL_Modelchecker;
wenzelm
parents:
70472
diff
changeset
|
928 |
arities: (thm * string * serial) Aritytab.table}; |
70456
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
929 |
|
70458 | 930 |
fun make_classes (classrels, arities) = Classes {classrels = classrels, arities = arities}; |
70456
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
931 |
|
70465 | 932 |
val empty_classes = make_classes (Symreltab.empty, Aritytab.empty); |
70456
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
933 |
|
70458 | 934 |
(*see Theory.at_begin hook for transitive closure of classrels and arity completion*) |
935 |
fun merge_classes |
|
936 |
(Classes {classrels = classrels1, arities = arities1}, |
|
937 |
Classes {classrels = classrels2, arities = arities2}) = |
|
70456
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
938 |
let |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
939 |
val classrels' = Symreltab.merge (K true) (classrels1, classrels2); |
70465 | 940 |
val arities' = Aritytab.merge (K true) (arities1, arities2); |
70458 | 941 |
in make_classes (classrels', arities') end; |
70456
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
942 |
|
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
943 |
|
70458 | 944 |
(* data *) |
945 |
||
70454 | 946 |
structure Data = Theory_Data |
947 |
( |
|
948 |
type T = |
|
79362
2187de552bd4
clarified stored data: actual thm allows to replay zproofs in a modular manner;
wenzelm
parents:
79335
diff
changeset
|
949 |
{name: Thm_Name.T * Position.T, thm: thm} Inttab.table * (*stored zproof thms*) |
70456
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
950 |
unit Name_Space.table * (*oracles: authentic derivation names*) |
70458 | 951 |
classes; (*type classes within the logic*) |
70456
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
952 |
|
79313
3b03af5125de
use strict Global_Theory.register_proofs as checkpoint for stored zproof, and thus reduce current zboxes;
wenzelm
parents:
79310
diff
changeset
|
953 |
val empty : T = (Inttab.empty, Name_Space.empty_table Markup.oracleN, empty_classes); |
79330
d300a8f02b84
clarified zproof storage: per-theory table in anticipation of session exports;
wenzelm
parents:
79329
diff
changeset
|
954 |
fun merge ((_, oracles1, sorts1), (_, oracles2, sorts2)) : T = |
d300a8f02b84
clarified zproof storage: per-theory table in anticipation of session exports;
wenzelm
parents:
79329
diff
changeset
|
955 |
(Inttab.empty, |
79313
3b03af5125de
use strict Global_Theory.register_proofs as checkpoint for stored zproof, and thus reduce current zboxes;
wenzelm
parents:
79310
diff
changeset
|
956 |
Name_Space.merge_tables (oracles1, oracles2), |
3b03af5125de
use strict Global_Theory.register_proofs as checkpoint for stored zproof, and thus reduce current zboxes;
wenzelm
parents:
79310
diff
changeset
|
957 |
merge_classes (sorts1, sorts2)); |
70454 | 958 |
); |
959 |
||
79313
3b03af5125de
use strict Global_Theory.register_proofs as checkpoint for stored zproof, and thus reduce current zboxes;
wenzelm
parents:
79310
diff
changeset
|
960 |
val get_zproofs = #1 o Data.get; |
3b03af5125de
use strict Global_Theory.register_proofs as checkpoint for stored zproof, and thus reduce current zboxes;
wenzelm
parents:
79310
diff
changeset
|
961 |
fun map_zproofs f = Data.map (fn (a, b, c) => (f a, b, c)); |
70456
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
962 |
|
79313
3b03af5125de
use strict Global_Theory.register_proofs as checkpoint for stored zproof, and thus reduce current zboxes;
wenzelm
parents:
79310
diff
changeset
|
963 |
val get_oracles = #2 o Data.get; |
3b03af5125de
use strict Global_Theory.register_proofs as checkpoint for stored zproof, and thus reduce current zboxes;
wenzelm
parents:
79310
diff
changeset
|
964 |
fun map_oracles f = Data.map (fn (a, b, c) => (a, f b, c)); |
3b03af5125de
use strict Global_Theory.register_proofs as checkpoint for stored zproof, and thus reduce current zboxes;
wenzelm
parents:
79310
diff
changeset
|
965 |
|
3b03af5125de
use strict Global_Theory.register_proofs as checkpoint for stored zproof, and thus reduce current zboxes;
wenzelm
parents:
79310
diff
changeset
|
966 |
val get_classes = (fn (_, _, Classes args) => args) o Data.get; |
70458 | 967 |
val get_classrels = #classrels o get_classes; |
968 |
val get_arities = #arities o get_classes; |
|
969 |
||
970 |
fun map_classes f = |
|
79313
3b03af5125de
use strict Global_Theory.register_proofs as checkpoint for stored zproof, and thus reduce current zboxes;
wenzelm
parents:
79310
diff
changeset
|
971 |
Data.map (fn (a, b, Classes {classrels, arities}) => |
3b03af5125de
use strict Global_Theory.register_proofs as checkpoint for stored zproof, and thus reduce current zboxes;
wenzelm
parents:
79310
diff
changeset
|
972 |
(a, b, make_classes (f (classrels, arities)))); |
70458 | 973 |
fun map_classrels f = map_classes (fn (classrels, arities) => (f classrels, arities)); |
974 |
fun map_arities f = map_classes (fn (classrels, arities) => (classrels, f arities)); |
|
975 |
||
79330
d300a8f02b84
clarified zproof storage: per-theory table in anticipation of session exports;
wenzelm
parents:
79329
diff
changeset
|
976 |
val _ = |
d300a8f02b84
clarified zproof storage: per-theory table in anticipation of session exports;
wenzelm
parents:
79329
diff
changeset
|
977 |
(Theory.setup o Theory.at_begin) (fn thy => |
d300a8f02b84
clarified zproof storage: per-theory table in anticipation of session exports;
wenzelm
parents:
79329
diff
changeset
|
978 |
if Inttab.is_empty (get_zproofs thy) then NONE |
d300a8f02b84
clarified zproof storage: per-theory table in anticipation of session exports;
wenzelm
parents:
79329
diff
changeset
|
979 |
else SOME (map_zproofs (K Inttab.empty) thy)); |
d300a8f02b84
clarified zproof storage: per-theory table in anticipation of session exports;
wenzelm
parents:
79329
diff
changeset
|
980 |
|
70458 | 981 |
|
982 |
(* type classes *) |
|
983 |
||
984 |
fun the_classrel thy (c1, c2) = |
|
985 |
(case Symreltab.lookup (get_classrels thy) (c1, c2) of |
|
986 |
SOME thm => transfer thy thm |
|
987 |
| NONE => error ("Unproven class relation " ^ |
|
988 |
Syntax.string_of_classrel (Proof_Context.init_global thy) [c1, c2])); |
|
989 |
||
990 |
fun the_arity thy (a, Ss, c) = |
|
70465 | 991 |
(case Aritytab.lookup (get_arities thy) (a, Ss, c) of |
70475
98b6da301e13
backed out changeset 1b8858f4c393: odd problems e.g. in CAVA_LTL_Modelchecker;
wenzelm
parents:
70472
diff
changeset
|
992 |
SOME (thm, _, _) => transfer thy thm |
70458 | 993 |
| NONE => error ("Unproven type arity " ^ |
994 |
Syntax.string_of_arity (Proof_Context.init_global thy) (a, Ss, [c]))); |
|
995 |
||
996 |
val classrel_proof = proof_of oo the_classrel; |
|
997 |
val arity_proof = proof_of oo the_arity; |
|
70457 | 998 |
|
70458 | 999 |
|
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1000 |
(* solve sort constraints by pro-forma proof *) |
70458 | 1001 |
|
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1002 |
local |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1003 |
|
79306
816472c38979
clarified pro-forma proof: no zboxes here (partially revert 686b7b14d041);
wenzelm
parents:
79305
diff
changeset
|
1004 |
fun union_digest (oracles1, thms1) (oracles2, thms2) = |
816472c38979
clarified pro-forma proof: no zboxes here (partially revert 686b7b14d041);
wenzelm
parents:
79305
diff
changeset
|
1005 |
(Proofterm.union_oracles oracles1 oracles2, Proofterm.union_thms thms1 thms2); |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1006 |
|
79306
816472c38979
clarified pro-forma proof: no zboxes here (partially revert 686b7b14d041);
wenzelm
parents:
79305
diff
changeset
|
1007 |
fun thm_digest (Thm (Deriv {body = PBody {oracles, thms, ...}, ...}, _)) = (oracles, thms); |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1008 |
|
70480
1a1b7d7f24bb
explicit check of left-over constraints from different theory, e.g. due to lack of Thm.trim_context;
wenzelm
parents:
70475
diff
changeset
|
1009 |
fun constraint_digest ({theory = thy, typ, sort, ...}: constraint) = |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1010 |
Sorts.of_sort_derivation (Sign.classes_of thy) |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1011 |
{class_relation = fn _ => fn _ => fn (digest, c1) => fn c2 => |
79306
816472c38979
clarified pro-forma proof: no zboxes here (partially revert 686b7b14d041);
wenzelm
parents:
79305
diff
changeset
|
1012 |
if c1 = c2 then ([], []) else union_digest digest (thm_digest (the_classrel thy (c1, c2))), |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1013 |
type_constructor = fn (a, _) => fn dom => fn c => |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1014 |
let val arity_digest = thm_digest (the_arity thy (a, (map o map) #2 dom, c)) |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1015 |
in (fold o fold) (union_digest o #1) dom arity_digest end, |
79306
816472c38979
clarified pro-forma proof: no zboxes here (partially revert 686b7b14d041);
wenzelm
parents:
79305
diff
changeset
|
1016 |
type_variable = fn T => map (pair ([], [])) (Type.sort_of_atyp T)} |
70480
1a1b7d7f24bb
explicit check of left-over constraints from different theory, e.g. due to lack of Thm.trim_context;
wenzelm
parents:
70475
diff
changeset
|
1017 |
(typ, sort); |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1018 |
|
79308
c9f253e91257
more robust: avoid assumption about Context.certificate_theory;
wenzelm
parents:
79307
diff
changeset
|
1019 |
fun bad_constraint_theory cert ({theory = thy, ...}: constraint) = |
c9f253e91257
more robust: avoid assumption about Context.certificate_theory;
wenzelm
parents:
79307
diff
changeset
|
1020 |
if Context.eq_thy_id (Context.certificate_theory_id cert, Context.theory_id thy) |
c9f253e91257
more robust: avoid assumption about Context.certificate_theory;
wenzelm
parents:
79307
diff
changeset
|
1021 |
then NONE else SOME thy; |
c9f253e91257
more robust: avoid assumption about Context.certificate_theory;
wenzelm
parents:
79307
diff
changeset
|
1022 |
|
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1023 |
in |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1024 |
|
79308
c9f253e91257
more robust: avoid assumption about Context.certificate_theory;
wenzelm
parents:
79307
diff
changeset
|
1025 |
fun solve_constraints (thm as Thm (der, args)) = |
79309
cf8ccfec5059
more normalization: re-use Thm.solve_constraints as important checkpoint for results, notably Global_Theory.name_thm;
wenzelm
parents:
79308
diff
changeset
|
1026 |
let |
cf8ccfec5059
more normalization: re-use Thm.solve_constraints as important checkpoint for results, notably Global_Theory.name_thm;
wenzelm
parents:
79308
diff
changeset
|
1027 |
val {cert, tags, maxidx, constraints, shyps, hyps, tpairs, prop} = args; |
cf8ccfec5059
more normalization: re-use Thm.solve_constraints as important checkpoint for results, notably Global_Theory.name_thm;
wenzelm
parents:
79308
diff
changeset
|
1028 |
|
cf8ccfec5059
more normalization: re-use Thm.solve_constraints as important checkpoint for results, notably Global_Theory.name_thm;
wenzelm
parents:
79308
diff
changeset
|
1029 |
val bad_thys = map_filter (bad_constraint_theory cert) constraints; |
cf8ccfec5059
more normalization: re-use Thm.solve_constraints as important checkpoint for results, notably Global_Theory.name_thm;
wenzelm
parents:
79308
diff
changeset
|
1030 |
val _ = |
cf8ccfec5059
more normalization: re-use Thm.solve_constraints as important checkpoint for results, notably Global_Theory.name_thm;
wenzelm
parents:
79308
diff
changeset
|
1031 |
if null bad_thys then () |
cf8ccfec5059
more normalization: re-use Thm.solve_constraints as important checkpoint for results, notably Global_Theory.name_thm;
wenzelm
parents:
79308
diff
changeset
|
1032 |
else |
cf8ccfec5059
more normalization: re-use Thm.solve_constraints as important checkpoint for results, notably Global_Theory.name_thm;
wenzelm
parents:
79308
diff
changeset
|
1033 |
raise THEORY ("solve_constraints: bad theories for theorem\n" ^ |
cf8ccfec5059
more normalization: re-use Thm.solve_constraints as important checkpoint for results, notably Global_Theory.name_thm;
wenzelm
parents:
79308
diff
changeset
|
1034 |
Syntax.string_of_term_global (hd bad_thys) (prop_of thm), bad_thys); |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1035 |
|
79309
cf8ccfec5059
more normalization: re-use Thm.solve_constraints as important checkpoint for results, notably Global_Theory.name_thm;
wenzelm
parents:
79308
diff
changeset
|
1036 |
val Deriv {promises, body = PBody {oracles, thms, zboxes, zproof, proof}} = der; |
cf8ccfec5059
more normalization: re-use Thm.solve_constraints as important checkpoint for results, notably Global_Theory.name_thm;
wenzelm
parents:
79308
diff
changeset
|
1037 |
val (oracles', thms') = (oracles, thms) |
cf8ccfec5059
more normalization: re-use Thm.solve_constraints as important checkpoint for results, notably Global_Theory.name_thm;
wenzelm
parents:
79308
diff
changeset
|
1038 |
|> fold (fold union_digest o constraint_digest) constraints; |
cf8ccfec5059
more normalization: re-use Thm.solve_constraints as important checkpoint for results, notably Global_Theory.name_thm;
wenzelm
parents:
79308
diff
changeset
|
1039 |
val zproof' = ZTerm.beta_norm_prooft zproof; |
cf8ccfec5059
more normalization: re-use Thm.solve_constraints as important checkpoint for results, notably Global_Theory.name_thm;
wenzelm
parents:
79308
diff
changeset
|
1040 |
in |
cf8ccfec5059
more normalization: re-use Thm.solve_constraints as important checkpoint for results, notably Global_Theory.name_thm;
wenzelm
parents:
79308
diff
changeset
|
1041 |
Thm (make_deriv promises oracles' thms' zboxes zproof' proof, |
cf8ccfec5059
more normalization: re-use Thm.solve_constraints as important checkpoint for results, notably Global_Theory.name_thm;
wenzelm
parents:
79308
diff
changeset
|
1042 |
{constraints = [], cert = cert, tags = tags, maxidx = maxidx, |
cf8ccfec5059
more normalization: re-use Thm.solve_constraints as important checkpoint for results, notably Global_Theory.name_thm;
wenzelm
parents:
79308
diff
changeset
|
1043 |
shyps = shyps, hyps = hyps, tpairs = tpairs, prop = prop}) |
cf8ccfec5059
more normalization: re-use Thm.solve_constraints as important checkpoint for results, notably Global_Theory.name_thm;
wenzelm
parents:
79308
diff
changeset
|
1044 |
end; |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1045 |
|
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1046 |
end; |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1047 |
|
71527 | 1048 |
(*Dangling sort constraints of a thm*) |
1049 |
fun extra_shyps (th as Thm (_, {shyps, ...})) = |
|
77869 | 1050 |
Sorts.subtract (fold_terms {hyps = true} Sorts.insert_term th []) shyps; |
71527 | 1051 |
|
1052 |
(*Remove extra sorts that are witnessed by type signature information*) |
|
77869 | 1053 |
fun strip_shyps thm = |
1054 |
(case thm of |
|
1055 |
Thm (_, {shyps = [], ...}) => thm |
|
1056 |
| Thm (der, {cert, tags, maxidx, constraints, shyps, hyps, tpairs, prop}) => |
|
71527 | 1057 |
let |
79387 | 1058 |
val Deriv {promises, body = PBody {oracles, thms, zboxes, zproof, proof}} = der; |
1059 |
||
71527 | 1060 |
val thy = theory_of_thm thm; |
1061 |
||
1062 |
val algebra = Sign.classes_of thy; |
|
1063 |
val minimize = Sorts.minimize_sort algebra; |
|
1064 |
val le = Sorts.sort_le algebra; |
|
1065 |
fun lt (S1, S2) = le (S1, S2) andalso not (le (S2, S1)); |
|
1066 |
fun rel (S1, S2) = if S1 = S2 then [] else [(Term.aT S1, S2)]; |
|
1067 |
||
79386
bd52ab785b7b
minor performance tuning, following 703201dbd413;
wenzelm
parents:
79365
diff
changeset
|
1068 |
val present_set = |
bd52ab785b7b
minor performance tuning, following 703201dbd413;
wenzelm
parents:
79365
diff
changeset
|
1069 |
Types.build (thm |> (fold_terms {hyps = true} o fold_types o fold_atyps) Types.add_set); |
bd52ab785b7b
minor performance tuning, following 703201dbd413;
wenzelm
parents:
79365
diff
changeset
|
1070 |
val present = map (fn T => (T, Type.sort_of_atyp T)) (Types.list_set present_set); |
bd52ab785b7b
minor performance tuning, following 703201dbd413;
wenzelm
parents:
79365
diff
changeset
|
1071 |
|
77869 | 1072 |
val extra = fold (Sorts.remove_sort o #2) present shyps; |
1073 |
val witnessed = Sign.witness_sorts thy present extra; |
|
1074 |
val non_witnessed = fold (Sorts.remove_sort o #2) witnessed extra |> map (`minimize); |
|
71527 | 1075 |
|
1076 |
val extra' = |
|
1077 |
non_witnessed |> map_filter (fn (S, _) => |
|
1078 |
if non_witnessed |> exists (fn (S', _) => lt (S', S)) then NONE else SOME S) |
|
77869 | 1079 |
|> Sorts.make; |
71527 | 1080 |
|
1081 |
val constrs' = |
|
1082 |
non_witnessed |> maps (fn (S1, S2) => |
|
77869 | 1083 |
let val S0 = the (find_first (fn S => le (S, S1)) extra') |
71527 | 1084 |
in rel (S0, S1) @ rel (S1, S2) end); |
1085 |
||
1086 |
val constraints' = fold (insert_constraints thy) (witnessed @ constrs') constraints; |
|
77869 | 1087 |
val shyps' = fold (Sorts.insert_sort o #2) present extra'; |
79224 | 1088 |
|
79387 | 1089 |
val replacements = present @ witnessed @ map (`Logic.dummy_tfree) extra'; |
1090 |
fun get_replacement S = |
|
1091 |
replacements |> get_first (fn (T', S') => if le (S', S) then SOME T' else NONE); |
|
1092 |
fun replace_atyp T = |
|
1093 |
if Types.defined present_set T then raise Same.SAME |
|
1094 |
else |
|
1095 |
(case get_replacement (Type.sort_of_atyp T) of |
|
1096 |
SOME T' => T' |
|
1097 |
| NONE => raise Fail "strip_shyps: bad type variable in proof term"); |
|
1098 |
||
1099 |
val proof' = proof |
|
1100 |
|> Same.commit (Proofterm.map_proof_types_same (Term_Subst.map_atypsT_same replace_atyp)); |
|
71527 | 1101 |
in |
79224 | 1102 |
Thm (make_deriv promises oracles thms zboxes zproof proof', |
71527 | 1103 |
{cert = cert, tags = tags, maxidx = maxidx, constraints = constraints', |
1104 |
shyps = shyps', hyps = hyps, tpairs = tpairs, prop = prop}) |
|
77869 | 1105 |
end) |
1106 |
|> solve_constraints; |
|
1107 |
||
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1108 |
|
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1109 |
|
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1110 |
(*** Closed theorems with official name ***) |
70458 | 1111 |
|
1112 |
(*non-deterministic, depends on unknown promises*) |
|
1113 |
fun derivation_closed (Thm (Deriv {body, ...}, _)) = |
|
1114 |
Proofterm.compact_proof (Proofterm.proof_of body); |
|
1115 |
||
1116 |
(*non-deterministic, depends on unknown promises*) |
|
70543
33749040b6f8
clarified derivation_name vs. raw_derivation_name;
wenzelm
parents:
70517
diff
changeset
|
1117 |
fun raw_derivation_name (Thm (Deriv {body, ...}, {shyps, hyps, prop, ...})) = |
77863
760515c45864
revert b43ee37926a9 due to problems with AFP/PAPP_Impossibility;
wenzelm
parents:
77827
diff
changeset
|
1118 |
Proofterm.get_approximative_name shyps hyps prop (Proofterm.proof_of body); |
70458 | 1119 |
|
70915
bd4d37edfee4
clarified expand_proof/expand_name: allow more detailed control via thm_header;
wenzelm
parents:
70908
diff
changeset
|
1120 |
fun expand_name (Thm (Deriv {body, ...}, {shyps, hyps, prop, ...})) = |
bd4d37edfee4
clarified expand_proof/expand_name: allow more detailed control via thm_header;
wenzelm
parents:
70908
diff
changeset
|
1121 |
let |
bd4d37edfee4
clarified expand_proof/expand_name: allow more detailed control via thm_header;
wenzelm
parents:
70908
diff
changeset
|
1122 |
val self_id = |
77863
760515c45864
revert b43ee37926a9 due to problems with AFP/PAPP_Impossibility;
wenzelm
parents:
77827
diff
changeset
|
1123 |
(case Proofterm.get_identity shyps hyps prop (Proofterm.proof_of body) of |
70915
bd4d37edfee4
clarified expand_proof/expand_name: allow more detailed control via thm_header;
wenzelm
parents:
70908
diff
changeset
|
1124 |
NONE => K false |
bd4d37edfee4
clarified expand_proof/expand_name: allow more detailed control via thm_header;
wenzelm
parents:
70908
diff
changeset
|
1125 |
| SOME {serial, ...} => fn (header: Proofterm.thm_header) => serial = #serial header); |
bd4d37edfee4
clarified expand_proof/expand_name: allow more detailed control via thm_header;
wenzelm
parents:
70908
diff
changeset
|
1126 |
fun expand header = if self_id header orelse #name header = "" then SOME "" else NONE; |
bd4d37edfee4
clarified expand_proof/expand_name: allow more detailed control via thm_header;
wenzelm
parents:
70908
diff
changeset
|
1127 |
in expand end; |
bd4d37edfee4
clarified expand_proof/expand_name: allow more detailed control via thm_header;
wenzelm
parents:
70908
diff
changeset
|
1128 |
|
70543
33749040b6f8
clarified derivation_name vs. raw_derivation_name;
wenzelm
parents:
70517
diff
changeset
|
1129 |
(*deterministic name of finished proof*) |
33749040b6f8
clarified derivation_name vs. raw_derivation_name;
wenzelm
parents:
70517
diff
changeset
|
1130 |
fun derivation_name (thm as Thm (_, {shyps, hyps, prop, ...})) = |
77863
760515c45864
revert b43ee37926a9 due to problems with AFP/PAPP_Impossibility;
wenzelm
parents:
77827
diff
changeset
|
1131 |
Proofterm.get_approximative_name shyps hyps prop (proof_of thm); |
70543
33749040b6f8
clarified derivation_name vs. raw_derivation_name;
wenzelm
parents:
70517
diff
changeset
|
1132 |
|
70595
2ae7e33c950f
clarified thm_id vs. thm_node/thm: retain theory_name;
wenzelm
parents:
70593
diff
changeset
|
1133 |
(*identified PThm node*) |
70551
9e87e978be5e
clarified identity of PThm nodes: do not reuse old id after renaming -- enforce uniqueness of substructures;
wenzelm
parents:
70543
diff
changeset
|
1134 |
fun derivation_id (thm as Thm (_, {shyps, hyps, prop, ...})) = |
77863
760515c45864
revert b43ee37926a9 due to problems with AFP/PAPP_Impossibility;
wenzelm
parents:
77827
diff
changeset
|
1135 |
Proofterm.get_id shyps hyps prop (proof_of thm); |
70551
9e87e978be5e
clarified identity of PThm nodes: do not reuse old id after renaming -- enforce uniqueness of substructures;
wenzelm
parents:
70543
diff
changeset
|
1136 |
|
70595
2ae7e33c950f
clarified thm_id vs. thm_node/thm: retain theory_name;
wenzelm
parents:
70593
diff
changeset
|
1137 |
(*dependencies of PThm node*) |
77873 | 1138 |
fun thm_deps (thm as Thm (Deriv {promises = [], body = PBody {thms, ...}, ...}, _)) = |
77866 | 1139 |
(case (derivation_id thm, thms) of |
1140 |
(SOME {serial = i, ...}, [(j, thm_node)]) => |
|
1141 |
if i = j then Proofterm.thm_node_thms thm_node else thms |
|
1142 |
| _ => thms) |
|
77873 | 1143 |
| thm_deps thm = raise THM ("thm_deps: bad promises", 0, [thm]); |
70595
2ae7e33c950f
clarified thm_id vs. thm_node/thm: retain theory_name;
wenzelm
parents:
70593
diff
changeset
|
1144 |
|
70494 | 1145 |
fun name_derivation name_pos = |
71530
046cf49162a3
more thorough strip_shyps for proof boxes (but types are usually stripped and reconstructed later);
wenzelm
parents:
71527
diff
changeset
|
1146 |
strip_shyps #> (fn thm as Thm (der, args) => |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1147 |
let |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1148 |
val thy = theory_of_thm thm; |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1149 |
|
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1150 |
val Deriv {promises, body} = der; |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1151 |
val {shyps, hyps, prop, tpairs, ...} = args; |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1152 |
|
70517
9a9003b5c0c1
more robust -- notably for metis, which tends to accumulate tpairs;
wenzelm
parents:
70503
diff
changeset
|
1153 |
val _ = null tpairs orelse raise THM ("name_derivation: bad flex-flex constraints", 0, [thm]); |
70458 | 1154 |
|
77873 | 1155 |
val ps = map (apsnd (Future.map fulfill_body)) promises; |
79332 | 1156 |
val body' = |
70494 | 1157 |
Proofterm.thm_proof thy (classrel_proof thy) (arity_proof thy) |
77863
760515c45864
revert b43ee37926a9 due to problems with AFP/PAPP_Impossibility;
wenzelm
parents:
77827
diff
changeset
|
1158 |
name_pos shyps hyps prop ps body; |
79262 | 1159 |
in Thm (make_deriv0 [] body', args) end); |
70458 | 1160 |
|
70494 | 1161 |
fun close_derivation pos = |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1162 |
solve_constraints #> (fn thm => |
70517
9a9003b5c0c1
more robust -- notably for metis, which tends to accumulate tpairs;
wenzelm
parents:
70503
diff
changeset
|
1163 |
if not (null (tpairs_of thm)) orelse derivation_closed thm then thm |
9a9003b5c0c1
more robust -- notably for metis, which tends to accumulate tpairs;
wenzelm
parents:
70503
diff
changeset
|
1164 |
else name_derivation ("", pos) thm); |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1165 |
|
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1166 |
val trim_context = solve_constraints #> trim_context_thm; |
70454 | 1167 |
|
1168 |
||
1169 |
||
1170 |
(*** Oracles ***) |
|
1171 |
||
79322 | 1172 |
fun add_oracle (b, oracle_fn) thy1 = |
70454 | 1173 |
let |
79322 | 1174 |
val (name, oracles') = Name_Space.define (Context.Theory thy1) true (b, ()) (get_oracles thy1); |
1175 |
val thy2 = map_oracles (K oracles') thy1; |
|
79323
3bbe31b35f5b
clarified context: avoid capture of thy2 within closure;
wenzelm
parents:
79322
diff
changeset
|
1176 |
val cert2 = Context.Certificate_Id (Context.theory_id thy2); |
70454 | 1177 |
fun invoke_oracle arg = |
79323
3bbe31b35f5b
clarified context: avoid capture of thy2 within closure;
wenzelm
parents:
79322
diff
changeset
|
1178 |
let val ct as Cterm {cert = cert3, t = prop, T, maxidx, sorts} = oracle_fn arg in |
70454 | 1179 |
if T <> propT then |
1180 |
raise THM ("Oracle's result must have type prop: " ^ name, 0, []) |
|
1181 |
else |
|
70834 | 1182 |
let |
79323
3bbe31b35f5b
clarified context: avoid capture of thy2 within closure;
wenzelm
parents:
79322
diff
changeset
|
1183 |
val cert = Context.join_certificate (cert2, cert3); |
79219
8b371e684acf
clarified signature: more explicit get_proofs_level with bounds check;
wenzelm
parents:
79212
diff
changeset
|
1184 |
val proofs = Proofterm.get_proofs_level (); |
8b371e684acf
clarified signature: more explicit get_proofs_level with bounds check;
wenzelm
parents:
79212
diff
changeset
|
1185 |
val oracle = |
8b371e684acf
clarified signature: more explicit get_proofs_level with bounds check;
wenzelm
parents:
79212
diff
changeset
|
1186 |
if Proofterm.oracle_enabled proofs |
8b371e684acf
clarified signature: more explicit get_proofs_level with bounds check;
wenzelm
parents:
79212
diff
changeset
|
1187 |
then ((name, Position.thread_data ()), SOME prop) |
8b371e684acf
clarified signature: more explicit get_proofs_level with bounds check;
wenzelm
parents:
79212
diff
changeset
|
1188 |
else ((name, Position.none), NONE); |
8b371e684acf
clarified signature: more explicit get_proofs_level with bounds check;
wenzelm
parents:
79212
diff
changeset
|
1189 |
val proof = |
8b371e684acf
clarified signature: more explicit get_proofs_level with bounds check;
wenzelm
parents:
79212
diff
changeset
|
1190 |
if Proofterm.proof_enabled proofs |
8b371e684acf
clarified signature: more explicit get_proofs_level with bounds check;
wenzelm
parents:
79212
diff
changeset
|
1191 |
then Proofterm.oracle_proof name prop |
8b371e684acf
clarified signature: more explicit get_proofs_level with bounds check;
wenzelm
parents:
79212
diff
changeset
|
1192 |
else MinProof; |
8b371e684acf
clarified signature: more explicit get_proofs_level with bounds check;
wenzelm
parents:
79212
diff
changeset
|
1193 |
val zproof = |
79321 | 1194 |
if Proofterm.zproof_enabled proofs then |
1195 |
let |
|
79322 | 1196 |
val thy = Context.certificate_theory cert handle ERROR msg => |
79323
3bbe31b35f5b
clarified context: avoid capture of thy2 within closure;
wenzelm
parents:
79322
diff
changeset
|
1197 |
raise CONTEXT (msg, [], [ct], [], NONE); |
79322 | 1198 |
in ZTerm.oracle_proof thy name prop end |
79219
8b371e684acf
clarified signature: more explicit get_proofs_level with bounds check;
wenzelm
parents:
79212
diff
changeset
|
1199 |
else ZDummy; |
70834 | 1200 |
in |
79279 | 1201 |
Thm (make_deriv [] [oracle] [] [] zproof proof, |
79119 | 1202 |
{cert = cert, |
70454 | 1203 |
tags = [], |
1204 |
maxidx = maxidx, |
|
77868 | 1205 |
constraints = [], |
70454 | 1206 |
shyps = sorts, |
77863
760515c45864
revert b43ee37926a9 due to problems with AFP/PAPP_Impossibility;
wenzelm
parents:
77827
diff
changeset
|
1207 |
hyps = [], |
70454 | 1208 |
tpairs = [], |
1209 |
prop = prop}) |
|
1210 |
end |
|
1211 |
end; |
|
79322 | 1212 |
in ((name, invoke_oracle), thy2) end; |
70454 | 1213 |
|
70560 | 1214 |
val oracle_space = Name_Space.space_of_table o get_oracles; |
1215 |
||
1216 |
fun pretty_oracle ctxt = |
|
1217 |
Name_Space.pretty ctxt (oracle_space (Proof_Context.theory_of ctxt)); |
|
1218 |
||
70454 | 1219 |
fun extern_oracles verbose ctxt = |
1220 |
map #1 (Name_Space.markup_table verbose ctxt (get_oracles (Proof_Context.theory_of ctxt))); |
|
1221 |
||
70565 | 1222 |
fun check_oracle ctxt = |
1223 |
Name_Space.check (Context.Proof ctxt) (get_oracles (Proof_Context.theory_of ctxt)) #> #1; |
|
1224 |
||
70454 | 1225 |
|
1226 |
||
1529 | 1227 |
(*** Meta rules ***) |
0 | 1228 |
|
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1229 |
(** primitive rules **) |
0 | 1230 |
|
16656 | 1231 |
(*The assumption rule A |- A*) |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1232 |
fun assume raw_ct = |
79321 | 1233 |
let val ct as Cterm {cert, t = prop, T, maxidx, sorts} = adjust_maxidx_cterm ~1 raw_ct in |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1234 |
if T <> propT then |
19230 | 1235 |
raise THM ("assume: prop", 0, []) |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1236 |
else if maxidx <> ~1 then |
19230 | 1237 |
raise THM ("assume: variables", maxidx, []) |
79119 | 1238 |
else |
1239 |
let |
|
79321 | 1240 |
fun zproof () = |
1241 |
let |
|
1242 |
val thy = Context.certificate_theory cert handle ERROR msg => |
|
1243 |
raise CONTEXT (msg, [], [ct], [], NONE); |
|
1244 |
in ZTerm.assume_proof thy prop end; |
|
79221 | 1245 |
fun proof () = Proofterm.Hyp prop; |
79119 | 1246 |
in |
79221 | 1247 |
Thm (deriv_rule0 zproof proof, |
79119 | 1248 |
{cert = cert, |
1249 |
tags = [], |
|
1250 |
maxidx = ~1, |
|
1251 |
constraints = [], |
|
1252 |
shyps = sorts, |
|
1253 |
hyps = [prop], |
|
1254 |
tpairs = [], |
|
1255 |
prop = prop}) |
|
1256 |
end |
|
0 | 1257 |
end; |
1258 |
||
1220 | 1259 |
(*Implication introduction |
3529 | 1260 |
[A] |
1261 |
: |
|
1262 |
B |
|
1220 | 1263 |
------- |
67721 | 1264 |
A \<Longrightarrow> B |
1220 | 1265 |
*) |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1266 |
fun implies_intr |
68691 | 1267 |
(ct as Cterm {t = A, T, maxidx = maxidx1, sorts, ...}) |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1268 |
(th as Thm (der, {maxidx = maxidx2, hyps, constraints, shyps, tpairs, prop, ...})) = |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1269 |
if T <> propT then |
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1270 |
raise THM ("implies_intr: assumptions must have type prop", 0, [th]) |
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1271 |
else |
79119 | 1272 |
let |
1273 |
val cert = join_certificate1 (ct, th); |
|
79321 | 1274 |
fun zproof p = |
1275 |
let |
|
1276 |
val thy = Context.certificate_theory cert handle ERROR msg => |
|
1277 |
raise CONTEXT (msg, [], [ct], [th], NONE); |
|
1278 |
in ZTerm.implies_intr_proof thy A p end |
|
79221 | 1279 |
fun proof p = Proofterm.implies_intr_proof A p; |
79119 | 1280 |
in |
79221 | 1281 |
Thm (deriv_rule1 zproof proof der, |
79119 | 1282 |
{cert = cert, |
1283 |
tags = [], |
|
1284 |
maxidx = Int.max (maxidx1, maxidx2), |
|
1285 |
constraints = constraints, |
|
1286 |
shyps = Sorts.union sorts shyps, |
|
1287 |
hyps = remove_hyps A hyps, |
|
1288 |
tpairs = tpairs, |
|
1289 |
prop = Logic.mk_implies (A, prop)}) |
|
1290 |
end; |
|
0 | 1291 |
|
1529 | 1292 |
|
1220 | 1293 |
(*Implication elimination |
67721 | 1294 |
A \<Longrightarrow> B A |
1220 | 1295 |
------------ |
1296 |
B |
|
1297 |
*) |
|
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1298 |
fun implies_elim thAB thA = |
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1299 |
let |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1300 |
val Thm (derA, |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1301 |
{maxidx = maxidx1, hyps = hypsA, constraints = constraintsA, shyps = shypsA, |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1302 |
tpairs = tpairsA, prop = propA, ...}) = thA |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1303 |
and Thm (der, {maxidx = maxidx2, hyps, constraints, shyps, tpairs, prop, ...}) = thAB; |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1304 |
fun err () = raise THM ("implies_elim: major premise", 0, [thAB, thA]); |
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1305 |
in |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1306 |
(case prop of |
56245 | 1307 |
Const ("Pure.imp", _) $ A $ B => |
20512 | 1308 |
if A aconv propA then |
79221 | 1309 |
Thm (deriv_rule2 (curry ZAppp) (curry Proofterm.%%) der derA, |
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
1310 |
{cert = join_certificate2 (thAB, thA), |
21646
c07b5b0e8492
thm/prf: separate official name vs. additional tags;
wenzelm
parents:
21576
diff
changeset
|
1311 |
tags = [], |
68691 | 1312 |
maxidx = Int.max (maxidx1, maxidx2), |
77868 | 1313 |
constraints = union_constraints constraintsA constraints, |
77869 | 1314 |
shyps = Sorts.union shypsA shyps, |
77863
760515c45864
revert b43ee37926a9 due to problems with AFP/PAPP_Impossibility;
wenzelm
parents:
77827
diff
changeset
|
1315 |
hyps = union_hyps hypsA hyps, |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1316 |
tpairs = union_tpairs tpairsA tpairs, |
28321
9f4499bf9384
type thm: fully internal derivation, no longer exported;
wenzelm
parents:
28290
diff
changeset
|
1317 |
prop = B}) |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1318 |
else err () |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1319 |
| _ => err ()) |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1320 |
end; |
250 | 1321 |
|
1220 | 1322 |
(*Forall introduction. The Free or Var x must not be free in the hypotheses. |
16656 | 1323 |
[x] |
1324 |
: |
|
1325 |
A |
|
1326 |
------ |
|
67721 | 1327 |
\<And>x. A |
1220 | 1328 |
*) |
77807 | 1329 |
fun occs x ts tpairs = |
1330 |
let fun occs t = Logic.occs (x, t) |
|
77863
760515c45864
revert b43ee37926a9 due to problems with AFP/PAPP_Impossibility;
wenzelm
parents:
77827
diff
changeset
|
1331 |
in exists occs ts orelse exists (occs o fst) tpairs orelse exists (occs o snd) tpairs end; |
77807 | 1332 |
|
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1333 |
fun forall_intr |
68692
0c568ec56f37
proper maxidx: if x does not occur in A, its maxidx could get lost;
wenzelm
parents:
68691
diff
changeset
|
1334 |
(ct as Cterm {maxidx = maxidx1, t = x, T, sorts, ...}) |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1335 |
(th as Thm (der, {maxidx = maxidx2, constraints, shyps, hyps, tpairs, prop, ...})) = |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1336 |
let |
77807 | 1337 |
fun check_result a ts = |
1338 |
if occs x ts tpairs then |
|
21798 | 1339 |
raise THM ("forall_intr: variable " ^ quote a ^ " free in assumptions", 0, [th]) |
77807 | 1340 |
else |
79119 | 1341 |
let |
1342 |
val cert = join_certificate1 (ct, th); |
|
79321 | 1343 |
fun zproof p = |
1344 |
let |
|
1345 |
val thy = Context.certificate_theory cert handle ERROR msg => |
|
1346 |
raise CONTEXT (msg, [], [ct], [th], NONE); |
|
1347 |
in ZTerm.forall_intr_proof thy T (a, x) p end; |
|
79221 | 1348 |
fun proof p = Proofterm.forall_intr_proof (a, x) NONE p; |
79119 | 1349 |
in |
79221 | 1350 |
Thm (deriv_rule1 zproof proof der, |
79119 | 1351 |
{cert = cert, |
1352 |
tags = [], |
|
1353 |
maxidx = Int.max (maxidx1, maxidx2), |
|
1354 |
constraints = constraints, |
|
1355 |
shyps = Sorts.union sorts shyps, |
|
1356 |
hyps = hyps, |
|
1357 |
tpairs = tpairs, |
|
1358 |
prop = Logic.all_const T $ Abs (a, T, abstract_over (x, prop))}) |
|
1359 |
end; |
|
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1360 |
in |
52788 | 1361 |
(case x of |
77807 | 1362 |
Free (a, _) => check_result a hyps |
77863
760515c45864
revert b43ee37926a9 due to problems with AFP/PAPP_Impossibility;
wenzelm
parents:
77827
diff
changeset
|
1363 |
| Var ((a, _), _) => check_result a [] |
52788 | 1364 |
| _ => raise THM ("forall_intr: not a variable", 0, [th])) |
0 | 1365 |
end; |
1366 |
||
1220 | 1367 |
(*Forall elimination |
67721 | 1368 |
\<And>x. A |
1220 | 1369 |
------ |
1370 |
A[t/x] |
|
1371 |
*) |
|
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1372 |
fun forall_elim |
68691 | 1373 |
(ct as Cterm {t, T, maxidx = maxidx1, sorts, ...}) |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1374 |
(th as Thm (der, {maxidx = maxidx2, constraints, shyps, hyps, tpairs, prop, ...})) = |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1375 |
(case prop of |
56245 | 1376 |
Const ("Pure.all", Type ("fun", [Type ("fun", [qary, _]), _])) $ A => |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1377 |
if T <> qary then |
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1378 |
raise THM ("forall_elim: type mismatch", 0, [th]) |
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1379 |
else |
79119 | 1380 |
let |
1381 |
val cert = join_certificate1 (ct, th); |
|
79321 | 1382 |
fun zproof p = |
1383 |
let |
|
1384 |
val thy = Context.certificate_theory cert handle ERROR msg => |
|
1385 |
raise CONTEXT (msg, [], [ct], [th], NONE); |
|
1386 |
in ZTerm.forall_elim_proof thy t p end; |
|
79221 | 1387 |
fun proof p = p % SOME t; |
79119 | 1388 |
in |
79221 | 1389 |
Thm (deriv_rule1 zproof proof der, |
79119 | 1390 |
{cert = cert, |
1391 |
tags = [], |
|
1392 |
maxidx = Int.max (maxidx1, maxidx2), |
|
1393 |
constraints = constraints, |
|
1394 |
shyps = Sorts.union sorts shyps, |
|
1395 |
hyps = hyps, |
|
1396 |
tpairs = tpairs, |
|
1397 |
prop = Term.betapply (A, t)}) |
|
1398 |
end |
|
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1399 |
| _ => raise THM ("forall_elim: not quantified", 0, [th])); |
0 | 1400 |
|
1401 |
||
1220 | 1402 |
(* Equality *) |
0 | 1403 |
|
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1404 |
(*Reflexivity |
67721 | 1405 |
t \<equiv> t |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1406 |
*) |
79321 | 1407 |
fun reflexive (ct as Cterm {cert, t, T, maxidx, sorts}) = |
79221 | 1408 |
let |
79321 | 1409 |
fun zproof () = |
1410 |
let |
|
1411 |
val thy = Context.certificate_theory cert handle ERROR msg => |
|
1412 |
raise CONTEXT (msg, [], [ct], [], NONE); |
|
1413 |
in ZTerm.reflexive_proof thy T t end; |
|
79221 | 1414 |
fun proof () = Proofterm.reflexive_proof; |
1415 |
in |
|
1416 |
Thm (deriv_rule0 zproof proof, |
|
79124 | 1417 |
{cert = cert, |
1418 |
tags = [], |
|
1419 |
maxidx = maxidx, |
|
1420 |
constraints = [], |
|
1421 |
shyps = sorts, |
|
1422 |
hyps = [], |
|
1423 |
tpairs = [], |
|
1424 |
prop = Logic.mk_equals (t, t)}) |
|
1425 |
end; |
|
0 | 1426 |
|
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1427 |
(*Symmetry |
67721 | 1428 |
t \<equiv> u |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1429 |
------ |
67721 | 1430 |
u \<equiv> t |
1220 | 1431 |
*) |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1432 |
fun symmetric (th as Thm (der, {cert, maxidx, constraints, shyps, hyps, tpairs, prop, ...})) = |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1433 |
(case prop of |
79124 | 1434 |
(eq as Const ("Pure.eq", Type ("fun", [T, _]))) $ t $ u => |
79321 | 1435 |
let |
1436 |
fun zproof p = |
|
1437 |
let |
|
1438 |
val thy = Context.certificate_theory cert handle ERROR msg => |
|
1439 |
raise CONTEXT (msg, [], [], [th], NONE); |
|
1440 |
in ZTerm.symmetric_proof thy T t u p end; |
|
1441 |
in |
|
79221 | 1442 |
Thm (deriv_rule1 zproof Proofterm.symmetric_proof der, |
79124 | 1443 |
{cert = cert, |
1444 |
tags = [], |
|
1445 |
maxidx = maxidx, |
|
1446 |
constraints = constraints, |
|
1447 |
shyps = shyps, |
|
1448 |
hyps = hyps, |
|
1449 |
tpairs = tpairs, |
|
1450 |
prop = eq $ u $ t}) |
|
1451 |
end |
|
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1452 |
| _ => raise THM ("symmetric", 0, [th])); |
0 | 1453 |
|
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1454 |
(*Transitivity |
67721 | 1455 |
t1 \<equiv> u u \<equiv> t2 |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1456 |
------------------ |
67721 | 1457 |
t1 \<equiv> t2 |
1220 | 1458 |
*) |
0 | 1459 |
fun transitive th1 th2 = |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1460 |
let |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1461 |
val Thm (der1, {maxidx = maxidx1, hyps = hyps1, constraints = constraints1, shyps = shyps1, |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1462 |
tpairs = tpairs1, prop = prop1, ...}) = th1 |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1463 |
and Thm (der2, {maxidx = maxidx2, hyps = hyps2, constraints = constraints2, shyps = shyps2, |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1464 |
tpairs = tpairs2, prop = prop2, ...}) = th2; |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1465 |
fun err msg = raise THM ("transitive: " ^ msg, 0, [th1, th2]); |
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1466 |
in |
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1467 |
case (prop1, prop2) of |
79124 | 1468 |
((eq as Const ("Pure.eq", Type (_, [T, _]))) $ t1 $ u, Const ("Pure.eq", _) $ u' $ t2) => |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1469 |
if not (u aconv u') then err "middle term" |
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1470 |
else |
79124 | 1471 |
let |
1472 |
val cert = join_certificate2 (th1, th2); |
|
79321 | 1473 |
fun zproof p q = |
1474 |
let |
|
1475 |
val thy = Context.certificate_theory cert handle ERROR msg => |
|
1476 |
raise CONTEXT (msg, [], [], [th1, th2], NONE); |
|
1477 |
in ZTerm.transitive_proof thy T t1 u t2 p q end; |
|
79221 | 1478 |
fun proof p = Proofterm.transitive_proof T u p; |
79124 | 1479 |
in |
79221 | 1480 |
Thm (deriv_rule2 zproof proof der1 der2, |
79124 | 1481 |
{cert = cert, |
1482 |
tags = [], |
|
1483 |
maxidx = Int.max (maxidx1, maxidx2), |
|
1484 |
constraints = union_constraints constraints1 constraints2, |
|
1485 |
shyps = Sorts.union shyps1 shyps2, |
|
1486 |
hyps = union_hyps hyps1 hyps2, |
|
1487 |
tpairs = union_tpairs tpairs1 tpairs2, |
|
1488 |
prop = eq $ t1 $ t2}) |
|
1489 |
end |
|
1490 |
| _ => err "premises" |
|
0 | 1491 |
end; |
1492 |
||
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1493 |
(*Beta-conversion |
67721 | 1494 |
(\<lambda>x. t) u \<equiv> t[u/x] |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1495 |
fully beta-reduces the term if full = true |
10416
5b33e732e459
- Moved rewriting functions to meta_simplifier.ML
berghofe
parents:
10348
diff
changeset
|
1496 |
*) |
79321 | 1497 |
fun beta_conversion full (ct as Cterm {cert, t, T, maxidx, sorts}) = |
79124 | 1498 |
let |
1499 |
val t' = |
|
1500 |
if full then Envir.beta_norm t |
|
1501 |
else |
|
1502 |
(case t of Abs (_, _, bodt) $ u => subst_bound (u, bodt) |
|
1503 |
| _ => raise THM ("beta_conversion: not a redex", 0, [])); |
|
79321 | 1504 |
fun zproof () = |
1505 |
let |
|
1506 |
val thy = Context.certificate_theory cert handle ERROR msg => |
|
1507 |
raise CONTEXT (msg, [], [ct], [], NONE); |
|
1508 |
in ZTerm.reflexive_proof thy T t end; |
|
79221 | 1509 |
fun proof () = Proofterm.reflexive_proof; |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1510 |
in |
79221 | 1511 |
Thm (deriv_rule0 zproof proof, |
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
1512 |
{cert = cert, |
21646
c07b5b0e8492
thm/prf: separate official name vs. additional tags;
wenzelm
parents:
21576
diff
changeset
|
1513 |
tags = [], |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1514 |
maxidx = maxidx, |
77868 | 1515 |
constraints = [], |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1516 |
shyps = sorts, |
77863
760515c45864
revert b43ee37926a9 due to problems with AFP/PAPP_Impossibility;
wenzelm
parents:
77827
diff
changeset
|
1517 |
hyps = [], |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1518 |
tpairs = [], |
28321
9f4499bf9384
type thm: fully internal derivation, no longer exported;
wenzelm
parents:
28290
diff
changeset
|
1519 |
prop = Logic.mk_equals (t, t')}) |
10416
5b33e732e459
- Moved rewriting functions to meta_simplifier.ML
berghofe
parents:
10348
diff
changeset
|
1520 |
end; |
5b33e732e459
- Moved rewriting functions to meta_simplifier.ML
berghofe
parents:
10348
diff
changeset
|
1521 |
|
79321 | 1522 |
fun eta_conversion (ct as Cterm {cert, t, T, maxidx, sorts}) = |
79221 | 1523 |
let |
79321 | 1524 |
fun zproof () = |
1525 |
let |
|
1526 |
val thy = Context.certificate_theory cert handle ERROR msg => |
|
1527 |
raise CONTEXT (msg, [], [ct], [], NONE); |
|
1528 |
in ZTerm.reflexive_proof thy T t end; |
|
79221 | 1529 |
fun proof () = Proofterm.reflexive_proof; |
1530 |
in |
|
1531 |
Thm (deriv_rule0 zproof proof, |
|
79124 | 1532 |
{cert = cert, |
1533 |
tags = [], |
|
1534 |
maxidx = maxidx, |
|
1535 |
constraints = [], |
|
1536 |
shyps = sorts, |
|
1537 |
hyps = [], |
|
1538 |
tpairs = [], |
|
1539 |
prop = Logic.mk_equals (t, Envir.eta_contract t)}) |
|
1540 |
end; |
|
0 | 1541 |
|
79321 | 1542 |
fun eta_long_conversion (ct as Cterm {cert, t, T, maxidx, sorts}) = |
79221 | 1543 |
let |
79321 | 1544 |
fun zproof () = |
1545 |
let |
|
1546 |
val thy = Context.certificate_theory cert handle ERROR msg => |
|
1547 |
raise CONTEXT (msg, [], [ct], [], NONE); |
|
1548 |
in ZTerm.reflexive_proof thy T t end; |
|
79221 | 1549 |
fun proof () = Proofterm.reflexive_proof; |
1550 |
in |
|
1551 |
Thm (deriv_rule0 zproof proof, |
|
79124 | 1552 |
{cert = cert, |
1553 |
tags = [], |
|
1554 |
maxidx = maxidx, |
|
1555 |
constraints = [], |
|
1556 |
shyps = sorts, |
|
1557 |
hyps = [], |
|
1558 |
tpairs = [], |
|
1559 |
prop = Logic.mk_equals (t, Envir.eta_long [] t)}) |
|
1560 |
end; |
|
23493 | 1561 |
|
0 | 1562 |
(*The abstraction rule. The Free or Var x must not be free in the hypotheses. |
1563 |
The bound variable will be named "a" (since x will be something like x320) |
|
67721 | 1564 |
t \<equiv> u |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1565 |
-------------- |
67721 | 1566 |
\<lambda>x. t \<equiv> \<lambda>x. u |
1220 | 1567 |
*) |
77807 | 1568 |
fun abstract_rule b |
79321 | 1569 |
(ct as Cterm {t = x, T, sorts, ...}) |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1570 |
(th as Thm (der, {cert, maxidx, hyps, constraints, shyps, tpairs, prop, ...})) = |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1571 |
let |
79124 | 1572 |
val (U, t, u) = |
1573 |
(case prop of |
|
1574 |
Const ("Pure.eq", Type ("fun", [U, _])) $ t $ u => (U, t, u) |
|
1575 |
| _ => raise THM ("abstract_rule: premise not an equality", 0, [th])); |
|
77807 | 1576 |
fun check_result a ts = |
1577 |
if occs x ts tpairs then |
|
21798 | 1578 |
raise THM ("abstract_rule: variable " ^ quote a ^ " free in assumptions", 0, [th]) |
77807 | 1579 |
else |
79124 | 1580 |
let |
1581 |
val f = Abs (b, T, abstract_over (x, t)); |
|
1582 |
val g = Abs (b, T, abstract_over (x, u)); |
|
79221 | 1583 |
fun zproof p = |
79321 | 1584 |
let |
1585 |
val thy = Context.certificate_theory cert handle ERROR msg => |
|
1586 |
raise CONTEXT (msg, [], [ct], [th], NONE); |
|
1587 |
in ZTerm.abstract_rule_proof thy T U (b, x) f g p end; |
|
79221 | 1588 |
fun proof p = Proofterm.abstract_rule_proof (b, x) p |
79124 | 1589 |
in |
79221 | 1590 |
Thm (deriv_rule1 zproof proof der, |
79124 | 1591 |
{cert = cert, |
1592 |
tags = [], |
|
1593 |
maxidx = maxidx, |
|
1594 |
constraints = constraints, |
|
1595 |
shyps = Sorts.union sorts shyps, |
|
1596 |
hyps = hyps, |
|
1597 |
tpairs = tpairs, |
|
1598 |
prop = Logic.mk_equals (f, g)}) |
|
1599 |
end; |
|
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1600 |
in |
52788 | 1601 |
(case x of |
77807 | 1602 |
Free (a, _) => check_result a hyps |
77863
760515c45864
revert b43ee37926a9 due to problems with AFP/PAPP_Impossibility;
wenzelm
parents:
77827
diff
changeset
|
1603 |
| Var ((a, _), _) => check_result a [] |
52788 | 1604 |
| _ => raise THM ("abstract_rule: not a variable", 0, [th])) |
0 | 1605 |
end; |
1606 |
||
1607 |
(*The combination rule |
|
67721 | 1608 |
f \<equiv> g t \<equiv> u |
1609 |
------------- |
|
1610 |
f t \<equiv> g u |
|
1220 | 1611 |
*) |
0 | 1612 |
fun combination th1 th2 = |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1613 |
let |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1614 |
val Thm (der1, {maxidx = maxidx1, constraints = constraints1, shyps = shyps1, |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1615 |
hyps = hyps1, tpairs = tpairs1, prop = prop1, ...}) = th1 |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1616 |
and Thm (der2, {maxidx = maxidx2, constraints = constraints2, shyps = shyps2, |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1617 |
hyps = hyps2, tpairs = tpairs2, prop = prop2, ...}) = th2; |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1618 |
in |
52788 | 1619 |
(case (prop1, prop2) of |
56245 | 1620 |
(Const ("Pure.eq", Type ("fun", [fT, _])) $ f $ g, |
1621 |
Const ("Pure.eq", Type ("fun", [tT, _])) $ t $ u) => |
|
79124 | 1622 |
let |
1623 |
val U = |
|
1624 |
(case fT of |
|
1625 |
Type ("fun", [T1, U]) => |
|
1626 |
if T1 = tT then U |
|
1627 |
else raise THM ("combination: types", 0, [th1, th2]) |
|
1628 |
| _ => raise THM ("combination: not function type", 0, [th1, th2])); |
|
1629 |
val cert = join_certificate2 (th1, th2); |
|
79221 | 1630 |
fun zproof p q = |
79321 | 1631 |
let |
1632 |
val thy = Context.certificate_theory cert handle ERROR msg => |
|
1633 |
raise CONTEXT (msg, [], [], [th1, th2], NONE); |
|
1634 |
in ZTerm.combination_proof thy fT U f g t u p q end; |
|
79221 | 1635 |
fun proof p q = Proofterm.combination_proof f g t u p q; |
79124 | 1636 |
in |
79221 | 1637 |
Thm (deriv_rule2 zproof proof der1 der2, |
79124 | 1638 |
{cert = cert, |
21646
c07b5b0e8492
thm/prf: separate official name vs. additional tags;
wenzelm
parents:
21576
diff
changeset
|
1639 |
tags = [], |
68691 | 1640 |
maxidx = Int.max (maxidx1, maxidx2), |
77868 | 1641 |
constraints = union_constraints constraints1 constraints2, |
77869 | 1642 |
shyps = Sorts.union shyps1 shyps2, |
77863
760515c45864
revert b43ee37926a9 due to problems with AFP/PAPP_Impossibility;
wenzelm
parents:
77827
diff
changeset
|
1643 |
hyps = union_hyps hyps1 hyps2, |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1644 |
tpairs = union_tpairs tpairs1 tpairs2, |
79124 | 1645 |
prop = Logic.mk_equals (f $ t, g $ u)}) |
1646 |
end |
|
52788 | 1647 |
| _ => raise THM ("combination: premises", 0, [th1, th2])) |
0 | 1648 |
end; |
1649 |
||
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1650 |
(*Equality introduction |
67721 | 1651 |
A \<Longrightarrow> B B \<Longrightarrow> A |
3529 | 1652 |
---------------- |
67721 | 1653 |
A \<equiv> B |
1220 | 1654 |
*) |
0 | 1655 |
fun equal_intr th1 th2 = |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1656 |
let |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1657 |
val Thm (der1, {maxidx = maxidx1, constraints = constraints1, shyps = shyps1, |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1658 |
hyps = hyps1, tpairs = tpairs1, prop = prop1, ...}) = th1 |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1659 |
and Thm (der2, {maxidx = maxidx2, constraints = constraints2, shyps = shyps2, |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1660 |
hyps = hyps2, tpairs = tpairs2, prop = prop2, ...}) = th2; |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1661 |
fun err msg = raise THM ("equal_intr: " ^ msg, 0, [th1, th2]); |
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1662 |
in |
52788 | 1663 |
(case (prop1, prop2) of |
56245 | 1664 |
(Const("Pure.imp", _) $ A $ B, Const("Pure.imp", _) $ B' $ A') => |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1665 |
if A aconv A' andalso B aconv B' then |
79124 | 1666 |
let |
1667 |
val cert = join_certificate2 (th1, th2); |
|
79221 | 1668 |
fun proof p q = Proofterm.equal_intr_proof A B p q; |
79321 | 1669 |
fun zproof p q = |
1670 |
let |
|
1671 |
val thy = Context.certificate_theory cert handle ERROR msg => |
|
1672 |
raise CONTEXT (msg, [], [], [th1, th2], NONE); |
|
1673 |
in ZTerm.equal_intr_proof thy A B p q end; |
|
79124 | 1674 |
in |
79221 | 1675 |
Thm (deriv_rule2 zproof proof der1 der2, |
79124 | 1676 |
{cert = cert, |
1677 |
tags = [], |
|
1678 |
maxidx = Int.max (maxidx1, maxidx2), |
|
1679 |
constraints = union_constraints constraints1 constraints2, |
|
1680 |
shyps = Sorts.union shyps1 shyps2, |
|
1681 |
hyps = union_hyps hyps1 hyps2, |
|
1682 |
tpairs = union_tpairs tpairs1 tpairs2, |
|
1683 |
prop = Logic.mk_equals (A, B)}) |
|
1684 |
end |
|
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1685 |
else err "not equal" |
52788 | 1686 |
| _ => err "premises") |
1529 | 1687 |
end; |
1688 |
||
1689 |
(*The equal propositions rule |
|
67721 | 1690 |
A \<equiv> B A |
1529 | 1691 |
--------- |
1692 |
B |
|
1693 |
*) |
|
1694 |
fun equal_elim th1 th2 = |
|
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1695 |
let |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1696 |
val Thm (der1, {maxidx = maxidx1, constraints = constraints1, shyps = shyps1, |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1697 |
hyps = hyps1, tpairs = tpairs1, prop = prop1, ...}) = th1 |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1698 |
and Thm (der2, {maxidx = maxidx2, constraints = constraints2, shyps = shyps2, |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1699 |
hyps = hyps2, tpairs = tpairs2, prop = prop2, ...}) = th2; |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1700 |
fun err msg = raise THM ("equal_elim: " ^ msg, 0, [th1, th2]); |
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1701 |
in |
52788 | 1702 |
(case prop1 of |
56245 | 1703 |
Const ("Pure.eq", _) $ A $ B => |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1704 |
if prop2 aconv A then |
79124 | 1705 |
let |
1706 |
val cert = join_certificate2 (th1, th2); |
|
79221 | 1707 |
fun proof p q = Proofterm.equal_elim_proof A B p q; |
79321 | 1708 |
fun zproof p q = |
1709 |
let |
|
1710 |
val thy = Context.certificate_theory cert handle ERROR msg => |
|
1711 |
raise CONTEXT (msg, [], [], [th1, th2], NONE); |
|
1712 |
in ZTerm.equal_elim_proof thy A B p q end; |
|
79124 | 1713 |
in |
79221 | 1714 |
Thm (deriv_rule2 zproof proof der1 der2, |
79124 | 1715 |
{cert = cert, |
1716 |
tags = [], |
|
1717 |
maxidx = Int.max (maxidx1, maxidx2), |
|
1718 |
constraints = union_constraints constraints1 constraints2, |
|
1719 |
shyps = Sorts.union shyps1 shyps2, |
|
1720 |
hyps = union_hyps hyps1 hyps2, |
|
1721 |
tpairs = union_tpairs tpairs1 tpairs2, |
|
1722 |
prop = B}) |
|
1723 |
end |
|
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1724 |
else err "not equal" |
52789 | 1725 |
| _ => err "major premise") |
1529 | 1726 |
end; |
0 | 1727 |
|
1220 | 1728 |
|
1729 |
||
0 | 1730 |
(**** Derived rules ****) |
1731 |
||
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1732 |
(*Smash unifies the list of term pairs leaving no flex-flex pairs. |
24143
90a9a6fe0d01
replaced Theory.self_ref by Theory.check_thy, which now produces a checked ref;
wenzelm
parents:
23781
diff
changeset
|
1733 |
Instantiates the theorem and deletes trivial tpairs. Resulting |
90a9a6fe0d01
replaced Theory.self_ref by Theory.check_thy, which now produces a checked ref;
wenzelm
parents:
23781
diff
changeset
|
1734 |
sequence may contain multiple elements if the tpairs are not all |
90a9a6fe0d01
replaced Theory.self_ref by Theory.check_thy, which now produces a checked ref;
wenzelm
parents:
23781
diff
changeset
|
1735 |
flex-flex.*) |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1736 |
fun flexflex_rule opt_ctxt = |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1737 |
solve_constraints #> (fn th => |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1738 |
let |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1739 |
val Thm (der, {cert, maxidx, constraints, shyps, hyps, tpairs, prop, ...}) = th; |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1740 |
val (context, cert') = make_context_certificate [th] opt_ctxt cert; |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1741 |
in |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1742 |
Unify.smash_unifiers context tpairs (Envir.empty maxidx) |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1743 |
|> Seq.map (fn env => |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1744 |
if Envir.is_empty env then th |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1745 |
else |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1746 |
let |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1747 |
val tpairs' = tpairs |> map (apply2 (Envir.norm_term env)) |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1748 |
(*remove trivial tpairs, of the form t \<equiv> t*) |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1749 |
|> filter_out (op aconv); |
79206 | 1750 |
val prop' = Envir.norm_term env prop; |
78033
9c18535a9fcd
proper exception CONTEXT for Context.certificate_theory;
wenzelm
parents:
77966
diff
changeset
|
1751 |
val thy' = Context.certificate_theory cert' handle ERROR msg => |
9c18535a9fcd
proper exception CONTEXT for Context.certificate_theory;
wenzelm
parents:
77966
diff
changeset
|
1752 |
raise CONTEXT (msg, [], [], [th], Option.map Context.Proof opt_ctxt); |
79207 | 1753 |
|
79270
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79263
diff
changeset
|
1754 |
fun zproof p = ZTerm.norm_proof thy' env [full_prop_of th] p; |
79221 | 1755 |
fun proof p = Proofterm.norm_proof_remove_types env p; |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1756 |
in |
79221 | 1757 |
Thm (deriv_rule1 zproof proof der, |
79206 | 1758 |
{cert = cert', |
1759 |
tags = [], |
|
1760 |
maxidx = maxidx_tpairs tpairs' (maxidx_of_term prop'), |
|
1761 |
constraints = insert_constraints_env thy' env constraints, |
|
1762 |
shyps = Envir.insert_sorts env shyps, |
|
1763 |
hyps = hyps, |
|
1764 |
tpairs = tpairs', |
|
1765 |
prop = prop'}) |
|
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1766 |
end) |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1767 |
end); |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1768 |
|
0 | 1769 |
|
19910 | 1770 |
(*Generalization of fixed variables |
1771 |
A |
|
1772 |
-------------------- |
|
1773 |
A[?'a/'a, ?x/x, ...] |
|
1774 |
*) |
|
1775 |
||
74200
17090e27aae9
more scalable data structure (but: rarely used with > 5 arguments);
wenzelm
parents:
74112
diff
changeset
|
1776 |
fun generalize (tfrees, frees) idx th = |
74266 | 1777 |
if Names.is_empty tfrees andalso Names.is_empty frees then th |
74200
17090e27aae9
more scalable data structure (but: rarely used with > 5 arguments);
wenzelm
parents:
74112
diff
changeset
|
1778 |
else |
17090e27aae9
more scalable data structure (but: rarely used with > 5 arguments);
wenzelm
parents:
74112
diff
changeset
|
1779 |
let |
17090e27aae9
more scalable data structure (but: rarely used with > 5 arguments);
wenzelm
parents:
74112
diff
changeset
|
1780 |
val Thm (der, {cert, maxidx, constraints, shyps, hyps, tpairs, prop, ...}) = th; |
17090e27aae9
more scalable data structure (but: rarely used with > 5 arguments);
wenzelm
parents:
74112
diff
changeset
|
1781 |
val _ = idx <= maxidx andalso raise THM ("generalize: bad index", idx, [th]); |
19910 | 1782 |
|
74200
17090e27aae9
more scalable data structure (but: rarely used with > 5 arguments);
wenzelm
parents:
74112
diff
changeset
|
1783 |
val bad_type = |
74266 | 1784 |
if Names.is_empty tfrees then K false |
1785 |
else Term.exists_subtype (fn TFree (a, _) => Names.defined tfrees a | _ => false); |
|
1786 |
fun bad_term (Free (x, T)) = bad_type T orelse Names.defined frees x |
|
74200
17090e27aae9
more scalable data structure (but: rarely used with > 5 arguments);
wenzelm
parents:
74112
diff
changeset
|
1787 |
| bad_term (Var (_, T)) = bad_type T |
17090e27aae9
more scalable data structure (but: rarely used with > 5 arguments);
wenzelm
parents:
74112
diff
changeset
|
1788 |
| bad_term (Const (_, T)) = bad_type T |
17090e27aae9
more scalable data structure (but: rarely used with > 5 arguments);
wenzelm
parents:
74112
diff
changeset
|
1789 |
| bad_term (Abs (_, T, t)) = bad_type T orelse bad_term t |
17090e27aae9
more scalable data structure (but: rarely used with > 5 arguments);
wenzelm
parents:
74112
diff
changeset
|
1790 |
| bad_term (t $ u) = bad_term t orelse bad_term u |
17090e27aae9
more scalable data structure (but: rarely used with > 5 arguments);
wenzelm
parents:
74112
diff
changeset
|
1791 |
| bad_term (Bound _) = false; |
77863
760515c45864
revert b43ee37926a9 due to problems with AFP/PAPP_Impossibility;
wenzelm
parents:
77827
diff
changeset
|
1792 |
val _ = exists bad_term hyps andalso |
74200
17090e27aae9
more scalable data structure (but: rarely used with > 5 arguments);
wenzelm
parents:
74112
diff
changeset
|
1793 |
raise THM ("generalize: variable free in assumptions", 0, [th]); |
19910 | 1794 |
|
74200
17090e27aae9
more scalable data structure (but: rarely used with > 5 arguments);
wenzelm
parents:
74112
diff
changeset
|
1795 |
val generalize = Term_Subst.generalize (tfrees, frees) idx; |
17090e27aae9
more scalable data structure (but: rarely used with > 5 arguments);
wenzelm
parents:
74112
diff
changeset
|
1796 |
val prop' = generalize prop; |
17090e27aae9
more scalable data structure (but: rarely used with > 5 arguments);
wenzelm
parents:
74112
diff
changeset
|
1797 |
val tpairs' = map (apply2 generalize) tpairs; |
17090e27aae9
more scalable data structure (but: rarely used with > 5 arguments);
wenzelm
parents:
74112
diff
changeset
|
1798 |
val maxidx' = maxidx_tpairs tpairs' (maxidx_of_term prop'); |
79133 | 1799 |
|
79221 | 1800 |
val zproof = ZTerm.generalize_proof (tfrees, frees) idx; |
1801 |
val proof = Proofterm.generalize_proof (tfrees, frees) idx prop; |
|
74200
17090e27aae9
more scalable data structure (but: rarely used with > 5 arguments);
wenzelm
parents:
74112
diff
changeset
|
1802 |
in |
79221 | 1803 |
Thm (deriv_rule1 zproof proof der, |
74200
17090e27aae9
more scalable data structure (but: rarely used with > 5 arguments);
wenzelm
parents:
74112
diff
changeset
|
1804 |
{cert = cert, |
17090e27aae9
more scalable data structure (but: rarely used with > 5 arguments);
wenzelm
parents:
74112
diff
changeset
|
1805 |
tags = [], |
17090e27aae9
more scalable data structure (but: rarely used with > 5 arguments);
wenzelm
parents:
74112
diff
changeset
|
1806 |
maxidx = maxidx', |
17090e27aae9
more scalable data structure (but: rarely used with > 5 arguments);
wenzelm
parents:
74112
diff
changeset
|
1807 |
constraints = constraints, |
17090e27aae9
more scalable data structure (but: rarely used with > 5 arguments);
wenzelm
parents:
74112
diff
changeset
|
1808 |
shyps = shyps, |
17090e27aae9
more scalable data structure (but: rarely used with > 5 arguments);
wenzelm
parents:
74112
diff
changeset
|
1809 |
hyps = hyps, |
17090e27aae9
more scalable data structure (but: rarely used with > 5 arguments);
wenzelm
parents:
74112
diff
changeset
|
1810 |
tpairs = tpairs', |
17090e27aae9
more scalable data structure (but: rarely used with > 5 arguments);
wenzelm
parents:
74112
diff
changeset
|
1811 |
prop = prop'}) |
17090e27aae9
more scalable data structure (but: rarely used with > 5 arguments);
wenzelm
parents:
74112
diff
changeset
|
1812 |
end; |
19910 | 1813 |
|
74200
17090e27aae9
more scalable data structure (but: rarely used with > 5 arguments);
wenzelm
parents:
74112
diff
changeset
|
1814 |
fun generalize_cterm (tfrees, frees) idx (ct as Cterm {cert, t, T, maxidx, sorts}) = |
74266 | 1815 |
if Names.is_empty tfrees andalso Names.is_empty frees then ct |
74200
17090e27aae9
more scalable data structure (but: rarely used with > 5 arguments);
wenzelm
parents:
74112
diff
changeset
|
1816 |
else if idx <= maxidx then raise CTERM ("generalize_cterm: bad index", [ct]) |
17090e27aae9
more scalable data structure (but: rarely used with > 5 arguments);
wenzelm
parents:
74112
diff
changeset
|
1817 |
else |
17090e27aae9
more scalable data structure (but: rarely used with > 5 arguments);
wenzelm
parents:
74112
diff
changeset
|
1818 |
Cterm {cert = cert, sorts = sorts, |
17090e27aae9
more scalable data structure (but: rarely used with > 5 arguments);
wenzelm
parents:
74112
diff
changeset
|
1819 |
T = Term_Subst.generalizeT tfrees idx T, |
17090e27aae9
more scalable data structure (but: rarely used with > 5 arguments);
wenzelm
parents:
74112
diff
changeset
|
1820 |
t = Term_Subst.generalize (tfrees, frees) idx t, |
17090e27aae9
more scalable data structure (but: rarely used with > 5 arguments);
wenzelm
parents:
74112
diff
changeset
|
1821 |
maxidx = Int.max (maxidx, idx)}; |
67697 | 1822 |
|
74200
17090e27aae9
more scalable data structure (but: rarely used with > 5 arguments);
wenzelm
parents:
74112
diff
changeset
|
1823 |
fun generalize_ctyp tfrees idx (cT as Ctyp {cert, T, maxidx, sorts}) = |
74266 | 1824 |
if Names.is_empty tfrees then cT |
74200
17090e27aae9
more scalable data structure (but: rarely used with > 5 arguments);
wenzelm
parents:
74112
diff
changeset
|
1825 |
else if idx <= maxidx then raise CTERM ("generalize_ctyp: bad index", []) |
17090e27aae9
more scalable data structure (but: rarely used with > 5 arguments);
wenzelm
parents:
74112
diff
changeset
|
1826 |
else |
17090e27aae9
more scalable data structure (but: rarely used with > 5 arguments);
wenzelm
parents:
74112
diff
changeset
|
1827 |
Ctyp {cert = cert, sorts = sorts, |
17090e27aae9
more scalable data structure (but: rarely used with > 5 arguments);
wenzelm
parents:
74112
diff
changeset
|
1828 |
T = Term_Subst.generalizeT tfrees idx T, |
17090e27aae9
more scalable data structure (but: rarely used with > 5 arguments);
wenzelm
parents:
74112
diff
changeset
|
1829 |
maxidx = Int.max (maxidx, idx)}; |
67697 | 1830 |
|
19910 | 1831 |
|
22584 | 1832 |
(*Instantiation of schematic variables |
16656 | 1833 |
A |
1834 |
-------------------- |
|
1835 |
A[t1/v1, ..., tn/vn] |
|
1220 | 1836 |
*) |
0 | 1837 |
|
6928 | 1838 |
local |
1839 |
||
74219 | 1840 |
fun add_cert cert_of (_, c) cert = Context.join_certificate (cert, cert_of c); |
1841 |
val add_instT_cert = add_cert (fn Ctyp {cert, ...} => cert); |
|
1842 |
val add_inst_cert = add_cert (fn Cterm {cert, ...} => cert); |
|
1843 |
||
77869 | 1844 |
fun add_sorts sorts_of (_, c) sorts = Sorts.union (sorts_of c) sorts; |
74219 | 1845 |
val add_instT_sorts = add_sorts (fn Ctyp {sorts, ...} => sorts); |
1846 |
val add_inst_sorts = add_sorts (fn Cterm {sorts, ...} => sorts); |
|
1847 |
||
77804 | 1848 |
fun make_instT thy (_: indexname, S) (Ctyp {T = U, maxidx, ...}) = |
74282 | 1849 |
if Sign.of_sort thy (U, S) then (U, maxidx) |
74219 | 1850 |
else raise TYPE ("Type not of sort " ^ Syntax.string_of_sort_global thy S, [U], []); |
15797 | 1851 |
|
74282 | 1852 |
fun make_inst thy (v as (_, T)) (Cterm {t = u, T = U, maxidx, ...}) = |
1853 |
if T = U then (u, maxidx) |
|
74219 | 1854 |
else |
1855 |
let |
|
1856 |
fun pretty_typing t ty = |
|
1857 |
Pretty.block [Syntax.pretty_term_global thy t, Pretty.str " ::", |
|
1858 |
Pretty.brk 1, Syntax.pretty_typ_global thy ty]; |
|
1859 |
val msg = |
|
1860 |
Pretty.string_of (Pretty.block |
|
1861 |
[Pretty.str "instantiate: type conflict", |
|
1862 |
Pretty.fbrk, pretty_typing (Var v) T, |
|
1863 |
Pretty.fbrk, pretty_typing u U]) |
|
1864 |
in raise TYPE (msg, [T, U], [Var v, u]) end; |
|
1865 |
||
1866 |
fun prep_insts (instT, inst) (cert, sorts) = |
|
6928 | 1867 |
let |
74219 | 1868 |
val cert' = cert |
74282 | 1869 |
|> TVars.fold add_instT_cert instT |
1870 |
|> Vars.fold add_inst_cert inst; |
|
1871 |
val thy' = |
|
1872 |
Context.certificate_theory cert' handle ERROR msg => |
|
1873 |
raise CONTEXT (msg, TVars.dest instT |> map #2, Vars.dest inst |> map #2, [], NONE); |
|
0 | 1874 |
|
74219 | 1875 |
val sorts' = sorts |
74282 | 1876 |
|> TVars.fold add_instT_sorts instT |
1877 |
|> Vars.fold add_inst_sorts inst; |
|
74219 | 1878 |
|
74282 | 1879 |
val instT' = TVars.map (make_instT thy') instT; |
1880 |
val inst' = Vars.map (make_inst thy') inst; |
|
74219 | 1881 |
in ((instT', inst'), (cert', sorts')) end; |
0 | 1882 |
|
6928 | 1883 |
in |
1884 |
||
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1885 |
(*Left-to-right replacements: ctpairs = [..., (vi, ti), ...]. |
0 | 1886 |
Instantiates distinct Vars by terms of same type. |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1887 |
Does NOT normalize the resulting theorem!*) |
74577
d4829a7333e2
clarified instantiation: local beta reduction after substitution, as for Envir.expand_term_defs;
wenzelm
parents:
74561
diff
changeset
|
1888 |
fun gen_instantiate inst_fn (instT, inst) th = |
74282 | 1889 |
if TVars.is_empty instT andalso Vars.is_empty inst then th |
1890 |
else |
|
1891 |
let |
|
1892 |
val Thm (der, {cert, hyps, constraints, shyps, tpairs, prop, ...}) = th; |
|
1893 |
val ((instT', inst'), (cert', shyps')) = prep_insts (instT, inst) (cert, shyps) |
|
1894 |
handle CONTEXT (msg, cTs, cts, ths, context) => |
|
1895 |
raise CONTEXT (msg, cTs, cts, th :: ths, context); |
|
74219 | 1896 |
|
74577
d4829a7333e2
clarified instantiation: local beta reduction after substitution, as for Envir.expand_term_defs;
wenzelm
parents:
74561
diff
changeset
|
1897 |
val subst = inst_fn (instT', inst'); |
74282 | 1898 |
val (prop', maxidx1) = subst prop ~1; |
1899 |
val (tpairs', maxidx') = |
|
1900 |
fold_map (fn (t, u) => fn i => subst t i ||>> subst u) tpairs maxidx1; |
|
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
1901 |
|
78033
9c18535a9fcd
proper exception CONTEXT for Context.certificate_theory;
wenzelm
parents:
77966
diff
changeset
|
1902 |
val thy' = Context.certificate_theory cert' |
9c18535a9fcd
proper exception CONTEXT for Context.certificate_theory;
wenzelm
parents:
77966
diff
changeset
|
1903 |
handle ERROR msg => raise CONTEXT (msg, [], [], [th], NONE); |
74282 | 1904 |
val constraints' = |
1905 |
TVars.fold (fn ((_, S), (T, _)) => insert_constraints thy' (T, S)) |
|
1906 |
instT' constraints; |
|
79149 | 1907 |
|
79221 | 1908 |
fun zproof p = |
79149 | 1909 |
ZTerm.instantiate_proof thy' |
1910 |
(TVars.fold (fn (v, (T, _)) => cons (v, T)) instT' [], |
|
1911 |
Vars.fold (fn (v, (t, _)) => cons (v, t)) inst' []) p; |
|
79221 | 1912 |
fun proof p = |
1913 |
Proofterm.instantiate (TVars.map (K #1) instT', Vars.map (K #1) inst') p; |
|
74282 | 1914 |
in |
79221 | 1915 |
Thm (deriv_rule1 zproof proof der, |
74282 | 1916 |
{cert = cert', |
1917 |
tags = [], |
|
1918 |
maxidx = maxidx', |
|
1919 |
constraints = constraints', |
|
1920 |
shyps = shyps', |
|
1921 |
hyps = hyps, |
|
1922 |
tpairs = tpairs', |
|
1923 |
prop = prop'}) |
|
1924 |
|> solve_constraints |
|
1925 |
end |
|
1926 |
handle TYPE (msg, _, _) => raise THM (msg, 0, [th]); |
|
6928 | 1927 |
|
74577
d4829a7333e2
clarified instantiation: local beta reduction after substitution, as for Envir.expand_term_defs;
wenzelm
parents:
74561
diff
changeset
|
1928 |
val instantiate = gen_instantiate Term_Subst.instantiate_maxidx; |
d4829a7333e2
clarified instantiation: local beta reduction after substitution, as for Envir.expand_term_defs;
wenzelm
parents:
74561
diff
changeset
|
1929 |
val instantiate_beta = gen_instantiate Term_Subst.instantiate_beta_maxidx; |
d4829a7333e2
clarified instantiation: local beta reduction after substitution, as for Envir.expand_term_defs;
wenzelm
parents:
74561
diff
changeset
|
1930 |
|
d4829a7333e2
clarified instantiation: local beta reduction after substitution, as for Envir.expand_term_defs;
wenzelm
parents:
74561
diff
changeset
|
1931 |
fun gen_instantiate_cterm inst_fn (instT, inst) ct = |
74282 | 1932 |
if TVars.is_empty instT andalso Vars.is_empty inst then ct |
1933 |
else |
|
1934 |
let |
|
1935 |
val Cterm {cert, t, T, sorts, ...} = ct; |
|
1936 |
val ((instT', inst'), (cert', sorts')) = prep_insts (instT, inst) (cert, sorts); |
|
74577
d4829a7333e2
clarified instantiation: local beta reduction after substitution, as for Envir.expand_term_defs;
wenzelm
parents:
74561
diff
changeset
|
1937 |
val subst = inst_fn (instT', inst'); |
74282 | 1938 |
val substT = Term_Subst.instantiateT_maxidx instT'; |
1939 |
val (t', maxidx1) = subst t ~1; |
|
1940 |
val (T', maxidx') = substT T maxidx1; |
|
1941 |
in Cterm {cert = cert', t = t', T = T', sorts = sorts', maxidx = maxidx'} end |
|
1942 |
handle TYPE (msg, _, _) => raise CTERM (msg, [ct]); |
|
22584 | 1943 |
|
74577
d4829a7333e2
clarified instantiation: local beta reduction after substitution, as for Envir.expand_term_defs;
wenzelm
parents:
74561
diff
changeset
|
1944 |
val instantiate_cterm = gen_instantiate_cterm Term_Subst.instantiate_maxidx; |
d4829a7333e2
clarified instantiation: local beta reduction after substitution, as for Envir.expand_term_defs;
wenzelm
parents:
74561
diff
changeset
|
1945 |
val instantiate_beta_cterm = gen_instantiate_cterm Term_Subst.instantiate_beta_maxidx; |
d4829a7333e2
clarified instantiation: local beta reduction after substitution, as for Envir.expand_term_defs;
wenzelm
parents:
74561
diff
changeset
|
1946 |
|
6928 | 1947 |
end; |
1948 |
||
0 | 1949 |
|
67721 | 1950 |
(*The trivial implication A \<Longrightarrow> A, justified by assume and forall rules. |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1951 |
A can contain Vars, not so for assume!*) |
79321 | 1952 |
fun trivial (ct as Cterm {cert, t = A, T, maxidx, sorts}) = |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1953 |
if T <> propT then |
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1954 |
raise THM ("trivial: the term must have type prop", 0, []) |
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
1955 |
else |
79221 | 1956 |
let |
79321 | 1957 |
fun zproof () = |
1958 |
let |
|
1959 |
val thy = Context.certificate_theory cert handle ERROR msg => |
|
1960 |
raise CONTEXT (msg, [], [ct], [], NONE); |
|
1961 |
in ZTerm.trivial_proof thy A end; |
|
79221 | 1962 |
fun proof () = Proofterm.trivial_proof; |
1963 |
in |
|
1964 |
Thm (deriv_rule0 zproof proof, |
|
79119 | 1965 |
{cert = cert, |
1966 |
tags = [], |
|
1967 |
maxidx = maxidx, |
|
1968 |
constraints = [], |
|
1969 |
shyps = sorts, |
|
1970 |
hyps = [], |
|
1971 |
tpairs = [], |
|
1972 |
prop = Logic.mk_implies (A, A)}) |
|
1973 |
end; |
|
0 | 1974 |
|
31944 | 1975 |
(*Axiom-scheme reflecting signature contents |
1976 |
T :: c |
|
1977 |
------------------- |
|
1978 |
OFCLASS(T, c_class) |
|
1979 |
*) |
|
1980 |
fun of_class (cT, raw_c) = |
|
24143
90a9a6fe0d01
replaced Theory.self_ref by Theory.check_thy, which now produces a checked ref;
wenzelm
parents:
23781
diff
changeset
|
1981 |
let |
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
1982 |
val Ctyp {cert, T, ...} = cT; |
61051 | 1983 |
val thy = Context.certificate_theory cert |
1984 |
handle ERROR msg => raise CONTEXT (msg, [cT], [], [], NONE); |
|
31903 | 1985 |
val c = Sign.certify_class thy raw_c; |
59621
291934bac95e
Thm.cterm_of and Thm.ctyp_of operate on local context;
wenzelm
parents:
59591
diff
changeset
|
1986 |
val Cterm {t = prop, maxidx, sorts, ...} = global_cterm_of thy (Logic.mk_of_class (T, c)); |
79221 | 1987 |
|
1988 |
fun zproof () = ZTerm.of_class_proof (T, c); |
|
1989 |
fun proof () = Proofterm.PClass (T, c); |
|
399
86cc2b98f9e0
added class_triv: theory -> class -> thm (for axclasses);
wenzelm
parents:
387
diff
changeset
|
1990 |
in |
31944 | 1991 |
if Sign.of_sort thy (T, [c]) then |
79221 | 1992 |
Thm (deriv_rule0 zproof proof, |
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
1993 |
{cert = cert, |
31944 | 1994 |
tags = [], |
1995 |
maxidx = maxidx, |
|
77868 | 1996 |
constraints = insert_constraints thy (T, [c]) [], |
31944 | 1997 |
shyps = sorts, |
77863
760515c45864
revert b43ee37926a9 due to problems with AFP/PAPP_Impossibility;
wenzelm
parents:
77827
diff
changeset
|
1998 |
hyps = [], |
31944 | 1999 |
tpairs = [], |
2000 |
prop = prop}) |
|
2001 |
else raise THM ("of_class: type not of class " ^ Syntax.string_of_sort_global thy [c], 0, []) |
|
70482
d4b5139eea34
more robust and convenient treatment of implicit context;
wenzelm
parents:
70480
diff
changeset
|
2002 |
end |> solve_constraints; |
399
86cc2b98f9e0
added class_triv: theory -> class -> thm (for axclasses);
wenzelm
parents:
387
diff
changeset
|
2003 |
|
36769
b6b88bf695b3
Thm.unconstrainT based on Logic.unconstrainT -- no proofterm yet;
wenzelm
parents:
36768
diff
changeset
|
2004 |
(*Internalize sort constraints of type variables*) |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
2005 |
val unconstrainT = |
71530
046cf49162a3
more thorough strip_shyps for proof boxes (but types are usually stripped and reconstructed later);
wenzelm
parents:
71527
diff
changeset
|
2006 |
strip_shyps #> (fn thm as Thm (der, args) => |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
2007 |
let |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
2008 |
val Deriv {promises, body} = der; |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
2009 |
val {cert, shyps, hyps, tpairs, prop, ...} = args; |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
2010 |
val thy = theory_of_thm thm; |
36883
4ed0d72def50
added Proofterm.unconstrain_thm_proof for Thm.unconstrainT -- loosely based on the version by krauss/schropp;
wenzelm
parents:
36882
diff
changeset
|
2011 |
|
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
2012 |
fun err msg = raise THM ("unconstrainT: " ^ msg, 0, [thm]); |
77863
760515c45864
revert b43ee37926a9 due to problems with AFP/PAPP_Impossibility;
wenzelm
parents:
77827
diff
changeset
|
2013 |
val _ = null hyps orelse err "bad hyps"; |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
2014 |
val _ = null tpairs orelse err "bad flex-flex constraints"; |
74235 | 2015 |
val tfrees = build_rev (Term.add_tfree_names prop); |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
2016 |
val _ = null tfrees orelse err ("illegal free type variables " ^ commas_quote tfrees); |
36769
b6b88bf695b3
Thm.unconstrainT based on Logic.unconstrainT -- no proofterm yet;
wenzelm
parents:
36768
diff
changeset
|
2017 |
|
77873 | 2018 |
val ps = map (apsnd (Future.map fulfill_body)) promises; |
79332 | 2019 |
val (prop', body') = |
70494 | 2020 |
Proofterm.unconstrain_thm_proof thy (classrel_proof thy) (arity_proof thy) |
2021 |
shyps prop ps body; |
|
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
2022 |
in |
79262 | 2023 |
Thm (make_deriv0 [] body', |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
2024 |
{cert = cert, |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
2025 |
tags = [], |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
2026 |
maxidx = maxidx_of_term prop', |
77868 | 2027 |
constraints = [], |
77869 | 2028 |
shyps = [[]], (*potentially redundant*) |
77863
760515c45864
revert b43ee37926a9 due to problems with AFP/PAPP_Impossibility;
wenzelm
parents:
77827
diff
changeset
|
2029 |
hyps = [], |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
2030 |
tpairs = [], |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
2031 |
prop = prop'}) |
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
2032 |
end); |
399
86cc2b98f9e0
added class_triv: theory -> class -> thm (for axclasses);
wenzelm
parents:
387
diff
changeset
|
2033 |
|
63611 | 2034 |
(*Replace all TFrees not fixed or in the hyps by new TVars*) |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
2035 |
fun varifyT_global' fixed (Thm (der, {cert, maxidx, constraints, shyps, hyps, tpairs, prop, ...})) = |
12500 | 2036 |
let |
77863
760515c45864
revert b43ee37926a9 due to problems with AFP/PAPP_Impossibility;
wenzelm
parents:
77827
diff
changeset
|
2037 |
val tfrees = fold TFrees.add_tfrees hyps fixed; |
13658
c9ad3e64ddcf
Changed handling of flex-flex constraints: now stored in separate
berghofe
parents:
13642
diff
changeset
|
2038 |
val prop1 = attach_tpairs tpairs prop; |
35845
e5980f0ad025
renamed varify/unvarify operations to varify_global/unvarify_global to emphasize that these only work in a global situation;
wenzelm
parents:
35408
diff
changeset
|
2039 |
val (al, prop2) = Type.varify_global tfrees prop1; |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2040 |
val (ts, prop3) = Logic.strip_prems (length tpairs, [], prop2); |
79221 | 2041 |
fun zproof p = ZTerm.varifyT_proof al p; |
2042 |
fun proof p = Proofterm.varifyT_proof al p; |
|
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2043 |
in |
79221 | 2044 |
(al, Thm (deriv_rule1 zproof proof der, |
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
2045 |
{cert = cert, |
21646
c07b5b0e8492
thm/prf: separate official name vs. additional tags;
wenzelm
parents:
21576
diff
changeset
|
2046 |
tags = [], |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2047 |
maxidx = Int.max (0, maxidx), |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
2048 |
constraints = constraints, |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2049 |
shyps = shyps, |
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2050 |
hyps = hyps, |
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2051 |
tpairs = rev (map Logic.dest_equals ts), |
28321
9f4499bf9384
type thm: fully internal derivation, no longer exported;
wenzelm
parents:
28290
diff
changeset
|
2052 |
prop = prop3})) |
9f4499bf9384
type thm: fully internal derivation, no longer exported;
wenzelm
parents:
28290
diff
changeset
|
2053 |
end; |
9f4499bf9384
type thm: fully internal derivation, no longer exported;
wenzelm
parents:
28290
diff
changeset
|
2054 |
|
74266 | 2055 |
val varifyT_global = #2 o varifyT_global' TFrees.empty; |
28321
9f4499bf9384
type thm: fully internal derivation, no longer exported;
wenzelm
parents:
28290
diff
changeset
|
2056 |
|
63611 | 2057 |
(*Replace all TVars by TFrees that are often new*) |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
2058 |
fun legacy_freezeT (Thm (der, {cert, constraints, shyps, hyps, tpairs, prop, ...})) = |
28321
9f4499bf9384
type thm: fully internal derivation, no longer exported;
wenzelm
parents:
28290
diff
changeset
|
2059 |
let |
9f4499bf9384
type thm: fully internal derivation, no longer exported;
wenzelm
parents:
28290
diff
changeset
|
2060 |
val prop1 = attach_tpairs tpairs prop; |
33832 | 2061 |
val prop2 = Type.legacy_freeze prop1; |
28321
9f4499bf9384
type thm: fully internal derivation, no longer exported;
wenzelm
parents:
28290
diff
changeset
|
2062 |
val (ts, prop3) = Logic.strip_prems (length tpairs, [], prop2); |
79221 | 2063 |
fun zproof p = ZTerm.legacy_freezeT_proof prop1 p; |
2064 |
fun proof p = Proofterm.legacy_freezeT prop1 p; |
|
28321
9f4499bf9384
type thm: fully internal derivation, no longer exported;
wenzelm
parents:
28290
diff
changeset
|
2065 |
in |
79221 | 2066 |
Thm (deriv_rule1 zproof proof der, |
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
2067 |
{cert = cert, |
28321
9f4499bf9384
type thm: fully internal derivation, no longer exported;
wenzelm
parents:
28290
diff
changeset
|
2068 |
tags = [], |
9f4499bf9384
type thm: fully internal derivation, no longer exported;
wenzelm
parents:
28290
diff
changeset
|
2069 |
maxidx = maxidx_of_term prop2, |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
2070 |
constraints = constraints, |
28321
9f4499bf9384
type thm: fully internal derivation, no longer exported;
wenzelm
parents:
28290
diff
changeset
|
2071 |
shyps = shyps, |
9f4499bf9384
type thm: fully internal derivation, no longer exported;
wenzelm
parents:
28290
diff
changeset
|
2072 |
hyps = hyps, |
9f4499bf9384
type thm: fully internal derivation, no longer exported;
wenzelm
parents:
28290
diff
changeset
|
2073 |
tpairs = rev (map Logic.dest_equals ts), |
18127 | 2074 |
prop = prop3}) |
0 | 2075 |
end; |
2076 |
||
70456
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2077 |
fun plain_prop_of raw_thm = |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2078 |
let |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2079 |
val thm = strip_shyps raw_thm; |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2080 |
fun err msg = raise THM ("plain_prop_of: " ^ msg, 0, [thm]); |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2081 |
in |
77863
760515c45864
revert b43ee37926a9 due to problems with AFP/PAPP_Impossibility;
wenzelm
parents:
77827
diff
changeset
|
2082 |
if not (null (hyps_of thm)) then |
70456
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2083 |
err "theorem may not contain hypotheses" |
77869 | 2084 |
else if not (null (extra_shyps thm)) then |
70456
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2085 |
err "theorem may not contain sort hypotheses" |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2086 |
else if not (null (tpairs_of thm)) then |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2087 |
err "theorem may not contain flex-flex pairs" |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2088 |
else prop_of thm |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2089 |
end; |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2090 |
|
0 | 2091 |
|
79313
3b03af5125de
use strict Global_Theory.register_proofs as checkpoint for stored zproof, and thus reduce current zboxes;
wenzelm
parents:
79310
diff
changeset
|
2092 |
(* stored thms: zproof *) |
3b03af5125de
use strict Global_Theory.register_proofs as checkpoint for stored zproof, and thus reduce current zboxes;
wenzelm
parents:
79310
diff
changeset
|
2093 |
|
79365 | 2094 |
val get_zproof_serials = Inttab.keys o get_zproofs; |
2095 |
||
79364 | 2096 |
fun get_zproof thy = |
2097 |
Inttab.lookup (get_zproofs thy) |
|
2098 |
#> Option.map (fn {name, thm} => {name = name, thm = transfer thy thm}); |
|
79313
3b03af5125de
use strict Global_Theory.register_proofs as checkpoint for stored zproof, and thus reduce current zboxes;
wenzelm
parents:
79310
diff
changeset
|
2099 |
|
79335 | 2100 |
fun store_zproof name thm thy = |
79313
3b03af5125de
use strict Global_Theory.register_proofs as checkpoint for stored zproof, and thus reduce current zboxes;
wenzelm
parents:
79310
diff
changeset
|
2101 |
let |
3b03af5125de
use strict Global_Theory.register_proofs as checkpoint for stored zproof, and thus reduce current zboxes;
wenzelm
parents:
79310
diff
changeset
|
2102 |
val Thm (Deriv {promises, body = PBody body}, args as {hyps, prop, ...}) = thm; |
3b03af5125de
use strict Global_Theory.register_proofs as checkpoint for stored zproof, and thus reduce current zboxes;
wenzelm
parents:
79310
diff
changeset
|
2103 |
val {oracles, thms, zboxes, zproof, proof} = body; |
79362
2187de552bd4
clarified stored data: actual thm allows to replay zproofs in a modular manner;
wenzelm
parents:
79335
diff
changeset
|
2104 |
fun deriv a b = make_deriv promises oracles thms a b proof; |
2187de552bd4
clarified stored data: actual thm allows to replay zproofs in a modular manner;
wenzelm
parents:
79335
diff
changeset
|
2105 |
|
79313
3b03af5125de
use strict Global_Theory.register_proofs as checkpoint for stored zproof, and thus reduce current zboxes;
wenzelm
parents:
79310
diff
changeset
|
2106 |
val _ = null promises orelse |
3b03af5125de
use strict Global_Theory.register_proofs as checkpoint for stored zproof, and thus reduce current zboxes;
wenzelm
parents:
79310
diff
changeset
|
2107 |
raise THM ("store_zproof: theorem may not use promises", 0, [thm]); |
3b03af5125de
use strict Global_Theory.register_proofs as checkpoint for stored zproof, and thus reduce current zboxes;
wenzelm
parents:
79310
diff
changeset
|
2108 |
|
79362
2187de552bd4
clarified stored data: actual thm allows to replay zproofs in a modular manner;
wenzelm
parents:
79335
diff
changeset
|
2109 |
val ((i, (_, zproof1)), zproof2) = ZTerm.thm_proof thy name hyps prop zproof; |
2187de552bd4
clarified stored data: actual thm allows to replay zproofs in a modular manner;
wenzelm
parents:
79335
diff
changeset
|
2110 |
val der1 = if Options.default_bool "prune_proofs" then deriv [] ZDummy else deriv zboxes zproof1; |
2187de552bd4
clarified stored data: actual thm allows to replay zproofs in a modular manner;
wenzelm
parents:
79335
diff
changeset
|
2111 |
val der2 = deriv [] zproof2; |
79363 | 2112 |
|
2113 |
val thm' = trim_context (Thm (der1, args)); |
|
2114 |
val thy' = thy |> (map_zproofs o Inttab.update) (i, {name = name, thm = thm'}); |
|
79362
2187de552bd4
clarified stored data: actual thm allows to replay zproofs in a modular manner;
wenzelm
parents:
79335
diff
changeset
|
2115 |
in (Thm (der2, args), thy') end; |
79313
3b03af5125de
use strict Global_Theory.register_proofs as checkpoint for stored zproof, and thus reduce current zboxes;
wenzelm
parents:
79310
diff
changeset
|
2116 |
|
3b03af5125de
use strict Global_Theory.register_proofs as checkpoint for stored zproof, and thus reduce current zboxes;
wenzelm
parents:
79310
diff
changeset
|
2117 |
|
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
2118 |
|
0 | 2119 |
(*** Inference rules for tactics ***) |
2120 |
||
2121 |
(*Destruct proof state into constraints, other goals, goal(i), rest *) |
|
28321
9f4499bf9384
type thm: fully internal derivation, no longer exported;
wenzelm
parents:
28290
diff
changeset
|
2122 |
fun dest_state (state as Thm (_, {prop,tpairs,...}), i) = |
13658
c9ad3e64ddcf
Changed handling of flex-flex constraints: now stored in separate
berghofe
parents:
13642
diff
changeset
|
2123 |
(case Logic.strip_prems(i, [], prop) of |
c9ad3e64ddcf
Changed handling of flex-flex constraints: now stored in separate
berghofe
parents:
13642
diff
changeset
|
2124 |
(B::rBs, C) => (tpairs, rev rBs, B, C) |
c9ad3e64ddcf
Changed handling of flex-flex constraints: now stored in separate
berghofe
parents:
13642
diff
changeset
|
2125 |
| _ => raise THM("dest_state", i, [state])) |
0 | 2126 |
handle TERM _ => raise THM("dest_state", i, [state]); |
2127 |
||
46255 | 2128 |
(*Prepare orule for resolution by lifting it over the parameters and |
52487
48bc24467008
backout dedd7952a62c: static "proofs" value within theory prevents later inferencing with different configuration;
wenzelm
parents:
52470
diff
changeset
|
2129 |
assumptions of goal.*) |
18035 | 2130 |
fun lift_rule goal orule = |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2131 |
let |
18035 | 2132 |
val Cterm {t = gprop, T, maxidx = gmax, sorts, ...} = goal; |
2133 |
val inc = gmax + 1; |
|
2134 |
val lift_abs = Logic.lift_abs inc gprop; |
|
2135 |
val lift_all = Logic.lift_all inc gprop; |
|
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
2136 |
val Thm (der, {maxidx, constraints, shyps, hyps, tpairs, prop, ...}) = orule; |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2137 |
val (As, B) = Logic.strip_horn prop; |
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2138 |
in |
18035 | 2139 |
if T <> propT then raise THM ("lift_rule: the term must have type prop", 0, []) |
2140 |
else |
|
79221 | 2141 |
let |
79237 | 2142 |
val cert = join_certificate1 (goal, orule); |
79227 | 2143 |
val prems = map lift_all As; |
79321 | 2144 |
fun zproof p = |
2145 |
let |
|
2146 |
val thy = Context.certificate_theory cert |
|
2147 |
handle ERROR msg => raise CONTEXT (msg, [], [goal], [orule], NONE); |
|
2148 |
in ZTerm.lift_proof thy gprop inc prems p end; |
|
79227 | 2149 |
fun proof p = Proofterm.lift_proof gprop inc prems p; |
79221 | 2150 |
in |
2151 |
Thm (deriv_rule1 zproof proof der, |
|
79237 | 2152 |
{cert = cert, |
79221 | 2153 |
tags = [], |
2154 |
maxidx = maxidx + inc, |
|
2155 |
constraints = constraints, |
|
2156 |
shyps = Sorts.union shyps sorts, (*sic!*) |
|
2157 |
hyps = hyps, |
|
2158 |
tpairs = map (apply2 lift_abs) tpairs, |
|
79227 | 2159 |
prop = Logic.list_implies (prems, lift_all B)}) |
79221 | 2160 |
end |
0 | 2161 |
end; |
2162 |
||
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
2163 |
fun incr_indexes i (thm as Thm (der, {cert, maxidx, constraints, shyps, hyps, tpairs, prop, ...})) = |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2164 |
if i < 0 then raise THM ("negative increment", 0, [thm]) |
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2165 |
else if i = 0 then thm |
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2166 |
else |
79221 | 2167 |
let |
2168 |
fun zproof p = ZTerm.incr_indexes_proof i p; |
|
2169 |
fun proof p = Proofterm.incr_indexes i p; |
|
2170 |
in |
|
2171 |
Thm (deriv_rule1 zproof proof der, |
|
2172 |
{cert = cert, |
|
2173 |
tags = [], |
|
2174 |
maxidx = maxidx + i, |
|
2175 |
constraints = constraints, |
|
2176 |
shyps = shyps, |
|
2177 |
hyps = hyps, |
|
79232 | 2178 |
tpairs = map (apply2 (Logic.incr_indexes ([], i))) tpairs, |
2179 |
prop = Logic.incr_indexes ([], i) prop}) |
|
79221 | 2180 |
end; |
10416
5b33e732e459
- Moved rewriting functions to meta_simplifier.ML
berghofe
parents:
10348
diff
changeset
|
2181 |
|
0 | 2182 |
(*Solve subgoal Bi of proof state B1...Bn/C by assumption. *) |
58950
d07464875dd4
optional proof context for unify operations, for the sake of proper local options;
wenzelm
parents:
58946
diff
changeset
|
2183 |
fun assumption opt_ctxt i state = |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2184 |
let |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
2185 |
val Thm (der, {cert, maxidx, constraints, shyps, hyps, ...}) = state; |
64981
ea6199b23dfa
proper background certificate from make_context, which can be a super-theory of the direct join (amending d07464875dd4);
wenzelm
parents:
64574
diff
changeset
|
2186 |
val (context, cert') = make_context_certificate [state] opt_ctxt cert; |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2187 |
val (tpairs, Bs, Bi, C) = dest_state (state, i); |
32032 | 2188 |
fun newth n (env, tpairs) = |
70822
22e2f5acc0b4
more accurate treatment of propositions within proof terms, but these are ultimately ignored for performance reasons;
wenzelm
parents:
70814
diff
changeset
|
2189 |
let |
78033
9c18535a9fcd
proper exception CONTEXT for Context.certificate_theory;
wenzelm
parents:
77966
diff
changeset
|
2190 |
val thy' = Context.certificate_theory cert' handle ERROR msg => |
9c18535a9fcd
proper exception CONTEXT for Context.certificate_theory;
wenzelm
parents:
77966
diff
changeset
|
2191 |
raise CONTEXT (msg, [], [], [state], Option.map Context.Proof opt_ctxt); |
79209 | 2192 |
val normt = Envir.norm_term env; |
79270
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79263
diff
changeset
|
2193 |
fun zproof p = ZTerm.assumption_proof thy' env Bs Bi n [full_prop_of state] p; |
79221 | 2194 |
fun proof p = |
79209 | 2195 |
Proofterm.assumption_proof (map normt Bs) (normt Bi) n p |
2196 |
|> not (Envir.is_empty env) ? Proofterm.norm_proof_remove_types env; |
|
70822
22e2f5acc0b4
more accurate treatment of propositions within proof terms, but these are ultimately ignored for performance reasons;
wenzelm
parents:
70814
diff
changeset
|
2197 |
in |
79221 | 2198 |
Thm (deriv_rule1 zproof proof der, |
70822
22e2f5acc0b4
more accurate treatment of propositions within proof terms, but these are ultimately ignored for performance reasons;
wenzelm
parents:
70814
diff
changeset
|
2199 |
{tags = [], |
22e2f5acc0b4
more accurate treatment of propositions within proof terms, but these are ultimately ignored for performance reasons;
wenzelm
parents:
70814
diff
changeset
|
2200 |
maxidx = Envir.maxidx_of env, |
78033
9c18535a9fcd
proper exception CONTEXT for Context.certificate_theory;
wenzelm
parents:
77966
diff
changeset
|
2201 |
constraints = insert_constraints_env thy' env constraints, |
70822
22e2f5acc0b4
more accurate treatment of propositions within proof terms, but these are ultimately ignored for performance reasons;
wenzelm
parents:
70814
diff
changeset
|
2202 |
shyps = Envir.insert_sorts env shyps, |
22e2f5acc0b4
more accurate treatment of propositions within proof terms, but these are ultimately ignored for performance reasons;
wenzelm
parents:
70814
diff
changeset
|
2203 |
hyps = hyps, |
22e2f5acc0b4
more accurate treatment of propositions within proof terms, but these are ultimately ignored for performance reasons;
wenzelm
parents:
70814
diff
changeset
|
2204 |
tpairs = if Envir.is_empty env then tpairs else map (apply2 normt) tpairs, |
22e2f5acc0b4
more accurate treatment of propositions within proof terms, but these are ultimately ignored for performance reasons;
wenzelm
parents:
70814
diff
changeset
|
2205 |
prop = |
79209 | 2206 |
if Envir.is_empty env |
2207 |
then Logic.list_implies (Bs, C) (*avoid wasted normalizations*) |
|
70822
22e2f5acc0b4
more accurate treatment of propositions within proof terms, but these are ultimately ignored for performance reasons;
wenzelm
parents:
70814
diff
changeset
|
2208 |
else normt (Logic.list_implies (Bs, C)) (*normalize the new rule fully*), |
22e2f5acc0b4
more accurate treatment of propositions within proof terms, but these are ultimately ignored for performance reasons;
wenzelm
parents:
70814
diff
changeset
|
2209 |
cert = cert'}) |
22e2f5acc0b4
more accurate treatment of propositions within proof terms, but these are ultimately ignored for performance reasons;
wenzelm
parents:
70814
diff
changeset
|
2210 |
end; |
30554
73f8bd5f0af8
substantial speedup of assumption and elim-resolution: Logic.assum_problems refrains from eager application of parameters, discriminate via Term.could_unify before invoking full unification (assumes terms in beta-normal form, as do higher term net operations anyway);
wenzelm
parents:
30466
diff
changeset
|
2211 |
|
30556
7be15917f3fa
eq_assumption: slightly more efficient by checking (open) result of Logic.assum_problems directly;
wenzelm
parents:
30554
diff
changeset
|
2212 |
val (close, asms, concl) = Logic.assum_problems (~1, Bi); |
7be15917f3fa
eq_assumption: slightly more efficient by checking (open) result of Logic.assum_problems directly;
wenzelm
parents:
30554
diff
changeset
|
2213 |
val concl' = close concl; |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2214 |
fun addprfs [] _ = Seq.empty |
30556
7be15917f3fa
eq_assumption: slightly more efficient by checking (open) result of Logic.assum_problems directly;
wenzelm
parents:
30554
diff
changeset
|
2215 |
| addprfs (asm :: rest) n = Seq.make (fn () => Seq.pull |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2216 |
(Seq.mapp (newth n) |
30556
7be15917f3fa
eq_assumption: slightly more efficient by checking (open) result of Logic.assum_problems directly;
wenzelm
parents:
30554
diff
changeset
|
2217 |
(if Term.could_unify (asm, concl) then |
58950
d07464875dd4
optional proof context for unify operations, for the sake of proper local options;
wenzelm
parents:
58946
diff
changeset
|
2218 |
(Unify.unifiers (context, Envir.empty maxidx, (close asm, concl') :: tpairs)) |
30554
73f8bd5f0af8
substantial speedup of assumption and elim-resolution: Logic.assum_problems refrains from eager application of parameters, discriminate via Term.could_unify before invoking full unification (assumes terms in beta-normal form, as do higher term net operations anyway);
wenzelm
parents:
30466
diff
changeset
|
2219 |
else Seq.empty) |
73f8bd5f0af8
substantial speedup of assumption and elim-resolution: Logic.assum_problems refrains from eager application of parameters, discriminate via Term.could_unify before invoking full unification (assumes terms in beta-normal form, as do higher term net operations anyway);
wenzelm
parents:
30466
diff
changeset
|
2220 |
(addprfs rest (n + 1)))) |
30556
7be15917f3fa
eq_assumption: slightly more efficient by checking (open) result of Logic.assum_problems directly;
wenzelm
parents:
30554
diff
changeset
|
2221 |
in addprfs asms 1 end; |
0 | 2222 |
|
250 | 2223 |
(*Solve subgoal Bi of proof state B1...Bn/C by assumption. |
51604 | 2224 |
Checks if Bi's conclusion is alpha/eta-convertible to one of its assumptions*) |
0 | 2225 |
fun eq_assumption i state = |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2226 |
let |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
2227 |
val Thm (der, {cert, maxidx, constraints, shyps, hyps, ...}) = state; |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2228 |
val (tpairs, Bs, Bi, C) = dest_state (state, i); |
30556
7be15917f3fa
eq_assumption: slightly more efficient by checking (open) result of Logic.assum_problems directly;
wenzelm
parents:
30554
diff
changeset
|
2229 |
val (_, asms, concl) = Logic.assum_problems (~1, Bi); |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2230 |
in |
52131 | 2231 |
(case find_index (fn asm => Envir.aeconv (asm, concl)) asms of |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2232 |
~1 => raise THM ("eq_assumption", 0, [state]) |
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2233 |
| n => |
79211 | 2234 |
let |
79221 | 2235 |
fun zproof p = |
79321 | 2236 |
let |
2237 |
val thy = Context.certificate_theory cert |
|
2238 |
handle ERROR msg => raise CONTEXT (msg, [], [], [state], NONE); |
|
2239 |
in ZTerm.assumption_proof thy Envir.init Bs Bi (n + 1) [] p end; |
|
79221 | 2240 |
fun proof p = Proofterm.assumption_proof Bs Bi (n + 1) p; |
79211 | 2241 |
in |
79221 | 2242 |
Thm (deriv_rule1 zproof proof der, |
79211 | 2243 |
{cert = cert, |
2244 |
tags = [], |
|
2245 |
maxidx = maxidx, |
|
2246 |
constraints = constraints, |
|
2247 |
shyps = shyps, |
|
2248 |
hyps = hyps, |
|
2249 |
tpairs = tpairs, |
|
2250 |
prop = Logic.list_implies (Bs, C)}) |
|
2251 |
end) |
|
0 | 2252 |
end; |
2253 |
||
2254 |
||
2671 | 2255 |
(*For rotate_tac: fast rotation of assumptions of subgoal i*) |
2256 |
fun rotate_rule k i state = |
|
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2257 |
let |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
2258 |
val Thm (der, {cert, maxidx, constraints, shyps, hyps, ...}) = state; |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2259 |
val (tpairs, Bs, Bi, C) = dest_state (state, i); |
46218
ecf6375e2abb
renamed Term.list_all to Logic.list_all, in accordance to HOLogic.list_all;
wenzelm
parents:
46217
diff
changeset
|
2260 |
val params = Term.strip_all_vars Bi; |
ecf6375e2abb
renamed Term.list_all to Logic.list_all, in accordance to HOLogic.list_all;
wenzelm
parents:
46217
diff
changeset
|
2261 |
val rest = Term.strip_all_body Bi; |
ecf6375e2abb
renamed Term.list_all to Logic.list_all, in accordance to HOLogic.list_all;
wenzelm
parents:
46217
diff
changeset
|
2262 |
val asms = Logic.strip_imp_prems rest |
ecf6375e2abb
renamed Term.list_all to Logic.list_all, in accordance to HOLogic.list_all;
wenzelm
parents:
46217
diff
changeset
|
2263 |
val concl = Logic.strip_imp_concl rest; |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2264 |
val n = length asms; |
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2265 |
val m = if k < 0 then n + k else k; |
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2266 |
val Bi' = |
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2267 |
if 0 = m orelse m = n then Bi |
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2268 |
else if 0 < m andalso m < n then |
19012 | 2269 |
let val (ps, qs) = chop m asms |
46218
ecf6375e2abb
renamed Term.list_all to Logic.list_all, in accordance to HOLogic.list_all;
wenzelm
parents:
46217
diff
changeset
|
2270 |
in Logic.list_all (params, Logic.list_implies (qs @ ps, concl)) end |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2271 |
else raise THM ("rotate_rule", k, [state]); |
79155 | 2272 |
|
79321 | 2273 |
fun zproof p = |
2274 |
let |
|
2275 |
val thy = Context.certificate_theory cert |
|
2276 |
handle ERROR msg => raise CONTEXT (msg, [], [], [state], NONE); |
|
2277 |
in ZTerm.rotate_proof thy Bs Bi' params asms m p end; |
|
79221 | 2278 |
fun proof p = Proofterm.rotate_proof Bs Bi' params asms m p; |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2279 |
in |
79221 | 2280 |
Thm (deriv_rule1 zproof proof der, |
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
2281 |
{cert = cert, |
21646
c07b5b0e8492
thm/prf: separate official name vs. additional tags;
wenzelm
parents:
21576
diff
changeset
|
2282 |
tags = [], |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2283 |
maxidx = maxidx, |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
2284 |
constraints = constraints, |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2285 |
shyps = shyps, |
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2286 |
hyps = hyps, |
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2287 |
tpairs = tpairs, |
28321
9f4499bf9384
type thm: fully internal derivation, no longer exported;
wenzelm
parents:
28290
diff
changeset
|
2288 |
prop = Logic.list_implies (Bs @ [Bi'], C)}) |
2671 | 2289 |
end; |
2290 |
||
2291 |
||
7248
322151fe6f02
new primitive rule permute_prems to underlie defer_tac and rotate_prems
paulson
parents:
7070
diff
changeset
|
2292 |
(*Rotates a rule's premises to the left by k, leaving the first j premises |
322151fe6f02
new primitive rule permute_prems to underlie defer_tac and rotate_prems
paulson
parents:
7070
diff
changeset
|
2293 |
unchanged. Does nothing if k=0 or if k equals n-j, where n is the |
58837 | 2294 |
number of premises. Useful with eresolve_tac and underlies defer_tac*) |
7248
322151fe6f02
new primitive rule permute_prems to underlie defer_tac and rotate_prems
paulson
parents:
7070
diff
changeset
|
2295 |
fun permute_prems j k rl = |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2296 |
let |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
2297 |
val Thm (der, {cert, maxidx, constraints, shyps, hyps, tpairs, prop, ...}) = rl; |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2298 |
val prems = Logic.strip_imp_prems prop |
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2299 |
and concl = Logic.strip_imp_concl prop; |
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2300 |
val moved_prems = List.drop (prems, j) |
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2301 |
and fixed_prems = List.take (prems, j) |
43278 | 2302 |
handle General.Subscript => raise THM ("permute_prems: j", j, [rl]); |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2303 |
val n_j = length moved_prems; |
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2304 |
val m = if k < 0 then n_j + k else k; |
70822
22e2f5acc0b4
more accurate treatment of propositions within proof terms, but these are ultimately ignored for performance reasons;
wenzelm
parents:
70814
diff
changeset
|
2305 |
val (prems', prop') = |
22e2f5acc0b4
more accurate treatment of propositions within proof terms, but these are ultimately ignored for performance reasons;
wenzelm
parents:
70814
diff
changeset
|
2306 |
if 0 = m orelse m = n_j then (prems, prop) |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2307 |
else if 0 < m andalso m < n_j then |
70822
22e2f5acc0b4
more accurate treatment of propositions within proof terms, but these are ultimately ignored for performance reasons;
wenzelm
parents:
70814
diff
changeset
|
2308 |
let |
22e2f5acc0b4
more accurate treatment of propositions within proof terms, but these are ultimately ignored for performance reasons;
wenzelm
parents:
70814
diff
changeset
|
2309 |
val (ps, qs) = chop m moved_prems; |
22e2f5acc0b4
more accurate treatment of propositions within proof terms, but these are ultimately ignored for performance reasons;
wenzelm
parents:
70814
diff
changeset
|
2310 |
val prems' = fixed_prems @ qs @ ps; |
22e2f5acc0b4
more accurate treatment of propositions within proof terms, but these are ultimately ignored for performance reasons;
wenzelm
parents:
70814
diff
changeset
|
2311 |
in (prems', Logic.list_implies (prems', concl)) end |
16725 | 2312 |
else raise THM ("permute_prems: k", k, [rl]); |
79155 | 2313 |
|
79321 | 2314 |
fun zproof p = |
2315 |
let |
|
2316 |
val thy = Context.certificate_theory cert |
|
2317 |
handle ERROR msg => raise CONTEXT (msg, [], [], [rl], NONE); |
|
2318 |
in ZTerm.permute_prems_proof thy prems' j m p end; |
|
79221 | 2319 |
fun proof p = Proofterm.permute_prems_proof prems' j m p; |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2320 |
in |
79221 | 2321 |
Thm (deriv_rule1 zproof proof der, |
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
2322 |
{cert = cert, |
21646
c07b5b0e8492
thm/prf: separate official name vs. additional tags;
wenzelm
parents:
21576
diff
changeset
|
2323 |
tags = [], |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2324 |
maxidx = maxidx, |
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
2325 |
constraints = constraints, |
16601
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2326 |
shyps = shyps, |
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2327 |
hyps = hyps, |
ee8eefade568
more efficient treatment of shyps and hyps (use ordered lists);
wenzelm
parents:
16425
diff
changeset
|
2328 |
tpairs = tpairs, |
28321
9f4499bf9384
type thm: fully internal derivation, no longer exported;
wenzelm
parents:
28290
diff
changeset
|
2329 |
prop = prop'}) |
7248
322151fe6f02
new primitive rule permute_prems to underlie defer_tac and rotate_prems
paulson
parents:
7070
diff
changeset
|
2330 |
end; |
322151fe6f02
new primitive rule permute_prems to underlie defer_tac and rotate_prems
paulson
parents:
7070
diff
changeset
|
2331 |
|
322151fe6f02
new primitive rule permute_prems to underlie defer_tac and rotate_prems
paulson
parents:
7070
diff
changeset
|
2332 |
|
44108
476a239d3e0e
rename_bvs now avoids introducing name clashes between schematic variables
berghofe
parents:
43795
diff
changeset
|
2333 |
(* strip_apply f B A strips off all assumptions/parameters from A |
0 | 2334 |
introduced by lifting over B, and applies f to remaining part of A*) |
2335 |
fun strip_apply f = |
|
79258 | 2336 |
let |
2337 |
fun strip ((c as Const ("Pure.imp", _)) $ _ $ B1) |
|
2338 |
(Const ("Pure.imp", _) $ A2 $ B2) = c $ A2 $ strip B1 B2 |
|
2339 |
| strip ((c as Const ("Pure.all", _)) $ Abs (_, _, t1)) |
|
2340 |
(Const ("Pure.all", _) $ Abs (a, T, t2)) = c $ Abs (a, T, strip t1 t2) |
|
2341 |
| strip _ A = f A |
|
0 | 2342 |
in strip end; |
2343 |
||
56245 | 2344 |
fun strip_lifted (Const ("Pure.imp", _) $ _ $ B1) |
2345 |
(Const ("Pure.imp", _) $ _ $ B2) = strip_lifted B1 B2 |
|
2346 |
| strip_lifted (Const ("Pure.all", _) $ Abs (_, _, t1)) |
|
2347 |
(Const ("Pure.all", _) $ Abs (_, _, t2)) = strip_lifted t1 t2 |
|
44108
476a239d3e0e
rename_bvs now avoids introducing name clashes between schematic variables
berghofe
parents:
43795
diff
changeset
|
2348 |
| strip_lifted _ A = A; |
476a239d3e0e
rename_bvs now avoids introducing name clashes between schematic variables
berghofe
parents:
43795
diff
changeset
|
2349 |
|
0 | 2350 |
(*Use the alist to rename all bound variables and some unknowns in a term |
2351 |
dpairs = current disagreement pairs; tpairs = permanent ones (flexflex); |
|
2352 |
Preserves unknowns in tpairs and on lhs of dpairs. *) |
|
79247 | 2353 |
fun rename_bvs dpairs tpairs B As = |
2354 |
let val al = fold_rev Term.match_bvars dpairs [] in |
|
79254 | 2355 |
if null al then {vars = Symtab.empty, bounds = Symtab.empty} |
79247 | 2356 |
else |
20330 | 2357 |
let |
79246 | 2358 |
val add_var = fold_aterms (fn Var ((x, _), _) => Symset.insert x | _ => I); |
2359 |
val unknowns = |
|
2360 |
Symset.build |
|
2361 |
(fold (add_var o fst) dpairs #> |
|
2362 |
fold (fn (t, u) => add_var t #> add_var u) tpairs); |
|
2363 |
||
250 | 2364 |
(*unknowns appearing elsewhere be preserved!*) |
79246 | 2365 |
val unknowns' = Symset.build (fold (add_var o strip_lifted B) As); |
2366 |
val al' = al |
|
2367 |
|> filter_out (fn (x, y) => |
|
2368 |
not (Symset.member unknowns' x) orelse |
|
2369 |
Symset.member unknowns x orelse Symset.member unknowns y) |
|
2370 |
|> distinct (eq_fst (op =)); |
|
2371 |
val unchanged = Symset.restrict (not o AList.defined (op =) al') unknowns'; |
|
79247 | 2372 |
|
79256
4a97f2daf2c0
tuned comments (see also 476a239d3e0e and possibly 4b62e0cb3aa8);
wenzelm
parents:
79254
diff
changeset
|
2373 |
(*avoid introducing name clashes between schematic variables*) |
44108
476a239d3e0e
rename_bvs now avoids introducing name clashes between schematic variables
berghofe
parents:
43795
diff
changeset
|
2374 |
fun del_clashing clash xs _ [] qs = |
476a239d3e0e
rename_bvs now avoids introducing name clashes between schematic variables
berghofe
parents:
43795
diff
changeset
|
2375 |
if clash then del_clashing false xs xs qs [] else qs |
476a239d3e0e
rename_bvs now avoids introducing name clashes between schematic variables
berghofe
parents:
43795
diff
changeset
|
2376 |
| del_clashing clash xs ys ((p as (x, y)) :: ps) qs = |
79246 | 2377 |
if Symset.member ys y |
2378 |
then del_clashing true (Symset.insert x xs) (Symset.insert x ys) ps qs |
|
2379 |
else del_clashing clash xs (Symset.insert y ys) ps (p :: qs); |
|
46497
89ccf66aa73d
renamed Thm.capply to Thm.apply, and Thm.cabs to Thm.lambda in conformance with similar operations in structure Term and Logic;
wenzelm
parents:
46475
diff
changeset
|
2380 |
val al'' = del_clashing false unchanged unchanged al' []; |
79246 | 2381 |
|
79254 | 2382 |
in {vars = Symtab.make_distinct al'', bounds = Symtab.make_distinct al} end |
79247 | 2383 |
end; |
2384 |
||
2385 |
(*Function to rename bounds/unknowns in the argument, lifted over B*) |
|
2386 |
fun rename_bvars dpairs tpairs B As = |
|
2387 |
let val {vars, bounds} = rename_bvs dpairs tpairs B As in |
|
79254 | 2388 |
if Symtab.forall (op =) vars andalso Symtab.forall (op =) bounds then NONE |
79247 | 2389 |
else |
2390 |
let |
|
79252 | 2391 |
fun term (Var ((x, i), T)) = |
79254 | 2392 |
let val y = perhaps (Symtab.lookup vars) x |
79252 | 2393 |
in if x = y then raise Same.SAME else Var ((y, i), T) end |
2394 |
| term (Abs (x, T, t)) = |
|
79254 | 2395 |
let val y = perhaps (Symtab.lookup bounds) x |
79252 | 2396 |
in if x = y then Abs (x, T, term t) else Abs (y, T, Same.commit term t) end |
2397 |
| term (t $ u) = (term t $ Same.commit term u handle Same.SAME => t $ term u) |
|
2398 |
| term _ = raise Same.SAME; |
|
79310 | 2399 |
in SOME term end |
79247 | 2400 |
end; |
0 | 2401 |
|
70459
f0a445c5a82c
maintain sort constraints from type instantiations, with pro-forma derivation to collect oracles/thms;
wenzelm
parents:
70458
diff
changeset
|
2402 |
|
0 | 2403 |
(*** RESOLUTION ***) |
2404 |
||
721
479832ff2d29
Pure/thm/norm_term_skip: new, for skipping normalization of the context
lcp
parents:
678
diff
changeset
|
2405 |
(** Lifting optimizations **) |
479832ff2d29
Pure/thm/norm_term_skip: new, for skipping normalization of the context
lcp
parents:
678
diff
changeset
|
2406 |
|
0 | 2407 |
(*strip off pairs of assumptions/parameters in parallel -- they are |
2408 |
identical because of lifting*) |
|
56245 | 2409 |
fun strip_assums2 (Const("Pure.imp", _) $ _ $ B1, |
2410 |
Const("Pure.imp", _) $ _ $ B2) = strip_assums2 (B1,B2) |
|
2411 |
| strip_assums2 (Const("Pure.all",_)$Abs(a,T,t1), |
|
2412 |
Const("Pure.all",_)$Abs(_,_,t2)) = |
|
0 | 2413 |
let val (B1,B2) = strip_assums2 (t1,t2) |
2414 |
in (Abs(a,T,B1), Abs(a,T,B2)) end |
|
2415 |
| strip_assums2 BB = BB; |
|
2416 |
||
2417 |
||
721
479832ff2d29
Pure/thm/norm_term_skip: new, for skipping normalization of the context
lcp
parents:
678
diff
changeset
|
2418 |
(*Faster normalization: skip assumptions that were lifted over*) |
479832ff2d29
Pure/thm/norm_term_skip: new, for skipping normalization of the context
lcp
parents:
678
diff
changeset
|
2419 |
fun norm_term_skip env 0 t = Envir.norm_term env t |
56245 | 2420 |
| norm_term_skip env n (Const ("Pure.all", _) $ Abs (a, T, t)) = |
32032 | 2421 |
let |
58946
3bf80312508e
proper Envir.norm_type for result of Unify.unifiers (amending 479832ff2d29 from 20 years ago);
wenzelm
parents:
58837
diff
changeset
|
2422 |
val T' = Envir.norm_type (Envir.type_env env) T |
32032 | 2423 |
(*Must instantiate types of parameters because they are flattened; |
2424 |
this could be a NEW parameter*) |
|
46217
7b19666f0e3d
renamed Term.all to Logic.all_const, in accordance to HOLogic.all_const;
wenzelm
parents:
45443
diff
changeset
|
2425 |
in Logic.all_const T' $ Abs (a, T', norm_term_skip env n t) end |
56245 | 2426 |
| norm_term_skip env n (Const ("Pure.imp", _) $ A $ B) = |
32032 | 2427 |
Logic.mk_implies (A, norm_term_skip env (n - 1) B) |
32784 | 2428 |
| norm_term_skip _ _ _ = error "norm_term_skip: too few assumptions??"; |
721
479832ff2d29
Pure/thm/norm_term_skip: new, for skipping normalization of the context
lcp
parents:
678
diff
changeset
|
2429 |
|
479832ff2d29
Pure/thm/norm_term_skip: new, for skipping normalization of the context
lcp
parents:
678
diff
changeset
|
2430 |
|
52222
0fa3b456a267
unify types of schematic variables in non-lifted case (i.e. "compose variants") -- allow schematic polymorphism, without revisiting HO-unification;
wenzelm
parents:
52131
diff
changeset
|
2431 |
(*unify types of schematic variables (non-lifted case)*) |
58950
d07464875dd4
optional proof context for unify operations, for the sake of proper local options;
wenzelm
parents:
58946
diff
changeset
|
2432 |
fun unify_var_types context (th1, th2) env = |
52222
0fa3b456a267
unify types of schematic variables in non-lifted case (i.e. "compose variants") -- allow schematic polymorphism, without revisiting HO-unification;
wenzelm
parents:
52131
diff
changeset
|
2433 |
let |
58950
d07464875dd4
optional proof context for unify operations, for the sake of proper local options;
wenzelm
parents:
58946
diff
changeset
|
2434 |
fun unify_vars (T :: Us) = fold (fn U => Pattern.unify_types context (T, U)) Us |
52222
0fa3b456a267
unify types of schematic variables in non-lifted case (i.e. "compose variants") -- allow schematic polymorphism, without revisiting HO-unification;
wenzelm
parents:
52131
diff
changeset
|
2435 |
| unify_vars _ = I; |
0fa3b456a267
unify types of schematic variables in non-lifted case (i.e. "compose variants") -- allow schematic polymorphism, without revisiting HO-unification;
wenzelm
parents:
52131
diff
changeset
|
2436 |
val add_vars = |
0fa3b456a267
unify types of schematic variables in non-lifted case (i.e. "compose variants") -- allow schematic polymorphism, without revisiting HO-unification;
wenzelm
parents:
52131
diff
changeset
|
2437 |
full_prop_of #> |
0fa3b456a267
unify types of schematic variables in non-lifted case (i.e. "compose variants") -- allow schematic polymorphism, without revisiting HO-unification;
wenzelm
parents:
52131
diff
changeset
|
2438 |
fold_aterms (fn Var v => Vartab.insert_list (op =) v | _ => I); |
74232 | 2439 |
val vars = Vartab.build (add_vars th1 #> add_vars th2); |
52222
0fa3b456a267
unify types of schematic variables in non-lifted case (i.e. "compose variants") -- allow schematic polymorphism, without revisiting HO-unification;
wenzelm
parents:
52131
diff
changeset
|
2440 |
in SOME (Vartab.fold (unify_vars o #2) vars env) end |
0fa3b456a267
unify types of schematic variables in non-lifted case (i.e. "compose variants") -- allow schematic polymorphism, without revisiting HO-unification;
wenzelm
parents:
52131
diff
changeset
|
2441 |
handle Pattern.Unif => NONE; |
0fa3b456a267
unify types of schematic variables in non-lifted case (i.e. "compose variants") -- allow schematic polymorphism, without revisiting HO-unification;
wenzelm
parents:
52131
diff
changeset
|
2442 |
|
0 | 2443 |
(*Composition of object rule r=(A1...Am/B) with proof state s=(B1...Bn/C) |
250 | 2444 |
Unifies B with Bi, replacing subgoal i (1 <= i <= n) |
0 | 2445 |
If match then forbid instantiations in proof state |
2446 |
If lifted then shorten the dpair using strip_assums2. |
|
2447 |
If eres_flg then simultaneously proves A1 by assumption. |
|
250 | 2448 |
nsubgoal is the number of new subgoals (written m above). |
0 | 2449 |
Curried so that resolution calls dest_state only once. |
2450 |
*) |
|
79239 | 2451 |
local exception COMPOSE in |
2452 |
||
58950
d07464875dd4
optional proof context for unify operations, for the sake of proper local options;
wenzelm
parents:
58946
diff
changeset
|
2453 |
fun bicompose_aux opt_ctxt {flatten, match, incremented} (state, (stpairs, Bs, Bi, C), lifted) |
79239 | 2454 |
(eres_flg, orule, nsubgoal) = |
2455 |
let |
|
2456 |
val Thm (sder, {maxidx=smax, constraints = constraints2, shyps = shyps2, hyps = hyps2, ...}) = state |
|
2457 |
and Thm (rder, {maxidx=rmax, constraints = constraints1, shyps = shyps1, hyps = hyps1, |
|
2458 |
tpairs = rtpairs, prop = rprop, ...}) = orule |
|
2459 |
(*How many hyps to skip over during normalization*) |
|
2460 |
and nlift = Logic.count_prems (strip_all_body Bi) + (if eres_flg then ~1 else 0); |
|
2461 |
val (context, cert) = |
|
2462 |
make_context_certificate [state, orule] opt_ctxt (join_certificate2 (state, orule)); |
|
2463 |
(*Add new theorem with prop = "\<lbrakk>Bs; As\<rbrakk> \<Longrightarrow> C" to thq*) |
|
2464 |
fun addth A (As, oldAs, rder', n) ((env, tpairs), thq) = |
|
2465 |
let |
|
2466 |
val normt = Envir.norm_term env; |
|
2467 |
(*perform minimal copying here by examining env*) |
|
2468 |
val (ntpairs, normp) = |
|
2469 |
if Envir.is_empty env then (tpairs, (Bs @ As, C)) |
|
2470 |
else |
|
2471 |
let val ntps = map (apply2 normt) tpairs in |
|
2472 |
if Envir.above env smax then |
|
2473 |
(*no assignments in state; normalize the rule only*) |
|
2474 |
if lifted |
|
2475 |
then (ntps, (Bs @ map (norm_term_skip env nlift) As, C)) |
|
2476 |
else (ntps, (Bs @ map normt As, C)) |
|
2477 |
else if match then raise COMPOSE |
|
2478 |
else (*normalize the new rule fully*) |
|
2479 |
(ntps, (map normt (Bs @ As), normt C)) |
|
2480 |
end; |
|
2481 |
val thy' = Context.certificate_theory cert handle ERROR msg => |
|
2482 |
raise CONTEXT (msg, [], [], [state, orule], Option.map Context.Proof opt_ctxt); |
|
2483 |
val constraints' = |
|
2484 |
union_constraints constraints1 constraints2 |
|
2485 |
|> insert_constraints_env thy' env; |
|
79261 | 2486 |
fun zproof p q = |
79270
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79263
diff
changeset
|
2487 |
ZTerm.bicompose_proof thy' env smax flatten Bs As A oldAs n (nlift + 1) |
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79263
diff
changeset
|
2488 |
[full_prop_of state, full_prop_of orule] p q; |
79241 | 2489 |
fun proof p q = |
2490 |
Proofterm.bicompose_proof env smax flatten Bs As A oldAs n (nlift + 1) p q; |
|
79239 | 2491 |
val th = |
2492 |
Thm (deriv_rule2 zproof proof rder' sder, |
|
2493 |
{tags = [], |
|
2494 |
maxidx = Envir.maxidx_of env, |
|
2495 |
constraints = constraints', |
|
2496 |
shyps = Envir.insert_sorts env (Sorts.union shyps1 shyps2), |
|
2497 |
hyps = union_hyps hyps1 hyps2, |
|
2498 |
tpairs = ntpairs, |
|
2499 |
prop = Logic.list_implies normp, |
|
2500 |
cert = cert}) |
|
2501 |
in Seq.cons th thq end handle COMPOSE => thq; |
|
2502 |
val (rAs, B) = Logic.strip_prems (nsubgoal, [], rprop) |
|
2503 |
handle TERM _ => raise THM("bicompose: rule", 0, [orule, state]); |
|
2504 |
(*Modify assumptions, deleting n-th if n>0 for e-resolution*) |
|
2505 |
fun newAs (As0, n, dpairs, tpairs) = |
|
2506 |
let val (As1, rder') = |
|
79253 | 2507 |
if lifted then |
79251 | 2508 |
(case rename_bvars dpairs tpairs B As0 of |
79310 | 2509 |
SOME term => |
2510 |
let fun proof p = Same.commit (Proofterm.map_proof_terms_same term I) p; |
|
2511 |
in (map (strip_apply (Same.commit term) B) As0, deriv_rule1 I proof rder) end |
|
79253 | 2512 |
| NONE => (As0, rder)) |
2513 |
else (As0, rder); |
|
79239 | 2514 |
in |
2515 |
(if flatten then map (Logic.flatten_params n) As1 else As1, As1, rder', n) |
|
2516 |
handle TERM _ => raise THM("bicompose: 1st premise", 0, [orule]) |
|
2517 |
end; |
|
2518 |
val BBi = if lifted then strip_assums2 (B, Bi) else (B, Bi); |
|
2519 |
val dpairs = BBi :: (rtpairs @ stpairs); |
|
30554
73f8bd5f0af8
substantial speedup of assumption and elim-resolution: Logic.assum_problems refrains from eager application of parameters, discriminate via Term.could_unify before invoking full unification (assumes terms in beta-normal form, as do higher term net operations anyway);
wenzelm
parents:
30466
diff
changeset
|
2520 |
|
79239 | 2521 |
(*elim-resolution: try each assumption in turn*) |
2522 |
fun eres _ [] = raise THM ("bicompose: no premises", 0, [orule, state]) |
|
2523 |
| eres env (A1 :: As) = |
|
2524 |
let |
|
2525 |
val A = SOME A1; |
|
2526 |
val (close, asms, concl) = Logic.assum_problems (nlift + 1, A1); |
|
2527 |
val concl' = close concl; |
|
2528 |
fun tryasms [] _ = Seq.empty |
|
2529 |
| tryasms (asm :: rest) n = |
|
2530 |
if Term.could_unify (asm, concl) then |
|
2531 |
let val asm' = close asm in |
|
2532 |
(case Seq.pull (Unify.unifiers (context, env, (asm', concl') :: dpairs)) of |
|
2533 |
NONE => tryasms rest (n + 1) |
|
2534 |
| cell as SOME ((_, tpairs), _) => |
|
2535 |
Seq.it_right (addth A (newAs (As, n, [BBi, (concl', asm')], tpairs))) |
|
2536 |
(Seq.make (fn () => cell), |
|
2537 |
Seq.make (fn () => Seq.pull (tryasms rest (n + 1))))) |
|
2538 |
end |
|
2539 |
else tryasms rest (n + 1); |
|
2540 |
in tryasms asms 1 end; |
|
30554
73f8bd5f0af8
substantial speedup of assumption and elim-resolution: Logic.assum_problems refrains from eager application of parameters, discriminate via Term.could_unify before invoking full unification (assumes terms in beta-normal form, as do higher term net operations anyway);
wenzelm
parents:
30466
diff
changeset
|
2541 |
|
0 | 2542 |
(*ordinary resolution*) |
79239 | 2543 |
fun res env = |
2544 |
(case Seq.pull (Unify.unifiers (context, env, dpairs)) of |
|
2545 |
NONE => Seq.empty |
|
2546 |
| cell as SOME ((_, tpairs), _) => |
|
2547 |
Seq.it_right (addth NONE (newAs (rev rAs, 0, [BBi], tpairs))) |
|
2548 |
(Seq.make (fn () => cell), Seq.empty)); |
|
52222
0fa3b456a267
unify types of schematic variables in non-lifted case (i.e. "compose variants") -- allow schematic polymorphism, without revisiting HO-unification;
wenzelm
parents:
52131
diff
changeset
|
2549 |
|
79239 | 2550 |
val env0 = Envir.empty (Int.max (rmax, smax)); |
2551 |
in |
|
2552 |
(case if incremented then SOME env0 else unify_var_types context (state, orule) env0 of |
|
2553 |
NONE => Seq.empty |
|
2554 |
| SOME env => if eres_flg then eres env (rev rAs) else res env) |
|
2555 |
end; |
|
2556 |
||
7528 | 2557 |
end; |
0 | 2558 |
|
58950
d07464875dd4
optional proof context for unify operations, for the sake of proper local options;
wenzelm
parents:
58946
diff
changeset
|
2559 |
fun bicompose opt_ctxt flags arg i state = |
d07464875dd4
optional proof context for unify operations, for the sake of proper local options;
wenzelm
parents:
58946
diff
changeset
|
2560 |
bicompose_aux opt_ctxt flags (state, dest_state (state,i), false) arg; |
0 | 2561 |
|
2562 |
(*Quick test whether rule is resolvable with the subgoal with hyps Hs |
|
2563 |
and conclusion B. If eres_flg then checks 1st premise of rule also*) |
|
2564 |
fun could_bires (Hs, B, eres_flg, rule) = |
|
29269
5c25a2012975
moved term order operations to structure TermOrd (cf. Pure/term_ord.ML);
wenzelm
parents:
29003
diff
changeset
|
2565 |
let fun could_reshyp (A1::_) = exists (fn H => Term.could_unify (A1, H)) Hs |
250 | 2566 |
| could_reshyp [] = false; (*no premise -- illegal*) |
29269
5c25a2012975
moved term order operations to structure TermOrd (cf. Pure/term_ord.ML);
wenzelm
parents:
29003
diff
changeset
|
2567 |
in Term.could_unify(concl_of rule, B) andalso |
250 | 2568 |
(not eres_flg orelse could_reshyp (prems_of rule)) |
0 | 2569 |
end; |
2570 |
||
2571 |
(*Bi-resolution of a state with a list of (flag,rule) pairs. |
|
2572 |
Puts the rule above: rule/state. Renames vars in the rules. *) |
|
58950
d07464875dd4
optional proof context for unify operations, for the sake of proper local options;
wenzelm
parents:
58946
diff
changeset
|
2573 |
fun biresolution opt_ctxt match brules i state = |
18035 | 2574 |
let val (stpairs, Bs, Bi, C) = dest_state(state,i); |
18145 | 2575 |
val lift = lift_rule (cprem_of state i); |
250 | 2576 |
val B = Logic.strip_assums_concl Bi; |
2577 |
val Hs = Logic.strip_assums_hyp Bi; |
|
52223
5bb6ae8acb87
tuned signature -- more explicit flags for low-level Thm.bicompose;
wenzelm
parents:
52222
diff
changeset
|
2578 |
val compose = |
58950
d07464875dd4
optional proof context for unify operations, for the sake of proper local options;
wenzelm
parents:
58946
diff
changeset
|
2579 |
bicompose_aux opt_ctxt {flatten = true, match = match, incremented = true} |
52223
5bb6ae8acb87
tuned signature -- more explicit flags for low-level Thm.bicompose;
wenzelm
parents:
52222
diff
changeset
|
2580 |
(state, (stpairs, Bs, Bi, C), true); |
4270 | 2581 |
fun res [] = Seq.empty |
250 | 2582 |
| res ((eres_flg, rule)::brules) = |
61044
b7af255dd200
more abstract theory certificate, which is not necessarily the full theory;
wenzelm
parents:
61042
diff
changeset
|
2583 |
if Config.get_generic (make_context [state] opt_ctxt (cert_of state)) |
58950
d07464875dd4
optional proof context for unify operations, for the sake of proper local options;
wenzelm
parents:
58946
diff
changeset
|
2584 |
Pattern.unify_trace_failure orelse could_bires (Hs, B, eres_flg, rule) |
4270 | 2585 |
then Seq.make (*delay processing remainder till needed*) |
22573 | 2586 |
(fn()=> SOME(compose (eres_flg, lift rule, nprems_of rule), |
250 | 2587 |
res brules)) |
2588 |
else res brules |
|
4270 | 2589 |
in Seq.flat (res brules) end; |
0 | 2590 |
|
70456
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2591 |
(*Resolution: exactly one resolvent must be produced*) |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2592 |
fun tha RSN (i, thb) = |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2593 |
(case Seq.chop 2 (biresolution NONE false [(false, tha)] i thb) of |
70472
cf66d2db97fe
more robust and convenient treatment of implicit context;
wenzelm
parents:
70469
diff
changeset
|
2594 |
([th], _) => solve_constraints th |
70456
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2595 |
| ([], _) => raise THM ("RSN: no unifiers", i, [tha, thb]) |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2596 |
| _ => raise THM ("RSN: multiple unifiers", i, [tha, thb])); |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2597 |
|
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2598 |
(*Resolution: P \<Longrightarrow> Q, Q \<Longrightarrow> R gives P \<Longrightarrow> R*) |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2599 |
fun tha RS thb = tha RSN (1,thb); |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2600 |
|
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2601 |
|
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2602 |
|
70458 | 2603 |
(**** Type classes ****) |
70456
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2604 |
|
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2605 |
fun standard_tvars thm = |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2606 |
let |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2607 |
val thy = theory_of_thm thm; |
74235 | 2608 |
val tvars = build_rev (Term.add_tvars (prop_of thm)); |
70456
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2609 |
val names = Name.invent Name.context Name.aT (length tvars); |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2610 |
val tinst = |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2611 |
map2 (fn (ai, S) => fn b => ((ai, S), global_ctyp_of thy (TVar ((b, 0), S)))) tvars names; |
74282 | 2612 |
in instantiate (TVars.make tinst, Vars.empty) thm end |
70456
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2613 |
|
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2614 |
|
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2615 |
(* class relations *) |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2616 |
|
70457 | 2617 |
val is_classrel = Symreltab.defined o get_classrels; |
2618 |
||
70456
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2619 |
fun complete_classrels thy = |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2620 |
let |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2621 |
fun complete (c, (_, (all_preds, all_succs))) (finished1, thy1) = |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2622 |
let |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2623 |
fun compl c1 c2 (finished2, thy2) = |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2624 |
if is_classrel thy2 (c1, c2) then (finished2, thy2) |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2625 |
else |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2626 |
(false, |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2627 |
thy2 |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2628 |
|> (map_classrels o Symreltab.update) ((c1, c2), |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2629 |
(the_classrel thy2 (c1, c) RS the_classrel thy2 (c, c2)) |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2630 |
|> standard_tvars |
71018
d32ed8927a42
more robust expose_proofs corresponding to register_proofs/consolidate_theory;
wenzelm
parents:
71017
diff
changeset
|
2631 |
|> close_derivation \<^here> |
d32ed8927a42
more robust expose_proofs corresponding to register_proofs/consolidate_theory;
wenzelm
parents:
71017
diff
changeset
|
2632 |
|> tap (expose_proof thy2) |
70456
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2633 |
|> trim_context)); |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2634 |
|
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2635 |
val proven = is_classrel thy1; |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2636 |
val preds = Graph.Keys.fold (fn c1 => proven (c1, c) ? cons c1) all_preds []; |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2637 |
val succs = Graph.Keys.fold (fn c2 => proven (c, c2) ? cons c2) all_succs []; |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2638 |
in |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2639 |
fold_product compl preds succs (finished1, thy1) |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2640 |
end; |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2641 |
in |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2642 |
(case Graph.fold complete (Sorts.classes_of (Sign.classes_of thy)) (true, thy) of |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2643 |
(true, _) => NONE |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2644 |
| (_, thy') => SOME thy') |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2645 |
end; |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2646 |
|
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2647 |
|
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2648 |
(* type arities *) |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2649 |
|
77891 | 2650 |
fun theory_names_of_arity {long} thy (a, c) = |
74234 | 2651 |
build (get_arities thy |> Aritytab.fold |
2652 |
(fn ((a', _, c'), (_, name, ser)) => (a = a' andalso c = c') ? cons (name, ser))) |
|
77891 | 2653 |
|> sort (int_ord o apply2 #2) |> map (if long then #1 else Long_Name.base_name o #1); |
70475
98b6da301e13
backed out changeset 1b8858f4c393: odd problems e.g. in CAVA_LTL_Modelchecker;
wenzelm
parents:
70472
diff
changeset
|
2654 |
|
98b6da301e13
backed out changeset 1b8858f4c393: odd problems e.g. in CAVA_LTL_Modelchecker;
wenzelm
parents:
70472
diff
changeset
|
2655 |
fun insert_arity_completions thy ((t, Ss, c), (th, thy_name, ser)) (finished, arities) = |
70456
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2656 |
let |
70461 | 2657 |
val completions = |
2658 |
Sign.super_classes thy c |> map_filter (fn c1 => |
|
70465 | 2659 |
if Aritytab.defined arities (t, Ss, c1) then NONE |
70461 | 2660 |
else |
2661 |
let |
|
2662 |
val th1 = |
|
2663 |
(th RS the_classrel thy (c, c1)) |
|
2664 |
|> standard_tvars |
|
71018
d32ed8927a42
more robust expose_proofs corresponding to register_proofs/consolidate_theory;
wenzelm
parents:
71017
diff
changeset
|
2665 |
|> close_derivation \<^here> |
d32ed8927a42
more robust expose_proofs corresponding to register_proofs/consolidate_theory;
wenzelm
parents:
71017
diff
changeset
|
2666 |
|> tap (expose_proof thy) |
70461 | 2667 |
|> trim_context; |
70475
98b6da301e13
backed out changeset 1b8858f4c393: odd problems e.g. in CAVA_LTL_Modelchecker;
wenzelm
parents:
70472
diff
changeset
|
2668 |
in SOME ((t, Ss, c1), (th1, thy_name, ser)) end); |
70456
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2669 |
val finished' = finished andalso null completions; |
70465 | 2670 |
val arities' = fold Aritytab.update completions arities; |
70456
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2671 |
in (finished', arities') end; |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2672 |
|
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2673 |
fun complete_arities thy = |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2674 |
let |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2675 |
val arities = get_arities thy; |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2676 |
val (finished, arities') = |
70465 | 2677 |
Aritytab.fold (insert_arity_completions thy) arities (true, get_arities thy); |
70456
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2678 |
in |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2679 |
if finished then NONE |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2680 |
else SOME (map_arities (K arities') thy) |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2681 |
end; |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2682 |
|
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2683 |
val _ = |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2684 |
Theory.setup |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2685 |
(Theory.at_begin complete_classrels #> |
70458 | 2686 |
Theory.at_begin complete_arities); |
70456
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2687 |
|
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2688 |
|
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2689 |
(* primitive rules *) |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2690 |
|
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2691 |
fun add_classrel raw_th thy = |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2692 |
let |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2693 |
val th = strip_shyps (transfer thy raw_th); |
71017
c85efa2be619
expose derivations more thoroughly, notably for locale/class reasoning;
wenzelm
parents:
71012
diff
changeset
|
2694 |
val th' = th |> unconstrainT |> tap (expose_proof thy) |> trim_context; |
70456
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2695 |
val prop = plain_prop_of th; |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2696 |
val (c1, c2) = Logic.dest_classrel prop; |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2697 |
in |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2698 |
thy |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2699 |
|> Sign.primitive_classrel (c1, c2) |
71017
c85efa2be619
expose derivations more thoroughly, notably for locale/class reasoning;
wenzelm
parents:
71012
diff
changeset
|
2700 |
|> map_classrels (Symreltab.update ((c1, c2), th')) |
70456
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2701 |
|> perhaps complete_classrels |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2702 |
|> perhaps complete_arities |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2703 |
end; |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2704 |
|
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2705 |
fun add_arity raw_th thy = |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2706 |
let |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2707 |
val th = strip_shyps (transfer thy raw_th); |
71017
c85efa2be619
expose derivations more thoroughly, notably for locale/class reasoning;
wenzelm
parents:
71012
diff
changeset
|
2708 |
val th' = th |> unconstrainT |> tap (expose_proof thy) |> trim_context; |
70456
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2709 |
val prop = plain_prop_of th; |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2710 |
val (t, Ss, c) = Logic.dest_arity prop; |
77891 | 2711 |
val ar = ((t, Ss, c), (th', Context.theory_long_name thy, serial ())); |
70456
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2712 |
in |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2713 |
thy |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2714 |
|> Sign.primitive_arity (t, Ss, [c]) |
70465 | 2715 |
|> map_arities (Aritytab.update ar #> curry (insert_arity_completions thy ar) true #> #2) |
70456
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2716 |
end; |
c742527a25fe
clarified modules: inference kernel maintains sort algebra within the logic;
wenzelm
parents:
70454
diff
changeset
|
2717 |
|
0 | 2718 |
end; |
1503 | 2719 |
|
32104 | 2720 |
structure Basic_Thm: BASIC_THM = Thm; |
2721 |
open Basic_Thm; |