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)"

definition

  "ABS x \<equiv> Abs (R x)"

definition

  "REP a = Eps (Rep a)"

  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)

    using equiv unfolding EQUIV_def by simp

qed

theorem thm10:

  shows "ABS (REP a) = a"

unfolding ABS_def REP_def

proof -

  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

  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 =

               |> Variable.variant_frees lthy [rel]

               |> map Free

in

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

end

*}

(*

ML {*

 typedef_term @{term R} @{typ "nat"} @{context}

  |> Syntax.string_of_term @{context}

  |> writeln

*}*)

ML {*

  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

     (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 {*

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 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 *}

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 =

          rtac quot_type_thm]

*}

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 *}

fun make_def (name, mx, trm) lthy =

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

in

  ((trm, thm), lthy')

end

*}

(*

locale foo = fixes x :: nat

begin

ML {* make_def (@{binding foo}, NoSyn, @{term "x + x"}) @{context} *}

*)

ML {*

let

in

  (thm',lthy')

end

*}

ML {*

val no_vars = Thm.rule_attribute (fn context => fn th =>

  let

    val ctxt = Variable.set_body false (Context.proof_of context);

    val ((_, [th']), _) = Variable.import true [th] ctxt;

  in th' end);

*}

ML ProofContext.theory_of

ML Expression.interpretation

ML {*

fun my_print_tac ctxt thm =

let

   val _ = tracing (Display.string_of_thm ctxt thm)

in

   Seq.single thm

end *}

ML LocalTheory.theory_result

ML {* Binding.str_of @{binding foo} *}

ML {*

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

  (* 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_name = Binding.prefix_name "ABS_" qty_name

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

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

  (* REMOVE VARIFY *)

  val _ = tracing (Syntax.string_of_typ lthy' (type_of ABS_trm))

  val _ = tracing (Syntax.string_of_typ lthy' (type_of REP_trm))

  val _ = tracing (Syntax.string_of_typ lthy' (type_of rel))

  (* 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

  (* interpretation *)

  val bindd = ((Binding.make ("", Position.none)), ([]: Attrib.src list))

  val ((_, [eqn1pre]), lthy''') = Variable.import true [ABS_def] lthy'';

  val eqn1i = Thm.prop_of (symmetric eqn1pre)

  val ((_, [eqn2pre]), lthy'''') = Variable.import true [REP_def] lthy''';

  val eqn2i = Thm.prop_of (symmetric eqn2pre)

  val exp_morphism = ProofContext.export_morphism lthy'''' (ProofContext.init (ProofContext.theory_of lthy''''));

  val exp_term = Morphism.term exp_morphism;

  val exp = Morphism.thm exp_morphism;

  val mthd = Method.SIMPLE_METHOD ((rtac quot_thm 1) THEN

    ALLGOALS (simp_tac (HOL_basic_ss addsimps [(symmetric (exp ABS_def)), (symmetric (exp REP_def))]))

    (*THEN print_tac "Hello"*))

  val mthdt = Method.Basic (fn _ => mthd)

  val bymt = Proof.global_terminal_proof (mthdt, NONE)

  val exp_i = [(@{const_name QUOT_TYPE},((("QUOT_TYPE_I_" ^ (Binding.name_of qty_name)), true),

    Expression.Named [

     ("R", rel),

     ("Abs", abs),

     ("Rep", rep)

    ]))]

in

  lthy''''

  |> reg_thm (quot_thm_name, quot_thm)

  ||>> reg_thm (quotient_thm_name, quotient_thm)

  ||> LocalTheory.theory (fn thy =>

      let

        val global_eqns = map exp_term [eqn2i, eqn1i];

        val (global_eqns2, lthy''''') = Variable.import_terms true global_eqns lthy'''';

        val global_eqns3 = map (fn t => (bindd, t)) global_eqns2;

(*        val _ = tracing (Syntax.string_of_typ lthy'''' (type_of (fst (Logic.dest_equals (exp_term eqn1i)))));*)

      in ProofContext.theory_of (bymt (Expression.interpretation (exp_i, []) global_eqns3 thy)) end)

end

*}

section {* various tests for quotient types*}

datatype trm =

| app  "trm" "trm"

| lam  "nat" "trm"

axiomatization RR :: "trm \<Rightarrow> trm \<Rightarrow> bool" where

  r_eq: "EQUIV RR"

ML {*

*}

(*ML {*

  val lthy = @{context};

  val qty_name = @{binding "qtrm"}

  val rel = @{term "RR"}

  val ty = @{typ trm}

  val equiv_thm = @{thm r_eq}

*}*)

local_setup {*

  fn lthy =>

    Toplevel.program (fn () =>

    exception_trace (

      fn () => snd (typedef_main (@{binding "qtrm"}, @{term "RR"}, @{typ trm}, @{thm r_eq}) lthy)

    )

  )

*}

print_theorems

(*thm QUOT_TYPE_I_qtrm.thm11*)

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' =

| 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 {*

  fn lthy =>

    exception_trace

      (fn () => (typedef_main (@{binding "qtrm'"}, @{term "R'"}, @{typ "'a trm'"}, @{thm r_eq'}) #> snd) lthy)

*}

print_theorems

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 *}

text {* information about map-functions for type-constructor *}

ML {*

type typ_info = {mapfun: string}

local

  structure Data = GenericDataFun

  (type T = typ_info Symtab.table

   val empty = Symtab.empty

   val extend = I

   fun merge _ = Symtab.merge (K true))

in

 val lookup = Symtab.lookup o Data.get

end

*}

(* mapfuns for some standard types *)

setup {*

    Context.theory_map (update @{type_name "list"} {mapfun = @{const_name "map"}})

 #> Context.theory_map (update @{type_name "*"} {mapfun = @{const_name "prod_fun"}})

 #> Context.theory_map (update @{type_name "fun"}  {mapfun = @{const_name "fun_map"}})

*}

ML {* lookup (Context.Proof @{context}) @{type_name list} *}

ML {*

datatype abs_or_rep = abs | rep

let

  val qty_name = Long_Name.base_name (fst (dest_Type qty))

  fun get_fun_aux s fs_tys =

  let

    val (fs, tys) = split_list fs_tys

    val oty = Type (s, otys)

    val nty = Type (s, ntys)

    val ftys = map (op -->) tys

  in

      SOME info => (list_comb (Const (#mapfun info, ftys ---> oty --> nty), fs), (oty, nty))

    | NONE => raise ERROR ("no map association for type " ^ s))

  end

  fun get_const abs = (Const ("QuotMain.ABS_" ^ qty_name, rty --> qty), (rty, qty))

    | get_const rep = (Const ("QuotMain.REP_" ^ qty_name, qty --> rty), (qty, rty))

in

  if ty = qty

  then (get_const abs_or_rep)

  else (case ty of

          TFree _ => (Abs ("x", ty, Bound 0), (ty, ty))

        | Type (_, []) => (Abs ("x", ty, Bound 0), (ty, ty))

        | _ => raise ERROR ("no variables")

       )

end

*}

ML {*

  get_fun rep @{typ t} @{typ qt} @{context} @{typ "t * nat"}

  |> fst

  |> Syntax.string_of_term @{context}

  |> writeln

*}

ML {*

fun get_const_def nconst oconst rty qty lthy =

let

  val ty = fastype_of nconst

  val (arg_tys, res_ty) = strip_type ty

  val fresh_args = arg_tys |> map (pair "x")

                           |> map Free

  val rep_fns = map (fst o get_fun rep rty qty lthy) arg_tys

  val abs_fn  = (fst o get_fun abs rty qty lthy) res_ty

in

  map (op $) (rep_fns ~~ fresh_args)

  |> curry list_comb oconst

  |> curry (op $) abs_fn

  |> fold_rev lambda fresh_args

end

*}

ML {*

  if ty = rty then qty

    (case ty of

       Type (s, tys) => Type (s, map (exchange_ty rty qty) tys)

      | _ => ty)

*}

ML {*