Nominal/nominal_dt_quot.ML
changeset 2431 331873ebc5cd
parent 2430 a746d49b0240
child 2432 7aa18bae6983
--- a/Nominal/nominal_dt_quot.ML	Sun Aug 22 14:02:49 2010 +0800
+++ b/Nominal/nominal_dt_quot.ML	Wed Aug 25 09:02:06 2010 +0800
@@ -13,11 +13,11 @@
   val define_qconsts: typ list -> (string  * term * mixfix) list -> local_theory -> 
     Quotient_Info.qconsts_info list * local_theory
 
-  val define_qperms: typ list -> string list -> (string * term * mixfix) list -> 
-    thm list -> local_theory -> local_theory
+  val define_qperms: typ list -> string list -> (string * sort) list -> 
+    (string * term * mixfix) list -> thm list -> local_theory -> local_theory
 
-  val define_qsizes: typ list -> string list -> (string * term * mixfix) list -> 
-    local_theory -> local_theory
+  val define_qsizes: typ list -> string list -> (string * sort) list -> 
+    (string * term * mixfix) list -> local_theory -> local_theory
 
   val lift_thm: Proof.context -> typ list -> thm list -> thm -> thm
 end
@@ -47,46 +47,62 @@
 
 
 (* defines the quotient permutations and proves pt-class *)
-fun define_qperms qtys qfull_ty_names perm_specs raw_perm_laws lthy =
+fun define_qperms qtys qfull_ty_names tvs perm_specs raw_perm_laws lthy =
 let
-  val lthy' = 
+  val _ = tracing ("qtys:\n" ^ cat_lines (map @{make_string} qtys))
+
+  val lthy1 = 
     lthy
     |> Local_Theory.exit_global
-    |> Class.instantiation (qfull_ty_names, [], @{sort pt}) 
+    |> Class.instantiation (qfull_ty_names, tvs, @{sort pt}) 
   
-  val (_, lthy'') = define_qconsts qtys perm_specs lthy'
+  val (qs, lthy2) = define_qconsts qtys perm_specs lthy1
+
+  val ((_, raw_perm_laws'), lthy3) = Variable.importT raw_perm_laws lthy2
 
-  val lifted_perm_laws = map (Quotient_Tacs.lifted lthy'' qtys []) raw_perm_laws
+  val lifted_perm_laws = 
+    map (Quotient_Tacs.lifted lthy3 qtys []) raw_perm_laws'
+    |> Variable.exportT lthy3 lthy2
 
   fun tac _ =
     Class.intro_classes_tac [] THEN
       (ALLGOALS (resolve_tac lifted_perm_laws))
 in
-  lthy''
+  lthy2
   |> Class.prove_instantiation_exit tac 
   |> Named_Target.theory_init
 end
 
 
 (* defines the size functions and proves size-class *)
-fun define_qsizes qtys qfull_ty_names size_specs lthy =
+fun define_qsizes qtys qfull_ty_names tvs size_specs lthy =
 let
   fun tac _ = Class.intro_classes_tac []
 in
   lthy
   |> Local_Theory.exit_global
-  |> Class.instantiation (qfull_ty_names, [], @{sort size})
+  |> Class.instantiation (qfull_ty_names, tvs, @{sort size})
   |> snd o (define_qconsts qtys size_specs)
   |> Class.prove_instantiation_exit tac
   |> Named_Target.theory_init
 end
 
 
-(* lifts a theorem and deletes all "_raw" suffixes *)
+(* lifts a theorem and cleans all "_raw" instances 
+   from variable names *)
 
-fun unraw_str s = 
-  unsuffix "_raw" s
-  handle Fail _ => s
+local
+  val any = Scan.one (Symbol.not_eof)
+  val raw = Scan.this_string "_raw"
+  val exclude =
+    Scan.repeat (Scan.unless raw any) --| raw >> implode
+  val parser = Scan.repeat (exclude || any)
+in
+  fun unraw_str s =
+   s |> explode
+     |> Scan.finite Symbol.stopper parser >> implode 
+     |> fst
+end
 
 fun unraw_vars_thm thm =
 let
@@ -111,6 +127,7 @@
   |> Quotient_Tacs.lifted ctxt qtys simps
   |> unraw_bounds_thm
   |> unraw_vars_thm
+  |> Drule.zero_var_indexes
 
 
 end (* structure *)