--- a/QuotMain.thy Thu Oct 29 17:35:03 2009 +0100
+++ b/QuotMain.thy Fri Oct 30 11:25:29 2009 +0100
@@ -950,7 +950,46 @@
*}
ML {*
-fun lift_thm lthy consts rty qty rel rel_eqv rel_refl quot rsp_thms trans2 reps_same t_defs t = let
+fun lookup_quot_data lthy qty =
+ let
+ val SOME quotdata = find_first (fn x => #qtyp x = qty) (quotdata_lookup lthy)
+ val rty = #rtyp quotdata
+ val rel = #rel quotdata
+ val rel_eqv = #equiv_thm quotdata
+ val rel_refl_pre = @{thm EQUIV_REFL} OF [rel_eqv]
+ val rel_refl = @{thm spec} OF [MetaSimplifier.rewrite_rule [@{thm REFL_def}] rel_refl_pre]
+ in
+ (rty, rel, rel_refl, rel_eqv)
+ end
+*}
+
+ML {*
+fun lookup_quot_thms lthy qty_name =
+ let
+ val thy = ProofContext.theory_of lthy;
+ val trans2 = PureThy.get_thm thy ("QUOT_TYPE_I_" ^ qty_name ^ ".R_trans2")
+ val reps_same = PureThy.get_thm thy ("QUOT_TYPE_I_" ^ qty_name ^ ".REPS_same")
+ val quot = PureThy.get_thm thy ("QUOTIENT_" ^ qty_name)
+ in
+ (trans2, reps_same, quot)
+ end
+*}
+
+ML {*
+fun lookup_quot_consts defs =
+ let
+ fun dest_term (a $ b) = (a, b);
+ val def_terms = map (snd o Logic.dest_equals o concl_of) defs;
+ in
+ map (fst o dest_Const o snd o dest_term) def_terms
+ end
+*}
+
+ML {*
+fun lift_thm lthy qty qty_name rsp_thms defs t = let
+ val (rty, rel, rel_refl, rel_eqv) = lookup_quot_data lthy qty;
+ val (trans2, reps_same, quot) = lookup_quot_thms lthy qty_name;
+ val consts = lookup_quot_consts defs;
val t_a = atomize_thm t;
val t_r = regularize t_a rty rel rel_eqv lthy;
val t_t = repabs lthy t_r consts rty qty quot rel_refl trans2 rsp_thms;
@@ -958,12 +997,14 @@
val simp_lam_prs_thms = map (make_simp_lam_prs_thm lthy quot) abs;
val t_l = repeat_eqsubst_thm lthy simp_lam_prs_thms t_t;
val t_a = simp_allex_prs lthy quot t_l;
- val t_defs_sym = add_lower_defs lthy t_defs;
- val t_d = repeat_eqsubst_thm lthy t_defs_sym t_a;
+ val defs_sym = add_lower_defs lthy defs;
+ val t_d = repeat_eqsubst_thm lthy defs_sym t_a;
val t_r = MetaSimplifier.rewrite_rule [reps_same] t_d;
in
ObjectLogic.rulify t_r
end
*}
+
end
+