190 end handle THM _ => |
190 end handle THM _ => |
191 error ("Bad monotonicity theorem:\n" ^ Display.string_of_thm_without_context thm); |
191 error ("Bad monotonicity theorem:\n" ^ Display.string_of_thm_without_context thm); |
192 |
192 |
193 val mono_add = Thm.declaration_attribute (map_monos o Thm.add_thm o mk_mono); |
193 val mono_add = Thm.declaration_attribute (map_monos o Thm.add_thm o mk_mono); |
194 val mono_del = Thm.declaration_attribute (map_monos o Thm.del_thm o mk_mono); |
194 val mono_del = Thm.declaration_attribute (map_monos o Thm.del_thm o mk_mono); |
|
195 |
|
196 |
|
197 |
|
198 (** equations **) |
|
199 |
|
200 structure Equation_Data = Generic_Data |
|
201 ( |
|
202 type T = thm Item_Net.T; |
|
203 val empty = Item_Net.init (op aconv o pairself Thm.prop_of) |
|
204 (single o fst o HOLogic.dest_eq o HOLogic.dest_Trueprop o Thm.prop_of); |
|
205 val extend = I; |
|
206 val merge = Item_Net.merge; |
|
207 ); |
|
208 |
|
209 val add_equation = Thm.declaration_attribute (Equation_Data.map o Item_Net.update) |
195 |
210 |
196 |
211 |
197 |
212 |
198 (** misc utilities **) |
213 (** misc utilities **) |
199 |
214 |
546 |
561 |
547 (* derivation of simplified equation *) |
562 (* derivation of simplified equation *) |
548 |
563 |
549 fun mk_simp_eq ctxt prop = |
564 fun mk_simp_eq ctxt prop = |
550 let |
565 let |
|
566 val thy = ProofContext.theory_of ctxt |
551 val ctxt' = Variable.auto_fixes prop ctxt |
567 val ctxt' = Variable.auto_fixes prop ctxt |
552 val cname = fst (dest_Const (fst (strip_comb (HOLogic.dest_Trueprop prop)))) |
568 val lhs_of = fst o HOLogic.dest_eq o HOLogic.dest_Trueprop o Thm.prop_of |
553 val info = the_inductive ctxt cname |
569 val substs = Item_Net.retrieve (Equation_Data.get (Context.Proof ctxt)) (HOLogic.dest_Trueprop prop) |
554 val eq = nth (#eqs (snd info)) (find_index (fn c => c = cname) (#names (fst info))) |
570 |> map_filter |
555 val lhs_eq = fst (HOLogic.dest_eq (HOLogic.dest_Trueprop (Thm.prop_of eq))) |
571 (fn eq => SOME (Pattern.match thy (lhs_of eq, HOLogic.dest_Trueprop prop) |
556 val subst = Pattern.match (ProofContext.theory_of ctxt) (lhs_eq, HOLogic.dest_Trueprop prop) |
572 (Vartab.empty, Vartab.empty), eq) |
557 (Vartab.empty, Vartab.empty) |
573 handle Pattern.MATCH => NONE) |
558 val certify = cterm_of (ProofContext.theory_of ctxt) |
574 val (subst, eq) = case substs of |
559 val inst = map (fn v => (certify (Var v), certify (Envir.subst_term subst (Var v)))) |
575 [s] => s |
560 (Term.add_vars lhs_eq []) |
576 | _ => error |
|
577 ("equations matching pattern " ^ Syntax.string_of_term ctxt prop ^ " is not unique") |
|
578 val inst = map (fn v => (cterm_of thy (Var v), cterm_of thy (Envir.subst_term subst (Var v)))) |
|
579 (Term.add_vars (lhs_of eq) []) |
561 in |
580 in |
562 cterm_instantiate inst eq |
581 cterm_instantiate inst eq |
563 |> Conv.fconv_rule (Conv.arg_conv (Conv.arg_conv |
582 |> Conv.fconv_rule (Conv.arg_conv (Conv.arg_conv |
564 (Simplifier.full_rewrite (simpset_of ctxt)))) |
583 (Simplifier.full_rewrite (simpset_of ctxt)))) |
565 |> singleton (Variable.export ctxt' ctxt) |
584 |> singleton (Variable.export ctxt' ctxt) |
831 ((rec_qualified true (Binding.name (coind_prefix coind ^ "induct")), |
850 ((rec_qualified true (Binding.name (coind_prefix coind ^ "induct")), |
832 map (Attrib.internal o K) (#2 induct)), [rulify (#1 induct)]); |
851 map (Attrib.internal o K) (#2 induct)), [rulify (#1 induct)]); |
833 |
852 |
834 val (eqs', lthy3) = lthy2 |> |
853 val (eqs', lthy3) = lthy2 |> |
835 fold_map (fn (name, eq) => Local_Theory.note |
854 fold_map (fn (name, eq) => Local_Theory.note |
836 ((Binding.qualify true (Long_Name.base_name name) (Binding.name "simps"), []), [eq]) |
855 ((Binding.qualify true (Long_Name.base_name name) (Binding.name "simps"), |
|
856 [Attrib.internal (K add_equation)]), [eq]) |
837 #> apfst (hd o snd)) |
857 #> apfst (hd o snd)) |
838 (if null eqs then [] else (cnames ~~ eqs)) |
858 (if null eqs then [] else (cnames ~~ eqs)) |
839 val (inducts, lthy4) = |
859 val (inducts, lthy4) = |
840 if no_ind orelse coind then ([], lthy3) |
860 if no_ind orelse coind then ([], lthy3) |
841 else |
861 else |