theory QuotMain

imports QuotScript QuotList Prove

begin

(*

prove {* @{prop "True"} *}

apply(rule TrueI)

done

*)

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 equiv: "EQUIV 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 x \<equiv> Abs (R x)"

definition

  "REP a = Eps (Rep a)"

lemma lem9: 

  shows "R (Eps (R x)) = R x"

proof -

  have a: "R x x" using equiv by (simp add: EQUIV_REFL_SYM_TRANS REFL_def)

  then have "R x (Eps (R x))" by (rule someI)

  then show "R (Eps (R x)) = R x" 

    using equiv unfolding EQUIV_def by simp

qed

theorem thm10:

  shows "ABS (REP a) = a"

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: equiv[simplified EQUIV_def])

lemma lem7:

  "(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: equiv[simplified EQUIV_def] lem7)

lemma REP_ABS_rsp:

  shows "R f (REP (ABS g)) = R f g"

  and   "R (REP (ABS g)) f = R g f"

apply(subst thm11)

apply(simp add: thm10 thm11)

apply(subst thm11)

apply(simp add: thm10 thm11)

done

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: equiv[simplified EQUIV_def])

done

end

section {* type definition for the quotient type *}

ML {*

Variable.variant_frees

*}

ML {*

(* constructs the term \<lambda>(c::ty \<Rightarrow> bool). \<exists>x. c = rel x *)

fun typedef_term rel ty lthy =

let 

  val [x, c] = [("x", ty), ("c", ty --> @{typ bool})] 

               |> Variable.variant_frees lthy [rel]

               |> map Free

in

  lambda c 

    (HOLogic.mk_exists 

       ("x", ty, HOLogic.mk_eq (c, (rel $ x))))

end

*}

ML {*

  |> Syntax.string_of_term @{context}

  |> writeln

ML {*

val typedef_tac =  

  EVERY1 [rewrite_goal_tac @{thms mem_def},

          rtac @{thm exI}, rtac @{thm exI}, rtac @{thm refl}]

*}

ML {*

(* makes the new type definitions *)

fun typedef_make (qty_name, rel, ty) lthy =

  LocalTheory.theory_result

  (Typedef.add_typedef false NONE 

     (qty_name, map fst (Term.add_tfreesT ty []), NoSyn)

       (typedef_term rel ty lthy)

         NONE typedef_tac) lthy

*}

text {* proves the QUOT_TYPE theorem for the new type *}

ML {*

fun typedef_quot_type_tac equiv_thm (typedef_info: Typedef.info) = 

let

  val rep_thm = #Rep typedef_info

  val rep_inv = #Rep_inverse typedef_info

  val abs_inv = #Abs_inverse typedef_info

  val rep_inj = #Rep_inject typedef_info

  val ss = HOL_basic_ss addsimps @{thms mem_def}

  val rep_thm_simpd = Simplifier.asm_full_simplify ss rep_thm

  val abs_inv_simpd = Simplifier.asm_full_simplify ss abs_inv

in

  EVERY1 [rtac @{thm QUOT_TYPE.intro},

          rtac equiv_thm, 

          rtac rep_thm_simpd, 

          rtac rep_inv, 

          rtac abs_inv_simpd, rtac @{thm exI}, rtac @{thm refl},

          rtac rep_inj]

end

*}

term QUOT_TYPE

ML {* HOLogic.mk_Trueprop *}

ML {* Goal.prove *}

ML {* Syntax.check_term *}

ML {* 

fun typedef_quot_type_thm (rel, abs, rep, equiv_thm, typedef_info) lthy =

let

  val quot_type_const = Const (@{const_name "QUOT_TYPE"}, dummyT)

  val goal = HOLogic.mk_Trueprop (quot_type_const $ rel $ abs $ rep)

             |> Syntax.check_term lthy

in

  Goal.prove lthy [] [] goal

    (fn _ => typedef_quot_type_tac equiv_thm typedef_info)

end

*}

ML {*

fun typedef_quotient_thm_tac defs quot_type_thm =

  EVERY1 [K (rewrite_goals_tac defs), 

          rtac @{thm QUOT_TYPE.QUOTIENT}, 

          rtac quot_type_thm]

*}

ML {* 

fun typedef_quotient_thm (rel, abs, rep, abs_def, rep_def, quot_type_thm) lthy =

let

  val quotient_const = Const (@{const_name "QUOTIENT"}, dummyT)

  val goal = HOLogic.mk_Trueprop (quotient_const $ rel $ abs $ rep)

             |> Syntax.check_term lthy

in

  Goal.prove lthy [] [] goal

    (fn _ => typedef_quotient_thm_tac [abs_def, rep_def] quot_type_thm)

end

*}

text {* two wrappers for define and note *}

ML {* 

fun make_def (name, mx, trm) lthy =

let   

  val ((trm, (_ , thm)), lthy') = 

     LocalTheory.define Thm.internalK ((name, mx), (Attrib.empty_binding, trm)) lthy

in

  ((trm, thm), lthy')

end

*}

ML {*

fun reg_thm (name, thm) lthy = 

let

  val ((_,[thm']), lthy') = LocalTheory.note Thm.theoremK ((name, []), [thm]) lthy 

in

  (thm',lthy')

end

*}

fun typedef_main (qty_name, rel, ty, equiv_thm) lthy =

let 

  (* generates typedef *)

  val ((_,typedef_info), lthy') = typedef_make (qty_name, rel, ty) lthy

  (* abs and rep functions *)

  val abs_ty = #abs_type typedef_info

  val rep_ty = #rep_type typedef_info

  val abs_name = #Abs_name typedef_info

  val rep_name = #Rep_name typedef_info

  val abs = Const (abs_name, rep_ty --> abs_ty)

  val rep = Const (rep_name, abs_ty --> rep_ty)

  (* ABS and REP definitions *)

  val ABS_const = Const (@{const_name "QUOT_TYPE.ABS"}, dummyT )

  val REP_const = Const (@{const_name "QUOT_TYPE.REP"}, dummyT )

  val ABS_trm = Syntax.check_term lthy' (ABS_const $ rel $ abs) 

  val REP_trm = Syntax.check_term lthy' (REP_const $ rep) 

  val ABS_name = Binding.prefix_name "ABS_" qty_name

  val REP_name = Binding.prefix_name "REP_" qty_name  

  val (((ABS, ABS_def), (REP, REP_def)), lthy'') = 

         lthy' |> make_def (ABS_name, NoSyn, ABS_trm)

               ||>> make_def (REP_name, NoSyn, REP_trm)

  (* quot_type theorem *)

  val quot_thm = typedef_quot_type_thm (rel, abs, rep, equiv_thm, typedef_info) lthy''

  val quot_thm_name = Binding.prefix_name "QUOT_TYPE_" qty_name

  (* quotient theorem *)

  val quotient_thm = typedef_quotient_thm (rel, ABS, REP, ABS_def, REP_def, quot_thm) lthy''

  val quotient_thm_name = Binding.prefix_name "QUOTIENT_" qty_name

in

  ||>> reg_thm (quotient_thm_name, quotient_thm)

end

*}

section {* various tests for quotient types*}

datatype trm =

  var  "nat" 

| app  "trm" "trm"

| lam  "nat" "trm"

ML {*

  typedef_main 

*}

local_setup {*

*}

term Rep_qtrm

term REP_qtrm

term Abs_qtrm

term ABS_qtrm

thm QUOT_TYPE_qtrm

thm QUOTIENT_qtrm

thm Rep_qtrm

text {* another test *}

datatype 'a my = Foo

consts Rmy :: "'a my \<Rightarrow> 'a my \<Rightarrow> bool"

axioms rmy_eq: "EQUIV Rmy"

term "\<lambda>(c::'a my\<Rightarrow>bool). \<exists>x. c = Rmy x"

datatype 'a trm' =

  var'  "'a" 

| app'  "'a trm'" "'a trm'"

| lam'  "'a" "'a trm'"

consts R' :: "'a trm' \<Rightarrow> 'a trm' \<Rightarrow> bool"

axioms r_eq': "EQUIV R'"

local_setup {*

*}

term ABS_qtrm'

term REP_qtrm'

thm QUOT_TYPE_qtrm'

thm QUOTIENT_qtrm'

thm Rep_qtrm'

text {* a test with lists of terms *}

datatype t =

  vr "string"

| ap "t list"

| lm "string" "t"

consts Rt :: "t \<Rightarrow> t \<Rightarrow> bool"

axioms t_eq: "EQUIV Rt"

local_setup {*

  typedef_main (@{binding "qt"}, @{term "Rt"}, @{typ "t"}, @{thm t_eq}) #> snd

*}

section {* lifting of constants *}