138 (* axiomatization -- within global theory *) |
138 (* axiomatization -- within global theory *) |
139 |
139 |
140 fun gen_axioms do_print prep raw_vars raw_specs thy = |
140 fun gen_axioms do_print prep raw_vars raw_specs thy = |
141 let |
141 let |
142 val ((vars, specs), _) = prep raw_vars [raw_specs] (ProofContext.init thy); |
142 val ((vars, specs), _) = prep raw_vars [raw_specs] (ProofContext.init thy); |
143 val xs = map (fn ((b, T), _) => (Binding.base_name b, T)) vars; |
143 val xs = map (fn ((b, T), _) => (Binding.name_of b, T)) vars; |
144 |
144 |
145 (*consts*) |
145 (*consts*) |
146 val (consts, consts_thy) = thy |> fold_map (Theory.specify_const []) vars; |
146 val (consts, consts_thy) = thy |> fold_map (Theory.specify_const []) vars; |
147 val subst = Term.subst_atomic (map Free xs ~~ consts); |
147 val subst = Term.subst_atomic (map Free xs ~~ consts); |
148 |
148 |
149 (*axioms*) |
149 (*axioms*) |
150 val (axioms, axioms_thy) = consts_thy |> fold_map (fn ((b, atts), props) => |
150 val (axioms, axioms_thy) = consts_thy |> fold_map (fn ((b, atts), props) => |
151 fold_map Thm.add_axiom |
151 fold_map Thm.add_axiom (* FIXME proper use of binding!? *) |
152 ((map o apfst) Binding.name (PureThy.name_multi (Binding.base_name b) (map subst props))) |
152 ((map o apfst) Binding.name (PureThy.name_multi (Binding.name_of b) (map subst props))) |
153 #>> (fn ths => ((b, atts), [(map Drule.standard' ths, [])]))) specs; |
153 #>> (fn ths => ((b, atts), [(map Drule.standard' ths, [])]))) specs; |
154 val (facts, thy') = axioms_thy |> PureThy.note_thmss Thm.axiomK |
154 val (facts, thy') = axioms_thy |> PureThy.note_thmss Thm.axiomK |
155 (Attrib.map_facts (Attrib.attribute_i axioms_thy) axioms); |
155 (Attrib.map_facts (Attrib.attribute_i axioms_thy) axioms); |
156 val _ = |
156 val _ = |
157 if not do_print then () |
157 if not do_print then () |
167 fun gen_def do_print prep (raw_var, (raw_a, raw_prop)) lthy = |
167 fun gen_def do_print prep (raw_var, (raw_a, raw_prop)) lthy = |
168 let |
168 let |
169 val (vars, [((raw_name, atts), [prop])]) = |
169 val (vars, [((raw_name, atts), [prop])]) = |
170 fst (prep (the_list raw_var) [(raw_a, [raw_prop])] lthy); |
170 fst (prep (the_list raw_var) [(raw_a, [raw_prop])] lthy); |
171 val (((x, T), rhs), prove) = LocalDefs.derived_def lthy true prop; |
171 val (((x, T), rhs), prove) = LocalDefs.derived_def lthy true prop; |
172 val name = Binding.map_base (Thm.def_name_optional x) raw_name; |
172 val name = Binding.map_name (Thm.def_name_optional x) raw_name; |
173 val var = |
173 val var = |
174 (case vars of |
174 (case vars of |
175 [] => (Binding.name x, NoSyn) |
175 [] => (Binding.name x, NoSyn) |
176 | [((b, _), mx)] => |
176 | [((b, _), mx)] => |
177 let |
177 let |
178 val y = Binding.base_name b; |
178 val y = Binding.name_of b; |
179 val _ = x = y orelse |
179 val _ = x = y orelse |
180 error ("Head of definition " ^ quote x ^ " differs from declaration " ^ quote y ^ |
180 error ("Head of definition " ^ quote x ^ " differs from declaration " ^ quote y ^ |
181 Position.str_of (Binding.pos_of b)); |
181 Position.str_of (Binding.pos_of b)); |
182 in (b, mx) end); |
182 in (b, mx) end); |
183 val ((lhs, (_, th)), lthy2) = lthy |> LocalTheory.define Thm.definitionK |
183 val ((lhs, (_, th)), lthy2) = lthy |> LocalTheory.define Thm.definitionK |
184 (var, ((Binding.map_base (suffix "_raw") name, []), rhs)); |
184 (var, ((Binding.map_name (suffix "_raw") name, []), rhs)); |
185 val ((def_name, [th']), lthy3) = lthy2 |> LocalTheory.note Thm.definitionK |
185 val ((def_name, [th']), lthy3) = lthy2 |> LocalTheory.note Thm.definitionK |
186 ((name, Code.add_default_eqn_attrib :: atts), [prove lthy2 th]); |
186 ((name, Code.add_default_eqn_attrib :: atts), [prove lthy2 th]); |
187 |
187 |
188 val lhs' = Morphism.term (LocalTheory.target_morphism lthy3) lhs; |
188 val lhs' = Morphism.term (LocalTheory.target_morphism lthy3) lhs; |
189 val _ = |
189 val _ = |
267 val goal_ctxt = fold (fold (Variable.auto_fixes o fst)) propp elems_ctxt; |
267 val goal_ctxt = fold (fold (Variable.auto_fixes o fst)) propp elems_ctxt; |
268 in ((prems, stmt, []), goal_ctxt) end |
268 in ((prems, stmt, []), goal_ctxt) end |
269 | Element.Obtains obtains => |
269 | Element.Obtains obtains => |
270 let |
270 let |
271 val case_names = obtains |> map_index (fn (i, (b, _)) => |
271 val case_names = obtains |> map_index (fn (i, (b, _)) => |
272 let val name = Binding.base_name b |
272 if Binding.is_empty b then string_of_int (i + 1) else Binding.name_of b); |
273 in if name = "" then string_of_int (i + 1) else name end); |
|
274 val constraints = obtains |> map (fn (_, (vars, _)) => |
273 val constraints = obtains |> map (fn (_, (vars, _)) => |
275 Element.Constrains |
274 Element.Constrains |
276 (vars |> map_filter (fn (x, SOME T) => SOME (Binding.base_name x, T) | _ => NONE))); |
275 (vars |> map_filter (fn (x, SOME T) => SOME (Binding.name_of x, T) | _ => NONE))); |
277 |
276 |
278 val raw_propp = obtains |> map (fn (_, (_, props)) => map (rpair []) props); |
277 val raw_propp = obtains |> map (fn (_, (_, props)) => map (rpair []) props); |
279 val (propp, elems_ctxt) = prep_stmt (elems @ constraints) raw_propp ctxt; |
278 val (propp, elems_ctxt) = prep_stmt (elems @ constraints) raw_propp ctxt; |
280 |
279 |
281 val thesis = ObjectLogic.fixed_judgment (ProofContext.theory_of ctxt) AutoBind.thesisN; |
280 val thesis = ObjectLogic.fixed_judgment (ProofContext.theory_of ctxt) AutoBind.thesisN; |
282 |
281 |
283 fun assume_case ((name, (vars, _)), asms) ctxt' = |
282 fun assume_case ((name, (vars, _)), asms) ctxt' = |
284 let |
283 let |
285 val bs = map fst vars; |
284 val bs = map fst vars; |
286 val xs = map Binding.base_name bs; |
285 val xs = map Binding.name_of bs; |
287 val props = map fst asms; |
286 val props = map fst asms; |
288 val (Ts, _) = ctxt' |
287 val (Ts, _) = ctxt' |
289 |> fold Variable.declare_term props |
288 |> fold Variable.declare_term props |
290 |> fold_map ProofContext.inferred_param xs; |
289 |> fold_map ProofContext.inferred_param xs; |
291 val asm = Term.list_all_free (xs ~~ Ts, Logic.list_implies (props, thesis)); |
290 val asm = Term.list_all_free (xs ~~ Ts, Logic.list_implies (props, thesis)); |