89 theorem: thm, |
89 theorem: thm, |
90 tvars: (indexname * sort) list, |
90 tvars: (indexname * sort) list, |
91 schematics: typ list Symtab.table, |
91 schematics: typ list Symtab.table, |
92 initial_round: int } |
92 initial_round: int } |
93 |
93 |
94 fun make_thm_info index initial_round schematics thm = |
|
95 if Symtab.is_empty schematics then Ground thm |
|
96 else Schematic { |
|
97 index = index, |
|
98 theorem = thm, |
|
99 tvars = Term.add_tvars (Thm.prop_of thm) [], |
|
100 schematics = schematics, |
|
101 initial_round = initial_round } |
|
102 |
|
103 fun prepare schematic_consts_of rthms = |
94 fun prepare schematic_consts_of rthms = |
104 let |
95 let |
105 val empty_subst = ((0, false, false), Vartab.empty) |
96 val empty_subst = ((0, false, false), Vartab.empty) |
106 |
97 |
107 fun prep (r, thm) ((i, idx), (consts, substs)) = |
98 fun prep (r, thm) ((i, idx), (consts, substs)) = |
108 let |
99 if not (Term.exists_type typ_has_tvars (Thm.prop_of thm)) then |
109 (* increase indices to avoid clashes of type variables *) |
100 (Ground thm, ((i+1, idx + Thm.maxidx_of thm + 1), (consts, substs))) |
110 val thm' = Thm.incr_indexes idx thm |
101 else |
111 val idx' = Thm.maxidx_of thm' + 1 |
102 let |
112 val schematics = schematic_consts_of (Thm.prop_of thm') |
103 (* increase indices to avoid clashes of type variables *) |
113 val consts' = |
104 val thm' = Thm.incr_indexes idx thm |
114 Symtab.fold (fn (n, _) => Symtab.update (n, [])) schematics consts |
105 val idx' = Thm.maxidx_of thm' + 1 |
115 val substs' = Inttab.update (i, [empty_subst]) substs |
106 val schematics = schematic_consts_of (Thm.prop_of thm') |
116 in |
107 val consts' = |
117 (make_thm_info i r schematics thm', ((i+1, idx'), (consts', substs'))) |
108 Symtab.fold (fn (n, _) => Symtab.update (n, [])) schematics consts |
118 end |
109 val substs' = Inttab.update (i, [empty_subst]) substs |
|
110 val thm_info = Schematic { |
|
111 index = i, |
|
112 theorem = thm', |
|
113 tvars = Term.add_tvars (Thm.prop_of thm') [], |
|
114 schematics = schematics, |
|
115 initial_round = r } |
|
116 in (thm_info, ((i+1, idx'), (consts', substs'))) end |
119 in fold_map prep rthms ((0, 0), (Symtab.empty, Inttab.empty)) ||> snd end |
117 in fold_map prep rthms ((0, 0), (Symtab.empty, Inttab.empty)) ||> snd end |
120 |
118 |
121 |
119 |
122 |
120 |
123 (** collecting substitutions **) |
121 (** collecting substitutions **) |
210 with_grounds new_grounds (with_all_combinations schematics ( |
208 with_grounds new_grounds (with_all_combinations schematics ( |
211 with_partial_substs refine_substs))) |
209 with_partial_substs refine_substs))) |
212 end |
210 end |
213 |
211 |
214 |
212 |
215 fun make_subst_ctxt ctxt thm_infos (known_grounds, substitutions) = |
213 fun make_subst_ctxt ctxt thm_infos known_grounds substitutions = |
216 let |
214 let |
217 val limit = Config.get ctxt max_new_instances |
215 val limit = Config.get ctxt max_new_instances |
218 |
216 |
219 fun add_ground_consts (Ground thm) = collect_instances known_grounds thm |
217 fun add_ground_consts (Ground thm) = collect_instances known_grounds thm |
220 | add_ground_consts (Schematic _) = I |
218 | add_ground_consts (Schematic _) = I |
221 val initial_grounds = fold add_ground_consts thm_infos Symtab.empty |
219 val initial_grounds = fold add_ground_consts thm_infos Symtab.empty |
222 in (thm_infos, (known_grounds, (limit, substitutions, initial_grounds))) end |
220 in (known_grounds, (limit, substitutions, initial_grounds)) end |
223 |
221 |
224 fun with_new round f thm_info = |
222 fun with_new round f thm_info = |
225 (case thm_info of |
223 (case thm_info of |
226 Schematic {index, theorem, tvars, schematics, initial_round} => |
224 Schematic {index, theorem, tvars, schematics, initial_round} => |
227 if initial_round <> round then I |
225 if initial_round <> round then I |
233 Schematic {index, theorem, tvars, schematics, initial_round} => |
231 Schematic {index, theorem, tvars, schematics, initial_round} => |
234 if initial_round < round then I |
232 if initial_round < round then I |
235 else f (round, index, theorem, tvars, schematics) |
233 else f (round, index, theorem, tvars, schematics) |
236 | Ground _ => I) |
234 | Ground _ => I) |
237 |
235 |
238 fun collect_substitutions ctxt round thm_infos (known_grounds, subst_ctxt) = |
236 fun collect_substitutions thm_infos ctxt round (known_grounds, subst_ctxt) = |
239 let val (limit, substitutions, next_grounds) = subst_ctxt |
237 let val (limit, substitutions, next_grounds) = subst_ctxt |
240 in |
238 in |
241 (* |
239 (* |
242 'known_grounds' are all constant names known to occur schematically |
240 'known_grounds' are all constant names known to occur schematically |
243 associated with all ground instances considered so far |
241 associated with all ground instances considered so far |
309 |
307 |
310 |
308 |
311 |
309 |
312 (** overall procedure **) |
310 (** overall procedure **) |
313 |
311 |
314 fun limit_rounds ctxt f thm_infos = |
312 fun limit_rounds ctxt f = |
315 let |
313 let |
316 val max = Config.get ctxt max_rounds |
314 val max = Config.get ctxt max_rounds |
317 |
315 |
318 fun round _ (true, x) = (thm_infos, x) |
316 fun round _ (true, x) = x |
319 | round i (_, x) = |
317 | round i (_, x) = |
320 if i <= max then round (i + 1) (f ctxt i thm_infos x) |
318 if i <= max then round (i + 1) (f ctxt i x) |
321 else ( |
319 else ( |
322 show_info ctxt "Warning: Monomorphization limit reached"; |
320 show_info ctxt "Warning: Monomorphization limit reached"; |
323 (thm_infos, x)) |
321 x) |
324 in round 1 o pair false end |
322 in round 1 o pair false end |
325 |
323 |
326 fun monomorph schematic_consts_of rthms ctxt = |
324 fun monomorph schematic_consts_of rthms ctxt = |
327 rthms |
325 let |
328 |> prepare schematic_consts_of |
326 val (thm_infos, (known_grounds, substitutions)) = |
329 |-> make_subst_ctxt ctxt |
327 prepare schematic_consts_of rthms |
330 |-> limit_rounds ctxt collect_substitutions |
328 in |
331 |-> instantiate_all ctxt |
329 if Symtab.is_empty known_grounds then |
|
330 (map (single o pair 0 o snd) rthms, ctxt) |
|
331 else |
|
332 make_subst_ctxt ctxt thm_infos known_grounds substitutions |
|
333 |> limit_rounds ctxt (collect_substitutions thm_infos) |
|
334 |> instantiate_all ctxt thm_infos |
|
335 end |
|
336 |
332 |
337 |
333 end |
338 end |
334 |
339 |