10 signature BASIC_PROOFTERM = |
10 signature BASIC_PROOFTERM = |
11 sig |
11 sig |
12 val proofs: int ref |
12 val proofs: int ref |
13 |
13 |
14 datatype proof = |
14 datatype proof = |
15 PBound of int |
15 MinProof |
|
16 | PBound of int |
16 | Abst of string * typ option * proof |
17 | Abst of string * typ option * proof |
17 | AbsP of string * term option * proof |
18 | AbsP of string * term option * proof |
18 | % of proof * term option |
19 | op % of proof * term option |
19 | %% of proof * proof |
20 | op %% of proof * proof |
20 | Hyp of term |
21 | Hyp of term |
21 | PThm of string * proof * term * typ list option |
|
22 | PAxm of string * term * typ list option |
22 | PAxm of string * term * typ list option |
23 | Oracle of string * term * typ list option |
23 | Oracle of string * term * typ list option |
24 | Promise of serial * term * typ list option |
24 | Promise of serial * term * typ list option |
25 | MinProof of ((string * term) * proof) list * (string * term) list * (string * term) list; |
25 | PThm of serial * ((string * term * typ list option) * proof_body Lazy.T) |
|
26 and proof_body = PBody of |
|
27 {oracles: (string * term) OrdList.T, |
|
28 thms: (serial * ((string * term * typ list option) * proof_body Lazy.T)) OrdList.T, |
|
29 proof: proof} |
26 |
30 |
27 val %> : proof * term -> proof |
31 val %> : proof * term -> proof |
28 end; |
32 end; |
29 |
33 |
30 signature PROOFTERM = |
34 signature PROOFTERM = |
31 sig |
35 sig |
32 include BASIC_PROOFTERM |
36 include BASIC_PROOFTERM |
33 |
37 |
|
38 val proof_of: proof_body -> proof |
|
39 val force_body: proof_body Lazy.T -> |
|
40 {oracles: (string * term) OrdList.T, |
|
41 thms: (serial * ((string * term * typ list option) * proof_body Lazy.T)) OrdList.T, |
|
42 proof: proof} |
|
43 val force_proof: proof_body Lazy.T -> proof |
|
44 val fold_body_thms: ((string * term * typ list option) * proof_body -> 'a -> 'a) -> |
|
45 proof_body list -> 'a -> 'a |
|
46 val fold_proof_atoms: bool -> (proof -> 'a -> 'a) -> proof list -> 'a -> 'a |
|
47 |
|
48 type oracle = string * term |
|
49 val oracle_ord: oracle * oracle -> order |
|
50 type pthm = serial * ((string * term * typ list option) * proof_body Lazy.T) |
|
51 val thm_ord: pthm * pthm -> order |
|
52 val make_proof_body: proof -> proof_body |
|
53 val merge_oracles: oracle OrdList.T -> oracle OrdList.T -> oracle OrdList.T |
|
54 val make_oracles: proof -> oracle OrdList.T |
|
55 val merge_thms: pthm OrdList.T -> pthm OrdList.T -> pthm OrdList.T |
|
56 val make_thms: proof -> pthm OrdList.T |
|
57 |
34 (** primitive operations **) |
58 (** primitive operations **) |
35 val min_proof : proof |
59 val proof_combt: proof * term list -> proof |
36 val proof_combt : proof * term list -> proof |
60 val proof_combt': proof * term option list -> proof |
37 val proof_combt' : proof * term option list -> proof |
61 val proof_combP: proof * proof list -> proof |
38 val proof_combP : proof * proof list -> proof |
62 val strip_combt: proof -> proof * term option list |
39 val strip_combt : proof -> proof * term option list |
63 val strip_combP: proof -> proof * proof list |
40 val strip_combP : proof -> proof * proof list |
64 val strip_thm: proof_body -> proof_body |
41 val strip_thm : proof -> proof |
65 val map_proof_terms_option: (term -> term option) -> (typ -> typ option) -> proof -> proof |
42 val map_proof_terms_option : (term -> term option) -> (typ -> typ option) -> proof -> proof |
66 val map_proof_terms: (term -> term) -> (typ -> typ) -> proof -> proof |
43 val map_proof_terms : (term -> term) -> (typ -> typ) -> proof -> proof |
67 val fold_proof_terms: (term -> 'a -> 'a) -> (typ -> 'a -> 'a) -> proof -> 'a -> 'a |
44 val fold_proof_terms : (term -> 'a -> 'a) -> (typ -> 'a -> 'a) -> proof -> 'a -> 'a |
68 val maxidx_proof: proof -> int -> int |
45 val maxidx_proof : proof -> int -> int |
69 val size_of_proof: proof -> int |
46 val size_of_proof : proof -> int |
70 val change_type: typ list option -> proof -> proof |
47 val change_type : typ list option -> proof -> proof |
71 val prf_abstract_over: term -> proof -> proof |
48 val prf_abstract_over : term -> proof -> proof |
72 val prf_incr_bv: int -> int -> int -> int -> proof -> proof |
49 val prf_incr_bv : int -> int -> int -> int -> proof -> proof |
73 val incr_pboundvars: int -> int -> proof -> proof |
50 val incr_pboundvars : int -> int -> proof -> proof |
74 val prf_loose_bvar1: proof -> int -> bool |
51 val prf_loose_bvar1 : proof -> int -> bool |
75 val prf_loose_Pbvar1: proof -> int -> bool |
52 val prf_loose_Pbvar1 : proof -> int -> bool |
76 val prf_add_loose_bnos: int -> int -> proof -> int list * int list -> int list * int list |
53 val prf_add_loose_bnos : int -> int -> proof -> |
77 val norm_proof: Envir.env -> proof -> proof |
54 int list * int list -> int list * int list |
78 val norm_proof': Envir.env -> proof -> proof |
55 val norm_proof : Envir.env -> proof -> proof |
79 val prf_subst_bounds: term list -> proof -> proof |
56 val norm_proof' : Envir.env -> proof -> proof |
80 val prf_subst_pbounds: proof list -> proof -> proof |
57 val prf_subst_bounds : term list -> proof -> proof |
81 val freeze_thaw_prf: proof -> proof * (proof -> proof) |
58 val prf_subst_pbounds : proof list -> proof -> proof |
|
59 val freeze_thaw_prf : proof -> proof * (proof -> proof) |
|
60 val proof_of_min_axm : string * term -> proof |
|
61 val proof_of_min_thm : (string * term) * proof -> proof |
|
62 |
|
63 val thms_of_proof : proof -> (term * proof) list Symtab.table -> |
|
64 (term * proof) list Symtab.table |
|
65 val thms_of_proof' : proof -> (term * proof) list Symtab.table -> |
|
66 (term * proof) list Symtab.table |
|
67 val axms_of_proof : proof -> proof Symtab.table -> proof Symtab.table |
|
68 val mk_min_proof : proof -> |
|
69 ((string * term) * proof) list * (string * term) list * (string * term) list -> |
|
70 ((string * term) * proof) list * (string * term) list * (string * term) list |
|
71 val add_oracles : bool -> proof -> (string * term) list -> (string * term) list |
|
72 |
82 |
73 (** proof terms for specific inference rules **) |
83 (** proof terms for specific inference rules **) |
74 val implies_intr_proof : term -> proof -> proof |
84 val implies_intr_proof: term -> proof -> proof |
75 val forall_intr_proof : term -> string -> proof -> proof |
85 val forall_intr_proof: term -> string -> proof -> proof |
76 val varify_proof : term -> (string * sort) list -> proof -> proof |
86 val varify_proof: term -> (string * sort) list -> proof -> proof |
77 val freezeT : term -> proof -> proof |
87 val freezeT: term -> proof -> proof |
78 val rotate_proof : term list -> term -> int -> proof -> proof |
88 val rotate_proof: term list -> term -> int -> proof -> proof |
79 val permute_prems_prf : term list -> int -> int -> proof -> proof |
89 val permute_prems_prf: term list -> int -> int -> proof -> proof |
80 val generalize: string list * string list -> int -> proof -> proof |
90 val generalize: string list * string list -> int -> proof -> proof |
81 val instantiate : ((indexname * sort) * typ) list * ((indexname * typ) * term) list |
91 val instantiate: ((indexname * sort) * typ) list * ((indexname * typ) * term) list |
82 -> proof -> proof |
92 -> proof -> proof |
83 val lift_proof : term -> int -> term -> proof -> proof |
93 val lift_proof: term -> int -> term -> proof -> proof |
84 val assumption_proof : term list -> term -> int -> proof -> proof |
94 val assumption_proof: term list -> term -> int -> proof -> proof |
85 val bicompose_proof : bool -> term list -> term list -> term list -> term option -> |
95 val bicompose_proof: bool -> term list -> term list -> term list -> term option -> |
86 int -> int -> proof -> proof -> proof |
96 int -> int -> proof -> proof -> proof |
87 val equality_axms : (string * term) list |
97 val equality_axms: (string * term) list |
88 val reflexive_axm : proof |
98 val reflexive_axm: proof |
89 val symmetric_axm : proof |
99 val symmetric_axm: proof |
90 val transitive_axm : proof |
100 val transitive_axm: proof |
91 val equal_intr_axm : proof |
101 val equal_intr_axm: proof |
92 val equal_elim_axm : proof |
102 val equal_elim_axm: proof |
93 val abstract_rule_axm : proof |
103 val abstract_rule_axm: proof |
94 val combination_axm : proof |
104 val combination_axm: proof |
95 val reflexive : proof |
105 val reflexive: proof |
96 val symmetric : proof -> proof |
106 val symmetric: proof -> proof |
97 val transitive : term -> typ -> proof -> proof -> proof |
107 val transitive: term -> typ -> proof -> proof -> proof |
98 val abstract_rule : term -> string -> proof -> proof |
108 val abstract_rule: term -> string -> proof -> proof |
99 val combination : term -> term -> term -> term -> typ -> proof -> proof -> proof |
109 val combination: term -> term -> term -> term -> typ -> proof -> proof -> proof |
100 val equal_intr : term -> term -> proof -> proof -> proof |
110 val equal_intr: term -> term -> proof -> proof -> proof |
101 val equal_elim : term -> term -> proof -> proof -> proof |
111 val equal_elim: term -> term -> proof -> proof -> proof |
102 val axm_proof : string -> term -> proof |
112 val axm_proof: string -> term -> proof |
103 val oracle_proof : string -> term -> proof |
113 val oracle_proof: string -> term -> proof |
104 val promise_proof : serial -> term -> proof |
114 val promise_proof: serial -> term -> proof |
105 val thm_proof : theory -> string -> term list -> term -> proof -> proof |
115 val fulfill_proof: (serial * proof Lazy.T) list -> proof_body -> proof_body |
106 val get_name : term list -> term -> proof -> string |
116 val thm_proof: theory -> string -> term list -> term -> |
|
117 (serial * proof Lazy.T) list -> proof_body -> pthm * proof |
|
118 val get_name: term list -> term -> proof -> string |
107 |
119 |
108 (** rewriting on proof terms **) |
120 (** rewriting on proof terms **) |
109 val add_prf_rrule : proof * proof -> theory -> theory |
121 val add_prf_rrule: proof * proof -> theory -> theory |
110 val add_prf_rproc : string * (Term.typ list -> proof -> proof option) -> |
122 val add_prf_rproc: (typ list -> proof -> proof option) -> theory -> theory |
111 theory -> theory |
123 val rewrite_proof: theory -> (proof * proof) list * |
112 val rewrite_proof : theory -> (proof * proof) list * |
124 (typ list -> proof -> proof option) list -> proof -> proof |
113 (string * (typ list -> proof -> proof option)) list -> proof -> proof |
125 val rewrite_proof_notypes: (proof * proof) list * |
114 val rewrite_proof_notypes : (proof * proof) list * |
126 (typ list -> proof -> proof option) list -> proof -> proof |
115 (string * (typ list -> proof -> proof option)) list -> proof -> proof |
127 val rew_proof: theory -> proof -> proof |
116 val rew_proof : theory -> proof -> proof |
|
117 val fulfill : proof Inttab.table -> proof -> proof |
|
118 end |
128 end |
119 |
129 |
120 structure Proofterm : PROOFTERM = |
130 structure Proofterm : PROOFTERM = |
121 struct |
131 struct |
122 |
132 |
123 open Envir; |
133 open Envir; |
124 |
134 |
|
135 |
|
136 (***** datatype proof *****) |
|
137 |
125 datatype proof = |
138 datatype proof = |
126 PBound of int |
139 MinProof |
|
140 | PBound of int |
127 | Abst of string * typ option * proof |
141 | Abst of string * typ option * proof |
128 | AbsP of string * term option * proof |
142 | AbsP of string * term option * proof |
129 | op % of proof * term option |
143 | op % of proof * term option |
130 | op %% of proof * proof |
144 | op %% of proof * proof |
131 | Hyp of term |
145 | Hyp of term |
132 | PThm of string * proof * term * typ list option |
|
133 | PAxm of string * term * typ list option |
146 | PAxm of string * term * typ list option |
134 | Oracle of string * term * typ list option |
147 | Oracle of string * term * typ list option |
135 | Promise of serial * term * typ list option |
148 | Promise of serial * term * typ list option |
136 | MinProof of ((string * term) * proof) list * (string * term) list * (string * term) list; |
149 | PThm of serial * ((string * term * typ list option) * proof_body Lazy.T) |
137 |
150 and proof_body = PBody of |
138 fun proof_of_min_axm (s, prop) = PAxm (s, prop, NONE); |
151 {oracles: (string * term) OrdList.T, |
139 fun proof_of_min_thm ((s, prop), prf) = PThm (s, prf, prop, NONE); |
152 thms: (serial * ((string * term * typ list option) * proof_body Lazy.T)) OrdList.T, |
140 |
153 proof: proof}; |
141 val string_term_ord = prod_ord fast_string_ord Term.fast_term_ord; |
154 |
142 |
155 val force_body = Lazy.force #> (fn PBody args => args); |
143 fun oracles_of_proof prf oras = |
156 val force_proof = #proof o force_body; |
144 let |
157 |
145 fun oras_of (Abst (_, _, prf)) = oras_of prf |
158 fun proof_of (PBody {proof, ...}) = proof; |
146 | oras_of (AbsP (_, _, prf)) = oras_of prf |
159 |
147 | oras_of (prf % _) = oras_of prf |
160 |
148 | oras_of (prf1 %% prf2) = oras_of prf1 #> oras_of prf2 |
161 (***** proof atoms *****) |
149 | oras_of (PThm (name, prf, prop, _)) = (fn tabs as (thms, oras) => |
162 |
150 if member (op =) (Symtab.lookup_list thms name) prop then tabs |
163 fun fold_body_thms f = |
151 else oras_of prf (Symtab.cons_list (name, prop) thms, oras)) |
164 let |
152 | oras_of (Oracle (s, prop, _)) = |
165 fun app (PBody {thms, ...}) = thms |> fold (fn (i, (stmt, body)) => fn (x, seen) => |
153 apsnd (OrdList.insert string_term_ord (s, prop)) |
166 if Inttab.defined seen i then (x, seen) |
154 | oras_of (MinProof (thms, _, oras)) = |
167 else |
155 apsnd (OrdList.union string_term_ord oras) #> |
168 let |
156 fold (oras_of o proof_of_min_thm) thms |
169 val body' = Lazy.force body; |
157 | oras_of _ = I |
170 val (x', seen') = app body' (x, Inttab.update (i, ()) seen); |
158 in |
171 in (f (stmt, body') x', seen') end); |
159 snd (oras_of prf (Symtab.empty, oras)) |
172 in fn bodies => fn x => #1 (fold app bodies (x, Inttab.empty)) end; |
160 end; |
173 |
161 |
174 fun fold_proof_atoms all f = |
162 fun add_oracles false = K I |
175 let |
163 | add_oracles true = oracles_of_proof; |
176 fun app (Abst (_, _, prf)) = app prf |
164 |
177 | app (AbsP (_, _, prf)) = app prf |
165 fun thms_of_proof (Abst (_, _, prf)) = thms_of_proof prf |
178 | app (prf % _) = app prf |
166 | thms_of_proof (AbsP (_, _, prf)) = thms_of_proof prf |
179 | app (prf1 %% prf2) = app prf1 #> app prf2 |
167 | thms_of_proof (prf1 %% prf2) = thms_of_proof prf1 #> thms_of_proof prf2 |
180 | app (prf as PThm (i, (_, body))) = (fn (x, seen) => |
168 | thms_of_proof (prf % _) = thms_of_proof prf |
181 if Inttab.defined seen i then (x, seen) |
169 | thms_of_proof (prf' as PThm (s, prf, prop, _)) = (fn tab => |
182 else |
170 if exists (fn (p, _) => p = prop) (Symtab.lookup_list tab s) then tab |
183 let val res = (f prf x, Inttab.update (i, ()) seen) |
171 else thms_of_proof prf (Symtab.cons_list (s, (prop, prf')) tab)) |
184 in if all then app (force_proof body) res else res |
172 | thms_of_proof (MinProof (prfs, _, _)) = fold (thms_of_proof o proof_of_min_thm) prfs |
185 end) |
173 | thms_of_proof _ = I; |
186 | app prf = (fn (x, seen) => (f prf x, seen)); |
174 |
187 in fn prfs => fn x => #1 (fold app prfs (x, Inttab.empty)) end; |
175 (* this version does not recursively descend into proofs of (named) theorems *) |
188 |
176 fun thms_of_proof' (Abst (_, _, prf)) = thms_of_proof' prf |
189 |
177 | thms_of_proof' (AbsP (_, _, prf)) = thms_of_proof' prf |
190 (* atom kinds *) |
178 | thms_of_proof' (prf1 %% prf2) = thms_of_proof' prf1 #> thms_of_proof' prf2 |
191 |
179 | thms_of_proof' (prf % _) = thms_of_proof' prf |
192 type oracle = string * term; |
180 | thms_of_proof' (PThm ("", prf, prop, _)) = thms_of_proof' prf |
193 val oracle_ord = prod_ord fast_string_ord Term.fast_term_ord; |
181 | thms_of_proof' (prf' as PThm (s, _, prop, _)) = |
194 |
182 Symtab.insert_list (eq_fst op =) (s, (prop, prf')) |
195 type pthm = serial * ((string * term * typ list option) * proof_body Lazy.T); |
183 | thms_of_proof' (MinProof (prfs, _, _)) = fold (thms_of_proof' o proof_of_min_thm) prfs |
196 fun thm_ord ((i, _): pthm, (j, _)) = int_ord (j, i); |
184 | thms_of_proof' _ = I; |
197 |
185 |
198 |
186 fun axms_of_proof (Abst (_, _, prf)) = axms_of_proof prf |
199 (* proof body *) |
187 | axms_of_proof (AbsP (_, _, prf)) = axms_of_proof prf |
200 |
188 | axms_of_proof (prf1 %% prf2) = axms_of_proof prf1 #> axms_of_proof prf2 |
201 fun make_body prf = |
189 | axms_of_proof (prf % _) = axms_of_proof prf |
202 let |
190 | axms_of_proof (prf as PAxm (s, _, _)) = Symtab.update (s, prf) |
203 val (oracles, thms) = fold_proof_atoms false |
191 | axms_of_proof (MinProof (_, prfs, _)) = fold (axms_of_proof o proof_of_min_axm) prfs |
204 (fn Oracle (s, prop, _) => apfst (cons (s, prop)) |
192 | axms_of_proof _ = I; |
205 | PThm thm => apsnd (cons thm) |
193 |
206 | _ => I) [prf] ([], []); |
194 (** collect all theorems, axioms and oracles **) |
207 in (OrdList.make oracle_ord oracles, OrdList.make thm_ord thms) end; |
195 |
208 |
196 fun map3 f g h (thms, axms, oras) = (f thms, g axms, h oras); |
209 fun make_proof_body prf = |
197 |
210 let val (oracles, thms) = make_body prf |
198 fun mk_min_proof (Abst (_, _, prf)) = mk_min_proof prf |
211 in PBody {oracles = oracles, thms = thms, proof = prf} end; |
199 | mk_min_proof (AbsP (_, _, prf)) = mk_min_proof prf |
212 |
200 | mk_min_proof (prf % _) = mk_min_proof prf |
213 val make_oracles = #1 o make_body; |
201 | mk_min_proof (prf1 %% prf2) = mk_min_proof prf1 #> mk_min_proof prf2 |
214 val make_thms = #2 o make_body; |
202 | mk_min_proof (PThm (s, prf, prop, _)) = |
215 |
203 map3 (OrdList.insert (string_term_ord o pairself fst) ((s, prop), prf)) I I |
216 val merge_oracles = OrdList.union oracle_ord; |
204 | mk_min_proof (PAxm (s, prop, _)) = |
217 val merge_thms = OrdList.union thm_ord; |
205 map3 I (OrdList.insert string_term_ord (s, prop)) I |
218 |
206 | mk_min_proof (Oracle (s, prop, _)) = |
219 fun merge_body (oracles1, thms1) (oracles2, thms2) = |
207 map3 I I (OrdList.insert string_term_ord (s, prop)) |
220 (merge_oracles oracles1 oracles2, merge_thms thms1 thms2); |
208 | mk_min_proof (MinProof (thms, axms, oras)) = |
221 |
209 map3 (OrdList.union (string_term_ord o pairself fst) thms) |
222 |
210 (OrdList.union string_term_ord axms) (OrdList.union string_term_ord oras) |
223 (***** proof objects with different levels of detail *****) |
211 | mk_min_proof _ = I; |
|
212 |
|
213 (** proof objects with different levels of detail **) |
|
214 |
|
215 val proofs = ref 2; |
|
216 |
|
217 val min_proof = MinProof ([], [], []); |
|
218 |
224 |
219 fun (prf %> t) = prf % SOME t; |
225 fun (prf %> t) = prf % SOME t; |
220 |
226 |
221 val proof_combt = Library.foldl (op %>); |
227 val proof_combt = Library.foldl (op %>); |
222 val proof_combt' = Library.foldl (op %); |
228 val proof_combt' = Library.foldl (op %); |
1160 fun rewrite_proof thy = rewrite_prf (fn (tyenv, f) => |
1174 fun rewrite_proof thy = rewrite_prf (fn (tyenv, f) => |
1161 Sign.typ_match thy (f ()) tyenv handle Type.TYPE_MATCH => raise PMatch); |
1175 Sign.typ_match thy (f ()) tyenv handle Type.TYPE_MATCH => raise PMatch); |
1162 |
1176 |
1163 fun rewrite_proof_notypes rews = rewrite_prf fst rews; |
1177 fun rewrite_proof_notypes rews = rewrite_prf fst rews; |
1164 |
1178 |
1165 fun fulfill tab = rewrite_proof_notypes |
|
1166 ([], [("Pure/fulfill", K (fn Promise (i, _, _) => Inttab.lookup tab i | _ => NONE))]); |
|
1167 |
|
1168 |
1179 |
1169 (**** theory data ****) |
1180 (**** theory data ****) |
1170 |
1181 |
1171 structure ProofData = TheoryDataFun |
1182 structure ProofData = TheoryDataFun |
1172 ( |
1183 ( |
1173 type T = (proof * proof) list * (string * (typ list -> proof -> proof option)) list; |
1184 type T = (stamp * (proof * proof)) list * (stamp * (typ list -> proof -> proof option)) list; |
1174 |
1185 |
1175 val empty = ([], []); |
1186 val empty = ([], []); |
1176 val copy = I; |
1187 val copy = I; |
1177 val extend = I; |
1188 val extend = I; |
1178 fun merge _ ((rules1, procs1) : T, (rules2, procs2)) = |
1189 fun merge _ ((rules1, procs1), (rules2, procs2)) : T = |
1179 (Library.merge (op =) (rules1, rules2), |
1190 (AList.merge (op =) (K true) (rules1, rules2), |
1180 AList.merge (op =) (K true) (procs1, procs2)); |
1191 AList.merge (op =) (K true) (procs1, procs2)); |
1181 ); |
1192 ); |
1182 |
1193 |
1183 fun rew_proof thy = rewrite_prf fst (ProofData.get thy); |
1194 fun get_data thy = let val (rules, procs) = ProofData.get thy in (map #2 rules, map #2 procs) end; |
1184 |
1195 fun rew_proof thy = rewrite_prf fst (get_data thy); |
1185 fun add_prf_rrule r = (ProofData.map o apfst) (insert (op =) r); |
1196 |
1186 |
1197 fun add_prf_rrule r = (ProofData.map o apfst) (cons (stamp (), r)); |
1187 fun add_prf_rproc p = (ProofData.map o apsnd) (AList.update (op =) p); |
1198 fun add_prf_rproc p = (ProofData.map o apsnd) (cons (stamp (), p)); |
1188 |
1199 |
1189 fun thm_proof thy name hyps prop prf = |
1200 |
1190 let |
1201 (***** theorems *****) |
|
1202 |
|
1203 fun fulfill_proof promises body0 = |
|
1204 let |
|
1205 val tab = Inttab.make promises; |
|
1206 fun fill (Promise (i, _, _)) = Option.map Lazy.force (Inttab.lookup tab i) |
|
1207 | fill _ = NONE; |
|
1208 val PBody {oracles = oracles0, thms = thms0, proof = proof0} = body0; |
|
1209 val proof = proof0 |> rewrite_proof_notypes ([], [K fill]); |
|
1210 val (oracles, thms) = (oracles0, thms0) |
|
1211 |> fold (merge_body o make_body o Lazy.force o #2) promises; |
|
1212 in PBody {oracles = oracles, thms = thms, proof = proof} end; |
|
1213 |
|
1214 fun thm_proof thy name hyps prop promises body = |
|
1215 let |
|
1216 val PBody {oracles = oracles0, thms = thms0, proof = prf} = body; |
1191 val prop = Logic.list_implies (hyps, prop); |
1217 val prop = Logic.list_implies (hyps, prop); |
1192 val nvs = needed_vars prop; |
1218 val nvs = needed_vars prop; |
1193 val args = map (fn (v as Var (ixn, _)) => |
1219 val args = map (fn (v as Var (ixn, _)) => |
1194 if member (op =) nvs ixn then SOME v else NONE) (vars_of prop) @ |
1220 if member (op =) nvs ixn then SOME v else NONE) (vars_of prop) @ |
1195 map SOME (sort Term.term_ord (term_frees prop)); |
1221 map SOME (sort Term.term_ord (term_frees prop)); |
1196 val opt_prf = if ! proofs = 2 then |
1222 |
1197 #4 (shrink_proof thy [] 0 (rewrite_prf fst (ProofData.get thy) |
1223 val proof0 = |
1198 (fold_rev implies_intr_proof hyps prf))) |
1224 if ! proofs = 2 then |
1199 else MinProof (mk_min_proof prf ([], [], [])); |
1225 #4 (shrink_proof thy [] 0 (rew_proof thy (fold_rev implies_intr_proof hyps prf))) |
1200 val head = (case strip_combt (fst (strip_combP prf)) of |
1226 else MinProof; |
1201 (PThm (old_name, prf', prop', NONE), args') => |
1227 |
1202 if (old_name="" orelse old_name=name) andalso |
1228 fun new_prf () = (serial (), ((name, prop, NONE), |
1203 prop = prop' andalso args = args' then |
1229 Lazy.lazy (fn () => |
1204 PThm (name, prf', prop, NONE) |
1230 fulfill_proof promises (PBody {oracles = oracles0, thms = thms0, proof = proof0})))); |
1205 else |
1231 |
1206 PThm (name, opt_prf, prop, NONE) |
1232 val head = |
1207 | _ => PThm (name, opt_prf, prop, NONE)) |
1233 (case strip_combt (fst (strip_combP prf)) of |
|
1234 (PThm (i, ((old_name, prop', NONE), body')), args') => |
|
1235 if (old_name = "" orelse old_name = name) andalso |
|
1236 prop = prop' andalso args = args' |
|
1237 then (i, ((name, prop, NONE), body')) |
|
1238 else new_prf () |
|
1239 | _ => new_prf ()) |
1208 in |
1240 in |
1209 proof_combP (proof_combt' (head, args), map Hyp hyps) |
1241 (head, proof_combP (proof_combt' (PThm head, args), map Hyp hyps)) |
1210 end; |
1242 end; |
1211 |
1243 |
1212 fun get_name hyps prop prf = |
1244 fun get_name hyps prop prf = |
1213 let val prop = Logic.list_implies (hyps, prop) in |
1245 let val prop = Logic.list_implies (hyps, prop) in |
1214 (case strip_combt (fst (strip_combP prf)) of |
1246 (case strip_combt (fst (strip_combP prf)) of |
1215 (PThm (name, _, prop', _), _) => if prop=prop' then name else "" |
1247 (PAxm (name, prop', _), _) => if prop = prop' then name else "" (* FIXME !? *) |
1216 | (PAxm (name, prop', _), _) => if prop=prop' then name else "" |
1248 | (PThm (_, ((name, prop', _), _)), _) => if prop = prop' then name else "" |
1217 | _ => "") |
1249 | _ => "") |
1218 end; |
1250 end; |
1219 |
1251 |
1220 end; |
1252 end; |
1221 |
1253 |