# HG changeset patch
# User Christian Urban <urbanc@in.tum.de>
# Date 1260191390 -3600
# Node ID 8a1c8dc72b5cfe91950b34ef1cfe31614c6580ae
# Parent  6088fea1c8b1e6aa87d85ae23e4d2694522fc093
directory re-arrangement

diff -r 6088fea1c8b1 -r 8a1c8dc72b5c FSet.thy
--- a/FSet.thy	Mon Dec 07 14:00:36 2009 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,440 +0,0 @@
-theory FSet
-imports QuotMain
-begin
-
-inductive
-  list_eq (infix "\<approx>" 50)
-where
-  "a#b#xs \<approx> b#a#xs"
-| "[] \<approx> []"
-| "xs \<approx> ys \<Longrightarrow> ys \<approx> xs"
-| "a#a#xs \<approx> a#xs"
-| "xs \<approx> ys \<Longrightarrow> a#xs \<approx> a#ys"
-| "\<lbrakk>xs1 \<approx> xs2; xs2 \<approx> xs3\<rbrakk> \<Longrightarrow> xs1 \<approx> xs3"
-
-lemma list_eq_refl:
-  shows "xs \<approx> xs"
-  by (induct xs) (auto intro: list_eq.intros)
-
-lemma equivp_list_eq:
-  shows "equivp list_eq"
-  unfolding equivp_reflp_symp_transp reflp_def symp_def transp_def
-  apply(auto intro: list_eq.intros list_eq_refl)
-  done
-
-quotient fset = "'a list" / "list_eq"
-  apply(rule equivp_list_eq)
-  done
-
-print_theorems
-
-typ "'a fset"
-thm "Rep_fset"
-thm "ABS_fset_def"
-
-quotient_def 
-  EMPTY :: "'a fset"
-where
-  "EMPTY \<equiv> ([]::'a list)"
-
-term Nil
-term EMPTY
-thm EMPTY_def
-
-quotient_def 
-  INSERT :: "'a \<Rightarrow> 'a fset \<Rightarrow> 'a fset"
-where
-  "INSERT \<equiv> op #"
-
-term Cons
-term INSERT
-thm INSERT_def
-
-quotient_def 
-  FUNION :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> 'a fset"
-where
-  "FUNION \<equiv> (op @)"
-
-term append
-term FUNION
-thm FUNION_def
-
-thm Quotient_fset
-
-thm QUOT_TYPE_I_fset.thm11
-
-
-fun
-  membship :: "'a \<Rightarrow> 'a list \<Rightarrow> bool" (infix "memb" 100)
-where
-  m1: "(x memb []) = False"
-| m2: "(x memb (y#xs)) = ((x=y) \<or> (x memb xs))"
-
-fun
-  card1 :: "'a list \<Rightarrow> nat"
-where
-  card1_nil: "(card1 []) = 0"
-| card1_cons: "(card1 (x # xs)) = (if (x memb xs) then (card1 xs) else (Suc (card1 xs)))"
-
-quotient_def 
-  CARD :: "'a fset \<Rightarrow> nat"
-where
-  "CARD \<equiv> card1"
-
-term card1
-term CARD
-thm CARD_def
-
-(* text {*
- Maybe make_const_def should require a theorem that says that the particular lifted function
- respects the relation. With it such a definition would be impossible:
- make_const_def @{binding CARD} @{term "length"} NoSyn @{typ "'a list"} @{typ "'a fset"} #> snd
-*}*)
-
-lemma card1_0:
-  fixes a :: "'a list"
-  shows "(card1 a = 0) = (a = [])"
-  by (induct a) auto
-
-lemma not_mem_card1:
-  fixes x :: "'a"
-  fixes xs :: "'a list"
-  shows "(~(x memb xs)) = (card1 (x # xs) = Suc (card1 xs))"
-  by auto
-
-lemma mem_cons:
-  fixes x :: "'a"
-  fixes xs :: "'a list"
-  assumes a : "x memb xs"
-  shows "x # xs \<approx> xs"
-  using a by (induct xs) (auto intro: list_eq.intros )
-
-lemma card1_suc:
-  fixes xs :: "'a list"
-  fixes n :: "nat"
-  assumes c: "card1 xs = Suc n"
-  shows "\<exists>a ys. ~(a memb ys) \<and> xs \<approx> (a # ys)"
-  using c
-apply(induct xs)
-apply (metis Suc_neq_Zero card1_0)
-apply (metis QUOT_TYPE_I_fset.R_trans card1_cons list_eq_refl mem_cons)
-done
-
-definition
-  rsp_fold
-where
-  "rsp_fold f = ((!u v. (f u v = f v u)) \<and> (!u v w. ((f u (f v w) = f (f u v) w))))"
-
-primrec
-  fold1
-where
-  "fold1 f (g :: 'a \<Rightarrow> 'b) (z :: 'b) [] = z"
-| "fold1 f g z (a # A) =
-     (if rsp_fold f
-     then (
-       if (a memb A) then (fold1 f g z A) else (f (g a) (fold1 f g z A))
-     ) else z)"
-
-lemma fs1_strong_cases:
-  fixes X :: "'a list"
-  shows "(X = []) \<or> (\<exists>a. \<exists> Y. (~(a memb Y) \<and> (X \<approx> a # Y)))"
-  apply (induct X)
-  apply (simp)
-  apply (metis QUOT_TYPE_I_fset.thm11 list_eq_refl mem_cons m1)
-  done
-
-quotient_def
-  IN :: "'a \<Rightarrow> 'a fset \<Rightarrow> bool"
-where
-  "IN \<equiv> membship"
-
-term membship
-term IN
-thm IN_def
-
-term fold1
-quotient_def 
-  FOLD :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'b fset \<Rightarrow> 'a"
-where
-  "FOLD \<equiv> fold1"
-
-term fold1
-term fold
-thm fold_def
-
-quotient_def 
-  fmap::"('a \<Rightarrow> 'b) \<Rightarrow> 'a fset \<Rightarrow> 'b fset"
-where
-  "fmap \<equiv> map"
-
-term map
-term fmap
-thm fmap_def
-
-lemma memb_rsp:
-  fixes z
-  assumes a: "x \<approx> y"
-  shows "(z memb x) = (z memb y)"
-  using a by induct auto
-
-lemma ho_memb_rsp[quotient_rsp]:
-  "(op = ===> (op \<approx> ===> op =)) (op memb) (op memb)"
-  by (simp add: memb_rsp)
-
-lemma card1_rsp:
-  fixes a b :: "'a list"
-  assumes e: "a \<approx> b"
-  shows "card1 a = card1 b"
-  using e by induct (simp_all add:memb_rsp)
-
-lemma ho_card1_rsp[quotient_rsp]: 
-  "(op \<approx> ===> op =) card1 card1"
-  by (simp add: card1_rsp)
-
-lemma cons_rsp[quotient_rsp]:
-  fixes z
-  assumes a: "xs \<approx> ys"
-  shows "(z # xs) \<approx> (z # ys)"
-  using a by (rule list_eq.intros(5))
-
-lemma ho_cons_rsp[quotient_rsp]:
-  "(op = ===> op \<approx> ===> op \<approx>) op # op #"
-  by (simp add: cons_rsp)
-
-lemma append_rsp_fst:
-  assumes a : "l1 \<approx> l2"
-  shows "(l1 @ s) \<approx> (l2 @ s)"
-  using a
-  by (induct) (auto intro: list_eq.intros list_eq_refl)
-
-lemma append_end:
-  shows "(e # l) \<approx> (l @ [e])"
-  apply (induct l)
-  apply (auto intro: list_eq.intros list_eq_refl)
-  done
-
-lemma rev_rsp:
-  shows "a \<approx> rev a"
-  apply (induct a)
-  apply simp
-  apply (rule list_eq_refl)
-  apply simp_all
-  apply (rule list_eq.intros(6))
-  prefer 2
-  apply (rule append_rsp_fst)
-  apply assumption
-  apply (rule append_end)
-  done
-
-lemma append_sym_rsp:
-  shows "(a @ b) \<approx> (b @ a)"
-  apply (rule list_eq.intros(6))
-  apply (rule append_rsp_fst)
-  apply (rule rev_rsp)
-  apply (rule list_eq.intros(6))
-  apply (rule rev_rsp)
-  apply (simp)
-  apply (rule append_rsp_fst)
-  apply (rule list_eq.intros(3))
-  apply (rule rev_rsp)
-  done
-
-lemma append_rsp:
-  assumes a : "l1 \<approx> r1"
-  assumes b : "l2 \<approx> r2 "
-  shows "(l1 @ l2) \<approx> (r1 @ r2)"
-  apply (rule list_eq.intros(6))
-  apply (rule append_rsp_fst)
-  using a apply (assumption)
-  apply (rule list_eq.intros(6))
-  apply (rule append_sym_rsp)
-  apply (rule list_eq.intros(6))
-  apply (rule append_rsp_fst)
-  using b apply (assumption)
-  apply (rule append_sym_rsp)
-  done
-
-lemma ho_append_rsp[quotient_rsp]:
-  "(op \<approx> ===> op \<approx> ===> op \<approx>) op @ op @"
-  by (simp add: append_rsp)
-
-lemma map_rsp:
-  assumes a: "a \<approx> b"
-  shows "map f a \<approx> map f b"
-  using a
-  apply (induct)
-  apply(auto intro: list_eq.intros)
-  done
-
-lemma ho_map_rsp[quotient_rsp]:
-  "(op = ===> op \<approx> ===> op \<approx>) map map"
-  by (simp add: map_rsp)
-
-lemma map_append:
-  "(map f (a @ b)) \<approx> (map f a) @ (map f b)"
- by simp (rule list_eq_refl)
-
-lemma ho_fold_rsp[quotient_rsp]:
-  "(op = ===> op = ===> op = ===> op \<approx> ===> op =) fold1 fold1"
-  apply (auto)
-  apply (case_tac "rsp_fold x")
-  prefer 2
-  apply (erule_tac list_eq.induct)
-  apply (simp_all)
-  apply (erule_tac list_eq.induct)
-  apply (simp_all)
-  apply (auto simp add: memb_rsp rsp_fold_def)
-done
-
-lemma list_equiv_rsp[quotient_rsp]:
-  shows "(op \<approx> ===> op \<approx> ===> op =) op \<approx> op \<approx>"
-by (auto intro: list_eq.intros)
-
-print_quotients
-
-ML {* val qty = @{typ "'a fset"} *}
-ML {* val rsp_thms =
-  @{thms ho_memb_rsp ho_cons_rsp ho_card1_rsp ho_map_rsp ho_append_rsp ho_fold_rsp} *}
-
-ML {* val (rty, rel, rel_refl, rel_eqv) = lookup_quot_data @{context} qty *}
-ML {* val (trans2, reps_same, absrep, quot) = lookup_quot_thms @{context} "fset"; *}
-ML {* fun lift_tac_fset lthy t = lift_tac lthy t *}
-
-lemma "IN x EMPTY = False"
-apply(tactic {* procedure_tac @{context} @{thm m1} 1 *})
-apply(tactic {* regularize_tac @{context} 1 *})
-apply(tactic {* all_inj_repabs_tac @{context} [rel_refl] [trans2] 1 *})
-apply(tactic {* clean_tac @{context} 1*})
-done
-
-lemma "IN x (INSERT y xa) = (x = y \<or> IN x xa)"
-by (tactic {* lift_tac_fset @{context} @{thm m2} 1 *})
-
-lemma "INSERT a (INSERT a x) = INSERT a x"
-apply (tactic {* lift_tac_fset @{context} @{thm list_eq.intros(4)} 1 *})
-done
-
-lemma "x = xa \<Longrightarrow> INSERT a x = INSERT a xa"
-apply (tactic {* lift_tac_fset @{context} @{thm list_eq.intros(5)} 1 *})
-done
-
-lemma "CARD x = Suc n \<Longrightarrow> (\<exists>a b. \<not> IN a b & x = INSERT a b)"
-apply (tactic {* lift_tac_fset @{context} @{thm card1_suc} 1 *})
-done
-
-lemma "(\<not> IN x xa) = (CARD (INSERT x xa) = Suc (CARD xa))"
-apply (tactic {* lift_tac_fset @{context} @{thm not_mem_card1} 1 *})
-done
-
-lemma "FOLD f g (z::'b) (INSERT a x) =
-  (if rsp_fold f then if IN a x then FOLD f g z x else f (g a) (FOLD f g z x) else z)"
-apply(tactic {* lift_tac_fset @{context} @{thm fold1.simps(2)} 1 *})
-done
-
-ML {* fun inj_repabs_tac_fset lthy = inj_repabs_tac lthy [rel_refl] [trans2] *}
-
-lemma "fmap f (FUNION (x::'b fset) (xa::'b fset)) = FUNION (fmap f x) (fmap f xa)"
-apply (tactic {* lift_tac_fset @{context} @{thm map_append} 1 *})
-done
-
-lemma "FUNION (FUNION x xa) xb = FUNION x (FUNION xa xb)"
-apply (tactic {* lift_tac_fset @{context} @{thm append_assoc} 1 *})
-done
-
-
-lemma "\<lbrakk>P EMPTY; \<And>a x. P x \<Longrightarrow> P (INSERT a x)\<rbrakk> \<Longrightarrow> P l"
-apply (tactic {* (ObjectLogic.full_atomize_tac THEN' gen_frees_tac @{context}) 1 *})
-apply(tactic {* procedure_tac @{context} @{thm list.induct} 1 *})
-apply(tactic {* regularize_tac @{context} 1 *})
-defer
-apply(tactic {* clean_tac @{context} 1 *})
-apply(tactic {* inj_repabs_tac_fset @{context} 1*})+
-done
-
-lemma list_induct_part:
-  assumes a: "P (x :: 'a list) ([] :: 'c list)"
-  assumes b: "\<And>e t. P x t \<Longrightarrow> P x (e # t)"
-  shows "P x l"
-  apply (rule_tac P="P x" in list.induct)
-  apply (rule a)
-  apply (rule b)
-  apply (assumption)
-  done
-
-ML {* quot *}
-thm quotient_thm
-
-lemma "P (x :: 'a list) (EMPTY :: 'c fset) \<Longrightarrow> (\<And>e t. P x t \<Longrightarrow> P x (INSERT e t)) \<Longrightarrow> P x l"
-apply (tactic {* lift_tac_fset @{context} @{thm list_induct_part} 1 *})
-done
-
-lemma "P (x :: 'a fset) (EMPTY :: 'c fset) \<Longrightarrow> (\<And>e t. P x t \<Longrightarrow> P x (INSERT e t)) \<Longrightarrow> P x l"
-apply (tactic {* lift_tac_fset @{context} @{thm list_induct_part} 1 *})
-done
-
-lemma "P (x :: 'a fset) ([] :: 'c list) \<Longrightarrow> (\<And>e t. P x t \<Longrightarrow> P x (e # t)) \<Longrightarrow> P x l"
-apply (tactic {* lift_tac_fset @{context} @{thm list_induct_part} 1 *})
-done
-
-quotient fset2 = "'a list" / "list_eq"
-  apply(rule equivp_list_eq)
-  done
-
-quotient_def
-  EMPTY2 :: "'a fset2"
-where
-  "EMPTY2 \<equiv> ([]::'a list)"
-
-quotient_def
-  INSERT2 :: "'a \<Rightarrow> 'a fset2 \<Rightarrow> 'a fset2"
-where
-  "INSERT2 \<equiv> op #"
-
-ML {* val quot = @{thms Quotient_fset Quotient_fset2} *}
-ML {* fun inj_repabs_tac_fset lthy = inj_repabs_tac lthy [rel_refl] [trans2] *}
-ML {* fun lift_tac_fset lthy t = lift_tac lthy t  *}
-
-lemma "P (x :: 'a fset2) (EMPTY :: 'c fset) \<Longrightarrow> (\<And>e t. P x t \<Longrightarrow> P x (INSERT e t)) \<Longrightarrow> P x l"
-apply (tactic {* lift_tac_fset @{context} @{thm list_induct_part} 1 *})
-done
-
-lemma "P (x :: 'a fset) (EMPTY2 :: 'c fset2) \<Longrightarrow> (\<And>e t. P x t \<Longrightarrow> P x (INSERT2 e t)) \<Longrightarrow> P x l"
-apply (tactic {* lift_tac_fset @{context} @{thm list_induct_part} 1 *})
-done
-
-quotient_def
-  fset_rec::"'a \<Rightarrow> ('b \<Rightarrow> 'b fset \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'b fset \<Rightarrow> 'a"
-where
-  "fset_rec \<equiv> list_rec"
-
-quotient_def
-  fset_case::"'a \<Rightarrow> ('b \<Rightarrow> 'b fset \<Rightarrow> 'a) \<Rightarrow> 'b fset \<Rightarrow> 'a"
-where
-  "fset_case \<equiv> list_case"
-
-(* Probably not true without additional assumptions about the function *)
-lemma list_rec_rsp[quotient_rsp]:
-  "(op = ===> (op = ===> op \<approx> ===> op =) ===> op \<approx> ===> op =) list_rec list_rec"
-  apply (auto)
-  apply (erule_tac list_eq.induct)
-  apply (simp_all)
-  sorry
-
-lemma list_case_rsp[quotient_rsp]:
-  "(op = ===> (op = ===> op \<approx> ===> op =) ===> op \<approx> ===> op =) list_case list_case"
-  apply (auto)
-  sorry
-
-ML {* val rsp_thms = @{thms list_rec_rsp list_case_rsp} @ rsp_thms *}
-ML {* fun lift_tac_fset lthy t = lift_tac lthy t *}
-
-lemma "fset_rec (f1::'t) x (INSERT a xa) = x a xa (fset_rec f1 x xa)"
-apply (tactic {* lift_tac_fset @{context} @{thm list.recs(2)} 1 *})
-done
-
-lemma "fset_case (f1::'t) f2 (INSERT a xa) = f2 a xa"
-apply (tactic {* lift_tac_fset @{context} @{thm list.cases(2)} 1 *})
-done
-
-
-end
diff -r 6088fea1c8b1 -r 8a1c8dc72b5c IntEx.thy
--- a/IntEx.thy	Mon Dec 07 14:00:36 2009 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,276 +0,0 @@
-theory IntEx
-imports QuotMain
-begin
-
-fun
-  intrel :: "(nat \<times> nat) \<Rightarrow> (nat \<times> nat) \<Rightarrow> bool" (infix "\<approx>" 50)
-where
-  "intrel (x, y) (u, v) = (x + v = u + y)"
-
-quotient my_int = "nat \<times> nat" / intrel
-  apply(unfold equivp_def)
-  apply(auto simp add: mem_def expand_fun_eq)
-  done
-
-thm quotient_equiv
-
-thm quotient_thm
-
-thm my_int_equivp
-
-print_theorems
-print_quotients
-
-quotient_def 
-  ZERO::"my_int"
-where
-  "ZERO \<equiv> (0::nat, 0::nat)"
-
-ML {* print_qconstinfo @{context} *}
-
-term ZERO
-thm ZERO_def
-
-ML {* prop_of @{thm ZERO_def} *}
-
-ML {* separate *}
-
-quotient_def 
-  ONE::"my_int"
-where
-  "ONE \<equiv> (1::nat, 0::nat)"
-
-ML {* print_qconstinfo @{context} *}
-
-term ONE
-thm ONE_def
-
-fun
-  my_plus :: "(nat \<times> nat) \<Rightarrow> (nat \<times> nat) \<Rightarrow> (nat \<times> nat)"
-where
-  "my_plus (x, y) (u, v) = (x + u, y + v)"
-
-quotient_def 
-  PLUS::"my_int \<Rightarrow> my_int \<Rightarrow> my_int"
-where
-  "PLUS \<equiv> my_plus"
-
-term my_plus
-term PLUS
-thm PLUS_def
-
-fun
-  my_neg :: "(nat \<times> nat) \<Rightarrow> (nat \<times> nat)"
-where
-  "my_neg (x, y) = (y, x)"
-
-quotient_def 
-  NEG::"my_int \<Rightarrow> my_int"
-where
-  "NEG \<equiv> my_neg"
-
-term NEG
-thm NEG_def
-
-definition
-  MINUS :: "my_int \<Rightarrow> my_int \<Rightarrow> my_int"
-where
-  "MINUS z w = PLUS z (NEG w)"
-
-fun
-  my_mult :: "(nat \<times> nat) \<Rightarrow> (nat \<times> nat) \<Rightarrow> (nat \<times> nat)"
-where
-  "my_mult (x, y) (u, v) = (x*u + y*v, x*v + y*u)"
-
-quotient_def 
-  MULT::"my_int \<Rightarrow> my_int \<Rightarrow> my_int"
-where
-  "MULT \<equiv> my_mult"
-
-term MULT
-thm MULT_def
-
-(* NOT SURE WETHER THIS DEFINITION IS CORRECT *)
-fun
-  my_le :: "(nat \<times> nat) \<Rightarrow> (nat \<times> nat) \<Rightarrow> bool"
-where
-  "my_le (x, y) (u, v) = (x+v \<le> u+y)"
-
-quotient_def 
-  LE :: "my_int \<Rightarrow> my_int \<Rightarrow> bool"
-where
-  "LE \<equiv> my_le"
-
-term LE
-thm LE_def
-
-
-definition
-  LESS :: "my_int \<Rightarrow> my_int \<Rightarrow> bool"
-where
-  "LESS z w = (LE z w \<and> z \<noteq> w)"
-
-term LESS
-thm LESS_def
-
-definition
-  ABS :: "my_int \<Rightarrow> my_int"
-where
-  "ABS i = (if (LESS i ZERO) then (NEG i) else i)"
-
-definition
-  SIGN :: "my_int \<Rightarrow> my_int"
-where
- "SIGN i = (if i = ZERO then ZERO else if (LESS ZERO i) then ONE else (NEG ONE))"
-
-ML {* print_qconstinfo @{context} *}
-
-lemma plus_sym_pre:
-  shows "my_plus a b \<approx> my_plus b a"
-  apply(cases a)
-  apply(cases b)
-  apply(auto)
-  done
-
-lemma plus_rsp[quotient_rsp]:
-  shows "(intrel ===> intrel ===> intrel) my_plus my_plus"
-by (simp)
-
-ML {* val qty = @{typ "my_int"} *}
-ML {* val (rty, rel, rel_refl, rel_eqv) = lookup_quot_data @{context} qty *}
-ML {* val (trans2, reps_same, absrep, quot) = lookup_quot_thms @{context} "my_int"; *}
-
-ML {* fun lift_tac_intex lthy t = lift_tac lthy t *}
-
-ML {* fun inj_repabs_tac_intex lthy = inj_repabs_tac lthy [rel_refl] [trans2] *}
-ML {* fun all_inj_repabs_tac_intex lthy = all_inj_repabs_tac lthy [rel_refl] [trans2] *}
-
-lemma test1: "my_plus a b = my_plus a b"
-apply(rule refl)
-done
-
-lemma "PLUS a b = PLUS a b"
-apply(tactic {* procedure_tac @{context} @{thm test1} 1 *})
-apply(tactic {* regularize_tac @{context} 1 *})
-apply(tactic {* all_inj_repabs_tac_intex @{context} 1*})
-apply(tactic {* clean_tac @{context} 1 *}) 
-done
-
-thm lambda_prs
-
-lemma test2: "my_plus a = my_plus a"
-apply(rule refl)
-done
-
-lemma "PLUS a = PLUS a"
-apply(tactic {* procedure_tac @{context} @{thm test2} 1 *})
-apply(rule ballI)
-apply(rule apply_rsp[OF Quotient_my_int plus_rsp])
-apply(simp only: in_respects)
-apply(tactic {* all_inj_repabs_tac_intex @{context} 1*})
-apply(tactic {* clean_tac @{context} 1 *})
-done
-
-lemma test3: "my_plus = my_plus"
-apply(rule refl)
-done
-
-lemma "PLUS = PLUS"
-apply(tactic {* procedure_tac @{context} @{thm test3} 1 *})
-apply(rule plus_rsp)
-apply(tactic {* all_inj_repabs_tac_intex @{context} 1*})
-apply(tactic {* clean_tac @{context} 1 *})
-done
-
-
-lemma "PLUS a b = PLUS b a"
-apply(tactic {* procedure_tac @{context} @{thm plus_sym_pre} 1 *})
-apply(tactic {* regularize_tac @{context} 1 *})
-apply(tactic {* all_inj_repabs_tac_intex @{context} 1*})
-apply(tactic {* clean_tac @{context} 1 *})
-done
-
-lemma plus_assoc_pre:
-  shows "my_plus (my_plus i j) k \<approx> my_plus i (my_plus j k)"
-  apply (cases i)
-  apply (cases j)
-  apply (cases k)
-  apply (simp)
-  done
-
-lemma plus_assoc: "PLUS (PLUS x xa) xb = PLUS x (PLUS xa xb)"
-apply(tactic {* procedure_tac @{context} @{thm plus_assoc_pre} 1 *})
-apply(tactic {* regularize_tac @{context} 1 *})
-apply(tactic {* all_inj_repabs_tac_intex @{context} 1*})
-apply(tactic {* clean_tac @{context} 1 *})
-done
-
-lemma ho_tst: "foldl my_plus x [] = x"
-apply simp
-done
-
-lemma "foldl PLUS x [] = x"
-apply(tactic {* procedure_tac @{context} @{thm ho_tst} 1 *})
-apply(tactic {* regularize_tac @{context} 1 *})
-apply(tactic {* all_inj_repabs_tac_intex @{context} 1*})
-apply(tactic {* clean_tac @{context} 1 *})
-apply(simp only: foldl_prs[OF Quotient_my_int Quotient_my_int] nil_prs[OF Quotient_my_int])
-done
-
-lemma ho_tst2: "foldl my_plus x (h # t) \<approx> my_plus h (foldl my_plus x t)"
-sorry
-
-lemma "foldl PLUS x (h # t) = PLUS h (foldl PLUS x t)"
-apply(tactic {* procedure_tac @{context} @{thm ho_tst2} 1 *})
-apply(tactic {* regularize_tac @{context} 1 *})
-apply(tactic {* all_inj_repabs_tac_intex @{context} 1*})
-apply(tactic {* clean_tac @{context} 1 *})
-apply(simp only: foldl_prs[OF Quotient_my_int Quotient_my_int] cons_prs[OF Quotient_my_int])
-done
-
-lemma ho_tst3: "foldl f (s::nat \<times> nat) ([]::(nat \<times> nat) list) = s"
-by simp
-
-lemma "foldl f (x::my_int) ([]::my_int list) = x"
-apply(tactic {* procedure_tac @{context} @{thm ho_tst3} 1 *})
-apply(tactic {* regularize_tac @{context} 1 *})
-apply(tactic {* all_inj_repabs_tac_intex @{context} 1*})
-(* TODO: does not work when this is added *)
-(* apply(tactic {* lambda_prs_tac @{context} 1 *})*)
-apply(tactic {* clean_tac @{context} 1 *})
-apply(simp only: foldl_prs[OF Quotient_my_int Quotient_my_int] nil_prs[OF Quotient_my_int])
-done
-
-lemma lam_tst: "(\<lambda>x. (x, x)) y = (y, (y :: nat \<times> nat))"
-by simp
-
-lemma "(\<lambda>x. (x, x)) (y::my_int) = (y, y)"
-apply(tactic {* procedure_tac @{context} @{thm lam_tst} 1 *})
-apply(tactic {* regularize_tac @{context} 1 *})
-apply(tactic {* all_inj_repabs_tac_intex @{context} 1*})
-apply(tactic {* clean_tac @{context} 1 *})
-apply(simp add: pair_prs)
-done
-
-lemma lam_tst2: "(\<lambda>(y :: nat \<times> nat). y) = (\<lambda>(x :: nat \<times> nat). x)"
-by simp
-
-
-
-
-lemma "(\<lambda>(y :: my_int). y) = (\<lambda>(x :: my_int). x)"
-apply(tactic {* procedure_tac @{context} @{thm lam_tst2} 1 *})
-defer
-apply(tactic {* all_inj_repabs_tac_intex @{context} 1*})
-(*apply(tactic {* lambda_prs_tac  @{context} 1 *})*)
-sorry
-
-lemma lam_tst3: "(\<lambda>(y :: nat \<times> nat \<Rightarrow> nat \<times> nat). y) = (\<lambda>(x :: nat \<times> nat \<Rightarrow> nat \<times> nat). x)"
-by auto
-
-lemma "(\<lambda>(y :: my_int \<Rightarrow> my_int). y) = (\<lambda>(x :: my_int \<Rightarrow> my_int). x)"
-apply(tactic {* procedure_tac @{context} @{thm lam_tst3} 1 *})
-defer
-apply(tactic {* all_inj_repabs_tac_intex @{context} 1*})
-apply(tactic {* lambda_prs_tac  @{context} 1 *})
-sorry
diff -r 6088fea1c8b1 -r 8a1c8dc72b5c IntEx2.thy
--- a/IntEx2.thy	Mon Dec 07 14:00:36 2009 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,436 +0,0 @@
-theory IntEx2
-imports QuotMain
-uses
-  ("Tools/numeral.ML")
-  ("Tools/numeral_syntax.ML")
-  ("Tools/int_arith.ML")
-begin
-
-
-fun
-  intrel :: "(nat \<times> nat) \<Rightarrow> (nat \<times> nat) \<Rightarrow> bool" (infix "\<approx>" 50)
-where
-  "intrel (x, y) (u, v) = (x + v = u + y)"
-
-quotient int = "nat \<times> nat" / intrel
-  apply(unfold equivp_def)
-  apply(auto simp add: mem_def expand_fun_eq)
-  done
-
-instantiation int :: "{zero, one, plus, minus, uminus, times, ord, abs, sgn}"
-begin
-
-quotient_def 
-  zero_qnt::"int"
-where
-  "zero_qnt \<equiv> (0::nat, 0::nat)"
-
-definition  Zero_int_def[code del]: 
-  "0 = zero_qnt"
-
-quotient_def 
-  one_qnt::"int"
-where
-  "one_qnt \<equiv> (1::nat, 0::nat)"
-
-definition One_int_def[code del]:
-  "1 = one_qnt"
-
-fun
-  plus_raw :: "(nat \<times> nat) \<Rightarrow> (nat \<times> nat) \<Rightarrow> (nat \<times> nat)"
-where
-  "plus_raw (x, y) (u, v) = (x + u, y + v)"
-
-quotient_def 
-  plus_qnt::"int \<Rightarrow> int \<Rightarrow> int"
-where
-  "plus_qnt \<equiv> plus_raw"
-
-definition add_int_def[code del]:
-  "z + w = plus_qnt z w"
-
-fun
-  minus_raw :: "(nat \<times> nat) \<Rightarrow> (nat \<times> nat)"
-where
-  "minus_raw (x, y) = (y, x)"
-
-quotient_def
-  minus_qnt::"int \<Rightarrow> int"
-where
-  "minus_qnt \<equiv> minus_raw"
-
-definition minus_int_def [code del]:
-    "- z = minus_qnt z"
-
-definition
-  diff_int_def [code del]:  "z - w = z + (-w::int)"
-
-fun
-  mult_raw :: "(nat \<times> nat) \<Rightarrow> (nat \<times> nat) \<Rightarrow> (nat \<times> nat)"
-where
-  "mult_raw (x, y) (u, v) = (x*u + y*v, x*v + y*u)"
-
-quotient_def 
-  mult_qnt::"int \<Rightarrow> int \<Rightarrow> int"
-where
-  "mult_qnt \<equiv> mult_raw"
-
-definition
-  mult_int_def [code del]: "z * w = mult_qnt z w"
-
-fun
-  le_raw :: "(nat \<times> nat) \<Rightarrow> (nat \<times> nat) \<Rightarrow> bool"
-where
-  "le_raw (x, y) (u, v) = (x+v \<le> u+y)"
-
-quotient_def 
-  le_qnt :: "int \<Rightarrow> int \<Rightarrow> bool"
-where
-  "le_qnt \<equiv> le_raw"
-
-definition
-  le_int_def [code del]:
-   "z \<le> w = le_qnt z w"
-
-definition
-  less_int_def [code del]: "(z\<Colon>int) < w = (z \<le> w \<and> z \<noteq> w)"
-
-definition
-  zabs_def: "\<bar>i\<Colon>int\<bar> = (if i < 0 then - i else i)"
-
-definition
-  zsgn_def: "sgn (i\<Colon>int) = (if i=0 then 0 else if 0<i then 1 else - 1)"
-
-instance ..
-
-end
-
-thm add_assoc
-
-lemma plus_raw_rsp[quotient_rsp]:
-  shows "(op \<approx> ===> op \<approx> ===> op \<approx>) plus_raw plus_raw"
-by auto
-
-lemma minus_raw_rsp[quotient_rsp]:
-  shows "(op \<approx> ===> op \<approx>) minus_raw minus_raw"
-  by auto
-
-lemma mult_raw_rsp[quotient_rsp]:
-  shows "(op \<approx> ===> op \<approx> ===> op \<approx>) mult_raw mult_raw"
-apply(auto)
-apply(simp add: mult algebra_simps)
-sorry
-
-lemma le_raw_rsp[quotient_rsp]:
-  shows "(op \<approx> ===> op \<approx> ===> op =) le_raw le_raw"
-by auto
-
-lemma plus_assoc_raw:
-  shows "plus_raw (plus_raw i j) k \<approx> plus_raw i (plus_raw j k)"
-by (cases i, cases j, cases k) (simp)
-
-lemma plus_sym_raw:
-  shows "plus_raw i j \<approx> plus_raw j i"
-by (cases i, cases j) (simp)
-
-lemma plus_zero_raw:
-  shows "plus_raw  (0, 0) i \<approx> i"
-by (cases i) (simp)
-
-lemma plus_minus_zero_raw:
-  shows "plus_raw (minus_raw i) i \<approx> (0, 0)"
-by (cases i) (simp)
-
-lemma mult_assoc_raw:
-  shows "mult_raw (mult_raw i j) k \<approx> mult_raw i (mult_raw j k)"
-by (cases i, cases j, cases k) 
-   (simp add: mult algebra_simps)
-
-lemma mult_sym_raw:
-  shows "mult_raw i j \<approx> mult_raw j i"
-by (cases i, cases j) (simp)
-
-lemma mult_one_raw:
-  shows "mult_raw  (1, 0) i \<approx> i"
-by (cases i) (simp)
-
-lemma mult_plus_comm_raw:
-  shows "mult_raw (plus_raw i j) k \<approx> plus_raw (mult_raw i k) (mult_raw j k)"
-by (cases i, cases j, cases k) 
-   (simp add: mult algebra_simps)
-
-lemma one_zero_distinct:
-  shows "\<not> (0, 0) \<approx> ((1::nat), (0::nat))"
-  by simp
-
-text{*The integers form a @{text comm_ring_1}*}
-
-
-ML {* val qty = @{typ "int"} *}
-ML {* val (rty, rel, rel_refl, rel_eqv) = lookup_quot_data @{context} qty *}
-ML {* val (trans2, reps_same, absrep, quot) = lookup_quot_thms @{context} "int" *}
-
-instance int :: comm_ring_1
-proof
-  fix i j k :: int
-  show "(i + j) + k = i + (j + k)"
-    unfolding add_int_def
-    apply(tactic {* lift_tac @{context} @{thm plus_assoc_raw} 1 *})
-    done
-  show "i + j = j + i" 
-    unfolding add_int_def
-    apply(tactic {* lift_tac @{context} @{thm plus_sym_raw} 1 *})
-    done
-  show "0 + i = (i::int)"
-    unfolding add_int_def Zero_int_def 
-    apply(tactic {* lift_tac @{context} @{thm plus_zero_raw} 1 *})
-    done
-  show "- i + i = 0"
-    unfolding add_int_def minus_int_def Zero_int_def 
-    apply(tactic {* lift_tac @{context} @{thm plus_minus_zero_raw} 1 *})
-    done
-  show "i - j = i + - j"
-    by (simp add: diff_int_def)
-  show "(i * j) * k = i * (j * k)"
-    unfolding mult_int_def 
-    apply(tactic {* lift_tac @{context} @{thm mult_assoc_raw} 1 *})
-    done
-  show "i * j = j * i"
-    unfolding mult_int_def 
-    apply(tactic {* lift_tac @{context} @{thm mult_sym_raw} 1 *})
-    done
-  show "1 * i = i"
-    unfolding mult_int_def One_int_def
-    apply(tactic {* lift_tac @{context} @{thm mult_one_raw} 1 *})
-    done
-  show "(i + j) * k = i * k + j * k"
-    unfolding mult_int_def add_int_def
-    apply(tactic {* lift_tac @{context} @{thm mult_plus_comm_raw} 1 *})
-    done
-  show "0 \<noteq> (1::int)"
-    unfolding Zero_int_def One_int_def
-    apply(tactic {* lift_tac @{context} @{thm one_zero_distinct} 1 *})
-    done
-qed
-
-term of_nat
-thm of_nat_def
-
-lemma int_def: "of_nat m = ABS_int (m, 0)"
-apply(induct m) 
-apply(simp add: Zero_int_def zero_qnt_def)
-apply(simp)
-apply(simp add: add_int_def One_int_def)
-apply(simp add: plus_qnt_def one_qnt_def)
-oops
-
-lemma le_antisym_raw:
-  shows "le_raw i j \<Longrightarrow> le_raw j i \<Longrightarrow> i \<approx> j"
-by (cases i, cases j) (simp)
-
-lemma le_refl_raw:
-  shows "le_raw i i"
-by (cases i) (simp)
-
-lemma le_trans_raw:
-  shows "le_raw i j \<Longrightarrow> le_raw j k \<Longrightarrow> le_raw i k"
-by (cases i, cases j, cases k) (simp)
-
-lemma le_cases_raw:
-  shows "le_raw i j \<or> le_raw j i"
-by (cases i, cases j) 
-   (simp add: linorder_linear)
-
-instance int :: linorder
-proof
-  fix i j k :: int
-  show antisym: "i \<le> j \<Longrightarrow> j \<le> i \<Longrightarrow> i = j"
-    unfolding le_int_def
-    apply(tactic {* lift_tac @{context} @{thm le_antisym_raw} 1 *})
-    done
-  show "(i < j) = (i \<le> j \<and> \<not> j \<le> i)"
-    by (auto simp add: less_int_def dest: antisym) 
-  show "i \<le> i"
-    unfolding le_int_def
-    apply(tactic {* lift_tac @{context} @{thm le_refl_raw} 1 *})
-    done
-  show "i \<le> j \<Longrightarrow> j \<le> k \<Longrightarrow> i \<le> k"
-    unfolding le_int_def
-    apply(tactic {* lift_tac @{context} @{thm le_trans_raw} 1 *})
-    done
-  show "i \<le> j \<or> j \<le> i"
-    unfolding le_int_def
-    apply(tactic {* lift_tac @{context} @{thm le_cases_raw} 1 *})
-    done
-qed
-
-instantiation int :: distrib_lattice
-begin
-
-definition
-  "(inf \<Colon> int \<Rightarrow> int \<Rightarrow> int) = min"
-
-definition
-  "(sup \<Colon> int \<Rightarrow> int \<Rightarrow> int) = max"
-
-instance
-  by intro_classes
-    (auto simp add: inf_int_def sup_int_def min_max.sup_inf_distrib1)
-
-end
-
-lemma le_plus_raw:
-  shows "le_raw i j \<Longrightarrow> le_raw (plus_raw k i) (plus_raw k j)"
-by (cases i, cases j, cases k) (simp)
-
-
-instance int :: pordered_cancel_ab_semigroup_add
-proof
-  fix i j k :: int
-  show "i \<le> j \<Longrightarrow> k + i \<le> k + j"
-    unfolding le_int_def add_int_def
-    apply(tactic {* lift_tac @{context} @{thm le_plus_raw} 1 *})
-    done
-qed
-
-lemma test:
-  "\<lbrakk>le_raw i j \<and> \<not>i \<approx> j; le_raw (0, 0) k \<and> \<not>(0, 0) \<approx> k\<rbrakk>
-    \<Longrightarrow> le_raw (mult_raw k i) (mult_raw k j) \<and> \<not>mult_raw k i \<approx> mult_raw k j"
-apply(cases i, cases j, cases k)
-apply(auto simp add: mult algebra_simps)
-sorry
-
-
-text{*The integers form an ordered integral domain*}
-instance int :: ordered_idom
-proof
-  fix i j k :: int
-  show "i < j \<Longrightarrow> 0 < k \<Longrightarrow> k * i < k * j"
-    unfolding mult_int_def le_int_def less_int_def Zero_int_def
-    apply(tactic {* lift_tac @{context} @{thm test} 1 *})
-    done
-  show "\<bar>i\<bar> = (if i < 0 then -i else i)"
-    by (simp only: zabs_def)
-  show "sgn (i\<Colon>int) = (if i=0 then 0 else if 0<i then 1 else - 1)"
-    by (simp only: zsgn_def)
-qed
-
-instance int :: lordered_ring
-proof  
-  fix k :: int
-  show "abs k = sup k (- k)"
-    by (auto simp add: sup_int_def zabs_def less_minus_self_iff [symmetric])
-qed
-
-lemmas int_distrib =
-  left_distrib [of "z1::int" "z2" "w", standard]
-  right_distrib [of "w::int" "z1" "z2", standard]
-  left_diff_distrib [of "z1::int" "z2" "w", standard]
-  right_diff_distrib [of "w::int" "z1" "z2", standard]
-
-
-subsection {* Embedding of the Integers into any @{text ring_1}: @{text of_int}*}
-
-(*
-context ring_1
-begin
-
- 
-definition 
-  of_int :: "int \<Rightarrow> 'a" 
-where
-  "of_int 
-*)
-
-
-subsection {* Binary representation *}
-
-text {*
-  This formalization defines binary arithmetic in terms of the integers
-  rather than using a datatype. This avoids multiple representations (leading
-  zeroes, etc.)  See @{text "ZF/Tools/twos-compl.ML"}, function @{text
-  int_of_binary}, for the numerical interpretation.
-
-  The representation expects that @{text "(m mod 2)"} is 0 or 1,
-  even if m is negative;
-  For instance, @{text "-5 div 2 = -3"} and @{text "-5 mod 2 = 1"}; thus
-  @{text "-5 = (-3)*2 + 1"}.
-  
-  This two's complement binary representation derives from the paper 
-  "An Efficient Representation of Arithmetic for Term Rewriting" by
-  Dave Cohen and Phil Watson, Rewriting Techniques and Applications,
-  Springer LNCS 488 (240-251), 1991.
-*}
-
-subsubsection {* The constructors @{term Bit0}, @{term Bit1}, @{term Pls} and @{term Min} *}
-
-definition
-  Pls :: int where
-  [code del]: "Pls = 0"
-
-definition
-  Min :: int where
-  [code del]: "Min = - 1"
-
-definition
-  Bit0 :: "int \<Rightarrow> int" where
-  [code del]: "Bit0 k = k + k"
-
-definition
-  Bit1 :: "int \<Rightarrow> int" where
-  [code del]: "Bit1 k = 1 + k + k"
-
-class number = -- {* for numeric types: nat, int, real, \dots *}
-  fixes number_of :: "int \<Rightarrow> 'a"
-
-use "~~/src/HOL/Tools/numeral.ML"
-
-syntax
-  "_Numeral" :: "num_const \<Rightarrow> 'a"    ("_")
-
-use "~~/src/HOL/Tools/numeral_syntax.ML"
-(*
-setup NumeralSyntax.setup
-
-abbreviation
-  "Numeral0 \<equiv> number_of Pls"
-
-abbreviation
-  "Numeral1 \<equiv> number_of (Bit1 Pls)"
-
-lemma Let_number_of [simp]: "Let (number_of v) f = f (number_of v)"
-  -- {* Unfold all @{text let}s involving constants *}
-  unfolding Let_def ..
-
-definition
-  succ :: "int \<Rightarrow> int" where
-  [code del]: "succ k = k + 1"
-
-definition
-  pred :: "int \<Rightarrow> int" where
-  [code del]: "pred k = k - 1"
-
-lemmas
-  max_number_of [simp] = max_def
-    [of "number_of u" "number_of v", standard, simp]
-and
-  min_number_of [simp] = min_def 
-    [of "number_of u" "number_of v", standard, simp]
-  -- {* unfolding @{text minx} and @{text max} on numerals *}
-
-lemmas numeral_simps = 
-  succ_def pred_def Pls_def Min_def Bit0_def Bit1_def
-
-text {* Removal of leading zeroes *}
-
-lemma Bit0_Pls [simp, code_post]:
-  "Bit0 Pls = Pls"
-  unfolding numeral_simps by simp
-
-lemma Bit1_Min [simp, code_post]:
-  "Bit1 Min = Min"
-  unfolding numeral_simps by simp
-
-lemmas normalize_bin_simps =
-  Bit0_Pls Bit1_Min
-*)
\ No newline at end of file
diff -r 6088fea1c8b1 -r 8a1c8dc72b5c IsaMakefile
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/IsaMakefile	Mon Dec 07 14:09:50 2009 +0100
@@ -0,0 +1,31 @@
+
+## targets
+
+default: Quot
+images: 
+test: Quot
+
+all: images test
+
+
+## global settings
+
+SRC = $(ISABELLE_HOME)/src
+OUT = $(ISABELLE_OUTPUT)
+LOG = $(OUT)/log
+
+USEDIR = $(ISABELLE_TOOL) usedir -v true -i true -d pdf  ## -D generated
+
+
+## Quot
+
+Quot: $(LOG)/HOL-Quot.gz
+
+$(LOG)/HOL-Quot.gz: Quot/ROOT.ML Quot/*.thy
+	@$(USEDIR) HOL Quot
+
+
+## clean
+
+clean:
+	@rm -f $(LOG)/HOL-Quot.gz
diff -r 6088fea1c8b1 -r 8a1c8dc72b5c LFex.thy
--- a/LFex.thy	Mon Dec 07 14:00:36 2009 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,307 +0,0 @@
-theory LFex
-imports Nominal QuotMain
-begin
-
-atom_decl name ident
-
-nominal_datatype kind = 
-    Type
-  | KPi "ty" "name" "kind"
-and ty =  
-    TConst "ident"
-  | TApp "ty" "trm"
-  | TPi "ty" "name" "ty"
-and trm = 
-    Const "ident"
-  | Var "name"
-  | App "trm" "trm"
-  | Lam "ty" "name" "trm" 
-
-function
-    fv_kind :: "kind \<Rightarrow> name set"
-and fv_ty   :: "ty \<Rightarrow> name set"
-and fv_trm  :: "trm \<Rightarrow> name set"
-where
-  "fv_kind (Type) = {}"
-| "fv_kind (KPi A x K) = (fv_ty A) \<union> ((fv_kind K) - {x})"
-| "fv_ty (TConst i) = {}"
-| "fv_ty (TApp A M) = (fv_ty A) \<union> (fv_trm M)"
-| "fv_ty (TPi A x B) = (fv_ty A) \<union> ((fv_ty B) - {x})"
-| "fv_trm (Const i) = {}"
-| "fv_trm (Var x) = {x}"
-| "fv_trm (App M N) = (fv_trm M) \<union> (fv_trm N)"
-| "fv_trm (Lam A x M) = (fv_ty A) \<union> ((fv_trm M) - {x})"
-sorry
-
-termination fv_kind sorry
-
-inductive
-    akind :: "kind \<Rightarrow> kind \<Rightarrow> bool" ("_ \<approx>ki _" [100, 100] 100)
-and aty   :: "ty \<Rightarrow> ty \<Rightarrow> bool"     ("_ \<approx>ty _" [100, 100] 100)
-and atrm  :: "trm \<Rightarrow> trm \<Rightarrow> bool"   ("_ \<approx>tr _" [100, 100] 100)
-where
-  a1:  "(Type) \<approx>ki (Type)"
-| a21: "\<lbrakk>A \<approx>ty A'; K \<approx>ki K'\<rbrakk> \<Longrightarrow> (KPi A x K) \<approx>ki (KPi A' x K')"
-| a22: "\<lbrakk>A \<approx>ty A'; K \<approx>ki ([(x,x')]\<bullet>K'); x \<notin> (fv_ty A'); x \<notin> ((fv_kind K') - {x'})\<rbrakk> 
-        \<Longrightarrow> (KPi A x K) \<approx>ki (KPi A' x' K')"
-| a3:  "i = j \<Longrightarrow> (TConst i) \<approx>ty (TConst j)"
-| a4:  "\<lbrakk>A \<approx>ty A'; M \<approx>tr M'\<rbrakk> \<Longrightarrow> (TApp A M) \<approx>ty (TApp A' M')"
-| a51: "\<lbrakk>A \<approx>ty A'; B \<approx>ty B'\<rbrakk> \<Longrightarrow> (TPi A x B) \<approx>ty (TPi A' x B')"
-| a52: "\<lbrakk>A \<approx>ty A'; B \<approx>ty ([(x,x')]\<bullet>B'); x \<notin> (fv_ty B'); x \<notin> ((fv_ty B') - {x'})\<rbrakk> 
-        \<Longrightarrow> (TPi A x B) \<approx>ty (TPi A' x' B')"
-| a6:  "i = j \<Longrightarrow> (Const i) \<approx>trm (Const j)"
-| a7:  "x = y \<Longrightarrow> (Var x) \<approx>trm (Var y)"
-| a8:  "\<lbrakk>M \<approx>trm M'; N \<approx>tr N'\<rbrakk> \<Longrightarrow> (App M N) \<approx>tr (App M' N')"
-| a91: "\<lbrakk>A \<approx>ty A'; M \<approx>tr M'\<rbrakk> \<Longrightarrow> (Lam A x M) \<approx>tr (Lam A' x M')"
-| a92: "\<lbrakk>A \<approx>ty A'; M \<approx>tr ([(x,x')]\<bullet>M'); x \<notin> (fv_ty B'); x \<notin> ((fv_trm M') - {x'})\<rbrakk> 
-        \<Longrightarrow> (Lam A x M) \<approx>tr (Lam A' x' M')"
-
-lemma al_refl:
-  fixes K::"kind" 
-  and   A::"ty"
-  and   M::"trm"
-  shows "K \<approx>ki K"
-  and   "A \<approx>ty A"
-  and   "M \<approx>tr M"
-  apply(induct K and A and M rule: kind_ty_trm.inducts)
-  apply(auto intro: akind_aty_atrm.intros)
-  done
-
-lemma alpha_equivps:
-  shows "equivp akind"
-  and   "equivp aty"
-  and   "equivp atrm"
-sorry
-
-quotient KIND = kind / akind
-  by (rule alpha_equivps)
-
-quotient TY = ty / aty
-   and   TRM = trm / atrm
-  by (auto intro: alpha_equivps)
-
-print_quotients
-
-quotient_def 
-  TYP :: "KIND"
-where
-  "TYP \<equiv> Type"
-
-quotient_def 
-  KPI :: "TY \<Rightarrow> name \<Rightarrow> KIND \<Rightarrow> KIND"
-where
-  "KPI \<equiv> KPi"
-
-quotient_def 
-  TCONST :: "ident \<Rightarrow> TY"
-where
-  "TCONST \<equiv> TConst"
-
-quotient_def 
-  TAPP :: "TY \<Rightarrow> TRM \<Rightarrow> TY"
-where
-  "TAPP \<equiv> TApp"
-
-quotient_def 
-  TPI :: "TY \<Rightarrow> name \<Rightarrow> TY \<Rightarrow> TY"
-where
-  "TPI \<equiv> TPi"
-
-(* FIXME: does not work with CONST *)
-quotient_def 
-  CONS :: "ident \<Rightarrow> TRM"
-where
-  "CONS \<equiv> Const"
-
-quotient_def 
-  VAR :: "name \<Rightarrow> TRM"
-where
-  "VAR \<equiv> Var"
-
-quotient_def 
-  APP :: "TRM \<Rightarrow> TRM \<Rightarrow> TRM"
-where
-  "APP \<equiv> App"
-
-quotient_def 
-  LAM :: "TY \<Rightarrow> name \<Rightarrow> TRM \<Rightarrow> TRM"
-where
-  "LAM \<equiv> Lam"
-
-thm TYP_def
-thm KPI_def
-thm TCONST_def
-thm TAPP_def
-thm TPI_def
-thm VAR_def
-thm CONS_def
-thm APP_def
-thm LAM_def
-
-(* FIXME: print out a warning if the type contains a liftet type, like kind \<Rightarrow> name set *)
-quotient_def 
-  FV_kind :: "KIND \<Rightarrow> name set"
-where
-  "FV_kind \<equiv> fv_kind"
-
-quotient_def 
-  FV_ty :: "TY \<Rightarrow> name set"
-where
-  "FV_ty \<equiv> fv_ty"
-
-quotient_def 
-  FV_trm :: "TRM \<Rightarrow> name set"
-where
-  "FV_trm \<equiv> fv_trm"
-
-thm FV_kind_def
-thm FV_ty_def
-thm FV_trm_def
-
-(* FIXME: does not work yet *)
-overloading
-    perm_kind \<equiv> "perm :: 'x prm \<Rightarrow> KIND \<Rightarrow> KIND"   (unchecked)
-    perm_ty   \<equiv> "perm :: 'x prm \<Rightarrow> TY \<Rightarrow> TY"       (unchecked)
-    perm_trm  \<equiv> "perm :: 'x prm \<Rightarrow> TRM \<Rightarrow> TRM"     (unchecked) 
-begin
-
-quotient_def 
-  perm_kind :: "'x prm \<Rightarrow> KIND \<Rightarrow> KIND"
-where
-  "perm_kind \<equiv> (perm::'x prm \<Rightarrow> kind \<Rightarrow> kind)"
-
-quotient_def 
-  perm_ty :: "'x prm \<Rightarrow> TY \<Rightarrow> TY"
-where
-  "perm_ty \<equiv> (perm::'x prm \<Rightarrow> ty \<Rightarrow> ty)"
-
-quotient_def 
-  perm_trm :: "'x prm \<Rightarrow> TRM \<Rightarrow> TRM"
-where
-  "perm_trm \<equiv> (perm::'x prm \<Rightarrow> trm \<Rightarrow> trm)"
-
-(* TODO/FIXME: Think whether these RSP theorems are true. *)
-lemma kpi_rsp[quotient_rsp]: 
-  "(aty ===> op = ===> akind ===> akind) KPi KPi" sorry
-lemma tconst_rsp[quotient_rsp]: 
-  "(op = ===> aty) TConst TConst" sorry
-lemma tapp_rsp[quotient_rsp]: 
-  "(aty ===> atrm ===> aty) TApp TApp" sorry
-lemma tpi_rsp[quotient_rsp]: 
-  "(aty ===> op = ===> aty ===> aty) TPi TPi" sorry
-lemma var_rsp[quotient_rsp]: 
-  "(op = ===> atrm) Var Var" sorry
-lemma app_rsp[quotient_rsp]: 
-  "(atrm ===> atrm ===> atrm) App App" sorry
-lemma const_rsp[quotient_rsp]: 
-  "(op = ===> atrm) Const Const" sorry
-lemma lam_rsp[quotient_rsp]: 
-  "(aty ===> op = ===> atrm ===> atrm) Lam Lam" sorry
-
-lemma perm_kind_rsp[quotient_rsp]: 
-  "(op = ===> akind ===> akind) op \<bullet> op \<bullet>" sorry
-lemma perm_ty_rsp[quotient_rsp]: 
-  "(op = ===> aty ===> aty) op \<bullet> op \<bullet>" sorry
-lemma perm_trm_rsp[quotient_rsp]: 
-  "(op = ===> atrm ===> atrm) op \<bullet> op \<bullet>" sorry
-
-lemma fv_ty_rsp[quotient_rsp]: 
-  "(aty ===> op =) fv_ty fv_ty" sorry
-lemma fv_kind_rsp[quotient_rsp]: 
-  "(akind ===> op =) fv_kind fv_kind" sorry
-lemma fv_trm_rsp[quotient_rsp]: 
-  "(atrm ===> op =) fv_trm fv_trm" sorry
-
-
-thm akind_aty_atrm.induct
-thm kind_ty_trm.induct
-
-ML {*
-  val quot = @{thms Quotient_KIND Quotient_TY Quotient_TRM}
-  val rel_refl = map (fn x => @{thm equivp_reflp} OF [x]) @{thms alpha_equivps}
-  val reps_same = map (fn x => @{thm Quotient_rel_rep} OF [x]) quot
-  val trans2 = map (fn x => @{thm equals_rsp} OF [x]) quot
-*}
-
-lemma 
-  assumes a0:
-  "P1 TYP TYP"
-  and a1: 
-  "\<And>A A' K K' x. \<lbrakk>(A::TY) = A'; P2 A A'; (K::KIND) = K'; P1 K K'\<rbrakk> 
-  \<Longrightarrow> P1 (KPI A x K) (KPI A' x K')"
-  and a2:    
-  "\<And>A A' K K' x x'. \<lbrakk>(A ::TY) = A'; P2 A A'; (K :: KIND) = ([(x, x')] \<bullet> K'); P1 K ([(x, x')] \<bullet> K'); 
-    x \<notin> FV_ty A'; x \<notin> FV_kind K' - {x'}\<rbrakk> \<Longrightarrow> P1 (KPI A x K) (KPI A' x' K')"
-  and a3: 
-  "\<And>i j. i = j \<Longrightarrow> P2 (TCONST i) (TCONST j)"
-  and a4:
-  "\<And>A A' M M'. \<lbrakk>(A ::TY) = A'; P2 A A'; (M :: TRM) = M'; P3 M M'\<rbrakk> \<Longrightarrow> P2 (TAPP A M) (TAPP A' M')"
-  and a5:
-  "\<And>A A' B B' x. \<lbrakk>(A ::TY) = A'; P2 A A'; (B ::TY) = B'; P2 B B'\<rbrakk> \<Longrightarrow> P2 (TPI A x B) (TPI A' x B')"
-  and a6:
-  "\<And>A A' B x x' B'. \<lbrakk>(A ::TY) = A'; P2 A A'; (B ::TY) = ([(x, x')] \<bullet> B'); P2 B ([(x, x')] \<bullet> B'); 
-  x \<notin> FV_ty B'; x \<notin> FV_ty B' - {x'}\<rbrakk> \<Longrightarrow> P2 (TPI A x B) (TPI A' x' B')"
-  and a7:
-  "\<And>i j m. i = j \<Longrightarrow> P3 (CONS i) (m (CONS j))"
-  and a8:
-  "\<And>x y m. x = y \<Longrightarrow> P3 (VAR x) (m (VAR y))"
-  and a9:
-  "\<And>M m M' N N'. \<lbrakk>(M :: TRM) = m M'; P3 M (m M'); (N :: TRM) = N'; P3 N N'\<rbrakk> \<Longrightarrow> P3 (APP M N) (APP M' N')"
-  and a10: 
-  "\<And>A A' M M' x. \<lbrakk>(A ::TY) = A'; P2 A A'; (M :: TRM) = M'; P3 M M'\<rbrakk> \<Longrightarrow> P3 (LAM A x M) (LAM A' x M')"
-  and a11:
-  "\<And>A A' M x x' M' B'. \<lbrakk>(A ::TY) = A'; P2 A A'; (M :: TRM) = ([(x, x')] \<bullet> M'); P3 M ([(x, x')] \<bullet> M'); 
-  x \<notin> FV_ty B'; x \<notin> FV_trm M' - {x'}\<rbrakk> \<Longrightarrow> P3 (LAM A x M) (LAM A' x' M')"
-  shows "((x1 :: KIND) = x2 \<longrightarrow> P1 x1 x2) \<and>
-         ((x3 ::TY) = x4 \<longrightarrow> P2 x3 x4) \<and> 
-         ((x5 :: TRM) = x6 \<longrightarrow> P3 x5 x6)"
-using a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11
-apply - 
-apply(tactic {* procedure_tac @{context} @{thm akind_aty_atrm.induct} 1 *})
-apply(tactic {* regularize_tac @{context} 1 *})
-apply(tactic {* all_inj_repabs_tac @{context} rel_refl trans2 1 *})
-apply(fold perm_kind_def perm_ty_def perm_trm_def)
-apply(tactic {* clean_tac @{context} 1 *})
-(*
-Profiling:
-ML_prf {* fun ith i =  (#concl (fst (Subgoal.focus @{context} i (#goal (Isar.goal ()))))) *}
-ML_prf {* profile 2 Seq.list_of ((clean_tac @{context} quot defs 1) (ith 3)) *}
-ML_prf {* profile 2 Seq.list_of ((regularize_tac @{context} @{thms alpha_equivps} 1) (ith 1)) *}
-ML_prf {* PolyML.profiling 1 *}
-ML_prf {* profile 2 Seq.list_of ((all_inj_repabs_tac @{context} quot rel_refl trans2 1) (#goal (Isar.goal ()))) *}
-*)
-done
-
-(* Does not work:
-lemma
-  assumes a0: "P1 TYP"
-  and     a1: "\<And>ty name kind. \<lbrakk>P2 ty; P1 kind\<rbrakk> \<Longrightarrow> P1 (KPI ty name kind)"
-  and     a2: "\<And>id. P2 (TCONST id)"
-  and     a3: "\<And>ty trm. \<lbrakk>P2 ty; P3 trm\<rbrakk> \<Longrightarrow> P2 (TAPP ty trm)"
-  and     a4: "\<And>ty1 name ty2. \<lbrakk>P2 ty1; P2 ty2\<rbrakk> \<Longrightarrow> P2 (TPI ty1 name ty2)"
-  and     a5: "\<And>id. P3 (CONS id)"
-  and     a6: "\<And>name. P3 (VAR name)"
-  and     a7: "\<And>trm1 trm2. \<lbrakk>P3 trm1; P3 trm2\<rbrakk> \<Longrightarrow> P3 (APP trm1 trm2)"
-  and     a8: "\<And>ty name trm. \<lbrakk>P2 ty; P3 trm\<rbrakk> \<Longrightarrow> P3 (LAM ty name trm)"
-  shows "P1 mkind \<and> P2 mty \<and> P3 mtrm"
-using a0 a1 a2 a3 a4 a5 a6 a7 a8
-*)
-
-lemma "\<lbrakk>P TYP;
-  \<And>ty name kind. \<lbrakk>Q ty; P kind\<rbrakk> \<Longrightarrow> P (KPI ty name kind);
-  \<And>id. Q (TCONST id);
-  \<And>ty trm. \<lbrakk>Q ty; R trm\<rbrakk> \<Longrightarrow> Q (TAPP ty trm);
-  \<And>ty1 name ty2. \<lbrakk>Q ty1; Q ty2\<rbrakk> \<Longrightarrow> Q (TPI ty1 name ty2);
-  \<And>id. R (CONS id); \<And>name. R (VAR name);
-  \<And>trm1 trm2. \<lbrakk>R trm1; R trm2\<rbrakk> \<Longrightarrow> R (APP trm1 trm2);
-  \<And>ty name trm. \<lbrakk>Q ty; R trm\<rbrakk> \<Longrightarrow> R (LAM ty name trm)\<rbrakk>
-  \<Longrightarrow> P mkind \<and> Q mty \<and> R mtrm"
-apply(tactic {* lift_tac @{context} @{thm kind_ty_trm.induct} 1 *})
-done
-
-print_quotients
-
-end
-
-
-
diff -r 6088fea1c8b1 -r 8a1c8dc72b5c LamEx.thy
--- a/LamEx.thy	Mon Dec 07 14:00:36 2009 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,252 +0,0 @@
-theory LamEx
-imports Nominal QuotMain
-begin
-
-atom_decl name
-
-thm abs_fresh(1)
-
-nominal_datatype rlam =
-  rVar "name"
-| rApp "rlam" "rlam"
-| rLam "name" "rlam"
-
-print_theorems
-
-function
-  rfv :: "rlam \<Rightarrow> name set"
-where
-  rfv_var: "rfv (rVar a) = {a}"
-| rfv_app: "rfv (rApp t1 t2) = (rfv t1) \<union> (rfv t2)"
-| rfv_lam: "rfv (rLam a t) = (rfv t) - {a}"
-sorry
-
-termination rfv sorry
-
-inductive
-  alpha :: "rlam \<Rightarrow> rlam \<Rightarrow> bool" ("_ \<approx> _" [100, 100] 100)
-where
-  a1: "a = b \<Longrightarrow> (rVar a) \<approx> (rVar b)"
-| a2: "\<lbrakk>t1 \<approx> t2; s1 \<approx> s2\<rbrakk> \<Longrightarrow> rApp t1 s1 \<approx> rApp t2 s2"
-| a3: "\<lbrakk>t \<approx> ([(a,b)]\<bullet>s); a \<notin> rfv (rLam b t)\<rbrakk> \<Longrightarrow> rLam a t \<approx> rLam b s"
-
-print_theorems
-
-lemma alpha_refl:
-  fixes t::"rlam"
-  shows "t \<approx> t"
-  apply(induct t rule: rlam.induct)
-  apply(simp add: a1)
-  apply(simp add: a2)
-  apply(rule a3)
-  apply(subst pt_swap_bij'')
-  apply(rule pt_name_inst)
-  apply(rule at_name_inst)
-  apply(simp)
-  apply(simp)
-  done
-
-lemma alpha_equivp:
-  shows "equivp alpha"
-sorry
-
-quotient lam = rlam / alpha
-  apply(rule alpha_equivp)
-  done
-
-print_quotients
-
-quotient_def 
-  Var :: "name \<Rightarrow> lam"
-where
-  "Var \<equiv> rVar"
-
-quotient_def 
-  App :: "lam \<Rightarrow> lam \<Rightarrow> lam"
-where
-  "App \<equiv> rApp"
-
-quotient_def 
-  Lam :: "name \<Rightarrow> lam \<Rightarrow> lam"
-where
-  "Lam \<equiv> rLam"
-
-thm Var_def
-thm App_def
-thm Lam_def
-
-quotient_def 
-  fv :: "lam \<Rightarrow> name set"
-where
-  "fv \<equiv> rfv"
-
-thm fv_def
-
-(* definition of overloaded permutation function *)
-(* for the lifted type lam                       *)
-overloading
-  perm_lam \<equiv> "perm :: 'x prm \<Rightarrow> lam \<Rightarrow> lam"   (unchecked)
-begin
-
-quotient_def 
-  perm_lam :: "'x prm \<Rightarrow> lam \<Rightarrow> lam"
-where
-  "perm_lam \<equiv> (perm::'x prm \<Rightarrow> rlam \<Rightarrow> rlam)"
-
-end
-
-(*quotient_def (for lam)
-  abs_fun_lam :: "'x prm \<Rightarrow> lam \<Rightarrow> lam"
-where
-  "perm_lam \<equiv> (perm::'x prm \<Rightarrow> rlam \<Rightarrow> rlam)"*)
-
-
-thm perm_lam_def
-
-(* lemmas that need to lift *)
-lemma pi_var_com:
-  fixes pi::"'x prm"
-  shows "(pi\<bullet>rVar a) \<approx> rVar (pi\<bullet>a)"
-  sorry
-
-lemma pi_app_com:
-  fixes pi::"'x prm"
-  shows "(pi\<bullet>rApp t1 t2) \<approx> rApp (pi\<bullet>t1) (pi\<bullet>t2)"
-  sorry
-
-lemma pi_lam_com:
-  fixes pi::"'x prm"
-  shows "(pi\<bullet>rLam a t) \<approx> rLam (pi\<bullet>a) (pi\<bullet>t)"
-  sorry
-
-
-
-lemma real_alpha:
-  assumes a: "t = [(a,b)]\<bullet>s" "a\<sharp>[b].s"
-  shows "Lam a t = Lam b s"
-using a
-unfolding fresh_def supp_def
-sorry
-
-lemma perm_rsp[quotient_rsp]:
-  "(op = ===> alpha ===> alpha) op \<bullet> op \<bullet>"
-  apply(auto)
-  (* this is propably true if some type conditions are imposed ;o) *)
-  sorry
-
-lemma fresh_rsp:
-  "(op = ===> alpha ===> op =) fresh fresh"
-  apply(auto)
-  (* this is probably only true if some type conditions are imposed *)
-  sorry
-
-lemma rVar_rsp[quotient_rsp]:
-  "(op = ===> alpha) rVar rVar"
-by (auto intro:a1)
-
-lemma rApp_rsp[quotient_rsp]: "(alpha ===> alpha ===> alpha) rApp rApp"
-by (auto intro:a2)
-
-lemma rLam_rsp[quotient_rsp]: "(op = ===> alpha ===> alpha) rLam rLam"
-  apply(auto)
-  apply(rule a3)
-  apply(rule_tac t="[(x,x)]\<bullet>y" and s="y" in subst)
-  apply(rule sym)
-  apply(rule trans)
-  apply(rule pt_name3)
-  apply(rule at_ds1[OF at_name_inst])
-  apply(simp add: pt_name1)
-  apply(assumption)
-  apply(simp add: abs_fresh)
-  done
-
-lemma rfv_rsp[quotient_rsp]: "(alpha ===> op =) rfv rfv"
-  sorry
-
-lemma rvar_inject: "rVar a \<approx> rVar b = (a = b)"
-apply (auto)
-apply (erule alpha.cases)
-apply (simp_all add: rlam.inject alpha_refl)
-done
-
-ML {* val qty = @{typ "lam"} *}
-ML {* val rsp_thms = @{thms perm_rsp fresh_rsp rVar_rsp rApp_rsp rLam_rsp rfv_rsp} *}
-
-ML {* val (rty, rel, rel_refl, rel_eqv) = lookup_quot_data @{context} qty *}
-ML {* val (trans2, reps_same, absrep, quot) = lookup_quot_thms @{context} "lam" *}
-ML {* fun lift_tac_lam lthy t = lift_tac lthy t *}
-
-lemma pi_var: "(pi\<Colon>('x \<times> 'x) list) \<bullet> Var a = Var (pi \<bullet> a)"
-apply (tactic {* lift_tac_lam @{context} @{thm pi_var_com} 1 *})
-done
-
-lemma pi_app: "(pi\<Colon>('x \<times> 'x) list) \<bullet> App (x\<Colon>lam) (xa\<Colon>lam) = App (pi \<bullet> x) (pi \<bullet> xa)"
-apply (tactic {* lift_tac_lam @{context} @{thm pi_app_com} 1 *})
-done
-
-lemma pi_lam: "(pi\<Colon>('x \<times> 'x) list) \<bullet> Lam (a\<Colon>name) (x\<Colon>lam) = Lam (pi \<bullet> a) (pi \<bullet> x)"
-apply (tactic {* lift_tac_lam @{context} @{thm pi_lam_com} 1 *})
-done
-
-lemma fv_var: "fv (Var (a\<Colon>name)) = {a}"
-apply (tactic {* lift_tac_lam @{context} @{thm rfv_var} 1 *})
-done
-
-lemma fv_app: "fv (App (x\<Colon>lam) (xa\<Colon>lam)) = fv x \<union> fv xa"
-apply (tactic {* lift_tac_lam @{context} @{thm rfv_app} 1 *})
-done
-
-lemma fv_lam: "fv (Lam (a\<Colon>name) (x\<Colon>lam)) = fv x - {a}"
-apply (tactic {* lift_tac_lam @{context} @{thm rfv_lam} 1 *})
-done
-
-lemma a1: "(a\<Colon>name) = (b\<Colon>name) \<Longrightarrow> Var a = Var b"
-apply (tactic {* lift_tac_lam @{context} @{thm a1} 1 *})
-done
-
-lemma a2: "\<lbrakk>(x\<Colon>lam) = (xa\<Colon>lam); (xb\<Colon>lam) = (xc\<Colon>lam)\<rbrakk> \<Longrightarrow> App x xb = App xa xc"
-apply (tactic {* lift_tac_lam @{context} @{thm a2} 1 *})
-done
-
-lemma a3: "\<lbrakk>(x\<Colon>lam) = [(a\<Colon>name, b\<Colon>name)] \<bullet> (xa\<Colon>lam); a \<notin> fv (Lam b x)\<rbrakk> \<Longrightarrow> Lam a x = Lam b xa"
-apply (tactic {* lift_tac_lam @{context} @{thm a3} 1 *})
-done
-
-lemma alpha_cases: "\<lbrakk>a1 = a2; \<And>a b. \<lbrakk>a1 = Var a; a2 = Var b; a = b\<rbrakk> \<Longrightarrow> P;
-     \<And>x xa xb xc. \<lbrakk>a1 = App x xb; a2 = App xa xc; x = xa; xb = xc\<rbrakk> \<Longrightarrow> P;
-     \<And>x a b xa. \<lbrakk>a1 = Lam a x; a2 = Lam b xa; x = [(a, b)] \<bullet> xa; a \<notin> fv (Lam b x)\<rbrakk> \<Longrightarrow> P\<rbrakk>
-    \<Longrightarrow> P"
-apply (tactic {* lift_tac_lam @{context} @{thm alpha.cases} 1 *})
-done
-
-lemma alpha_induct: "\<lbrakk>(qx\<Colon>lam) = (qxa\<Colon>lam); \<And>(a\<Colon>name) b\<Colon>name. a = b \<Longrightarrow> (qxb\<Colon>lam \<Rightarrow> lam \<Rightarrow> bool) (Var a) (Var b);
-     \<And>(x\<Colon>lam) (xa\<Colon>lam) (xb\<Colon>lam) xc\<Colon>lam. \<lbrakk>x = xa; qxb x xa; xb = xc; qxb xb xc\<rbrakk> \<Longrightarrow> qxb (App x xb) (App xa xc);
-     \<And>(x\<Colon>lam) (a\<Colon>name) (b\<Colon>name) xa\<Colon>lam.
-        \<lbrakk>x = [(a, b)] \<bullet> xa; qxb x ([(a, b)] \<bullet> xa); a \<notin> fv (Lam b x)\<rbrakk> \<Longrightarrow> qxb (Lam a x) (Lam b xa)\<rbrakk>
-    \<Longrightarrow> qxb qx qxa"
-apply (tactic {* lift_tac_lam @{context} @{thm alpha.induct} 1 *})
-done
-
-lemma var_inject: "(Var a = Var b) = (a = b)"
-apply (tactic {* lift_tac_lam @{context} @{thm rvar_inject} 1 *})
-done
-
-lemma lam_induct:" \<lbrakk>\<And>name. P (Var name); \<And>lam1 lam2. \<lbrakk>P lam1; P lam2\<rbrakk> \<Longrightarrow> P (App lam1 lam2);
-              \<And>name lam. P lam \<Longrightarrow> P (Lam name lam)\<rbrakk> \<Longrightarrow> P lam"
-apply (tactic {* lift_tac_lam @{context} @{thm rlam.induct} 1 *})
-done
-
-lemma var_supp:
-  shows "supp (Var a) = ((supp a)::name set)"
-  apply(simp add: supp_def)
-  apply(simp add: pi_var)
-  apply(simp add: var_inject)
-  done
-
-lemma var_fresh:
-  fixes a::"name"
-  shows "(a\<sharp>(Var b)) = (a\<sharp>b)"
-  apply(simp add: fresh_def)
-  apply(simp add: var_supp)
-  done
-
diff -r 6088fea1c8b1 -r 8a1c8dc72b5c Prove.thy
--- a/Prove.thy	Mon Dec 07 14:00:36 2009 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,28 +0,0 @@
-theory Prove
-imports Plain 
-begin
-
-ML {*
-val r = Unsynchronized.ref (NONE:(unit -> term) option)
-*}
-
-ML {*
-let
-  fun after_qed thm_name thms lthy =
-       Local_Theory.note (thm_name, (flat thms)) lthy |> snd
-    
-  fun setup_proof (name_spec, (txt, pos)) lthy =
-  let
-    val trm = ML_Context.evaluate lthy true ("r", r) txt
-  in
-    Proof.theorem_i NONE (after_qed name_spec) [[(trm,[])]] lthy
-  end
-
-  val parser = SpecParse.opt_thm_name ":" -- OuterParse.ML_source
-in
-  OuterSyntax.local_theory_to_proof "prove" "proving a proposition" 
-    OuterKeyword.thy_goal (parser >> setup_proof)
-end
-*}
-
-end
diff -r 6088fea1c8b1 -r 8a1c8dc72b5c Quot/Examples/FSet.thy
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Quot/Examples/FSet.thy	Mon Dec 07 14:09:50 2009 +0100
@@ -0,0 +1,440 @@
+theory FSet
+imports "../QuotMain"
+begin
+
+inductive
+  list_eq (infix "\<approx>" 50)
+where
+  "a#b#xs \<approx> b#a#xs"
+| "[] \<approx> []"
+| "xs \<approx> ys \<Longrightarrow> ys \<approx> xs"
+| "a#a#xs \<approx> a#xs"
+| "xs \<approx> ys \<Longrightarrow> a#xs \<approx> a#ys"
+| "\<lbrakk>xs1 \<approx> xs2; xs2 \<approx> xs3\<rbrakk> \<Longrightarrow> xs1 \<approx> xs3"
+
+lemma list_eq_refl:
+  shows "xs \<approx> xs"
+  by (induct xs) (auto intro: list_eq.intros)
+
+lemma equivp_list_eq:
+  shows "equivp list_eq"
+  unfolding equivp_reflp_symp_transp reflp_def symp_def transp_def
+  apply(auto intro: list_eq.intros list_eq_refl)
+  done
+
+quotient fset = "'a list" / "list_eq"
+  apply(rule equivp_list_eq)
+  done
+
+print_theorems
+
+typ "'a fset"
+thm "Rep_fset"
+thm "ABS_fset_def"
+
+quotient_def 
+  EMPTY :: "'a fset"
+where
+  "EMPTY \<equiv> ([]::'a list)"
+
+term Nil
+term EMPTY
+thm EMPTY_def
+
+quotient_def 
+  INSERT :: "'a \<Rightarrow> 'a fset \<Rightarrow> 'a fset"
+where
+  "INSERT \<equiv> op #"
+
+term Cons
+term INSERT
+thm INSERT_def
+
+quotient_def 
+  FUNION :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> 'a fset"
+where
+  "FUNION \<equiv> (op @)"
+
+term append
+term FUNION
+thm FUNION_def
+
+thm Quotient_fset
+
+thm QUOT_TYPE_I_fset.thm11
+
+
+fun
+  membship :: "'a \<Rightarrow> 'a list \<Rightarrow> bool" (infix "memb" 100)
+where
+  m1: "(x memb []) = False"
+| m2: "(x memb (y#xs)) = ((x=y) \<or> (x memb xs))"
+
+fun
+  card1 :: "'a list \<Rightarrow> nat"
+where
+  card1_nil: "(card1 []) = 0"
+| card1_cons: "(card1 (x # xs)) = (if (x memb xs) then (card1 xs) else (Suc (card1 xs)))"
+
+quotient_def 
+  CARD :: "'a fset \<Rightarrow> nat"
+where
+  "CARD \<equiv> card1"
+
+term card1
+term CARD
+thm CARD_def
+
+(* text {*
+ Maybe make_const_def should require a theorem that says that the particular lifted function
+ respects the relation. With it such a definition would be impossible:
+ make_const_def @{binding CARD} @{term "length"} NoSyn @{typ "'a list"} @{typ "'a fset"} #> snd
+*}*)
+
+lemma card1_0:
+  fixes a :: "'a list"
+  shows "(card1 a = 0) = (a = [])"
+  by (induct a) auto
+
+lemma not_mem_card1:
+  fixes x :: "'a"
+  fixes xs :: "'a list"
+  shows "(~(x memb xs)) = (card1 (x # xs) = Suc (card1 xs))"
+  by auto
+
+lemma mem_cons:
+  fixes x :: "'a"
+  fixes xs :: "'a list"
+  assumes a : "x memb xs"
+  shows "x # xs \<approx> xs"
+  using a by (induct xs) (auto intro: list_eq.intros )
+
+lemma card1_suc:
+  fixes xs :: "'a list"
+  fixes n :: "nat"
+  assumes c: "card1 xs = Suc n"
+  shows "\<exists>a ys. ~(a memb ys) \<and> xs \<approx> (a # ys)"
+  using c
+apply(induct xs)
+apply (metis Suc_neq_Zero card1_0)
+apply (metis QUOT_TYPE_I_fset.R_trans card1_cons list_eq_refl mem_cons)
+done
+
+definition
+  rsp_fold
+where
+  "rsp_fold f = ((!u v. (f u v = f v u)) \<and> (!u v w. ((f u (f v w) = f (f u v) w))))"
+
+primrec
+  fold1
+where
+  "fold1 f (g :: 'a \<Rightarrow> 'b) (z :: 'b) [] = z"
+| "fold1 f g z (a # A) =
+     (if rsp_fold f
+     then (
+       if (a memb A) then (fold1 f g z A) else (f (g a) (fold1 f g z A))
+     ) else z)"
+
+lemma fs1_strong_cases:
+  fixes X :: "'a list"
+  shows "(X = []) \<or> (\<exists>a. \<exists> Y. (~(a memb Y) \<and> (X \<approx> a # Y)))"
+  apply (induct X)
+  apply (simp)
+  apply (metis QUOT_TYPE_I_fset.thm11 list_eq_refl mem_cons m1)
+  done
+
+quotient_def
+  IN :: "'a \<Rightarrow> 'a fset \<Rightarrow> bool"
+where
+  "IN \<equiv> membship"
+
+term membship
+term IN
+thm IN_def
+
+term fold1
+quotient_def 
+  FOLD :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'b fset \<Rightarrow> 'a"
+where
+  "FOLD \<equiv> fold1"
+
+term fold1
+term fold
+thm fold_def
+
+quotient_def 
+  fmap::"('a \<Rightarrow> 'b) \<Rightarrow> 'a fset \<Rightarrow> 'b fset"
+where
+  "fmap \<equiv> map"
+
+term map
+term fmap
+thm fmap_def
+
+lemma memb_rsp:
+  fixes z
+  assumes a: "x \<approx> y"
+  shows "(z memb x) = (z memb y)"
+  using a by induct auto
+
+lemma ho_memb_rsp[quotient_rsp]:
+  "(op = ===> (op \<approx> ===> op =)) (op memb) (op memb)"
+  by (simp add: memb_rsp)
+
+lemma card1_rsp:
+  fixes a b :: "'a list"
+  assumes e: "a \<approx> b"
+  shows "card1 a = card1 b"
+  using e by induct (simp_all add:memb_rsp)
+
+lemma ho_card1_rsp[quotient_rsp]: 
+  "(op \<approx> ===> op =) card1 card1"
+  by (simp add: card1_rsp)
+
+lemma cons_rsp[quotient_rsp]:
+  fixes z
+  assumes a: "xs \<approx> ys"
+  shows "(z # xs) \<approx> (z # ys)"
+  using a by (rule list_eq.intros(5))
+
+lemma ho_cons_rsp[quotient_rsp]:
+  "(op = ===> op \<approx> ===> op \<approx>) op # op #"
+  by (simp add: cons_rsp)
+
+lemma append_rsp_fst:
+  assumes a : "l1 \<approx> l2"
+  shows "(l1 @ s) \<approx> (l2 @ s)"
+  using a
+  by (induct) (auto intro: list_eq.intros list_eq_refl)
+
+lemma append_end:
+  shows "(e # l) \<approx> (l @ [e])"
+  apply (induct l)
+  apply (auto intro: list_eq.intros list_eq_refl)
+  done
+
+lemma rev_rsp:
+  shows "a \<approx> rev a"
+  apply (induct a)
+  apply simp
+  apply (rule list_eq_refl)
+  apply simp_all
+  apply (rule list_eq.intros(6))
+  prefer 2
+  apply (rule append_rsp_fst)
+  apply assumption
+  apply (rule append_end)
+  done
+
+lemma append_sym_rsp:
+  shows "(a @ b) \<approx> (b @ a)"
+  apply (rule list_eq.intros(6))
+  apply (rule append_rsp_fst)
+  apply (rule rev_rsp)
+  apply (rule list_eq.intros(6))
+  apply (rule rev_rsp)
+  apply (simp)
+  apply (rule append_rsp_fst)
+  apply (rule list_eq.intros(3))
+  apply (rule rev_rsp)
+  done
+
+lemma append_rsp:
+  assumes a : "l1 \<approx> r1"
+  assumes b : "l2 \<approx> r2 "
+  shows "(l1 @ l2) \<approx> (r1 @ r2)"
+  apply (rule list_eq.intros(6))
+  apply (rule append_rsp_fst)
+  using a apply (assumption)
+  apply (rule list_eq.intros(6))
+  apply (rule append_sym_rsp)
+  apply (rule list_eq.intros(6))
+  apply (rule append_rsp_fst)
+  using b apply (assumption)
+  apply (rule append_sym_rsp)
+  done
+
+lemma ho_append_rsp[quotient_rsp]:
+  "(op \<approx> ===> op \<approx> ===> op \<approx>) op @ op @"
+  by (simp add: append_rsp)
+
+lemma map_rsp:
+  assumes a: "a \<approx> b"
+  shows "map f a \<approx> map f b"
+  using a
+  apply (induct)
+  apply(auto intro: list_eq.intros)
+  done
+
+lemma ho_map_rsp[quotient_rsp]:
+  "(op = ===> op \<approx> ===> op \<approx>) map map"
+  by (simp add: map_rsp)
+
+lemma map_append:
+  "(map f (a @ b)) \<approx> (map f a) @ (map f b)"
+ by simp (rule list_eq_refl)
+
+lemma ho_fold_rsp[quotient_rsp]:
+  "(op = ===> op = ===> op = ===> op \<approx> ===> op =) fold1 fold1"
+  apply (auto)
+  apply (case_tac "rsp_fold x")
+  prefer 2
+  apply (erule_tac list_eq.induct)
+  apply (simp_all)
+  apply (erule_tac list_eq.induct)
+  apply (simp_all)
+  apply (auto simp add: memb_rsp rsp_fold_def)
+done
+
+lemma list_equiv_rsp[quotient_rsp]:
+  shows "(op \<approx> ===> op \<approx> ===> op =) op \<approx> op \<approx>"
+by (auto intro: list_eq.intros)
+
+print_quotients
+
+ML {* val qty = @{typ "'a fset"} *}
+ML {* val rsp_thms =
+  @{thms ho_memb_rsp ho_cons_rsp ho_card1_rsp ho_map_rsp ho_append_rsp ho_fold_rsp} *}
+
+ML {* val (rty, rel, rel_refl, rel_eqv) = lookup_quot_data @{context} qty *}
+ML {* val (trans2, reps_same, absrep, quot) = lookup_quot_thms @{context} "fset"; *}
+ML {* fun lift_tac_fset lthy t = lift_tac lthy t *}
+
+lemma "IN x EMPTY = False"
+apply(tactic {* procedure_tac @{context} @{thm m1} 1 *})
+apply(tactic {* regularize_tac @{context} 1 *})
+apply(tactic {* all_inj_repabs_tac @{context} [rel_refl] [trans2] 1 *})
+apply(tactic {* clean_tac @{context} 1*})
+done
+
+lemma "IN x (INSERT y xa) = (x = y \<or> IN x xa)"
+by (tactic {* lift_tac_fset @{context} @{thm m2} 1 *})
+
+lemma "INSERT a (INSERT a x) = INSERT a x"
+apply (tactic {* lift_tac_fset @{context} @{thm list_eq.intros(4)} 1 *})
+done
+
+lemma "x = xa \<Longrightarrow> INSERT a x = INSERT a xa"
+apply (tactic {* lift_tac_fset @{context} @{thm list_eq.intros(5)} 1 *})
+done
+
+lemma "CARD x = Suc n \<Longrightarrow> (\<exists>a b. \<not> IN a b & x = INSERT a b)"
+apply (tactic {* lift_tac_fset @{context} @{thm card1_suc} 1 *})
+done
+
+lemma "(\<not> IN x xa) = (CARD (INSERT x xa) = Suc (CARD xa))"
+apply (tactic {* lift_tac_fset @{context} @{thm not_mem_card1} 1 *})
+done
+
+lemma "FOLD f g (z::'b) (INSERT a x) =
+  (if rsp_fold f then if IN a x then FOLD f g z x else f (g a) (FOLD f g z x) else z)"
+apply(tactic {* lift_tac_fset @{context} @{thm fold1.simps(2)} 1 *})
+done
+
+ML {* fun inj_repabs_tac_fset lthy = inj_repabs_tac lthy [rel_refl] [trans2] *}
+
+lemma "fmap f (FUNION (x::'b fset) (xa::'b fset)) = FUNION (fmap f x) (fmap f xa)"
+apply (tactic {* lift_tac_fset @{context} @{thm map_append} 1 *})
+done
+
+lemma "FUNION (FUNION x xa) xb = FUNION x (FUNION xa xb)"
+apply (tactic {* lift_tac_fset @{context} @{thm append_assoc} 1 *})
+done
+
+
+lemma "\<lbrakk>P EMPTY; \<And>a x. P x \<Longrightarrow> P (INSERT a x)\<rbrakk> \<Longrightarrow> P l"
+apply (tactic {* (ObjectLogic.full_atomize_tac THEN' gen_frees_tac @{context}) 1 *})
+apply(tactic {* procedure_tac @{context} @{thm list.induct} 1 *})
+apply(tactic {* regularize_tac @{context} 1 *})
+defer
+apply(tactic {* clean_tac @{context} 1 *})
+apply(tactic {* inj_repabs_tac_fset @{context} 1*})+
+done
+
+lemma list_induct_part:
+  assumes a: "P (x :: 'a list) ([] :: 'c list)"
+  assumes b: "\<And>e t. P x t \<Longrightarrow> P x (e # t)"
+  shows "P x l"
+  apply (rule_tac P="P x" in list.induct)
+  apply (rule a)
+  apply (rule b)
+  apply (assumption)
+  done
+
+ML {* quot *}
+thm quotient_thm
+
+lemma "P (x :: 'a list) (EMPTY :: 'c fset) \<Longrightarrow> (\<And>e t. P x t \<Longrightarrow> P x (INSERT e t)) \<Longrightarrow> P x l"
+apply (tactic {* lift_tac_fset @{context} @{thm list_induct_part} 1 *})
+done
+
+lemma "P (x :: 'a fset) (EMPTY :: 'c fset) \<Longrightarrow> (\<And>e t. P x t \<Longrightarrow> P x (INSERT e t)) \<Longrightarrow> P x l"
+apply (tactic {* lift_tac_fset @{context} @{thm list_induct_part} 1 *})
+done
+
+lemma "P (x :: 'a fset) ([] :: 'c list) \<Longrightarrow> (\<And>e t. P x t \<Longrightarrow> P x (e # t)) \<Longrightarrow> P x l"
+apply (tactic {* lift_tac_fset @{context} @{thm list_induct_part} 1 *})
+done
+
+quotient fset2 = "'a list" / "list_eq"
+  apply(rule equivp_list_eq)
+  done
+
+quotient_def
+  EMPTY2 :: "'a fset2"
+where
+  "EMPTY2 \<equiv> ([]::'a list)"
+
+quotient_def
+  INSERT2 :: "'a \<Rightarrow> 'a fset2 \<Rightarrow> 'a fset2"
+where
+  "INSERT2 \<equiv> op #"
+
+ML {* val quot = @{thms Quotient_fset Quotient_fset2} *}
+ML {* fun inj_repabs_tac_fset lthy = inj_repabs_tac lthy [rel_refl] [trans2] *}
+ML {* fun lift_tac_fset lthy t = lift_tac lthy t  *}
+
+lemma "P (x :: 'a fset2) (EMPTY :: 'c fset) \<Longrightarrow> (\<And>e t. P x t \<Longrightarrow> P x (INSERT e t)) \<Longrightarrow> P x l"
+apply (tactic {* lift_tac_fset @{context} @{thm list_induct_part} 1 *})
+done
+
+lemma "P (x :: 'a fset) (EMPTY2 :: 'c fset2) \<Longrightarrow> (\<And>e t. P x t \<Longrightarrow> P x (INSERT2 e t)) \<Longrightarrow> P x l"
+apply (tactic {* lift_tac_fset @{context} @{thm list_induct_part} 1 *})
+done
+
+quotient_def
+  fset_rec::"'a \<Rightarrow> ('b \<Rightarrow> 'b fset \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'b fset \<Rightarrow> 'a"
+where
+  "fset_rec \<equiv> list_rec"
+
+quotient_def
+  fset_case::"'a \<Rightarrow> ('b \<Rightarrow> 'b fset \<Rightarrow> 'a) \<Rightarrow> 'b fset \<Rightarrow> 'a"
+where
+  "fset_case \<equiv> list_case"
+
+(* Probably not true without additional assumptions about the function *)
+lemma list_rec_rsp[quotient_rsp]:
+  "(op = ===> (op = ===> op \<approx> ===> op =) ===> op \<approx> ===> op =) list_rec list_rec"
+  apply (auto)
+  apply (erule_tac list_eq.induct)
+  apply (simp_all)
+  sorry
+
+lemma list_case_rsp[quotient_rsp]:
+  "(op = ===> (op = ===> op \<approx> ===> op =) ===> op \<approx> ===> op =) list_case list_case"
+  apply (auto)
+  sorry
+
+ML {* val rsp_thms = @{thms list_rec_rsp list_case_rsp} @ rsp_thms *}
+ML {* fun lift_tac_fset lthy t = lift_tac lthy t *}
+
+lemma "fset_rec (f1::'t) x (INSERT a xa) = x a xa (fset_rec f1 x xa)"
+apply (tactic {* lift_tac_fset @{context} @{thm list.recs(2)} 1 *})
+done
+
+lemma "fset_case (f1::'t) f2 (INSERT a xa) = f2 a xa"
+apply (tactic {* lift_tac_fset @{context} @{thm list.cases(2)} 1 *})
+done
+
+
+end
diff -r 6088fea1c8b1 -r 8a1c8dc72b5c Quot/Examples/IntEx.thy
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Quot/Examples/IntEx.thy	Mon Dec 07 14:09:50 2009 +0100
@@ -0,0 +1,276 @@
+theory IntEx
+imports "../QuotMain"
+begin
+
+fun
+  intrel :: "(nat \<times> nat) \<Rightarrow> (nat \<times> nat) \<Rightarrow> bool" (infix "\<approx>" 50)
+where
+  "intrel (x, y) (u, v) = (x + v = u + y)"
+
+quotient my_int = "nat \<times> nat" / intrel
+  apply(unfold equivp_def)
+  apply(auto simp add: mem_def expand_fun_eq)
+  done
+
+thm quotient_equiv
+
+thm quotient_thm
+
+thm my_int_equivp
+
+print_theorems
+print_quotients
+
+quotient_def 
+  ZERO::"my_int"
+where
+  "ZERO \<equiv> (0::nat, 0::nat)"
+
+ML {* print_qconstinfo @{context} *}
+
+term ZERO
+thm ZERO_def
+
+ML {* prop_of @{thm ZERO_def} *}
+
+ML {* separate *}
+
+quotient_def 
+  ONE::"my_int"
+where
+  "ONE \<equiv> (1::nat, 0::nat)"
+
+ML {* print_qconstinfo @{context} *}
+
+term ONE
+thm ONE_def
+
+fun
+  my_plus :: "(nat \<times> nat) \<Rightarrow> (nat \<times> nat) \<Rightarrow> (nat \<times> nat)"
+where
+  "my_plus (x, y) (u, v) = (x + u, y + v)"
+
+quotient_def 
+  PLUS::"my_int \<Rightarrow> my_int \<Rightarrow> my_int"
+where
+  "PLUS \<equiv> my_plus"
+
+term my_plus
+term PLUS
+thm PLUS_def
+
+fun
+  my_neg :: "(nat \<times> nat) \<Rightarrow> (nat \<times> nat)"
+where
+  "my_neg (x, y) = (y, x)"
+
+quotient_def 
+  NEG::"my_int \<Rightarrow> my_int"
+where
+  "NEG \<equiv> my_neg"
+
+term NEG
+thm NEG_def
+
+definition
+  MINUS :: "my_int \<Rightarrow> my_int \<Rightarrow> my_int"
+where
+  "MINUS z w = PLUS z (NEG w)"
+
+fun
+  my_mult :: "(nat \<times> nat) \<Rightarrow> (nat \<times> nat) \<Rightarrow> (nat \<times> nat)"
+where
+  "my_mult (x, y) (u, v) = (x*u + y*v, x*v + y*u)"
+
+quotient_def 
+  MULT::"my_int \<Rightarrow> my_int \<Rightarrow> my_int"
+where
+  "MULT \<equiv> my_mult"
+
+term MULT
+thm MULT_def
+
+(* NOT SURE WETHER THIS DEFINITION IS CORRECT *)
+fun
+  my_le :: "(nat \<times> nat) \<Rightarrow> (nat \<times> nat) \<Rightarrow> bool"
+where
+  "my_le (x, y) (u, v) = (x+v \<le> u+y)"
+
+quotient_def 
+  LE :: "my_int \<Rightarrow> my_int \<Rightarrow> bool"
+where
+  "LE \<equiv> my_le"
+
+term LE
+thm LE_def
+
+
+definition
+  LESS :: "my_int \<Rightarrow> my_int \<Rightarrow> bool"
+where
+  "LESS z w = (LE z w \<and> z \<noteq> w)"
+
+term LESS
+thm LESS_def
+
+definition
+  ABS :: "my_int \<Rightarrow> my_int"
+where
+  "ABS i = (if (LESS i ZERO) then (NEG i) else i)"
+
+definition
+  SIGN :: "my_int \<Rightarrow> my_int"
+where
+ "SIGN i = (if i = ZERO then ZERO else if (LESS ZERO i) then ONE else (NEG ONE))"
+
+ML {* print_qconstinfo @{context} *}
+
+lemma plus_sym_pre:
+  shows "my_plus a b \<approx> my_plus b a"
+  apply(cases a)
+  apply(cases b)
+  apply(auto)
+  done
+
+lemma plus_rsp[quotient_rsp]:
+  shows "(intrel ===> intrel ===> intrel) my_plus my_plus"
+by (simp)
+
+ML {* val qty = @{typ "my_int"} *}
+ML {* val (rty, rel, rel_refl, rel_eqv) = lookup_quot_data @{context} qty *}
+ML {* val (trans2, reps_same, absrep, quot) = lookup_quot_thms @{context} "my_int"; *}
+
+ML {* fun lift_tac_intex lthy t = lift_tac lthy t *}
+
+ML {* fun inj_repabs_tac_intex lthy = inj_repabs_tac lthy [rel_refl] [trans2] *}
+ML {* fun all_inj_repabs_tac_intex lthy = all_inj_repabs_tac lthy [rel_refl] [trans2] *}
+
+lemma test1: "my_plus a b = my_plus a b"
+apply(rule refl)
+done
+
+lemma "PLUS a b = PLUS a b"
+apply(tactic {* procedure_tac @{context} @{thm test1} 1 *})
+apply(tactic {* regularize_tac @{context} 1 *})
+apply(tactic {* all_inj_repabs_tac_intex @{context} 1*})
+apply(tactic {* clean_tac @{context} 1 *}) 
+done
+
+thm lambda_prs
+
+lemma test2: "my_plus a = my_plus a"
+apply(rule refl)
+done
+
+lemma "PLUS a = PLUS a"
+apply(tactic {* procedure_tac @{context} @{thm test2} 1 *})
+apply(rule ballI)
+apply(rule apply_rsp[OF Quotient_my_int plus_rsp])
+apply(simp only: in_respects)
+apply(tactic {* all_inj_repabs_tac_intex @{context} 1*})
+apply(tactic {* clean_tac @{context} 1 *})
+done
+
+lemma test3: "my_plus = my_plus"
+apply(rule refl)
+done
+
+lemma "PLUS = PLUS"
+apply(tactic {* procedure_tac @{context} @{thm test3} 1 *})
+apply(rule plus_rsp)
+apply(tactic {* all_inj_repabs_tac_intex @{context} 1*})
+apply(tactic {* clean_tac @{context} 1 *})
+done
+
+
+lemma "PLUS a b = PLUS b a"
+apply(tactic {* procedure_tac @{context} @{thm plus_sym_pre} 1 *})
+apply(tactic {* regularize_tac @{context} 1 *})
+apply(tactic {* all_inj_repabs_tac_intex @{context} 1*})
+apply(tactic {* clean_tac @{context} 1 *})
+done
+
+lemma plus_assoc_pre:
+  shows "my_plus (my_plus i j) k \<approx> my_plus i (my_plus j k)"
+  apply (cases i)
+  apply (cases j)
+  apply (cases k)
+  apply (simp)
+  done
+
+lemma plus_assoc: "PLUS (PLUS x xa) xb = PLUS x (PLUS xa xb)"
+apply(tactic {* procedure_tac @{context} @{thm plus_assoc_pre} 1 *})
+apply(tactic {* regularize_tac @{context} 1 *})
+apply(tactic {* all_inj_repabs_tac_intex @{context} 1*})
+apply(tactic {* clean_tac @{context} 1 *})
+done
+
+lemma ho_tst: "foldl my_plus x [] = x"
+apply simp
+done
+
+lemma "foldl PLUS x [] = x"
+apply(tactic {* procedure_tac @{context} @{thm ho_tst} 1 *})
+apply(tactic {* regularize_tac @{context} 1 *})
+apply(tactic {* all_inj_repabs_tac_intex @{context} 1*})
+apply(tactic {* clean_tac @{context} 1 *})
+apply(simp only: foldl_prs[OF Quotient_my_int Quotient_my_int] nil_prs[OF Quotient_my_int])
+done
+
+lemma ho_tst2: "foldl my_plus x (h # t) \<approx> my_plus h (foldl my_plus x t)"
+sorry
+
+lemma "foldl PLUS x (h # t) = PLUS h (foldl PLUS x t)"
+apply(tactic {* procedure_tac @{context} @{thm ho_tst2} 1 *})
+apply(tactic {* regularize_tac @{context} 1 *})
+apply(tactic {* all_inj_repabs_tac_intex @{context} 1*})
+apply(tactic {* clean_tac @{context} 1 *})
+apply(simp only: foldl_prs[OF Quotient_my_int Quotient_my_int] cons_prs[OF Quotient_my_int])
+done
+
+lemma ho_tst3: "foldl f (s::nat \<times> nat) ([]::(nat \<times> nat) list) = s"
+by simp
+
+lemma "foldl f (x::my_int) ([]::my_int list) = x"
+apply(tactic {* procedure_tac @{context} @{thm ho_tst3} 1 *})
+apply(tactic {* regularize_tac @{context} 1 *})
+apply(tactic {* all_inj_repabs_tac_intex @{context} 1*})
+(* TODO: does not work when this is added *)
+(* apply(tactic {* lambda_prs_tac @{context} 1 *})*)
+apply(tactic {* clean_tac @{context} 1 *})
+apply(simp only: foldl_prs[OF Quotient_my_int Quotient_my_int] nil_prs[OF Quotient_my_int])
+done
+
+lemma lam_tst: "(\<lambda>x. (x, x)) y = (y, (y :: nat \<times> nat))"
+by simp
+
+lemma "(\<lambda>x. (x, x)) (y::my_int) = (y, y)"
+apply(tactic {* procedure_tac @{context} @{thm lam_tst} 1 *})
+apply(tactic {* regularize_tac @{context} 1 *})
+apply(tactic {* all_inj_repabs_tac_intex @{context} 1*})
+apply(tactic {* clean_tac @{context} 1 *})
+apply(simp add: pair_prs)
+done
+
+lemma lam_tst2: "(\<lambda>(y :: nat \<times> nat). y) = (\<lambda>(x :: nat \<times> nat). x)"
+by simp
+
+
+
+
+lemma "(\<lambda>(y :: my_int). y) = (\<lambda>(x :: my_int). x)"
+apply(tactic {* procedure_tac @{context} @{thm lam_tst2} 1 *})
+defer
+apply(tactic {* all_inj_repabs_tac_intex @{context} 1*})
+(*apply(tactic {* lambda_prs_tac  @{context} 1 *})*)
+sorry
+
+lemma lam_tst3: "(\<lambda>(y :: nat \<times> nat \<Rightarrow> nat \<times> nat). y) = (\<lambda>(x :: nat \<times> nat \<Rightarrow> nat \<times> nat). x)"
+by auto
+
+lemma "(\<lambda>(y :: my_int \<Rightarrow> my_int). y) = (\<lambda>(x :: my_int \<Rightarrow> my_int). x)"
+apply(tactic {* procedure_tac @{context} @{thm lam_tst3} 1 *})
+defer
+apply(tactic {* all_inj_repabs_tac_intex @{context} 1*})
+apply(tactic {* lambda_prs_tac  @{context} 1 *})
+sorry
diff -r 6088fea1c8b1 -r 8a1c8dc72b5c Quot/Examples/IntEx2.thy
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Quot/Examples/IntEx2.thy	Mon Dec 07 14:09:50 2009 +0100
@@ -0,0 +1,436 @@
+theory IntEx2
+imports "../QuotMain"
+uses
+  ("Tools/numeral.ML")
+  ("Tools/numeral_syntax.ML")
+  ("Tools/int_arith.ML")
+begin
+
+
+fun
+  intrel :: "(nat \<times> nat) \<Rightarrow> (nat \<times> nat) \<Rightarrow> bool" (infix "\<approx>" 50)
+where
+  "intrel (x, y) (u, v) = (x + v = u + y)"
+
+quotient int = "nat \<times> nat" / intrel
+  apply(unfold equivp_def)
+  apply(auto simp add: mem_def expand_fun_eq)
+  done
+
+instantiation int :: "{zero, one, plus, minus, uminus, times, ord, abs, sgn}"
+begin
+
+quotient_def 
+  zero_qnt::"int"
+where
+  "zero_qnt \<equiv> (0::nat, 0::nat)"
+
+definition  Zero_int_def[code del]: 
+  "0 = zero_qnt"
+
+quotient_def 
+  one_qnt::"int"
+where
+  "one_qnt \<equiv> (1::nat, 0::nat)"
+
+definition One_int_def[code del]:
+  "1 = one_qnt"
+
+fun
+  plus_raw :: "(nat \<times> nat) \<Rightarrow> (nat \<times> nat) \<Rightarrow> (nat \<times> nat)"
+where
+  "plus_raw (x, y) (u, v) = (x + u, y + v)"
+
+quotient_def 
+  plus_qnt::"int \<Rightarrow> int \<Rightarrow> int"
+where
+  "plus_qnt \<equiv> plus_raw"
+
+definition add_int_def[code del]:
+  "z + w = plus_qnt z w"
+
+fun
+  minus_raw :: "(nat \<times> nat) \<Rightarrow> (nat \<times> nat)"
+where
+  "minus_raw (x, y) = (y, x)"
+
+quotient_def
+  minus_qnt::"int \<Rightarrow> int"
+where
+  "minus_qnt \<equiv> minus_raw"
+
+definition minus_int_def [code del]:
+    "- z = minus_qnt z"
+
+definition
+  diff_int_def [code del]:  "z - w = z + (-w::int)"
+
+fun
+  mult_raw :: "(nat \<times> nat) \<Rightarrow> (nat \<times> nat) \<Rightarrow> (nat \<times> nat)"
+where
+  "mult_raw (x, y) (u, v) = (x*u + y*v, x*v + y*u)"
+
+quotient_def 
+  mult_qnt::"int \<Rightarrow> int \<Rightarrow> int"
+where
+  "mult_qnt \<equiv> mult_raw"
+
+definition
+  mult_int_def [code del]: "z * w = mult_qnt z w"
+
+fun
+  le_raw :: "(nat \<times> nat) \<Rightarrow> (nat \<times> nat) \<Rightarrow> bool"
+where
+  "le_raw (x, y) (u, v) = (x+v \<le> u+y)"
+
+quotient_def 
+  le_qnt :: "int \<Rightarrow> int \<Rightarrow> bool"
+where
+  "le_qnt \<equiv> le_raw"
+
+definition
+  le_int_def [code del]:
+   "z \<le> w = le_qnt z w"
+
+definition
+  less_int_def [code del]: "(z\<Colon>int) < w = (z \<le> w \<and> z \<noteq> w)"
+
+definition
+  zabs_def: "\<bar>i\<Colon>int\<bar> = (if i < 0 then - i else i)"
+
+definition
+  zsgn_def: "sgn (i\<Colon>int) = (if i=0 then 0 else if 0<i then 1 else - 1)"
+
+instance ..
+
+end
+
+thm add_assoc
+
+lemma plus_raw_rsp[quotient_rsp]:
+  shows "(op \<approx> ===> op \<approx> ===> op \<approx>) plus_raw plus_raw"
+by auto
+
+lemma minus_raw_rsp[quotient_rsp]:
+  shows "(op \<approx> ===> op \<approx>) minus_raw minus_raw"
+  by auto
+
+lemma mult_raw_rsp[quotient_rsp]:
+  shows "(op \<approx> ===> op \<approx> ===> op \<approx>) mult_raw mult_raw"
+apply(auto)
+apply(simp add: mult algebra_simps)
+sorry
+
+lemma le_raw_rsp[quotient_rsp]:
+  shows "(op \<approx> ===> op \<approx> ===> op =) le_raw le_raw"
+by auto
+
+lemma plus_assoc_raw:
+  shows "plus_raw (plus_raw i j) k \<approx> plus_raw i (plus_raw j k)"
+by (cases i, cases j, cases k) (simp)
+
+lemma plus_sym_raw:
+  shows "plus_raw i j \<approx> plus_raw j i"
+by (cases i, cases j) (simp)
+
+lemma plus_zero_raw:
+  shows "plus_raw  (0, 0) i \<approx> i"
+by (cases i) (simp)
+
+lemma plus_minus_zero_raw:
+  shows "plus_raw (minus_raw i) i \<approx> (0, 0)"
+by (cases i) (simp)
+
+lemma mult_assoc_raw:
+  shows "mult_raw (mult_raw i j) k \<approx> mult_raw i (mult_raw j k)"
+by (cases i, cases j, cases k) 
+   (simp add: mult algebra_simps)
+
+lemma mult_sym_raw:
+  shows "mult_raw i j \<approx> mult_raw j i"
+by (cases i, cases j) (simp)
+
+lemma mult_one_raw:
+  shows "mult_raw  (1, 0) i \<approx> i"
+by (cases i) (simp)
+
+lemma mult_plus_comm_raw:
+  shows "mult_raw (plus_raw i j) k \<approx> plus_raw (mult_raw i k) (mult_raw j k)"
+by (cases i, cases j, cases k) 
+   (simp add: mult algebra_simps)
+
+lemma one_zero_distinct:
+  shows "\<not> (0, 0) \<approx> ((1::nat), (0::nat))"
+  by simp
+
+text{*The integers form a @{text comm_ring_1}*}
+
+
+ML {* val qty = @{typ "int"} *}
+ML {* val (rty, rel, rel_refl, rel_eqv) = lookup_quot_data @{context} qty *}
+ML {* val (trans2, reps_same, absrep, quot) = lookup_quot_thms @{context} "int" *}
+
+instance int :: comm_ring_1
+proof
+  fix i j k :: int
+  show "(i + j) + k = i + (j + k)"
+    unfolding add_int_def
+    apply(tactic {* lift_tac @{context} @{thm plus_assoc_raw} 1 *})
+    done
+  show "i + j = j + i" 
+    unfolding add_int_def
+    apply(tactic {* lift_tac @{context} @{thm plus_sym_raw} 1 *})
+    done
+  show "0 + i = (i::int)"
+    unfolding add_int_def Zero_int_def 
+    apply(tactic {* lift_tac @{context} @{thm plus_zero_raw} 1 *})
+    done
+  show "- i + i = 0"
+    unfolding add_int_def minus_int_def Zero_int_def 
+    apply(tactic {* lift_tac @{context} @{thm plus_minus_zero_raw} 1 *})
+    done
+  show "i - j = i + - j"
+    by (simp add: diff_int_def)
+  show "(i * j) * k = i * (j * k)"
+    unfolding mult_int_def 
+    apply(tactic {* lift_tac @{context} @{thm mult_assoc_raw} 1 *})
+    done
+  show "i * j = j * i"
+    unfolding mult_int_def 
+    apply(tactic {* lift_tac @{context} @{thm mult_sym_raw} 1 *})
+    done
+  show "1 * i = i"
+    unfolding mult_int_def One_int_def
+    apply(tactic {* lift_tac @{context} @{thm mult_one_raw} 1 *})
+    done
+  show "(i + j) * k = i * k + j * k"
+    unfolding mult_int_def add_int_def
+    apply(tactic {* lift_tac @{context} @{thm mult_plus_comm_raw} 1 *})
+    done
+  show "0 \<noteq> (1::int)"
+    unfolding Zero_int_def One_int_def
+    apply(tactic {* lift_tac @{context} @{thm one_zero_distinct} 1 *})
+    done
+qed
+
+term of_nat
+thm of_nat_def
+
+lemma int_def: "of_nat m = ABS_int (m, 0)"
+apply(induct m) 
+apply(simp add: Zero_int_def zero_qnt_def)
+apply(simp)
+apply(simp add: add_int_def One_int_def)
+apply(simp add: plus_qnt_def one_qnt_def)
+oops
+
+lemma le_antisym_raw:
+  shows "le_raw i j \<Longrightarrow> le_raw j i \<Longrightarrow> i \<approx> j"
+by (cases i, cases j) (simp)
+
+lemma le_refl_raw:
+  shows "le_raw i i"
+by (cases i) (simp)
+
+lemma le_trans_raw:
+  shows "le_raw i j \<Longrightarrow> le_raw j k \<Longrightarrow> le_raw i k"
+by (cases i, cases j, cases k) (simp)
+
+lemma le_cases_raw:
+  shows "le_raw i j \<or> le_raw j i"
+by (cases i, cases j) 
+   (simp add: linorder_linear)
+
+instance int :: linorder
+proof
+  fix i j k :: int
+  show antisym: "i \<le> j \<Longrightarrow> j \<le> i \<Longrightarrow> i = j"
+    unfolding le_int_def
+    apply(tactic {* lift_tac @{context} @{thm le_antisym_raw} 1 *})
+    done
+  show "(i < j) = (i \<le> j \<and> \<not> j \<le> i)"
+    by (auto simp add: less_int_def dest: antisym) 
+  show "i \<le> i"
+    unfolding le_int_def
+    apply(tactic {* lift_tac @{context} @{thm le_refl_raw} 1 *})
+    done
+  show "i \<le> j \<Longrightarrow> j \<le> k \<Longrightarrow> i \<le> k"
+    unfolding le_int_def
+    apply(tactic {* lift_tac @{context} @{thm le_trans_raw} 1 *})
+    done
+  show "i \<le> j \<or> j \<le> i"
+    unfolding le_int_def
+    apply(tactic {* lift_tac @{context} @{thm le_cases_raw} 1 *})
+    done
+qed
+
+instantiation int :: distrib_lattice
+begin
+
+definition
+  "(inf \<Colon> int \<Rightarrow> int \<Rightarrow> int) = min"
+
+definition
+  "(sup \<Colon> int \<Rightarrow> int \<Rightarrow> int) = max"
+
+instance
+  by intro_classes
+    (auto simp add: inf_int_def sup_int_def min_max.sup_inf_distrib1)
+
+end
+
+lemma le_plus_raw:
+  shows "le_raw i j \<Longrightarrow> le_raw (plus_raw k i) (plus_raw k j)"
+by (cases i, cases j, cases k) (simp)
+
+
+instance int :: pordered_cancel_ab_semigroup_add
+proof
+  fix i j k :: int
+  show "i \<le> j \<Longrightarrow> k + i \<le> k + j"
+    unfolding le_int_def add_int_def
+    apply(tactic {* lift_tac @{context} @{thm le_plus_raw} 1 *})
+    done
+qed
+
+lemma test:
+  "\<lbrakk>le_raw i j \<and> \<not>i \<approx> j; le_raw (0, 0) k \<and> \<not>(0, 0) \<approx> k\<rbrakk>
+    \<Longrightarrow> le_raw (mult_raw k i) (mult_raw k j) \<and> \<not>mult_raw k i \<approx> mult_raw k j"
+apply(cases i, cases j, cases k)
+apply(auto simp add: mult algebra_simps)
+sorry
+
+
+text{*The integers form an ordered integral domain*}
+instance int :: ordered_idom
+proof
+  fix i j k :: int
+  show "i < j \<Longrightarrow> 0 < k \<Longrightarrow> k * i < k * j"
+    unfolding mult_int_def le_int_def less_int_def Zero_int_def
+    apply(tactic {* lift_tac @{context} @{thm test} 1 *})
+    done
+  show "\<bar>i\<bar> = (if i < 0 then -i else i)"
+    by (simp only: zabs_def)
+  show "sgn (i\<Colon>int) = (if i=0 then 0 else if 0<i then 1 else - 1)"
+    by (simp only: zsgn_def)
+qed
+
+instance int :: lordered_ring
+proof  
+  fix k :: int
+  show "abs k = sup k (- k)"
+    by (auto simp add: sup_int_def zabs_def less_minus_self_iff [symmetric])
+qed
+
+lemmas int_distrib =
+  left_distrib [of "z1::int" "z2" "w", standard]
+  right_distrib [of "w::int" "z1" "z2", standard]
+  left_diff_distrib [of "z1::int" "z2" "w", standard]
+  right_diff_distrib [of "w::int" "z1" "z2", standard]
+
+
+subsection {* Embedding of the Integers into any @{text ring_1}: @{text of_int}*}
+
+(*
+context ring_1
+begin
+
+ 
+definition 
+  of_int :: "int \<Rightarrow> 'a" 
+where
+  "of_int 
+*)
+
+
+subsection {* Binary representation *}
+
+text {*
+  This formalization defines binary arithmetic in terms of the integers
+  rather than using a datatype. This avoids multiple representations (leading
+  zeroes, etc.)  See @{text "ZF/Tools/twos-compl.ML"}, function @{text
+  int_of_binary}, for the numerical interpretation.
+
+  The representation expects that @{text "(m mod 2)"} is 0 or 1,
+  even if m is negative;
+  For instance, @{text "-5 div 2 = -3"} and @{text "-5 mod 2 = 1"}; thus
+  @{text "-5 = (-3)*2 + 1"}.
+  
+  This two's complement binary representation derives from the paper 
+  "An Efficient Representation of Arithmetic for Term Rewriting" by
+  Dave Cohen and Phil Watson, Rewriting Techniques and Applications,
+  Springer LNCS 488 (240-251), 1991.
+*}
+
+subsubsection {* The constructors @{term Bit0}, @{term Bit1}, @{term Pls} and @{term Min} *}
+
+definition
+  Pls :: int where
+  [code del]: "Pls = 0"
+
+definition
+  Min :: int where
+  [code del]: "Min = - 1"
+
+definition
+  Bit0 :: "int \<Rightarrow> int" where
+  [code del]: "Bit0 k = k + k"
+
+definition
+  Bit1 :: "int \<Rightarrow> int" where
+  [code del]: "Bit1 k = 1 + k + k"
+
+class number = -- {* for numeric types: nat, int, real, \dots *}
+  fixes number_of :: "int \<Rightarrow> 'a"
+
+use "~~/src/HOL/Tools/numeral.ML"
+
+syntax
+  "_Numeral" :: "num_const \<Rightarrow> 'a"    ("_")
+
+use "~~/src/HOL/Tools/numeral_syntax.ML"
+(*
+setup NumeralSyntax.setup
+
+abbreviation
+  "Numeral0 \<equiv> number_of Pls"
+
+abbreviation
+  "Numeral1 \<equiv> number_of (Bit1 Pls)"
+
+lemma Let_number_of [simp]: "Let (number_of v) f = f (number_of v)"
+  -- {* Unfold all @{text let}s involving constants *}
+  unfolding Let_def ..
+
+definition
+  succ :: "int \<Rightarrow> int" where
+  [code del]: "succ k = k + 1"
+
+definition
+  pred :: "int \<Rightarrow> int" where
+  [code del]: "pred k = k - 1"
+
+lemmas
+  max_number_of [simp] = max_def
+    [of "number_of u" "number_of v", standard, simp]
+and
+  min_number_of [simp] = min_def 
+    [of "number_of u" "number_of v", standard, simp]
+  -- {* unfolding @{text minx} and @{text max} on numerals *}
+
+lemmas numeral_simps = 
+  succ_def pred_def Pls_def Min_def Bit0_def Bit1_def
+
+text {* Removal of leading zeroes *}
+
+lemma Bit0_Pls [simp, code_post]:
+  "Bit0 Pls = Pls"
+  unfolding numeral_simps by simp
+
+lemma Bit1_Min [simp, code_post]:
+  "Bit1 Min = Min"
+  unfolding numeral_simps by simp
+
+lemmas normalize_bin_simps =
+  Bit0_Pls Bit1_Min
+*)
\ No newline at end of file
diff -r 6088fea1c8b1 -r 8a1c8dc72b5c Quot/Examples/LFex.thy
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Quot/Examples/LFex.thy	Mon Dec 07 14:09:50 2009 +0100
@@ -0,0 +1,307 @@
+theory LFex
+imports Nominal "../QuotMain"
+begin
+
+atom_decl name ident
+
+nominal_datatype kind = 
+    Type
+  | KPi "ty" "name" "kind"
+and ty =  
+    TConst "ident"
+  | TApp "ty" "trm"
+  | TPi "ty" "name" "ty"
+and trm = 
+    Const "ident"
+  | Var "name"
+  | App "trm" "trm"
+  | Lam "ty" "name" "trm" 
+
+function
+    fv_kind :: "kind \<Rightarrow> name set"
+and fv_ty   :: "ty \<Rightarrow> name set"
+and fv_trm  :: "trm \<Rightarrow> name set"
+where
+  "fv_kind (Type) = {}"
+| "fv_kind (KPi A x K) = (fv_ty A) \<union> ((fv_kind K) - {x})"
+| "fv_ty (TConst i) = {}"
+| "fv_ty (TApp A M) = (fv_ty A) \<union> (fv_trm M)"
+| "fv_ty (TPi A x B) = (fv_ty A) \<union> ((fv_ty B) - {x})"
+| "fv_trm (Const i) = {}"
+| "fv_trm (Var x) = {x}"
+| "fv_trm (App M N) = (fv_trm M) \<union> (fv_trm N)"
+| "fv_trm (Lam A x M) = (fv_ty A) \<union> ((fv_trm M) - {x})"
+sorry
+
+termination fv_kind sorry
+
+inductive
+    akind :: "kind \<Rightarrow> kind \<Rightarrow> bool" ("_ \<approx>ki _" [100, 100] 100)
+and aty   :: "ty \<Rightarrow> ty \<Rightarrow> bool"     ("_ \<approx>ty _" [100, 100] 100)
+and atrm  :: "trm \<Rightarrow> trm \<Rightarrow> bool"   ("_ \<approx>tr _" [100, 100] 100)
+where
+  a1:  "(Type) \<approx>ki (Type)"
+| a21: "\<lbrakk>A \<approx>ty A'; K \<approx>ki K'\<rbrakk> \<Longrightarrow> (KPi A x K) \<approx>ki (KPi A' x K')"
+| a22: "\<lbrakk>A \<approx>ty A'; K \<approx>ki ([(x,x')]\<bullet>K'); x \<notin> (fv_ty A'); x \<notin> ((fv_kind K') - {x'})\<rbrakk> 
+        \<Longrightarrow> (KPi A x K) \<approx>ki (KPi A' x' K')"
+| a3:  "i = j \<Longrightarrow> (TConst i) \<approx>ty (TConst j)"
+| a4:  "\<lbrakk>A \<approx>ty A'; M \<approx>tr M'\<rbrakk> \<Longrightarrow> (TApp A M) \<approx>ty (TApp A' M')"
+| a51: "\<lbrakk>A \<approx>ty A'; B \<approx>ty B'\<rbrakk> \<Longrightarrow> (TPi A x B) \<approx>ty (TPi A' x B')"
+| a52: "\<lbrakk>A \<approx>ty A'; B \<approx>ty ([(x,x')]\<bullet>B'); x \<notin> (fv_ty B'); x \<notin> ((fv_ty B') - {x'})\<rbrakk> 
+        \<Longrightarrow> (TPi A x B) \<approx>ty (TPi A' x' B')"
+| a6:  "i = j \<Longrightarrow> (Const i) \<approx>trm (Const j)"
+| a7:  "x = y \<Longrightarrow> (Var x) \<approx>trm (Var y)"
+| a8:  "\<lbrakk>M \<approx>trm M'; N \<approx>tr N'\<rbrakk> \<Longrightarrow> (App M N) \<approx>tr (App M' N')"
+| a91: "\<lbrakk>A \<approx>ty A'; M \<approx>tr M'\<rbrakk> \<Longrightarrow> (Lam A x M) \<approx>tr (Lam A' x M')"
+| a92: "\<lbrakk>A \<approx>ty A'; M \<approx>tr ([(x,x')]\<bullet>M'); x \<notin> (fv_ty B'); x \<notin> ((fv_trm M') - {x'})\<rbrakk> 
+        \<Longrightarrow> (Lam A x M) \<approx>tr (Lam A' x' M')"
+
+lemma al_refl:
+  fixes K::"kind" 
+  and   A::"ty"
+  and   M::"trm"
+  shows "K \<approx>ki K"
+  and   "A \<approx>ty A"
+  and   "M \<approx>tr M"
+  apply(induct K and A and M rule: kind_ty_trm.inducts)
+  apply(auto intro: akind_aty_atrm.intros)
+  done
+
+lemma alpha_equivps:
+  shows "equivp akind"
+  and   "equivp aty"
+  and   "equivp atrm"
+sorry
+
+quotient KIND = kind / akind
+  by (rule alpha_equivps)
+
+quotient TY = ty / aty
+   and   TRM = trm / atrm
+  by (auto intro: alpha_equivps)
+
+print_quotients
+
+quotient_def 
+  TYP :: "KIND"
+where
+  "TYP \<equiv> Type"
+
+quotient_def 
+  KPI :: "TY \<Rightarrow> name \<Rightarrow> KIND \<Rightarrow> KIND"
+where
+  "KPI \<equiv> KPi"
+
+quotient_def 
+  TCONST :: "ident \<Rightarrow> TY"
+where
+  "TCONST \<equiv> TConst"
+
+quotient_def 
+  TAPP :: "TY \<Rightarrow> TRM \<Rightarrow> TY"
+where
+  "TAPP \<equiv> TApp"
+
+quotient_def 
+  TPI :: "TY \<Rightarrow> name \<Rightarrow> TY \<Rightarrow> TY"
+where
+  "TPI \<equiv> TPi"
+
+(* FIXME: does not work with CONST *)
+quotient_def 
+  CONS :: "ident \<Rightarrow> TRM"
+where
+  "CONS \<equiv> Const"
+
+quotient_def 
+  VAR :: "name \<Rightarrow> TRM"
+where
+  "VAR \<equiv> Var"
+
+quotient_def 
+  APP :: "TRM \<Rightarrow> TRM \<Rightarrow> TRM"
+where
+  "APP \<equiv> App"
+
+quotient_def 
+  LAM :: "TY \<Rightarrow> name \<Rightarrow> TRM \<Rightarrow> TRM"
+where
+  "LAM \<equiv> Lam"
+
+thm TYP_def
+thm KPI_def
+thm TCONST_def
+thm TAPP_def
+thm TPI_def
+thm VAR_def
+thm CONS_def
+thm APP_def
+thm LAM_def
+
+(* FIXME: print out a warning if the type contains a liftet type, like kind \<Rightarrow> name set *)
+quotient_def 
+  FV_kind :: "KIND \<Rightarrow> name set"
+where
+  "FV_kind \<equiv> fv_kind"
+
+quotient_def 
+  FV_ty :: "TY \<Rightarrow> name set"
+where
+  "FV_ty \<equiv> fv_ty"
+
+quotient_def 
+  FV_trm :: "TRM \<Rightarrow> name set"
+where
+  "FV_trm \<equiv> fv_trm"
+
+thm FV_kind_def
+thm FV_ty_def
+thm FV_trm_def
+
+(* FIXME: does not work yet *)
+overloading
+    perm_kind \<equiv> "perm :: 'x prm \<Rightarrow> KIND \<Rightarrow> KIND"   (unchecked)
+    perm_ty   \<equiv> "perm :: 'x prm \<Rightarrow> TY \<Rightarrow> TY"       (unchecked)
+    perm_trm  \<equiv> "perm :: 'x prm \<Rightarrow> TRM \<Rightarrow> TRM"     (unchecked) 
+begin
+
+quotient_def 
+  perm_kind :: "'x prm \<Rightarrow> KIND \<Rightarrow> KIND"
+where
+  "perm_kind \<equiv> (perm::'x prm \<Rightarrow> kind \<Rightarrow> kind)"
+
+quotient_def 
+  perm_ty :: "'x prm \<Rightarrow> TY \<Rightarrow> TY"
+where
+  "perm_ty \<equiv> (perm::'x prm \<Rightarrow> ty \<Rightarrow> ty)"
+
+quotient_def 
+  perm_trm :: "'x prm \<Rightarrow> TRM \<Rightarrow> TRM"
+where
+  "perm_trm \<equiv> (perm::'x prm \<Rightarrow> trm \<Rightarrow> trm)"
+
+(* TODO/FIXME: Think whether these RSP theorems are true. *)
+lemma kpi_rsp[quotient_rsp]: 
+  "(aty ===> op = ===> akind ===> akind) KPi KPi" sorry
+lemma tconst_rsp[quotient_rsp]: 
+  "(op = ===> aty) TConst TConst" sorry
+lemma tapp_rsp[quotient_rsp]: 
+  "(aty ===> atrm ===> aty) TApp TApp" sorry
+lemma tpi_rsp[quotient_rsp]: 
+  "(aty ===> op = ===> aty ===> aty) TPi TPi" sorry
+lemma var_rsp[quotient_rsp]: 
+  "(op = ===> atrm) Var Var" sorry
+lemma app_rsp[quotient_rsp]: 
+  "(atrm ===> atrm ===> atrm) App App" sorry
+lemma const_rsp[quotient_rsp]: 
+  "(op = ===> atrm) Const Const" sorry
+lemma lam_rsp[quotient_rsp]: 
+  "(aty ===> op = ===> atrm ===> atrm) Lam Lam" sorry
+
+lemma perm_kind_rsp[quotient_rsp]: 
+  "(op = ===> akind ===> akind) op \<bullet> op \<bullet>" sorry
+lemma perm_ty_rsp[quotient_rsp]: 
+  "(op = ===> aty ===> aty) op \<bullet> op \<bullet>" sorry
+lemma perm_trm_rsp[quotient_rsp]: 
+  "(op = ===> atrm ===> atrm) op \<bullet> op \<bullet>" sorry
+
+lemma fv_ty_rsp[quotient_rsp]: 
+  "(aty ===> op =) fv_ty fv_ty" sorry
+lemma fv_kind_rsp[quotient_rsp]: 
+  "(akind ===> op =) fv_kind fv_kind" sorry
+lemma fv_trm_rsp[quotient_rsp]: 
+  "(atrm ===> op =) fv_trm fv_trm" sorry
+
+
+thm akind_aty_atrm.induct
+thm kind_ty_trm.induct
+
+ML {*
+  val quot = @{thms Quotient_KIND Quotient_TY Quotient_TRM}
+  val rel_refl = map (fn x => @{thm equivp_reflp} OF [x]) @{thms alpha_equivps}
+  val reps_same = map (fn x => @{thm Quotient_rel_rep} OF [x]) quot
+  val trans2 = map (fn x => @{thm equals_rsp} OF [x]) quot
+*}
+
+lemma 
+  assumes a0:
+  "P1 TYP TYP"
+  and a1: 
+  "\<And>A A' K K' x. \<lbrakk>(A::TY) = A'; P2 A A'; (K::KIND) = K'; P1 K K'\<rbrakk> 
+  \<Longrightarrow> P1 (KPI A x K) (KPI A' x K')"
+  and a2:    
+  "\<And>A A' K K' x x'. \<lbrakk>(A ::TY) = A'; P2 A A'; (K :: KIND) = ([(x, x')] \<bullet> K'); P1 K ([(x, x')] \<bullet> K'); 
+    x \<notin> FV_ty A'; x \<notin> FV_kind K' - {x'}\<rbrakk> \<Longrightarrow> P1 (KPI A x K) (KPI A' x' K')"
+  and a3: 
+  "\<And>i j. i = j \<Longrightarrow> P2 (TCONST i) (TCONST j)"
+  and a4:
+  "\<And>A A' M M'. \<lbrakk>(A ::TY) = A'; P2 A A'; (M :: TRM) = M'; P3 M M'\<rbrakk> \<Longrightarrow> P2 (TAPP A M) (TAPP A' M')"
+  and a5:
+  "\<And>A A' B B' x. \<lbrakk>(A ::TY) = A'; P2 A A'; (B ::TY) = B'; P2 B B'\<rbrakk> \<Longrightarrow> P2 (TPI A x B) (TPI A' x B')"
+  and a6:
+  "\<And>A A' B x x' B'. \<lbrakk>(A ::TY) = A'; P2 A A'; (B ::TY) = ([(x, x')] \<bullet> B'); P2 B ([(x, x')] \<bullet> B'); 
+  x \<notin> FV_ty B'; x \<notin> FV_ty B' - {x'}\<rbrakk> \<Longrightarrow> P2 (TPI A x B) (TPI A' x' B')"
+  and a7:
+  "\<And>i j m. i = j \<Longrightarrow> P3 (CONS i) (m (CONS j))"
+  and a8:
+  "\<And>x y m. x = y \<Longrightarrow> P3 (VAR x) (m (VAR y))"
+  and a9:
+  "\<And>M m M' N N'. \<lbrakk>(M :: TRM) = m M'; P3 M (m M'); (N :: TRM) = N'; P3 N N'\<rbrakk> \<Longrightarrow> P3 (APP M N) (APP M' N')"
+  and a10: 
+  "\<And>A A' M M' x. \<lbrakk>(A ::TY) = A'; P2 A A'; (M :: TRM) = M'; P3 M M'\<rbrakk> \<Longrightarrow> P3 (LAM A x M) (LAM A' x M')"
+  and a11:
+  "\<And>A A' M x x' M' B'. \<lbrakk>(A ::TY) = A'; P2 A A'; (M :: TRM) = ([(x, x')] \<bullet> M'); P3 M ([(x, x')] \<bullet> M'); 
+  x \<notin> FV_ty B'; x \<notin> FV_trm M' - {x'}\<rbrakk> \<Longrightarrow> P3 (LAM A x M) (LAM A' x' M')"
+  shows "((x1 :: KIND) = x2 \<longrightarrow> P1 x1 x2) \<and>
+         ((x3 ::TY) = x4 \<longrightarrow> P2 x3 x4) \<and> 
+         ((x5 :: TRM) = x6 \<longrightarrow> P3 x5 x6)"
+using a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11
+apply - 
+apply(tactic {* procedure_tac @{context} @{thm akind_aty_atrm.induct} 1 *})
+apply(tactic {* regularize_tac @{context} 1 *})
+apply(tactic {* all_inj_repabs_tac @{context} rel_refl trans2 1 *})
+apply(fold perm_kind_def perm_ty_def perm_trm_def)
+apply(tactic {* clean_tac @{context} 1 *})
+(*
+Profiling:
+ML_prf {* fun ith i =  (#concl (fst (Subgoal.focus @{context} i (#goal (Isar.goal ()))))) *}
+ML_prf {* profile 2 Seq.list_of ((clean_tac @{context} quot defs 1) (ith 3)) *}
+ML_prf {* profile 2 Seq.list_of ((regularize_tac @{context} @{thms alpha_equivps} 1) (ith 1)) *}
+ML_prf {* PolyML.profiling 1 *}
+ML_prf {* profile 2 Seq.list_of ((all_inj_repabs_tac @{context} quot rel_refl trans2 1) (#goal (Isar.goal ()))) *}
+*)
+done
+
+(* Does not work:
+lemma
+  assumes a0: "P1 TYP"
+  and     a1: "\<And>ty name kind. \<lbrakk>P2 ty; P1 kind\<rbrakk> \<Longrightarrow> P1 (KPI ty name kind)"
+  and     a2: "\<And>id. P2 (TCONST id)"
+  and     a3: "\<And>ty trm. \<lbrakk>P2 ty; P3 trm\<rbrakk> \<Longrightarrow> P2 (TAPP ty trm)"
+  and     a4: "\<And>ty1 name ty2. \<lbrakk>P2 ty1; P2 ty2\<rbrakk> \<Longrightarrow> P2 (TPI ty1 name ty2)"
+  and     a5: "\<And>id. P3 (CONS id)"
+  and     a6: "\<And>name. P3 (VAR name)"
+  and     a7: "\<And>trm1 trm2. \<lbrakk>P3 trm1; P3 trm2\<rbrakk> \<Longrightarrow> P3 (APP trm1 trm2)"
+  and     a8: "\<And>ty name trm. \<lbrakk>P2 ty; P3 trm\<rbrakk> \<Longrightarrow> P3 (LAM ty name trm)"
+  shows "P1 mkind \<and> P2 mty \<and> P3 mtrm"
+using a0 a1 a2 a3 a4 a5 a6 a7 a8
+*)
+
+lemma "\<lbrakk>P TYP;
+  \<And>ty name kind. \<lbrakk>Q ty; P kind\<rbrakk> \<Longrightarrow> P (KPI ty name kind);
+  \<And>id. Q (TCONST id);
+  \<And>ty trm. \<lbrakk>Q ty; R trm\<rbrakk> \<Longrightarrow> Q (TAPP ty trm);
+  \<And>ty1 name ty2. \<lbrakk>Q ty1; Q ty2\<rbrakk> \<Longrightarrow> Q (TPI ty1 name ty2);
+  \<And>id. R (CONS id); \<And>name. R (VAR name);
+  \<And>trm1 trm2. \<lbrakk>R trm1; R trm2\<rbrakk> \<Longrightarrow> R (APP trm1 trm2);
+  \<And>ty name trm. \<lbrakk>Q ty; R trm\<rbrakk> \<Longrightarrow> R (LAM ty name trm)\<rbrakk>
+  \<Longrightarrow> P mkind \<and> Q mty \<and> R mtrm"
+apply(tactic {* lift_tac @{context} @{thm kind_ty_trm.induct} 1 *})
+done
+
+print_quotients
+
+end
+
+
+
diff -r 6088fea1c8b1 -r 8a1c8dc72b5c Quot/Examples/LamEx.thy
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Quot/Examples/LamEx.thy	Mon Dec 07 14:09:50 2009 +0100
@@ -0,0 +1,252 @@
+theory LamEx
+imports Nominal "../QuotMain"
+begin
+
+atom_decl name
+
+thm abs_fresh(1)
+
+nominal_datatype rlam =
+  rVar "name"
+| rApp "rlam" "rlam"
+| rLam "name" "rlam"
+
+print_theorems
+
+function
+  rfv :: "rlam \<Rightarrow> name set"
+where
+  rfv_var: "rfv (rVar a) = {a}"
+| rfv_app: "rfv (rApp t1 t2) = (rfv t1) \<union> (rfv t2)"
+| rfv_lam: "rfv (rLam a t) = (rfv t) - {a}"
+sorry
+
+termination rfv sorry
+
+inductive
+  alpha :: "rlam \<Rightarrow> rlam \<Rightarrow> bool" ("_ \<approx> _" [100, 100] 100)
+where
+  a1: "a = b \<Longrightarrow> (rVar a) \<approx> (rVar b)"
+| a2: "\<lbrakk>t1 \<approx> t2; s1 \<approx> s2\<rbrakk> \<Longrightarrow> rApp t1 s1 \<approx> rApp t2 s2"
+| a3: "\<lbrakk>t \<approx> ([(a,b)]\<bullet>s); a \<notin> rfv (rLam b t)\<rbrakk> \<Longrightarrow> rLam a t \<approx> rLam b s"
+
+print_theorems
+
+lemma alpha_refl:
+  fixes t::"rlam"
+  shows "t \<approx> t"
+  apply(induct t rule: rlam.induct)
+  apply(simp add: a1)
+  apply(simp add: a2)
+  apply(rule a3)
+  apply(subst pt_swap_bij'')
+  apply(rule pt_name_inst)
+  apply(rule at_name_inst)
+  apply(simp)
+  apply(simp)
+  done
+
+lemma alpha_equivp:
+  shows "equivp alpha"
+sorry
+
+quotient lam = rlam / alpha
+  apply(rule alpha_equivp)
+  done
+
+print_quotients
+
+quotient_def 
+  Var :: "name \<Rightarrow> lam"
+where
+  "Var \<equiv> rVar"
+
+quotient_def 
+  App :: "lam \<Rightarrow> lam \<Rightarrow> lam"
+where
+  "App \<equiv> rApp"
+
+quotient_def 
+  Lam :: "name \<Rightarrow> lam \<Rightarrow> lam"
+where
+  "Lam \<equiv> rLam"
+
+thm Var_def
+thm App_def
+thm Lam_def
+
+quotient_def 
+  fv :: "lam \<Rightarrow> name set"
+where
+  "fv \<equiv> rfv"
+
+thm fv_def
+
+(* definition of overloaded permutation function *)
+(* for the lifted type lam                       *)
+overloading
+  perm_lam \<equiv> "perm :: 'x prm \<Rightarrow> lam \<Rightarrow> lam"   (unchecked)
+begin
+
+quotient_def 
+  perm_lam :: "'x prm \<Rightarrow> lam \<Rightarrow> lam"
+where
+  "perm_lam \<equiv> (perm::'x prm \<Rightarrow> rlam \<Rightarrow> rlam)"
+
+end
+
+(*quotient_def (for lam)
+  abs_fun_lam :: "'x prm \<Rightarrow> lam \<Rightarrow> lam"
+where
+  "perm_lam \<equiv> (perm::'x prm \<Rightarrow> rlam \<Rightarrow> rlam)"*)
+
+
+thm perm_lam_def
+
+(* lemmas that need to lift *)
+lemma pi_var_com:
+  fixes pi::"'x prm"
+  shows "(pi\<bullet>rVar a) \<approx> rVar (pi\<bullet>a)"
+  sorry
+
+lemma pi_app_com:
+  fixes pi::"'x prm"
+  shows "(pi\<bullet>rApp t1 t2) \<approx> rApp (pi\<bullet>t1) (pi\<bullet>t2)"
+  sorry
+
+lemma pi_lam_com:
+  fixes pi::"'x prm"
+  shows "(pi\<bullet>rLam a t) \<approx> rLam (pi\<bullet>a) (pi\<bullet>t)"
+  sorry
+
+
+
+lemma real_alpha:
+  assumes a: "t = [(a,b)]\<bullet>s" "a\<sharp>[b].s"
+  shows "Lam a t = Lam b s"
+using a
+unfolding fresh_def supp_def
+sorry
+
+lemma perm_rsp[quotient_rsp]:
+  "(op = ===> alpha ===> alpha) op \<bullet> op \<bullet>"
+  apply(auto)
+  (* this is propably true if some type conditions are imposed ;o) *)
+  sorry
+
+lemma fresh_rsp:
+  "(op = ===> alpha ===> op =) fresh fresh"
+  apply(auto)
+  (* this is probably only true if some type conditions are imposed *)
+  sorry
+
+lemma rVar_rsp[quotient_rsp]:
+  "(op = ===> alpha) rVar rVar"
+by (auto intro:a1)
+
+lemma rApp_rsp[quotient_rsp]: "(alpha ===> alpha ===> alpha) rApp rApp"
+by (auto intro:a2)
+
+lemma rLam_rsp[quotient_rsp]: "(op = ===> alpha ===> alpha) rLam rLam"
+  apply(auto)
+  apply(rule a3)
+  apply(rule_tac t="[(x,x)]\<bullet>y" and s="y" in subst)
+  apply(rule sym)
+  apply(rule trans)
+  apply(rule pt_name3)
+  apply(rule at_ds1[OF at_name_inst])
+  apply(simp add: pt_name1)
+  apply(assumption)
+  apply(simp add: abs_fresh)
+  done
+
+lemma rfv_rsp[quotient_rsp]: "(alpha ===> op =) rfv rfv"
+  sorry
+
+lemma rvar_inject: "rVar a \<approx> rVar b = (a = b)"
+apply (auto)
+apply (erule alpha.cases)
+apply (simp_all add: rlam.inject alpha_refl)
+done
+
+ML {* val qty = @{typ "lam"} *}
+ML {* val rsp_thms = @{thms perm_rsp fresh_rsp rVar_rsp rApp_rsp rLam_rsp rfv_rsp} *}
+
+ML {* val (rty, rel, rel_refl, rel_eqv) = lookup_quot_data @{context} qty *}
+ML {* val (trans2, reps_same, absrep, quot) = lookup_quot_thms @{context} "lam" *}
+ML {* fun lift_tac_lam lthy t = lift_tac lthy t *}
+
+lemma pi_var: "(pi\<Colon>('x \<times> 'x) list) \<bullet> Var a = Var (pi \<bullet> a)"
+apply (tactic {* lift_tac_lam @{context} @{thm pi_var_com} 1 *})
+done
+
+lemma pi_app: "(pi\<Colon>('x \<times> 'x) list) \<bullet> App (x\<Colon>lam) (xa\<Colon>lam) = App (pi \<bullet> x) (pi \<bullet> xa)"
+apply (tactic {* lift_tac_lam @{context} @{thm pi_app_com} 1 *})
+done
+
+lemma pi_lam: "(pi\<Colon>('x \<times> 'x) list) \<bullet> Lam (a\<Colon>name) (x\<Colon>lam) = Lam (pi \<bullet> a) (pi \<bullet> x)"
+apply (tactic {* lift_tac_lam @{context} @{thm pi_lam_com} 1 *})
+done
+
+lemma fv_var: "fv (Var (a\<Colon>name)) = {a}"
+apply (tactic {* lift_tac_lam @{context} @{thm rfv_var} 1 *})
+done
+
+lemma fv_app: "fv (App (x\<Colon>lam) (xa\<Colon>lam)) = fv x \<union> fv xa"
+apply (tactic {* lift_tac_lam @{context} @{thm rfv_app} 1 *})
+done
+
+lemma fv_lam: "fv (Lam (a\<Colon>name) (x\<Colon>lam)) = fv x - {a}"
+apply (tactic {* lift_tac_lam @{context} @{thm rfv_lam} 1 *})
+done
+
+lemma a1: "(a\<Colon>name) = (b\<Colon>name) \<Longrightarrow> Var a = Var b"
+apply (tactic {* lift_tac_lam @{context} @{thm a1} 1 *})
+done
+
+lemma a2: "\<lbrakk>(x\<Colon>lam) = (xa\<Colon>lam); (xb\<Colon>lam) = (xc\<Colon>lam)\<rbrakk> \<Longrightarrow> App x xb = App xa xc"
+apply (tactic {* lift_tac_lam @{context} @{thm a2} 1 *})
+done
+
+lemma a3: "\<lbrakk>(x\<Colon>lam) = [(a\<Colon>name, b\<Colon>name)] \<bullet> (xa\<Colon>lam); a \<notin> fv (Lam b x)\<rbrakk> \<Longrightarrow> Lam a x = Lam b xa"
+apply (tactic {* lift_tac_lam @{context} @{thm a3} 1 *})
+done
+
+lemma alpha_cases: "\<lbrakk>a1 = a2; \<And>a b. \<lbrakk>a1 = Var a; a2 = Var b; a = b\<rbrakk> \<Longrightarrow> P;
+     \<And>x xa xb xc. \<lbrakk>a1 = App x xb; a2 = App xa xc; x = xa; xb = xc\<rbrakk> \<Longrightarrow> P;
+     \<And>x a b xa. \<lbrakk>a1 = Lam a x; a2 = Lam b xa; x = [(a, b)] \<bullet> xa; a \<notin> fv (Lam b x)\<rbrakk> \<Longrightarrow> P\<rbrakk>
+    \<Longrightarrow> P"
+apply (tactic {* lift_tac_lam @{context} @{thm alpha.cases} 1 *})
+done
+
+lemma alpha_induct: "\<lbrakk>(qx\<Colon>lam) = (qxa\<Colon>lam); \<And>(a\<Colon>name) b\<Colon>name. a = b \<Longrightarrow> (qxb\<Colon>lam \<Rightarrow> lam \<Rightarrow> bool) (Var a) (Var b);
+     \<And>(x\<Colon>lam) (xa\<Colon>lam) (xb\<Colon>lam) xc\<Colon>lam. \<lbrakk>x = xa; qxb x xa; xb = xc; qxb xb xc\<rbrakk> \<Longrightarrow> qxb (App x xb) (App xa xc);
+     \<And>(x\<Colon>lam) (a\<Colon>name) (b\<Colon>name) xa\<Colon>lam.
+        \<lbrakk>x = [(a, b)] \<bullet> xa; qxb x ([(a, b)] \<bullet> xa); a \<notin> fv (Lam b x)\<rbrakk> \<Longrightarrow> qxb (Lam a x) (Lam b xa)\<rbrakk>
+    \<Longrightarrow> qxb qx qxa"
+apply (tactic {* lift_tac_lam @{context} @{thm alpha.induct} 1 *})
+done
+
+lemma var_inject: "(Var a = Var b) = (a = b)"
+apply (tactic {* lift_tac_lam @{context} @{thm rvar_inject} 1 *})
+done
+
+lemma lam_induct:" \<lbrakk>\<And>name. P (Var name); \<And>lam1 lam2. \<lbrakk>P lam1; P lam2\<rbrakk> \<Longrightarrow> P (App lam1 lam2);
+              \<And>name lam. P lam \<Longrightarrow> P (Lam name lam)\<rbrakk> \<Longrightarrow> P lam"
+apply (tactic {* lift_tac_lam @{context} @{thm rlam.induct} 1 *})
+done
+
+lemma var_supp:
+  shows "supp (Var a) = ((supp a)::name set)"
+  apply(simp add: supp_def)
+  apply(simp add: pi_var)
+  apply(simp add: var_inject)
+  done
+
+lemma var_fresh:
+  fixes a::"name"
+  shows "(a\<sharp>(Var b)) = (a\<sharp>b)"
+  apply(simp add: fresh_def)
+  apply(simp add: var_supp)
+  done
+
diff -r 6088fea1c8b1 -r 8a1c8dc72b5c Quot/Prove.thy
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Quot/Prove.thy	Mon Dec 07 14:09:50 2009 +0100
@@ -0,0 +1,28 @@
+theory Prove
+imports Plain 
+begin
+
+ML {*
+val r = Unsynchronized.ref (NONE:(unit -> term) option)
+*}
+
+ML {*
+let
+  fun after_qed thm_name thms lthy =
+       Local_Theory.note (thm_name, (flat thms)) lthy |> snd
+    
+  fun setup_proof (name_spec, (txt, pos)) lthy =
+  let
+    val trm = ML_Context.evaluate lthy true ("r", r) txt
+  in
+    Proof.theorem_i NONE (after_qed name_spec) [[(trm,[])]] lthy
+  end
+
+  val parser = SpecParse.opt_thm_name ":" -- OuterParse.ML_source
+in
+  OuterSyntax.local_theory_to_proof "prove" "proving a proposition" 
+    OuterKeyword.thy_goal (parser >> setup_proof)
+end
+*}
+
+end
diff -r 6088fea1c8b1 -r 8a1c8dc72b5c Quot/QuotList.thy
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Quot/QuotList.thy	Mon Dec 07 14:09:50 2009 +0100
@@ -0,0 +1,174 @@
+theory QuotList
+imports QuotScript List
+begin
+
+fun
+  list_rel
+where
+  "list_rel R [] [] = True"
+| "list_rel R (x#xs) [] = False"
+| "list_rel R [] (x#xs) = False"
+| "list_rel R (x#xs) (y#ys) = (R x y \<and> list_rel R xs ys)"
+
+lemma list_equivp:
+  assumes a: "equivp R"
+  shows "equivp (list_rel R)"
+  unfolding equivp_def
+  apply(rule allI)+
+  apply(induct_tac x y rule: list_induct2')
+  apply(simp_all add: expand_fun_eq)
+  apply(metis list_rel.simps(1) list_rel.simps(2))
+  apply(metis list_rel.simps(1) list_rel.simps(2))
+  apply(rule iffI)
+  apply(rule allI)
+  apply(case_tac x)
+  apply(simp_all)
+  using a
+  apply(unfold equivp_def)
+  apply(auto)[1]
+  apply(metis list_rel.simps(4))
+  done
+
+lemma list_rel_rel:
+  assumes q: "Quotient R Abs Rep"
+  shows "list_rel R r s = (list_rel R r r \<and> list_rel R s s \<and> (map Abs r = map Abs s))"
+  apply(induct r s rule: list_induct2')
+  apply(simp_all)
+  using Quotient_rel[OF q]
+  apply(metis)
+  done
+
+lemma list_quotient:
+  assumes q: "Quotient R Abs Rep"
+  shows "Quotient (list_rel R) (map Abs) (map Rep)"
+  unfolding Quotient_def
+  apply(rule conjI)
+  apply(rule allI)
+  apply(induct_tac a)
+  apply(simp)
+  apply(simp add: Quotient_abs_rep[OF q])
+  apply(rule conjI)
+  apply(rule allI)
+  apply(induct_tac a)
+  apply(simp)
+  apply(simp)
+  apply(simp add: Quotient_rep_reflp[OF q])
+  apply(rule allI)+
+  apply(rule list_rel_rel[OF q])
+  done
+
+
+lemma cons_prs:
+  assumes q: "Quotient R Abs Rep"
+  shows "(map Abs) ((Rep h) # (map Rep t)) = h # t"
+by (induct t) (simp_all add: Quotient_abs_rep[OF q])
+
+lemma cons_rsp:
+  assumes q: "Quotient R Abs Rep"
+  shows "(R ===> list_rel R ===> list_rel R) op # op #"
+by (auto)
+
+lemma nil_prs:
+  assumes q: "Quotient R Abs Rep"
+  shows "map Abs [] \<equiv> []"
+by (simp)
+
+lemma nil_rsp:
+  assumes q: "Quotient R Abs Rep"
+  shows "list_rel R [] []"
+by simp
+
+lemma map_prs:
+  assumes a: "Quotient R1 abs1 rep1"
+  and     b: "Quotient R2 abs2 rep2"
+  shows "(map abs2) (map ((abs1 ---> rep2) f) (map rep1 l)) = map f l"
+by (induct l) (simp_all add: Quotient_abs_rep[OF a] Quotient_abs_rep[OF b])
+
+lemma map_rsp:
+  assumes q1: "Quotient R1 Abs1 Rep1"
+  and     q2: "Quotient R2 Abs2 Rep2"
+  shows "((R1 ===> R2) ===> (list_rel R1) ===> list_rel R2) map map"
+apply(simp)
+apply(rule allI)+
+apply(rule impI)
+apply(rule allI)+
+apply (induct_tac xa ya rule: list_induct2')
+apply simp_all
+done
+
+(* TODO: if the above is correct, we can remove this one *)
+lemma map_rsp_lo:
+  assumes q1: "Quotient R1 Abs1 Rep1"
+  and     q2: "Quotient R2 Abs2 Rep2"
+  and     a: "(R1 ===> R2) f1 f2"
+  and     b: "list_rel R1 l1 l2"
+  shows "list_rel R2 (map f1 l1) (map f2 l2)"
+using b a
+by (induct l1 l2 rule: list_induct2') (simp_all)
+
+lemma foldr_prs:
+  assumes a: "Quotient R1 abs1 rep1"
+  and     b: "Quotient R2 abs2 rep2"
+  shows "abs2 (foldr ((abs1 ---> abs2 ---> rep2) f) (map rep1 l) (rep2 e)) = foldr f l e"
+by (induct l) (simp_all add: Quotient_abs_rep[OF a] Quotient_abs_rep[OF b])
+
+lemma foldl_prs:
+  assumes a: "Quotient R1 abs1 rep1"
+  and     b: "Quotient R2 abs2 rep2"
+  shows "abs1 (foldl ((abs1 ---> abs2 ---> rep1) f) (rep1 e) (map rep2 l)) = foldl f e l"
+by (induct l arbitrary:e) (simp_all add: Quotient_abs_rep[OF a] Quotient_abs_rep[OF b])
+
+lemma list_rel_empty: "list_rel R [] b \<Longrightarrow> length b = 0"
+by (induct b) (simp_all)
+
+lemma list_rel_len: "list_rel R a b \<Longrightarrow> length a = length b"
+apply (induct a arbitrary: b)
+apply (simp add: list_rel_empty)
+apply (case_tac b)
+apply simp_all
+done
+
+(* TODO: induct_tac doesn't accept 'arbitrary'.
+         induct     doesn't accept 'rule'.
+   that's why the proof uses manual generalisation and needs assumptions
+   both in conclusion for induction and in assumptions. *)
+lemma foldl_rsp:
+  assumes q1: "Quotient R1 Abs1 Rep1"
+  and     q2: "Quotient R2 Abs2 Rep2"
+  shows "((R1 ===> R2 ===> R1) ===> R1 ===> list_rel R2 ===> R1) foldl foldl"
+apply auto
+apply (subgoal_tac "R1 xa ya \<longrightarrow> list_rel R2 xb yb \<longrightarrow> R1 (foldl x xa xb) (foldl y ya yb)")
+apply simp
+apply (rule_tac x="xa" in spec)
+apply (rule_tac x="ya" in spec)
+apply (rule_tac xs="xb" and ys="yb" in list_induct2)
+apply (rule list_rel_len)
+apply (simp_all)
+done
+
+(* TODO: foldr_rsp should be similar *)
+
+
+
+
+(* TODO: Rest are unused *)
+
+lemma list_map_id:
+  shows "map (\<lambda>x. x) = (\<lambda>x. x)"
+  by simp
+
+lemma list_rel_eq:
+  shows "list_rel (op =) \<equiv> (op =)"
+apply(rule eq_reflection)
+unfolding expand_fun_eq
+apply(rule allI)+
+apply(induct_tac x xa rule: list_induct2')
+apply(simp_all)
+done
+
+lemma list_rel_refl:
+  assumes a: "\<And>x y. R x y = (R x = R y)"
+  shows "list_rel R x x"
+by (induct x) (auto simp add: a)
+
+end
diff -r 6088fea1c8b1 -r 8a1c8dc72b5c Quot/QuotMain.thy
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Quot/QuotMain.thy	Mon Dec 07 14:09:50 2009 +0100
@@ -0,0 +1,1191 @@
+theory QuotMain
+imports QuotScript QuotList QuotProd Prove
+uses ("quotient_info.ML")
+     ("quotient.ML")
+     ("quotient_def.ML")
+begin
+
+
+locale QUOT_TYPE =
+  fixes R :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
+  and   Abs :: "('a \<Rightarrow> bool) \<Rightarrow> 'b"
+  and   Rep :: "'b \<Rightarrow> ('a \<Rightarrow> bool)"
+  assumes equivp: "equivp R"
+  and     rep_prop: "\<And>y. \<exists>x. Rep y = R x"
+  and     rep_inverse: "\<And>x. Abs (Rep x) = x"
+  and     abs_inverse: "\<And>x. (Rep (Abs (R x))) = (R x)"
+  and     rep_inject: "\<And>x y. (Rep x = Rep y) = (x = y)"
+begin
+
+definition
+  ABS::"'a \<Rightarrow> 'b"
+where
+  "ABS x \<equiv> Abs (R x)"
+
+definition
+  REP::"'b \<Rightarrow> 'a"
+where
+  "REP a = Eps (Rep a)"
+
+lemma lem9:
+  shows "R (Eps (R x)) = R x"
+proof -
+  have a: "R x x" using equivp by (simp add: equivp_reflp_symp_transp reflp_def)
+  then have "R x (Eps (R x))" by (rule someI)
+  then show "R (Eps (R x)) = R x"
+    using equivp unfolding equivp_def by simp
+qed
+
+theorem thm10:
+  shows "ABS (REP a) \<equiv> a"
+  apply  (rule eq_reflection)
+  unfolding ABS_def REP_def
+proof -
+  from rep_prop
+  obtain x where eq: "Rep a = R x" by auto
+  have "Abs (R (Eps (Rep a))) = Abs (R (Eps (R x)))" using eq by simp
+  also have "\<dots> = Abs (R x)" using lem9 by simp
+  also have "\<dots> = Abs (Rep a)" using eq by simp
+  also have "\<dots> = a" using rep_inverse by simp
+  finally
+  show "Abs (R (Eps (Rep a))) = a" by simp
+qed
+
+lemma REP_refl:
+  shows "R (REP a) (REP a)"
+unfolding REP_def
+by (simp add: equivp[simplified equivp_def])
+
+lemma lem7:
+  shows "(R x = R y) = (Abs (R x) = Abs (R y))"
+apply(rule iffI)
+apply(simp)
+apply(drule rep_inject[THEN iffD2])
+apply(simp add: abs_inverse)
+done
+
+theorem thm11:
+  shows "R r r' = (ABS r = ABS r')"
+unfolding ABS_def
+by (simp only: equivp[simplified equivp_def] lem7)
+
+
+lemma REP_ABS_rsp:
+  shows "R f (REP (ABS g)) = R f g"
+  and   "R (REP (ABS g)) f = R g f"
+by (simp_all add: thm10 thm11)
+
+lemma Quotient:
+  "Quotient R ABS REP"
+apply(unfold Quotient_def)
+apply(simp add: thm10)
+apply(simp add: REP_refl)
+apply(subst thm11[symmetric])
+apply(simp add: equivp[simplified equivp_def])
+done
+
+lemma R_trans:
+  assumes ab: "R a b"
+  and     bc: "R b c"
+  shows "R a c"
+proof -
+  have tr: "transp R" using equivp equivp_reflp_symp_transp[of R] by simp
+  moreover have ab: "R a b" by fact
+  moreover have bc: "R b c" by fact
+  ultimately show "R a c" unfolding transp_def by blast
+qed
+
+lemma R_sym:
+  assumes ab: "R a b"
+  shows "R b a"
+proof -
+  have re: "symp R" using equivp equivp_reflp_symp_transp[of R] by simp
+  then show "R b a" using ab unfolding symp_def by blast
+qed
+
+lemma R_trans2:
+  assumes ac: "R a c"
+  and     bd: "R b d"
+  shows "R a b = R c d"
+using ac bd
+by (blast intro: R_trans R_sym)
+
+lemma REPS_same:
+  shows "R (REP a) (REP b) \<equiv> (a = b)"
+proof -
+  have "R (REP a) (REP b) = (a = b)"
+  proof
+    assume as: "R (REP a) (REP b)"
+    from rep_prop
+    obtain x y
+      where eqs: "Rep a = R x" "Rep b = R y" by blast
+    from eqs have "R (Eps (R x)) (Eps (R y))" using as unfolding REP_def by simp
+    then have "R x (Eps (R y))" using lem9 by simp
+    then have "R (Eps (R y)) x" using R_sym by blast
+    then have "R y x" using lem9 by simp
+    then have "R x y" using R_sym by blast
+    then have "ABS x = ABS y" using thm11 by simp
+    then have "Abs (Rep a) = Abs (Rep b)" using eqs unfolding ABS_def by simp
+    then show "a = b" using rep_inverse by simp
+  next
+    assume ab: "a = b"
+    have "reflp R" using equivp equivp_reflp_symp_transp[of R] by simp
+    then show "R (REP a) (REP b)" unfolding reflp_def using ab by auto
+  qed
+  then show "R (REP a) (REP b) \<equiv> (a = b)" by simp
+qed
+
+end
+
+section {* type definition for the quotient type *}
+
+(* the auxiliary data for the quotient types *)
+use "quotient_info.ML"
+
+declare [[map list = (map, list_rel)]]
+declare [[map * = (prod_fun, prod_rel)]]
+declare [[map "fun" = (fun_map, fun_rel)]]
+
+(* identity quotient is not here as it has to be applied first *)
+lemmas [quotient_thm] =
+  fun_quotient list_quotient prod_quotient
+
+lemmas [quotient_rsp] =
+  quot_rel_rsp nil_rsp cons_rsp foldl_rsp pair_rsp
+
+(* fun_map is not here since equivp is not true *)
+(* TODO: option, ... *)
+lemmas [quotient_equiv] =
+  identity_equivp list_equivp prod_equivp
+
+
+ML {* maps_lookup @{theory} "List.list" *}
+ML {* maps_lookup @{theory} "*" *}
+ML {* maps_lookup @{theory} "fun" *}
+
+
+(* definition of the quotient types *)
+(* FIXME: should be called quotient_typ.ML *)
+use "quotient.ML"
+
+
+(* lifting of constants *)
+use "quotient_def.ML"
+
+section {* Simset setup *}
+
+(* since HOL_basic_ss is too "big", we need to set up *)
+(* our own minimal simpset                            *)
+ML {*
+fun  mk_minimal_ss ctxt =
+  Simplifier.context ctxt empty_ss
+    setsubgoaler asm_simp_tac
+    setmksimps (mksimps [])
+*}
+
+section {* atomize *}
+
+lemma atomize_eqv[atomize]:
+  shows "(Trueprop A \<equiv> Trueprop B) \<equiv> (A \<equiv> B)"
+proof
+  assume "A \<equiv> B"
+  then show "Trueprop A \<equiv> Trueprop B" by unfold
+next
+  assume *: "Trueprop A \<equiv> Trueprop B"
+  have "A = B"
+  proof (cases A)
+    case True
+    have "A" by fact
+    then show "A = B" using * by simp
+  next
+    case False
+    have "\<not>A" by fact
+    then show "A = B" using * by auto
+  qed
+  then show "A \<equiv> B" by (rule eq_reflection)
+qed
+
+ML {*
+fun atomize_thm thm =
+let
+  val thm' = Thm.freezeT (forall_intr_vars thm)
+  val thm'' = ObjectLogic.atomize (cprop_of thm')
+in
+  @{thm equal_elim_rule1} OF [thm'', thm']
+end
+*}
+
+section {* infrastructure about id *}
+
+lemma prod_fun_id: "prod_fun id id \<equiv> id"
+  by (rule eq_reflection) (simp add: prod_fun_def)
+
+lemma map_id: "map id \<equiv> id"
+  apply (rule eq_reflection)
+  apply (rule ext)
+  apply (rule_tac list="x" in list.induct)
+  apply (simp_all)
+  done
+
+lemmas id_simps =
+  fun_map_id[THEN eq_reflection]
+  id_apply[THEN eq_reflection]
+  id_def[THEN eq_reflection,symmetric]
+  prod_fun_id map_id
+
+ML {*
+fun simp_ids thm =
+  MetaSimplifier.rewrite_rule @{thms id_simps} thm
+*}
+
+section {* Debugging infrastructure for testing tactics *}
+
+ML {*
+fun my_print_tac ctxt s i thm =
+let
+  val prem_str = nth (prems_of thm) (i - 1)
+                 |> Syntax.string_of_term ctxt
+                 handle Subscript => "no subgoal"
+  val _ = tracing (s ^ "\n" ^ prem_str)
+in
+  Seq.single thm
+end *}
+
+ML {*
+fun DT ctxt s tac i thm =
+let
+  val before_goal = nth (prems_of thm) (i - 1)
+                    |> Syntax.string_of_term ctxt
+  val before_msg = ["before: " ^ s, before_goal, "after: " ^ s]
+                   |> cat_lines
+in 
+  EVERY [tac i, my_print_tac ctxt before_msg i] thm
+end
+
+fun NDT ctxt s tac thm = tac thm  
+*}
+
+section {* Matching of terms and types *}
+
+ML {*
+fun matches_typ (ty, ty') =
+  case (ty, ty') of
+    (_, TVar _) => true
+  | (TFree x, TFree x') => x = x'
+  | (Type (s, tys), Type (s', tys')) => 
+       s = s' andalso 
+       if (length tys = length tys') 
+       then (List.all matches_typ (tys ~~ tys')) 
+       else false
+  | _ => false
+*}
+
+ML {*
+fun matches_term (trm, trm') = 
+   case (trm, trm') of 
+     (_, Var _) => true
+   | (Const (s, ty), Const (s', ty')) => s = s' andalso matches_typ (ty, ty')
+   | (Free (x, ty), Free (x', ty')) => x = x' andalso matches_typ (ty, ty')
+   | (Bound i, Bound j) => i = j
+   | (Abs (_, T, t), Abs (_, T', t')) => matches_typ (T, T') andalso matches_term (t, t')
+   | (t $ s, t' $ s') => matches_term (t, t') andalso matches_term (s, s') 
+   | _ => false
+*}
+
+section {* Infrastructure for collecting theorems for starting the lifting *}
+
+ML {*
+fun lookup_quot_data lthy qty =
+  let
+    val qty_name = fst (dest_Type qty)
+    val SOME quotdata = quotdata_lookup lthy qty_name
+    (* TODO: Should no longer be needed *)
+    val rty = Logic.unvarifyT (#rtyp quotdata)
+    val rel = #rel quotdata
+    val rel_eqv = #equiv_thm quotdata
+    val rel_refl = @{thm equivp_reflp} OF [rel_eqv]
+  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 absrep = PureThy.get_thm thy ("QUOT_TYPE_I_" ^ qty_name ^ ".thm10")
+    val quot = PureThy.get_thm thy ("Quotient_" ^ qty_name)
+  in
+    (trans2, reps_same, absrep, quot)
+  end
+*}
+
+section {* Regularization *} 
+
+(*
+Regularizing an rtrm means:
+ - quantifiers over a type that needs lifting are replaced by
+   bounded quantifiers, for example:
+      \<forall>x. P     \<Longrightarrow>     \<forall>x \<in> (Respects R). P  /  All (Respects R) P
+
+   the relation R is given by the rty and qty;
+ 
+ - abstractions over a type that needs lifting are replaced
+   by bounded abstractions:
+      \<lambda>x. P     \<Longrightarrow>     Ball (Respects R) (\<lambda>x. P)
+
+ - equalities over the type being lifted are replaced by
+   corresponding relations:
+      A = B     \<Longrightarrow>     A \<approx> B
+
+   example with more complicated types of A, B:
+      A = B     \<Longrightarrow>     (op = \<Longrightarrow> op \<approx>) A B
+*)
+
+ML {*
+(* builds the relation that is the argument of respects *)
+fun mk_resp_arg lthy (rty, qty) =
+let
+  val thy = ProofContext.theory_of lthy
+in  
+  if rty = qty
+  then HOLogic.eq_const rty
+  else
+    case (rty, qty) of
+      (Type (s, tys), Type (s', tys')) =>
+       if s = s' 
+       then let
+              val SOME map_info = maps_lookup thy s
+              val args = map (mk_resp_arg lthy) (tys ~~ tys')
+            in
+              list_comb (Const (#relfun map_info, dummyT), args) 
+            end  
+       else let  
+              val SOME qinfo = quotdata_lookup_thy thy s'
+              (* FIXME: check in this case that the rty and qty *)
+              (* FIXME: correspond to each other *)
+              val (s, _) = dest_Const (#rel qinfo)
+              (* FIXME: the relation should only be the string        *)
+              (* FIXME: and the type needs to be calculated as below; *)
+              (* FIXME: maybe one should actually have a term         *)
+              (* FIXME: and one needs to force it to have this type   *)
+            in
+              Const (s, rty --> rty --> @{typ bool})
+            end
+      | _ => HOLogic.eq_const dummyT 
+             (* FIXME: check that the types correspond to each other? *)
+end
+*}
+
+ML {*
+val mk_babs = Const (@{const_name Babs}, dummyT)
+val mk_ball = Const (@{const_name Ball}, dummyT)
+val mk_bex  = Const (@{const_name Bex}, dummyT)
+val mk_resp = Const (@{const_name Respects}, dummyT)
+*}
+
+ML {*
+(* - applies f to the subterm of an abstraction,   *)
+(*   otherwise to the given term,                  *)
+(* - used by regularize, therefore abstracted      *)
+(*   variables do not have to be treated specially *)
+
+fun apply_subt f trm1 trm2 =
+  case (trm1, trm2) of
+    (Abs (x, T, t), Abs (x', T', t')) => Abs (x, T, f t t')
+  | _ => f trm1 trm2
+
+(* the major type of All and Ex quantifiers *)
+fun qnt_typ ty = domain_type (domain_type ty)  
+*}
+
+ML {*
+(* produces a regularized version of rtm      *)
+(* - the result is still not completely typed *)
+(* - does not need any special treatment of   *)
+(*   bound variables                          *)
+
+fun regularize_trm lthy rtrm qtrm =
+  case (rtrm, qtrm) of
+    (Abs (x, ty, t), Abs (x', ty', t')) =>
+       let
+         val subtrm = Abs(x, ty, regularize_trm lthy t t')
+       in
+         if ty = ty'
+         then subtrm
+         else mk_babs $ (mk_resp $ mk_resp_arg lthy (ty, ty')) $ subtrm
+       end
+
+  | (Const (@{const_name "All"}, ty) $ t, Const (@{const_name "All"}, ty') $ t') =>
+       let
+         val subtrm = apply_subt (regularize_trm lthy) t t'
+       in
+         if ty = ty'
+         then Const (@{const_name "All"}, ty) $ subtrm
+         else mk_ball $ (mk_resp $ mk_resp_arg lthy (qnt_typ ty, qnt_typ ty')) $ subtrm
+       end
+
+  | (Const (@{const_name "Ex"}, ty) $ t, Const (@{const_name "Ex"}, ty') $ t') =>
+       let
+         val subtrm = apply_subt (regularize_trm lthy) t t'
+       in
+         if ty = ty'
+         then Const (@{const_name "Ex"}, ty) $ subtrm
+         else mk_bex $ (mk_resp $ mk_resp_arg lthy (qnt_typ ty, qnt_typ ty')) $ subtrm
+       end
+
+  | (* equalities need to be replaced by appropriate equivalence relations *) 
+    (Const (@{const_name "op ="}, ty), Const (@{const_name "op ="}, ty')) =>
+         if ty = ty'
+         then rtrm
+         else mk_resp_arg lthy (domain_type ty, domain_type ty') 
+
+  | (* in this case we check whether the given equivalence relation is correct *) 
+    (rel, Const (@{const_name "op ="}, ty')) =>
+       let 
+         val exc = LIFT_MATCH "regularise (relation mismatch)"
+         val rel_ty = (fastype_of rel) handle TERM _ => raise exc 
+         val rel' = mk_resp_arg lthy (domain_type rel_ty, domain_type ty') 
+       in 
+         if rel' = rel
+         then rtrm
+         else raise exc
+       end  
+  | (_, Const (s, _)) =>
+       let 
+         fun same_name (Const (s, _)) (Const (s', _)) = (s = s')
+           | same_name _ _ = false
+       in
+         if same_name rtrm qtrm 
+         then rtrm 
+         else 
+           let 
+             fun exc1 s = LIFT_MATCH ("regularize (constant " ^ s ^ " not found)")
+             val exc2   = LIFT_MATCH ("regularize (constant mismatch)")
+             val thy = ProofContext.theory_of lthy
+             val rtrm' = (#rconst (qconsts_lookup thy s)) handle NotFound => raise (exc1 s) 
+           in 
+             if matches_term (rtrm, rtrm')
+             then rtrm
+             else raise exc2
+           end
+       end 
+
+  | (t1 $ t2, t1' $ t2') =>
+       (regularize_trm lthy t1 t1') $ (regularize_trm lthy t2 t2')
+
+  | (Free (x, ty), Free (x', ty')) => 
+       (* this case cannot arrise as we start with two fully atomized terms *)
+       raise (LIFT_MATCH "regularize (frees)")
+
+  | (Bound i, Bound i') =>
+       if i = i' 
+       then rtrm 
+       else raise (LIFT_MATCH "regularize (bounds mismatch)")
+
+  | (rt, qt) =>
+       raise (LIFT_MATCH "regularize (default)")
+*}
+
+ML {*
+fun equiv_tac ctxt =
+  REPEAT_ALL_NEW (FIRST' 
+    [resolve_tac (equiv_rules_get ctxt)])
+*}
+
+ML {*
+fun equiv_solver_tac ss = equiv_tac (Simplifier.the_context ss)
+val equiv_solver = Simplifier.mk_solver' "Equivalence goal solver" equiv_solver_tac
+*}
+
+ML {*
+fun prep_trm thy (x, (T, t)) =
+  (cterm_of thy (Var (x, T)), cterm_of thy t)
+
+fun prep_ty thy (x, (S, ty)) =
+  (ctyp_of thy (TVar (x, S)), ctyp_of thy ty)
+*}
+
+ML {*
+fun matching_prs thy pat trm =
+let
+  val univ = Unify.matchers thy [(pat, trm)]
+  val SOME (env, _) = Seq.pull univ
+  val tenv = Vartab.dest (Envir.term_env env)
+  val tyenv = Vartab.dest (Envir.type_env env)
+in
+  (map (prep_ty thy) tyenv, map (prep_trm thy) tenv)
+end
+*}
+
+ML {*
+fun calculate_instance ctxt thm redex R1 R2 =
+let
+  val thy = ProofContext.theory_of ctxt
+  val goal = Const (@{const_name "equivp"}, dummyT) $ R2  
+             |> Syntax.check_term ctxt
+             |> HOLogic.mk_Trueprop 
+  val eqv_prem = Goal.prove ctxt [] [] goal (fn {context,...} => equiv_tac context 1)
+  val thm = (@{thm eq_reflection} OF [thm OF [eqv_prem]])
+  val R1c = cterm_of thy R1
+  val thmi = Drule.instantiate' [] [SOME R1c] thm
+  val inst = matching_prs thy (term_of (Thm.lhs_of thmi)) redex
+  val thm2 = Drule.eta_contraction_rule (Drule.instantiate inst thmi)
+in
+  SOME thm2
+end
+handle _ => NONE
+(* FIXME/TODO: what is the place where the exception can be raised: matching_prs? *)
+*}
+
+ML {*
+fun ball_bex_range_simproc ss redex =
+let
+  val ctxt = Simplifier.the_context ss
+in 
+ case redex of
+    (Const (@{const_name "Ball"}, _) $ (Const (@{const_name "Respects"}, _) $ 
+      (Const (@{const_name "fun_rel"}, _) $ R1 $ R2)) $ _) =>
+        calculate_instance ctxt @{thm ball_reg_eqv_range} redex R1 R2
+  | (Const (@{const_name "Bex"}, _) $ (Const (@{const_name "Respects"}, _) $ 
+      (Const (@{const_name "fun_rel"}, _) $ R1 $ R2)) $ _) =>  
+        calculate_instance ctxt @{thm bex_reg_eqv_range} redex R1 R2
+  | _ => NONE
+end
+*}
+
+lemma eq_imp_rel: 
+  shows "equivp R \<Longrightarrow> a = b \<longrightarrow> R a b"
+by (simp add: equivp_reflp)
+
+(* FIXME/TODO: How does regularizing work? *)
+(* FIXME/TODO: needs to be adapted
+
+To prove that the raw theorem implies the regularised one, 
+we try in order:
+
+ - Reflexivity of the relation
+ - Assumption
+ - Elimnating quantifiers on both sides of toplevel implication
+ - Simplifying implications on both sides of toplevel implication
+ - Ball (Respects ?E) ?P = All ?P
+ - (\<And>x. ?R x \<Longrightarrow> ?P x \<longrightarrow> ?Q x) \<Longrightarrow> All ?P \<longrightarrow> Ball ?R ?Q
+
+*)
+ML {*
+fun regularize_tac ctxt =
+let
+  val thy = ProofContext.theory_of ctxt
+  val pat_ball = @{term "Ball (Respects (R1 ===> R2)) P"}
+  val pat_bex  = @{term "Bex (Respects (R1 ===> R2)) P"}
+  val simproc = Simplifier.simproc_i thy "" [pat_ball, pat_bex] (K (ball_bex_range_simproc))
+  val simpset = (mk_minimal_ss ctxt) 
+                       addsimps @{thms ball_reg_eqv bex_reg_eqv}
+                       addsimprocs [simproc] addSolver equiv_solver
+  (* TODO: Make sure that there are no list_rel, pair_rel etc involved *)
+  val eq_eqvs = map (fn x => @{thm eq_imp_rel} OF [x]) (equiv_rules_get ctxt)
+in
+  ObjectLogic.full_atomize_tac THEN'
+  simp_tac simpset THEN'
+  REPEAT_ALL_NEW (FIRST' [
+    rtac @{thm ball_reg_right},
+    rtac @{thm bex_reg_left},
+    resolve_tac (Inductive.get_monos ctxt),
+    rtac @{thm ball_all_comm},
+    rtac @{thm bex_ex_comm},
+    resolve_tac eq_eqvs,
+    simp_tac simpset])
+end
+*}
+
+section {* Injections of rep and abses *}
+
+(*
+Injecting repabs means:
+
+  For abstractions:
+  * If the type of the abstraction doesn't need lifting we recurse.
+  * If it does we add RepAbs around the whole term and check if the
+    variable needs lifting.
+    * If it doesn't then we recurse
+    * If it does we recurse and put 'RepAbs' around all occurences
+      of the variable in the obtained subterm. This in combination
+      with the RepAbs above will let us change the type of the
+      abstraction with rewriting.
+  For applications:
+  * If the term is 'Respects' applied to anything we leave it unchanged
+  * If the term needs lifting and the head is a constant that we know
+    how to lift, we put a RepAbs and recurse
+  * If the term needs lifting and the head is a free applied to subterms
+    (if it is not applied we treated it in Abs branch) then we
+    put RepAbs and recurse
+  * Otherwise just recurse.
+*)
+
+ML {*
+fun mk_repabs lthy (T, T') trm = 
+  Quotient_Def.get_fun repF lthy (T, T') 
+    $ (Quotient_Def.get_fun absF lthy (T, T') $ trm)
+*}
+
+ML {*
+(* bound variables need to be treated properly,    *)
+(* as the type of subterms need to be calculated   *)
+(* in the abstraction case                         *)
+
+fun inj_repabs_trm lthy (rtrm, qtrm) =
+ case (rtrm, qtrm) of
+    (Const (@{const_name "Ball"}, T) $ r $ t, Const (@{const_name "All"}, _) $ t') =>
+       Const (@{const_name "Ball"}, T) $ r $ (inj_repabs_trm lthy (t, t'))
+
+  | (Const (@{const_name "Bex"}, T) $ r $ t, Const (@{const_name "Ex"}, _) $ t') =>
+       Const (@{const_name "Bex"}, T) $ r $ (inj_repabs_trm lthy (t, t'))
+
+  | (Const (@{const_name "Babs"}, T) $ r $ t, t' as (Abs _)) =>
+       Const (@{const_name "Babs"}, T) $ r $ (inj_repabs_trm lthy (t, t'))
+
+  | (Abs (x, T, t), Abs (x', T', t')) =>
+      let
+        val rty = fastype_of rtrm
+        val qty = fastype_of qtrm
+        val (y, s) = Term.dest_abs (x, T, t)
+        val (_, s') = Term.dest_abs (x', T', t')
+        val yvar = Free (y, T)
+        val result = Term.lambda_name (y, yvar) (inj_repabs_trm lthy (s, s'))
+      in
+        if rty = qty 
+        then result
+        else mk_repabs lthy (rty, qty) result
+      end
+
+  | (t $ s, t' $ s') =>  
+       (inj_repabs_trm lthy (t, t')) $ (inj_repabs_trm lthy (s, s'))
+
+  | (Free (_, T), Free (_, T')) => 
+        if T = T' 
+        then rtrm 
+        else mk_repabs lthy (T, T') rtrm
+
+  | (_, Const (@{const_name "op ="}, _)) => rtrm
+
+    (* FIXME: check here that rtrm is the corresponding definition for the const *)
+  | (_, Const (_, T')) =>
+      let
+        val rty = fastype_of rtrm
+      in 
+        if rty = T'                    
+        then rtrm
+        else mk_repabs lthy (rty, T') rtrm
+      end   
+  
+  | _ => raise (LIFT_MATCH "injection")
+*}
+
+section {* RepAbs Injection Tactic *}
+
+ML {*
+fun quotient_tac ctxt =
+  REPEAT_ALL_NEW (FIRST'
+    [rtac @{thm identity_quotient},
+     resolve_tac (quotient_rules_get ctxt)])
+*}
+
+(* solver for the simplifier *)
+ML {*
+fun quotient_solver_tac ss = quotient_tac (Simplifier.the_context ss)
+val quotient_solver = Simplifier.mk_solver' "Quotient goal solver" quotient_solver_tac
+*}
+
+ML {*
+fun solve_quotient_assums ctxt thm =
+  let val gl = hd (Drule.strip_imp_prems (cprop_of thm)) in
+  thm OF [Goal.prove_internal [] gl (fn _ => quotient_tac ctxt 1)]
+  end
+  handle _ => error "solve_quotient_assums failed. Maybe a quotient_thm is missing"
+*}
+
+(* Not used *)
+(* It proves the Quotient assumptions by calling quotient_tac *)
+ML {*
+fun solve_quotient_assum i ctxt thm =
+  let
+    val tac =
+      (compose_tac (false, thm, i)) THEN_ALL_NEW
+      (quotient_tac ctxt);
+    val gc = Drule.strip_imp_concl (cprop_of thm);
+  in
+    Goal.prove_internal [] gc (fn _ => tac 1)
+  end
+  handle _ => error "solve_quotient_assum"
+*}
+
+definition
+  "QUOT_TRUE x \<equiv> True"
+
+ML {*
+fun find_qt_asm asms =
+  let
+    fun find_fun trm =
+      case trm of
+        (Const(@{const_name Trueprop}, _) $ (Const (@{const_name QUOT_TRUE}, _) $ _)) => true
+      | _ => false
+  in
+    case find_first find_fun asms of
+      SOME (_ $ (_ $ (f $ a))) => (f, a)
+    | SOME _ => error "find_qt_asm: no pair"
+    | NONE => error "find_qt_asm: no assumption"
+  end
+*}
+
+(*
+To prove that the regularised theorem implies the abs/rep injected, 
+we try:
+
+ 1) theorems 'trans2' from the appropriate QUOT_TYPE
+ 2) remove lambdas from both sides: lambda_rsp_tac
+ 3) remove Ball/Bex from the right hand side
+ 4) use user-supplied RSP theorems
+ 5) remove rep_abs from the right side
+ 6) reflexivity of equality
+ 7) split applications of lifted type (apply_rsp)
+ 8) split applications of non-lifted type (cong_tac)
+ 9) apply extentionality
+ A) reflexivity of the relation
+ B) assumption
+    (Lambdas under respects may have left us some assumptions)
+ C) proving obvious higher order equalities by simplifying fun_rel
+    (not sure if it is still needed?)
+ D) unfolding lambda on one side
+ E) simplifying (= ===> =) for simpler respectfulness
+
+*)
+
+lemma quot_true_dests:
+  shows QT_all: "QUOT_TRUE (All P) \<Longrightarrow> QUOT_TRUE P"
+  and   QT_ex:  "QUOT_TRUE (Ex P) \<Longrightarrow> QUOT_TRUE P"
+  and   QT_lam: "QUOT_TRUE (\<lambda>x. P x) \<Longrightarrow> (\<And>x. QUOT_TRUE  (P x))"
+  and   QT_ext: "(\<And>x. QUOT_TRUE (a x) \<Longrightarrow> f x = g x) \<Longrightarrow> (QUOT_TRUE a \<Longrightarrow> f = g)"
+apply(simp_all add: QUOT_TRUE_def ext)
+done
+
+lemma QUOT_TRUE_i: "(QUOT_TRUE (a :: bool) \<Longrightarrow> P) \<Longrightarrow> P"
+by (simp add: QUOT_TRUE_def)
+
+lemma QUOT_TRUE_imp: "QUOT_TRUE a \<equiv> QUOT_TRUE b"
+by (simp add: QUOT_TRUE_def)
+
+ML {*
+fun quot_true_conv1 ctxt fnctn ctrm =
+  case (term_of ctrm) of
+    (Const (@{const_name QUOT_TRUE}, _) $ x) =>
+    let
+      val fx = fnctn x;
+      val thy = ProofContext.theory_of ctxt;
+      val cx = cterm_of thy x;
+      val cfx = cterm_of thy fx;
+      val cxt = ctyp_of thy (fastype_of x);
+      val cfxt = ctyp_of thy (fastype_of fx);
+      val thm = Drule.instantiate' [SOME cxt, SOME cfxt] [SOME cx, SOME cfx] @{thm QUOT_TRUE_imp}
+    in
+      Conv.rewr_conv thm ctrm
+    end
+*}
+
+ML {*
+fun quot_true_conv ctxt fnctn ctrm =
+  case (term_of ctrm) of
+    (Const (@{const_name QUOT_TRUE}, _) $ _) =>
+      quot_true_conv1 ctxt fnctn ctrm
+  | _ $ _ => Conv.comb_conv (quot_true_conv ctxt fnctn) ctrm
+  | Abs _ => Conv.abs_conv (fn (_, ctxt) => quot_true_conv ctxt fnctn) ctxt ctrm
+  | _ => Conv.all_conv ctrm
+*}
+
+ML {*
+fun quot_true_tac ctxt fnctn = CONVERSION
+    ((Conv.params_conv ~1 (fn ctxt =>
+       (Conv.prems_conv ~1 (quot_true_conv ctxt fnctn)))) ctxt)
+*}
+
+ML {* fun dest_comb (f $ a) = (f, a) *}
+ML {* fun dest_bcomb ((_ $ l) $ r) = (l, r) *}
+(* TODO: Can this be done easier? *)
+ML {*
+fun unlam t =
+  case t of
+    (Abs a) => snd (Term.dest_abs a)
+  | _ => unlam (Abs("", domain_type (fastype_of t), (incr_boundvars 1 t) $ (Bound 0)))
+*}
+
+ML {*
+fun dest_fun_type (Type("fun", [T, S])) = (T, S)
+  | dest_fun_type _ = error "dest_fun_type"
+*}
+
+ML {*
+val bare_concl = HOLogic.dest_Trueprop o Logic.strip_assums_concl
+*}
+
+ML {*
+val apply_rsp_tac =
+  Subgoal.FOCUS (fn {concl, asms, context,...} =>
+    case ((HOLogic.dest_Trueprop (term_of concl))) of
+      ((R2 $ (f $ x) $ (g $ y))) =>
+        (let
+          val (asmf, asma) = find_qt_asm (map term_of asms);
+        in
+          if (fastype_of asmf) = (fastype_of f) then no_tac else let
+            val ty_a = fastype_of x;
+            val ty_b = fastype_of asma;
+            val ty_c = range_type (type_of f);
+            val thy = ProofContext.theory_of context;
+            val ty_inst = map (SOME o (ctyp_of thy)) [ty_a, ty_b, ty_c];
+            val thm = Drule.instantiate' ty_inst [] @{thm apply_rsp}
+            val te = solve_quotient_assums context thm
+            val t_inst = map (SOME o (cterm_of thy)) [R2, f, g, x, y];
+            val thm = Drule.instantiate' [] t_inst te
+          in
+            compose_tac (false, thm, 2) 1
+          end
+        end
+        handle ERROR "find_qt_asm: no pair" => no_tac)
+    | _ => no_tac)
+*}
+ML {*
+fun SOLVES' tac = tac THEN_ALL_NEW (fn _ => no_tac)
+*}
+
+ML {*
+fun rep_abs_rsp_tac ctxt =
+  SUBGOAL (fn (goal, i) =>
+    case (bare_concl goal) of 
+      (rel $ _ $ (rep $ (abs $ _))) =>
+        (let
+           val thy = ProofContext.theory_of ctxt;
+           val (ty_a, ty_b) = dest_fun_type (fastype_of abs);
+           val ty_inst = map (SOME o (ctyp_of thy)) [ty_a, ty_b];
+           val t_inst = map (SOME o (cterm_of thy)) [rel, abs, rep];
+           val thm = Drule.instantiate' ty_inst t_inst @{thm rep_abs_rsp}
+           val te = solve_quotient_assums ctxt thm
+         in
+           rtac te i
+         end
+         handle _ => no_tac)
+    | _ => no_tac)
+*}
+
+ML {*
+fun inj_repabs_tac_match ctxt trans2 = SUBGOAL (fn (goal, i) =>
+(case (bare_concl goal) of
+    (* (R1 ===> R2) (\<lambda>x\<dots>) (\<lambda>y\<dots>) ----> \<lbrakk>R1 x y\<rbrakk> \<Longrightarrow> R2 (\<dots>x) (\<dots>y) *)
+  ((Const (@{const_name fun_rel}, _) $ _ $ _) $ (Abs _) $ (Abs _))
+      => rtac @{thm fun_rel_id} THEN' quot_true_tac ctxt unlam
+
+    (* (op =) (Ball\<dots>) (Ball\<dots>) ----> (op =) (\<dots>) (\<dots>) *)
+| (Const (@{const_name "op ="},_) $
+    (Const(@{const_name Ball},_) $ (Const (@{const_name Respects}, _) $ _) $ _) $
+    (Const(@{const_name Ball},_) $ (Const (@{const_name Respects}, _) $ _) $ _))
+      => rtac @{thm ball_rsp} THEN' dtac @{thm QT_all}
+
+    (* (R1 ===> op =) (Ball\<dots>) (Ball\<dots>) ----> \<lbrakk>R1 x y\<rbrakk> \<Longrightarrow> (Ball\<dots>x) = (Ball\<dots>y) *)
+| (Const (@{const_name fun_rel}, _) $ _ $ _) $
+    (Const(@{const_name Ball},_) $ (Const (@{const_name Respects}, _) $ _) $ _) $
+    (Const(@{const_name Ball},_) $ (Const (@{const_name Respects}, _) $ _) $ _)
+      => rtac @{thm fun_rel_id} THEN' quot_true_tac ctxt unlam
+
+    (* (op =) (Bex\<dots>) (Bex\<dots>) ----> (op =) (\<dots>) (\<dots>) *)
+| Const (@{const_name "op ="},_) $
+    (Const(@{const_name Bex},_) $ (Const (@{const_name Respects}, _) $ _) $ _) $
+    (Const(@{const_name Bex},_) $ (Const (@{const_name Respects}, _) $ _) $ _)
+      => rtac @{thm bex_rsp} THEN' dtac @{thm QT_ex}
+
+    (* (R1 ===> op =) (Bex\<dots>) (Bex\<dots>) ----> \<lbrakk>R1 x y\<rbrakk> \<Longrightarrow> (Bex\<dots>x) = (Bex\<dots>y) *)
+| (Const (@{const_name fun_rel}, _) $ _ $ _) $
+    (Const(@{const_name Bex},_) $ (Const (@{const_name Respects}, _) $ _) $ _) $
+    (Const(@{const_name Bex},_) $ (Const (@{const_name Respects}, _) $ _) $ _)
+      => rtac @{thm fun_rel_id} THEN' quot_true_tac ctxt unlam
+
+| (_ $
+    (Const(@{const_name Babs},_) $ (Const (@{const_name Respects}, _) $ _) $ _) $
+    (Const(@{const_name Babs},_) $ (Const (@{const_name Respects}, _) $ _) $ _))
+      => rtac @{thm babs_rsp} THEN' RANGE [quotient_tac ctxt]
+
+    (* reflexivity of operators arising from Cong_tac *)
+| Const (@{const_name "op ="},_) $ _ $ _ 
+      => rtac @{thm refl} ORELSE'
+          (resolve_tac trans2 THEN' RANGE [
+            quot_true_tac ctxt (fst o dest_bcomb), quot_true_tac ctxt (snd o dest_bcomb)])
+
+(* TODO: These patterns should should be somehow combined and generalized... *)
+| (Const (@{const_name fun_rel}, _) $ _ $ _) $
+    (Const (@{const_name fun_rel}, _) $ _ $ _) $
+    (Const (@{const_name fun_rel}, _) $ _ $ _)
+    => rtac @{thm quot_rel_rsp} THEN_ALL_NEW quotient_tac ctxt
+
+| (Const (@{const_name fun_rel}, _) $ _ $ _) $
+    (Const (@{const_name prod_rel}, _) $ _ $ _) $
+    (Const (@{const_name prod_rel}, _) $ _ $ _)
+    => rtac @{thm quot_rel_rsp} THEN_ALL_NEW quotient_tac ctxt
+
+   (* respectfulness of constants; in particular of a simple relation *)
+| _ $ (Const _) $ (Const _)  (* fun_rel, list_rel, etc but not equality *)
+    => resolve_tac (rsp_rules_get ctxt) THEN_ALL_NEW quotient_tac ctxt
+
+    (* R (\<dots>) (Rep (Abs \<dots>)) ----> R (\<dots>) (\<dots>) *)
+    (* observe ---> *)
+| _ $ _ $ _ 
+    => rep_abs_rsp_tac ctxt
+
+| _ => error "inj_repabs_tac not a relation"
+) i)
+*}
+
+ML {*
+fun inj_repabs_tac ctxt rel_refl trans2 =
+  (FIRST' [
+    inj_repabs_tac_match ctxt trans2,
+    (* R (t $ \<dots>) (t' $ \<dots>) ----> apply_rsp   provided type of t needs lifting *)
+    NDT ctxt "A" (apply_rsp_tac ctxt THEN'
+                (RANGE [quot_true_tac ctxt (fst o dest_comb), quot_true_tac ctxt (snd o dest_comb)])),
+    (* (op =) (t $ \<dots>) (t' $ \<dots>) ----> Cong   provided type of t does not need lifting *)
+    (* merge with previous tactic *)
+    NDT ctxt "B" (Cong_Tac.cong_tac @{thm cong} THEN'
+                (RANGE [quot_true_tac ctxt (fst o dest_comb), quot_true_tac ctxt (snd o dest_comb)])),
+    (* (op =) (\<lambda>x\<dots>) (\<lambda>x\<dots>) ----> (op =) (\<dots>) (\<dots>) *)
+    NDT ctxt "C" (rtac @{thm ext} THEN' quot_true_tac ctxt unlam),
+    (* resolving with R x y assumptions *)
+    NDT ctxt "E" (atac),
+    (* reflexivity of the basic relations *)
+    (* R \<dots> \<dots> *)
+    NDT ctxt "D" (resolve_tac rel_refl)
+    ])
+*}
+
+ML {*
+fun all_inj_repabs_tac ctxt rel_refl trans2 =
+  REPEAT_ALL_NEW (inj_repabs_tac ctxt rel_refl trans2)
+*}
+
+section {* Cleaning of the theorem *}
+
+ML {*
+fun make_inst lhs t =
+  let
+    val _ $ (Abs (_, _, (f as Var (_, Type ("fun", [T, _]))) $ u)) = lhs;
+    val _ $ (Abs (_, _, g)) = t;
+    fun mk_abs i t =
+      if incr_boundvars i u aconv t then Bound i
+      else (case t of
+        t1 $ t2 => mk_abs i t1 $ mk_abs i t2
+      | Abs (s, T, t') => Abs (s, T, mk_abs (i + 1) t')
+      | Bound j => if i = j then error "make_inst" else t
+      | _ => t);
+  in (f, Abs ("x", T, mk_abs 0 g)) end;
+*}
+
+ML {*
+fun lambda_prs_simple_conv ctxt ctrm =
+  case (term_of ctrm) of
+   ((Const (@{const_name fun_map}, _) $ r1 $ (a2 as (Const (s,_)))) $ (Abs _)) =>
+     let
+       val thy = ProofContext.theory_of ctxt
+       val (ty_b, ty_a) = dest_fun_type (fastype_of r1)
+       val (ty_c, ty_d) = dest_fun_type (fastype_of a2)
+       val tyinst = map (SOME o (ctyp_of thy)) [ty_a, ty_b, ty_c, ty_d]
+       val tinst = [NONE, NONE, SOME (cterm_of thy r1), NONE, SOME (cterm_of thy a2)]
+       val lpi = Drule.instantiate' tyinst tinst @{thm lambda_prs}
+       val te = @{thm eq_reflection} OF [solve_quotient_assums ctxt (solve_quotient_assums ctxt lpi)]
+       val ts = MetaSimplifier.rewrite_rule @{thms id_simps} te
+       val _ = tracing ("te rule:\n" ^ (Syntax.string_of_term ctxt (prop_of te)));
+       val tl = Thm.lhs_of ts
+       val (insp, inst) = make_inst (term_of tl) (term_of ctrm)
+       val ti = Drule.instantiate ([], [(cterm_of thy insp, cterm_of thy inst)]) ts
+       val _ = if not (s = @{const_name "id"}) then
+                  (tracing "lambda_prs";
+                   tracing ("redex:\n" ^ (Syntax.string_of_term ctxt (term_of ctrm)));
+                   tracing ("lpi rule:\n" ^ (Syntax.string_of_term ctxt (prop_of lpi)));
+                   tracing ("te rule:\n" ^ (Syntax.string_of_term ctxt (prop_of te)));
+                   tracing ("ts rule:\n" ^ (Syntax.string_of_term ctxt (prop_of ts)));
+                   tracing ("instantiated rule:\n" ^ (Syntax.string_of_term ctxt (prop_of ti))))
+               else ()
+     in
+       Conv.rewr_conv ti ctrm
+     end
+  | _ => Conv.all_conv ctrm
+*}
+
+ML {*
+val lambda_prs_conv =
+  More_Conv.top_conv lambda_prs_simple_conv
+
+fun lambda_prs_tac ctxt = CONVERSION (lambda_prs_conv ctxt)
+*}
+
+(*
+ Cleaning the theorem consists of three rewriting steps.
+ The first two need to be done before fun_map is unfolded
+
+ 1) lambda_prs:
+     (Rep1 ---> Abs2) (\<lambda>x. Rep2 (f (Abs1 x)))  ---->  f
+
+    Implemented as conversion since it is not a pattern.
+
+ 2) all_prs (the same for exists):
+     Ball (Respects R) ((abs ---> id) f)  ---->  All f
+
+    Rewriting with definitions from the argument defs
+     (rep ---> abs) oldConst ----> newconst
+
+ 3) Quotient_rel_rep:
+      Rel (Rep x) (Rep y)  ---->  x = y
+
+    Quotient_abs_rep:
+      Abs (Rep x)  ---->  x
+
+    id_simps; fun_map.simps
+*)
+
+ML {*
+fun clean_tac lthy =
+  let
+    val thy = ProofContext.theory_of lthy;
+    val defs = map (Thm.varifyT o symmetric o #def) (qconsts_dest thy)
+      (* FIXME: shouldn't the definitions already be varified? *)
+    val thms1 = @{thms all_prs ex_prs} @ defs
+    val thms2 = @{thms eq_reflection[OF fun_map.simps]} 
+                @ @{thms id_simps Quotient_abs_rep Quotient_rel_rep} 
+    fun simps thms = (mk_minimal_ss lthy) addsimps thms addSolver quotient_solver
+  in
+    EVERY' [lambda_prs_tac lthy,
+            simp_tac (simps thms1),
+            simp_tac (simps thms2),
+            TRY o rtac refl]
+  end
+*}
+
+section {* Genralisation of free variables in a goal *}
+
+ML {*
+fun inst_spec ctrm =
+   Drule.instantiate' [SOME (ctyp_of_term ctrm)] [NONE, SOME ctrm] @{thm spec}
+
+fun inst_spec_tac ctrms =
+  EVERY' (map (dtac o inst_spec) ctrms)
+
+fun all_list xs trm = 
+  fold (fn (x, T) => fn t' => HOLogic.mk_all (x, T, t')) xs trm
+
+fun apply_under_Trueprop f = 
+  HOLogic.dest_Trueprop #> f #> HOLogic.mk_Trueprop
+
+fun gen_frees_tac ctxt =
+ SUBGOAL (fn (concl, i) =>
+  let
+    val thy = ProofContext.theory_of ctxt
+    val vrs = Term.add_frees concl []
+    val cvrs = map (cterm_of thy o Free) vrs
+    val concl' = apply_under_Trueprop (all_list vrs) concl
+    val goal = Logic.mk_implies (concl', concl)
+    val rule = Goal.prove ctxt [] [] goal 
+      (K (EVERY1 [inst_spec_tac (rev cvrs), atac]))
+  in
+    rtac rule i
+  end)  
+*}
+
+section {* General outline of the lifting procedure *}
+
+(* - A is the original raw theorem          *)
+(* - B is the regularized theorem           *)
+(* - C is the rep/abs injected version of B *) 
+(* - D is the lifted theorem                *)
+(*                                          *)
+(* - b is the regularization step           *)
+(* - c is the rep/abs injection step        *)
+(* - d is the cleaning part                 *)
+
+lemma lifting_procedure:
+  assumes a: "A"
+  and     b: "A \<Longrightarrow> B"
+  and     c: "B = C"
+  and     d: "C = D"
+  shows   "D"
+  using a b c d
+  by simp
+
+ML {*
+fun lift_match_error ctxt fun_str rtrm qtrm =
+let
+  val rtrm_str = Syntax.string_of_term ctxt rtrm
+  val qtrm_str = Syntax.string_of_term ctxt qtrm
+  val msg = [enclose "[" "]" fun_str, "The quotient theorem\n", qtrm_str, 
+             "and the lifted theorem\n", rtrm_str, "do not match"]
+in
+  error (space_implode " " msg)
+end
+*}
+
+ML {* 
+fun procedure_inst ctxt rtrm qtrm =
+let
+  val thy = ProofContext.theory_of ctxt
+  val rtrm' = HOLogic.dest_Trueprop rtrm
+  val qtrm' = HOLogic.dest_Trueprop qtrm
+  val reg_goal = 
+        Syntax.check_term ctxt (regularize_trm ctxt rtrm' qtrm')
+        handle (LIFT_MATCH s) => lift_match_error ctxt s rtrm qtrm
+  val _ = warning "Regularization done."
+  val inj_goal = 
+        Syntax.check_term ctxt (inj_repabs_trm ctxt (reg_goal, qtrm'))
+        handle (LIFT_MATCH s) => lift_match_error ctxt s rtrm qtrm
+  val _ = warning "RepAbs Injection done."
+in
+  Drule.instantiate' []
+    [SOME (cterm_of thy rtrm'),
+     SOME (cterm_of thy reg_goal),
+     SOME (cterm_of thy inj_goal)] @{thm lifting_procedure}
+end
+*}
+
+(* Left for debugging *)
+ML {*
+fun procedure_tac ctxt rthm =
+  ObjectLogic.full_atomize_tac
+  THEN' gen_frees_tac ctxt
+  THEN' CSUBGOAL (fn (gl, i) =>
+    let
+      val rthm' = atomize_thm rthm
+      val rule = procedure_inst ctxt (prop_of rthm') (term_of gl)
+      val thm = Drule.instantiate' [] [SOME (snd (Thm.dest_comb gl))] @{thm QUOT_TRUE_i}
+    in
+      (rtac rule THEN' RANGE [rtac rthm', (fn _ => all_tac), rtac thm]) i
+    end)
+*}
+
+ML {*
+(* FIXME/TODO should only get as arguments the rthm like procedure_tac *)
+
+fun lift_tac ctxt rthm =
+  ObjectLogic.full_atomize_tac
+  THEN' gen_frees_tac ctxt
+  THEN' CSUBGOAL (fn (gl, i) =>
+    let
+      val rthm' = atomize_thm rthm
+      val rule = procedure_inst ctxt (prop_of rthm') (term_of gl)
+      val rel_refl = map (fn x => @{thm equivp_reflp} OF [x]) (equiv_rules_get ctxt)
+      val quotients = quotient_rules_get ctxt
+      val trans2 = map (fn x => @{thm equals_rsp} OF [x]) quotients
+      val thm = Drule.instantiate' [] [SOME (snd (Thm.dest_comb gl))] @{thm QUOT_TRUE_i}
+    in
+      (rtac rule THEN'
+       RANGE [rtac rthm',
+              regularize_tac ctxt,
+              rtac thm THEN' all_inj_repabs_tac ctxt rel_refl trans2,
+              clean_tac ctxt]) i
+    end)
+*}
+
+end
+
diff -r 6088fea1c8b1 -r 8a1c8dc72b5c Quot/QuotProd.thy
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Quot/QuotProd.thy	Mon Dec 07 14:09:50 2009 +0100
@@ -0,0 +1,80 @@
+theory QuotProd
+imports QuotScript
+begin
+
+fun
+  prod_rel
+where
+  "prod_rel r1 r2 = (\<lambda>(a,b) (c,d). r1 a c \<and> r2 b d)"
+
+(* prod_fun is a good mapping function *)
+
+lemma prod_equivp:
+  assumes a: "equivp R1"
+  assumes b: "equivp R2"
+  shows "equivp (prod_rel R1 R2)"
+unfolding equivp_reflp_symp_transp reflp_def symp_def transp_def
+apply(auto simp add: equivp_reflp[OF a] equivp_reflp[OF b])
+apply(simp only: equivp_symp[OF a])
+apply(simp only: equivp_symp[OF b])
+using equivp_transp[OF a] apply blast
+using equivp_transp[OF b] apply blast
+done
+
+lemma prod_quotient:
+  assumes q1: "Quotient R1 Abs1 Rep1"
+  assumes q2: "Quotient R2 Abs2 Rep2"
+  shows "Quotient (prod_rel R1 R2) (prod_fun Abs1 Abs2) (prod_fun Rep1 Rep2)"
+unfolding Quotient_def
+apply (simp add: Quotient_abs_rep[OF q1] Quotient_abs_rep[OF q2] Quotient_rel_rep[OF q1] Quotient_rel_rep[OF q2])
+using Quotient_rel[OF q1] Quotient_rel[OF q2] by blast
+
+lemma pair_rsp:
+  assumes q1: "Quotient R1 Abs1 Rep1"
+  assumes q2: "Quotient R2 Abs2 Rep2"
+  shows "(R1 ===> R2 ===> prod_rel R1 R2) Pair Pair"
+by auto
+
+lemma pair_prs:
+  assumes q1: "Quotient R1 Abs1 Rep1"
+  assumes q2: "Quotient R2 Abs2 Rep2"
+  shows "(prod_fun Abs1 Abs2) (Rep1 l, Rep2 r) \<equiv> (l, r)"
+  by (simp add: Quotient_abs_rep[OF q1] Quotient_abs_rep[OF q2])
+
+(* TODO: Is the quotient assumption q1 necessary? *)
+(* TODO: Aren't there hard to use later? *)
+lemma fst_rsp:
+  assumes q1: "Quotient R1 Abs1 Rep1"
+  assumes q2: "Quotient R2 Abs2 Rep2"
+  assumes a: "(prod_rel R1 R2) p1 p2"
+  shows "R1 (fst p1) (fst p2)"
+  using a
+  apply(case_tac p1)
+  apply(case_tac p2)
+  apply(auto)
+  done
+
+lemma snd_rsp:
+  assumes q1: "Quotient R1 Abs1 Rep1"
+  assumes q2: "Quotient R2 Abs2 Rep2"
+  assumes a: "(prod_rel R1 R2) p1 p2"
+  shows "R2 (snd p1) (snd p2)"
+  using a
+  apply(case_tac p1)
+  apply(case_tac p2)
+  apply(auto)
+  done
+
+lemma fst_prs:
+  assumes q1: "Quotient R1 Abs1 Rep1"
+  assumes q2: "Quotient R2 Abs2 Rep2"
+  shows "Abs1 (fst ((prod_fun Rep1 Rep2) p)) = fst p"
+by (case_tac p) (auto simp add: Quotient_abs_rep[OF q1])
+
+lemma snd_prs:
+  assumes q1: "Quotient R1 Abs1 Rep1"
+  assumes q2: "Quotient R2 Abs2 Rep2"
+  shows "Abs2 (snd ((prod_fun Rep1 Rep2) p)) = snd p"
+by (case_tac p) (auto simp add: Quotient_abs_rep[OF q2])
+
+end
diff -r 6088fea1c8b1 -r 8a1c8dc72b5c Quot/QuotScript.thy
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Quot/QuotScript.thy	Mon Dec 07 14:09:50 2009 +0100
@@ -0,0 +1,569 @@
+theory QuotScript
+imports Plain ATP_Linkup
+begin
+
+definition
+  "equivp E \<equiv> \<forall>x y. E x y = (E x = E y)"
+
+definition
+  "reflp E \<equiv> \<forall>x. E x x"
+
+definition
+  "symp E \<equiv> \<forall>x y. E x y \<longrightarrow> E y x"
+
+definition
+  "transp E \<equiv> \<forall>x y z. E x y \<and> E y z \<longrightarrow> E x z"
+
+lemma equivp_reflp_symp_transp:
+  shows "equivp E = (reflp E \<and> symp E \<and> transp E)"
+  unfolding equivp_def reflp_def symp_def transp_def expand_fun_eq
+  by (blast)
+
+lemma equivp_reflp:
+  shows "equivp E \<Longrightarrow> (\<And>x. E x x)"
+  by (simp only: equivp_reflp_symp_transp reflp_def)
+
+lemma equivp_symp:
+  shows "equivp E \<Longrightarrow> (\<And>x y. E x y \<Longrightarrow> E y x)"
+  by (metis equivp_reflp_symp_transp symp_def)
+
+lemma equivp_transp:
+  shows "equivp E \<Longrightarrow> (\<And>x y z. E x y \<Longrightarrow> E y z \<Longrightarrow> E x z)"
+by (metis equivp_reflp_symp_transp transp_def)
+
+definition
+  "part_equivp E \<equiv> (\<exists>x. E x x) \<and> (\<forall>x y. E x y = (E x x \<and> E y y \<and> (E x = E y)))"
+
+lemma equivp_IMP_part_equivp:
+  assumes a: "equivp E"
+  shows "part_equivp E"
+  using a unfolding equivp_def part_equivp_def
+  by auto
+
+definition
+  "Quotient E Abs Rep \<equiv> (\<forall>a. Abs (Rep a) = a) \<and>
+                        (\<forall>a. E (Rep a) (Rep a)) \<and>
+                        (\<forall>r s. E r s = (E r r \<and> E s s \<and> (Abs r = Abs s)))"
+
+lemma Quotient_abs_rep:
+  assumes a: "Quotient E Abs Rep"
+  shows "Abs (Rep a) \<equiv> a"
+  using a unfolding Quotient_def
+  by simp
+
+lemma Quotient_rep_reflp:
+  assumes a: "Quotient E Abs Rep"
+  shows "E (Rep a) (Rep a)"
+  using a unfolding Quotient_def
+  by blast
+
+lemma Quotient_rel:
+  assumes a: "Quotient E Abs Rep"
+  shows " E r s = (E r r \<and> E s s \<and> (Abs r = Abs s))"
+  using a unfolding Quotient_def
+  by blast
+
+lemma Quotient_rel_rep:
+  assumes a: "Quotient R Abs Rep"
+  shows "R (Rep a) (Rep b) \<equiv> (a = b)"
+  apply (rule eq_reflection)
+  using a unfolding Quotient_def
+  by metis
+
+lemma Quotient_rep_abs:
+  assumes a: "Quotient R Abs Rep"
+  shows "R r r \<Longrightarrow> R (Rep (Abs r)) r"
+  using a unfolding Quotient_def
+  by blast
+
+lemma identity_equivp:
+  shows "equivp (op =)"
+  unfolding equivp_def
+  by auto
+
+lemma identity_quotient:
+  shows "Quotient (op =) id id"
+  unfolding Quotient_def id_def
+  by blast
+
+lemma Quotient_symp:
+  assumes a: "Quotient E Abs Rep"
+  shows "symp E"
+  using a unfolding Quotient_def symp_def
+  by metis
+
+lemma Quotient_transp:
+  assumes a: "Quotient E Abs Rep"
+  shows "transp E"
+  using a unfolding Quotient_def transp_def
+  by metis
+
+fun
+  fun_map
+where
+  "fun_map f g h x = g (h (f x))"
+
+abbreviation
+  fun_map_syn (infixr "--->" 55)
+where
+  "f ---> g \<equiv> fun_map f g"
+
+lemma fun_map_id:
+  shows "(id ---> id) = id"
+  by (simp add: expand_fun_eq id_def)
+
+fun
+  fun_rel
+where
+  "fun_rel E1 E2 f g = (\<forall>x y. E1 x y \<longrightarrow> E2 (f x) (g y))"
+
+abbreviation
+  fun_rel_syn (infixr "===>" 55)
+where
+  "E1 ===> E2 \<equiv> fun_rel E1 E2"
+
+lemma fun_rel_eq:
+  "(op =) ===> (op =) \<equiv> (op =)"
+by (rule eq_reflection) (simp add: expand_fun_eq)
+
+lemma fun_quotient:
+  assumes q1: "Quotient R1 abs1 rep1"
+  and     q2: "Quotient R2 abs2 rep2"
+  shows "Quotient (R1 ===> R2) (rep1 ---> abs2) (abs1 ---> rep2)"
+proof -
+  have "\<forall>a. (rep1 ---> abs2) ((abs1 ---> rep2) a) = a"
+    apply(simp add: expand_fun_eq)
+    using q1 q2
+    apply(simp add: Quotient_def)
+    done
+  moreover
+  have "\<forall>a. (R1 ===> R2) ((abs1 ---> rep2) a) ((abs1 ---> rep2) a)"
+    apply(auto)
+    using q1 q2 unfolding Quotient_def
+    apply(metis)
+    done
+  moreover
+  have "\<forall>r s. (R1 ===> R2) r s = ((R1 ===> R2) r r \<and> (R1 ===> R2) s s \<and> 
+        (rep1 ---> abs2) r  = (rep1 ---> abs2) s)"
+    apply(auto simp add: expand_fun_eq)
+    using q1 q2 unfolding Quotient_def
+    apply(metis)
+    using q1 q2 unfolding Quotient_def
+    apply(metis)
+    using q1 q2 unfolding Quotient_def
+    apply(metis)
+    using q1 q2 unfolding Quotient_def
+    apply(metis)
+    done
+  ultimately
+  show "Quotient (R1 ===> R2) (rep1 ---> abs2) (abs1 ---> rep2)"
+    unfolding Quotient_def by blast
+qed
+
+definition
+  Respects
+where
+  "Respects R x \<equiv> (R x x)"
+
+lemma in_respects:
+  shows "(x \<in> Respects R) = R x x"
+  unfolding mem_def Respects_def by simp
+
+lemma equals_rsp:
+  assumes q: "Quotient R Abs Rep"
+  and     a: "R xa xb" "R ya yb"
+  shows "R xa ya = R xb yb"
+  using Quotient_symp[OF q] Quotient_transp[OF q] unfolding symp_def transp_def
+  using a by blast
+
+lemma lambda_prs:
+  assumes q1: "Quotient R1 Abs1 Rep1"
+  and     q2: "Quotient R2 Abs2 Rep2"
+  shows "(Rep1 ---> Abs2) (\<lambda>x. Rep2 (f (Abs1 x))) = (\<lambda>x. f x)"
+  unfolding expand_fun_eq
+  using Quotient_abs_rep[OF q1] Quotient_abs_rep[OF q2]
+  by simp
+
+lemma lambda_prs1:
+  assumes q1: "Quotient R1 Abs1 Rep1"
+  and     q2: "Quotient R2 Abs2 Rep2"
+  shows "(Rep1 ---> Abs2) (\<lambda>x. (Abs1 ---> Rep2) f x) = (\<lambda>x. f x)"
+  unfolding expand_fun_eq
+  using Quotient_abs_rep[OF q1] Quotient_abs_rep[OF q2]
+  by simp
+
+lemma rep_abs_rsp:
+  assumes q: "Quotient R Abs Rep"
+  and     a: "R x1 x2"
+  shows "R x1 (Rep (Abs x2))"
+  using q a by (metis Quotient_rel[OF q] Quotient_abs_rep[OF q] Quotient_rep_reflp[OF q])
+
+(* In the following theorem R1 can be instantiated with anything,
+   but we know some of the types of the Rep and Abs functions;
+   so by solving Quotient assumptions we can get a unique R1 that
+   will be provable; which is why we need to use apply_rsp and
+   not the primed version *)
+lemma apply_rsp:
+  assumes q: "Quotient R1 Abs1 Rep1"
+  and     a: "(R1 ===> R2) f g" "R1 x y"
+  shows "R2 ((f::'a\<Rightarrow>'c) x) ((g::'a\<Rightarrow>'c) y)"
+  using a by simp
+
+lemma apply_rsp':
+  assumes a: "(R1 ===> R2) f g" "R1 x y"
+  shows "R2 (f x) (g y)"
+  using a by simp
+
+(* Set of lemmas for regularisation of ball and bex *)
+
+lemma ball_reg_eqv:
+  fixes P :: "'a \<Rightarrow> bool"
+  assumes a: "equivp R"
+  shows "Ball (Respects R) P = (All P)"
+  by (metis equivp_def in_respects a)
+
+lemma bex_reg_eqv:
+  fixes P :: "'a \<Rightarrow> bool"
+  assumes a: "equivp R"
+  shows "Bex (Respects R) P = (Ex P)"
+  by (metis equivp_def in_respects a)
+
+lemma ball_reg_right:
+  assumes a: "\<And>x. R x \<Longrightarrow> P x \<longrightarrow> Q x"
+  shows "All P \<longrightarrow> Ball R Q"
+  by (metis COMBC_def Collect_def Collect_mem_eq a)
+
+lemma bex_reg_left:
+  assumes a: "\<And>x. R x \<Longrightarrow> Q x \<longrightarrow> P x"
+  shows "Bex R Q \<longrightarrow> Ex P"
+  by (metis COMBC_def Collect_def Collect_mem_eq a)
+
+lemma ball_reg_left:
+  assumes a: "equivp R"
+  shows "(\<And>x. (Q x \<longrightarrow> P x)) \<Longrightarrow> Ball (Respects R) Q \<longrightarrow> All P"
+  by (metis equivp_reflp in_respects a)
+
+lemma bex_reg_right:
+  assumes a: "equivp R"
+  shows "(\<And>x. (Q x \<longrightarrow> P x)) \<Longrightarrow> Ex Q \<longrightarrow> Bex (Respects R) P"
+  by (metis equivp_reflp in_respects a)
+
+lemma ball_reg_eqv_range:
+  fixes P::"'a \<Rightarrow> bool"
+  and x::"'a"
+  assumes a: "equivp R2"
+  shows   "(Ball (Respects (R1 ===> R2)) (\<lambda>f. P (f x)) = All (\<lambda>f. P (f x)))"
+  apply(rule iffI)
+  apply(rule allI)
+  apply(drule_tac x="\<lambda>y. f x" in bspec)
+  apply(simp add: Respects_def in_respects)
+  apply(rule impI)
+  using a equivp_reflp_symp_transp[of "R2"]
+  apply(simp add: reflp_def)
+  apply(simp)
+  apply(simp)
+  done
+
+lemma bex_reg_eqv_range:
+  fixes P::"'a \<Rightarrow> bool"
+  and x::"'a"
+  assumes a: "equivp R2"
+  shows   "(Bex (Respects (R1 ===> R2)) (\<lambda>f. P (f x)) = Ex (\<lambda>f. P (f x)))"
+  apply(auto)
+  apply(rule_tac x="\<lambda>y. f x" in bexI)
+  apply(simp)
+  apply(simp add: Respects_def in_respects)
+  apply(rule impI)
+  using a equivp_reflp_symp_transp[of "R2"]
+  apply(simp add: reflp_def)
+  done
+
+lemma all_reg:
+  assumes a: "!x :: 'a. (P x --> Q x)"
+  and     b: "All P"
+  shows "All Q"
+  using a b by (metis)
+
+lemma ex_reg:
+  assumes a: "!x :: 'a. (P x --> Q x)"
+  and     b: "Ex P"
+  shows "Ex Q"
+  using a b by (metis)
+
+lemma ball_reg:
+  assumes a: "!x :: 'a. (R x --> P x --> Q x)"
+  and     b: "Ball R P"
+  shows "Ball R Q"
+  using a b by (metis COMBC_def Collect_def Collect_mem_eq)
+
+lemma bex_reg:
+  assumes a: "!x :: 'a. (R x --> P x --> Q x)"
+  and     b: "Bex R P"
+  shows "Bex R Q"
+  using a b by (metis COMBC_def Collect_def Collect_mem_eq)
+
+lemma ball_all_comm:
+  "(\<And>y. (\<forall>x\<in>P. A x y) \<longrightarrow> (\<forall>x. B x y)) \<Longrightarrow> ((\<forall>x\<in>P. \<forall>y. A x y) \<longrightarrow> (\<forall>x. \<forall>y. B x y))"
+by auto
+
+lemma bex_ex_comm:
+  "((\<exists>y. \<exists>x. A x y) \<longrightarrow> (\<exists>y. \<exists>x\<in>P. B x y)) \<Longrightarrow> ((\<exists>x. \<exists>y. A x y) \<longrightarrow> (\<exists>x\<in>P. \<exists>y. B x y))"
+by auto
+
+(* Bounded abstraction *)
+definition
+  Babs :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b"
+where
+  "(x \<in> p) \<Longrightarrow> (Babs p m x = m x)"
+
+(* 3 lemmas needed for proving repabs_inj *)
+lemma ball_rsp:
+  assumes a: "(R ===> (op =)) f g"
+  shows "Ball (Respects R) f = Ball (Respects R) g"
+  using a by (simp add: Ball_def in_respects)
+
+lemma bex_rsp:
+  assumes a: "(R ===> (op =)) f g"
+  shows "(Bex (Respects R) f = Bex (Respects R) g)"
+  using a by (simp add: Bex_def in_respects)
+
+lemma babs_rsp:
+  assumes q: "Quotient R1 Abs1 Rep1"
+  and     a: "(R1 ===> R2) f g"
+  shows      "(R1 ===> R2) (Babs (Respects R1) f) (Babs (Respects R1) g)"
+  apply (auto simp add: Babs_def)
+  apply (subgoal_tac "x \<in> Respects R1 \<and> y \<in> Respects R1")
+  using a apply (simp add: Babs_def)
+  apply (simp add: in_respects)
+  using Quotient_rel[OF q]
+  by metis
+
+(* 2 lemmas needed for cleaning of quantifiers *)
+lemma all_prs:
+  assumes a: "Quotient R absf repf"
+  shows "Ball (Respects R) ((absf ---> id) f) = All f"
+  using a unfolding Quotient_def
+  by (metis in_respects fun_map.simps id_apply)
+
+lemma ex_prs:
+  assumes a: "Quotient R absf repf"
+  shows "Bex (Respects R) ((absf ---> id) f) = Ex f"
+  using a unfolding Quotient_def
+  by (metis COMBC_def Collect_def Collect_mem_eq in_respects fun_map.simps id_apply)
+
+lemma fun_rel_id:
+  assumes a: "\<And>x y. R1 x y \<Longrightarrow> R2 (f x) (g y)"
+  shows "(R1 ===> R2) f g"
+using a by simp
+
+lemma quot_rel_rsp:
+  assumes a: "Quotient R Abs Rep"
+  shows "(R ===> R ===> op =) R R"
+  apply(rule fun_rel_id)+
+  apply(rule equals_rsp[OF a])
+  apply(assumption)+
+  done
+
+
+
+
+
+
+(******************************************)
+(* REST OF THE FILE IS UNUSED (until now) *)
+(******************************************)
+lemma Quotient_rel_abs:
+  assumes a: "Quotient E Abs Rep"
+  shows "E r s \<Longrightarrow> Abs r = Abs s"
+using a unfolding Quotient_def
+by blast
+
+lemma Quotient_rel_abs_eq:
+  assumes a: "Quotient E Abs Rep"
+  shows "E r r \<Longrightarrow> E s s \<Longrightarrow> E r s = (Abs r = Abs s)"
+using a unfolding Quotient_def
+by blast
+
+lemma in_fun:
+  shows "x \<in> ((f ---> g) s) = g (f x \<in> s)"
+by (simp add: mem_def)
+
+lemma RESPECTS_THM:
+  shows "Respects (R1 ===> R2) f = (\<forall>x y. R1 x y \<longrightarrow> R2 (f x) (f y))"
+unfolding Respects_def
+by (simp add: expand_fun_eq) 
+
+lemma RESPECTS_REP_ABS:
+  assumes a: "Quotient R1 Abs1 Rep1"
+  and     b: "Respects (R1 ===> R2) f"
+  and     c: "R1 x x"
+  shows "R2 (f (Rep1 (Abs1 x))) (f x)"
+using a b[simplified RESPECTS_THM] c unfolding Quotient_def
+by blast
+
+lemma RESPECTS_MP:
+  assumes a: "Respects (R1 ===> R2) f"
+  and     b: "R1 x y"
+  shows "R2 (f x) (f y)"
+using a b unfolding Respects_def
+by simp
+
+lemma RESPECTS_o:
+  assumes a: "Respects (R2 ===> R3) f"
+  and     b: "Respects (R1 ===> R2) g"
+  shows "Respects (R1 ===> R3) (f o g)"
+using a b unfolding Respects_def
+by simp
+
+lemma fun_rel_EQ_REL:
+  assumes q1: "Quotient R1 Abs1 Rep1"
+  and     q2: "Quotient R2 Abs2 Rep2"
+  shows "(R1 ===> R2) f g = ((Respects (R1 ===> R2) f) \<and> (Respects (R1 ===> R2) g) 
+                             \<and> ((Rep1 ---> Abs2) f = (Rep1 ---> Abs2) g))"
+using fun_quotient[OF q1 q2] unfolding Respects_def Quotient_def expand_fun_eq
+by blast
+
+(* Not used since in the end we just unfold fun_map *)
+lemma APP_PRS:
+  assumes q1: "Quotient R1 abs1 rep1"
+  and     q2: "Quotient R2 abs2 rep2"
+  shows "abs2 ((abs1 ---> rep2) f (rep1 x)) = f x"
+unfolding expand_fun_eq
+using Quotient_abs_rep[OF q1] Quotient_abs_rep[OF q2]
+by simp
+
+(* Ask Peter: assumption q1 and q2 not used and lemma is the 'identity' *)
+lemma LAMBDA_RSP:
+  assumes q1: "Quotient R1 Abs1 Rep1"
+  and     q2: "Quotient R2 Abs2 Rep2"
+  and     a: "(R1 ===> R2) f1 f2"
+  shows "(R1 ===> R2) (\<lambda>x. f1 x) (\<lambda>y. f2 y)"
+by (rule a)
+
+(* ASK Peter about next four lemmas in quotientScript
+lemma ABSTRACT_PRS:
+  assumes q1: "Quotient R1 Abs1 Rep1"
+  and     q2: "Quotient R2 Abs2 Rep2"
+  shows "f = (Rep1 ---> Abs2) ???"
+*)
+
+
+lemma fun_rel_EQUALS:
+  assumes q1: "Quotient R1 Abs1 Rep1"
+  and     q2: "Quotient R2 Abs2 Rep2"
+  and     r1: "Respects (R1 ===> R2) f"
+  and     r2: "Respects (R1 ===> R2) g" 
+  shows "((Rep1 ---> Abs2) f = (Rep1 ---> Abs2) g) = (\<forall>x y. R1 x y \<longrightarrow> R2 (f x) (g y))"
+apply(rule_tac iffI)
+using fun_quotient[OF q1 q2] r1 r2 unfolding Quotient_def Respects_def
+apply(metis apply_rsp')
+using r1 unfolding Respects_def expand_fun_eq
+apply(simp (no_asm_use))
+apply(metis Quotient_rel[OF q2] Quotient_rel_rep[OF q1])
+done
+
+(* ask Peter: fun_rel_IMP used twice *) 
+lemma fun_rel_IMP2:
+  assumes q1: "Quotient R1 Abs1 Rep1"
+  and     q2: "Quotient R2 Abs2 Rep2"
+  and     r1: "Respects (R1 ===> R2) f"
+  and     r2: "Respects (R1 ===> R2) g" 
+  and     a:  "(Rep1 ---> Abs2) f = (Rep1 ---> Abs2) g"
+  shows "R1 x y \<Longrightarrow> R2 (f x) (g y)"
+using q1 q2 r1 r2 a
+by (simp add: fun_rel_EQUALS)
+
+lemma LAMBDA_REP_ABS_RSP:
+  assumes r1: "\<And>r r'. R1 r r' \<Longrightarrow>R1 r (Rep1 (Abs1 r'))"
+  and     r2: "\<And>r r'. R2 r r' \<Longrightarrow>R2 r (Rep2 (Abs2 r'))"
+  shows "(R1 ===> R2) f1 f2 \<Longrightarrow> (R1 ===> R2) f1 ((Abs1 ---> Rep2) ((Rep1 ---> Abs2) f2))"
+using r1 r2 by auto
+
+(* Not used *)
+lemma rep_abs_rsp_left:
+  assumes q: "Quotient R Abs Rep"
+  and     a: "R x1 x2"
+  shows "R x1 (Rep (Abs x2))"
+using q a by (metis Quotient_rel[OF q] Quotient_abs_rep[OF q] Quotient_rep_reflp[OF q])
+
+
+
+(* bool theory: COND, LET *)
+lemma IF_PRS:
+  assumes q: "Quotient R Abs Rep"
+  shows "If a b c = Abs (If a (Rep b) (Rep c))"
+using Quotient_abs_rep[OF q] by auto
+
+(* ask peter: no use of q *)
+lemma IF_RSP:
+  assumes q: "Quotient R Abs Rep"
+  and     a: "a1 = a2" "R b1 b2" "R c1 c2"
+  shows "R (If a1 b1 c1) (If a2 b2 c2)"
+using a by auto
+
+lemma LET_PRS:
+  assumes q1: "Quotient R1 Abs1 Rep1"
+  and     q2: "Quotient R2 Abs2 Rep2"
+  shows "Let x f = Abs2 (Let (Rep1 x) ((Abs1 ---> Rep2) f))"
+using Quotient_abs_rep[OF q1] Quotient_abs_rep[OF q2] by auto
+
+lemma LET_RSP:
+  assumes q1: "Quotient R1 Abs1 Rep1"
+  and     a1: "(R1 ===> R2) f g"
+  and     a2: "R1 x y"
+  shows "R2 ((Let x f)::'c) ((Let y g)::'c)"
+using apply_rsp[OF q1 a1] a2
+by auto
+
+
+
+(* ask peter what are literal_case *)
+(* literal_case_PRS *)
+(* literal_case_RSP *)
+
+
+
+
+
+(* combinators: I, K, o, C, W *)
+
+(* We use id_simps which includes id_apply; so these 2 theorems can be removed *)
+
+lemma I_PRS:
+  assumes q: "Quotient R Abs Rep"
+  shows "id e = Abs (id (Rep e))"
+using Quotient_abs_rep[OF q] by auto
+
+lemma I_RSP:
+  assumes q: "Quotient R Abs Rep"
+  and     a: "R e1 e2"
+  shows "R (id e1) (id e2)"
+using a by auto
+
+lemma o_PRS:
+  assumes q1: "Quotient R1 Abs1 Rep1"
+  and     q2: "Quotient R2 Abs2 Rep2"
+  and     q3: "Quotient R3 Abs3 Rep3"
+  shows "f o g = (Rep1 ---> Abs3) (((Abs2 ---> Rep3) f) o ((Abs1 ---> Rep2) g))"
+using Quotient_abs_rep[OF q1] Quotient_abs_rep[OF q2] Quotient_abs_rep[OF q3]
+unfolding o_def expand_fun_eq
+by simp
+
+lemma o_RSP:
+  assumes q1: "Quotient R1 Abs1 Rep1"
+  and     q2: "Quotient R2 Abs2 Rep2"
+  and     q3: "Quotient R3 Abs3 Rep3"
+  and     a1: "(R2 ===> R3) f1 f2"
+  and     a2: "(R1 ===> R2) g1 g2"
+  shows "(R1 ===> R3) (f1 o g1) (f2 o g2)"
+using a1 a2 unfolding o_def expand_fun_eq
+by (auto)
+
+lemma COND_PRS:
+  assumes a: "Quotient R absf repf"
+  shows "(if a then b else c) = absf (if a then repf b else repf c)"
+  using a unfolding Quotient_def by auto
+
+
+end
+
diff -r 6088fea1c8b1 -r 8a1c8dc72b5c Quot/Quotients.thy
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Quot/Quotients.thy	Mon Dec 07 14:09:50 2009 +0100
@@ -0,0 +1,80 @@
+theory Quotients
+imports Main
+begin
+
+(* Other quotients that have not been proved yet *)
+
+fun
+  option_rel
+where
+  "option_rel R None None = True"
+| "option_rel R (Some x) None = False"
+| "option_rel R None (Some x) = False"
+| "option_rel R (Some x) (Some y) = R x y"
+
+fun
+  option_map
+where
+  "option_map f None = None"
+| "option_map f (Some x) = Some (f x)"
+
+fun
+  prod_rel
+where
+  "prod_rel R1 R2 (a1,a2) (b1,b2) = (R1 a1 b1 \<and> R2 a2 b2)"
+
+fun
+  prod_map
+where
+  "prod_map f1 f2 (a,b) = (f1 a, f2 b)"
+
+fun
+  sum_rel
+where
+  "sum_rel R1 R2 (Inl a1) (Inl b1) = R1 a1 b1"
+| "sum_rel R1 R2 (Inl a1) (Inr b2) = False"
+| "sum_rel R1 R2 (Inr a2) (Inl b1) = False"
+| "sum_rel R1 R2 (Inr a2) (Inr b2) = R2 a2 b2"
+
+fun
+  sum_map
+where
+  "sum_map f1 f2 (Inl a) = Inl (f1 a)"
+| "sum_map f1 f2 (Inr a) = Inr (f2 a)"
+
+
+
+
+
+fun
+  noption_map::"('a \<Rightarrow> 'b) \<Rightarrow> ('a noption) \<Rightarrow> ('b noption)"
+where
+  "noption_map f (nSome x) = nSome (f x)"
+| "noption_map f nNone = nNone"
+
+fun
+  noption_rel
+where
+  "noption_rel r (nSome x) (nSome y) = r x y"
+| "noption_rel r _ _ = False"
+
+declare [[map noption = (noption_map, noption_rel)]]
+
+lemma "noption_map id = id"
+sorry
+
+lemma noption_Quotient:
+  assumes q: "Quotient R Abs Rep"
+  shows "Quotient (noption_rel R) (noption_map Abs) (noption_map Rep)"
+  apply (unfold Quotient_def)
+  apply (auto)
+  using q
+  apply (unfold Quotient_def)
+  apply (case_tac "a :: 'b noption")
+  apply (simp)
+  apply (simp)
+  apply (case_tac "a :: 'b noption")
+  apply (simp only: option_map.simps)
+  apply (subst option_rel.simps)
+  (* Simp starts hanging so don't know how to continue *)
+  sorry
diff -r 6088fea1c8b1 -r 8a1c8dc72b5c Quot/ROOT.ML
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Quot/ROOT.ML	Mon Dec 07 14:09:50 2009 +0100
@@ -0,0 +1,4 @@
+(*
+  no_document use_thys ["This_Theory1", "This_Theory2"];
+  use_thys ["That_Theory1", "That_Theory2", "That_Theory3"];
+*)
diff -r 6088fea1c8b1 -r 8a1c8dc72b5c QuotList.thy
--- a/QuotList.thy	Mon Dec 07 14:00:36 2009 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,174 +0,0 @@
-theory QuotList
-imports QuotScript List
-begin
-
-fun
-  list_rel
-where
-  "list_rel R [] [] = True"
-| "list_rel R (x#xs) [] = False"
-| "list_rel R [] (x#xs) = False"
-| "list_rel R (x#xs) (y#ys) = (R x y \<and> list_rel R xs ys)"
-
-lemma list_equivp:
-  assumes a: "equivp R"
-  shows "equivp (list_rel R)"
-  unfolding equivp_def
-  apply(rule allI)+
-  apply(induct_tac x y rule: list_induct2')
-  apply(simp_all add: expand_fun_eq)
-  apply(metis list_rel.simps(1) list_rel.simps(2))
-  apply(metis list_rel.simps(1) list_rel.simps(2))
-  apply(rule iffI)
-  apply(rule allI)
-  apply(case_tac x)
-  apply(simp_all)
-  using a
-  apply(unfold equivp_def)
-  apply(auto)[1]
-  apply(metis list_rel.simps(4))
-  done
-
-lemma list_rel_rel:
-  assumes q: "Quotient R Abs Rep"
-  shows "list_rel R r s = (list_rel R r r \<and> list_rel R s s \<and> (map Abs r = map Abs s))"
-  apply(induct r s rule: list_induct2')
-  apply(simp_all)
-  using Quotient_rel[OF q]
-  apply(metis)
-  done
-
-lemma list_quotient:
-  assumes q: "Quotient R Abs Rep"
-  shows "Quotient (list_rel R) (map Abs) (map Rep)"
-  unfolding Quotient_def
-  apply(rule conjI)
-  apply(rule allI)
-  apply(induct_tac a)
-  apply(simp)
-  apply(simp add: Quotient_abs_rep[OF q])
-  apply(rule conjI)
-  apply(rule allI)
-  apply(induct_tac a)
-  apply(simp)
-  apply(simp)
-  apply(simp add: Quotient_rep_reflp[OF q])
-  apply(rule allI)+
-  apply(rule list_rel_rel[OF q])
-  done
-
-
-lemma cons_prs:
-  assumes q: "Quotient R Abs Rep"
-  shows "(map Abs) ((Rep h) # (map Rep t)) = h # t"
-by (induct t) (simp_all add: Quotient_abs_rep[OF q])
-
-lemma cons_rsp:
-  assumes q: "Quotient R Abs Rep"
-  shows "(R ===> list_rel R ===> list_rel R) op # op #"
-by (auto)
-
-lemma nil_prs:
-  assumes q: "Quotient R Abs Rep"
-  shows "map Abs [] \<equiv> []"
-by (simp)
-
-lemma nil_rsp:
-  assumes q: "Quotient R Abs Rep"
-  shows "list_rel R [] []"
-by simp
-
-lemma map_prs:
-  assumes a: "Quotient R1 abs1 rep1"
-  and     b: "Quotient R2 abs2 rep2"
-  shows "(map abs2) (map ((abs1 ---> rep2) f) (map rep1 l)) = map f l"
-by (induct l) (simp_all add: Quotient_abs_rep[OF a] Quotient_abs_rep[OF b])
-
-lemma map_rsp:
-  assumes q1: "Quotient R1 Abs1 Rep1"
-  and     q2: "Quotient R2 Abs2 Rep2"
-  shows "((R1 ===> R2) ===> (list_rel R1) ===> list_rel R2) map map"
-apply(simp)
-apply(rule allI)+
-apply(rule impI)
-apply(rule allI)+
-apply (induct_tac xa ya rule: list_induct2')
-apply simp_all
-done
-
-(* TODO: if the above is correct, we can remove this one *)
-lemma map_rsp_lo:
-  assumes q1: "Quotient R1 Abs1 Rep1"
-  and     q2: "Quotient R2 Abs2 Rep2"
-  and     a: "(R1 ===> R2) f1 f2"
-  and     b: "list_rel R1 l1 l2"
-  shows "list_rel R2 (map f1 l1) (map f2 l2)"
-using b a
-by (induct l1 l2 rule: list_induct2') (simp_all)
-
-lemma foldr_prs:
-  assumes a: "Quotient R1 abs1 rep1"
-  and     b: "Quotient R2 abs2 rep2"
-  shows "abs2 (foldr ((abs1 ---> abs2 ---> rep2) f) (map rep1 l) (rep2 e)) = foldr f l e"
-by (induct l) (simp_all add: Quotient_abs_rep[OF a] Quotient_abs_rep[OF b])
-
-lemma foldl_prs:
-  assumes a: "Quotient R1 abs1 rep1"
-  and     b: "Quotient R2 abs2 rep2"
-  shows "abs1 (foldl ((abs1 ---> abs2 ---> rep1) f) (rep1 e) (map rep2 l)) = foldl f e l"
-by (induct l arbitrary:e) (simp_all add: Quotient_abs_rep[OF a] Quotient_abs_rep[OF b])
-
-lemma list_rel_empty: "list_rel R [] b \<Longrightarrow> length b = 0"
-by (induct b) (simp_all)
-
-lemma list_rel_len: "list_rel R a b \<Longrightarrow> length a = length b"
-apply (induct a arbitrary: b)
-apply (simp add: list_rel_empty)
-apply (case_tac b)
-apply simp_all
-done
-
-(* TODO: induct_tac doesn't accept 'arbitrary'.
-         induct     doesn't accept 'rule'.
-   that's why the proof uses manual generalisation and needs assumptions
-   both in conclusion for induction and in assumptions. *)
-lemma foldl_rsp:
-  assumes q1: "Quotient R1 Abs1 Rep1"
-  and     q2: "Quotient R2 Abs2 Rep2"
-  shows "((R1 ===> R2 ===> R1) ===> R1 ===> list_rel R2 ===> R1) foldl foldl"
-apply auto
-apply (subgoal_tac "R1 xa ya \<longrightarrow> list_rel R2 xb yb \<longrightarrow> R1 (foldl x xa xb) (foldl y ya yb)")
-apply simp
-apply (rule_tac x="xa" in spec)
-apply (rule_tac x="ya" in spec)
-apply (rule_tac xs="xb" and ys="yb" in list_induct2)
-apply (rule list_rel_len)
-apply (simp_all)
-done
-
-(* TODO: foldr_rsp should be similar *)
-
-
-
-
-(* TODO: Rest are unused *)
-
-lemma list_map_id:
-  shows "map (\<lambda>x. x) = (\<lambda>x. x)"
-  by simp
-
-lemma list_rel_eq:
-  shows "list_rel (op =) \<equiv> (op =)"
-apply(rule eq_reflection)
-unfolding expand_fun_eq
-apply(rule allI)+
-apply(induct_tac x xa rule: list_induct2')
-apply(simp_all)
-done
-
-lemma list_rel_refl:
-  assumes a: "\<And>x y. R x y = (R x = R y)"
-  shows "list_rel R x x"
-by (induct x) (auto simp add: a)
-
-end
diff -r 6088fea1c8b1 -r 8a1c8dc72b5c QuotMain.thy
--- a/QuotMain.thy	Mon Dec 07 14:00:36 2009 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,1191 +0,0 @@
-theory QuotMain
-imports QuotScript QuotList QuotProd Prove
-uses ("quotient_info.ML")
-     ("quotient.ML")
-     ("quotient_def.ML")
-begin
-
-
-locale QUOT_TYPE =
-  fixes R :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
-  and   Abs :: "('a \<Rightarrow> bool) \<Rightarrow> 'b"
-  and   Rep :: "'b \<Rightarrow> ('a \<Rightarrow> bool)"
-  assumes equivp: "equivp R"
-  and     rep_prop: "\<And>y. \<exists>x. Rep y = R x"
-  and     rep_inverse: "\<And>x. Abs (Rep x) = x"
-  and     abs_inverse: "\<And>x. (Rep (Abs (R x))) = (R x)"
-  and     rep_inject: "\<And>x y. (Rep x = Rep y) = (x = y)"
-begin
-
-definition
-  ABS::"'a \<Rightarrow> 'b"
-where
-  "ABS x \<equiv> Abs (R x)"
-
-definition
-  REP::"'b \<Rightarrow> 'a"
-where
-  "REP a = Eps (Rep a)"
-
-lemma lem9:
-  shows "R (Eps (R x)) = R x"
-proof -
-  have a: "R x x" using equivp by (simp add: equivp_reflp_symp_transp reflp_def)
-  then have "R x (Eps (R x))" by (rule someI)
-  then show "R (Eps (R x)) = R x"
-    using equivp unfolding equivp_def by simp
-qed
-
-theorem thm10:
-  shows "ABS (REP a) \<equiv> a"
-  apply  (rule eq_reflection)
-  unfolding ABS_def REP_def
-proof -
-  from rep_prop
-  obtain x where eq: "Rep a = R x" by auto
-  have "Abs (R (Eps (Rep a))) = Abs (R (Eps (R x)))" using eq by simp
-  also have "\<dots> = Abs (R x)" using lem9 by simp
-  also have "\<dots> = Abs (Rep a)" using eq by simp
-  also have "\<dots> = a" using rep_inverse by simp
-  finally
-  show "Abs (R (Eps (Rep a))) = a" by simp
-qed
-
-lemma REP_refl:
-  shows "R (REP a) (REP a)"
-unfolding REP_def
-by (simp add: equivp[simplified equivp_def])
-
-lemma lem7:
-  shows "(R x = R y) = (Abs (R x) = Abs (R y))"
-apply(rule iffI)
-apply(simp)
-apply(drule rep_inject[THEN iffD2])
-apply(simp add: abs_inverse)
-done
-
-theorem thm11:
-  shows "R r r' = (ABS r = ABS r')"
-unfolding ABS_def
-by (simp only: equivp[simplified equivp_def] lem7)
-
-
-lemma REP_ABS_rsp:
-  shows "R f (REP (ABS g)) = R f g"
-  and   "R (REP (ABS g)) f = R g f"
-by (simp_all add: thm10 thm11)
-
-lemma Quotient:
-  "Quotient R ABS REP"
-apply(unfold Quotient_def)
-apply(simp add: thm10)
-apply(simp add: REP_refl)
-apply(subst thm11[symmetric])
-apply(simp add: equivp[simplified equivp_def])
-done
-
-lemma R_trans:
-  assumes ab: "R a b"
-  and     bc: "R b c"
-  shows "R a c"
-proof -
-  have tr: "transp R" using equivp equivp_reflp_symp_transp[of R] by simp
-  moreover have ab: "R a b" by fact
-  moreover have bc: "R b c" by fact
-  ultimately show "R a c" unfolding transp_def by blast
-qed
-
-lemma R_sym:
-  assumes ab: "R a b"
-  shows "R b a"
-proof -
-  have re: "symp R" using equivp equivp_reflp_symp_transp[of R] by simp
-  then show "R b a" using ab unfolding symp_def by blast
-qed
-
-lemma R_trans2:
-  assumes ac: "R a c"
-  and     bd: "R b d"
-  shows "R a b = R c d"
-using ac bd
-by (blast intro: R_trans R_sym)
-
-lemma REPS_same:
-  shows "R (REP a) (REP b) \<equiv> (a = b)"
-proof -
-  have "R (REP a) (REP b) = (a = b)"
-  proof
-    assume as: "R (REP a) (REP b)"
-    from rep_prop
-    obtain x y
-      where eqs: "Rep a = R x" "Rep b = R y" by blast
-    from eqs have "R (Eps (R x)) (Eps (R y))" using as unfolding REP_def by simp
-    then have "R x (Eps (R y))" using lem9 by simp
-    then have "R (Eps (R y)) x" using R_sym by blast
-    then have "R y x" using lem9 by simp
-    then have "R x y" using R_sym by blast
-    then have "ABS x = ABS y" using thm11 by simp
-    then have "Abs (Rep a) = Abs (Rep b)" using eqs unfolding ABS_def by simp
-    then show "a = b" using rep_inverse by simp
-  next
-    assume ab: "a = b"
-    have "reflp R" using equivp equivp_reflp_symp_transp[of R] by simp
-    then show "R (REP a) (REP b)" unfolding reflp_def using ab by auto
-  qed
-  then show "R (REP a) (REP b) \<equiv> (a = b)" by simp
-qed
-
-end
-
-section {* type definition for the quotient type *}
-
-(* the auxiliary data for the quotient types *)
-use "quotient_info.ML"
-
-declare [[map list = (map, list_rel)]]
-declare [[map * = (prod_fun, prod_rel)]]
-declare [[map "fun" = (fun_map, fun_rel)]]
-
-(* identity quotient is not here as it has to be applied first *)
-lemmas [quotient_thm] =
-  fun_quotient list_quotient prod_quotient
-
-lemmas [quotient_rsp] =
-  quot_rel_rsp nil_rsp cons_rsp foldl_rsp pair_rsp
-
-(* fun_map is not here since equivp is not true *)
-(* TODO: option, ... *)
-lemmas [quotient_equiv] =
-  identity_equivp list_equivp prod_equivp
-
-
-ML {* maps_lookup @{theory} "List.list" *}
-ML {* maps_lookup @{theory} "*" *}
-ML {* maps_lookup @{theory} "fun" *}
-
-
-(* definition of the quotient types *)
-(* FIXME: should be called quotient_typ.ML *)
-use "quotient.ML"
-
-
-(* lifting of constants *)
-use "quotient_def.ML"
-
-section {* Simset setup *}
-
-(* since HOL_basic_ss is too "big", we need to set up *)
-(* our own minimal simpset                            *)
-ML {*
-fun  mk_minimal_ss ctxt =
-  Simplifier.context ctxt empty_ss
-    setsubgoaler asm_simp_tac
-    setmksimps (mksimps [])
-*}
-
-section {* atomize *}
-
-lemma atomize_eqv[atomize]:
-  shows "(Trueprop A \<equiv> Trueprop B) \<equiv> (A \<equiv> B)"
-proof
-  assume "A \<equiv> B"
-  then show "Trueprop A \<equiv> Trueprop B" by unfold
-next
-  assume *: "Trueprop A \<equiv> Trueprop B"
-  have "A = B"
-  proof (cases A)
-    case True
-    have "A" by fact
-    then show "A = B" using * by simp
-  next
-    case False
-    have "\<not>A" by fact
-    then show "A = B" using * by auto
-  qed
-  then show "A \<equiv> B" by (rule eq_reflection)
-qed
-
-ML {*
-fun atomize_thm thm =
-let
-  val thm' = Thm.freezeT (forall_intr_vars thm)
-  val thm'' = ObjectLogic.atomize (cprop_of thm')
-in
-  @{thm equal_elim_rule1} OF [thm'', thm']
-end
-*}
-
-section {* infrastructure about id *}
-
-lemma prod_fun_id: "prod_fun id id \<equiv> id"
-  by (rule eq_reflection) (simp add: prod_fun_def)
-
-lemma map_id: "map id \<equiv> id"
-  apply (rule eq_reflection)
-  apply (rule ext)
-  apply (rule_tac list="x" in list.induct)
-  apply (simp_all)
-  done
-
-lemmas id_simps =
-  fun_map_id[THEN eq_reflection]
-  id_apply[THEN eq_reflection]
-  id_def[THEN eq_reflection,symmetric]
-  prod_fun_id map_id
-
-ML {*
-fun simp_ids thm =
-  MetaSimplifier.rewrite_rule @{thms id_simps} thm
-*}
-
-section {* Debugging infrastructure for testing tactics *}
-
-ML {*
-fun my_print_tac ctxt s i thm =
-let
-  val prem_str = nth (prems_of thm) (i - 1)
-                 |> Syntax.string_of_term ctxt
-                 handle Subscript => "no subgoal"
-  val _ = tracing (s ^ "\n" ^ prem_str)
-in
-  Seq.single thm
-end *}
-
-ML {*
-fun DT ctxt s tac i thm =
-let
-  val before_goal = nth (prems_of thm) (i - 1)
-                    |> Syntax.string_of_term ctxt
-  val before_msg = ["before: " ^ s, before_goal, "after: " ^ s]
-                   |> cat_lines
-in 
-  EVERY [tac i, my_print_tac ctxt before_msg i] thm
-end
-
-fun NDT ctxt s tac thm = tac thm  
-*}
-
-section {* Matching of terms and types *}
-
-ML {*
-fun matches_typ (ty, ty') =
-  case (ty, ty') of
-    (_, TVar _) => true
-  | (TFree x, TFree x') => x = x'
-  | (Type (s, tys), Type (s', tys')) => 
-       s = s' andalso 
-       if (length tys = length tys') 
-       then (List.all matches_typ (tys ~~ tys')) 
-       else false
-  | _ => false
-*}
-
-ML {*
-fun matches_term (trm, trm') = 
-   case (trm, trm') of 
-     (_, Var _) => true
-   | (Const (s, ty), Const (s', ty')) => s = s' andalso matches_typ (ty, ty')
-   | (Free (x, ty), Free (x', ty')) => x = x' andalso matches_typ (ty, ty')
-   | (Bound i, Bound j) => i = j
-   | (Abs (_, T, t), Abs (_, T', t')) => matches_typ (T, T') andalso matches_term (t, t')
-   | (t $ s, t' $ s') => matches_term (t, t') andalso matches_term (s, s') 
-   | _ => false
-*}
-
-section {* Infrastructure for collecting theorems for starting the lifting *}
-
-ML {*
-fun lookup_quot_data lthy qty =
-  let
-    val qty_name = fst (dest_Type qty)
-    val SOME quotdata = quotdata_lookup lthy qty_name
-    (* TODO: Should no longer be needed *)
-    val rty = Logic.unvarifyT (#rtyp quotdata)
-    val rel = #rel quotdata
-    val rel_eqv = #equiv_thm quotdata
-    val rel_refl = @{thm equivp_reflp} OF [rel_eqv]
-  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 absrep = PureThy.get_thm thy ("QUOT_TYPE_I_" ^ qty_name ^ ".thm10")
-    val quot = PureThy.get_thm thy ("Quotient_" ^ qty_name)
-  in
-    (trans2, reps_same, absrep, quot)
-  end
-*}
-
-section {* Regularization *} 
-
-(*
-Regularizing an rtrm means:
- - quantifiers over a type that needs lifting are replaced by
-   bounded quantifiers, for example:
-      \<forall>x. P     \<Longrightarrow>     \<forall>x \<in> (Respects R). P  /  All (Respects R) P
-
-   the relation R is given by the rty and qty;
- 
- - abstractions over a type that needs lifting are replaced
-   by bounded abstractions:
-      \<lambda>x. P     \<Longrightarrow>     Ball (Respects R) (\<lambda>x. P)
-
- - equalities over the type being lifted are replaced by
-   corresponding relations:
-      A = B     \<Longrightarrow>     A \<approx> B
-
-   example with more complicated types of A, B:
-      A = B     \<Longrightarrow>     (op = \<Longrightarrow> op \<approx>) A B
-*)
-
-ML {*
-(* builds the relation that is the argument of respects *)
-fun mk_resp_arg lthy (rty, qty) =
-let
-  val thy = ProofContext.theory_of lthy
-in  
-  if rty = qty
-  then HOLogic.eq_const rty
-  else
-    case (rty, qty) of
-      (Type (s, tys), Type (s', tys')) =>
-       if s = s' 
-       then let
-              val SOME map_info = maps_lookup thy s
-              val args = map (mk_resp_arg lthy) (tys ~~ tys')
-            in
-              list_comb (Const (#relfun map_info, dummyT), args) 
-            end  
-       else let  
-              val SOME qinfo = quotdata_lookup_thy thy s'
-              (* FIXME: check in this case that the rty and qty *)
-              (* FIXME: correspond to each other *)
-              val (s, _) = dest_Const (#rel qinfo)
-              (* FIXME: the relation should only be the string        *)
-              (* FIXME: and the type needs to be calculated as below; *)
-              (* FIXME: maybe one should actually have a term         *)
-              (* FIXME: and one needs to force it to have this type   *)
-            in
-              Const (s, rty --> rty --> @{typ bool})
-            end
-      | _ => HOLogic.eq_const dummyT 
-             (* FIXME: check that the types correspond to each other? *)
-end
-*}
-
-ML {*
-val mk_babs = Const (@{const_name Babs}, dummyT)
-val mk_ball = Const (@{const_name Ball}, dummyT)
-val mk_bex  = Const (@{const_name Bex}, dummyT)
-val mk_resp = Const (@{const_name Respects}, dummyT)
-*}
-
-ML {*
-(* - applies f to the subterm of an abstraction,   *)
-(*   otherwise to the given term,                  *)
-(* - used by regularize, therefore abstracted      *)
-(*   variables do not have to be treated specially *)
-
-fun apply_subt f trm1 trm2 =
-  case (trm1, trm2) of
-    (Abs (x, T, t), Abs (x', T', t')) => Abs (x, T, f t t')
-  | _ => f trm1 trm2
-
-(* the major type of All and Ex quantifiers *)
-fun qnt_typ ty = domain_type (domain_type ty)  
-*}
-
-ML {*
-(* produces a regularized version of rtm      *)
-(* - the result is still not completely typed *)
-(* - does not need any special treatment of   *)
-(*   bound variables                          *)
-
-fun regularize_trm lthy rtrm qtrm =
-  case (rtrm, qtrm) of
-    (Abs (x, ty, t), Abs (x', ty', t')) =>
-       let
-         val subtrm = Abs(x, ty, regularize_trm lthy t t')
-       in
-         if ty = ty'
-         then subtrm
-         else mk_babs $ (mk_resp $ mk_resp_arg lthy (ty, ty')) $ subtrm
-       end
-
-  | (Const (@{const_name "All"}, ty) $ t, Const (@{const_name "All"}, ty') $ t') =>
-       let
-         val subtrm = apply_subt (regularize_trm lthy) t t'
-       in
-         if ty = ty'
-         then Const (@{const_name "All"}, ty) $ subtrm
-         else mk_ball $ (mk_resp $ mk_resp_arg lthy (qnt_typ ty, qnt_typ ty')) $ subtrm
-       end
-
-  | (Const (@{const_name "Ex"}, ty) $ t, Const (@{const_name "Ex"}, ty') $ t') =>
-       let
-         val subtrm = apply_subt (regularize_trm lthy) t t'
-       in
-         if ty = ty'
-         then Const (@{const_name "Ex"}, ty) $ subtrm
-         else mk_bex $ (mk_resp $ mk_resp_arg lthy (qnt_typ ty, qnt_typ ty')) $ subtrm
-       end
-
-  | (* equalities need to be replaced by appropriate equivalence relations *) 
-    (Const (@{const_name "op ="}, ty), Const (@{const_name "op ="}, ty')) =>
-         if ty = ty'
-         then rtrm
-         else mk_resp_arg lthy (domain_type ty, domain_type ty') 
-
-  | (* in this case we check whether the given equivalence relation is correct *) 
-    (rel, Const (@{const_name "op ="}, ty')) =>
-       let 
-         val exc = LIFT_MATCH "regularise (relation mismatch)"
-         val rel_ty = (fastype_of rel) handle TERM _ => raise exc 
-         val rel' = mk_resp_arg lthy (domain_type rel_ty, domain_type ty') 
-       in 
-         if rel' = rel
-         then rtrm
-         else raise exc
-       end  
-  | (_, Const (s, _)) =>
-       let 
-         fun same_name (Const (s, _)) (Const (s', _)) = (s = s')
-           | same_name _ _ = false
-       in
-         if same_name rtrm qtrm 
-         then rtrm 
-         else 
-           let 
-             fun exc1 s = LIFT_MATCH ("regularize (constant " ^ s ^ " not found)")
-             val exc2   = LIFT_MATCH ("regularize (constant mismatch)")
-             val thy = ProofContext.theory_of lthy
-             val rtrm' = (#rconst (qconsts_lookup thy s)) handle NotFound => raise (exc1 s) 
-           in 
-             if matches_term (rtrm, rtrm')
-             then rtrm
-             else raise exc2
-           end
-       end 
-
-  | (t1 $ t2, t1' $ t2') =>
-       (regularize_trm lthy t1 t1') $ (regularize_trm lthy t2 t2')
-
-  | (Free (x, ty), Free (x', ty')) => 
-       (* this case cannot arrise as we start with two fully atomized terms *)
-       raise (LIFT_MATCH "regularize (frees)")
-
-  | (Bound i, Bound i') =>
-       if i = i' 
-       then rtrm 
-       else raise (LIFT_MATCH "regularize (bounds mismatch)")
-
-  | (rt, qt) =>
-       raise (LIFT_MATCH "regularize (default)")
-*}
-
-ML {*
-fun equiv_tac ctxt =
-  REPEAT_ALL_NEW (FIRST' 
-    [resolve_tac (equiv_rules_get ctxt)])
-*}
-
-ML {*
-fun equiv_solver_tac ss = equiv_tac (Simplifier.the_context ss)
-val equiv_solver = Simplifier.mk_solver' "Equivalence goal solver" equiv_solver_tac
-*}
-
-ML {*
-fun prep_trm thy (x, (T, t)) =
-  (cterm_of thy (Var (x, T)), cterm_of thy t)
-
-fun prep_ty thy (x, (S, ty)) =
-  (ctyp_of thy (TVar (x, S)), ctyp_of thy ty)
-*}
-
-ML {*
-fun matching_prs thy pat trm =
-let
-  val univ = Unify.matchers thy [(pat, trm)]
-  val SOME (env, _) = Seq.pull univ
-  val tenv = Vartab.dest (Envir.term_env env)
-  val tyenv = Vartab.dest (Envir.type_env env)
-in
-  (map (prep_ty thy) tyenv, map (prep_trm thy) tenv)
-end
-*}
-
-ML {*
-fun calculate_instance ctxt thm redex R1 R2 =
-let
-  val thy = ProofContext.theory_of ctxt
-  val goal = Const (@{const_name "equivp"}, dummyT) $ R2  
-             |> Syntax.check_term ctxt
-             |> HOLogic.mk_Trueprop 
-  val eqv_prem = Goal.prove ctxt [] [] goal (fn {context,...} => equiv_tac context 1)
-  val thm = (@{thm eq_reflection} OF [thm OF [eqv_prem]])
-  val R1c = cterm_of thy R1
-  val thmi = Drule.instantiate' [] [SOME R1c] thm
-  val inst = matching_prs thy (term_of (Thm.lhs_of thmi)) redex
-  val thm2 = Drule.eta_contraction_rule (Drule.instantiate inst thmi)
-in
-  SOME thm2
-end
-handle _ => NONE
-(* FIXME/TODO: what is the place where the exception can be raised: matching_prs? *)
-*}
-
-ML {*
-fun ball_bex_range_simproc ss redex =
-let
-  val ctxt = Simplifier.the_context ss
-in 
- case redex of
-    (Const (@{const_name "Ball"}, _) $ (Const (@{const_name "Respects"}, _) $ 
-      (Const (@{const_name "fun_rel"}, _) $ R1 $ R2)) $ _) =>
-        calculate_instance ctxt @{thm ball_reg_eqv_range} redex R1 R2
-  | (Const (@{const_name "Bex"}, _) $ (Const (@{const_name "Respects"}, _) $ 
-      (Const (@{const_name "fun_rel"}, _) $ R1 $ R2)) $ _) =>  
-        calculate_instance ctxt @{thm bex_reg_eqv_range} redex R1 R2
-  | _ => NONE
-end
-*}
-
-lemma eq_imp_rel: 
-  shows "equivp R \<Longrightarrow> a = b \<longrightarrow> R a b"
-by (simp add: equivp_reflp)
-
-(* FIXME/TODO: How does regularizing work? *)
-(* FIXME/TODO: needs to be adapted
-
-To prove that the raw theorem implies the regularised one, 
-we try in order:
-
- - Reflexivity of the relation
- - Assumption
- - Elimnating quantifiers on both sides of toplevel implication
- - Simplifying implications on both sides of toplevel implication
- - Ball (Respects ?E) ?P = All ?P
- - (\<And>x. ?R x \<Longrightarrow> ?P x \<longrightarrow> ?Q x) \<Longrightarrow> All ?P \<longrightarrow> Ball ?R ?Q
-
-*)
-ML {*
-fun regularize_tac ctxt =
-let
-  val thy = ProofContext.theory_of ctxt
-  val pat_ball = @{term "Ball (Respects (R1 ===> R2)) P"}
-  val pat_bex  = @{term "Bex (Respects (R1 ===> R2)) P"}
-  val simproc = Simplifier.simproc_i thy "" [pat_ball, pat_bex] (K (ball_bex_range_simproc))
-  val simpset = (mk_minimal_ss ctxt) 
-                       addsimps @{thms ball_reg_eqv bex_reg_eqv}
-                       addsimprocs [simproc] addSolver equiv_solver
-  (* TODO: Make sure that there are no list_rel, pair_rel etc involved *)
-  val eq_eqvs = map (fn x => @{thm eq_imp_rel} OF [x]) (equiv_rules_get ctxt)
-in
-  ObjectLogic.full_atomize_tac THEN'
-  simp_tac simpset THEN'
-  REPEAT_ALL_NEW (FIRST' [
-    rtac @{thm ball_reg_right},
-    rtac @{thm bex_reg_left},
-    resolve_tac (Inductive.get_monos ctxt),
-    rtac @{thm ball_all_comm},
-    rtac @{thm bex_ex_comm},
-    resolve_tac eq_eqvs,
-    simp_tac simpset])
-end
-*}
-
-section {* Injections of rep and abses *}
-
-(*
-Injecting repabs means:
-
-  For abstractions:
-  * If the type of the abstraction doesn't need lifting we recurse.
-  * If it does we add RepAbs around the whole term and check if the
-    variable needs lifting.
-    * If it doesn't then we recurse
-    * If it does we recurse and put 'RepAbs' around all occurences
-      of the variable in the obtained subterm. This in combination
-      with the RepAbs above will let us change the type of the
-      abstraction with rewriting.
-  For applications:
-  * If the term is 'Respects' applied to anything we leave it unchanged
-  * If the term needs lifting and the head is a constant that we know
-    how to lift, we put a RepAbs and recurse
-  * If the term needs lifting and the head is a free applied to subterms
-    (if it is not applied we treated it in Abs branch) then we
-    put RepAbs and recurse
-  * Otherwise just recurse.
-*)
-
-ML {*
-fun mk_repabs lthy (T, T') trm = 
-  Quotient_Def.get_fun repF lthy (T, T') 
-    $ (Quotient_Def.get_fun absF lthy (T, T') $ trm)
-*}
-
-ML {*
-(* bound variables need to be treated properly,    *)
-(* as the type of subterms need to be calculated   *)
-(* in the abstraction case                         *)
-
-fun inj_repabs_trm lthy (rtrm, qtrm) =
- case (rtrm, qtrm) of
-    (Const (@{const_name "Ball"}, T) $ r $ t, Const (@{const_name "All"}, _) $ t') =>
-       Const (@{const_name "Ball"}, T) $ r $ (inj_repabs_trm lthy (t, t'))
-
-  | (Const (@{const_name "Bex"}, T) $ r $ t, Const (@{const_name "Ex"}, _) $ t') =>
-       Const (@{const_name "Bex"}, T) $ r $ (inj_repabs_trm lthy (t, t'))
-
-  | (Const (@{const_name "Babs"}, T) $ r $ t, t' as (Abs _)) =>
-       Const (@{const_name "Babs"}, T) $ r $ (inj_repabs_trm lthy (t, t'))
-
-  | (Abs (x, T, t), Abs (x', T', t')) =>
-      let
-        val rty = fastype_of rtrm
-        val qty = fastype_of qtrm
-        val (y, s) = Term.dest_abs (x, T, t)
-        val (_, s') = Term.dest_abs (x', T', t')
-        val yvar = Free (y, T)
-        val result = Term.lambda_name (y, yvar) (inj_repabs_trm lthy (s, s'))
-      in
-        if rty = qty 
-        then result
-        else mk_repabs lthy (rty, qty) result
-      end
-
-  | (t $ s, t' $ s') =>  
-       (inj_repabs_trm lthy (t, t')) $ (inj_repabs_trm lthy (s, s'))
-
-  | (Free (_, T), Free (_, T')) => 
-        if T = T' 
-        then rtrm 
-        else mk_repabs lthy (T, T') rtrm
-
-  | (_, Const (@{const_name "op ="}, _)) => rtrm
-
-    (* FIXME: check here that rtrm is the corresponding definition for the const *)
-  | (_, Const (_, T')) =>
-      let
-        val rty = fastype_of rtrm
-      in 
-        if rty = T'                    
-        then rtrm
-        else mk_repabs lthy (rty, T') rtrm
-      end   
-  
-  | _ => raise (LIFT_MATCH "injection")
-*}
-
-section {* RepAbs Injection Tactic *}
-
-ML {*
-fun quotient_tac ctxt =
-  REPEAT_ALL_NEW (FIRST'
-    [rtac @{thm identity_quotient},
-     resolve_tac (quotient_rules_get ctxt)])
-*}
-
-(* solver for the simplifier *)
-ML {*
-fun quotient_solver_tac ss = quotient_tac (Simplifier.the_context ss)
-val quotient_solver = Simplifier.mk_solver' "Quotient goal solver" quotient_solver_tac
-*}
-
-ML {*
-fun solve_quotient_assums ctxt thm =
-  let val gl = hd (Drule.strip_imp_prems (cprop_of thm)) in
-  thm OF [Goal.prove_internal [] gl (fn _ => quotient_tac ctxt 1)]
-  end
-  handle _ => error "solve_quotient_assums failed. Maybe a quotient_thm is missing"
-*}
-
-(* Not used *)
-(* It proves the Quotient assumptions by calling quotient_tac *)
-ML {*
-fun solve_quotient_assum i ctxt thm =
-  let
-    val tac =
-      (compose_tac (false, thm, i)) THEN_ALL_NEW
-      (quotient_tac ctxt);
-    val gc = Drule.strip_imp_concl (cprop_of thm);
-  in
-    Goal.prove_internal [] gc (fn _ => tac 1)
-  end
-  handle _ => error "solve_quotient_assum"
-*}
-
-definition
-  "QUOT_TRUE x \<equiv> True"
-
-ML {*
-fun find_qt_asm asms =
-  let
-    fun find_fun trm =
-      case trm of
-        (Const(@{const_name Trueprop}, _) $ (Const (@{const_name QUOT_TRUE}, _) $ _)) => true
-      | _ => false
-  in
-    case find_first find_fun asms of
-      SOME (_ $ (_ $ (f $ a))) => (f, a)
-    | SOME _ => error "find_qt_asm: no pair"
-    | NONE => error "find_qt_asm: no assumption"
-  end
-*}
-
-(*
-To prove that the regularised theorem implies the abs/rep injected, 
-we try:
-
- 1) theorems 'trans2' from the appropriate QUOT_TYPE
- 2) remove lambdas from both sides: lambda_rsp_tac
- 3) remove Ball/Bex from the right hand side
- 4) use user-supplied RSP theorems
- 5) remove rep_abs from the right side
- 6) reflexivity of equality
- 7) split applications of lifted type (apply_rsp)
- 8) split applications of non-lifted type (cong_tac)
- 9) apply extentionality
- A) reflexivity of the relation
- B) assumption
-    (Lambdas under respects may have left us some assumptions)
- C) proving obvious higher order equalities by simplifying fun_rel
-    (not sure if it is still needed?)
- D) unfolding lambda on one side
- E) simplifying (= ===> =) for simpler respectfulness
-
-*)
-
-lemma quot_true_dests:
-  shows QT_all: "QUOT_TRUE (All P) \<Longrightarrow> QUOT_TRUE P"
-  and   QT_ex:  "QUOT_TRUE (Ex P) \<Longrightarrow> QUOT_TRUE P"
-  and   QT_lam: "QUOT_TRUE (\<lambda>x. P x) \<Longrightarrow> (\<And>x. QUOT_TRUE  (P x))"
-  and   QT_ext: "(\<And>x. QUOT_TRUE (a x) \<Longrightarrow> f x = g x) \<Longrightarrow> (QUOT_TRUE a \<Longrightarrow> f = g)"
-apply(simp_all add: QUOT_TRUE_def ext)
-done
-
-lemma QUOT_TRUE_i: "(QUOT_TRUE (a :: bool) \<Longrightarrow> P) \<Longrightarrow> P"
-by (simp add: QUOT_TRUE_def)
-
-lemma QUOT_TRUE_imp: "QUOT_TRUE a \<equiv> QUOT_TRUE b"
-by (simp add: QUOT_TRUE_def)
-
-ML {*
-fun quot_true_conv1 ctxt fnctn ctrm =
-  case (term_of ctrm) of
-    (Const (@{const_name QUOT_TRUE}, _) $ x) =>
-    let
-      val fx = fnctn x;
-      val thy = ProofContext.theory_of ctxt;
-      val cx = cterm_of thy x;
-      val cfx = cterm_of thy fx;
-      val cxt = ctyp_of thy (fastype_of x);
-      val cfxt = ctyp_of thy (fastype_of fx);
-      val thm = Drule.instantiate' [SOME cxt, SOME cfxt] [SOME cx, SOME cfx] @{thm QUOT_TRUE_imp}
-    in
-      Conv.rewr_conv thm ctrm
-    end
-*}
-
-ML {*
-fun quot_true_conv ctxt fnctn ctrm =
-  case (term_of ctrm) of
-    (Const (@{const_name QUOT_TRUE}, _) $ _) =>
-      quot_true_conv1 ctxt fnctn ctrm
-  | _ $ _ => Conv.comb_conv (quot_true_conv ctxt fnctn) ctrm
-  | Abs _ => Conv.abs_conv (fn (_, ctxt) => quot_true_conv ctxt fnctn) ctxt ctrm
-  | _ => Conv.all_conv ctrm
-*}
-
-ML {*
-fun quot_true_tac ctxt fnctn = CONVERSION
-    ((Conv.params_conv ~1 (fn ctxt =>
-       (Conv.prems_conv ~1 (quot_true_conv ctxt fnctn)))) ctxt)
-*}
-
-ML {* fun dest_comb (f $ a) = (f, a) *}
-ML {* fun dest_bcomb ((_ $ l) $ r) = (l, r) *}
-(* TODO: Can this be done easier? *)
-ML {*
-fun unlam t =
-  case t of
-    (Abs a) => snd (Term.dest_abs a)
-  | _ => unlam (Abs("", domain_type (fastype_of t), (incr_boundvars 1 t) $ (Bound 0)))
-*}
-
-ML {*
-fun dest_fun_type (Type("fun", [T, S])) = (T, S)
-  | dest_fun_type _ = error "dest_fun_type"
-*}
-
-ML {*
-val bare_concl = HOLogic.dest_Trueprop o Logic.strip_assums_concl
-*}
-
-ML {*
-val apply_rsp_tac =
-  Subgoal.FOCUS (fn {concl, asms, context,...} =>
-    case ((HOLogic.dest_Trueprop (term_of concl))) of
-      ((R2 $ (f $ x) $ (g $ y))) =>
-        (let
-          val (asmf, asma) = find_qt_asm (map term_of asms);
-        in
-          if (fastype_of asmf) = (fastype_of f) then no_tac else let
-            val ty_a = fastype_of x;
-            val ty_b = fastype_of asma;
-            val ty_c = range_type (type_of f);
-            val thy = ProofContext.theory_of context;
-            val ty_inst = map (SOME o (ctyp_of thy)) [ty_a, ty_b, ty_c];
-            val thm = Drule.instantiate' ty_inst [] @{thm apply_rsp}
-            val te = solve_quotient_assums context thm
-            val t_inst = map (SOME o (cterm_of thy)) [R2, f, g, x, y];
-            val thm = Drule.instantiate' [] t_inst te
-          in
-            compose_tac (false, thm, 2) 1
-          end
-        end
-        handle ERROR "find_qt_asm: no pair" => no_tac)
-    | _ => no_tac)
-*}
-ML {*
-fun SOLVES' tac = tac THEN_ALL_NEW (fn _ => no_tac)
-*}
-
-ML {*
-fun rep_abs_rsp_tac ctxt =
-  SUBGOAL (fn (goal, i) =>
-    case (bare_concl goal) of 
-      (rel $ _ $ (rep $ (abs $ _))) =>
-        (let
-           val thy = ProofContext.theory_of ctxt;
-           val (ty_a, ty_b) = dest_fun_type (fastype_of abs);
-           val ty_inst = map (SOME o (ctyp_of thy)) [ty_a, ty_b];
-           val t_inst = map (SOME o (cterm_of thy)) [rel, abs, rep];
-           val thm = Drule.instantiate' ty_inst t_inst @{thm rep_abs_rsp}
-           val te = solve_quotient_assums ctxt thm
-         in
-           rtac te i
-         end
-         handle _ => no_tac)
-    | _ => no_tac)
-*}
-
-ML {*
-fun inj_repabs_tac_match ctxt trans2 = SUBGOAL (fn (goal, i) =>
-(case (bare_concl goal) of
-    (* (R1 ===> R2) (\<lambda>x\<dots>) (\<lambda>y\<dots>) ----> \<lbrakk>R1 x y\<rbrakk> \<Longrightarrow> R2 (\<dots>x) (\<dots>y) *)
-  ((Const (@{const_name fun_rel}, _) $ _ $ _) $ (Abs _) $ (Abs _))
-      => rtac @{thm fun_rel_id} THEN' quot_true_tac ctxt unlam
-
-    (* (op =) (Ball\<dots>) (Ball\<dots>) ----> (op =) (\<dots>) (\<dots>) *)
-| (Const (@{const_name "op ="},_) $
-    (Const(@{const_name Ball},_) $ (Const (@{const_name Respects}, _) $ _) $ _) $
-    (Const(@{const_name Ball},_) $ (Const (@{const_name Respects}, _) $ _) $ _))
-      => rtac @{thm ball_rsp} THEN' dtac @{thm QT_all}
-
-    (* (R1 ===> op =) (Ball\<dots>) (Ball\<dots>) ----> \<lbrakk>R1 x y\<rbrakk> \<Longrightarrow> (Ball\<dots>x) = (Ball\<dots>y) *)
-| (Const (@{const_name fun_rel}, _) $ _ $ _) $
-    (Const(@{const_name Ball},_) $ (Const (@{const_name Respects}, _) $ _) $ _) $
-    (Const(@{const_name Ball},_) $ (Const (@{const_name Respects}, _) $ _) $ _)
-      => rtac @{thm fun_rel_id} THEN' quot_true_tac ctxt unlam
-
-    (* (op =) (Bex\<dots>) (Bex\<dots>) ----> (op =) (\<dots>) (\<dots>) *)
-| Const (@{const_name "op ="},_) $
-    (Const(@{const_name Bex},_) $ (Const (@{const_name Respects}, _) $ _) $ _) $
-    (Const(@{const_name Bex},_) $ (Const (@{const_name Respects}, _) $ _) $ _)
-      => rtac @{thm bex_rsp} THEN' dtac @{thm QT_ex}
-
-    (* (R1 ===> op =) (Bex\<dots>) (Bex\<dots>) ----> \<lbrakk>R1 x y\<rbrakk> \<Longrightarrow> (Bex\<dots>x) = (Bex\<dots>y) *)
-| (Const (@{const_name fun_rel}, _) $ _ $ _) $
-    (Const(@{const_name Bex},_) $ (Const (@{const_name Respects}, _) $ _) $ _) $
-    (Const(@{const_name Bex},_) $ (Const (@{const_name Respects}, _) $ _) $ _)
-      => rtac @{thm fun_rel_id} THEN' quot_true_tac ctxt unlam
-
-| (_ $
-    (Const(@{const_name Babs},_) $ (Const (@{const_name Respects}, _) $ _) $ _) $
-    (Const(@{const_name Babs},_) $ (Const (@{const_name Respects}, _) $ _) $ _))
-      => rtac @{thm babs_rsp} THEN' RANGE [quotient_tac ctxt]
-
-    (* reflexivity of operators arising from Cong_tac *)
-| Const (@{const_name "op ="},_) $ _ $ _ 
-      => rtac @{thm refl} ORELSE'
-          (resolve_tac trans2 THEN' RANGE [
-            quot_true_tac ctxt (fst o dest_bcomb), quot_true_tac ctxt (snd o dest_bcomb)])
-
-(* TODO: These patterns should should be somehow combined and generalized... *)
-| (Const (@{const_name fun_rel}, _) $ _ $ _) $
-    (Const (@{const_name fun_rel}, _) $ _ $ _) $
-    (Const (@{const_name fun_rel}, _) $ _ $ _)
-    => rtac @{thm quot_rel_rsp} THEN_ALL_NEW quotient_tac ctxt
-
-| (Const (@{const_name fun_rel}, _) $ _ $ _) $
-    (Const (@{const_name prod_rel}, _) $ _ $ _) $
-    (Const (@{const_name prod_rel}, _) $ _ $ _)
-    => rtac @{thm quot_rel_rsp} THEN_ALL_NEW quotient_tac ctxt
-
-   (* respectfulness of constants; in particular of a simple relation *)
-| _ $ (Const _) $ (Const _)  (* fun_rel, list_rel, etc but not equality *)
-    => resolve_tac (rsp_rules_get ctxt) THEN_ALL_NEW quotient_tac ctxt
-
-    (* R (\<dots>) (Rep (Abs \<dots>)) ----> R (\<dots>) (\<dots>) *)
-    (* observe ---> *)
-| _ $ _ $ _ 
-    => rep_abs_rsp_tac ctxt
-
-| _ => error "inj_repabs_tac not a relation"
-) i)
-*}
-
-ML {*
-fun inj_repabs_tac ctxt rel_refl trans2 =
-  (FIRST' [
-    inj_repabs_tac_match ctxt trans2,
-    (* R (t $ \<dots>) (t' $ \<dots>) ----> apply_rsp   provided type of t needs lifting *)
-    NDT ctxt "A" (apply_rsp_tac ctxt THEN'
-                (RANGE [quot_true_tac ctxt (fst o dest_comb), quot_true_tac ctxt (snd o dest_comb)])),
-    (* (op =) (t $ \<dots>) (t' $ \<dots>) ----> Cong   provided type of t does not need lifting *)
-    (* merge with previous tactic *)
-    NDT ctxt "B" (Cong_Tac.cong_tac @{thm cong} THEN'
-                (RANGE [quot_true_tac ctxt (fst o dest_comb), quot_true_tac ctxt (snd o dest_comb)])),
-    (* (op =) (\<lambda>x\<dots>) (\<lambda>x\<dots>) ----> (op =) (\<dots>) (\<dots>) *)
-    NDT ctxt "C" (rtac @{thm ext} THEN' quot_true_tac ctxt unlam),
-    (* resolving with R x y assumptions *)
-    NDT ctxt "E" (atac),
-    (* reflexivity of the basic relations *)
-    (* R \<dots> \<dots> *)
-    NDT ctxt "D" (resolve_tac rel_refl)
-    ])
-*}
-
-ML {*
-fun all_inj_repabs_tac ctxt rel_refl trans2 =
-  REPEAT_ALL_NEW (inj_repabs_tac ctxt rel_refl trans2)
-*}
-
-section {* Cleaning of the theorem *}
-
-ML {*
-fun make_inst lhs t =
-  let
-    val _ $ (Abs (_, _, (f as Var (_, Type ("fun", [T, _]))) $ u)) = lhs;
-    val _ $ (Abs (_, _, g)) = t;
-    fun mk_abs i t =
-      if incr_boundvars i u aconv t then Bound i
-      else (case t of
-        t1 $ t2 => mk_abs i t1 $ mk_abs i t2
-      | Abs (s, T, t') => Abs (s, T, mk_abs (i + 1) t')
-      | Bound j => if i = j then error "make_inst" else t
-      | _ => t);
-  in (f, Abs ("x", T, mk_abs 0 g)) end;
-*}
-
-ML {*
-fun lambda_prs_simple_conv ctxt ctrm =
-  case (term_of ctrm) of
-   ((Const (@{const_name fun_map}, _) $ r1 $ (a2 as (Const (s,_)))) $ (Abs _)) =>
-     let
-       val thy = ProofContext.theory_of ctxt
-       val (ty_b, ty_a) = dest_fun_type (fastype_of r1)
-       val (ty_c, ty_d) = dest_fun_type (fastype_of a2)
-       val tyinst = map (SOME o (ctyp_of thy)) [ty_a, ty_b, ty_c, ty_d]
-       val tinst = [NONE, NONE, SOME (cterm_of thy r1), NONE, SOME (cterm_of thy a2)]
-       val lpi = Drule.instantiate' tyinst tinst @{thm lambda_prs}
-       val te = @{thm eq_reflection} OF [solve_quotient_assums ctxt (solve_quotient_assums ctxt lpi)]
-       val ts = MetaSimplifier.rewrite_rule @{thms id_simps} te
-       val _ = tracing ("te rule:\n" ^ (Syntax.string_of_term ctxt (prop_of te)));
-       val tl = Thm.lhs_of ts
-       val (insp, inst) = make_inst (term_of tl) (term_of ctrm)
-       val ti = Drule.instantiate ([], [(cterm_of thy insp, cterm_of thy inst)]) ts
-       val _ = if not (s = @{const_name "id"}) then
-                  (tracing "lambda_prs";
-                   tracing ("redex:\n" ^ (Syntax.string_of_term ctxt (term_of ctrm)));
-                   tracing ("lpi rule:\n" ^ (Syntax.string_of_term ctxt (prop_of lpi)));
-                   tracing ("te rule:\n" ^ (Syntax.string_of_term ctxt (prop_of te)));
-                   tracing ("ts rule:\n" ^ (Syntax.string_of_term ctxt (prop_of ts)));
-                   tracing ("instantiated rule:\n" ^ (Syntax.string_of_term ctxt (prop_of ti))))
-               else ()
-     in
-       Conv.rewr_conv ti ctrm
-     end
-  | _ => Conv.all_conv ctrm
-*}
-
-ML {*
-val lambda_prs_conv =
-  More_Conv.top_conv lambda_prs_simple_conv
-
-fun lambda_prs_tac ctxt = CONVERSION (lambda_prs_conv ctxt)
-*}
-
-(*
- Cleaning the theorem consists of three rewriting steps.
- The first two need to be done before fun_map is unfolded
-
- 1) lambda_prs:
-     (Rep1 ---> Abs2) (\<lambda>x. Rep2 (f (Abs1 x)))  ---->  f
-
-    Implemented as conversion since it is not a pattern.
-
- 2) all_prs (the same for exists):
-     Ball (Respects R) ((abs ---> id) f)  ---->  All f
-
-    Rewriting with definitions from the argument defs
-     (rep ---> abs) oldConst ----> newconst
-
- 3) Quotient_rel_rep:
-      Rel (Rep x) (Rep y)  ---->  x = y
-
-    Quotient_abs_rep:
-      Abs (Rep x)  ---->  x
-
-    id_simps; fun_map.simps
-*)
-
-ML {*
-fun clean_tac lthy =
-  let
-    val thy = ProofContext.theory_of lthy;
-    val defs = map (Thm.varifyT o symmetric o #def) (qconsts_dest thy)
-      (* FIXME: shouldn't the definitions already be varified? *)
-    val thms1 = @{thms all_prs ex_prs} @ defs
-    val thms2 = @{thms eq_reflection[OF fun_map.simps]} 
-                @ @{thms id_simps Quotient_abs_rep Quotient_rel_rep} 
-    fun simps thms = (mk_minimal_ss lthy) addsimps thms addSolver quotient_solver
-  in
-    EVERY' [lambda_prs_tac lthy,
-            simp_tac (simps thms1),
-            simp_tac (simps thms2),
-            TRY o rtac refl]
-  end
-*}
-
-section {* Genralisation of free variables in a goal *}
-
-ML {*
-fun inst_spec ctrm =
-   Drule.instantiate' [SOME (ctyp_of_term ctrm)] [NONE, SOME ctrm] @{thm spec}
-
-fun inst_spec_tac ctrms =
-  EVERY' (map (dtac o inst_spec) ctrms)
-
-fun all_list xs trm = 
-  fold (fn (x, T) => fn t' => HOLogic.mk_all (x, T, t')) xs trm
-
-fun apply_under_Trueprop f = 
-  HOLogic.dest_Trueprop #> f #> HOLogic.mk_Trueprop
-
-fun gen_frees_tac ctxt =
- SUBGOAL (fn (concl, i) =>
-  let
-    val thy = ProofContext.theory_of ctxt
-    val vrs = Term.add_frees concl []
-    val cvrs = map (cterm_of thy o Free) vrs
-    val concl' = apply_under_Trueprop (all_list vrs) concl
-    val goal = Logic.mk_implies (concl', concl)
-    val rule = Goal.prove ctxt [] [] goal 
-      (K (EVERY1 [inst_spec_tac (rev cvrs), atac]))
-  in
-    rtac rule i
-  end)  
-*}
-
-section {* General outline of the lifting procedure *}
-
-(* - A is the original raw theorem          *)
-(* - B is the regularized theorem           *)
-(* - C is the rep/abs injected version of B *) 
-(* - D is the lifted theorem                *)
-(*                                          *)
-(* - b is the regularization step           *)
-(* - c is the rep/abs injection step        *)
-(* - d is the cleaning part                 *)
-
-lemma lifting_procedure:
-  assumes a: "A"
-  and     b: "A \<Longrightarrow> B"
-  and     c: "B = C"
-  and     d: "C = D"
-  shows   "D"
-  using a b c d
-  by simp
-
-ML {*
-fun lift_match_error ctxt fun_str rtrm qtrm =
-let
-  val rtrm_str = Syntax.string_of_term ctxt rtrm
-  val qtrm_str = Syntax.string_of_term ctxt qtrm
-  val msg = [enclose "[" "]" fun_str, "The quotient theorem\n", qtrm_str, 
-             "and the lifted theorem\n", rtrm_str, "do not match"]
-in
-  error (space_implode " " msg)
-end
-*}
-
-ML {* 
-fun procedure_inst ctxt rtrm qtrm =
-let
-  val thy = ProofContext.theory_of ctxt
-  val rtrm' = HOLogic.dest_Trueprop rtrm
-  val qtrm' = HOLogic.dest_Trueprop qtrm
-  val reg_goal = 
-        Syntax.check_term ctxt (regularize_trm ctxt rtrm' qtrm')
-        handle (LIFT_MATCH s) => lift_match_error ctxt s rtrm qtrm
-  val _ = warning "Regularization done."
-  val inj_goal = 
-        Syntax.check_term ctxt (inj_repabs_trm ctxt (reg_goal, qtrm'))
-        handle (LIFT_MATCH s) => lift_match_error ctxt s rtrm qtrm
-  val _ = warning "RepAbs Injection done."
-in
-  Drule.instantiate' []
-    [SOME (cterm_of thy rtrm'),
-     SOME (cterm_of thy reg_goal),
-     SOME (cterm_of thy inj_goal)] @{thm lifting_procedure}
-end
-*}
-
-(* Left for debugging *)
-ML {*
-fun procedure_tac ctxt rthm =
-  ObjectLogic.full_atomize_tac
-  THEN' gen_frees_tac ctxt
-  THEN' CSUBGOAL (fn (gl, i) =>
-    let
-      val rthm' = atomize_thm rthm
-      val rule = procedure_inst ctxt (prop_of rthm') (term_of gl)
-      val thm = Drule.instantiate' [] [SOME (snd (Thm.dest_comb gl))] @{thm QUOT_TRUE_i}
-    in
-      (rtac rule THEN' RANGE [rtac rthm', (fn _ => all_tac), rtac thm]) i
-    end)
-*}
-
-ML {*
-(* FIXME/TODO should only get as arguments the rthm like procedure_tac *)
-
-fun lift_tac ctxt rthm =
-  ObjectLogic.full_atomize_tac
-  THEN' gen_frees_tac ctxt
-  THEN' CSUBGOAL (fn (gl, i) =>
-    let
-      val rthm' = atomize_thm rthm
-      val rule = procedure_inst ctxt (prop_of rthm') (term_of gl)
-      val rel_refl = map (fn x => @{thm equivp_reflp} OF [x]) (equiv_rules_get ctxt)
-      val quotients = quotient_rules_get ctxt
-      val trans2 = map (fn x => @{thm equals_rsp} OF [x]) quotients
-      val thm = Drule.instantiate' [] [SOME (snd (Thm.dest_comb gl))] @{thm QUOT_TRUE_i}
-    in
-      (rtac rule THEN'
-       RANGE [rtac rthm',
-              regularize_tac ctxt,
-              rtac thm THEN' all_inj_repabs_tac ctxt rel_refl trans2,
-              clean_tac ctxt]) i
-    end)
-*}
-
-end
-
diff -r 6088fea1c8b1 -r 8a1c8dc72b5c QuotProd.thy
--- a/QuotProd.thy	Mon Dec 07 14:00:36 2009 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,80 +0,0 @@
-theory QuotProd
-imports QuotScript
-begin
-
-fun
-  prod_rel
-where
-  "prod_rel r1 r2 = (\<lambda>(a,b) (c,d). r1 a c \<and> r2 b d)"
-
-(* prod_fun is a good mapping function *)
-
-lemma prod_equivp:
-  assumes a: "equivp R1"
-  assumes b: "equivp R2"
-  shows "equivp (prod_rel R1 R2)"
-unfolding equivp_reflp_symp_transp reflp_def symp_def transp_def
-apply(auto simp add: equivp_reflp[OF a] equivp_reflp[OF b])
-apply(simp only: equivp_symp[OF a])
-apply(simp only: equivp_symp[OF b])
-using equivp_transp[OF a] apply blast
-using equivp_transp[OF b] apply blast
-done
-
-lemma prod_quotient:
-  assumes q1: "Quotient R1 Abs1 Rep1"
-  assumes q2: "Quotient R2 Abs2 Rep2"
-  shows "Quotient (prod_rel R1 R2) (prod_fun Abs1 Abs2) (prod_fun Rep1 Rep2)"
-unfolding Quotient_def
-apply (simp add: Quotient_abs_rep[OF q1] Quotient_abs_rep[OF q2] Quotient_rel_rep[OF q1] Quotient_rel_rep[OF q2])
-using Quotient_rel[OF q1] Quotient_rel[OF q2] by blast
-
-lemma pair_rsp:
-  assumes q1: "Quotient R1 Abs1 Rep1"
-  assumes q2: "Quotient R2 Abs2 Rep2"
-  shows "(R1 ===> R2 ===> prod_rel R1 R2) Pair Pair"
-by auto
-
-lemma pair_prs:
-  assumes q1: "Quotient R1 Abs1 Rep1"
-  assumes q2: "Quotient R2 Abs2 Rep2"
-  shows "(prod_fun Abs1 Abs2) (Rep1 l, Rep2 r) \<equiv> (l, r)"
-  by (simp add: Quotient_abs_rep[OF q1] Quotient_abs_rep[OF q2])
-
-(* TODO: Is the quotient assumption q1 necessary? *)
-(* TODO: Aren't there hard to use later? *)
-lemma fst_rsp:
-  assumes q1: "Quotient R1 Abs1 Rep1"
-  assumes q2: "Quotient R2 Abs2 Rep2"
-  assumes a: "(prod_rel R1 R2) p1 p2"
-  shows "R1 (fst p1) (fst p2)"
-  using a
-  apply(case_tac p1)
-  apply(case_tac p2)
-  apply(auto)
-  done
-
-lemma snd_rsp:
-  assumes q1: "Quotient R1 Abs1 Rep1"
-  assumes q2: "Quotient R2 Abs2 Rep2"
-  assumes a: "(prod_rel R1 R2) p1 p2"
-  shows "R2 (snd p1) (snd p2)"
-  using a
-  apply(case_tac p1)
-  apply(case_tac p2)
-  apply(auto)
-  done
-
-lemma fst_prs:
-  assumes q1: "Quotient R1 Abs1 Rep1"
-  assumes q2: "Quotient R2 Abs2 Rep2"
-  shows "Abs1 (fst ((prod_fun Rep1 Rep2) p)) = fst p"
-by (case_tac p) (auto simp add: Quotient_abs_rep[OF q1])
-
-lemma snd_prs:
-  assumes q1: "Quotient R1 Abs1 Rep1"
-  assumes q2: "Quotient R2 Abs2 Rep2"
-  shows "Abs2 (snd ((prod_fun Rep1 Rep2) p)) = snd p"
-by (case_tac p) (auto simp add: Quotient_abs_rep[OF q2])
-
-end
diff -r 6088fea1c8b1 -r 8a1c8dc72b5c QuotScript.thy
--- a/QuotScript.thy	Mon Dec 07 14:00:36 2009 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,569 +0,0 @@
-theory QuotScript
-imports Plain ATP_Linkup
-begin
-
-definition
-  "equivp E \<equiv> \<forall>x y. E x y = (E x = E y)"
-
-definition
-  "reflp E \<equiv> \<forall>x. E x x"
-
-definition
-  "symp E \<equiv> \<forall>x y. E x y \<longrightarrow> E y x"
-
-definition
-  "transp E \<equiv> \<forall>x y z. E x y \<and> E y z \<longrightarrow> E x z"
-
-lemma equivp_reflp_symp_transp:
-  shows "equivp E = (reflp E \<and> symp E \<and> transp E)"
-  unfolding equivp_def reflp_def symp_def transp_def expand_fun_eq
-  by (blast)
-
-lemma equivp_reflp:
-  shows "equivp E \<Longrightarrow> (\<And>x. E x x)"
-  by (simp only: equivp_reflp_symp_transp reflp_def)
-
-lemma equivp_symp:
-  shows "equivp E \<Longrightarrow> (\<And>x y. E x y \<Longrightarrow> E y x)"
-  by (metis equivp_reflp_symp_transp symp_def)
-
-lemma equivp_transp:
-  shows "equivp E \<Longrightarrow> (\<And>x y z. E x y \<Longrightarrow> E y z \<Longrightarrow> E x z)"
-by (metis equivp_reflp_symp_transp transp_def)
-
-definition
-  "part_equivp E \<equiv> (\<exists>x. E x x) \<and> (\<forall>x y. E x y = (E x x \<and> E y y \<and> (E x = E y)))"
-
-lemma equivp_IMP_part_equivp:
-  assumes a: "equivp E"
-  shows "part_equivp E"
-  using a unfolding equivp_def part_equivp_def
-  by auto
-
-definition
-  "Quotient E Abs Rep \<equiv> (\<forall>a. Abs (Rep a) = a) \<and>
-                        (\<forall>a. E (Rep a) (Rep a)) \<and>
-                        (\<forall>r s. E r s = (E r r \<and> E s s \<and> (Abs r = Abs s)))"
-
-lemma Quotient_abs_rep:
-  assumes a: "Quotient E Abs Rep"
-  shows "Abs (Rep a) \<equiv> a"
-  using a unfolding Quotient_def
-  by simp
-
-lemma Quotient_rep_reflp:
-  assumes a: "Quotient E Abs Rep"
-  shows "E (Rep a) (Rep a)"
-  using a unfolding Quotient_def
-  by blast
-
-lemma Quotient_rel:
-  assumes a: "Quotient E Abs Rep"
-  shows " E r s = (E r r \<and> E s s \<and> (Abs r = Abs s))"
-  using a unfolding Quotient_def
-  by blast
-
-lemma Quotient_rel_rep:
-  assumes a: "Quotient R Abs Rep"
-  shows "R (Rep a) (Rep b) \<equiv> (a = b)"
-  apply (rule eq_reflection)
-  using a unfolding Quotient_def
-  by metis
-
-lemma Quotient_rep_abs:
-  assumes a: "Quotient R Abs Rep"
-  shows "R r r \<Longrightarrow> R (Rep (Abs r)) r"
-  using a unfolding Quotient_def
-  by blast
-
-lemma identity_equivp:
-  shows "equivp (op =)"
-  unfolding equivp_def
-  by auto
-
-lemma identity_quotient:
-  shows "Quotient (op =) id id"
-  unfolding Quotient_def id_def
-  by blast
-
-lemma Quotient_symp:
-  assumes a: "Quotient E Abs Rep"
-  shows "symp E"
-  using a unfolding Quotient_def symp_def
-  by metis
-
-lemma Quotient_transp:
-  assumes a: "Quotient E Abs Rep"
-  shows "transp E"
-  using a unfolding Quotient_def transp_def
-  by metis
-
-fun
-  fun_map
-where
-  "fun_map f g h x = g (h (f x))"
-
-abbreviation
-  fun_map_syn (infixr "--->" 55)
-where
-  "f ---> g \<equiv> fun_map f g"
-
-lemma fun_map_id:
-  shows "(id ---> id) = id"
-  by (simp add: expand_fun_eq id_def)
-
-fun
-  fun_rel
-where
-  "fun_rel E1 E2 f g = (\<forall>x y. E1 x y \<longrightarrow> E2 (f x) (g y))"
-
-abbreviation
-  fun_rel_syn (infixr "===>" 55)
-where
-  "E1 ===> E2 \<equiv> fun_rel E1 E2"
-
-lemma fun_rel_eq:
-  "(op =) ===> (op =) \<equiv> (op =)"
-by (rule eq_reflection) (simp add: expand_fun_eq)
-
-lemma fun_quotient:
-  assumes q1: "Quotient R1 abs1 rep1"
-  and     q2: "Quotient R2 abs2 rep2"
-  shows "Quotient (R1 ===> R2) (rep1 ---> abs2) (abs1 ---> rep2)"
-proof -
-  have "\<forall>a. (rep1 ---> abs2) ((abs1 ---> rep2) a) = a"
-    apply(simp add: expand_fun_eq)
-    using q1 q2
-    apply(simp add: Quotient_def)
-    done
-  moreover
-  have "\<forall>a. (R1 ===> R2) ((abs1 ---> rep2) a) ((abs1 ---> rep2) a)"
-    apply(auto)
-    using q1 q2 unfolding Quotient_def
-    apply(metis)
-    done
-  moreover
-  have "\<forall>r s. (R1 ===> R2) r s = ((R1 ===> R2) r r \<and> (R1 ===> R2) s s \<and> 
-        (rep1 ---> abs2) r  = (rep1 ---> abs2) s)"
-    apply(auto simp add: expand_fun_eq)
-    using q1 q2 unfolding Quotient_def
-    apply(metis)
-    using q1 q2 unfolding Quotient_def
-    apply(metis)
-    using q1 q2 unfolding Quotient_def
-    apply(metis)
-    using q1 q2 unfolding Quotient_def
-    apply(metis)
-    done
-  ultimately
-  show "Quotient (R1 ===> R2) (rep1 ---> abs2) (abs1 ---> rep2)"
-    unfolding Quotient_def by blast
-qed
-
-definition
-  Respects
-where
-  "Respects R x \<equiv> (R x x)"
-
-lemma in_respects:
-  shows "(x \<in> Respects R) = R x x"
-  unfolding mem_def Respects_def by simp
-
-lemma equals_rsp:
-  assumes q: "Quotient R Abs Rep"
-  and     a: "R xa xb" "R ya yb"
-  shows "R xa ya = R xb yb"
-  using Quotient_symp[OF q] Quotient_transp[OF q] unfolding symp_def transp_def
-  using a by blast
-
-lemma lambda_prs:
-  assumes q1: "Quotient R1 Abs1 Rep1"
-  and     q2: "Quotient R2 Abs2 Rep2"
-  shows "(Rep1 ---> Abs2) (\<lambda>x. Rep2 (f (Abs1 x))) = (\<lambda>x. f x)"
-  unfolding expand_fun_eq
-  using Quotient_abs_rep[OF q1] Quotient_abs_rep[OF q2]
-  by simp
-
-lemma lambda_prs1:
-  assumes q1: "Quotient R1 Abs1 Rep1"
-  and     q2: "Quotient R2 Abs2 Rep2"
-  shows "(Rep1 ---> Abs2) (\<lambda>x. (Abs1 ---> Rep2) f x) = (\<lambda>x. f x)"
-  unfolding expand_fun_eq
-  using Quotient_abs_rep[OF q1] Quotient_abs_rep[OF q2]
-  by simp
-
-lemma rep_abs_rsp:
-  assumes q: "Quotient R Abs Rep"
-  and     a: "R x1 x2"
-  shows "R x1 (Rep (Abs x2))"
-  using q a by (metis Quotient_rel[OF q] Quotient_abs_rep[OF q] Quotient_rep_reflp[OF q])
-
-(* In the following theorem R1 can be instantiated with anything,
-   but we know some of the types of the Rep and Abs functions;
-   so by solving Quotient assumptions we can get a unique R1 that
-   will be provable; which is why we need to use apply_rsp and
-   not the primed version *)
-lemma apply_rsp:
-  assumes q: "Quotient R1 Abs1 Rep1"
-  and     a: "(R1 ===> R2) f g" "R1 x y"
-  shows "R2 ((f::'a\<Rightarrow>'c) x) ((g::'a\<Rightarrow>'c) y)"
-  using a by simp
-
-lemma apply_rsp':
-  assumes a: "(R1 ===> R2) f g" "R1 x y"
-  shows "R2 (f x) (g y)"
-  using a by simp
-
-(* Set of lemmas for regularisation of ball and bex *)
-
-lemma ball_reg_eqv:
-  fixes P :: "'a \<Rightarrow> bool"
-  assumes a: "equivp R"
-  shows "Ball (Respects R) P = (All P)"
-  by (metis equivp_def in_respects a)
-
-lemma bex_reg_eqv:
-  fixes P :: "'a \<Rightarrow> bool"
-  assumes a: "equivp R"
-  shows "Bex (Respects R) P = (Ex P)"
-  by (metis equivp_def in_respects a)
-
-lemma ball_reg_right:
-  assumes a: "\<And>x. R x \<Longrightarrow> P x \<longrightarrow> Q x"
-  shows "All P \<longrightarrow> Ball R Q"
-  by (metis COMBC_def Collect_def Collect_mem_eq a)
-
-lemma bex_reg_left:
-  assumes a: "\<And>x. R x \<Longrightarrow> Q x \<longrightarrow> P x"
-  shows "Bex R Q \<longrightarrow> Ex P"
-  by (metis COMBC_def Collect_def Collect_mem_eq a)
-
-lemma ball_reg_left:
-  assumes a: "equivp R"
-  shows "(\<And>x. (Q x \<longrightarrow> P x)) \<Longrightarrow> Ball (Respects R) Q \<longrightarrow> All P"
-  by (metis equivp_reflp in_respects a)
-
-lemma bex_reg_right:
-  assumes a: "equivp R"
-  shows "(\<And>x. (Q x \<longrightarrow> P x)) \<Longrightarrow> Ex Q \<longrightarrow> Bex (Respects R) P"
-  by (metis equivp_reflp in_respects a)
-
-lemma ball_reg_eqv_range:
-  fixes P::"'a \<Rightarrow> bool"
-  and x::"'a"
-  assumes a: "equivp R2"
-  shows   "(Ball (Respects (R1 ===> R2)) (\<lambda>f. P (f x)) = All (\<lambda>f. P (f x)))"
-  apply(rule iffI)
-  apply(rule allI)
-  apply(drule_tac x="\<lambda>y. f x" in bspec)
-  apply(simp add: Respects_def in_respects)
-  apply(rule impI)
-  using a equivp_reflp_symp_transp[of "R2"]
-  apply(simp add: reflp_def)
-  apply(simp)
-  apply(simp)
-  done
-
-lemma bex_reg_eqv_range:
-  fixes P::"'a \<Rightarrow> bool"
-  and x::"'a"
-  assumes a: "equivp R2"
-  shows   "(Bex (Respects (R1 ===> R2)) (\<lambda>f. P (f x)) = Ex (\<lambda>f. P (f x)))"
-  apply(auto)
-  apply(rule_tac x="\<lambda>y. f x" in bexI)
-  apply(simp)
-  apply(simp add: Respects_def in_respects)
-  apply(rule impI)
-  using a equivp_reflp_symp_transp[of "R2"]
-  apply(simp add: reflp_def)
-  done
-
-lemma all_reg:
-  assumes a: "!x :: 'a. (P x --> Q x)"
-  and     b: "All P"
-  shows "All Q"
-  using a b by (metis)
-
-lemma ex_reg:
-  assumes a: "!x :: 'a. (P x --> Q x)"
-  and     b: "Ex P"
-  shows "Ex Q"
-  using a b by (metis)
-
-lemma ball_reg:
-  assumes a: "!x :: 'a. (R x --> P x --> Q x)"
-  and     b: "Ball R P"
-  shows "Ball R Q"
-  using a b by (metis COMBC_def Collect_def Collect_mem_eq)
-
-lemma bex_reg:
-  assumes a: "!x :: 'a. (R x --> P x --> Q x)"
-  and     b: "Bex R P"
-  shows "Bex R Q"
-  using a b by (metis COMBC_def Collect_def Collect_mem_eq)
-
-lemma ball_all_comm:
-  "(\<And>y. (\<forall>x\<in>P. A x y) \<longrightarrow> (\<forall>x. B x y)) \<Longrightarrow> ((\<forall>x\<in>P. \<forall>y. A x y) \<longrightarrow> (\<forall>x. \<forall>y. B x y))"
-by auto
-
-lemma bex_ex_comm:
-  "((\<exists>y. \<exists>x. A x y) \<longrightarrow> (\<exists>y. \<exists>x\<in>P. B x y)) \<Longrightarrow> ((\<exists>x. \<exists>y. A x y) \<longrightarrow> (\<exists>x\<in>P. \<exists>y. B x y))"
-by auto
-
-(* Bounded abstraction *)
-definition
-  Babs :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b"
-where
-  "(x \<in> p) \<Longrightarrow> (Babs p m x = m x)"
-
-(* 3 lemmas needed for proving repabs_inj *)
-lemma ball_rsp:
-  assumes a: "(R ===> (op =)) f g"
-  shows "Ball (Respects R) f = Ball (Respects R) g"
-  using a by (simp add: Ball_def in_respects)
-
-lemma bex_rsp:
-  assumes a: "(R ===> (op =)) f g"
-  shows "(Bex (Respects R) f = Bex (Respects R) g)"
-  using a by (simp add: Bex_def in_respects)
-
-lemma babs_rsp:
-  assumes q: "Quotient R1 Abs1 Rep1"
-  and     a: "(R1 ===> R2) f g"
-  shows      "(R1 ===> R2) (Babs (Respects R1) f) (Babs (Respects R1) g)"
-  apply (auto simp add: Babs_def)
-  apply (subgoal_tac "x \<in> Respects R1 \<and> y \<in> Respects R1")
-  using a apply (simp add: Babs_def)
-  apply (simp add: in_respects)
-  using Quotient_rel[OF q]
-  by metis
-
-(* 2 lemmas needed for cleaning of quantifiers *)
-lemma all_prs:
-  assumes a: "Quotient R absf repf"
-  shows "Ball (Respects R) ((absf ---> id) f) = All f"
-  using a unfolding Quotient_def
-  by (metis in_respects fun_map.simps id_apply)
-
-lemma ex_prs:
-  assumes a: "Quotient R absf repf"
-  shows "Bex (Respects R) ((absf ---> id) f) = Ex f"
-  using a unfolding Quotient_def
-  by (metis COMBC_def Collect_def Collect_mem_eq in_respects fun_map.simps id_apply)
-
-lemma fun_rel_id:
-  assumes a: "\<And>x y. R1 x y \<Longrightarrow> R2 (f x) (g y)"
-  shows "(R1 ===> R2) f g"
-using a by simp
-
-lemma quot_rel_rsp:
-  assumes a: "Quotient R Abs Rep"
-  shows "(R ===> R ===> op =) R R"
-  apply(rule fun_rel_id)+
-  apply(rule equals_rsp[OF a])
-  apply(assumption)+
-  done
-
-
-
-
-
-
-(******************************************)
-(* REST OF THE FILE IS UNUSED (until now) *)
-(******************************************)
-lemma Quotient_rel_abs:
-  assumes a: "Quotient E Abs Rep"
-  shows "E r s \<Longrightarrow> Abs r = Abs s"
-using a unfolding Quotient_def
-by blast
-
-lemma Quotient_rel_abs_eq:
-  assumes a: "Quotient E Abs Rep"
-  shows "E r r \<Longrightarrow> E s s \<Longrightarrow> E r s = (Abs r = Abs s)"
-using a unfolding Quotient_def
-by blast
-
-lemma in_fun:
-  shows "x \<in> ((f ---> g) s) = g (f x \<in> s)"
-by (simp add: mem_def)
-
-lemma RESPECTS_THM:
-  shows "Respects (R1 ===> R2) f = (\<forall>x y. R1 x y \<longrightarrow> R2 (f x) (f y))"
-unfolding Respects_def
-by (simp add: expand_fun_eq) 
-
-lemma RESPECTS_REP_ABS:
-  assumes a: "Quotient R1 Abs1 Rep1"
-  and     b: "Respects (R1 ===> R2) f"
-  and     c: "R1 x x"
-  shows "R2 (f (Rep1 (Abs1 x))) (f x)"
-using a b[simplified RESPECTS_THM] c unfolding Quotient_def
-by blast
-
-lemma RESPECTS_MP:
-  assumes a: "Respects (R1 ===> R2) f"
-  and     b: "R1 x y"
-  shows "R2 (f x) (f y)"
-using a b unfolding Respects_def
-by simp
-
-lemma RESPECTS_o:
-  assumes a: "Respects (R2 ===> R3) f"
-  and     b: "Respects (R1 ===> R2) g"
-  shows "Respects (R1 ===> R3) (f o g)"
-using a b unfolding Respects_def
-by simp
-
-lemma fun_rel_EQ_REL:
-  assumes q1: "Quotient R1 Abs1 Rep1"
-  and     q2: "Quotient R2 Abs2 Rep2"
-  shows "(R1 ===> R2) f g = ((Respects (R1 ===> R2) f) \<and> (Respects (R1 ===> R2) g) 
-                             \<and> ((Rep1 ---> Abs2) f = (Rep1 ---> Abs2) g))"
-using fun_quotient[OF q1 q2] unfolding Respects_def Quotient_def expand_fun_eq
-by blast
-
-(* Not used since in the end we just unfold fun_map *)
-lemma APP_PRS:
-  assumes q1: "Quotient R1 abs1 rep1"
-  and     q2: "Quotient R2 abs2 rep2"
-  shows "abs2 ((abs1 ---> rep2) f (rep1 x)) = f x"
-unfolding expand_fun_eq
-using Quotient_abs_rep[OF q1] Quotient_abs_rep[OF q2]
-by simp
-
-(* Ask Peter: assumption q1 and q2 not used and lemma is the 'identity' *)
-lemma LAMBDA_RSP:
-  assumes q1: "Quotient R1 Abs1 Rep1"
-  and     q2: "Quotient R2 Abs2 Rep2"
-  and     a: "(R1 ===> R2) f1 f2"
-  shows "(R1 ===> R2) (\<lambda>x. f1 x) (\<lambda>y. f2 y)"
-by (rule a)
-
-(* ASK Peter about next four lemmas in quotientScript
-lemma ABSTRACT_PRS:
-  assumes q1: "Quotient R1 Abs1 Rep1"
-  and     q2: "Quotient R2 Abs2 Rep2"
-  shows "f = (Rep1 ---> Abs2) ???"
-*)
-
-
-lemma fun_rel_EQUALS:
-  assumes q1: "Quotient R1 Abs1 Rep1"
-  and     q2: "Quotient R2 Abs2 Rep2"
-  and     r1: "Respects (R1 ===> R2) f"
-  and     r2: "Respects (R1 ===> R2) g" 
-  shows "((Rep1 ---> Abs2) f = (Rep1 ---> Abs2) g) = (\<forall>x y. R1 x y \<longrightarrow> R2 (f x) (g y))"
-apply(rule_tac iffI)
-using fun_quotient[OF q1 q2] r1 r2 unfolding Quotient_def Respects_def
-apply(metis apply_rsp')
-using r1 unfolding Respects_def expand_fun_eq
-apply(simp (no_asm_use))
-apply(metis Quotient_rel[OF q2] Quotient_rel_rep[OF q1])
-done
-
-(* ask Peter: fun_rel_IMP used twice *) 
-lemma fun_rel_IMP2:
-  assumes q1: "Quotient R1 Abs1 Rep1"
-  and     q2: "Quotient R2 Abs2 Rep2"
-  and     r1: "Respects (R1 ===> R2) f"
-  and     r2: "Respects (R1 ===> R2) g" 
-  and     a:  "(Rep1 ---> Abs2) f = (Rep1 ---> Abs2) g"
-  shows "R1 x y \<Longrightarrow> R2 (f x) (g y)"
-using q1 q2 r1 r2 a
-by (simp add: fun_rel_EQUALS)
-
-lemma LAMBDA_REP_ABS_RSP:
-  assumes r1: "\<And>r r'. R1 r r' \<Longrightarrow>R1 r (Rep1 (Abs1 r'))"
-  and     r2: "\<And>r r'. R2 r r' \<Longrightarrow>R2 r (Rep2 (Abs2 r'))"
-  shows "(R1 ===> R2) f1 f2 \<Longrightarrow> (R1 ===> R2) f1 ((Abs1 ---> Rep2) ((Rep1 ---> Abs2) f2))"
-using r1 r2 by auto
-
-(* Not used *)
-lemma rep_abs_rsp_left:
-  assumes q: "Quotient R Abs Rep"
-  and     a: "R x1 x2"
-  shows "R x1 (Rep (Abs x2))"
-using q a by (metis Quotient_rel[OF q] Quotient_abs_rep[OF q] Quotient_rep_reflp[OF q])
-
-
-
-(* bool theory: COND, LET *)
-lemma IF_PRS:
-  assumes q: "Quotient R Abs Rep"
-  shows "If a b c = Abs (If a (Rep b) (Rep c))"
-using Quotient_abs_rep[OF q] by auto
-
-(* ask peter: no use of q *)
-lemma IF_RSP:
-  assumes q: "Quotient R Abs Rep"
-  and     a: "a1 = a2" "R b1 b2" "R c1 c2"
-  shows "R (If a1 b1 c1) (If a2 b2 c2)"
-using a by auto
-
-lemma LET_PRS:
-  assumes q1: "Quotient R1 Abs1 Rep1"
-  and     q2: "Quotient R2 Abs2 Rep2"
-  shows "Let x f = Abs2 (Let (Rep1 x) ((Abs1 ---> Rep2) f))"
-using Quotient_abs_rep[OF q1] Quotient_abs_rep[OF q2] by auto
-
-lemma LET_RSP:
-  assumes q1: "Quotient R1 Abs1 Rep1"
-  and     a1: "(R1 ===> R2) f g"
-  and     a2: "R1 x y"
-  shows "R2 ((Let x f)::'c) ((Let y g)::'c)"
-using apply_rsp[OF q1 a1] a2
-by auto
-
-
-
-(* ask peter what are literal_case *)
-(* literal_case_PRS *)
-(* literal_case_RSP *)
-
-
-
-
-
-(* combinators: I, K, o, C, W *)
-
-(* We use id_simps which includes id_apply; so these 2 theorems can be removed *)
-
-lemma I_PRS:
-  assumes q: "Quotient R Abs Rep"
-  shows "id e = Abs (id (Rep e))"
-using Quotient_abs_rep[OF q] by auto
-
-lemma I_RSP:
-  assumes q: "Quotient R Abs Rep"
-  and     a: "R e1 e2"
-  shows "R (id e1) (id e2)"
-using a by auto
-
-lemma o_PRS:
-  assumes q1: "Quotient R1 Abs1 Rep1"
-  and     q2: "Quotient R2 Abs2 Rep2"
-  and     q3: "Quotient R3 Abs3 Rep3"
-  shows "f o g = (Rep1 ---> Abs3) (((Abs2 ---> Rep3) f) o ((Abs1 ---> Rep2) g))"
-using Quotient_abs_rep[OF q1] Quotient_abs_rep[OF q2] Quotient_abs_rep[OF q3]
-unfolding o_def expand_fun_eq
-by simp
-
-lemma o_RSP:
-  assumes q1: "Quotient R1 Abs1 Rep1"
-  and     q2: "Quotient R2 Abs2 Rep2"
-  and     q3: "Quotient R3 Abs3 Rep3"
-  and     a1: "(R2 ===> R3) f1 f2"
-  and     a2: "(R1 ===> R2) g1 g2"
-  shows "(R1 ===> R3) (f1 o g1) (f2 o g2)"
-using a1 a2 unfolding o_def expand_fun_eq
-by (auto)
-
-lemma COND_PRS:
-  assumes a: "Quotient R absf repf"
-  shows "(if a then b else c) = absf (if a then repf b else repf c)"
-  using a unfolding Quotient_def by auto
-
-
-end
-
diff -r 6088fea1c8b1 -r 8a1c8dc72b5c Quotients.thy
--- a/Quotients.thy	Mon Dec 07 14:00:36 2009 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,80 +0,0 @@
-theory Quotients
-imports Main
-begin
-
-(* Other quotients that have not been proved yet *)
-
-fun
-  option_rel
-where
-  "option_rel R None None = True"
-| "option_rel R (Some x) None = False"
-| "option_rel R None (Some x) = False"
-| "option_rel R (Some x) (Some y) = R x y"
-
-fun
-  option_map
-where
-  "option_map f None = None"
-| "option_map f (Some x) = Some (f x)"
-
-fun
-  prod_rel
-where
-  "prod_rel R1 R2 (a1,a2) (b1,b2) = (R1 a1 b1 \<and> R2 a2 b2)"
-
-fun
-  prod_map
-where
-  "prod_map f1 f2 (a,b) = (f1 a, f2 b)"
-
-fun
-  sum_rel
-where
-  "sum_rel R1 R2 (Inl a1) (Inl b1) = R1 a1 b1"
-| "sum_rel R1 R2 (Inl a1) (Inr b2) = False"
-| "sum_rel R1 R2 (Inr a2) (Inl b1) = False"
-| "sum_rel R1 R2 (Inr a2) (Inr b2) = R2 a2 b2"
-
-fun
-  sum_map
-where
-  "sum_map f1 f2 (Inl a) = Inl (f1 a)"
-| "sum_map f1 f2 (Inr a) = Inr (f2 a)"
-
-
-
-
-
-fun
-  noption_map::"('a \<Rightarrow> 'b) \<Rightarrow> ('a noption) \<Rightarrow> ('b noption)"
-where
-  "noption_map f (nSome x) = nSome (f x)"
-| "noption_map f nNone = nNone"
-
-fun
-  noption_rel
-where
-  "noption_rel r (nSome x) (nSome y) = r x y"
-| "noption_rel r _ _ = False"
-
-declare [[map noption = (noption_map, noption_rel)]]
-
-lemma "noption_map id = id"
-sorry
-
-lemma noption_Quotient:
-  assumes q: "Quotient R Abs Rep"
-  shows "Quotient (noption_rel R) (noption_map Abs) (noption_map Rep)"
-  apply (unfold Quotient_def)
-  apply (auto)
-  using q
-  apply (unfold Quotient_def)
-  apply (case_tac "a :: 'b noption")
-  apply (simp)
-  apply (simp)
-  apply (case_tac "a :: 'b noption")
-  apply (simp only: option_map.simps)
-  apply (subst option_rel.simps)
-  (* Simp starts hanging so don't know how to continue *)
-  sorry