diff -r 39ae45d3a11b -r 2b8e387d2dfc Nominal/nominal_eqvt.ML --- a/Nominal/nominal_eqvt.ML Thu Jun 16 23:11:50 2011 +0900 +++ b/Nominal/nominal_eqvt.ML Thu Jun 16 20:07:03 2011 +0100 @@ -8,8 +8,7 @@ signature NOMINAL_EQVT = sig - val raw_equivariance: bool -> term list -> thm -> thm list -> Proof.context -> thm list * local_theory - val equivariance: string -> Proof.context -> (thm list * local_theory) + val raw_equivariance: term list -> thm -> thm list -> Proof.context -> thm list val equivariance_cmd: string -> Proof.context -> local_theory end @@ -75,20 +74,10 @@ (* stores thm under name.eqvt and adds [eqvt]-attribute *) -fun note_named_thm (name, thm) ctxt = - let - val thm_name = Binding.qualified_name - (Long_Name.qualify (Long_Name.base_name name) "eqvt") - val attr = Attrib.internal (K eqvt_add) - val ((_, [thm']), ctxt') = Local_Theory.note ((thm_name, [attr]), [thm]) ctxt - in - (thm', ctxt') - end - fun get_name (Const (a, _)) = a | get_name (Free (a, _)) = a -fun raw_equivariance note_flag pred_trms raw_induct intrs ctxt = +fun raw_equivariance pred_trms raw_induct intrs ctxt = let val is_already_eqvt = filter (is_eqvt ctxt) pred_trms @@ -110,36 +99,34 @@ (HOLogic.dest_conj (HOLogic.dest_Trueprop raw_concl)); val goal = HOLogic.mk_Trueprop - (foldr1 HOLogic.mk_conj (map (prepare_goal pi) preds)) - - val thms = Goal.prove ctxt' [] [] goal + (foldr1 HOLogic.mk_conj (map (prepare_goal pi) preds)) + in + Goal.prove ctxt' [] [] goal (fn {context,...} => eqvt_rel_tac context pred_names pi raw_induct' intrs' 1) |> Datatype_Aux.split_conj_thm |> ProofContext.export ctxt' ctxt |> map (fn th => th RS mp) |> map zero_var_indexes - in - if note_flag - then fold_map note_named_thm (pred_names ~~ thms) ctxt - else (thms, ctxt) end -fun equivariance pred_name ctxt = +fun note_named_thm (name, thm) ctxt = let - val thy = ProofContext.theory_of ctxt - val (_, {preds, raw_induct, intrs, ...}) = - Inductive.the_inductive ctxt (Sign.intern_const thy pred_name) + val thm_name = Binding.qualified_name + (Long_Name.qualify (Long_Name.base_name name) "eqvt") + val attr = Attrib.internal (K eqvt_add) + val ((_, [thm']), ctxt') = Local_Theory.note ((thm_name, [attr]), [thm]) ctxt in - raw_equivariance false preds raw_induct intrs ctxt + (thm', ctxt') end fun equivariance_cmd pred_name ctxt = let val thy = ProofContext.theory_of ctxt - val (_, {preds, raw_induct, intrs, ...}) = + val ({names, ...}, {preds, raw_induct, intrs, ...}) = Inductive.the_inductive ctxt (Sign.intern_const thy pred_name) + val thms = raw_equivariance preds raw_induct intrs ctxt in - raw_equivariance true preds raw_induct intrs ctxt |> snd + fold_map note_named_thm (names ~~ thms) ctxt |> snd end local structure P = Parse and K = Keyword in