section\<open>Basic relativization of function spaces\<close>

theory Discipline_Function
  imports
    Arities
begin

subsection\<open>Discipline for \<^term>\<open>fst\<close> and \<^term>\<open>snd\<close>\<close>

arity_theorem for "empty_fm"
arity_theorem for "upair_fm"
arity_theorem for "pair_fm"
definition
  is_fst :: "(i\<Rightarrow>o)\<Rightarrow>i\<Rightarrow>i\<Rightarrow>o" where
  "is_fst(M,x,t) \<equiv> (\<exists>z[M]. pair(M,t,z,x)) \<or>
                       (\<not>(\<exists>z[M]. \<exists>w[M]. pair(M,w,z,x)) \<and> empty(M,t))"
synthesize "fst" from_definition "is_fst"
notation fst_fm (\<open>\<cdot>fst'(_') is _\<cdot>\<close>)

arity_theorem for "fst_fm"

definition fst_rel ::  "[i\<Rightarrow>o,i] \<Rightarrow> i"  where
  "fst_rel(M,p) \<equiv> THE d. M(d) \<and> is_fst(M,p,d)"

reldb_add relational "fst" "is_fst"
reldb_add functional "fst" "fst_rel"

definition
  is_snd :: "(i\<Rightarrow>o)\<Rightarrow>i\<Rightarrow>i\<Rightarrow>o" where
  "is_snd(M,x,t) \<equiv> (\<exists>z[M]. pair(M,z,t,x)) \<or>
                       (\<not>(\<exists>z[M]. \<exists>w[M]. pair(M,z,w,x)) \<and> empty(M,t))"
synthesize "snd" from_definition "is_snd"
notation snd_fm (\<open>\<cdot>snd'(_') is _\<cdot>\<close>)
arity_theorem for "snd_fm"

definition snd_rel ::  "[i\<Rightarrow>o,i] \<Rightarrow> i"  where
  "snd_rel(M,p) \<equiv> THE d. M(d) \<and> is_snd(M,p,d)"

reldb_add relational "snd" "is_snd"
reldb_add functional "snd" "snd_rel"

context M_trans
begin

lemma fst_snd_closed:
  assumes "M(p)"
  shows "M(fst(p)) \<and> M(snd(p))"
  unfolding fst_def snd_def using assms
  by (cases "\<exists>a. \<exists>b. p = \<langle>a, b\<rangle>";auto)

lemma fst_closed[intro,simp]: "M(x) \<Longrightarrow> M(fst(x))"
  using fst_snd_closed by auto

lemma snd_closed[intro,simp]: "M(x) \<Longrightarrow> M(snd(x))"
  using fst_snd_closed by auto

lemma fst_abs [absolut]:
  "\<lbrakk>M(p); M(x) \<rbrakk> \<Longrightarrow> is_fst(M,p,x) \<longleftrightarrow> x = fst(p)"
  unfolding is_fst_def fst_def
  by (cases "\<exists>a. \<exists>b. p = \<langle>a, b\<rangle>";auto)

lemma snd_abs [absolut]:
  "\<lbrakk>M(p); M(y) \<rbrakk> \<Longrightarrow> is_snd(M,p,y) \<longleftrightarrow> y = snd(p)"
  unfolding is_snd_def snd_def
  by (cases "\<exists>a. \<exists>b. p = \<langle>a, b\<rangle>";auto)

lemma empty_rel_abs : "M(x) \<Longrightarrow> M(0) \<Longrightarrow> x = 0 \<longleftrightarrow> x = (THE d. M(d) \<and> empty(M, d))"
  unfolding the_def
  using transM
  by auto

lemma fst_rel_abs:
  assumes "M(p)"
  shows "fst_rel(M,p) = fst(p)"
  using fst_abs assms
  unfolding fst_def fst_rel_def
  by (cases "\<exists>a. \<exists>b. p = \<langle>a, b\<rangle>";auto;rule_tac the_equality[symmetric],simp_all)

lemma snd_rel_abs:
  assumes "M(p)"
  shows " snd_rel(M,p) = snd(p)"
  using snd_abs assms
  unfolding snd_def snd_rel_def
  by (cases "\<exists>a. \<exists>b. p = \<langle>a, b\<rangle>";auto;rule_tac the_equality[symmetric],simp_all)

end \<comment> \<open>\<^locale>\<open>M_trans\<close>\<close>

subsection\<open>Discipline for \<^term>\<open>minimum\<close>\<close>

relativize functional "first" "first_rel" external
relativize functional "minimum" "minimum_rel" external
context M_trans
begin

lemma minimum_closed[simp,intro]:
  assumes "M(A)"
  shows "M(minimum(r,A))"
  using first_is_elem the_equality_if transM[OF _ \<open>M(A)\<close>]
  by(cases "\<exists>x . first(x,A,r)",auto simp:minimum_def)

lemma first_abs :
  assumes "M(B)"
  shows "first(z,B,r) \<longleftrightarrow> first_rel(M,z,B,r)"
  unfolding first_def first_rel_def using assms by auto

lemma minimum_abs:
  assumes "M(B)"
  shows "minimum(r,B) = minimum_rel(M,r,B)"
proof -
  from assms
  have "first(b, B, r) \<longleftrightarrow> M(b) \<and> first_rel(M,b,B,r)" for b
    using first_abs
  proof (auto)
    fix b
    assume "first_rel(M,b,B,r)"
    with \<open>M(B)\<close>
    have "b\<in>B" using first_abs first_is_elem by simp
    with \<open>M(B)\<close>
    show "M(b)" using transM[OF \<open>b\<in>B\<close>] by simp
  qed
  with assms
  show ?thesis unfolding minimum_rel_def minimum_def
    by simp
qed

end \<comment> \<open>\<^locale>\<open>M_trans\<close>\<close>

subsection\<open>Discipline for \<^term>\<open>function_space\<close>\<close>

definition
  is_function_space :: "[i\<Rightarrow>o,i,i,i] \<Rightarrow> o"  where
  "is_function_space(M,A,B,fs) \<equiv> M(fs) \<and> is_funspace(M,A,B,fs)"

definition
  function_space_rel :: "[i\<Rightarrow>o,i,i] \<Rightarrow> i"  where
  "function_space_rel(M,A,B) \<equiv> THE d. is_function_space(M,A,B,d)"

reldb_rem absolute "Pi"
reldb_add relational "Pi" "is_function_space"
reldb_add functional "Pi" "function_space_rel"

abbreviation
  function_space_r :: "[i,i\<Rightarrow>o,i] \<Rightarrow> i" (\<open>_ \<rightarrow>\<^bsup>_\<^esup> _\<close> [61,1,61] 60) where
  "A \<rightarrow>\<^bsup>M\<^esup> B \<equiv> function_space_rel(M,A,B)"

abbreviation
  function_space_r_set ::  "[i,i,i] \<Rightarrow> i" (\<open>_ \<rightarrow>\<^bsup>_\<^esup> _\<close> [61,1,61] 60) where
  "function_space_r_set(A,M) \<equiv> function_space_rel(##M,A)"

context M_Pi
begin

lemma is_function_space_uniqueness:
  assumes
    "M(r)" "M(B)"
    "is_function_space(M,r,B,d)" "is_function_space(M,r,B,d')"
  shows
    "d=d'"
  using assms extensionality_trans
  unfolding is_function_space_def is_funspace_def
  by simp

lemma is_function_space_witness:
  assumes "M(A)" "M(B)"
  shows "\<exists>d[M]. is_function_space(M,A,B,d)"
proof -
  from assms
  interpret M_Pi_assumptions M A "\<lambda>_. B"
    using Pi_replacement Pi_separation
    by unfold_locales (auto dest:transM simp add:Sigfun_def)
  have "\<forall>f[M]. f \<in> Pi_rel(M,A, \<lambda>_. B) \<longleftrightarrow> f \<in> A \<rightarrow> B"
    using Pi_rel_char by simp
  with assms
  show ?thesis unfolding is_funspace_def is_function_space_def by auto
qed

lemma is_function_space_closed :
  "is_function_space(M,A,B,d) \<Longrightarrow> M(d)"
  unfolding is_function_space_def by simp

\<comment> \<open>adding closure to simpset and claset\<close>
lemma function_space_rel_closed[intro,simp]:
  assumes "M(x)" "M(y)"
  shows "M(function_space_rel(M,x,y))"
proof -
  have "is_function_space(M, x, y, THE xa. is_function_space(M, x, y, xa))"
    using assms
      theI[OF ex1I[of "is_function_space(M,x,y)"], OF _ is_function_space_uniqueness[of x y]]
      is_function_space_witness
    by auto
  then show ?thesis
    using assms is_function_space_closed
    unfolding function_space_rel_def
    by blast
qed

lemmas trans_function_space_rel_closed[trans_closed] = transM[OF _ function_space_rel_closed]

lemma is_function_space_iff:
  assumes "M(x)" "M(y)" "M(d)"
  shows "is_function_space(M,x,y,d) \<longleftrightarrow> d = function_space_rel(M,x,y)"
proof (intro iffI)
  assume "d = function_space_rel(M,x,y)"
  moreover
  note assms
  moreover from this
  obtain e where "M(e)" "is_function_space(M,x,y,e)"
    using is_function_space_witness by blast
  ultimately
  show "is_function_space(M, x, y, d)"
    using is_function_space_uniqueness[of x y] is_function_space_witness
      theI[OF ex1I[of "is_function_space(M,x,y)"], OF _ is_function_space_uniqueness[of x y], of e]
    unfolding function_space_rel_def
    by auto
next
  assume "is_function_space(M, x, y, d)"
  with assms
  show "d = function_space_rel(M,x,y)"
    using is_function_space_uniqueness unfolding function_space_rel_def
    by (blast del:the_equality intro:the_equality[symmetric])
qed

lemma def_function_space_rel:
  assumes "M(A)" "M(y)"
  shows "function_space_rel(M,A,y) = Pi_rel(M,A,\<lambda>_. y)"
proof -
  from assms
  interpret M_Pi_assumptions M A "\<lambda>_. y"
    using Pi_replacement Pi_separation
    by unfold_locales (auto dest:transM simp add:Sigfun_def)
  from assms
  have "x\<in>function_space_rel(M,A,y) \<longleftrightarrow> x\<in>Pi_rel(M,A,\<lambda>_. y)" if "M(x)" for x
    using that
      is_function_space_iff[of A y, OF _ _ function_space_rel_closed, of A y]
      def_Pi_rel Pi_rel_char mbnr.Pow_rel_char
    unfolding is_function_space_def is_funspace_def by (simp add:Pi_def)
  with assms
  show ?thesis \<comment> \<open>At this point, quoting "trans\_rules" doesn't work\<close>
    using transM[OF _ function_space_rel_closed, OF _ \<open>M(A)\<close> \<open>M(y)\<close>]
      transM[OF _ Pi_rel_closed] by blast
qed

lemma function_space_rel_char:
  assumes "M(A)" "M(y)"
  shows "function_space_rel(M,A,y) = {f \<in> A \<rightarrow> y. M(f)}"
proof -
  from assms
  interpret M_Pi_assumptions M A "\<lambda>_. y"
    using Pi_replacement Pi_separation
    by unfold_locales (auto dest:transM simp add:Sigfun_def)
  show ?thesis
    using assms def_function_space_rel Pi_rel_char
    by simp
qed

lemma mem_function_space_rel_abs:
  assumes "M(A)" "M(y)" "M(f)"
  shows "f \<in> function_space_rel(M,A,y) \<longleftrightarrow>  f \<in> A \<rightarrow> y"
  using assms function_space_rel_char by simp

end \<comment> \<open>\<^locale>\<open>M_Pi\<close>\<close>

locale M_N_Pi = M:M_Pi + N:M_Pi N for N +
  assumes
    M_imp_N:"M(x) \<Longrightarrow> N(x)"
begin

lemma function_space_rel_transfer: "M(A) \<Longrightarrow> M(B) \<Longrightarrow>
                          function_space_rel(M,A,B) \<subseteq> function_space_rel(N,A,B)"
  using M.function_space_rel_char N.function_space_rel_char
  by (auto dest!:M_imp_N)

end \<comment> \<open>\<^locale>\<open>M_N_Pi\<close>\<close>

abbreviation
  "is_apply \<equiv> fun_apply"
  \<comment> \<open>It is not necessary to perform the Discipline for \<^term>\<open>is_apply\<close>
  since it is absolute in this context\<close>

subsection\<open>Discipline for \<^term>\<open>Collect\<close> terms.\<close>

text\<open>We have to isolate the predicate involved and apply the
Discipline to it.\<close>

definition \<comment> \<open>completely relational\<close>
  injP_rel:: "[i\<Rightarrow>o,i,i]\<Rightarrow>o" where
  "injP_rel(M,A,f) \<equiv> \<forall>w[M]. \<forall>x[M]. \<forall>fw[M]. \<forall>fx[M]. w\<in>A \<and> x\<in>A \<and>
            is_apply(M,f,w,fw) \<and> is_apply(M,f,x,fx) \<and> fw=fx\<longrightarrow> w=x"

synthesize "injP_rel" from_definition assuming "nonempty"

arity_theorem for "injP_rel_fm"

context M_basic
begin

\<comment> \<open>I'm undecided on keeping the relative quantifiers here.
    Same with \<^term>\<open>surjP\<close> below. It might relieve from changing
    @{thm [source] exI allI} to @{thm [source] rexI rallI} in some proofs.
    I wonder if this escalates well. Assuming that all terms
    appearing in the "def\_" theorem are in \<^term>\<open>M\<close> and using
    @{thm [source] transM}, it might do.\<close>
lemma def_injP_rel:
  assumes
    "M(A)" "M(f)"
  shows
    "injP_rel(M,A,f) \<longleftrightarrow> (\<forall>w[M]. \<forall>x[M]. w\<in>A \<and> x\<in>A \<and> f`w=f`x \<longrightarrow> w=x)"
  using assms unfolding injP_rel_def by simp

end \<comment> \<open>\<^locale>\<open>M_basic\<close>\<close>

subsection\<open>Discipline for \<^term>\<open>inj\<close>\<close>

definition \<comment> \<open>completely relational\<close>
  is_inj   :: "[i\<Rightarrow>o,i,i,i]\<Rightarrow>o"  where
  "is_inj(M,A,B,I) \<equiv> M(I) \<and> (\<exists>F[M]. is_function_space(M,A,B,F) \<and>
       is_Collect(M,F,injP_rel(M,A),I))"

declare typed_function_iff_sats Collect_iff_sats [iff_sats]

synthesize "is_funspace" from_definition assuming "nonempty"
arity_theorem for "is_funspace_fm"

synthesize "is_function_space" from_definition assuming "nonempty"
notation is_function_space_fm (\<open>\<cdot>_ \<rightarrow> _ is _\<cdot>\<close>)

arity_theorem for "is_function_space_fm"

synthesize "is_inj" from_definition assuming "nonempty"
notation is_inj_fm (\<open>\<cdot>inj'(_,_') is _\<cdot>\<close>)

arity_theorem intermediate for "is_inj_fm"

lemma arity_is_inj_fm[arity]:
  "A \<in> nat \<Longrightarrow>
    B \<in> nat \<Longrightarrow> I \<in> nat \<Longrightarrow> arity(is_inj_fm(A, B, I)) = succ(A) \<union> succ(B) \<union> succ(I)"
  using arity_is_inj_fm' by (auto simp:pred_Un_distrib arity)

definition
  inj_rel :: "[i\<Rightarrow>o,i,i] \<Rightarrow> i" (\<open>inj\<^bsup>_\<^esup>'(_,_')\<close>) where
  "inj_rel(M,A,B) \<equiv> THE d. is_inj(M,A,B,d)"

abbreviation
  inj_r_set ::  "[i,i,i] \<Rightarrow> i" (\<open>inj\<^bsup>_\<^esup>'(_,_')\<close>) where
  "inj_r_set(M) \<equiv> inj_rel(##M)"

locale M_inj = M_Pi +
  assumes
    injP_separation: "M(r) \<Longrightarrow> separation(M,injP_rel(M, r))"
begin

lemma is_inj_uniqueness:
  assumes
    "M(r)" "M(B)"
    "is_inj(M,r,B,d)" "is_inj(M,r,B,d')"
  shows
    "d=d'"
  using assms is_function_space_iff extensionality_trans
  unfolding is_inj_def by simp

lemma is_inj_witness: "M(r) \<Longrightarrow> M(B)\<Longrightarrow> \<exists>d[M]. is_inj(M,r,B,d)"
  using injP_separation is_function_space_iff
  unfolding is_inj_def by simp

lemma is_inj_closed :
  "is_inj(M,x,y,d) \<Longrightarrow> M(d)"
  unfolding is_inj_def by simp

lemma inj_rel_closed[intro,simp]:
  assumes "M(x)" "M(y)"
  shows "M(inj_rel(M,x,y))"
proof -
  have "is_inj(M, x, y, THE xa. is_inj(M, x, y, xa))"
    using assms
      theI[OF ex1I[of "is_inj(M,x,y)"], OF _ is_inj_uniqueness[of x y]]
      is_inj_witness
    by auto
  then show ?thesis
    using assms is_inj_closed
    unfolding inj_rel_def
    by blast
qed

lemmas trans_inj_rel_closed[trans_closed] = transM[OF _ inj_rel_closed]

lemma inj_rel_iff:
  assumes "M(x)" "M(y)" "M(d)"
  shows "is_inj(M,x,y,d) \<longleftrightarrow> d = inj_rel(M,x,y)"
proof (intro iffI)
  assume "d = inj_rel(M,x,y)"
  moreover
  note assms
  moreover from this
  obtain e where "M(e)" "is_inj(M,x,y,e)"
    using is_inj_witness by blast
  ultimately
  show "is_inj(M, x, y, d)"
    using is_inj_uniqueness[of x y] is_inj_witness
      theI[OF ex1I[of "is_inj(M,x,y)"], OF _ is_inj_uniqueness[of x y], of e]
    unfolding inj_rel_def
    by auto
next
  assume "is_inj(M, x, y, d)"
  with assms
  show "d = inj_rel(M,x,y)"
    using is_inj_uniqueness unfolding inj_rel_def
    by (blast del:the_equality intro:the_equality[symmetric])
qed

lemma def_inj_rel:
  assumes "M(A)" "M(B)"
  shows "inj_rel(M,A,B) =
         {f \<in> function_space_rel(M,A,B).  \<forall>w[M]. \<forall>x[M]. w\<in>A \<and> x\<in>A \<and> f`w = f`x \<longrightarrow> w=x}"
    (is "_ = Collect(_,?P)")
proof -
  from assms
  have "inj_rel(M,A,B) \<subseteq> function_space_rel(M,A,B)"
    using inj_rel_iff[of A B "inj_rel(M,A,B)"] is_function_space_iff
    unfolding is_inj_def by auto
  moreover from assms
  have "f \<in> inj_rel(M,A,B) \<Longrightarrow> ?P(f)" for f
    using inj_rel_iff[of A B "inj_rel(M,A,B)"] is_function_space_iff
      def_injP_rel transM[OF _ function_space_rel_closed, OF _ \<open>M(A)\<close> \<open>M(B)\<close>]
    unfolding is_inj_def by auto
  moreover from assms
  have "f \<in> function_space_rel(M,A,B) \<Longrightarrow> ?P(f) \<Longrightarrow> f \<in> inj_rel(M,A,B)" for f
    using inj_rel_iff[of A B "inj_rel(M,A,B)"] is_function_space_iff
      def_injP_rel transM[OF _ function_space_rel_closed, OF _ \<open>M(A)\<close> \<open>M(B)\<close>]
    unfolding is_inj_def by auto
  ultimately
  show ?thesis by force
qed

lemma inj_rel_char:
  assumes "M(A)" "M(B)"
  shows "inj_rel(M,A,B) = {f \<in> inj(A,B). M(f)}"
proof -
  from assms
  interpret M_Pi_assumptions M A "\<lambda>_. B"
    using Pi_replacement Pi_separation
    by unfold_locales (auto dest:transM simp add:Sigfun_def)
  from assms
  show ?thesis
    using def_inj_rel[OF assms] def_function_space_rel[OF assms]
      transM[OF _ \<open>M(A)\<close>] Pi_rel_char
    unfolding inj_def
    by auto
qed

end \<comment> \<open>\<^locale>\<open>M_inj\<close>\<close>

locale M_N_inj = M:M_inj + N:M_inj N for N +
  assumes
    M_imp_N:"M(x) \<Longrightarrow> N(x)"
begin

lemma inj_rel_transfer: "M(A) \<Longrightarrow> M(B) \<Longrightarrow> inj_rel(M,A,B) \<subseteq> inj_rel(N,A,B)"
  using M.inj_rel_char N.inj_rel_char
  by (auto dest!:M_imp_N)

end \<comment> \<open>\<^locale>\<open>M_N_inj\<close>\<close>

subsection\<open>Discipline for \<^term>\<open>surj\<close>\<close>

definition
  surjP_rel:: "[i\<Rightarrow>o,i,i,i]\<Rightarrow>o" where
  "surjP_rel(M,A,B,f) \<equiv>
    \<forall>y[M]. \<exists>x[M]. \<exists>fx[M]. y\<in>B \<longrightarrow> x\<in>A \<and> is_apply(M,f,x,fx) \<and> fx=y"

synthesize "surjP_rel" from_definition assuming "nonempty"

context M_basic
begin

lemma def_surjP_rel:
  assumes
    "M(A)" "M(B)" "M(f)"
  shows
    "surjP_rel(M,A,B,f) \<longleftrightarrow> (\<forall>y[M]. \<exists>x[M]. y\<in>B \<longrightarrow> x\<in>A \<and> f`x=y)"
  using assms unfolding surjP_rel_def by auto

end \<comment> \<open>\<^locale>\<open>M_basic\<close>\<close>

subsection\<open>Discipline for \<^term>\<open>surj\<close>\<close>

definition \<comment> \<open>completely relational\<close>
  is_surj   :: "[i\<Rightarrow>o,i,i,i]\<Rightarrow>o"  where
  "is_surj(M,A,B,I) \<equiv> M(I) \<and> (\<exists>F[M]. is_function_space(M,A,B,F) \<and>
       is_Collect(M,F,surjP_rel(M,A,B),I))"

synthesize "is_surj" from_definition assuming "nonempty"
notation is_surj_fm (\<open>\<cdot>surj'(_,_') is _\<cdot>\<close>)

definition
  surj_rel :: "[i\<Rightarrow>o,i,i] \<Rightarrow> i" (\<open>surj\<^bsup>_\<^esup>'(_,_')\<close>) where
  "surj_rel(M,A,B) \<equiv> THE d. is_surj(M,A,B,d)"

abbreviation
  surj_r_set ::  "[i,i,i] \<Rightarrow> i" (\<open>surj\<^bsup>_\<^esup>'(_,_')\<close>) where
  "surj_r_set(M) \<equiv> surj_rel(##M)"

locale M_surj = M_Pi +
  assumes
    surjP_separation: "M(A)\<Longrightarrow>M(B)\<Longrightarrow>separation(M,\<lambda>x. surjP_rel(M,A,B,x))"
begin

lemma is_surj_uniqueness:
  assumes
    "M(r)" "M(B)"
    "is_surj(M,r,B,d)" "is_surj(M,r,B,d')"
  shows
    "d=d'"
  using assms is_function_space_iff extensionality_trans
  unfolding is_surj_def by simp

lemma is_surj_witness: "M(r) \<Longrightarrow> M(B)\<Longrightarrow> \<exists>d[M]. is_surj(M,r,B,d)"
  using surjP_separation is_function_space_iff
  unfolding is_surj_def by simp

lemma is_surj_closed :
  "is_surj(M,x,y,d) \<Longrightarrow> M(d)"
  unfolding is_surj_def by simp

lemma surj_rel_closed[intro,simp]:
  assumes "M(x)" "M(y)"
  shows "M(surj_rel(M,x,y))"
proof -
  have "is_surj(M, x, y, THE xa. is_surj(M, x, y, xa))"
    using assms
      theI[OF ex1I[of "is_surj(M,x,y)"], OF _ is_surj_uniqueness[of x y]]
      is_surj_witness
    by auto
  then show ?thesis
    using assms is_surj_closed
    unfolding surj_rel_def
    by blast
qed

lemmas trans_surj_rel_closed[trans_closed] = transM[OF _ surj_rel_closed]

lemma surj_rel_iff:
  assumes "M(x)" "M(y)" "M(d)"
  shows "is_surj(M,x,y,d) \<longleftrightarrow> d = surj_rel(M,x,y)"
proof (intro iffI)
  assume "d = surj_rel(M,x,y)"
  moreover
  note assms
  moreover from this
  obtain e where "M(e)" "is_surj(M,x,y,e)"
    using is_surj_witness by blast
  ultimately
  show "is_surj(M, x, y, d)"
    using is_surj_uniqueness[of x y] is_surj_witness
      theI[OF ex1I[of "is_surj(M,x,y)"], OF _ is_surj_uniqueness[of x y], of e]
    unfolding surj_rel_def
    by auto
next
  assume "is_surj(M, x, y, d)"
  with assms
  show "d = surj_rel(M,x,y)"
    using is_surj_uniqueness unfolding surj_rel_def
    by (blast del:the_equality intro:the_equality[symmetric])
qed

lemma def_surj_rel:
  assumes "M(A)" "M(B)"
  shows "surj_rel(M,A,B) =
         {f \<in> function_space_rel(M,A,B). \<forall>y[M]. \<exists>x[M]. y\<in>B \<longrightarrow> x\<in>A \<and> f`x=y }"
    (is "_ = Collect(_,?P)")
proof -
  from assms
  have "surj_rel(M,A,B) \<subseteq> function_space_rel(M,A,B)"
    using surj_rel_iff[of A B "surj_rel(M,A,B)"] is_function_space_iff
    unfolding is_surj_def by auto
  moreover from assms
  have "f \<in> surj_rel(M,A,B) \<Longrightarrow> ?P(f)" for f
    using surj_rel_iff[of A B "surj_rel(M,A,B)"] is_function_space_iff
      def_surjP_rel transM[OF _ function_space_rel_closed, OF _ \<open>M(A)\<close> \<open>M(B)\<close>]
    unfolding is_surj_def by auto
  moreover from assms
  have "f \<in> function_space_rel(M,A,B) \<Longrightarrow> ?P(f) \<Longrightarrow> f \<in> surj_rel(M,A,B)" for f
    using surj_rel_iff[of A B "surj_rel(M,A,B)"] is_function_space_iff
      def_surjP_rel transM[OF _ function_space_rel_closed, OF _ \<open>M(A)\<close> \<open>M(B)\<close>]
    unfolding is_surj_def by auto
  ultimately
  show ?thesis by force
qed

lemma surj_rel_char:
  assumes "M(A)" "M(B)"
  shows "surj_rel(M,A,B) = {f \<in> surj(A,B). M(f)}"
proof -
  from assms
  interpret M_Pi_assumptions M A "\<lambda>_. B"
    using Pi_replacement Pi_separation
    by unfold_locales (auto dest:transM simp add:Sigfun_def)
  from assms
  show ?thesis
    using def_surj_rel[OF assms] def_function_space_rel[OF assms]
      transM[OF _ \<open>M(A)\<close>] transM[OF _ \<open>M(B)\<close>] Pi_rel_char
    unfolding surj_def
    by auto
qed

end \<comment> \<open>\<^locale>\<open>M_surj\<close>\<close>

locale M_N_surj = M:M_surj + N:M_surj N for N +
  assumes
    M_imp_N:"M(x) \<Longrightarrow> N(x)"
begin

lemma surj_rel_transfer: "M(A) \<Longrightarrow> M(B) \<Longrightarrow> surj_rel(M,A,B) \<subseteq> surj_rel(N,A,B)"
  using M.surj_rel_char N.surj_rel_char
  by (auto dest!:M_imp_N)

end \<comment> \<open>\<^locale>\<open>M_N_surj\<close>\<close>

subsection\<open>Discipline for \<^term>\<open>Inter\<close>\<close>

definition
  is_Int :: "[i\<Rightarrow>o,i,i,i]\<Rightarrow>o"  where
  "is_Int(M,A,B,I) \<equiv> M(I) \<and> (\<forall>x[M]. x \<in> I \<longleftrightarrow> x \<in> A \<and> x \<in> B)"

reldb_rem relational "inter"
reldb_add absolute relational "ZF_Base.Int" "is_Int"

synthesize "is_Int" from_definition assuming "nonempty"
notation is_Int_fm (\<open>_ \<inter> _ is _\<close>)

context M_basic
begin

lemma is_Int_closed :
  "is_Int(M,A,B,I) \<Longrightarrow> M(I)"
  unfolding is_Int_def by simp

lemma is_Int_abs:
  assumes
    "M(A)" "M(B)" "M(I)"
  shows
    "is_Int(M,A,B,I) \<longleftrightarrow> I = A \<inter> B"
  using assms transM[OF _ \<open>M(B)\<close>] transM[OF _ \<open>M(I)\<close>]
  unfolding is_Int_def by blast

lemma is_Int_uniqueness:
  assumes
    "M(r)" "M(B)"
    "is_Int(M,r,B,d)" "is_Int(M,r,B,d')"
  shows
    "d=d'"
proof -
  have "M(d)" and "M(d')"
    using assms is_Int_closed by simp+
  then show ?thesis
    using assms is_Int_abs by simp
qed

text\<open>Note: @{thm [source] Int_closed} already in \<^theory>\<open>ZF-Constructible.Relative\<close>.\<close>

end \<comment> \<open>\<^locale>\<open>M_basic\<close>\<close>

subsection\<open>Discipline for \<^term>\<open>bij\<close>\<close>

reldb_add functional "inj" "inj_rel"
reldb_add functional relational "inj_rel" "is_inj"
reldb_add functional "surj" "surj_rel"
reldb_add functional relational "surj_rel" "is_surj"
relativize functional "bij" "bij_rel" external
relationalize "bij_rel" "is_bij"

synthesize "is_bij" from_definition assuming "nonempty"
notation is_bij_fm (\<open>\<cdot>bij'(_,_') is _\<cdot>\<close>)

abbreviation
  bij_r_class ::  "[i\<Rightarrow>o,i,i] \<Rightarrow> i" (\<open>bij\<^bsup>_\<^esup>'(_,_')\<close>) where
  "bij_r_class \<equiv> bij_rel"

abbreviation
  bij_r_set ::  "[i,i,i] \<Rightarrow> i" (\<open>bij\<^bsup>_\<^esup>'(_,_')\<close>) where
  "bij_r_set(M) \<equiv> bij_rel(##M)"

locale M_Perm = M_Pi + M_inj + M_surj
begin

lemma is_bij_closed : "is_bij(M,f,y,d) \<Longrightarrow> M(d)"
  unfolding is_bij_def using is_Int_closed is_inj_witness is_surj_witness by auto

lemma bij_rel_closed[intro,simp]:
  assumes "M(x)" "M(y)"
  shows "M(bij_rel(M,x,y))"
  unfolding bij_rel_def
  using assms Int_closed surj_rel_closed inj_rel_closed
  by auto

lemmas trans_bij_rel_closed[trans_closed] = transM[OF _ bij_rel_closed]

lemma bij_rel_iff:
  assumes "M(x)" "M(y)" "M(d)"
  shows "is_bij(M,x,y,d) \<longleftrightarrow> d = bij_rel(M,x,y)"
  unfolding is_bij_def bij_rel_def
  using assms surj_rel_iff inj_rel_iff is_Int_abs
  by auto

lemma def_bij_rel:
  assumes "M(A)" "M(B)"
  shows "bij_rel(M,A,B) = inj_rel(M,A,B) \<inter> surj_rel(M,A,B)"
  using assms bij_rel_iff inj_rel_iff surj_rel_iff
    is_Int_abs\<comment> \<open>For absolute terms, "\_abs" replaces "\_iff".
                 Also, in this case "\_closed" is in the simpset.\<close>
  unfolding is_bij_def by simp

lemma bij_rel_char:
  assumes "M(A)" "M(B)"
  shows "bij_rel(M,A,B) = {f \<in> bij(A,B). M(f)}"
  using assms def_bij_rel inj_rel_char surj_rel_char
  unfolding bij_def\<comment> \<open>Unfolding this might be a pattern already\<close>
  by auto

end \<comment> \<open>\<^locale>\<open>M_Perm\<close>\<close>

locale M_N_Perm = M_N_Pi + M_N_inj + M_N_surj + M:M_Perm + N:M_Perm N

begin

lemma bij_rel_transfer: "M(A) \<Longrightarrow> M(B) \<Longrightarrow> bij_rel(M,A,B) \<subseteq> bij_rel(N,A,B)"
  using M.bij_rel_char N.bij_rel_char
  by (auto dest!:M_imp_N)

end \<comment> \<open>\<^locale>\<open>M_N_Perm\<close>\<close>

context M_Perm
begin

lemma mem_bij_rel: "\<lbrakk>f \<in> bij\<^bsup>M\<^esup>(A,B); M(A); M(B)\<rbrakk> \<Longrightarrow> f\<in>bij(A,B)"
  using bij_rel_char by simp

lemma mem_inj_rel: "\<lbrakk>f \<in> inj\<^bsup>M\<^esup>(A,B); M(A); M(B)\<rbrakk> \<Longrightarrow> f\<in>inj(A,B)"
  using inj_rel_char by simp

lemma mem_surj_rel: "\<lbrakk>f \<in> surj\<^bsup>M\<^esup>(A,B); M(A); M(B)\<rbrakk> \<Longrightarrow> f\<in>surj(A,B)"
  using surj_rel_char by simp

end \<comment> \<open>\<^locale>\<open>M_Perm\<close>\<close>

subsection\<open>Discipline for \<^term>\<open>eqpoll\<close>\<close>

relativize functional "eqpoll" "eqpoll_rel" external
relationalize "eqpoll_rel" "is_eqpoll"

synthesize "is_eqpoll" from_definition assuming "nonempty"
arity_theorem for "is_eqpoll_fm"
notation is_eqpoll_fm (\<open>\<cdot>_ \<approx> _\<cdot>\<close>)

context M_Perm begin

is_iff_rel for "eqpoll"
  using bij_rel_iff unfolding is_eqpoll_def eqpoll_rel_def by simp

end \<comment> \<open>\<^locale>\<open>M_Perm\<close>\<close>

abbreviation
  eqpoll_r :: "[i,i\<Rightarrow>o,i] => o" (\<open>_ \<approx>\<^bsup>_\<^esup> _\<close> [51,1,51] 50) where
  "A \<approx>\<^bsup>M\<^esup> B \<equiv> eqpoll_rel(M,A,B)"

abbreviation
  eqpoll_r_set ::  "[i,i,i] \<Rightarrow> o" (\<open>_ \<approx>\<^bsup>_\<^esup> _\<close> [51,1,51] 50) where
  "eqpoll_r_set(A,M) \<equiv> eqpoll_rel(##M,A)"

context M_Perm
begin

lemma def_eqpoll_rel:
  assumes
    "M(A)" "M(B)"
  shows
    "eqpoll_rel(M,A,B) \<longleftrightarrow> (\<exists>f[M]. f \<in> bij_rel(M,A,B))"
  using assms bij_rel_iff
  unfolding eqpoll_rel_def by simp

end \<comment> \<open>\<^locale>\<open>M_Perm\<close>\<close>

context M_N_Perm
begin

text\<open>The next lemma is not part of the discipline\<close>
lemma eqpoll_rel_transfer: assumes "A \<approx>\<^bsup>M\<^esup> B" "M(A)" "M(B)"
  shows "A \<approx>\<^bsup>N\<^esup> B"
proof -
  note assms
  moreover from this
  obtain f where "f \<in> bij\<^bsup>M\<^esup>(A,B)" "N(f)"
    using M.def_eqpoll_rel by (auto dest!:M_imp_N)
  moreover from calculation
  have "f \<in> bij\<^bsup>N\<^esup>(A,B)"
    using bij_rel_transfer by (auto)
  ultimately
  show ?thesis
    using N.def_eqpoll_rel by (blast dest!:M_imp_N)
qed

end \<comment> \<open>\<^locale>\<open>M_N_Perm\<close>\<close>

subsection\<open>Discipline for \<^term>\<open>lepoll\<close>\<close>

relativize functional "lepoll" "lepoll_rel" external
relationalize "lepoll_rel" "is_lepoll"

synthesize "is_lepoll" from_definition assuming "nonempty"
notation is_lepoll_fm (\<open>\<cdot>_ \<lesssim> _\<cdot>\<close>)
arity_theorem for "is_lepoll_fm"

context M_inj begin

is_iff_rel for "lepoll"
  using inj_rel_iff unfolding is_lepoll_def lepoll_rel_def by simp

end \<comment> \<open>\<^locale>\<open>M_inj\<close>\<close>

abbreviation
  lepoll_r :: "[i,i\<Rightarrow>o,i] => o" (\<open>_ \<lesssim>\<^bsup>_\<^esup> _\<close> [51,1,51] 50) where
  "A \<lesssim>\<^bsup>M\<^esup> B \<equiv> lepoll_rel(M,A,B)"

abbreviation
  lepoll_r_set ::  "[i,i,i] \<Rightarrow> o" (\<open>_ \<lesssim>\<^bsup>_\<^esup> _\<close> [51,1,51] 50) where
  "lepoll_r_set(A,M) \<equiv> lepoll_rel(##M,A)"

context M_Perm
begin

lemma def_lepoll_rel:
  assumes
    "M(A)" "M(B)"
  shows
    "lepoll_rel(M,A,B) \<longleftrightarrow> (\<exists>f[M]. f \<in> inj_rel(M,A,B))"
  using assms inj_rel_iff
  unfolding lepoll_rel_def by simp

end \<comment> \<open>\<^locale>\<open>M_Perm\<close>\<close>

context M_N_Perm
begin

\<comment> \<open>This lemma is not part of the discipline.\<close>
lemma lepoll_rel_transfer: assumes "A \<lesssim>\<^bsup>M\<^esup> B" "M(A)" "M(B)"
  shows "A \<lesssim>\<^bsup>N\<^esup> B"
proof -
  note assms
  moreover from this
  obtain f where "f \<in> inj\<^bsup>M\<^esup>(A,B)" "N(f)"
    using M.def_lepoll_rel by (auto dest!:M_imp_N)
  moreover from calculation
  have "f \<in> inj\<^bsup>N\<^esup>(A,B)"
    using inj_rel_transfer by (auto)
  ultimately
  show ?thesis
    using N.def_lepoll_rel by (blast dest!:M_imp_N)
qed

end \<comment> \<open>\<^locale>\<open>M_N_Perm\<close>\<close>

subsection\<open>Discipline for \<^term>\<open>lesspoll\<close>\<close>

relativize functional "lesspoll" "lesspoll_rel" external
relationalize "lesspoll_rel" "is_lesspoll"

synthesize "is_lesspoll" from_definition assuming "nonempty"
notation is_lesspoll_fm (\<open>\<cdot>_ \<prec> _\<cdot>\<close>)
arity_theorem for "is_lesspoll_fm"

context M_Perm begin

is_iff_rel for "lesspoll"
  using is_lepoll_iff is_eqpoll_iff
  unfolding is_lesspoll_def lesspoll_rel_def by simp

end \<comment> \<open>\<^locale>\<open>M_Perm\<close>\<close>

abbreviation
  lesspoll_r :: "[i,i\<Rightarrow>o,i] => o" (\<open>_ \<prec>\<^bsup>_\<^esup> _\<close> [51,1,51] 50) where
  "A \<prec>\<^bsup>M\<^esup> B \<equiv> lesspoll_rel(M,A,B)"

abbreviation
  lesspoll_r_set ::  "[i,i,i] \<Rightarrow> o" (\<open>_ \<prec>\<^bsup>_\<^esup> _\<close> [51,1,51] 50) where
  "lesspoll_r_set(A,M) \<equiv> lesspoll_rel(##M,A)"

text\<open>Since \<^term>\<open>lesspoll_rel\<close> is defined as a propositional
combination of older terms, there is no need for a separate ``def''
theorem for it.\<close>

text\<open>Note that \<^term>\<open>lesspoll_rel\<close> is neither $\Sigma_1^{\mathit{ZF}}$ nor
 $\Pi_1^{\mathit{ZF}}$, so there is no ``transfer'' theorem for it.\<close>

definition
  Powapply :: "[i,i] \<Rightarrow> i"  where
  "Powapply(f,y) \<equiv> Pow(f`y)"

reldb_add functional "Pow" "Pow_rel"
reldb_add relational "Pow" "is_Pow"

declare Replace_iff_sats[iff_sats]
synthesize "is_Pow" from_definition assuming "nonempty"
arity_theorem for "is_Pow_fm"

relativize functional "Powapply" "Powapply_rel"
relationalize "Powapply_rel" "is_Powapply"
synthesize "is_Powapply" from_definition assuming "nonempty"
arity_theorem for "is_Powapply_fm"

notation Powapply_rel (\<open>Powapply\<^bsup>_\<^esup>'(_,_')\<close>)

context M_basic
begin

rel_closed for "Powapply"
  unfolding Powapply_rel_def
  by simp

is_iff_rel for "Powapply"
  using Pow_rel_iff
  unfolding is_Powapply_def Powapply_rel_def
  by simp

end \<comment>\<open>\<^locale>\<open>M_basic\<close>\<close>

end


(*   This file is a part of IsarMathLib -
    a library of formalized mathematics for Isabelle/Isar.

    Copyright (C) 2008  Seo Sanghyeon

    This program is free software; Redistribution and use in source and binary forms,
    with or without modification, are permitted provided that the following conditions are met:

   1. Redistributions of source code must retain the above copyright notice,
   this list of conditions and the following disclaimer.
   2. Redistributions in binary form must reproduce the above copyright notice,
   this list of conditions and the following disclaimer in the documentation and/or
   other materials provided with the distribution.
   3. The name of the author may not be used to endorse or promote products
   derived from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

*)

section \<open>Order on natural numbers\<close>

theory NatOrder_ZF imports Nat_ZF_IML Order_ZF

begin

text\<open>This theory proves that $\leq$ is a linear order on $\mathbb{N}$.
  $\leq$ is defined in Isabelle's \<open>Nat\<close> theory, and
  linear order is defined in \<open>Order_ZF\<close> theory.
  Contributed by Seo Sanghyeon.\<close>

subsection\<open>Order on natural numbers\<close>

text\<open>This is the only section in this theory.\<close>

text\<open>To prove that $\leq$ is a total order, we use a result on ordinals.\<close>

lemma NatOrder_ZF_1_L1:
  assumes "a\<in>nat" and "b\<in>nat"
  shows "a \<le> b \<or> b \<le> a"
proof -
  from assms have I: "Ord(a) \<and> Ord(b)"
    using nat_into_Ord by auto
  then have "a \<in> b \<or> a = b \<or> b \<in> a"
    using Ord_linear by simp
  with I have "a < b \<or> a = b \<or> b < a"
    using ltI by auto
  with I show "a \<le> b \<or> b \<le> a"
    using le_iff by auto
qed

text\<open>$\leq$ is antisymmetric, transitive, total, and linear. Proofs by
  rewrite using definitions.\<close>

lemma NatOrder_ZF_1_L2:
  shows
  "antisym(Le)"
  "trans(Le)"
  "Le {is total on} nat"
  "IsLinOrder(nat,Le)"
proof -
  show "antisym(Le)"
    using antisym_def Le_def le_anti_sym by auto
  moreover show "trans(Le)"
    using trans_def Le_def le_trans by blast
  moreover show "Le {is total on} nat"
    using IsTotal_def Le_def NatOrder_ZF_1_L1 by simp
  ultimately show "IsLinOrder(nat,Le)"
    using IsLinOrder_def by simp
qed

text\<open>The order on natural numbers is linear on every natural number.
  Recall that each natural number is a subset of the set of
  all natural numbers (as well as a member).\<close>

lemma natord_lin_on_each_nat:
  assumes A1: "n \<in> nat" shows "IsLinOrder(n,Le)"
proof -
  from A1 have "n \<subseteq> nat" using nat_subset_nat
    by simp
  then show ?thesis using NatOrder_ZF_1_L2 ord_linear_subset
    by blast
qed

end


(*
Author: Alexander Katovsky
*)

section "Monadic Equational Theory"

theory MonadicEquationalTheory
imports Category Universe
begin

record ('t,'f) Signature =
  BaseTypes :: "'t set" ("Ty\<index>")
  BaseFunctions :: "'f set" ("Fn\<index>")
  SigDom :: "'f \<Rightarrow> 't" ("sDom\<index>")
  SigCod :: "'f \<Rightarrow> 't" ("sCod\<index>")

locale Signature =
  fixes S :: "('t,'f) Signature" (structure)
  assumes Domt: "f \<in> Fn \<Longrightarrow> sDom f \<in> Ty"
  and     Codt: "f \<in> Fn \<Longrightarrow> sCod f \<in> Ty"

definition funsignature_abbrev ("_ \<in> Sig _ : _ \<rightarrow> _" ) where
  "f \<in> Sig S : A \<rightarrow> B \<equiv> f \<in> (BaseFunctions S) \<and> A \<in> (BaseTypes S) \<and> B \<in> (BaseTypes S) \<and>
                        (SigDom S f) = A \<and> (SigCod S f) = B \<and> Signature S"

lemma funsignature_abbrevE[elim]:
"\<lbrakk>f \<in> Sig S : A \<rightarrow> B ; \<lbrakk>f \<in> (BaseFunctions S) ; A \<in> (BaseTypes S) ; B \<in> (BaseTypes S) ;
                        (SigDom S f) = A ; (SigCod S f) = B ; Signature S\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
by (simp add: funsignature_abbrev_def)

datatype ('t,'f) Expression = ExprVar ("Vx") | ExprApp 'f "('t,'f) Expression" ("_ E@ _")
datatype ('t,'f) Language = Type 't ("\<turnstile> _ Type") | Term 't "('t,'f) Expression" 't ("Vx : _ \<turnstile> _ : _") |
                            Equation 't "('t,'f) Expression" "('t,'f) Expression" 't ("Vx : _ \<turnstile> _\<equiv>_ : _")

inductive
  WellDefined :: "('t,'f) Signature \<Rightarrow> ('t,'f) Language \<Rightarrow> bool" ("Sig _ \<triangleright> _") where
    WellDefinedTy: "A \<in> BaseTypes S \<Longrightarrow> Sig S \<triangleright> \<turnstile> A Type"
  | WellDefinedVar: "Sig S \<triangleright> \<turnstile> A Type \<Longrightarrow> Sig S \<triangleright> (Vx : A  \<turnstile> Vx : A)"
  | WellDefinedFn: "\<lbrakk>Sig S \<triangleright> (Vx : A  \<turnstile> e : B)  ; f \<in> Sig S : B \<rightarrow> C\<rbrakk> \<Longrightarrow> Sig S \<triangleright> (Vx : A  \<turnstile> (f E@ e) : C)"
  | WellDefinedEq: "\<lbrakk>Sig S \<triangleright> (Vx : A  \<turnstile> e1 : B) ; Sig S \<triangleright> (Vx : A  \<turnstile> e2 : B)\<rbrakk> \<Longrightarrow> Sig S \<triangleright> (Vx : A \<turnstile> e1 \<equiv> e2 : B)"

lemmas WellDefined.intros [intro]
inductive_cases WellDefinedTyE [elim!]: "Sig S \<triangleright> \<turnstile> A Type"
inductive_cases WellDefinedVarE [elim!]: "Sig S \<triangleright> (Vx : A  \<turnstile> Vx : A)"
inductive_cases WellDefinedFnE [elim!]: "Sig S \<triangleright> (Vx : A  \<turnstile> (f E@ e) : C)"
inductive_cases WellDefinedEqE [elim!]: "Sig S \<triangleright> (Vx : A \<turnstile> e1 \<equiv> e2 : B)"

lemma SigId: "Sig S \<triangleright> (Vx : A  \<turnstile> Vx : B) \<Longrightarrow> A = B"
apply(rule WellDefined.cases)
by simp+

lemma SigTyId: "Sig S \<triangleright> (Vx : A  \<turnstile> Vx : A) \<Longrightarrow> A \<in> BaseTypes S"
apply(rule WellDefined.cases)
by auto

lemma (in Signature) SigTy: "\<And> B . Sig S \<triangleright> (Vx : A  \<turnstile> e : B) \<Longrightarrow> (A \<in> BaseTypes S \<and> B \<in> BaseTypes S)"
proof(induct e)
  {
    fix B assume a: "Sig S \<triangleright> Vx : A \<turnstile> Vx : B"
    have "A = B" using a SigId[of S] by simp
    thus "A \<in> Ty \<and> B \<in> Ty" using a by auto
  }
  {
    fix B f e assume ih: "\<And>B'. Sig S \<triangleright> (Vx : A \<turnstile> e : B') \<Longrightarrow> A \<in> Ty \<and> B' \<in> Ty"
    and a: "Sig S \<triangleright> (Vx : A \<turnstile> (f E@ e) : B)"
    from a obtain B' where f: "f \<in> Sig S : B' \<rightarrow> B" and "Sig S \<triangleright> (Vx : A \<turnstile> e : B')" by auto
    hence "A \<in> Ty" using ih by auto
    moreover have "B \<in> Ty" using f by (auto simp add: funsignature_abbrev_def Codt)
    ultimately show "A \<in> Ty \<and> B \<in> Ty" by simp
  }
qed

(*An interpretation is an object, a morphism or a boolean*)
datatype ('o,'m) IType = IObj 'o | IMor 'm | IBool bool

record ('t,'f,'o,'m) Interpretation =
  ISignature :: "('t,'f) Signature" ("iS\<index>")
  ICategory  :: "('o,'m) Category"  ("iC\<index>")
  ITypes     :: "'t \<Rightarrow> 'o" ("Ty\<lbrakk>_\<rbrakk>\<index>")
  IFunctions :: "'f \<Rightarrow> 'm" ("Fn\<lbrakk>_\<rbrakk>\<index>")

locale Interpretation =
  fixes I :: "('t,'f,'o,'m) Interpretation" (structure)
  assumes ICat: "Category  iC"
  and     ISig: "Signature iS"
  and     It  : "A \<in> BaseTypes iS \<Longrightarrow> Ty\<lbrakk>A\<rbrakk> \<in> Obj iC"
  and     If  : "(f \<in> Sig iS : A \<rightarrow> B) \<Longrightarrow> Fn\<lbrakk>f\<rbrakk> maps\<^bsub>iC\<^esub> Ty\<lbrakk>A\<rbrakk> to Ty\<lbrakk>B\<rbrakk>"

inductive Interp  ("L\<lbrakk>_\<rbrakk>\<index> \<rightarrow> _") where
    InterpTy: "Sig iS\<^bsub>I\<^esub> \<triangleright> \<turnstile> A Type \<Longrightarrow>
                       L\<lbrakk>\<turnstile> A Type\<rbrakk>\<^bsub>I\<^esub> \<rightarrow> (IObj Ty\<lbrakk>A\<rbrakk>\<^bsub>I\<^esub>)"
  | InterpVar: "L\<lbrakk>\<turnstile> A Type\<rbrakk>\<^bsub>I\<^esub> \<rightarrow> (IObj c) \<Longrightarrow>
                       L\<lbrakk>Vx : A  \<turnstile> Vx : A\<rbrakk>\<^bsub>I\<^esub> \<rightarrow> (IMor (Id iC\<^bsub>I\<^esub> c))"
  | InterpFn: "\<lbrakk>Sig iS\<^bsub>I\<^esub> \<triangleright> Vx : A  \<turnstile> e : B ;
               f \<in> Sig iS\<^bsub>I\<^esub> : B \<rightarrow> C ;
               L\<lbrakk>Vx : A  \<turnstile> e : B\<rbrakk>\<^bsub>I\<^esub> \<rightarrow> (IMor g)\<rbrakk> \<Longrightarrow>
               L\<lbrakk>Vx : A  \<turnstile> (f E@ e) : C\<rbrakk>\<^bsub>I\<^esub> \<rightarrow> (IMor (g ;;\<^bsub>ICategory I\<^esub> Fn\<lbrakk>f\<rbrakk>\<^bsub>I\<^esub>))"
  | InterpEq: "\<lbrakk>L\<lbrakk>Vx : A  \<turnstile> e1 : B\<rbrakk>\<^bsub>I\<^esub> \<rightarrow> (IMor g1) ;
                L\<lbrakk>Vx : A  \<turnstile> e2 : B\<rbrakk>\<^bsub>I\<^esub> \<rightarrow> (IMor g2)\<rbrakk> \<Longrightarrow>
                L\<lbrakk>Vx : A  \<turnstile> e1 \<equiv> e2 : B\<rbrakk>\<^bsub>I\<^esub> \<rightarrow> (IBool (g1 = g2))"

lemmas  Interp.intros [intro]
inductive_cases  InterpTyE [elim!]: "L\<lbrakk>\<turnstile> A Type\<rbrakk>\<^bsub>I\<^esub> \<rightarrow> i"
inductive_cases  InterpVarE [elim!]: "L\<lbrakk>Vx : A  \<turnstile> Vx : A\<rbrakk>\<^bsub>I\<^esub> \<rightarrow> i"
inductive_cases  InterpFnE [elim!]: "L\<lbrakk>Vx : A  \<turnstile> (f E@ e) : C\<rbrakk>\<^bsub>I\<^esub> \<rightarrow> i"
inductive_cases  InterpEqE [elim!]: "L\<lbrakk>Vx : A  \<turnstile> e1 \<equiv> e2 : B\<rbrakk>\<^bsub>I\<^esub> \<rightarrow> i"

lemma (in Interpretation) InterpEqEq[intro]:
  "\<lbrakk>L\<lbrakk>Vx : A  \<turnstile> e1 : B\<rbrakk> \<rightarrow> (IMor g) ; L\<lbrakk>Vx : A  \<turnstile> e2 : B\<rbrakk> \<rightarrow> (IMor g)\<rbrakk> \<Longrightarrow> L\<lbrakk>Vx : A  \<turnstile> e1 \<equiv> e2 : B\<rbrakk> \<rightarrow> (IBool True)"
proof-
  assume a: "L\<lbrakk>Vx : A  \<turnstile> e1 : B\<rbrakk> \<rightarrow> (IMor g)" and b: "L\<lbrakk>Vx : A  \<turnstile> e2 : B\<rbrakk> \<rightarrow> (IMor g)"
  thus ?thesis using InterpEq[of I A e1 B g e2 g] by simp
qed

lemma (in Interpretation) InterpExprWellDefined:
"L\<lbrakk>Vx : A \<turnstile> e : B\<rbrakk> \<rightarrow> i \<Longrightarrow> Sig iS \<triangleright> Vx : A  \<turnstile> e : B"
apply (rule Interp.cases)
by auto

lemma (in Interpretation) WellDefined: "L\<lbrakk>\<phi>\<rbrakk> \<rightarrow> i \<Longrightarrow> Sig iS \<triangleright> \<phi>"
apply(rule Interp.cases)
by (auto simp add: InterpExprWellDefined)

lemma (in Interpretation) FunctionalExpr:
"\<And>i j A B.\<lbrakk>L\<lbrakk>Vx : A \<turnstile> e : B\<rbrakk> \<rightarrow> i; L\<lbrakk>Vx : A \<turnstile> e : B\<rbrakk> \<rightarrow> j\<rbrakk> \<Longrightarrow> i = j"
apply (induct e)
apply (rule Interp.cases)
apply auto
apply (auto simp add: funsignature_abbrev_def)
done

lemma (in Interpretation) Functional: "\<lbrakk>L\<lbrakk>\<phi>\<rbrakk> \<rightarrow> i1 ; L\<lbrakk>\<phi>\<rbrakk> \<rightarrow> i2\<rbrakk> \<Longrightarrow> i1 = i2"
proof(induct \<phi>)
  {
    fix t show "\<lbrakk>L\<lbrakk>\<turnstile> t Type\<rbrakk> \<rightarrow> i1 ; L\<lbrakk>\<turnstile> t Type\<rbrakk> \<rightarrow> i2\<rbrakk> \<Longrightarrow> i1 = i2" by auto
  }
  {
    fix t1 t2 e
    show "\<lbrakk>L\<lbrakk>Vx : t1 \<turnstile> e : t2\<rbrakk> \<rightarrow> i1; L\<lbrakk>Vx : t1 \<turnstile> e : t2\<rbrakk> \<rightarrow> i2\<rbrakk> \<Longrightarrow> i1 = i2" by (simp add: FunctionalExpr)
  }
  {
    fix t1 t2 e1 e2 show "\<lbrakk>L\<lbrakk>Vx : t1 \<turnstile> e1 \<equiv> e2 : t2\<rbrakk> \<rightarrow> i1; L\<lbrakk>Vx : t1 \<turnstile> e1 \<equiv> e2 : t2\<rbrakk> \<rightarrow> i2\<rbrakk> \<Longrightarrow> i1 = i2"
    proof(auto)
      {
        fix f g h assume f1: "L\<lbrakk>Vx : t1 \<turnstile> e1 : t2\<rbrakk> \<rightarrow> (IMor f)" and f2: "L\<lbrakk>Vx : t1 \<turnstile> e2 : t2\<rbrakk> \<rightarrow> (IMor f)"
          and g1: "L\<lbrakk>Vx : t1 \<turnstile> e1 : t2\<rbrakk> \<rightarrow> (IMor g)" and g2: "L\<lbrakk>Vx : t1 \<turnstile> e2 : t2\<rbrakk> \<rightarrow> (IMor h)"
        have "f = g" using f1 g1 FunctionalExpr[of t1 e1 t2 "IMor f" "IMor g"] by simp
        moreover have "f = h" using f2 g2 FunctionalExpr[of t1 e2 t2 "IMor f" "IMor h"] by simp
        ultimately show "g = h" by simp
      }
      moreover
      {
        fix f g h assume f1: "L\<lbrakk>Vx : t1 \<turnstile> e1 : t2\<rbrakk> \<rightarrow> (IMor f)" and f2: "L\<lbrakk>Vx : t1 \<turnstile> e2 : t2\<rbrakk> \<rightarrow> (IMor g)"
          and g1: "L\<lbrakk>Vx : t1 \<turnstile> e1 : t2\<rbrakk> \<rightarrow> (IMor h)" and g2: "L\<lbrakk>Vx : t1 \<turnstile> e2 : t2\<rbrakk> \<rightarrow> (IMor h)"
        have "f = h" using f1 g1 FunctionalExpr[of t1 e1 t2 "IMor f" "IMor h"] by simp
        moreover have "g = h" using f2 g2 FunctionalExpr[of t1 e2 t2 "IMor g" "IMor h"] by simp
        ultimately show "f = g" by simp
      }
    qed
  }
qed

lemma (in Interpretation) MorphismsPreserved:
"\<And> B i . L\<lbrakk>Vx : A  \<turnstile> e : B\<rbrakk> \<rightarrow> i \<Longrightarrow> \<exists> g . i = (IMor g) \<and> (g maps\<^bsub>iC \<^esub>Ty\<lbrakk>A\<rbrakk> to Ty\<lbrakk>B\<rbrakk>)"
proof(induct e)
  {
    fix B i assume a: "L\<lbrakk>Vx : A \<turnstile> Vx : B\<rbrakk> \<rightarrow> i" show "\<exists> g. i = IMor g \<and> g maps\<^bsub>iC\<^esub> Ty\<lbrakk>A\<rbrakk> to Ty\<lbrakk>B\<rbrakk>"
    proof(rule exI[where ?x="Id iC Ty\<lbrakk>A\<rbrakk>"], rule conjI)
      have sig: "Sig iS \<triangleright> Vx : A  \<turnstile> Vx : B" using a by (simp add: InterpExprWellDefined)
      hence aEqb: "A = B" by (simp add: SigId)
      have ty: "A \<in> BaseTypes iS" using aEqb sig SigTyId by simp
      hence "L\<lbrakk>Vx : A \<turnstile> Vx : A\<rbrakk> \<rightarrow> (IMor (Id iC Ty\<lbrakk>A\<rbrakk>))" by auto
      thus "i = IMor (Category.Id iC Ty\<lbrakk>A\<rbrakk>)" using a aEqb Functional by simp
      show "(Id iC Ty\<lbrakk>A\<rbrakk>) maps\<^bsub>iC\<^esub> Ty\<lbrakk>A\<rbrakk> to Ty\<lbrakk>B\<rbrakk>" using aEqb ICat It[of A] Category.Cidm[of iC "Ty\<lbrakk>A\<rbrakk>"] ty by simp
    qed
  }
  {
    fix f e B i assume a: "\<And> B i . L\<lbrakk>Vx : A \<turnstile> e : B\<rbrakk> \<rightarrow> i \<Longrightarrow> \<exists>g. i = IMor g \<and> g maps\<^bsub>iC\<^esub> Ty\<lbrakk>A\<rbrakk> to Ty\<lbrakk>B\<rbrakk>"
               and b: "L\<lbrakk>Vx : A \<turnstile> f E@ e : B\<rbrakk> \<rightarrow> i"
    show "\<exists>g. i = IMor g \<and> g maps\<^bsub>iC\<^esub> Ty\<lbrakk>A\<rbrakk> to Ty\<lbrakk>B\<rbrakk>" using a b
    proof-
      from b obtain g B' where g: "(Sig iS \<triangleright> Vx : A \<turnstile> e : B') \<and> (f \<in> Sig iS : B' \<rightarrow> B) \<and> (L\<lbrakk>Vx : A \<turnstile> e : B'\<rbrakk> \<rightarrow> (IMor g))"
        by auto
      from a have gmaps: "g maps\<^bsub>iC\<^esub> Ty\<lbrakk>A\<rbrakk> to Ty\<lbrakk>B'\<rbrakk>" using g by auto
      have fmaps: "Fn\<lbrakk>f\<rbrakk> maps\<^bsub>iC\<^esub> Ty\<lbrakk>B'\<rbrakk> to Ty\<lbrakk>B\<rbrakk>" using g If by simp
      have "(g ;;\<^bsub>iC\<^esub> Fn\<lbrakk>f\<rbrakk>) maps\<^bsub>iC\<^esub> Ty\<lbrakk>A\<rbrakk> to Ty\<lbrakk>B\<rbrakk>" using ICat fmaps gmaps Category.Ccompt[of "iC" g] by simp
      moreover have "L\<lbrakk>Vx : A \<turnstile> f E@ e : B\<rbrakk> \<rightarrow> (IMor (g ;;\<^bsub>iC\<^esub> Fn\<lbrakk>f\<rbrakk>))" using g by auto
      ultimately show ?thesis using b Functional exI[where ?x = "(g ;;\<^bsub>iC\<^esub> Fn\<lbrakk>f\<rbrakk>)"] by simp
    qed
  }
qed

lemma (in Interpretation) Expr2Mor: "L\<lbrakk>Vx : A  \<turnstile> e : B\<rbrakk> \<rightarrow> (IMor g) \<Longrightarrow> (g maps\<^bsub>iC \<^esub>Ty\<lbrakk>A\<rbrakk> to Ty\<lbrakk>B\<rbrakk>)"
proof-
  assume a: "L\<lbrakk>Vx : A  \<turnstile> e : B\<rbrakk> \<rightarrow> (IMor g)"
  from MorphismsPreserved[of A e B "(IMor g)"] obtain g' where "(IMor g) = (IMor g') \<and> (g' maps\<^bsub>iC \<^esub>Ty\<lbrakk>A\<rbrakk> to Ty\<lbrakk>B\<rbrakk>)"
    using a by auto
  thus ?thesis by simp
qed

lemma (in Interpretation) WellDefinedExprInterp: "\<And> B . (Sig iS \<triangleright> Vx : A  \<turnstile> e : B) \<Longrightarrow> (\<exists> i . L\<lbrakk>Vx : A  \<turnstile> e : B\<rbrakk> \<rightarrow> i)"
proof(induct e)
  {
    fix B assume sig: "(Sig iS \<triangleright> Vx : A  \<turnstile> Vx : B)" show "\<exists>i. L\<lbrakk>Vx : A \<turnstile> Vx : B\<rbrakk> \<rightarrow> i"
    proof-
      have aEqb: "A = B" using sig by (simp add: SigId)
      hence ty: "A \<in> BaseTypes iS" using sig SigTyId by simp
      hence "L\<lbrakk>Vx : A \<turnstile> Vx : A\<rbrakk> \<rightarrow> (IMor (Id iC Ty\<lbrakk>A\<rbrakk>))" by auto
      thus ?thesis using aEqb by auto
    qed
  }
  {
    fix f e B assume a: "\<And> B . (Sig iS \<triangleright> Vx : A  \<turnstile> e : B) \<Longrightarrow> (\<exists> i . L\<lbrakk>Vx : A  \<turnstile> e : B\<rbrakk> \<rightarrow> i)"
      and b: "(Sig iS \<triangleright> Vx : A  \<turnstile> f E@ e : B)"
    show "\<exists> i . L\<lbrakk>Vx : A  \<turnstile> f E@ e : B\<rbrakk> \<rightarrow> i"
    proof-
      from b obtain B' where B': "(Sig iS \<triangleright> (Vx : A  \<turnstile> e : B')) \<and> (f \<in> Sig iS : B' \<rightarrow> B)" by auto
      from B' a obtain i where i: "L\<lbrakk>Vx : A  \<turnstile> e : B'\<rbrakk> \<rightarrow> i" by auto
      from MorphismsPreserved[of A e B' i] i obtain g where g: "i = (IMor g)" by auto
      thus ?thesis using B' i by auto
    qed
  }
qed

lemma (in Interpretation) Sig2Mor: assumes "(Sig iS \<triangleright> Vx : A  \<turnstile> e : B)" shows "\<exists> g . L\<lbrakk>Vx : A  \<turnstile> e : B\<rbrakk> \<rightarrow> (IMor g)"
proof-
  from WellDefinedExprInterp[of A e B] assms obtain i where i: "L\<lbrakk>Vx : A  \<turnstile> e : B\<rbrakk> \<rightarrow> i" by auto
  thus ?thesis using MorphismsPreserved[of A e B i] i by auto
qed

record ('t,'f) Axioms =
  aAxioms :: "('t,'f) Language set"
  aSignature :: "('t,'f) Signature" ("aS\<index>")

locale Axioms =
  fixes Ax :: "('t,'f) Axioms" (structure)
  assumes AxT: "(aAxioms Ax) \<subseteq> {(Vx : A \<turnstile> e1 \<equiv> e2 : B) | A B e1 e2 . Sig (aSignature Ax) \<triangleright> (Vx : A \<turnstile> e1 \<equiv> e2 : B)}"
  assumes AxSig: "Signature (aSignature Ax)"

primrec Subst :: "('t,'f) Expression \<Rightarrow> ('t,'f) Expression \<Rightarrow> ('t,'f) Expression" ("sub _ in _" [81,81] 81) where
  "(sub e in Vx) = e" | "sub e in (f E@ d) = (f E@ (sub e in d))"

lemma SubstXinE: "(sub Vx in e) = e"
by(induct e, auto simp add: Subst_def)

lemma SubstAssoc: "sub a in (sub b in c) = sub (sub a in b) in c"
by(induct c, (simp add: Subst_def)+)

lemma SubstWellDefined: "\<And> C . \<lbrakk>Sig S \<triangleright> (Vx : A \<turnstile> e : B); Sig S \<triangleright> (Vx : B \<turnstile> d : C)\<rbrakk>
       \<Longrightarrow> Sig S \<triangleright> (Vx : A \<turnstile> (sub e in d) : C)"
proof(induct d)
  {
    fix C assume a: "Sig S \<triangleright> Vx : A \<turnstile> e : B" and b: "Sig S \<triangleright> Vx : B \<turnstile> Vx : C"
    have BCeq: "B = C" using b SigId[of S] by simp
    thus "Sig S \<triangleright> Vx : A \<turnstile> sub e in Vx : C" using a by simp
  }
  {
    fix f d C assume ih: "\<And>B'. \<lbrakk>Sig S \<triangleright> Vx : A \<turnstile> e : B; Sig S \<triangleright> Vx : B \<turnstile> d : B'\<rbrakk>
            \<Longrightarrow> Sig S \<triangleright> Vx : A \<turnstile> sub e in d : B'" and a: "Sig S \<triangleright> Vx : A \<turnstile> e : B"
    and b: "Sig S \<triangleright> Vx : B \<turnstile> f E@ d : C"
    from b obtain B' where B': "f \<in> Sig S : B' \<rightarrow> C" and d: "Sig S \<triangleright> Vx : B \<turnstile> d : B'" by auto
    hence "Sig S \<triangleright> Vx : A \<turnstile> sub e in d : B'" using ih a by simp
    hence "Sig S \<triangleright> Vx : A \<turnstile> f E@ (sub e in d) : C" using B' by auto
    thus "Sig S \<triangleright> Vx : A \<turnstile> (sub e in (f E@ d)) : C" by auto
  }
qed

inductive_set (in Axioms) Theory where
  Ax: "A \<in> (aAxioms Ax) \<Longrightarrow> A \<in> Theory"
| Refl: "Sig (aSignature Ax) \<triangleright> (Vx : A \<turnstile> e : B) \<Longrightarrow> (Vx : A \<turnstile> e \<equiv> e : B) \<in> Theory"
| Symm: "(Vx : A \<turnstile> e1 \<equiv> e2 : B) \<in> Theory \<Longrightarrow> (Vx : A \<turnstile> e2 \<equiv> e1 : B) \<in> Theory"
| Trans: "\<lbrakk>(Vx : A \<turnstile> e1 \<equiv> e2 : B) \<in> Theory ; (Vx : A \<turnstile> e2 \<equiv> e3 : B) \<in> Theory\<rbrakk> \<Longrightarrow>
           (Vx : A \<turnstile> e1 \<equiv> e3 : B) \<in> Theory"
| Congr: "\<lbrakk>(Vx : A \<turnstile> e1 \<equiv> e2 : B) \<in> Theory ; f \<in> Sig (aSignature Ax) : B \<rightarrow> C\<rbrakk> \<Longrightarrow>
           (Vx : A \<turnstile> (f E@ e1) \<equiv> (f E@ e2) : C) \<in> Theory"
| Subst: "\<lbrakk>Sig (aSignature Ax) \<triangleright> (Vx : A \<turnstile> e1 : B) ; (Vx : B \<turnstile> e2 \<equiv> e3 : C) \<in> Theory\<rbrakk> \<Longrightarrow>
           (Vx : A \<turnstile> (sub e1 in e2) \<equiv> (sub e1 in e3) : C) \<in> Theory"

lemma (in Axioms) Equiv2WellDefined: "\<phi> \<in> Theory \<Longrightarrow> Sig aS \<triangleright> \<phi>"
proof(rule Theory.induct,auto simp add: SubstWellDefined)
  {
    fix \<phi> assume ax: "\<phi> \<in> aAxioms Ax"
    from AxT obtain A e1 e2 B where "Sig aS \<triangleright> Vx : A \<turnstile> e1 \<equiv> e2 : B" and "\<phi> = Vx : A \<turnstile> e1 \<equiv> e2 : B" using ax by blast
    thus "Sig aS \<triangleright> \<phi>" by simp
  }
qed

lemma (in Axioms) Subst':
  "\<And> C . \<lbrakk>Sig aS \<triangleright> Vx : B \<turnstile> d : C ; (Vx : A \<turnstile> e1 \<equiv> e2 : B) \<in> Theory\<rbrakk> \<Longrightarrow>
  (Vx : A \<turnstile> (sub e1 in d) \<equiv> (sub e2 in d) : C) \<in> Theory"
proof(induct d)
  {
    fix C assume a: "Sig aS \<triangleright> Vx : B \<turnstile> Vx : C" and b: "(Vx : A \<turnstile> e1\<equiv>e2 : B) \<in> Theory"
    have BCeq: "B = C" using a SigId[of aS B C] by simp
    thus "(Vx : A \<turnstile> (sub e1 in Vx) \<equiv> (sub e2 in Vx) : C) \<in> Theory" using b by (simp add: Subst_def)
  }
  {
    fix C f d assume ih: "\<And> B' . \<lbrakk>Sig aS \<triangleright> Vx : B \<turnstile> d : B'; (Vx : A \<turnstile> e1\<equiv>e2 : B) \<in> Theory\<rbrakk>
      \<Longrightarrow> (Vx : A \<turnstile> (sub e1 in d) \<equiv> (sub e2 in d) : B') \<in> Theory" and wd: "Sig aS \<triangleright> Vx : B \<turnstile> f E@ d : C" and
      eq: "(Vx : A \<turnstile> e1 \<equiv> e2 : B) \<in> Theory"
    from wd obtain B' where B': "f \<in> Sig aS : B' \<rightarrow> C" and d: "Sig aS \<triangleright> Vx : B \<turnstile> d : B'" by auto
    hence "(Vx : A \<turnstile> (sub e1 in d) \<equiv> (sub e2 in d) : B') \<in> Theory" using ih eq by simp
    hence "(Vx : A \<turnstile> f E@ (sub e1 in d) \<equiv> f E@ (sub e2 in d) : C) \<in> Theory" using B' by (simp add: Congr)
    thus "(Vx : A \<turnstile> (sub e1 in (f E@ d)) \<equiv> (sub e2 in (f E@ d)) : C) \<in> Theory" by (simp add: Subst_def)
  }
qed

(*This is the diamond problem in multiple inheritance -- both Interpretation and Axioms share a Signature*)
locale Model = Interpretation I + Axioms Ax
  for I :: "('t,'f,'o,'m) Interpretation" (structure)
  and Ax :: "('t,'f) Axioms" +
  assumes AxSound: "\<phi> \<in> (aAxioms Ax) \<Longrightarrow> L\<lbrakk>\<phi>\<rbrakk> \<rightarrow> (IBool True)"
  and Seq[simp]: "(aSignature Ax) = iS"

lemma (in Interpretation) Equiv:
  assumes "L\<lbrakk>Vx : A \<turnstile> e1 \<equiv> e2 : B\<rbrakk> \<rightarrow> (IBool True)"
  shows "\<exists> g . (L\<lbrakk>Vx : A \<turnstile> e1 : B\<rbrakk> \<rightarrow> (IMor g)) \<and> (L\<lbrakk>Vx : A \<turnstile> e2 : B\<rbrakk> \<rightarrow> (IMor g))"
proof-
  from assms Sig2Mor[of A e1 B] obtain g1 where g1: "L\<lbrakk>Vx : A \<turnstile> e1 : B\<rbrakk> \<rightarrow> (IMor g1)" by auto
  from assms Sig2Mor[of A e2 B] obtain g2 where g2: "L\<lbrakk>Vx : A \<turnstile> e2 : B\<rbrakk> \<rightarrow> (IMor g2)" by auto
  have "L\<lbrakk>Vx : A \<turnstile> e1\<equiv>e2 : B\<rbrakk> \<rightarrow> (IBool (g1 = g2))" using g1 g2 by auto
  hence "g1 = g2" using assms Functional[of "Vx : A \<turnstile> e1\<equiv>e2 : B" "(IBool True)" "IBool (g1=g2)"] by simp
  thus ?thesis using g1 g2 by auto
qed

lemma (in Interpretation) SubstComp: "\<And> h C . \<lbrakk>(L\<lbrakk>Vx : A \<turnstile> e : B\<rbrakk> \<rightarrow> (IMor g)) ; (L\<lbrakk>Vx : B \<turnstile> d : C\<rbrakk> \<rightarrow> (IMor h))\<rbrakk> \<Longrightarrow>
  (L\<lbrakk>Vx : A \<turnstile> (sub e in d) : C\<rbrakk> \<rightarrow> (IMor (g ;;\<^bsub>iC\<^esub> h)))"
proof(induct d,auto)
  {
    fix h C assume a: "L\<lbrakk>Vx : A \<turnstile> e : B\<rbrakk> \<rightarrow> IMor g" and b: "L\<lbrakk>Vx : B \<turnstile> Vx : C\<rbrakk> \<rightarrow> (IMor h)"
    show "L\<lbrakk>Vx : A \<turnstile> e : C\<rbrakk> \<rightarrow> IMor (g ;;\<^bsub>iC\<^esub> h)"
    proof-
      have beqc: "B = C" using b SigId[of iS B C] InterpExprWellDefined by simp
      have "L\<lbrakk>Vx : B \<turnstile> Vx : B\<rbrakk> \<rightarrow> (IMor (Id iC Ty\<lbrakk>B\<rbrakk>))" using beqc b by auto
      hence h: "h = Id iC Ty\<lbrakk>B\<rbrakk>" using b beqc by (auto simp add: Functional)
      have "g maps\<^bsub>iC \<^esub>Ty\<lbrakk>A\<rbrakk> to Ty\<lbrakk>B\<rbrakk>" using a MorphismsPreserved by auto
      hence "g \<in> Mor iC" and "cod\<^bsub>iC\<^esub> g = Ty\<lbrakk>B\<rbrakk>" by auto
      hence "(g ;;\<^bsub>iC\<^esub> h) = g" using h ICat Category.Cidr[of iC g] by simp
      thus ?thesis using beqc a by simp
    qed
  }
  {
    fix f d C' h C assume
      i: "\<And> h C' . L\<lbrakk>Vx : B \<turnstile> d : C'\<rbrakk> \<rightarrow> IMor h \<Longrightarrow> L\<lbrakk>Vx : A \<turnstile> (sub e in d) : C'\<rbrakk> \<rightarrow> (IMor (g ;;\<^bsub>iC\<^esub> h))" and
      a: "L\<lbrakk>Vx : A \<turnstile> e : B\<rbrakk> \<rightarrow> IMor g" "f \<in> Sig iS : C' \<rightarrow> C" "L\<lbrakk>Vx : B \<turnstile> d : C'\<rbrakk> \<rightarrow> IMor h"
    show "L\<lbrakk>Vx : A \<turnstile> f E@ (sub e in d) : C\<rbrakk> \<rightarrow> (IMor (g ;;\<^bsub>iC\<^esub> (h ;;\<^bsub>iC\<^esub> Fn\<lbrakk>f\<rbrakk>)))"
    proof-
      have "L\<lbrakk>Vx : A \<turnstile> (sub e in d) : C'\<rbrakk> \<rightarrow> (IMor (g ;;\<^bsub>iC\<^esub> h))" using i a by auto
      moreover hence "Sig iS \<triangleright> Vx : A \<turnstile> (sub e in d) : C'" using InterpExprWellDefined by simp
      ultimately have 1: "L\<lbrakk>Vx : A \<turnstile> f E@ (sub e in d) : C\<rbrakk> \<rightarrow> (IMor ((g ;;\<^bsub>iC\<^esub> h) ;;\<^bsub>iC\<^esub> Fn\<lbrakk>f\<rbrakk>))" using a(2) by auto
      have "g maps\<^bsub>iC\<^esub> Ty\<lbrakk>A\<rbrakk> to Ty\<lbrakk>B\<rbrakk>" and "h maps\<^bsub>iC\<^esub> Ty\<lbrakk>B\<rbrakk> to Ty\<lbrakk>C'\<rbrakk>" and "Fn\<lbrakk>f\<rbrakk> maps\<^bsub>iC\<^esub> Ty\<lbrakk>C'\<rbrakk> to Ty\<lbrakk>C\<rbrakk>"
        using a If Expr2Mor by simp+
      hence "g \<approx>>\<^bsub>iC\<^esub> h" and "h \<approx>>\<^bsub>iC\<^esub> (Fn\<lbrakk>f\<rbrakk>)" using MapsToCompDef[of iC] by simp+
      hence "(g ;;\<^bsub>iC\<^esub> h) ;;\<^bsub>iC\<^esub> Fn\<lbrakk>f\<rbrakk> = g ;;\<^bsub>iC\<^esub> (h ;;\<^bsub>iC\<^esub> Fn\<lbrakk>f\<rbrakk>)" using ICat Category.Cassoc[of iC] by simp
      thus ?thesis using 1 by simp
    qed
  }
qed

lemma (in Model) Sound: "\<phi> \<in> Theory \<Longrightarrow>  L\<lbrakk>\<phi>\<rbrakk> \<rightarrow> (IBool True)"
proof(rule Theory.induct, (simp_all add: AxSound)+)
  {
    fix A e B assume sig: "Sig iS \<triangleright> Vx : A \<turnstile> e : B" show "L\<lbrakk>Vx : A \<turnstile> e\<equiv>e : B\<rbrakk> \<rightarrow> (IBool True)"
    proof-
      from sig Sig2Mor[of A e B] obtain g where g: "L\<lbrakk>Vx : A \<turnstile> e : B\<rbrakk> \<rightarrow> (IMor g)" by auto
      thus ?thesis using InterpEq[of I A e B g e g] by simp
    qed
  }
  {
    fix A e1 e2 B assume a: "L\<lbrakk>Vx : A \<turnstile> e1\<equiv>e2 : B\<rbrakk> \<rightarrow> (IBool True)" show "L\<lbrakk>Vx : A \<turnstile> e2\<equiv>e1 : B\<rbrakk> \<rightarrow> (IBool True)"
    proof-
      from a obtain g where g1: "L\<lbrakk>Vx : A \<turnstile> e1 : B\<rbrakk> \<rightarrow> (IMor g)" and g2: "L\<lbrakk>Vx : A \<turnstile> e2 : B\<rbrakk> \<rightarrow> (IMor g)"
        using Equiv by auto
      thus ?thesis by auto
    qed
  }
  {
    fix A e1 e2 B e3 assume a: "L\<lbrakk>Vx : A \<turnstile> e1\<equiv>e2 : B\<rbrakk> \<rightarrow> (IBool True)" and b: "L\<lbrakk>Vx : A \<turnstile> e2\<equiv>e3 : B\<rbrakk> \<rightarrow> (IBool True)"
    show "L\<lbrakk>Vx : A \<turnstile> e1\<equiv>e3 : B\<rbrakk> \<rightarrow> (IBool True)"
    proof-
      from a obtain g where g1: "L\<lbrakk>Vx : A \<turnstile> e1 : B\<rbrakk> \<rightarrow> (IMor g)" and g2: "L\<lbrakk>Vx : A \<turnstile> e2 : B\<rbrakk> \<rightarrow> (IMor g)"
        using Equiv by auto
      from b obtain g' where g1': "L\<lbrakk>Vx : A \<turnstile> e2 : B\<rbrakk> \<rightarrow> (IMor g')" and g2': "L\<lbrakk>Vx : A \<turnstile> e3 : B\<rbrakk> \<rightarrow> (IMor g')"
        using Equiv by auto
      have eq: "g = g'" using g2 g1' using Functional by auto
      thus ?thesis using eq g1 g2' by auto
    qed
  }
  {
    fix A e1 e2 B f C assume a: "L\<lbrakk>Vx : A \<turnstile> e1\<equiv>e2 : B\<rbrakk> \<rightarrow> (IBool True)" and b: "f \<in> Sig iS : B \<rightarrow> C"
    show "L\<lbrakk>Vx : A \<turnstile> (f E@ e1) \<equiv> (f E@ e2) : C\<rbrakk> \<rightarrow> (IBool True)"
    proof-
      from a obtain g where g1: "L\<lbrakk>Vx : A \<turnstile> e1 : B\<rbrakk> \<rightarrow> (IMor g)" and g2: "L\<lbrakk>Vx : A \<turnstile> e2 : B\<rbrakk> \<rightarrow> (IMor g)"
        using Equiv by auto
      have s1: "Sig iS \<triangleright> Vx : A  \<turnstile> e1 : B" and s2: "Sig iS \<triangleright> Vx : A  \<turnstile> e2 : B" using g1 g2 InterpExprWellDefined by simp+
      have "L\<lbrakk>Vx : A  \<turnstile> (f E@ e1) : C\<rbrakk> \<rightarrow> (IMor (g ;;\<^bsub>iC\<^esub> Fn\<lbrakk>f\<rbrakk>))"
        and "L\<lbrakk>Vx : A  \<turnstile> (f E@ e2) : C\<rbrakk> \<rightarrow> (IMor (g ;;\<^bsub>iC\<^esub> Fn\<lbrakk>f\<rbrakk>))" using b g1 s1 g2 s2 by auto
      thus ?thesis using InterpEqEq[of A "(f E@ e1)" C "(g ;;\<^bsub>iC\<^esub> Fn\<lbrakk>f\<rbrakk>)"] by simp
    qed
  }
  {
    fix A e1 B e2 e3 C assume a: "Sig iS \<triangleright> (Vx : A \<turnstile> e1 : B)" and b: "L\<lbrakk>Vx : B \<turnstile> e2\<equiv>e3 : C\<rbrakk> \<rightarrow> (IBool True)"
    show "L\<lbrakk>Vx : A \<turnstile> (sub e1 in e2) \<equiv> (sub e1 in e3) : C\<rbrakk> \<rightarrow> (IBool True)"
    proof-
      from b obtain g where g1: "L\<lbrakk>Vx : B \<turnstile> e2 : C\<rbrakk> \<rightarrow> (IMor g)" and g2: "L\<lbrakk>Vx : B \<turnstile> e3 : C\<rbrakk> \<rightarrow> (IMor g)"
        using Equiv by auto
      from a Sig2Mor[of A e1 B] obtain f where f: "L\<lbrakk>Vx : A \<turnstile> e1 : B\<rbrakk> \<rightarrow> (IMor f)" by auto
      have "L\<lbrakk>Vx : A \<turnstile> (sub e1 in e2) : C\<rbrakk> \<rightarrow> (IMor (f ;;\<^bsub>iC\<^esub> g))" using SubstComp g1 f by simp
      moreover have "L\<lbrakk>Vx : A \<turnstile> (sub e1 in e3) : C\<rbrakk> \<rightarrow> (IMor (f ;;\<^bsub>iC\<^esub> g))" using SubstComp g2 f by simp
      ultimately show ?thesis using InterpEqEq by simp
    qed
  }
qed

record ('t,'f) TermEquivClT =
  TDomain :: 't
  TExprSet :: "('t,'f) Expression set"
  TCodomain :: 't

locale ZFAxioms = Ax : Axioms Ax for Ax :: "(ZF,ZF) Axioms" (structure) +
  assumes     fnzf: "BaseFunctions (aSignature Ax) \<in> range explode"

(*(tree depth, rule number, components)*)
primrec Expr2ZF :: "(ZF,ZF) Expression \<Rightarrow> ZF" where
    Expr2ZFVx: "Expr2ZF Vx = ZFTriple (nat2Nat 0) (nat2Nat 0) Empty"
  | Expr2ZFfe: "Expr2ZF (f E@ e) = ZFTriple (SucNat (ZFTFst (Expr2ZF e)))
                                 (nat2Nat 1)
                                 (Opair f (Expr2ZF e))"

definition ZF2Expr :: "ZF \<Rightarrow> (ZF,ZF) Expression" where
  "ZF2Expr = inv Expr2ZF"

definition "ZFDepth = Nat2nat o ZFTFst"
definition "ZFType = Nat2nat o ZFTSnd"
definition "ZFData = ZFTThd"

lemma Expr2ZFType0: "ZFType (Expr2ZF e) = 0 \<Longrightarrow> e = Vx"
by(cases e,auto simp add: ZFType_def ZFTSnd Elem_Empty_Nat Elem_SucNat_Nat ZFSucNeq0)

lemma ZFDepthInNat: "Elem (ZFTFst (Expr2ZF e)) Nat"
by(induct e, auto simp add:  ZFTFst HOLZF.Elem_Empty_Nat Elem_SucNat_Nat)

lemma Expr2ZFType1: "ZFType (Expr2ZF e) = 1 \<Longrightarrow>
  \<exists> f e' . e = (f E@ e') \<and> (Suc (ZFDepth (Expr2ZF e'))) = (ZFDepth (Expr2ZF e))"
by(cases e,auto simp add: ZFType_def ZFTSnd ZFDepth_def ZFTFst ZFZero ZFDepthInNat Nat2nat_SucNat)

lemma Expr2ZFDepth0: "ZFDepth (Expr2ZF e) = 0 \<Longrightarrow> ZFType (Expr2ZF e) = 0"
by(cases e, auto simp add: ZFDepth_def ZFTFst ZFType_def ZFTSnd ZFSucNeq0 ZFDepthInNat)

lemma Expr2ZFDepthSuc: "ZFDepth (Expr2ZF e) = Suc n \<Longrightarrow> ZFType (Expr2ZF e) = 1"
by(cases e, auto simp add: ZFDepth_def ZFTFst ZFType_def ZFTSnd ZFSucZero ZFSucNeq0 ZFZero)

lemma Expr2Data: "ZFData (Expr2ZF (f E@ e)) = Opair f (Expr2ZF e)"
by(auto simp add: ZFData_def ZFTThd)

lemma Expr2ZFinj: "inj Expr2ZF"
proof(auto simp add: inj_on_def)
  have a: "\<And> n e d . \<lbrakk>n = ZFDepth (Expr2ZF e) ; Expr2ZF e = Expr2ZF d\<rbrakk> \<Longrightarrow> e = d"
  proof-
    fix n show "\<And> e d . \<lbrakk>n = ZFDepth (Expr2ZF e) ; Expr2ZF e = Expr2ZF d\<rbrakk> \<Longrightarrow> e = d"
    proof(induct n)
      {
        fix e d assume a: "0 = ZFDepth (Expr2ZF e)" and b: "Expr2ZF e = Expr2ZF d"
        have "0 = ZFDepth (Expr2ZF d)" using a b by simp
        hence "e = Vx" and "d = Vx" using a by (simp add: Expr2ZFDepth0 Expr2ZFType0)+
        thus "e = d" by simp
      }
      {
        fix n e d assume ih: "\<And> e' d' . \<lbrakk>n = ZFDepth (Expr2ZF e') ; Expr2ZF e' = Expr2ZF d'\<rbrakk> \<Longrightarrow> e' = d'"
          and a: "Suc n = ZFDepth (Expr2ZF e)" and b: "Expr2ZF e = Expr2ZF d"
        have "ZFType (Expr2ZF e) = 1" and "ZFType (Expr2ZF d) = 1" using a b Expr2ZFDepthSuc[of e n] by simp+
        from this Expr2ZFType1[of e] Expr2ZFType1[of d] obtain fe fd e' d'
          where e: "e = (fe E@ e') \<and> (Suc (ZFDepth (Expr2ZF e'))) = (ZFDepth (Expr2ZF e))" and
          d: "d = (fd E@ d') \<and> (Suc (ZFDepth (Expr2ZF d'))) = (ZFDepth (Expr2ZF d))" by auto
        hence "Suc (ZFDepth (Expr2ZF e')) = Suc n" using a by simp
        hence ne: "(ZFDepth (Expr2ZF e')) = n" by (rule Suc_inject)
        have edat: "ZFData (Expr2ZF e) = Opair fe (Expr2ZF e')" using e Expr2Data by simp
        have ddat: "ZFData (Expr2ZF d) = Opair fd (Expr2ZF d')" using d Expr2Data by simp
        have fd_eq_fe: "fe = fd" and "(Expr2ZF e') = (Expr2ZF d')" using edat ddat Opair b by auto
        hence "e' = d'" using ne ih by auto
        thus "e = d" using e d fd_eq_fe by auto
      }
    qed
  qed
  fix e d show "Expr2ZF e = Expr2ZF d \<Longrightarrow> e = d" using a by auto
qed

definition "TermEquivClGen T A e B \<equiv> {e' . (Vx : A \<turnstile> e' \<equiv> e : B) \<in> Axioms.Theory T}"
definition "TermEquivCl' T A e B \<equiv> \<lparr> TDomain = A , TExprSet = TermEquivClGen T A e B , TCodomain = B\<rparr>"

definition m2ZF :: "(ZF,ZF) TermEquivClT \<Rightarrow> ZF" where
  "m2ZF t \<equiv> ZFTriple (TDomain t) (implode (Expr2ZF ` (TExprSet t))) (TCodomain t)"

definition ZF2m :: "(ZF,ZF) Axioms \<Rightarrow> ZF \<Rightarrow> (ZF,ZF) TermEquivClT" where
  "ZF2m T \<equiv> inv_into {TermEquivCl' T A e B | A e B . True} m2ZF"

lemma TDomain: "TDomain (TermEquivCl' T A e B) = A" by (simp add: TermEquivCl'_def)
lemma TCodomain: "TCodomain (TermEquivCl' T A e B) = B" by (simp add: TermEquivCl'_def)

primrec WellFormedToSet :: "(ZF,ZF) Signature \<Rightarrow> nat \<Rightarrow> (ZF,ZF) Expression set" where
  WFS0: "WellFormedToSet S 0 = {Vx}"
| WFSS: "WellFormedToSet S (Suc n) = (WellFormedToSet S n) \<union>
                { f E@ e | f e . f \<in> BaseFunctions S \<and> e \<in> (WellFormedToSet S n)}"

lemma WellFormedToSetInRangeExplode: "ZFAxioms T \<Longrightarrow> (Expr2ZF ` (WellFormedToSet aS\<^bsub>T\<^esub> n)) \<in> range explode"
proof((induct n),(simp add: WellFormedToSet_def SingletonInRangeExplode))
  fix n assume zfx: "ZFAxioms T" and ih: "ZFAxioms T \<Longrightarrow> Expr2ZF ` WellFormedToSet aS\<^bsub>T\<^esub> n \<in> range explode"
  hence a: "Expr2ZF ` WellFormedToSet aS\<^bsub>T\<^esub> n \<in> range explode" by simp
  have "Expr2ZF ` { f E@ e | f e . f \<in> BaseFunctions aS\<^bsub>T\<^esub> \<and> e \<in> (WellFormedToSet aS\<^bsub>T\<^esub> n)}
    = (\<lambda> (f, ze) . Expr2ZF (f E@ (ZF2Expr ze))) ` ((BaseFunctions aS\<^bsub>T\<^esub>) \<times> Expr2ZF ` (WellFormedToSet aS\<^bsub>T\<^esub> n))"
  proof (auto simp add: image_Collect image_def ZF2Expr_def Expr2ZFinj)
    fix f e
    assume f: "f \<in> BaseFunctions aS\<^bsub>T\<^esub>" and e: "e \<in> WellFormedToSet aS\<^bsub>T\<^esub> n"
    show "\<exists> x \<in> BaseFunctions aS\<^bsub>T\<^esub>.\<exists>y. (\<exists> x \<in> WellFormedToSet aS\<^bsub>T\<^esub> n. y = Expr2ZF x) \<and>
      ZFTriple (SucNat (ZFTFst (Expr2ZF e))) (SucNat Empty) (Opair f (Expr2ZF e)) =
      ZFTriple (SucNat (ZFTFst (Expr2ZF (inv Expr2ZF y)))) (SucNat Empty) (Opair x (Expr2ZF (inv Expr2ZF y)))"
      apply(rule bexI[where ?x = f], rule exI[where ?x = "Expr2ZF e"])
      apply (auto simp add: Expr2ZFinj f e)
      done
    show "\<exists>x. (\<exists>f e. x = f E@ e \<and> f \<in> (BaseFunctions aS\<^bsub>T\<^esub>) \<and> e \<in> WellFormedToSet aS\<^bsub>T\<^esub> n) \<and>
              ZFTriple (SucNat (ZFTFst (Expr2ZF e))) (SucNat Empty) (Opair f (Expr2ZF e)) = Expr2ZF x"
      apply(rule exI[where ?x = "f E@ e"])
      apply (auto simp add: f e)
      done
  qed
  moreover have "(BaseFunctions aS\<^bsub>T\<^esub>) \<in> range explode" using zfx ZFAxioms.fnzf by simp
  ultimately have "Expr2ZF ` { f E@ e | f e . f \<in> BaseFunctions aS\<^bsub>T\<^esub> \<and> e \<in> (WellFormedToSet aS\<^bsub>T\<^esub> n)} \<in> range explode"
    using a ZFProdFnInRangeExplode by simp
  moreover have "Expr2ZF ` WellFormedToSet aS\<^bsub>T\<^esub> (Suc n) = (Expr2ZF ` (WellFormedToSet aS\<^bsub>T\<^esub> n)) \<union>
                (Expr2ZF  ` { f E@ e | f e . f \<in> BaseFunctions aS\<^bsub>T\<^esub> \<and> e \<in> (WellFormedToSet aS\<^bsub>T\<^esub> n)})" by auto
  ultimately show "Expr2ZF ` WellFormedToSet aS\<^bsub>T\<^esub> (Suc n) \<in> range explode" using ZFUnionInRangeExplode a by simp
qed

lemma WellDefinedToWellFormedSet: "\<And> B . (Sig S \<triangleright> (Vx : A \<turnstile> e : B)) \<Longrightarrow> \<exists>n. e \<in> WellFormedToSet S n"
proof(induct e)
  {
    fix B assume "Sig S \<triangleright> Vx : A \<turnstile> Vx : B"
    show "\<exists>n. Vx \<in> WellFormedToSet S n" by (rule exI[of _ 0], auto)
  }
  {
    fix f e B assume ih: "\<And>B'. Sig S \<triangleright> Vx : A \<turnstile> e : B' \<Longrightarrow> \<exists>n. e \<in> WellFormedToSet S n"
      and "Sig S \<triangleright> Vx : A \<turnstile> (f E@ e) : B"
    from this obtain B' where "Sig S \<triangleright> (Vx : A \<turnstile> e : B')" and f: "f \<in> Sig S : B' \<rightarrow> B" by auto
    from this obtain n where a: "e \<in> WellFormedToSet S n" using ih by auto
    have ff: "f \<in> BaseFunctions S" using f by auto
    show "\<exists>n. (f E@ e) \<in> WellFormedToSet S n" by(rule exI[of _ "Suc n"], auto simp add: a ff)
  }
qed

lemma TermSetInSet: "ZFAxioms T \<Longrightarrow> Expr2ZF ` (TermEquivClGen T A e B) \<in> range explode"
proof-
  assume zfax: "ZFAxioms T"
  have "(TermEquivClGen T A e B) \<subseteq> {e' . (Sig aS\<^bsub>T\<^esub> \<triangleright> (Vx : A \<turnstile> e' : B))}"
  proof(auto simp add: TermEquivClGen_def)
    fix x assume "Vx : A \<turnstile> x\<equiv>e : B \<in> Axioms.Theory T"
    hence "Sig aS\<^bsub>T\<^esub> \<triangleright> Vx : A \<turnstile> x\<equiv>e : B" by (auto simp add: Axioms.Equiv2WellDefined zfax)
    thus "Sig aS\<^bsub>T\<^esub> \<triangleright> Vx : A \<turnstile> x : B" by auto
  qed
  also have "... \<subseteq> (\<Union> n . (WellFormedToSet aS\<^bsub>T\<^esub> n))" by (auto simp add: WellDefinedToWellFormedSet)
  finally have "Expr2ZF ` (TermEquivClGen T A e B) \<subseteq> Expr2ZF ` (\<Union> n . (WellFormedToSet aS\<^bsub>T\<^esub> n))" by auto
  also have "... = (\<Union> n . (Expr2ZF ` (WellFormedToSet aS\<^bsub>T\<^esub> n)))" by auto
  finally have "Expr2ZF ` (TermEquivClGen T A e B) \<subseteq> (\<Union> n . (Expr2ZF ` (WellFormedToSet aS\<^bsub>T\<^esub> n)))" by auto
  moreover have "(\<Union> n . (Expr2ZF ` (WellFormedToSet aS\<^bsub>T\<^esub> n))) \<in> range explode"
    using zfax ZFUnionNatInRangeExplode WellFormedToSetInRangeExplode by auto
  ultimately show ?thesis using  ZFSubsetRangeExplode[of
    "(\<Union> n . (Expr2ZF ` (WellFormedToSet aS\<^bsub>T\<^esub> n)))" "Expr2ZF ` (TermEquivClGen T A e B)"] by simp
qed

lemma m2ZFinj_on: "ZFAxioms T \<Longrightarrow> inj_on m2ZF {TermEquivCl' T A e B | A e B . True}"
apply(auto simp only: inj_on_def m2ZF_def)
apply(drule ZFTriple)
apply(auto simp add: TDomain TCodomain implode_def)
apply(simp add: TermEquivCl'_def)
apply(drule inv_into_injective)
apply(auto simp add: TermSetInSet inj_image_eq_iff Expr2ZFinj)
done

lemma ZF2m: "ZFAxioms T \<Longrightarrow> ZF2m T (m2ZF (TermEquivCl' T A e B)) = (TermEquivCl' T A e B)"
proof-
  assume zfax: "ZFAxioms T"
  let ?A = "{TermEquivCl' T A e B | A e B . True}" and ?x = "TermEquivCl' T A e B"
  have "?x \<in> ?A" by auto
  thus ?thesis using m2ZFinj_on[of T] inv_into_f_f zfax by (simp add:  ZF2m_def )
qed

definition TermEquivCl ("[_,_,_]\<index>") where "[A,e,B]\<^bsub>T\<^esub> \<equiv> m2ZF (TermEquivCl' T A e B)"

definition "CLDomain T \<equiv> TDomain o ZF2m T"
definition "CLCodomain T \<equiv> TCodomain o ZF2m T"

definition "CanonicalComp T f g \<equiv>
  THE h . \<exists> e e' . h = [CLDomain T f,sub e in e',CLCodomain T g]\<^bsub>T\<^esub> \<and>
  f = [CLDomain T f,e,CLCodomain T f]\<^bsub>T\<^esub> \<and> g = [CLDomain T g,e',CLCodomain T g]\<^bsub>T\<^esub>"

lemma CLDomain: "ZFAxioms T \<Longrightarrow> CLDomain T [A,e,B]\<^bsub>T\<^esub> = A"  by (simp add: TermEquivCl_def CLDomain_def ZF2m TDomain)
lemma CLCodomain: "ZFAxioms T \<Longrightarrow> CLCodomain T [A,e,B]\<^bsub>T\<^esub> = B"  by (simp add: TermEquivCl_def CLCodomain_def ZF2m TCodomain)

lemma Equiv2Cl: assumes "Axioms T" and "(Vx : A \<turnstile> e \<equiv> d : B) \<in> Axioms.Theory T" shows  "[A,e,B]\<^bsub>T\<^esub> = [A,d,B]\<^bsub>T\<^esub>"
proof-
  have "{e'. (Vx : A \<turnstile> e'\<equiv>e : B) \<in> Axioms.Theory T} = {e'. (Vx : A \<turnstile> e'\<equiv>d : B) \<in> Axioms.Theory T}"
    using assms by(blast intro: Axioms.Trans Axioms.Symm)
  thus ?thesis by(auto simp add: TermEquivCl_def TermEquivCl'_def TermEquivClGen_def)
qed

lemma Cl2Equiv:
  assumes axt: "ZFAxioms T" and sa: "Sig aS\<^bsub>T\<^esub> \<triangleright> (Vx : A \<turnstile> e : B)" and cl: "[A,e,B]\<^bsub>T\<^esub> = [A,d,B]\<^bsub>T\<^esub>"
  shows "(Vx : A \<turnstile> e \<equiv> d : B) \<in> Axioms.Theory T"
proof-
  have "ZF2m T (m2ZF (TermEquivCl' T A e B)) = ZF2m T (m2ZF (TermEquivCl' T A d B))" using cl by (simp add: TermEquivCl_def)
  hence a:"TermEquivCl' T A e B = TermEquivCl' T A d B" using assms by (simp add: ZF2m)
  have "(Vx : A \<turnstile> e \<equiv> e : B) \<in> Axioms.Theory T" using axt sa Axioms.Refl[of T] by simp
  hence "e \<in> TermEquivClGen T A e B" by (simp add: TermEquivClGen_def)
  hence "e \<in> TermEquivClGen T A d B" using a by (simp add: TermEquivCl'_def)
  thus ?thesis by (simp add: TermEquivClGen_def)
qed

lemma CanonicalCompWellDefined:
  assumes zaxt: "ZFAxioms T" and "Sig aS\<^bsub>T\<^esub> \<triangleright> (Vx : A \<turnstile> d : B)" and "Sig aS\<^bsub>T\<^esub> \<triangleright> (Vx : B \<turnstile> d' : C)"
  shows "CanonicalComp T [A,d,B]\<^bsub>T\<^esub> [B,d',C]\<^bsub>T\<^esub> = [A,sub d in d',C]\<^bsub>T\<^esub>"
proof((simp only: zaxt CanonicalComp_def CLDomain CLCodomain),(rule the_equality),
    (rule exI[of _ d], rule exI[of _ d'], auto))
  fix e e' assume de: "[A,d,B]\<^bsub>T\<^esub> = [A,e,B]\<^bsub>T\<^esub>" and de': "[B,d',C]\<^bsub>T\<^esub> = [B,e',C]\<^bsub>T\<^esub>"
  have axt: "Axioms T" using assms by simp
  have a: "(Vx : A \<turnstile> d \<equiv> e : B) \<in> Axioms.Theory T" using assms de Cl2Equiv by simp
  hence sa: "(Vx : A \<turnstile> (sub d in d') \<equiv> (sub e in d') : C) \<in> Axioms.Theory T"
    using assms Axioms.Subst'[of T] by simp
  have b: "(Vx : B \<turnstile> d'\<equiv> e' : C) \<in> Axioms.Theory T" using assms de' Cl2Equiv by simp
  have "Sig aS\<^bsub>T\<^esub> \<triangleright> (Vx : A \<turnstile> d \<equiv> e : B)" using a axt Axioms.Equiv2WellDefined[of T] by simp
  hence "Sig aS\<^bsub>T\<^esub> \<triangleright> (Vx : A \<turnstile> e : B)" by auto
  hence "(Vx : A \<turnstile> (sub e in d') \<equiv> (sub e in e') : C) \<in> Axioms.Theory T" using b Axioms.Subst[of T] axt by simp
  hence "(Vx : A \<turnstile> (sub e in e') \<equiv> (sub d in d') : C) \<in> Axioms.Theory T" using sa axt
    by (blast intro: Axioms.Symm[of T] Axioms.Trans[of T])
  thus "[A,sub e in e',C]\<^bsub>T\<^esub> = [A,sub d in d',C]\<^bsub>T\<^esub>" using zaxt Equiv2Cl by simp
qed

definition "CanonicalCat' T \<equiv> \<lparr>
  Obj = BaseTypes (aS\<^bsub>T\<^esub>),
  Mor = {[A,e,B]\<^bsub>T\<^esub> | A e B . Sig aS\<^bsub>T\<^esub> \<triangleright> (Vx : A \<turnstile> e : B)},
  Dom = CLDomain T,
  Cod = CLCodomain T,
  Id  = (\<lambda> A . [A,Vx,A]\<^bsub>T\<^esub>),
  Comp = CanonicalComp T
  \<rparr>"

definition "CanonicalCat T \<equiv> MakeCat (CanonicalCat' T)"

lemma CanonicalCat'MapsTo:
  assumes "f maps\<^bsub>CanonicalCat' T\<^esub> X to Y" and zx: "ZFAxioms T"
  shows "\<exists> ef . f = [X,ef,Y]\<^bsub>T\<^esub> \<and> Sig (aSignature T) \<triangleright> (Vx : X \<turnstile> ef : Y)"
proof-
  have fm: "f \<in> Mor (CanonicalCat' T)" and fd: "Dom (CanonicalCat' T) f = X" and fc: "Cod (CanonicalCat' T) f = Y"
    using assms by auto
  from fm obtain ef A B where ef: "f = [A,ef,B]\<^bsub>T\<^esub>" and efsig: "Sig (aSignature T) \<triangleright> (Vx : A \<turnstile> ef : B)"
    by (auto simp add: CanonicalCat'_def)
  have "A = X" and "B = Y" using fd fc ef zx CLDomain[of T] CLCodomain[of T]  by (simp add: CanonicalCat'_def)+
  thus ?thesis using ef efsig by auto
qed

lemma CanonicalCatCat': "ZFAxioms T \<Longrightarrow> Category_axioms (CanonicalCat' T)"
proof(auto simp only: Category_axioms_def)
  have obj: "obj\<^bsub>CanonicalCat' T\<^esub> = BaseTypes (aSignature T)" by (simp add: CanonicalCat'_def)
  assume zx: "ZFAxioms T"
  hence axt: "Axioms T" by simp
  {
    fix f assume a: "f \<in> mor\<^bsub>CanonicalCat' T\<^esub>"
    from a obtain A e B where f: "f = [A,e,B]\<^bsub>T\<^esub>" and fwd: "Sig (aSignature T) \<triangleright> (Vx : A \<turnstile> e : B)"
      by (auto simp add: CanonicalCat'_def)
    have domf: "dom\<^bsub>CanonicalCat' T\<^esub> f = CLDomain T f" and codf: "cod\<^bsub>CanonicalCat' T\<^esub> f = CLCodomain T f"
      by (simp add: CanonicalCat'_def)+
    have absig: "A \<in> Ty\<^bsub>aSignature T\<^esub> \<and> B \<in> Ty\<^bsub>aSignature T\<^esub>" using fwd Signature.SigTy[of "(aSignature T)"] Axioms.AxSig axt
      by auto
    have Awd: "Sig (aSignature T) \<triangleright> (Vx : A \<turnstile> Vx : A)" and Bwd: "Sig (aSignature T) \<triangleright> (Vx : B \<turnstile> Vx : B)"
      using absig by auto
    show "dom\<^bsub>CanonicalCat' T\<^esub> f \<in> obj\<^bsub>CanonicalCat' T\<^esub>" using domf f obj CLDomain[of T A e B] absig zx
      by simp
    show "cod\<^bsub>CanonicalCat' T\<^esub> f \<in> obj\<^bsub>CanonicalCat' T\<^esub>" using codf f obj CLCodomain[of T A e B] absig zx
      by simp
    have idA: "Id (CanonicalCat' T) A = [A,Vx,A]\<^bsub>T\<^esub>" and idB: "Id (CanonicalCat' T) B = [B,Vx,B]\<^bsub>T\<^esub>"
      by (simp add: CanonicalCat'_def)+
    have "(Id (CanonicalCat' T) (dom\<^bsub>CanonicalCat' T\<^esub> f)) ;;\<^bsub>CanonicalCat' T\<^esub> f = [A, sub Vx in e, B]\<^bsub>T\<^esub>"
      using f domf CLDomain[of T A e B] idA axt CanonicalCompWellDefined[of T] Awd fwd zx
      by (simp add: CanonicalCat'_def)
    thus "(Id (CanonicalCat' T) (dom\<^bsub>CanonicalCat' T\<^esub> f)) ;;\<^bsub>CanonicalCat' T\<^esub> f = f" using f SubstXinE[of e] by simp
    have "f ;;\<^bsub>CanonicalCat' T\<^esub> (Id (CanonicalCat' T) (cod\<^bsub>CanonicalCat' T\<^esub> f)) = [A, sub e in Vx, B]\<^bsub>T\<^esub>"
      using f codf CLCodomain[of T A e B] idB axt CanonicalCompWellDefined[of T] Bwd fwd zx
      by (simp add: CanonicalCat'_def)
    thus "f ;;\<^bsub>CanonicalCat' T\<^esub> (Id (CanonicalCat' T) (cod\<^bsub>CanonicalCat' T\<^esub> f)) = f" using f Subst_def by simp
  }
  {
    fix X assume a: "X \<in> obj\<^bsub>CanonicalCat' T\<^esub>"
    have "X \<in> BaseTypes (aSignature T)" using a by (simp add: CanonicalCat'_def)
    hence b: "Sig (aSignature T) \<triangleright> (Vx : X \<turnstile> Vx : X)" by auto
    show "Id (CanonicalCat' T) X maps\<^bsub>CanonicalCat' T\<^esub> X to X"
      apply(rule MapsToI)
      apply(auto simp add: CanonicalCat'_def CLDomain CLCodomain zx)
      apply(rule exI)+
      apply(auto simp add: b)
      done
  }
  {
    fix f g h assume a: "f \<approx>>\<^bsub>CanonicalCat' T\<^esub> g" and b: "g \<approx>>\<^bsub>CanonicalCat' T\<^esub> h"
    from a b have fm: "f \<in> Mor (CanonicalCat' T)" and gm: "g \<in> Mor (CanonicalCat' T)"
      and hm: "h \<in> Mor (CanonicalCat' T)" and fg: "Cod (CanonicalCat' T) f = Dom (CanonicalCat' T) g"
      and gh: "Cod (CanonicalCat' T) g = Dom (CanonicalCat' T) h" by auto
    from fm obtain A ef B where f: "f = [A,ef,B]\<^bsub>T\<^esub>" and fwd: "Sig (aSignature T) \<triangleright> (Vx : A \<turnstile> ef : B)"
      by (auto simp add: CanonicalCat'_def)
    from gm obtain B' eg C where g: "g = [B',eg,C]\<^bsub>T\<^esub>" and gwd: "Sig (aSignature T) \<triangleright> (Vx : B' \<turnstile> eg : C)"
      by (auto simp add: CanonicalCat'_def)
    from hm obtain C' eh D where h: "h = [C',eh,D]\<^bsub>T\<^esub>" and hwd: "Sig (aSignature T) \<triangleright> (Vx : C' \<turnstile> eh : D)"
      by (auto simp add: CanonicalCat'_def)
    from fg have Beq: "B = B'" using f g zx CLCodomain[of T A ef B] CLDomain[of T B' eg C] by (simp add: CanonicalCat'_def)
    from gh have Ceq: "C = C'" using g h zx CLCodomain[of T B' eg C] CLDomain[of T C' eh D] by (simp add: CanonicalCat'_def)
    have "CanonicalComp T (CanonicalComp T f g) h = CanonicalComp T f (CanonicalComp T g h)"
    proof-
      have "(CanonicalComp T f g) = [A,sub ef in eg,C]\<^bsub>T\<^esub>"
        using axt fwd gwd Beq zx CanonicalCompWellDefined[of T A ef B eg C] f g by simp
      moreover have "Sig aS\<^bsub>T\<^esub> \<triangleright> Vx : A \<turnstile> sub ef in eg : C" using fwd gwd SubstWellDefined Beq by simp
      ultimately have a: "CanonicalComp T (CanonicalComp T f g) h = [A,(sub (sub ef in eg) in eh),D]\<^bsub>T\<^esub>"
        using CanonicalCompWellDefined[of T A "sub ef in eg" C eh D] axt hwd h Beq Ceq zx by simp
      have "(CanonicalComp T g h) = [B,sub eg in eh,D]\<^bsub>T\<^esub>"
        using axt gwd hwd Ceq Beq CanonicalCompWellDefined[of T B eg C eh D] g h zx by simp
      moreover have "Sig aS\<^bsub>T\<^esub> \<triangleright> Vx : B \<turnstile> sub eg in eh : D" using gwd hwd SubstWellDefined Beq Ceq by simp
      ultimately have b: "CanonicalComp T f (CanonicalComp T g h) = [A,(sub ef in (sub eg in eh)),D]\<^bsub>T\<^esub>"
        using CanonicalCompWellDefined[of T A ef B "sub eg in eh" D] axt fwd f zx by simp
      show ?thesis using a b by (simp add: SubstAssoc)
    qed
    thus "(f ;;\<^bsub>CanonicalCat' T\<^esub> g) ;;\<^bsub>CanonicalCat' T\<^esub> h = f ;;\<^bsub>CanonicalCat' T\<^esub> (g ;;\<^bsub>CanonicalCat' T\<^esub> h)"
      by(simp add: CanonicalCat'_def)
  }
  {
    fix f X Y g Z assume a: "f maps\<^bsub>CanonicalCat' T\<^esub> X to Y" and b: "g maps\<^bsub>CanonicalCat' T\<^esub> Y to Z"
    from a CanonicalCat'MapsTo[of T f X Y] obtain ef
      where f: "f = [X,ef,Y]\<^bsub>T\<^esub>" and fwd: "Sig (aSignature T) \<triangleright> (Vx : X \<turnstile> ef : Y)" using zx by auto
    from b CanonicalCat'MapsTo[of T g Y Z] obtain eg
      where g: "g = [Y,eg,Z]\<^bsub>T\<^esub>" and gwd: "Sig (aSignature T) \<triangleright> (Vx : Y \<turnstile> eg : Z)" using zx by auto
    have fg: "CanonicalComp T f g = [X,sub ef in eg,Z]\<^bsub>T\<^esub>"
      using CanonicalCompWellDefined[of T X ef Y eg Z] f g fwd gwd zx by simp
    have fgwd: "Sig (aSignature T) \<triangleright> (Vx : X \<turnstile> sub ef in eg : Z)"
      using fwd gwd SubstWellDefined[of "aS\<^bsub>T\<^esub>"] by simp
    have "(CanonicalComp T f g) maps\<^bsub>CanonicalCat' T\<^esub> X to Z"
    proof(rule MapsToI)
      show "Dom (CanonicalCat' T) (CanonicalComp T f g) = X"
        using fg CLDomain[of T] zx by (simp add: CanonicalCat'_def)
      show "CanonicalComp T f g \<in> Mor (CanonicalCat' T)" using fg fgwd by (auto simp add: CanonicalCat'_def)
      show "Cod (CanonicalCat' T) (CanonicalComp T f g) = Z"
        using fg CLCodomain[of T] zx by (simp add: CanonicalCat'_def)
    qed
    thus "f ;;\<^bsub>CanonicalCat' T\<^esub> g maps\<^bsub>CanonicalCat' T\<^esub> X to Z" by (simp add: CanonicalCat'_def)
  }
qed

lemma CanonicalCatCat: "ZFAxioms T \<Longrightarrow> Category (CanonicalCat T)"
by (simp add: CanonicalCat_def CanonicalCatCat' MakeCat)

definition CanonicalInterpretation where
"CanonicalInterpretation T \<equiv> \<lparr>
  ISignature = aSignature T,
  ICategory  = CanonicalCat T,
  ITypes     = \<lambda> A . A,
  IFunctions = \<lambda> f . [SigDom (aSignature T) f, f E@ Vx, SigCod (aSignature T) f]\<^bsub>T\<^esub>
\<rparr>"

abbreviation "CI T \<equiv> CanonicalInterpretation T"

lemma CIObj: "Obj (CanonicalCat T) = BaseTypes (aSignature T)"
by (simp add: MakeCat_def CanonicalCat_def CanonicalCat'_def)

lemma CIMor: "ZFAxioms T \<Longrightarrow> [A,e,B]\<^bsub>T\<^esub> \<in> Mor (CanonicalCat T) = Sig (aSignature T) \<triangleright> (Vx : A \<turnstile> e : B)"
proof(auto simp add: MakeCat_def CanonicalCat_def CanonicalCat'_def)
  fix A' e' B' assume zx: "ZFAxioms T" and b: "[A,e,B]\<^bsub>T\<^esub> = [A',e',B']\<^bsub>T\<^esub>" and c: "Sig aS\<^bsub>T\<^esub> \<triangleright> Vx : A' \<turnstile> e' : B'"
  have "CLDomain T [A,e,B]\<^bsub>T\<^esub> = CLDomain T [A',e',B']\<^bsub>T\<^esub>"
    and "CLCodomain T [A,e,B]\<^bsub>T\<^esub> = CLCodomain T [A',e',B']\<^bsub>T\<^esub>" using b by simp+
  hence "A = A'" and "B = B'" by (simp add: CLDomain CLCodomain zx)+
  hence "(Vx : A \<turnstile> e' \<equiv> e : B) \<in> Axioms.Theory T" using zx b c Cl2Equiv[of T A e' B e] by simp
  hence "Sig aS\<^bsub>T\<^esub> \<triangleright> (Vx : A \<turnstile> e' \<equiv> e : B)" using Axioms.Equiv2WellDefined[of T] zx by simp
  thus "Sig aS\<^bsub>T\<^esub> \<triangleright> Vx : A \<turnstile> e : B" by auto
qed

lemma CIDom: "\<lbrakk>ZFAxioms T ; [A,e,B]\<^bsub>T\<^esub> \<in> Mor(CanonicalCat T)\<rbrakk> \<Longrightarrow>  Dom (CanonicalCat T) [A,e,B]\<^bsub>T\<^esub> = A"
proof-
  assume "[A,e,B]\<^bsub>T\<^esub> \<in> Mor(CanonicalCat T)" and "ZFAxioms T"
  thus "Dom (CanonicalCat T) [A,e,B]\<^bsub>T\<^esub> = A"
    by (simp add: CLDomain MakeCatMor CanonicalCat_def MakeCat_def CanonicalCat'_def)
qed

lemma CICod: "\<lbrakk>ZFAxioms T ; [A,e,B]\<^bsub>T\<^esub> \<in> Mor(CanonicalCat T)\<rbrakk> \<Longrightarrow> Cod (CanonicalCat T) [A,e,B]\<^bsub>T\<^esub> = B"
proof-
  assume "[A,e,B]\<^bsub>T\<^esub> \<in> Mor(CanonicalCat T)" and "ZFAxioms T"
  thus "Cod (CanonicalCat T) [A,e,B]\<^bsub>T\<^esub> = B"
    by (simp add: CLCodomain MakeCatMor CanonicalCat_def MakeCat_def CanonicalCat'_def)
qed

lemma CIId: "\<lbrakk>A \<in> BaseTypes (aSignature T)\<rbrakk> \<Longrightarrow> Id (CanonicalCat T) A = [A,Vx,A]\<^bsub>T\<^esub>"
by(simp add: MakeCat_def CanonicalCat_def CanonicalCat'_def)

lemma CIComp:
  assumes "ZFAxioms T" and "Sig (aSignature T) \<triangleright> (Vx : A \<turnstile> e : B)" and "Sig (aSignature T) \<triangleright> (Vx : B \<turnstile> d : C)"
  shows "[A,e,B]\<^bsub>T\<^esub> ;;\<^bsub>CanonicalCat T\<^esub> [B,d,C]\<^bsub>T\<^esub> = [A,sub e in d,C]\<^bsub>T\<^esub>"
proof-
  have "[A,e,B]\<^bsub>T\<^esub> \<approx>>\<^bsub>CanonicalCat' T\<^esub> [B,d,C]\<^bsub>T\<^esub>"
  proof(rule CompDefinedI)
    show "[A,e,B]\<^bsub>T\<^esub> \<in> Mor (CanonicalCat' T)" and "[B,d,C]\<^bsub>T\<^esub> \<in> Mor (CanonicalCat' T)"
      using assms by (auto simp add:  CanonicalCat'_def)
    have "cod\<^bsub>CanonicalCat' T\<^esub> [A,e,B]\<^bsub>T\<^esub> = B" using assms by (simp add: CanonicalCat'_def CLCodomain)
    moreover have "dom\<^bsub>CanonicalCat' T\<^esub> [B,d,C]\<^bsub>T\<^esub> = B" using assms by (simp add: CanonicalCat'_def CLDomain)
    ultimately show "cod\<^bsub>CanonicalCat' T\<^esub> [A,e,B]\<^bsub>T\<^esub> = dom\<^bsub>CanonicalCat' T\<^esub> [B,d,C]\<^bsub>T\<^esub>" by simp
  qed
  hence "[A,e,B]\<^bsub>T\<^esub> ;;\<^bsub>CanonicalCat T\<^esub> [B,d,C]\<^bsub>T\<^esub> = [A,e,B]\<^bsub>T\<^esub> ;;\<^bsub>CanonicalCat' T\<^esub> [B,d,C]\<^bsub>T\<^esub>"
    by (auto simp add: MakeCatComp CanonicalCat_def)
  thus "[A,e,B]\<^bsub>T\<^esub> ;;\<^bsub>CanonicalCat T\<^esub> [B,d,C]\<^bsub>T\<^esub> = [A, sub e in d, C]\<^bsub>T\<^esub>"
    using CanonicalCompWellDefined[of T] assms by (simp add: CanonicalCat'_def)
qed

lemma [simp]: "ZFAxioms T \<Longrightarrow> Category iC\<^bsub>CI T\<^esub>" by(simp add: CanonicalInterpretation_def CanonicalCatCat[of T])
lemma [simp]: "ZFAxioms T \<Longrightarrow> Signature iS\<^bsub>CI T\<^esub>" by(simp add: CanonicalInterpretation_def Axioms.AxSig)

lemma CIInterpretation: "ZFAxioms T \<Longrightarrow> Interpretation (CI T)"
proof(auto simp only: Interpretation_def)
  assume xt: "ZFAxioms T"
  show "Category iC\<^bsub>CI T\<^esub>" and "Signature iS\<^bsub>CI T\<^esub>" using xt by simp+
  {
    fix A assume "A \<in> BaseTypes (iS\<^bsub>CI T\<^esub>)" thus "Ty\<lbrakk>A\<rbrakk>\<^bsub>CI T\<^esub> \<in> Obj (iC\<^bsub>CI T\<^esub>)"
      by(simp add: CanonicalInterpretation_def CIObj[of T])
  }
  {
    fix f A B assume a: "f \<in> Sig iS\<^bsub>CI T\<^esub> : A \<rightarrow> B"
    hence "[sDom\<^bsub>ISignature (CI T)\<^esub> f,f E@ Vx,sCod\<^bsub>ISignature (CI T)\<^esub> f]\<^bsub>T\<^esub> \<in> mor\<^bsub>CanonicalCat T\<^esub>"
      using xt by(auto simp add: CanonicalInterpretation_def CIMor)
    thus "Fn\<lbrakk>f\<rbrakk>\<^bsub>CI T\<^esub> maps\<^bsub>ICategory (CI T) \<^esub>Ty\<lbrakk>A\<rbrakk>\<^bsub>CI T\<^esub> to Ty\<lbrakk>B\<rbrakk>\<^bsub>CI T\<^esub>" using a xt
      by(auto simp add: CanonicalInterpretation_def MapsTo_def funsignature_abbrev_def CIDom CICod)
  }
qed

lemma CIInterp2Mor: "ZFAxioms T \<Longrightarrow> (\<And> B . Sig iS\<^bsub>CI T\<^esub> \<triangleright> (Vx : A \<turnstile> e : B) \<Longrightarrow>  L\<lbrakk>Vx : A \<turnstile> e : B\<rbrakk>\<^bsub>CI T\<^esub> \<rightarrow> (IMor [A, e, B]\<^bsub>T\<^esub>))"
proof(induct e)
  assume xt: "ZFAxioms T"
  {
    fix B assume a: "Sig iS\<^bsub>CI T\<^esub> \<triangleright> Vx : A \<turnstile> Vx : B"
    have aeqb: "A = B" using a SigId[of "iS\<^bsub>CI T\<^esub>" A B] Interpretation.InterpExprWellDefined[of "CI T"] by simp
    moreover have bt: "A \<in> BaseTypes iS\<^bsub>CI T\<^esub>" using a SigTyId aeqb by simp
    ultimately have b: "L\<lbrakk>Vx : A \<turnstile> Vx : B\<rbrakk>\<^bsub>CI T\<^esub> \<rightarrow> (IMor (Id iC\<^bsub>CI T\<^esub> Ty\<lbrakk>A\<rbrakk>\<^bsub>CI T\<^esub>))" by auto
    have "Ty\<lbrakk>A\<rbrakk>\<^bsub>CI T\<^esub> = A" by (simp add: CanonicalInterpretation_def)
    hence "(Id iC\<^bsub>CI T\<^esub> Ty\<lbrakk>A\<rbrakk>\<^bsub>CI T\<^esub>) = [A,Vx,A]\<^bsub>T\<^esub>" using bt CIId by(simp add: CanonicalInterpretation_def)
    thus "L\<lbrakk>Vx : A \<turnstile> Vx : B\<rbrakk>\<^bsub>CI T\<^esub> \<rightarrow> (IMor [A,Vx,B]\<^bsub>T\<^esub>)" using aeqb b by simp
  }
  {
    fix f e B assume ih: "\<And>B'. \<lbrakk>ZFAxioms T ; Sig iS\<^bsub>CI T\<^esub> \<triangleright> (Vx : A \<turnstile> e : B')\<rbrakk> \<Longrightarrow> (L\<lbrakk>Vx : A \<turnstile> e : B'\<rbrakk>\<^bsub>CI T\<^esub> \<rightarrow> (IMor [A,e,B']\<^bsub>T\<^esub>))"
    and a: "Sig iS\<^bsub>CI T\<^esub> \<triangleright> Vx : A \<turnstile> f E@ e : B"
    from a obtain B' where sig: "Sig iS\<^bsub>CI T\<^esub> \<triangleright> (Vx : A \<turnstile> e : B')" and f: "f \<in> Sig iS\<^bsub>CI T\<^esub> : B' \<rightarrow> B" by auto
    hence "L\<lbrakk>Vx : A \<turnstile> e : B'\<rbrakk>\<^bsub>CI T\<^esub> \<rightarrow> (IMor [A,e,B']\<^bsub>T\<^esub>)" using ih xt by auto
    hence b: "L\<lbrakk>Vx : A \<turnstile> f E@ e : B\<rbrakk>\<^bsub>CI T\<^esub> \<rightarrow> (IMor ([A,e,B']\<^bsub>T\<^esub> ;;\<^bsub>ICategory (CI T)\<^esub> Fn\<lbrakk>f\<rbrakk>\<^bsub>CI T\<^esub>))" using sig f by auto
    have "[A,e,B']\<^bsub>T\<^esub> ;;\<^bsub>ICategory (CI T)\<^esub> Fn\<lbrakk>f\<rbrakk>\<^bsub>CI T\<^esub> = [A,f E@ e,B]\<^bsub>T\<^esub>"
    proof-
      have aa: "Fn\<lbrakk>f\<rbrakk>\<^bsub>CI T\<^esub> = [B', f E@ Vx, B]\<^bsub>T\<^esub>" using f by (simp add: CanonicalInterpretation_def funsignature_abbrev_def)
      have "Sig iS\<^bsub>CI T\<^esub> \<triangleright> Vx : A \<turnstile> e : B'" and "Sig iS\<^bsub>CI T\<^esub> \<triangleright> Vx : B' \<turnstile> f E@ Vx : B"  using sig f by auto
      hence "[A,e,B']\<^bsub>T\<^esub> ;;\<^bsub>ICategory (CI T)\<^esub> [B', f E@ Vx, B]\<^bsub>T\<^esub> = [A, sub e in (f E@ Vx), B]\<^bsub>T\<^esub>"
        using CIComp[of T] xt by (simp add: CanonicalInterpretation_def)
      moreover have "sub e in (f E@ Vx) = f E@ e" by (auto simp add: Subst_def)
      ultimately show ?thesis using aa by simp
    qed
    thus "L\<lbrakk>Vx : A \<turnstile> f E@ e : B\<rbrakk>\<^bsub>CI T\<^esub> \<rightarrow> (IMor [A,f E@ e,B]\<^bsub>T\<^esub>)" using b by simp
  }
qed

lemma CIModel: "ZFAxioms T \<Longrightarrow> Model (CI T) T"
proof(auto simp add: Model_def Model_axioms_def )
  assume xt: "ZFAxioms T"
  have axt: "Axioms T" using xt by simp
  show ii: "Interpretation (CI T)" using xt by (simp add: CIInterpretation)
  show aeq: "aS\<^bsub>T\<^esub> = iS\<^bsub>CI T\<^esub>" by (simp add: CanonicalInterpretation_def)
  {
    fix \<phi> assume a: "\<phi> \<in> aAxioms T"
    from a Axioms.AxT obtain A B e d where \<phi>: "\<phi> = Vx : A \<turnstile> e \<equiv> d : B" and sig: "Sig aS\<^bsub>T\<^esub> \<triangleright> Vx : A \<turnstile> e \<equiv> d : B"
      using axt by blast
    have "Sig aS\<^bsub>T\<^esub> \<triangleright> Vx : A \<turnstile> e : B" using sig by auto
    hence e: "L\<lbrakk>Vx : A \<turnstile> e : B\<rbrakk>\<^bsub>CI T\<^esub> \<rightarrow> (IMor [A, e, B]\<^bsub>T\<^esub>)" using aeq CIInterp2Mor xt by simp
    have "Sig aS\<^bsub>T\<^esub> \<triangleright> Vx : A \<turnstile> d : B" using sig by auto
    hence d: "L\<lbrakk>Vx : A \<turnstile> d : B\<rbrakk>\<^bsub>CI T\<^esub> \<rightarrow> (IMor [A, d, B]\<^bsub>T\<^esub>)" using aeq CIInterp2Mor xt by simp
    have "\<phi> \<in> Axioms.Theory T" using a axt by (simp add: Axioms.Theory.Ax)
    hence "[A, e, B]\<^bsub>T\<^esub> = [A, d, B]\<^bsub>T\<^esub>" using \<phi> Equiv2Cl axt by simp
    thus "L\<lbrakk>\<phi>\<rbrakk>\<^bsub>CI T\<^esub> \<rightarrow> (IBool True)" using e d \<phi> ii InterpEq[of "CI T" A e B "[A, e, B]\<^bsub>T\<^esub>" d "[A, d, B]\<^bsub>T\<^esub>"] by simp
  }
qed

lemma CIComplete: assumes "ZFAxioms T" and "L\<lbrakk>\<phi>\<rbrakk>\<^bsub>CI T\<^esub> \<rightarrow> (IBool True)" shows "\<phi> \<in> Axioms.Theory T"
proof-
  have ii: "Interpretation (CI T)" using assms by (simp add: CIInterpretation)
  hence aeq: "aS\<^bsub>T\<^esub> = iS\<^bsub>CI T\<^esub>" by (simp add: CanonicalInterpretation_def)
  from Interpretation.Bool[of "CI T" \<phi> True] obtain A B e d where \<phi>: "\<phi> = (Vx : A \<turnstile> e \<equiv> d : B)" using ii assms by auto
  from Interpretation.Equiv[of "CI T" A e d B] obtain g
    where g1: "L\<lbrakk>Vx : A \<turnstile> e : B\<rbrakk>\<^bsub>CI T\<^esub> \<rightarrow> (IMor g)"
    and   g2: "L\<lbrakk>Vx : A \<turnstile> d : B\<rbrakk>\<^bsub>CI T\<^esub> \<rightarrow> (IMor g)" using ii \<phi> assms by auto
  have ewd: "Sig iS\<^bsub>CI T\<^esub> \<triangleright> (Vx : A \<turnstile> e : B)" and dwd: "Sig iS\<^bsub>CI T\<^esub> \<triangleright> (Vx : A \<turnstile> d : B)"
    using g1 g2 Interpretation.InterpExprWellDefined[of "CI T"] ii by simp+
  have ie: "L\<lbrakk>Vx : A \<turnstile> e : B\<rbrakk>\<^bsub>CI T\<^esub> \<rightarrow> (IMor [A, e, B]\<^bsub>T\<^esub>)" using ewd CIInterp2Mor assms by simp
  have id: "L\<lbrakk>Vx : A \<turnstile> d : B\<rbrakk>\<^bsub>CI T\<^esub> \<rightarrow> (IMor [A, d, B]\<^bsub>T\<^esub>)" using dwd CIInterp2Mor assms by simp
  have "[A, e, B]\<^bsub>T\<^esub> = g"
    using g1 ie ii Interpretation.Functional[of "CI T" "Vx : A \<turnstile> e : B" "IMor [A, e, B]\<^bsub>T\<^esub>" "IMor g"] by simp
  moreover have "[A, d, B]\<^bsub>T\<^esub> = g"
    using g2 id ii Interpretation.Functional[of "CI T" "Vx : A \<turnstile> d : B" "IMor [A, d, B]\<^bsub>T\<^esub>" "IMor g"] by simp
  ultimately have "[A, e, B]\<^bsub>T\<^esub> = [A, d, B]\<^bsub>T\<^esub>" by simp
  thus ?thesis using \<phi> ewd Cl2Equiv aeq assms by simp
qed

lemma Complete:
  assumes "ZFAxioms T"
  and "\<And> (I :: (ZF,ZF,ZF,ZF) Interpretation) . Model I T \<Longrightarrow> (L\<lbrakk>\<phi>\<rbrakk>\<^bsub>I\<^esub> \<rightarrow> (IBool True))"
  shows "\<phi> \<in> Axioms.Theory T"
proof-
  have "Model (CI T) T" using assms CIModel by simp
  thus ?thesis using CIComplete[of T \<phi>] assms by auto
qed

end