QuotMain.thy
changeset 239 02b14a21761a
parent 236 23f9fead8bd6
child 241 60acf3d3a4a0
--- 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
+