section \<open>Environments and Substitution for Quasi-Terms\<close>

theory QuasiTerms_Environments_Substitution
imports QuasiTerms_PickFresh_Alpha
begin

text\<open>Inside this theory, since anyway all the interesting properties hold only
modulo alpha, we forget completely about qAFresh and use only qFresh.\<close>

text\<open>In this section we define, for quasi-terms, parallel substitution according to
{\em environments}.
This is the most general kind of substitution -- an environment, i.e., a partial
map from variables
to quasi-terms, indicates which quasi-term (if any) to be substituted for each
variable; substitution
is then applied to a subject quasi-term and an environment.  In order to ``keep up"
with the notion
of good quasi-term, we define good environments and show that substitution
preserves goodness.  Since,
unlike swapping, substitution does not behave well w.r.t. quasi-terms
(but only w.r.t. terms, i.e., to alpha-equivalence classes),
here we prove the minimum amount of properties required for properly lifting
parallel substitution to terms. Then compositionality properties
of parallel substitution will be proved directly for terms.
\<close>

subsection \<open>Environments\<close>

type_synonym ('index,'bindex,'varSort,'var,'opSym)qEnv =
      "'varSort \<Rightarrow> 'var \<Rightarrow> ('index,'bindex,'varSort,'var,'opSym)qTerm option"

(*********************************************)
context FixVars  (* scope all throughout the file *)
begin

definition qGoodEnv :: "('index,'bindex,'varSort,'var,'opSym)qEnv \<Rightarrow> bool"
where
"qGoodEnv rho ==
 (\<forall> xs. liftAll qGood (rho xs)) \<and>
 (\<forall> ys. |{y. rho ys y \<noteq> None}| <o |UNIV :: 'var set| )"

definition qFreshEnv where
"qFreshEnv zs z rho ==
 rho zs z = None \<and> (\<forall> xs. liftAll (qFresh zs z) (rho xs))"

definition alphaEnv where
"alphaEnv =
 {(rho,rho'). \<forall> xs. sameDom (rho xs) (rho' xs) \<and>
                      liftAll2 (\<lambda>X X'. X #= X') (rho xs) (rho' xs)}"

abbreviation alphaEnv_abbrev ::
"('index,'bindex,'varSort,'var,'opSym)qEnv \<Rightarrow>
 ('index,'bindex,'varSort,'var,'opSym)qEnv \<Rightarrow> bool" (infix "&=" 50)
where
"rho &= rho' == (rho,rho') \<in> alphaEnv"

definition pickQFreshEnv
where
"pickQFreshEnv xs V XS Rho ==
 pickQFresh xs (V \<union> (\<Union> rho \<in> Rho. {x. rho xs x \<noteq> None}))
               (XS \<union> (\<Union> rho \<in> Rho. {X. \<exists> ys y. rho ys y = Some X}))"

lemma qGoodEnv_imp_card_of_qTerm:
assumes "qGoodEnv rho"
shows "|{X. \<exists> y. rho ys y = Some X}| <o |UNIV :: 'var set|"
proof-
  let ?rel = "{(y,X). rho ys y = Some X}"
  let ?Left = "{X. \<exists> y. rho ys y = Some X}"
  let ?Left' = "{y. \<exists> X. rho ys y = Some X}"
  have "\<And> y X X'. (y,X) \<in> ?rel \<and> (y,X') \<in> ?rel \<longrightarrow> X = X'" by force
  hence "|?Left| \<le>o |?Left'|" using card_of_inj_rel[of ?rel] by auto
  moreover have "|?Left'| <o |UNIV :: 'var set|" using assms unfolding qGoodEnv_def by auto
  ultimately show ?thesis using ordLeq_ordLess_trans by blast
qed

lemma qGoodEnv_imp_card_of_qTerm2:
assumes "qGoodEnv rho"
shows "|{X. \<exists> ys y. rho ys y = Some X}| <o |UNIV :: 'var set|"
proof-
  let ?Left = "{X. \<exists> ys y. rho ys y = Some X}"
  let ?F = "\<lambda> ys. {X. \<exists> y. rho ys y = Some X}"
  have "?Left = (\<Union> ys. ?F ys)" by auto
  moreover have "\<forall> ys. |?F ys| <o |UNIV :: 'var set|"
  using assms qGoodEnv_imp_card_of_qTerm by auto
  ultimately show ?thesis
  using var_regular_INNER varSort_lt_var_INNER by(force simp add: regular_UNION)
qed

lemma qGoodEnv_iff:
"qGoodEnv rho =
 ((\<forall> xs. liftAll qGood (rho xs)) \<and>
  (\<forall> ys. |{y. rho ys y \<noteq> None}| <o |UNIV :: 'var set| ) \<and>
  |{X. \<exists> ys y. rho ys y = Some X}| <o |UNIV :: 'var set| )"
unfolding qGoodEnv_def apply auto
apply(rule qGoodEnv_imp_card_of_qTerm2) unfolding qGoodEnv_def by simp

lemma alphaEnv_refl:
"qGoodEnv rho \<Longrightarrow> rho &= rho"
using alpha_refl
unfolding alphaEnv_def qGoodEnv_def liftAll_def liftAll2_def sameDom_def by fastforce

lemma alphaEnv_sym:
"rho &= rho' \<Longrightarrow> rho' &= rho"
using alpha_sym unfolding alphaEnv_def liftAll2_def sameDom_def by fastforce

lemma alphaEnv_trans:
assumes good: "qGoodEnv rho" and
        alpha1: "rho &= rho'" and alpha2: "rho' &= rho''"
shows "rho &= rho''"
using assms unfolding alphaEnv_def
apply(auto)
using sameDom_trans apply blast
unfolding liftAll2_def proof(auto)
  fix xs x X X''
  assume rho: "rho xs x = Some X" and rho'': "rho'' xs x = Some X''"
  moreover have "(rho xs x = None) = (rho' xs x = None)"
  using alpha1 unfolding alphaEnv_def sameDom_def by auto
  ultimately obtain X' where rho': "rho' xs x = Some X'" by auto
  hence "X #= X'" using alpha1 rho unfolding alphaEnv_def liftAll2_def by auto
  moreover have "X' #= X''"
  using alpha2 rho' rho'' unfolding alphaEnv_def liftAll2_def by auto
  moreover have "qGood X" using good rho unfolding qGoodEnv_def liftAll_def by auto
  ultimately show "X #= X''" using alpha_trans by blast
qed

lemma pickQFreshEnv_card_of:
assumes Vvar: "|V| <o |UNIV :: 'var set|" and XSvar: "|XS| <o |UNIV :: 'var set|" and
        good: "\<forall> X \<in> XS. qGood X" and
        Rhovar: "|Rho| <o |UNIV :: 'var set|" and RhoGood: "\<forall> rho \<in> Rho. qGoodEnv rho"
shows
"pickQFreshEnv xs V XS Rho \<notin> V \<and>
 (\<forall> X \<in> XS. qFresh xs (pickQFreshEnv xs V XS Rho) X) \<and>
 (\<forall> rho \<in> Rho. qFreshEnv xs (pickQFreshEnv xs V XS Rho) rho)"
proof-
  let ?z =" pickQFreshEnv xs V XS Rho"
  let ?V2 = "\<Union> rho \<in> Rho. {x. rho xs x \<noteq> None}"  let ?W = "V \<union> ?V2"
  let ?XS2 = "\<Union> rho \<in> Rho. {X. \<exists> ys y. rho ys y = Some X}" let ?YS = "XS \<union> ?XS2"
  have "|?W| <o |UNIV :: 'var set|"
  proof-
    have "\<forall> rho \<in> Rho. |{x. rho xs x \<noteq> None}| <o |UNIV :: 'var set|"
    using RhoGood unfolding qGoodEnv_iff using qGoodEnv_iff by auto
    hence "|?V2| <o |UNIV :: 'var set|"
    using var_regular_INNER Rhovar by (auto simp add: regular_UNION)
    thus ?thesis using var_infinite_INNER Vvar card_of_Un_ordLess_infinite by auto
  qed
  moreover have "|?YS| <o |UNIV :: 'var set|"
  proof-
    have "\<forall> rho \<in> Rho. |{X. \<exists> ys y. rho ys y = Some X}| <o |UNIV :: 'var set|"
    using RhoGood unfolding qGoodEnv_iff by auto
    hence "|?XS2| <o |UNIV :: 'var set|"
    using var_regular_INNER Rhovar by (auto simp add: regular_UNION)
    thus ?thesis using var_infinite_INNER XSvar card_of_Un_ordLess_infinite by auto
  qed
  moreover have "\<forall> Y \<in> ?YS. qGood Y"
  using good RhoGood unfolding qGoodEnv_iff liftAll_def by blast
  ultimately
  have "?z \<notin> ?W \<and> (\<forall> Y \<in> ?YS. qFresh xs ?z Y)"
  unfolding pickQFreshEnv_def using pickQFresh_card_of[of ?W ?YS] by auto
  thus ?thesis unfolding qFreshEnv_def liftAll_def by(auto)
qed

lemma pickQFreshEnv:
assumes Vvar: "|V| <o |UNIV :: 'var set| \<or> finite V"
and XSvar: "|XS| <o |UNIV :: 'var set| \<or> finite XS"
and good: "\<forall> X \<in> XS. qGood X"
and Rhovar: "|Rho| <o |UNIV :: 'var set| \<or> finite Rho"
and RhoGood: "\<forall> rho \<in> Rho. qGoodEnv rho"
shows
"pickQFreshEnv xs V XS Rho \<notin> V \<and>
 (\<forall> X \<in> XS. qFresh xs (pickQFreshEnv xs V XS Rho) X) \<and>
 (\<forall> rho \<in> Rho. qFreshEnv xs (pickQFreshEnv xs V XS Rho) rho)"
proof-
  have 1: "|V| <o |UNIV :: 'var set| \<and> |XS| <o |UNIV :: 'var set| \<and> |Rho| <o |UNIV :: 'var set|"
  using assms var_infinite_INNER by(auto simp add: finite_ordLess_infinite2)
  show ?thesis
  apply(rule pickQFreshEnv_card_of)
  using assms 1 by auto
qed

corollary obtain_qFreshEnv:
fixes XS::"('index,'bindex,'varSort,'var,'opSym)qTerm set" and
      Rho::"('index,'bindex,'varSort,'var,'opSym)qEnv set" and rho
assumes Vvar: "|V| <o |UNIV :: 'var set| \<or> finite V"
and XSvar: "|XS| <o |UNIV :: 'var set| \<or> finite XS"
and good: "\<forall> X \<in> XS. qGood X"
and Rhovar: "|Rho| <o |UNIV :: 'var set| \<or> finite Rho"
and RhoGood: "\<forall> rho \<in> Rho. qGoodEnv rho"
shows
"\<exists> z. z \<notin> V \<and>
 (\<forall> X \<in> XS. qFresh xs z X) \<and> (\<forall> rho \<in> Rho. qFreshEnv xs z rho)"
apply(rule exI[of _ "pickQFreshEnv xs V XS Rho"])
using assms by(rule pickQFreshEnv)

subsection \<open>Parallel substitution\<close>

(* I shall prove only a *minimal* collection of facts for quasi-
[parallel substitution], just enough
  to show that substitution preserves alpha.  The other properties shall be proved
  for alpha-equivalence directly.   *)

definition aux_qPsubst_ignoreFirst ::
"('index,'bindex,'varSort,'var,'opSym)qEnv * ('index,'bindex,'varSort,'var,'opSym)qTerm +
 ('index,'bindex,'varSort,'var,'opSym)qEnv * ('index,'bindex,'varSort,'var,'opSym)qAbs
 \<Rightarrow> ('index,'bindex,'varSort,'var,'opSym)qTermItem"
where
"aux_qPsubst_ignoreFirst K ==
 case K of Inl (rho,X) \<Rightarrow> termIn X
          |Inr (rho,A) \<Rightarrow> absIn A"

lemma aux_qPsubst_ignoreFirst_qTermLessQSwapped_wf:
"wf(inv_image qTermQSwappedLess aux_qPsubst_ignoreFirst)"
using qTermQSwappedLess_wf wf_inv_image by auto

function
qPsubst ::
"('index,'bindex,'varSort,'var,'opSym)qEnv \<Rightarrow> ('index,'bindex,'varSort,'var,'opSym)qTerm \<Rightarrow>
 ('index,'bindex,'varSort,'var,'opSym)qTerm"
and
qPsubstAbs ::
"('index,'bindex,'varSort,'var,'opSym)qEnv \<Rightarrow> ('index,'bindex,'varSort,'var,'opSym)qAbs \<Rightarrow>
 ('index,'bindex,'varSort,'var,'opSym)qAbs"
where
"qPsubst rho (qVar xs x) = (case rho xs x of None \<Rightarrow> qVar xs x| Some X \<Rightarrow> X)"
|
"qPsubst rho (qOp delta inp binp) =
 qOp delta (lift (qPsubst rho) inp) (lift (qPsubstAbs rho) binp)"
|
"qPsubstAbs rho (qAbs xs x X) =
 (let x' = pickQFreshEnv xs {x} {X} {rho} in qAbs xs x' (qPsubst rho (X #[[x' \<and> x]]_xs)))"
by(pat_completeness, auto)
termination
apply(relation "inv_image qTermQSwappedLess aux_qPsubst_ignoreFirst")
apply(simp add: aux_qPsubst_ignoreFirst_qTermLessQSwapped_wf)
by(auto simp add: qTermQSwappedLess_def qTermLess_modulo_def
   aux_qPsubst_ignoreFirst_def qSwap_qSwapped)

abbreviation qPsubst_abbrev ::
"('index,'bindex,'varSort,'var,'opSym)qTerm \<Rightarrow> ('index,'bindex,'varSort,'var,'opSym)qEnv \<Rightarrow>
 ('index,'bindex,'varSort,'var,'opSym)qTerm" ("_ #[[_]]")
where "X #[[rho]] == qPsubst rho X"

abbreviation qPsubstAbs_abbrev ::
"('index,'bindex,'varSort,'var,'opSym)qAbs \<Rightarrow> ('index,'bindex,'varSort,'var,'opSym)qEnv \<Rightarrow>
 ('index,'bindex,'varSort,'var,'opSym)qAbs" ("_ $[[_]]")
where "A $[[rho]] == qPsubstAbs rho A"

lemma qPsubstAll_preserves_qGoodAll:
fixes X::"('index,'bindex,'varSort,'var,'opSym)qTerm" and
      A::"('index,'bindex,'varSort,'var,'opSym)qAbs" and rho
assumes GOOD_ENV: "qGoodEnv rho"
shows
"(qGood X \<longrightarrow> qGood (X #[[rho]])) \<and> (qGoodAbs A \<longrightarrow> qGoodAbs (A $[[rho]]))"
proof(induction rule: qTerm_induct[of _ _ X A])
  case (Var xs x)
  show ?case
  using GOOD_ENV unfolding qGoodEnv_iff liftAll_def
  by(cases "rho xs x", auto)
next
  case (Op delta inp binp)
  show ?case proof safe
    assume g: "qGood (qOp delta inp binp)"
    hence 0: "liftAll qGood (lift (qPsubst rho) inp) \<and>
              liftAll qGoodAbs (lift (qPsubstAbs rho) binp)"
    using Op unfolding liftAll_lift_comp comp_def
    by (simp_all add: Let_def liftAll_mp)
    have "{i. lift (qPsubst rho) inp i \<noteq> None} = {i. inp i \<noteq> None} \<and>
     {i. lift (qPsubstAbs rho) binp i \<noteq> None} = {i. binp i \<noteq> None}"
    by simp (meson lift_Some)
    hence "|{i. \<exists>y. lift (qPsubst rho) inp i = Some y}| <o |UNIV:: 'var set|"
    and "|{i. \<exists>y. lift (qPsubstAbs rho) binp i = Some y}| <o |UNIV:: 'var set|"
    using g by (auto simp: liftAll_def)
    thus "qGood qOp delta inp binp #[[rho]]" using 0 by simp
  qed
next
  case (Abs xs x X)
  show ?case proof safe
    assume g: "qGoodAbs (qAbs xs x X)"
    let ?x' = "pickQFreshEnv xs {x} {X} {rho}"  let ?X' = "X #[[?x' \<and> x]]_xs"
    have "qGood ?X'" using g qSwap_preserves_qGood by auto
    moreover have "(X,?X') \<in> qSwapped" using qSwap_qSwapped by fastforce
    ultimately have "qGood (qPsubst rho ?X')" using Abs.IH by simp
    thus "qGoodAbs ((qAbs xs x X) $[[rho]])" by (simp add: Let_def)
  qed
qed

corollary qPsubst_preserves_qGood:
"\<lbrakk>qGoodEnv rho; qGood X\<rbrakk> \<Longrightarrow> qGood (X #[[rho]])"
using qPsubstAll_preserves_qGoodAll by auto

corollary qPsubstAbs_preserves_qGoodAbs:
"\<lbrakk>qGoodEnv rho; qGoodAbs A\<rbrakk> \<Longrightarrow> qGoodAbs (A $[[rho]])"
using qPsubstAll_preserves_qGoodAll by auto

lemma qPsubstAll_preserves_qFreshAll:
fixes X::"('index,'bindex,'varSort,'var,'opSym)qTerm" and
      A::"('index,'bindex,'varSort,'var,'opSym)qAbs" and rho
assumes GOOD_ENV: "qGoodEnv rho"
shows
"(qFresh zs z X \<longrightarrow>
  (qGood X \<and> qFreshEnv zs z rho \<longrightarrow> qFresh zs z (X #[[rho]]))) \<and>
 (qFreshAbs zs z A \<longrightarrow>
  (qGoodAbs A \<and> qFreshEnv zs z rho \<longrightarrow> qFreshAbs zs z (A $[[rho]])))"
proof(induction rule: qTerm_induct[of _ _ X A])
  case (Var xs x)
  then show ?case
  unfolding qFreshEnv_def liftAll_def by (cases "rho xs x") auto
next
  case (Op delta inp binp)
  thus ?case
  by (auto simp add: lift_def liftAll_def qFreshEnv_def split: option.splits)
next
  case (Abs xs x X)
  show ?case proof safe
    assume q: "qFreshAbs zs z (qAbs xs x X)"
    "qGoodAbs (qAbs xs x X)" "qFreshEnv zs z rho"
    let ?x' = "pickQFreshEnv xs {x} {X} {rho}"  let ?X' = "X #[[?x' \<and> x]]_xs"
    have x': "qFresh xs ?x' X \<and> qFreshEnv xs ?x' rho"
    using q GOOD_ENV by(auto simp add: pickQFreshEnv)
    hence goodX': "qGood ?X'" using q qSwap_preserves_qGood by auto
    have XX': "(X,?X') \<in> qSwapped" using qSwap_qSwapped by fastforce
    have  "(zs = xs \<and> z = ?x') \<or> qFresh zs z (qPsubst rho ?X')"
    by (meson qSwap_preserves_qFresh_distinct
    Abs.IH(1) XX' goodX' q qAbs_alphaAbs_qSwap_qFresh qFreshAbs.simps
    qFreshAbs_preserves_alphaAbs1 qSwap_preserves_qGood2 x')
    thus "qFreshAbs zs z ((qAbs xs x X) $[[rho]])"
    by simp (meson qFreshAbs.simps)+
  qed
qed

lemma qPsubst_preserves_qFresh:
"\<lbrakk>qGood X; qGoodEnv rho; qFresh zs z X; qFreshEnv zs z rho\<rbrakk>
 \<Longrightarrow> qFresh zs z (X #[[rho]])"
by(simp add: qPsubstAll_preserves_qFreshAll)

lemma qPsubstAbs_preserves_qFreshAbs:
"\<lbrakk>qGoodAbs A; qGoodEnv rho; qFreshAbs zs z A; qFreshEnv zs z rho\<rbrakk>
 \<Longrightarrow> qFreshAbs zs z (A $[[rho]])"
by(simp add: qPsubstAll_preserves_qFreshAll)

text\<open>While in general we try to avoid proving facts in parallel,
   here we seem to have no choice -- it is the first time we must use mutual
induction:\<close>

lemma qPsubstAll_preserves_alphaAll_qSwapAll:
fixes X::"('index,'bindex,'varSort,'var,'opSym)qTerm" and
      A::"('index,'bindex,'varSort,'var,'opSym)qAbs" and
      rho::"('index,'bindex,'varSort,'var,'opSym)qEnv"
assumes goodRho: "qGoodEnv rho"
shows
"(qGood X \<longrightarrow>
  (\<forall> Y. X #= Y \<longrightarrow> (X #[[rho]]) #= (Y #[[rho]])) \<and>
  (\<forall> xs z1 z2. qFreshEnv xs z1 rho \<and> qFreshEnv xs z2 rho \<longrightarrow>
               ((X #[[z1 \<and> z2]]_xs) #[[rho]]) #= ((X #[[rho]]) #[[z1 \<and> z2]]_xs))) \<and>
 (qGoodAbs A \<longrightarrow>
  (\<forall> B. A $= B \<longrightarrow> (A $[[rho]]) $= (B $[[rho]])) \<and>
  (\<forall> xs z1 z2. qFreshEnv xs z1 rho \<and> qFreshEnv xs z2 rho \<longrightarrow>
               ((A $[[z1 \<and> z2]]_xs) $[[rho]]) $= ((A $[[rho]]) $[[z1 \<and> z2]]_xs)))"
proof(induction rule: qGood_qTerm_induct_mutual)
  case (Var1 xs x)
  then show ?case
  by (metis alpha_refl goodRho qGood.simps(1) qPsubst_preserves_qGood qVar_alpha_iff)
next
  case (Var2 xs x)
  show ?case proof safe
    fix s::'sort and zs z1 z2
    assume FreshEnv: "qFreshEnv zs z1 rho" "qFreshEnv zs z2 rho"
    hence n: "rho zs z1 = None \<and> rho zs z2 = None" unfolding qFreshEnv_def by simp
    let ?Left = "qPsubst rho ((qVar xs x) #[[z1 \<and> z2]]_zs)"
    let ?Right = "(qPsubst rho (qVar xs x)) #[[z1 \<and> z2]]_zs"
    have "qGood (qVar xs x)" by simp
    hence "qGood ((qVar xs x) #[[z1 \<and> z2]]_zs)"
    using qSwap_preserves_qGood by blast
    hence goodLeft: "qGood ?Left" using goodRho qPsubst_preserves_qGood by blast
    show "?Left #= ?Right"
    proof(cases "rho xs x")
      case None
      hence "rho xs (x @xs[z1 \<and> z2]_zs) = None"
      using n unfolding sw_def by auto
      thus ?thesis using None by simp
    next
      case (Some X)
      hence "xs \<noteq> zs \<or> x \<notin> {z1,z2}" using n by auto
      hence "(x @xs[z1 \<and> z2]_zs) = x" unfolding sw_def by auto
      moreover
      {have "qFresh zs z1 X \<and> qFresh zs z2 X"
       using Some FreshEnv unfolding qFreshEnv_def liftAll_def by auto
       moreover have "qGood X" using Some goodRho unfolding qGoodEnv_def liftAll_def by auto
       ultimately have "X #= (X #[[z1 \<and> z2]]_zs)"
       by(auto simp: alpha_qFresh_qSwap_id alpha_sym)
      }
      ultimately show ?thesis using Some by simp
    qed
  qed
next
  case (Op1 delta inp binp)
  show ?case proof safe
    fix Y assume q: "qOp delta inp binp #= Y"
    then obtain inp' binp' where Y: "Y = qOp delta inp' binp'" and
       *: "(\<forall>i. (inp i = None) = (inp' i = None)) \<and>
           (\<forall>i. (binp i = None) = (binp' i = None))" and
       **: "(\<forall>i X X'. inp i = Some X \<and> inp' i = Some X' \<longrightarrow> X #= X') \<and>
            (\<forall>i A A'. binp i = Some A \<and> binp' i = Some A' \<longrightarrow> A $= A')"
    unfolding qOp_alpha_iff sameDom_def liftAll2_def by auto
    show "(qOp delta inp binp) #[[rho]] #= (Y #[[rho]])"
    using Op1 **
    by (simp add: Y sameDom_def liftAll2_def)
       (fastforce simp add: * lift_None lift_Some
        liftAll_def lift_def split: option.splits)
  qed
next
  case (Op2 delta inp binp)
  thus ?case
  by (auto simp: sameDom_def liftAll2_def lift_None lift_def liftAll_def split: option.splits)
next
  case (Abs1 xs x X)
  show ?case proof safe
    fix B
    assume alpha_xXB: "qAbs xs x X $= B"
    then obtain y Y where B: "B = qAbs xs y Y" unfolding qAbs_alphaAbs_iff by auto
    have "qGoodAbs B" using \<open>qGood X\<close> alpha_xXB alphaAbs_preserves_qGoodAbs by force
    hence goodY: "qGood Y" unfolding B by simp
    let ?x' = "pickQFreshEnv xs {x} {X} {rho}"
    let ?y' = "pickQFreshEnv xs {y} {Y} {rho}"
    obtain x' and y' where x'y'_def: "x' = ?x'" "y' = ?y'" and
           x'y'_rev: "?x' = x'" "?y' = y'" by blast
    have x'y'_freshXY: "qFresh xs x' X \<and> qFresh xs y' Y"
    unfolding x'y'_def using \<open>qGood X\<close> goodY goodRho by (auto simp add: pickQFreshEnv)
    have x'y'_fresh_rho: "qFreshEnv xs x' rho \<and> qFreshEnv xs y' rho"
    unfolding x'y'_def using \<open>qGood X\<close> goodY goodRho by (auto simp add: pickQFreshEnv)
    have x'y'_not_xy: "x' \<noteq> x \<and> y' \<noteq> y"
    unfolding x'y'_def using \<open>qGood X\<close> goodY goodRho
    using pickQFreshEnv[of "{x}" "{X}"] pickQFreshEnv[of "{y}" "{Y}"] by force
    have goodXx'x: "qGood (X #[[x' \<and> x]]_xs)" using \<open>qGood X\<close> qSwap_preserves_qGood by auto
    hence good: "qGood(qPsubst rho (X #[[x' \<and> x]]_xs))"
    using goodRho qPsubst_preserves_qGood by auto
    have goodYy'y: "qGood (Y #[[y' \<and> y]]_xs)" using goodY qSwap_preserves_qGood by auto
    obtain z where z_not: "z \<notin> {x,y,x',y'}" and
    z_fresh_XY: "qFresh xs z X \<and> qFresh xs z Y"
    and z_fresh_rho: "qFreshEnv xs z rho" using \<open>qGood X\<close> goodY goodRho
    using obtain_qFreshEnv[of "{x,y,x',y'}" "{X,Y}" "{rho}"] by auto
    (* Notations: *)
    let ?Xx'x = "X #[[x' \<and> x]]_xs"   let ?Yy'y = "Y #[[y' \<and> y]]_xs"
    let ?Xx'xzx' = "?Xx'x #[[z \<and> x']]_xs" let ?Yy'yzy' = "?Yy'y #[[z \<and> y']]_xs"
    let ?Xzx = "X #[[z \<and> x]]_xs"   let ?Yzy = "Y #[[z \<and> y]]_xs"
    (* Preliminary facts: *)
    have goodXx'x: "qGood ?Xx'x" using \<open>qGood X\<close> qSwap_preserves_qGood by auto
    hence goodXx'xzx': "qGood ?Xx'xzx'" using qSwap_preserves_qGood by auto
    have "qGood (?Xx'x #[[rho]])" using goodXx'x goodRho qPsubst_preserves_qGood by auto
    hence goodXx'x_rho_zx': "qGood ((?Xx'x #[[rho]]) #[[z \<and> x']]_xs)"
    using qSwap_preserves_qGood by auto
    have goodYy'y: "qGood ?Yy'y" using goodY qSwap_preserves_qGood by auto
    (*  *)
    have skelXx'x: "qSkel ?Xx'x = qSkel X" using qSkel_qSwap by fastforce
    hence skelXx'xzx': "qSkel ?Xx'xzx' = qSkel X" by (auto simp add: qSkel_qSwap)
    have "qSkelAbs B = qSkelAbs (qAbs xs x X)"
    using alpha_xXB alphaAll_qSkelAll by fastforce
    hence "qSkel Y = qSkel X" unfolding B by(auto simp add: fun_eq_iff)
    hence skelYy'y: "qSkel ?Yy'y = qSkel X" by(auto simp add: qSkel_qSwap)
    (* Main proof: *)
    have "((?Xx'x #[[rho]]) #[[z \<and> x']]_xs) #= (?Xx'xzx' #[[rho]])"
    using skelXx'x goodXx'x z_fresh_rho x'y'_fresh_rho
          Abs1.IH(2)[of "?Xx'x"] by (auto simp add: alpha_sym)
    moreover
    {have "?Xx'xzx' #= ?Xzx"
     using \<open>qGood X\<close> x'y'_freshXY z_fresh_XY alpha_qFresh_qSwap_compose by fastforce
     moreover have "?Xzx #= ?Yzy" using alpha_xXB unfolding B
     using z_fresh_XY \<open>qGood X\<close> goodY
     by (simp only: alphaAbs_qAbs_iff_all_qFresh)
     moreover have "?Yzy #= ?Yy'yzy'" using goodY x'y'_freshXY z_fresh_XY
     by(auto simp add: alpha_qFresh_qSwap_compose alpha_sym)
     ultimately have "?Xx'xzx' #= ?Yy'yzy'" using goodXx'xzx' alpha_trans by blast
     hence "(?Xx'xzx' #[[rho]]) #= (?Yy'yzy' #[[rho]])"
     using goodXx'xzx' skelXx'xzx' Abs1.IH(1) by auto
    }
    moreover have "(?Yy'yzy' #[[rho]]) #= ((?Yy'y #[[rho]]) #[[z \<and> y']]_xs)"
    using skelYy'y goodYy'y z_fresh_rho x'y'_fresh_rho
          Abs1.IH(2)[of "?Yy'y"] alpha_sym by fastforce
    ultimately
    have "((?Xx'x #[[rho]]) #[[z \<and> x']]_xs) #= ((?Yy'y #[[rho]]) #[[z \<and> y']]_xs)"
    using goodXx'x_rho_zx' alpha_trans by blast
    thus "(qAbs xs x X) $[[rho]] $= (B $[[rho]])"
    unfolding B apply simp unfolding Let_def
    unfolding x'y'_rev
    using good z_not apply(simp only: alphaAbs_qAbs_iff_ex_qFresh)
    by (auto intro!: exI[of _ z]
    simp: alphaAbs_qAbs_iff_ex_qFresh goodRho goodXx'x qPsubstAll_preserves_qFreshAll
    qSwap_preserves_qFresh_distinct z_fresh_XY goodYy'y qPsubst_preserves_qFresh z_fresh_rho)
  qed
next
  case (Abs2 xs x X)
  show ?case proof safe
    fix zs z1 z2
    assume z1z2_fresh_rho: "qFreshEnv zs z1 rho" "qFreshEnv zs z2 rho"
    let ?x' = "pickQFreshEnv xs {x @xs[z1 \<and> z2]_zs} {X #[[z1 \<and> z2]]_zs} {rho}"
    let ?x'' = "pickQFreshEnv xs {x} {X} {rho}"
    obtain x' x'' where x'x''_def: "x' = ?x'" "x'' = ?x''" and
           x'x''_rev: "?x' = x'" "?x'' = x''" by blast
    let ?xa = "x @xs[z1 \<and> z2]_zs"  let ?xa'' = "x'' @xs[z1 \<and> z2]_zs"
    obtain u where "u \<notin> {x,x',x'',z1,z2}" and
    u_fresh_X: "qFresh xs u X" and u_fresh_rho: "qFreshEnv xs u rho"
    using \<open>qGood X\<close> goodRho using obtain_qFreshEnv[of "{x,x',x'',z1,z2}" "{X}" "{rho}"] by auto
    hence u_not: "u \<notin> {x,x',x'',z1,z2,?xa,?xa''}" unfolding sw_def by auto
    let ?ua = "u @xs [z1 \<and> z2]_zs"
    let ?Xz1z2 = "X #[[z1 \<and> z2]]_zs"
      let ?Xz1z2x'xa = "?Xz1z2 #[[x' \<and> ?xa]]_xs"
        let ?Xz1z2x'xa_rho = "?Xz1z2x'xa #[[rho]]"
          let ?Xz1z2x'xa_rho_ux' = "?Xz1z2x'xa_rho #[[u \<and> x']]_xs"
        let ?Xz1z2x'xaux' = "?Xz1z2x'xa #[[u \<and> x']]_xs"
          let ?Xz1z2x'xaux'_rho = "?Xz1z2x'xaux' #[[rho]]"
      let ?Xz1z2uxa = "?Xz1z2 #[[u \<and> ?xa]]_xs"
      let ?Xz1z2uaxa = "?Xz1z2 #[[?ua \<and> ?xa]]_xs"
    let ?Xux = "X #[[u \<and> x]]_xs"
      let ?Xuxz1z2 = "?Xux #[[z1 \<and> z2]]_zs"
    let ?Xx''x = "X #[[x'' \<and> x]]_xs"
      let ?Xx''xux'' = "?Xx''x #[[u \<and> x'']]_xs"
        let ?Xx''xux''z1z2 = "?Xx''xux'' #[[z1 \<and> z2]]_zs"
      let ?Xx''xz1z2 = "?Xx''x #[[z1 \<and> z2]]_zs"
        let ?Xx''xz1z2uaxa'' = "?Xx''xz1z2 #[[?ua \<and> ?xa'']]_xs"
          let ?Xx''xz1z2uaxa''_rho = "?Xx''xz1z2uaxa'' #[[rho]]"
        let ?Xx''xz1z2uxa'' = "?Xx''xz1z2 #[[u \<and> ?xa'']]_xs"
          let ?Xx''xz1z2uxa''_rho = "?Xx''xz1z2uxa'' #[[rho]]"
        let ?Xx''xz1z2_rho = "?Xx''xz1z2 #[[rho]]"
          let ?Xx''xz1z2_rho_uxa'' = "?Xx''xz1z2_rho #[[u \<and> ?xa'']]_xs"
      let ?Xx''x_rho = "?Xx''x #[[rho]]"
        let ?Xx''x_rho_z1z2 = "?Xx''x_rho #[[z1 \<and> z2]]_zs"
          let ?Xx''x_rho_z1z2uxa'' = "?Xx''x_rho_z1z2 #[[u \<and> ?xa'']]_xs"
    (* Facts about x', x'', ?xa, ?ua, ?xa'': *)
    have goodXz1z2: "qGood ?Xz1z2" using \<open>qGood X\<close> qSwap_preserves_qGood by auto
    have x'x''_fresh_Xz1z2: "qFresh xs x' ?Xz1z2 \<and> qFresh xs x'' X"
    unfolding x'x''_def using \<open>qGood X\<close> goodXz1z2 goodRho by (auto simp add: pickQFreshEnv)
    have x'x''_fresh_rho: "qFreshEnv xs x' rho \<and> qFreshEnv xs x'' rho"
    unfolding x'x''_def using \<open>qGood X\<close> goodXz1z2 goodRho by (auto simp add: pickQFreshEnv)
    have ua_eq_u: "?ua = u" using u_not unfolding sw_def by auto
    (* Good: *)
    have goodXz1z2x'xa: "qGood ?Xz1z2x'xa" using goodXz1z2 qSwap_preserves_qGood by auto
    have goodXux: "qGood ?Xux" using \<open>qGood X\<close> qSwap_preserves_qGood by auto
    hence goodXuxz1z2: "qGood ?Xuxz1z2" using qSwap_preserves_qGood by auto
    have goodXx''x: "qGood ?Xx''x" using \<open>qGood X\<close> qSwap_preserves_qGood by auto
    hence goodXx''xz1z2: "qGood ?Xx''xz1z2" using qSwap_preserves_qGood by auto
    hence "qGood ?Xx''xz1z2_rho" using goodRho qPsubst_preserves_qGood by auto
    hence goodXx''xz1z2_rho: "qGood ?Xx''xz1z2_rho"
    using goodRho qPsubst_preserves_qGood by auto
    have goodXz1z2x'xaux': "qGood ?Xz1z2x'xaux'"
    using goodXz1z2x'xa qSwap_preserves_qGood by auto
    have goodXz1z2x'xa_rho: "qGood ?Xz1z2x'xa_rho"
    using goodXz1z2x'xa goodRho qPsubst_preserves_qGood by auto
    hence goodXz1z2x'xa_rho_ux': "qGood ?Xz1z2x'xa_rho_ux'"
    using qSwap_preserves_qGood by auto
    (* Fresh: *)
    have xa''_fresh_rho: "qFreshEnv xs ?xa'' rho"
    using x'x''_fresh_rho z1z2_fresh_rho unfolding sw_def by auto
    have u_fresh_Xz1z2: "qFresh xs u ?Xz1z2"
    using u_fresh_X u_not by(auto simp add: qSwap_preserves_qFresh_distinct)
    hence "qFresh xs u ?Xz1z2x'xa" using u_not by(auto simp add: qSwap_preserves_qFresh_distinct)
    hence u_fresh_Xz1z2x'xa_rho: "qFresh xs u ?Xz1z2x'xa_rho"
    using u_fresh_rho u_fresh_X goodRho goodXz1z2x'xa qPsubst_preserves_qFresh by auto
    have "qFresh xs u ?Xx''x"
    using u_fresh_X u_not by(auto simp add: qSwap_preserves_qFresh_distinct)
    hence "qFresh xs u ?Xx''x_rho" using goodRho goodXx''x u_fresh_rho
    by(auto simp add: qPsubst_preserves_qFresh)
    hence u_fresh_Xx''x_rho_z1z2: "qFresh xs u ?Xx''x_rho_z1z2"
    using u_not by(auto simp add: qSwap_preserves_qFresh_distinct)
    (* Skeleton: *)
    have skel_Xz1z2x'xa: "qSkel ?Xz1z2x'xa = qSkel X" by(auto simp add: qSkel_qSwap)
    hence skel_Xz1z2x'xaux': "qSkel ?Xz1z2x'xaux' = qSkel X" by(auto simp add: qSkel_qSwap)
    have skel_Xx''x: "qSkel ?Xx''x = qSkel X" by(auto simp add: qSkel_qSwap)
    hence skel_Xx''xz1z2: "qSkel ?Xx''xz1z2 = qSkel X" by(auto simp add: qSkel_qSwap)
    (* Main proof: *)
    have "?Xz1z2x'xaux'_rho #= ?Xz1z2x'xa_rho_ux'"
    using x'x''_fresh_rho u_fresh_rho skel_Xz1z2x'xa goodXz1z2x'xa
    using Abs2.IH(2)[of ?Xz1z2x'xa] by auto
    hence "?Xz1z2x'xa_rho_ux' #= ?Xz1z2x'xaux'_rho" using alpha_sym by auto
    moreover
    {have "?Xz1z2x'xaux' #= ?Xz1z2uxa"
     using goodXz1z2 u_fresh_Xz1z2 x'x''_fresh_Xz1z2
     using alpha_qFresh_qSwap_compose by fastforce
     moreover have "?Xz1z2uxa = ?Xuxz1z2"
     using ua_eq_u qSwap_compose[of zs z1 z2 xs x u X] by(auto simp: qSwap_sym)
     moreover
     {have "?Xux #= ?Xx''xux''"
      using \<open>qGood X\<close> u_fresh_X x'x''_fresh_Xz1z2
      by(auto simp: alpha_qFresh_qSwap_compose alpha_sym)
      hence "?Xuxz1z2 #= ?Xx''xux''z1z2"
      using goodXux by (auto simp add: qSwap_preserves_alpha)
     }
     moreover have "?Xx''xux''z1z2 = ?Xx''xz1z2uxa''"
     using ua_eq_u qSwap_compose[of zs z1 z2 _  _ _ ?Xx''x] by auto
     ultimately have "?Xz1z2x'xaux' #= ?Xx''xz1z2uxa''"
     using goodXz1z2x'xaux' alpha_trans by auto
     hence "?Xz1z2x'xaux'_rho #= ?Xx''xz1z2uxa''_rho"
     using goodXz1z2x'xaux' skel_Xz1z2x'xaux' Abs2.IH(1) by auto
    }
    moreover have "?Xx''xz1z2uxa''_rho #= ?Xx''xz1z2_rho_uxa''"
    using xa''_fresh_rho u_fresh_rho skel_Xx''xz1z2 goodXx''xz1z2
    using Abs2.IH(2)[of ?Xx''xz1z2] by auto
    moreover
    {have "?Xx''xz1z2_rho #= ?Xx''x_rho_z1z2"
     using z1z2_fresh_rho skel_Xx''x goodXx''x
     using Abs2.IH(2)[of ?Xx''x] by auto
     hence "?Xx''xz1z2_rho_uxa'' #= ?Xx''x_rho_z1z2uxa''"
     using goodXx''xz1z2_rho by(auto simp add: qSwap_preserves_alpha)
    }
    ultimately have "?Xz1z2x'xa_rho_ux' #= ?Xx''x_rho_z1z2uxa''"
    using goodXz1z2x'xa_rho_ux' alpha_trans by blast
    thus "((qAbs xs x X) $[[z1 \<and> z2]]_zs) $[[rho]] $=
          (((qAbs xs x X) $[[rho]]) $[[z1 \<and> z2]]_zs)"
    using goodXz1z2x'xa_rho
    goodXz1z2x'xa u_not u_fresh_Xz1z2x'xa_rho u_fresh_Xx''x_rho_z1z2
    apply(simp add: Let_def x'x''_rev del: alpha.simps alphaAbs.simps )
    by (auto simp only: Let_def alphaAbs_qAbs_iff_ex_qFresh)
  qed
qed

corollary qPsubst_preserves_alpha1:
assumes "qGoodEnv rho" and "qGood X \<or> qGood Y" and "X #= Y"
shows "(X #[[rho]]) #= (Y #[[rho]])"
using alpha_preserves_qGood assms qPsubstAll_preserves_alphaAll_qSwapAll by blast

corollary qPsubstAbs_preserves_alphaAbs1:
assumes "qGoodEnv rho" and "qGoodAbs A \<or> qGoodAbs B" and "A $= B"
shows "(A $[[rho]]) $= (B $[[rho]])"
using alphaAbs_preserves_qGoodAbs assms qPsubstAll_preserves_alphaAll_qSwapAll by blast

corollary alpha_qFreshEnv_qSwap_qPsubst_commute:
"\<lbrakk>qGoodEnv rho; qGood X; qFreshEnv zs z1 rho; qFreshEnv zs z2 rho\<rbrakk> \<Longrightarrow>
 ((X #[[z1 \<and> z2]]_zs) #[[rho]]) #= ((X #[[rho]]) #[[z1 \<and> z2]]_zs)"
by(simp add: qPsubstAll_preserves_alphaAll_qSwapAll)

corollary alphaAbs_qFreshEnv_qSwapAbs_qPsubstAbs_commute:
"\<lbrakk>qGoodEnv rho; qGoodAbs A;
  qFreshEnv zs z1 rho; qFreshEnv zs z2 rho\<rbrakk> \<Longrightarrow>
 ((A $[[z1 \<and> z2]]_zs) $[[rho]]) $= ((A $[[rho]]) $[[z1 \<and> z2]]_zs)"
by(simp add: qPsubstAll_preserves_alphaAll_qSwapAll)

lemma qPsubstAll_preserves_alphaAll2:
fixes X::"('index,'bindex,'varSort,'var,'opSym)qTerm" and
      A::"('index,'bindex,'varSort,'var,'opSym)qAbs" and
      rho'::"('index,'bindex,'varSort,'var,'opSym)qEnv" and rho''
assumes rho'_alpha_rho'': "rho' &= rho''" and
        goodRho': "qGoodEnv rho'" and goodRho'': "qGoodEnv rho''"
shows
"(qGood X \<longrightarrow> (X #[[rho']]) #= (X #[[rho'']])) \<and>
 (qGoodAbs A \<longrightarrow> (A $[[rho']]) $= (A $[[rho'']]))"
proof(induction rule: qGood_qTerm_induct)
  case (Var xs x)
  then show ?case
  proof (cases "rho' xs x")
    case None
    hence "rho'' xs x = None" using rho'_alpha_rho'' unfolding alphaEnv_def sameDom_def by auto
    thus ?thesis using None by simp
  next
    case (Some X')
    then obtain X'' where rho'': "rho'' xs x = Some X''"
    using assms unfolding alphaEnv_def sameDom_def by force
    hence "X' #= X''" using Some rho'_alpha_rho''
    unfolding alphaEnv_def liftAll2_def by auto
    thus ?thesis using Some rho'' by simp
  qed
next
  case (Op delta inp binp)
  then show ?case
  by (auto simp: lift_def liftAll_def liftAll2_def sameDom_def Let_def
      split: option.splits)
next
  case (Abs xs x X)
  let ?x' = "pickQFreshEnv xs {x} {X} {rho'}"
  let ?x'' = "pickQFreshEnv xs {x} {X} {rho''}"
  obtain x' x'' where x'x''_def: "x' = ?x'" "x'' = ?x''" and
          x'x''_rev: "?x' = x'" "?x'' = x''" by blast
  have x'x''_fresh_X: "qFresh xs x' X \<and> qFresh xs x'' X"
  unfolding x'x''_def using \<open>qGood X\<close> goodRho' goodRho'' by (auto simp add: pickQFreshEnv)
  have x'_fresh_rho': "qFreshEnv xs x' rho'"
  unfolding x'x''_def using \<open>qGood X\<close> goodRho' goodRho'' by (auto simp add: pickQFreshEnv)
  have x''_fresh_rho'': "qFreshEnv xs x'' rho''"
  unfolding x'x''_def using \<open>qGood X\<close> goodRho' goodRho'' by (auto simp add: pickQFreshEnv)
  obtain u where u_not: "u \<notin> {x,x',x''}" and
  u_fresh_X: "qFresh xs u X" and
  u_fresh_rho': "qFreshEnv xs u rho'" and u_fresh_rho'': "qFreshEnv xs u rho''"
  using \<open>qGood X\<close> goodRho' goodRho''
  using obtain_qFreshEnv[of "{x,x',x''}" "{X}" "{rho',rho''}"] by auto
  (* Preliminary facts and notations: *)
  let ?Xx'x = "X #[[x' \<and> x]]_xs"
    let ?Xx'x_rho' = "?Xx'x #[[rho']]"
      let ?Xx'x_rho'_ux' = "?Xx'x_rho' #[[u \<and> x']]_xs"
    let ?Xx'xux' = "?Xx'x #[[u \<and> x']]_xs"
      let ?Xx'xux'_rho' = "?Xx'xux' #[[rho']]"
  let ?Xux = "X #[[u \<and> x]]_xs"
    let ?Xux_rho' = "?Xux #[[rho']]"
    let ?Xux_rho'' = "?Xux #[[rho'']]"
  let ?Xx''x = "X #[[x'' \<and> x]]_xs"
    let ?Xx''xux'' = "?Xx''x #[[u \<and> x'']]_xs"
      let ?Xx''xux''_rho'' = "?Xx''xux'' #[[rho'']]"
    let ?Xx''x_rho'' = "?Xx''x #[[rho'']]"
      let ?Xx''x_rho''_ux'' = "?Xx''x_rho'' #[[u \<and> x'']]_xs"
  (* Good: *)
  have goodXx'x: "qGood ?Xx'x" using \<open>qGood X\<close> qSwap_preserves_qGood by auto
  hence goodXx'x_rho': "qGood ?Xx'x_rho'" using \<open>qGood X\<close> goodRho' qPsubst_preserves_qGood by auto
  hence goodXx'x_rho'_ux': "qGood ?Xx'x_rho'_ux'"
  using \<open>qGood X\<close> qSwap_preserves_qGood by auto
  have goodXx'xux': "qGood ?Xx'xux'" using goodXx'x qSwap_preserves_qGood by auto
  have goodXux: "qGood ?Xux" using \<open>qGood X\<close> qSwap_preserves_qGood by auto
  have goodXx''x: "qGood ?Xx''x" using \<open>qGood X\<close> qSwap_preserves_qGood by auto
  hence goodXx''x_rho'': "qGood ?Xx''x_rho''"
  using \<open>qGood X\<close> goodRho'' qPsubst_preserves_qGood by auto
  (* Fresh: *)
  have "qFresh xs u ?Xx'x" using u_not u_fresh_X
  by(auto simp add: qSwap_preserves_qFresh_distinct)
  hence fresh_Xx'x_rho': "qFresh xs u ?Xx'x_rho'"
  using u_fresh_rho'  goodXx'x goodRho' by(auto simp add: qPsubst_preserves_qFresh)
  have "qFresh xs u ?Xx''x" using u_not u_fresh_X
  by(auto simp add: qSwap_preserves_qFresh_distinct)
  hence fresh_Xx''x_rho'': "qFresh xs u ?Xx''x_rho''"
  using u_fresh_rho''  goodXx''x goodRho'' by(auto simp add: qPsubst_preserves_qFresh)
  (* qSwapped: *)
  have Xux: "(X,?Xux) :qSwapped" by(simp add: qSwap_qSwapped)
  (* Main proof: *)
  have "?Xx'x_rho'_ux' #= ?Xx'xux'_rho'"
  using goodRho' goodXx'x u_fresh_rho' x'_fresh_rho'
  by(auto simp: alpha_qFreshEnv_qSwap_qPsubst_commute alpha_sym)
  moreover
  {have "?Xx'xux' #= ?Xux" using \<open>qGood X\<close> u_fresh_X x'x''_fresh_X
   using alpha_qFresh_qSwap_compose by fastforce
   hence "?Xx'xux'_rho' #= ?Xux_rho'" using goodXx'xux' goodRho'
   using qPsubst_preserves_alpha1 by auto
  }
  moreover have "?Xux_rho' #= ?Xux_rho''" using Xux Abs.IH by auto
  moreover
  {have "?Xux #= ?Xx''xux''" using \<open>qGood X\<close> u_fresh_X x'x''_fresh_X
   by(auto simp add: alpha_qFresh_qSwap_compose alpha_sym)
   hence "?Xux_rho'' #= ?Xx''xux''_rho''" using goodXux goodRho''
   using qPsubst_preserves_alpha1 by auto
  }
  moreover have "?Xx''xux''_rho'' #= ?Xx''x_rho''_ux''"
  using goodRho'' goodXx''x u_fresh_rho'' x''_fresh_rho''
  by(auto simp: alpha_qFreshEnv_qSwap_qPsubst_commute)
  ultimately have "?Xx'x_rho'_ux' #= ?Xx''x_rho''_ux''"
  using goodXx'x_rho'_ux' alpha_trans by blast
  hence "qAbs xs ?x' (qPsubst rho' (X #[[?x' \<and> x]]_xs)) $=
         qAbs xs ?x''(qPsubst rho''(X #[[?x''\<and> x]]_xs))"
  unfolding x'x''_rev using goodXx'x_rho' fresh_Xx'x_rho' fresh_Xx''x_rho''
  by (auto simp only: alphaAbs_qAbs_iff_ex_qFresh)
  thus ?case by (metis qPsubstAbs.simps)
qed

corollary qPsubst_preserves_alpha2:
"\<lbrakk>qGood X; qGoodEnv rho'; qGoodEnv rho''; rho' &= rho''\<rbrakk>
 \<Longrightarrow> (X #[[rho']]) #= (X #[[rho'']])"
by(simp add: qPsubstAll_preserves_alphaAll2)

corollary qPsubstAbs_preserves_alphaAbs2:
"\<lbrakk>qGoodAbs A; qGoodEnv rho'; qGoodEnv rho''; rho' &= rho''\<rbrakk>
 \<Longrightarrow> (A $[[rho']]) $= (A $[[rho'']])"
by(simp add: qPsubstAll_preserves_alphaAll2)

lemma qPsubst_preserves_alpha:
assumes "qGood X \<or> qGood X'" and "qGoodEnv rho" and "qGoodEnv rho'"
and "X #= X'" and "rho &= rho'"
shows "(X #[[rho]]) #= (X' #[[rho']])"
 by (metis (no_types, lifting) assms alpha_trans qPsubst_preserves_alpha1
qPsubst_preserves_alpha2 qPsubst_preserves_qGood)

end  (* context FixVars *)

end


(*  Title:      HOL/Algebra/FiniteProduct.thy
    Author:     Clemens Ballarin, started 19 November 2002

This file is largely based on HOL/Finite_Set.thy.
*)

theory FiniteProduct
imports Group
begin

subsection {* Product Operator for Commutative Monoids *}

subsubsection {* Inductive Definition of a Relation for Products over Sets *}

text {* Instantiation of locale @{text LC} of theory @{text Finite_Set} is not
  possible, because here we have explicit typing rules like
  @{text "x \<in> carrier G"}.  We introduce an explicit argument for the domain
  @{text D}. *}

inductive_set
  foldSetD :: "['a set, 'b => 'a => 'a, 'a] => ('b set * 'a) set"
  for D :: "'a set" and f :: "'b => 'a => 'a" and e :: 'a
  where
    emptyI [intro]: "e \<in> D ==> ({}, e) \<in> foldSetD D f e"
  | insertI [intro]: "[| x ~: A; f x y \<in> D; (A, y) \<in> foldSetD D f e |] ==>
                      (insert x A, f x y) \<in> foldSetD D f e"

inductive_cases empty_foldSetDE [elim!]: "({}, x) \<in> foldSetD D f e"

definition
  foldD :: "['a set, 'b => 'a => 'a, 'a, 'b set] => 'a"
  where "foldD D f e A = (THE x. (A, x) \<in> foldSetD D f e)"

lemma foldSetD_closed:
  "[| (A, z) \<in> foldSetD D f e ; e \<in> D; !!x y. [| x \<in> A; y \<in> D |] ==> f x y \<in> D
      |] ==> z \<in> D"
  by (erule foldSetD.cases) auto

lemma Diff1_foldSetD:
  "[| (A - {x}, y) \<in> foldSetD D f e; x \<in> A; f x y \<in> D |] ==>
   (A, f x y) \<in> foldSetD D f e"
  apply (erule insert_Diff [THEN subst], rule foldSetD.intros)
    apply auto
  done

lemma foldSetD_imp_finite [simp]: "(A, x) \<in> foldSetD D f e ==> finite A"
  by (induct set: foldSetD) auto

lemma finite_imp_foldSetD:
  "[| finite A; e \<in> D; !!x y. [| x \<in> A; y \<in> D |] ==> f x y \<in> D |] ==>
   EX x. (A, x) \<in> foldSetD D f e"
proof (induct set: finite)
  case empty then show ?case by auto
next
  case (insert x F)
  then obtain y where y: "(F, y) \<in> foldSetD D f e" by auto
  with insert have "y \<in> D" by (auto dest: foldSetD_closed)
  with y and insert have "(insert x F, f x y) \<in> foldSetD D f e"
    by (intro foldSetD.intros) auto
  then show ?case ..
qed

text {* Left-Commutative Operations *}

locale LCD =
  fixes B :: "'b set"
  and D :: "'a set"
  and f :: "'b => 'a => 'a"    (infixl "\<cdot>" 70)
  assumes left_commute:
    "[| x \<in> B; y \<in> B; z \<in> D |] ==> x \<cdot> (y \<cdot> z) = y \<cdot> (x \<cdot> z)"
  and f_closed [simp, intro!]: "!!x y. [| x \<in> B; y \<in> D |] ==> f x y \<in> D"

lemma (in LCD) foldSetD_closed [dest]:
  "(A, z) \<in> foldSetD D f e ==> z \<in> D"
  by (erule foldSetD.cases) auto

lemma (in LCD) Diff1_foldSetD:
  "[| (A - {x}, y) \<in> foldSetD D f e; x \<in> A; A \<subseteq> B |] ==>
  (A, f x y) \<in> foldSetD D f e"
  apply (subgoal_tac "x \<in> B")
   prefer 2 apply fast
  apply (erule insert_Diff [THEN subst], rule foldSetD.intros)
    apply auto
  done

lemma (in LCD) foldSetD_imp_finite [simp]:
  "(A, x) \<in> foldSetD D f e ==> finite A"
  by (induct set: foldSetD) auto

lemma (in LCD) finite_imp_foldSetD:
  "[| finite A; A \<subseteq> B; e \<in> D |] ==> EX x. (A, x) \<in> foldSetD D f e"
proof (induct set: finite)
  case empty then show ?case by auto
next
  case (insert x F)
  then obtain y where y: "(F, y) \<in> foldSetD D f e" by auto
  with insert have "y \<in> D" by auto
  with y and insert have "(insert x F, f x y) \<in> foldSetD D f e"
    by (intro foldSetD.intros) auto
  then show ?case ..
qed

lemma (in LCD) foldSetD_determ_aux:
  "e \<in> D ==> \<forall>A x. A \<subseteq> B & card A < n --> (A, x) \<in> foldSetD D f e -->
    (\<forall>y. (A, y) \<in> foldSetD D f e --> y = x)"
  apply (induct n)
   apply (auto simp add: less_Suc_eq) (* slow *)
  apply (erule foldSetD.cases)
   apply blast
  apply (erule foldSetD.cases)
   apply blast
  apply clarify
  txt {* force simplification of @{text "card A < card (insert ...)"}. *}
  apply (erule rev_mp)
  apply (simp add: less_Suc_eq_le)
  apply (rule impI)
  apply (rename_tac xa Aa ya xb Ab yb, case_tac "xa = xb")
   apply (subgoal_tac "Aa = Ab")
    prefer 2 apply (blast elim!: equalityE)
   apply blast
  txt {* case @{prop "xa \<notin> xb"}. *}
  apply (subgoal_tac "Aa - {xb} = Ab - {xa} & xb \<in> Aa & xa \<in> Ab")
   prefer 2 apply (blast elim!: equalityE)
  apply clarify
  apply (subgoal_tac "Aa = insert xb Ab - {xa}")
   prefer 2 apply blast
  apply (subgoal_tac "card Aa \<le> card Ab")
   prefer 2
   apply (rule Suc_le_mono [THEN subst])
   apply (simp add: card_Suc_Diff1)
  apply (rule_tac A1 = "Aa - {xb}" in finite_imp_foldSetD [THEN exE])
     apply (blast intro: foldSetD_imp_finite)
    apply best
   apply assumption
  apply (frule (1) Diff1_foldSetD)
   apply best
  apply (subgoal_tac "ya = f xb x")
   prefer 2
   apply (subgoal_tac "Aa \<subseteq> B")
    prefer 2 apply best (* slow *)
   apply (blast del: equalityCE)
  apply (subgoal_tac "(Ab - {xa}, x) \<in> foldSetD D f e")
   prefer 2 apply simp
  apply (subgoal_tac "yb = f xa x")
   prefer 2
   apply (blast del: equalityCE dest: Diff1_foldSetD)
  apply (simp (no_asm_simp))
  apply (rule left_commute)
    apply assumption
   apply best (* slow *)
  apply best
  done

lemma (in LCD) foldSetD_determ:
  "[| (A, x) \<in> foldSetD D f e; (A, y) \<in> foldSetD D f e; e \<in> D; A \<subseteq> B |]
  ==> y = x"
  by (blast intro: foldSetD_determ_aux [rule_format])

lemma (in LCD) foldD_equality:
  "[| (A, y) \<in> foldSetD D f e; e \<in> D; A \<subseteq> B |] ==> foldD D f e A = y"
  by (unfold foldD_def) (blast intro: foldSetD_determ)

lemma foldD_empty [simp]:
  "e \<in> D ==> foldD D f e {} = e"
  by (unfold foldD_def) blast

lemma (in LCD) foldD_insert_aux:
  "[| x ~: A; x \<in> B; e \<in> D; A \<subseteq> B |] ==>
    ((insert x A, v) \<in> foldSetD D f e) =
    (EX y. (A, y) \<in> foldSetD D f e & v = f x y)"
  apply auto
  apply (rule_tac A1 = A in finite_imp_foldSetD [THEN exE])
     apply (fastforce dest: foldSetD_imp_finite)
    apply assumption
   apply assumption
  apply (blast intro: foldSetD_determ)
  done

lemma (in LCD) foldD_insert:
    "[| finite A; x ~: A; x \<in> B; e \<in> D; A \<subseteq> B |] ==>
     foldD D f e (insert x A) = f x (foldD D f e A)"
  apply (unfold foldD_def)
  apply (simp add: foldD_insert_aux)
  apply (rule the_equality)
   apply (auto intro: finite_imp_foldSetD
     cong add: conj_cong simp add: foldD_def [symmetric] foldD_equality)
  done

lemma (in LCD) foldD_closed [simp]:
  "[| finite A; e \<in> D; A \<subseteq> B |] ==> foldD D f e A \<in> D"
proof (induct set: finite)
  case empty then show ?case by simp
next
  case insert then show ?case by (simp add: foldD_insert)
qed

lemma (in LCD) foldD_commute:
  "[| finite A; x \<in> B; e \<in> D; A \<subseteq> B |] ==>
   f x (foldD D f e A) = foldD D f (f x e) A"
  apply (induct set: finite)
   apply simp
  apply (auto simp add: left_commute foldD_insert)
  done

lemma Int_mono2:
  "[| A \<subseteq> C; B \<subseteq> C |] ==> A Int B \<subseteq> C"
  by blast

lemma (in LCD) foldD_nest_Un_Int:
  "[| finite A; finite C; e \<in> D; A \<subseteq> B; C \<subseteq> B |] ==>
   foldD D f (foldD D f e C) A = foldD D f (foldD D f e (A Int C)) (A Un C)"
  apply (induct set: finite)
   apply simp
  apply (simp add: foldD_insert foldD_commute Int_insert_left insert_absorb
    Int_mono2)
  done

lemma (in LCD) foldD_nest_Un_disjoint:
  "[| finite A; finite B; A Int B = {}; e \<in> D; A \<subseteq> B; C \<subseteq> B |]
    ==> foldD D f e (A Un B) = foldD D f (foldD D f e B) A"
  by (simp add: foldD_nest_Un_Int)

-- {* Delete rules to do with @{text foldSetD} relation. *}

declare foldSetD_imp_finite [simp del]
  empty_foldSetDE [rule del]
  foldSetD.intros [rule del]
declare (in LCD)
  foldSetD_closed [rule del]

text {* Commutative Monoids *}

text {*
  We enter a more restrictive context, with @{text "f :: 'a => 'a => 'a"}
  instead of @{text "'b => 'a => 'a"}.
*}

locale ACeD =
  fixes D :: "'a set"
    and f :: "'a => 'a => 'a"    (infixl "\<cdot>" 70)
    and e :: 'a
  assumes ident [simp]: "x \<in> D ==> x \<cdot> e = x"
    and commute: "[| x \<in> D; y \<in> D |] ==> x \<cdot> y = y \<cdot> x"
    and assoc: "[| x \<in> D; y \<in> D; z \<in> D |] ==> (x \<cdot> y) \<cdot> z = x \<cdot> (y \<cdot> z)"
    and e_closed [simp]: "e \<in> D"
    and f_closed [simp]: "[| x \<in> D; y \<in> D |] ==> x \<cdot> y \<in> D"

lemma (in ACeD) left_commute:
  "[| x \<in> D; y \<in> D; z \<in> D |] ==> x \<cdot> (y \<cdot> z) = y \<cdot> (x \<cdot> z)"
proof -
  assume D: "x \<in> D" "y \<in> D" "z \<in> D"
  then have "x \<cdot> (y \<cdot> z) = (y \<cdot> z) \<cdot> x" by (simp add: commute)
  also from D have "... = y \<cdot> (z \<cdot> x)" by (simp add: assoc)
  also from D have "z \<cdot> x = x \<cdot> z" by (simp add: commute)
  finally show ?thesis .
qed

lemmas (in ACeD) AC = assoc commute left_commute

lemma (in ACeD) left_ident [simp]: "x \<in> D ==> e \<cdot> x = x"
proof -
  assume "x \<in> D"
  then have "x \<cdot> e = x" by (rule ident)
  with `x \<in> D` show ?thesis by (simp add: commute)
qed

lemma (in ACeD) foldD_Un_Int:
  "[| finite A; finite B; A \<subseteq> D; B \<subseteq> D |] ==>
    foldD D f e A \<cdot> foldD D f e B =
    foldD D f e (A Un B) \<cdot> foldD D f e (A Int B)"
  apply (induct set: finite)
   apply (simp add: left_commute LCD.foldD_closed [OF LCD.intro [of D]])
  apply (simp add: AC insert_absorb Int_insert_left
    LCD.foldD_insert [OF LCD.intro [of D]]
    LCD.foldD_closed [OF LCD.intro [of D]]
    Int_mono2)
  done

lemma (in ACeD) foldD_Un_disjoint:
  "[| finite A; finite B; A Int B = {}; A \<subseteq> D; B \<subseteq> D |] ==>
    foldD D f e (A Un B) = foldD D f e A \<cdot> foldD D f e B"
  by (simp add: foldD_Un_Int
    left_commute LCD.foldD_closed [OF LCD.intro [of D]])

subsubsection {* Products over Finite Sets *}

definition
  finprod :: "[('b, 'm) monoid_scheme, 'a => 'b, 'a set] => 'b"
  where "finprod G f A =
   (if finite A
    then foldD (carrier G) (mult G o f) \<one>\<^bsub>G\<^esub> A
    else undefined)"

syntax
  "_finprod" :: "index => idt => 'a set => 'b => 'b"
      ("(3\<Otimes>__:_. _)" [1000, 0, 51, 10] 10)
syntax (xsymbols)
  "_finprod" :: "index => idt => 'a set => 'b => 'b"
      ("(3\<Otimes>__\<in>_. _)" [1000, 0, 51, 10] 10)
syntax (HTML output)
  "_finprod" :: "index => idt => 'a set => 'b => 'b"
      ("(3\<Otimes>__\<in>_. _)" [1000, 0, 51, 10] 10)
translations
  "\<Otimes>\<index>i:A. b" == "CONST finprod \<struct>\<index> (%i. b) A"
  -- {* Beware of argument permutation! *}

lemma (in comm_monoid) finprod_empty [simp]:
  "finprod G f {} = \<one>"
  by (simp add: finprod_def)

declare funcsetI [intro]
  funcset_mem [dest]

context comm_monoid begin

lemma finprod_insert [simp]:
  "[| finite F; a \<notin> F; f \<in> F -> carrier G; f a \<in> carrier G |] ==>
   finprod G f (insert a F) = f a \<otimes> finprod G f F"
  apply (rule trans)
   apply (simp add: finprod_def)
  apply (rule trans)
   apply (rule LCD.foldD_insert [OF LCD.intro [of "insert a F"]])
         apply simp
         apply (rule m_lcomm)
           apply fast
          apply fast
         apply assumption
        apply fastforce
       apply simp+
   apply fast
  apply (auto simp add: finprod_def)
  done

lemma finprod_one [simp]:
  "finite A ==> (\<Otimes>i:A. \<one>) = \<one>"
proof (induct set: finite)
  case empty show ?case by simp
next
  case (insert a A)
  have "(%i. \<one>) \<in> A -> carrier G" by auto
  with insert show ?case by simp
qed

lemma finprod_closed [simp]:
  fixes A
  assumes fin: "finite A" and f: "f \<in> A -> carrier G"
  shows "finprod G f A \<in> carrier G"
using fin f
proof induct
  case empty show ?case by simp
next
  case (insert a A)
  then have a: "f a \<in> carrier G" by fast
  from insert have A: "f \<in> A -> carrier G" by fast
  from insert A a show ?case by simp
qed

lemma funcset_Int_left [simp, intro]:
  "[| f \<in> A -> C; f \<in> B -> C |] ==> f \<in> A Int B -> C"
  by fast

lemma funcset_Un_left [iff]:
  "(f \<in> A Un B -> C) = (f \<in> A -> C & f \<in> B -> C)"
  by fast

lemma finprod_Un_Int:
  "[| finite A; finite B; g \<in> A -> carrier G; g \<in> B -> carrier G |] ==>
     finprod G g (A Un B) \<otimes> finprod G g (A Int B) =
     finprod G g A \<otimes> finprod G g B"
-- {* The reversed orientation looks more natural, but LOOPS as a simprule! *}
proof (induct set: finite)
  case empty then show ?case by simp
next
  case (insert a A)
  then have a: "g a \<in> carrier G" by fast
  from insert have A: "g \<in> A -> carrier G" by fast
  from insert A a show ?case
    by (simp add: m_ac Int_insert_left insert_absorb Int_mono2)
qed

lemma finprod_Un_disjoint:
  "[| finite A; finite B; A Int B = {};
      g \<in> A -> carrier G; g \<in> B -> carrier G |]
   ==> finprod G g (A Un B) = finprod G g A \<otimes> finprod G g B"
  apply (subst finprod_Un_Int [symmetric])
      apply auto
  done

lemma finprod_multf:
  "[| finite A; f \<in> A -> carrier G; g \<in> A -> carrier G |] ==>
   finprod G (%x. f x \<otimes> g x) A = (finprod G f A \<otimes> finprod G g A)"
proof (induct set: finite)
  case empty show ?case by simp
next
  case (insert a A) then
  have fA: "f \<in> A -> carrier G" by fast
  from insert have fa: "f a \<in> carrier G" by fast
  from insert have gA: "g \<in> A -> carrier G" by fast
  from insert have ga: "g a \<in> carrier G" by fast
  from insert have fgA: "(%x. f x \<otimes> g x) \<in> A -> carrier G"
    by (simp add: Pi_def)
  show ?case
    by (simp add: insert fA fa gA ga fgA m_ac)
qed

lemma finprod_cong':
  "[| A = B; g \<in> B -> carrier G;
      !!i. i \<in> B ==> f i = g i |] ==> finprod G f A = finprod G g B"
proof -
  assume prems: "A = B" "g \<in> B -> carrier G"
    "!!i. i \<in> B ==> f i = g i"
  show ?thesis
  proof (cases "finite B")
    case True
    then have "!!A. [| A = B; g \<in> B -> carrier G;
      !!i. i \<in> B ==> f i = g i |] ==> finprod G f A = finprod G g B"
    proof induct
      case empty thus ?case by simp
    next
      case (insert x B)
      then have "finprod G f A = finprod G f (insert x B)" by simp
      also from insert have "... = f x \<otimes> finprod G f B"
      proof (intro finprod_insert)
        show "finite B" by fact
      next
        show "x ~: B" by fact
      next
        assume "x ~: B" "!!i. i \<in> insert x B \<Longrightarrow> f i = g i"
          "g \<in> insert x B \<rightarrow> carrier G"
        thus "f \<in> B -> carrier G" by fastforce
      next
        assume "x ~: B" "!!i. i \<in> insert x B \<Longrightarrow> f i = g i"
          "g \<in> insert x B \<rightarrow> carrier G"
        thus "f x \<in> carrier G" by fastforce
      qed
      also from insert have "... = g x \<otimes> finprod G g B" by fastforce
      also from insert have "... = finprod G g (insert x B)"
      by (intro finprod_insert [THEN sym]) auto
      finally show ?case .
    qed
    with prems show ?thesis by simp
  next
    case False with prems show ?thesis by (simp add: finprod_def)
  qed
qed

lemma finprod_cong:
  "[| A = B; f \<in> B -> carrier G = True;
      !!i. i \<in> B =simp=> f i = g i |] ==> finprod G f A = finprod G g B"
  (* This order of prems is slightly faster (3%) than the last two swapped. *)
  by (rule finprod_cong') (auto simp add: simp_implies_def)

text {*Usually, if this rule causes a failed congruence proof error,
  the reason is that the premise @{text "g \<in> B -> carrier G"} cannot be shown.
  Adding @{thm [source] Pi_def} to the simpset is often useful.
  For this reason, @{thm [source] finprod_cong}
  is not added to the simpset by default.
*}

end

declare funcsetI [rule del]
  funcset_mem [rule del]

context comm_monoid begin

lemma finprod_0 [simp]:
  "f \<in> {0::nat} -> carrier G ==> finprod G f {..0} = f 0"
by (simp add: Pi_def)

lemma finprod_Suc [simp]:
  "f \<in> {..Suc n} -> carrier G ==>
   finprod G f {..Suc n} = (f (Suc n) \<otimes> finprod G f {..n})"
by (simp add: Pi_def atMost_Suc)

lemma finprod_Suc2:
  "f \<in> {..Suc n} -> carrier G ==>
   finprod G f {..Suc n} = (finprod G (%i. f (Suc i)) {..n} \<otimes> f 0)"
proof (induct n)
  case 0 thus ?case by (simp add: Pi_def)
next
  case Suc thus ?case by (simp add: m_assoc Pi_def)
qed

lemma finprod_mult [simp]:
  "[| f \<in> {..n} -> carrier G; g \<in> {..n} -> carrier G |] ==>
     finprod G (%i. f i \<otimes> g i) {..n::nat} =
     finprod G f {..n} \<otimes> finprod G g {..n}"
  by (induct n) (simp_all add: m_ac Pi_def)

(* The following two were contributed by Jeremy Avigad. *)

lemma finprod_reindex:
  assumes fin: "finite A"
    shows "f : (h ` A) \<rightarrow> carrier G \<Longrightarrow>
        inj_on h A ==> finprod G f (h ` A) = finprod G (%x. f (h x)) A"
  using fin
  by induct (auto simp add: Pi_def)

lemma finprod_const:
  assumes fin [simp]: "finite A"
      and a [simp]: "a : carrier G"
    shows "finprod G (%x. a) A = a (^) card A"
  using fin apply induct
  apply force
  apply (subst finprod_insert)
  apply auto
  apply (subst m_comm)
  apply auto
  done

(* The following lemma was contributed by Jesus Aransay. *)

lemma finprod_singleton:
  assumes i_in_A: "i \<in> A" and fin_A: "finite A" and f_Pi: "f \<in> A \<rightarrow> carrier G"
  shows "(\<Otimes>j\<in>A. if i = j then f j else \<one>) = f i"
  using i_in_A finprod_insert [of "A - {i}" i "(\<lambda>j. if i = j then f j else \<one>)"]
    fin_A f_Pi finprod_one [of "A - {i}"]
    finprod_cong [of "A - {i}" "A - {i}" "(\<lambda>j. if i = j then f j else \<one>)" "(\<lambda>i. \<one>)"]
  unfolding Pi_def simp_implies_def by (force simp add: insert_absorb)

end

end


(*  Title:       SetCat
    Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
    Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
*)

chapter SetCat

theory SetCat
imports SetCategory ConcreteCategory
begin

  text\<open>
    This theory proves the consistency of the \<open>set_category\<close> locale by giving
    a particular concrete construction of an interpretation for it.
    Applying the general construction given by @{locale concrete_category},
    we define arrows to be terms \<open>MkArr A B F\<close>, where \<open>A\<close> and \<open>B\<close> are sets
    and \<open>F\<close> is an extensional function that maps \<open>A\<close> to \<open>B\<close>.
\<close>

  locale setcat
  begin

    type_synonym 'aa arr = "('aa set, 'aa \<Rightarrow> 'aa) concrete_category.arr"

    interpretation concrete_category \<open>UNIV :: 'a set set\<close> \<open>\<lambda>A B. extensional A \<inter> (A \<rightarrow> B)\<close>
      \<open>\<lambda>A. \<lambda>x \<in> A. x\<close> \<open>\<lambda>C B A g f. compose A g f\<close>
      using compose_Id Id_compose
      apply unfold_locales
          apply auto[3]
       apply blast
      by (metis IntD2 compose_assoc)

    abbreviation Comp      (infixr "\<cdot>" 55)
    where "Comp \<equiv> COMP"
    notation in_hom        ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")

    lemma MkArr_expansion:
    assumes "arr f"
    shows "f = MkArr (Dom f) (Cod f) (\<lambda>x \<in> Dom f. Map f x)"
    proof (intro arr_eqI)
      show "arr f" by fact
      show "arr (MkArr (Dom f) (Cod f) (\<lambda>x \<in> Dom f. Map f x))"
        using assms arr_char
        by (metis (mono_tags, lifting) Int_iff MkArr_Map extensional_restrict)
      show "Dom f = Dom (MkArr (Dom f) (Cod f) (\<lambda>x \<in> Dom f. Map f x))"
        by simp
      show "Cod f = Cod (MkArr (Dom f) (Cod f) (\<lambda>x \<in> Dom f. Map f x))"
        by simp
      show "Map f = Map (MkArr (Dom f) (Cod f) (\<lambda>x \<in> Dom f. Map f x))"
        using assms arr_char
        by (metis (mono_tags, lifting) Int_iff MkArr_Map extensional_restrict)
    qed

    lemma arr_char:
    shows "arr f \<longleftrightarrow> f \<noteq> Null \<and> Map f \<in> extensional (Dom f) \<inter> (Dom f \<rightarrow> Cod f)"
      using arr_char by auto

    lemma terminal_char:
    shows "terminal a \<longleftrightarrow> (\<exists>x. a = MkIde {x})"
    proof
      show "\<exists>x. a = MkIde {x} \<Longrightarrow> terminal a"
      proof -
        assume a: "\<exists>x. a = MkIde {x}"
        from this obtain x where x: "a = MkIde {x}" by blast
        have "terminal (MkIde {x})"
        proof
          show "ide (MkIde {x})"
            using ide_MkIde by auto
          show "\<And>a. ide a \<Longrightarrow> \<exists>!f. \<guillemotleft>f : a \<rightarrow> MkIde {x}\<guillemotright>"
          proof
            fix a :: "'a setcat.arr"
            assume a: "ide a"
            show "\<guillemotleft>MkArr (Dom a) {x} (\<lambda>_\<in>Dom a. x) : a \<rightarrow> MkIde {x}\<guillemotright>"
              using a MkArr_in_hom
              by (metis (mono_tags, lifting) IntI MkIde_Dom' restrictI restrict_extensional
                  singletonI UNIV_I)
            fix f :: "'a setcat.arr"
            assume f: "\<guillemotleft>f : a \<rightarrow> MkIde {x}\<guillemotright>"
            show "f = MkArr (Dom a) {x} (\<lambda>_ \<in> Dom a. x)"
            proof -
              have 1: "Dom f = Dom a \<and> Cod f = {x}"
                using a f by (metis (mono_tags, lifting) Dom.simps(1) in_hom_char)
              moreover have "Map f = (\<lambda>_ \<in> Dom a. x)"
              proof
                fix z
                have "z \<notin> Dom a \<Longrightarrow> Map f z = (\<lambda>_ \<in> Dom a. x) z"
                  using f 1 MkArr_expansion
                  by (metis (mono_tags, lifting) Map.simps(1) in_homE restrict_apply)
                moreover have "z \<in> Dom a \<Longrightarrow> Map f z = (\<lambda>_ \<in> Dom a. x) z"
                  using f 1 arr_char [of f] by fastforce
                ultimately show "Map f z = (\<lambda>_ \<in> Dom a. x) z" by auto
              qed
              ultimately show ?thesis
               using f MkArr_expansion [of f] by fastforce
            qed
          qed
        qed
        thus "terminal a" using x by simp
      qed
      show "terminal a \<Longrightarrow> \<exists>x. a = MkIde {x}"
      proof -
        assume a: "terminal a"
        hence "ide a" using terminal_def by auto
        have 1: "\<exists>!x. x \<in> Dom a"
        proof -
          have "Dom a = {} \<Longrightarrow> \<not>terminal a"
          proof -
            assume "Dom a = {}"
            hence 1: "a = MkIde {}" using \<open>ide a\<close> MkIde_Dom' by force
            have "\<And>f. f \<in> hom (MkIde {undefined}) (MkIde ({} :: 'a set))
                         \<Longrightarrow> Map f \<in> {undefined} \<rightarrow> {}"
            proof -
              fix f
              assume f: "f \<in> hom (MkIde {undefined}) (MkIde ({} :: 'a set))"
              show "Map f \<in> {undefined} \<rightarrow> {}"
                using f MkArr_expansion arr_char [of f] in_hom_char  by auto
            qed
            hence "hom (MkIde {undefined}) a = {}" using 1 by auto
            moreover have "ide (MkIde {undefined})" using ide_MkIde by auto
            ultimately show "\<not>terminal a" by blast
          qed
          moreover have "\<And>x x'. x \<in> Dom a \<and> x' \<in> Dom a \<and> x \<noteq> x' \<Longrightarrow> \<not>terminal a"
          proof -
            fix x x'
            assume 1: "x \<in> Dom a \<and> x' \<in> Dom a \<and> x \<noteq> x'"
            have "\<guillemotleft>MkArr {undefined} (Dom a) (\<lambda>_ \<in> {undefined}. x) : MkIde {undefined} \<rightarrow> a\<guillemotright>"
              using 1
              by (metis (mono_tags, lifting) IntI MkIde_Dom' \<open>ide a\<close> restrictI
                  restrict_extensional MkArr_in_hom UNIV_I)
            moreover have
              "\<guillemotleft>MkArr {undefined} (Dom a) (\<lambda>_ \<in> {undefined}. x') : MkIde {undefined} \<rightarrow> a\<guillemotright>"
              using 1
              by (metis (mono_tags, lifting) IntI MkIde_Dom' \<open>ide a\<close> restrictI
                  restrict_extensional MkArr_in_hom UNIV_I)
            moreover have "MkArr {undefined} (Dom a) (\<lambda>_ \<in> {undefined}. x) \<noteq>
                           MkArr {undefined} (Dom a) (\<lambda>_ \<in> {undefined}. x')"
              using 1 by (metis arr.inject restrict_apply' singletonI)
            ultimately show "\<not>terminal a"
              using terminal_arr_unique
              by (metis (mono_tags, lifting) in_homE)
          qed
          ultimately show ?thesis
            using a by auto
        qed
        hence "Dom a = {THE x. x \<in> Dom a}"
          using theI [of "\<lambda>x. x \<in> Dom a"] by auto
        hence "a = MkIde {THE x. x \<in> Dom a}"
          using a terminal_def by (metis (mono_tags, lifting) MkIde_Dom')
        thus "\<exists>x. a = MkIde {x}"
          by auto
      qed
    qed

    definition Img :: "'a setcat.arr \<Rightarrow> 'a setcat.arr"
    where "Img f = MkIde (Map f ` Dom f)"

    interpretation set_category_data Comp Img ..

    lemma terminal_unity:
    shows "terminal unity"
      using terminal_char unity_def someI_ex [of terminal]
      by (metis (mono_tags, lifting))

    text\<open>
      The inverse maps @{term UP} and @{term DOWN} are used to pass back and forth between
      the inhabitants of type @{typ 'a} and the corresponding terminal objects.
      These are exported so that a client of the theory can relate the concrete
      element type @{typ 'a} to the otherwise abstract arrow type.
\<close>

    definition UP :: "'a \<Rightarrow> 'a setcat.arr"
    where "UP x \<equiv> MkIde {x}"

    definition DOWN :: "'a setcat.arr \<Rightarrow> 'a"
    where "DOWN t \<equiv> the_elem (Dom t)"

    abbreviation U
    where "U \<equiv> DOWN unity"

    lemma UP_mapsto:
    shows "UP \<in> UNIV \<rightarrow> Univ"
      using terminal_char UP_def by fast

    lemma DOWN_mapsto:
    shows "DOWN \<in> Univ \<rightarrow> UNIV"
      by auto

    lemma DOWN_UP [simp]:
    shows "DOWN (UP x) = x"
      by (simp add: DOWN_def UP_def)

    lemma UP_DOWN [simp]:
    assumes "t \<in> Univ"
    shows "UP (DOWN t) = t"
      using assms terminal_char UP_def DOWN_def
      by (metis (mono_tags, lifting) mem_Collect_eq DOWN_UP)

    lemma inj_UP:
    shows "inj UP"
      by (metis DOWN_UP injI)

    lemma bij_UP:
    shows "bij_betw UP UNIV Univ"
    proof (intro bij_betwI)
      interpret category Comp using is_category by auto
      show DOWN_UP: "\<And>x :: 'a. DOWN (UP x) = x" by simp
      show UP_DOWN: "\<And>t. t \<in> Univ \<Longrightarrow> UP (DOWN t) = t" by simp
      show "UP \<in> UNIV \<rightarrow> Univ" using UP_mapsto by auto
      show "DOWN \<in> Collect terminal \<rightarrow> UNIV" by auto
    qed

    lemma Dom_terminal:
    assumes "terminal t"
    shows "Dom t = {DOWN t}"
      using assms UP_def
      by (metis (mono_tags, lifting) Dom.simps(1) DOWN_def terminal_char the_elem_eq)

    text\<open>
      The image of a point @{term "p \<in> hom unity a"} is a terminal object, which is given
      by the formula @{term "(UP o Fun p o DOWN) unity"}.
\<close>

    lemma Img_point:
    assumes "\<guillemotleft>p : unity \<rightarrow> a\<guillemotright>"
    shows "Img \<in> hom unity a \<rightarrow> Univ"
    and "Img p = (UP o Map p o DOWN) unity"
    proof -
      show "Img \<in> hom unity a \<rightarrow> Univ"
      proof
        fix f
        assume f: "f \<in> hom unity a"
        have "terminal (MkIde (Map f ` Dom unity))"
        proof -
          obtain u :: 'a where u: "unity = MkIde {u}"
            using terminal_unity terminal_char
            by (metis (mono_tags, lifting))
          have "Map f ` Dom unity = {Map f u}"
            using u by simp
          thus ?thesis
            using terminal_char by auto
        qed
        hence "MkIde (Map f ` Dom unity) \<in> Univ" by simp
        moreover have "MkIde (Map f ` Dom unity) = Img f"
          using f dom_char Img_def in_homE
          by (metis (mono_tags, lifting) Dom.simps(1) mem_Collect_eq)
        ultimately show "Img f \<in> Univ" by auto
      qed
      have "Img p = MkIde (Map p ` Dom p)" using Img_def by blast
      also have "... = MkIde (Map p ` {U})"
        using assms in_hom_char terminal_unity Dom_terminal
        by (metis (mono_tags, lifting))
      also have "... = (UP o Map p o DOWN) unity" by (simp add: UP_def)
      finally show "Img p = (UP o Map p o DOWN) unity" using assms by auto
    qed

    text\<open>
      The function @{term Img} is injective on @{term "hom unity a"} and its inverse takes
      a terminal object @{term t} to the arrow in @{term "hom unity a"} corresponding to the
      constant-@{term t} function.
\<close>

    abbreviation MkElem :: "'a setcat.arr => 'a setcat.arr => 'a setcat.arr"
    where "MkElem t a \<equiv> MkArr {U} (Dom a) (\<lambda>_ \<in> {U}. DOWN t)"

    lemma MkElem_in_hom:
    assumes "arr f" and "x \<in> Dom f"
    shows "\<guillemotleft>MkElem (UP x) (dom f) : unity \<rightarrow> dom f\<guillemotright>"
    proof -
      have "(\<lambda>_ \<in> {U}. DOWN (UP x)) \<in> {U} \<rightarrow> Dom (dom f)"
        using assms dom_char [of f] by simp
      moreover have "MkIde {U} = unity"
        using terminal_char terminal_unity
        by (metis (mono_tags, lifting) DOWN_UP UP_def)
      moreover have "MkIde (Dom (dom f)) = dom f"
        using assms dom_char MkIde_Dom' ide_dom by blast
      ultimately show ?thesis
        using assms MkArr_in_hom [of "{U}" "Dom (dom f)" "\<lambda>_ \<in> {U}. DOWN (UP x)"]
        by (metis (mono_tags, lifting) IntI restrict_extensional UNIV_I)
    qed

    lemma MkElem_Img:
    assumes "p \<in> hom unity a"
    shows "MkElem (Img p) a = p"
    proof -
      have 0: "Img p = UP (Map p U)"
        using assms Img_point(2) by auto
      have 1: "Dom p = {U}"
        using assms terminal_unity Dom_terminal
        by (metis (mono_tags, lifting) in_hom_char mem_Collect_eq)
      moreover have "Cod p = Dom a"
        using assms
        by (metis (mono_tags, lifting) in_hom_char mem_Collect_eq)
      moreover have "Map p = (\<lambda>_ \<in> {U}. DOWN (Img p))"
      proof
        fix e
        show "Map p e = (\<lambda>_ \<in> {U}. DOWN (Img p)) e"
        proof -
          have "Map p e = (\<lambda>x \<in> Dom p. Map p x) e"
            using assms MkArr_expansion [of p]
            by (metis (mono_tags, lifting) CollectD Map.simps(1) in_homE)
          also have "... = (\<lambda>_ \<in> {U}. DOWN (Img p)) e"
            using assms 0 1 by simp
          finally show ?thesis by blast
        qed
      qed
      ultimately show "MkElem (Img p) a = p"
        using assms MkArr_Map CollectD
        by (metis (mono_tags, lifting) in_homE mem_Collect_eq)
    qed

    lemma inj_Img:
    assumes "ide a"
    shows "inj_on Img (hom unity a)"
    proof (intro inj_onI)
      fix x y
      assume x: "x \<in> hom unity a"
      assume y: "y \<in> hom unity a"
      assume eq: "Img x = Img y"
      show "x = y"
      proof (intro arr_eqI)
        show "arr x" using x by blast
        show "arr y" using y by blast
        show "Dom x = Dom y"
          using x y in_hom_char by (metis (mono_tags, lifting) CollectD)
        show "Cod x = Cod y"
          using x y in_hom_char by (metis (mono_tags, lifting) CollectD)
        show "Map x = Map y"
        proof -
          have "Map x = (\<lambda>z \<in> {U}. Map x z) \<and> Map y = (\<lambda>z \<in> {U}. Map y z)"
            using x y \<open>arr x\<close> \<open>arr y\<close> Dom_terminal terminal_unity MkArr_expansion
            by (metis (mono_tags, lifting) CollectD Map.simps(1) in_hom_char)
          moreover have "Map x U = Map y U"
            using x y eq
            by (metis (mono_tags, lifting) CollectD Img_point(2) o_apply setcat.DOWN_UP)
          ultimately show ?thesis
            by (metis (mono_tags, lifting) restrict_ext singletonD)
        qed
      qed
    qed

    lemma set_char:
    assumes "ide a"
    shows "set a = UP ` Dom a"
    proof
      show "set a \<subseteq> UP ` Dom a"
      proof
        fix t
        assume "t \<in> set a"
        from this obtain p where p: "\<guillemotleft>p : unity \<rightarrow> a\<guillemotright> \<and> t = Img p"
          using set_def by blast
        have "t = (UP o Map p o DOWN) unity"
          using p Img_point(2) by blast
        moreover have "(Map p o DOWN) unity \<in> Dom a"
          using p arr_char in_hom_char Dom_terminal terminal_unity
          by (metis (mono_tags, lifting) IntD2 Pi_split_insert_domain o_apply)
        ultimately show "t \<in> UP ` Dom a" by simp
      qed
      show "UP ` Dom a \<subseteq> set a"
      proof
        fix t
        assume "t \<in> UP ` Dom a"
        from this obtain x where x: "x \<in> Dom a \<and> t = UP x" by blast
        let ?p = "MkElem (UP x) a"
        have p: "?p \<in> hom unity a"
          using assms x MkElem_in_hom [of "dom a"] ideD(1-2) by force
        moreover have "Img ?p = t"
          using p x DOWN_UP
          by (metis (no_types, lifting) Dom.simps(1) Map.simps(1) image_empty
              image_insert image_restrict_eq setcat.Img_def UP_def)
        ultimately show "t \<in> set a" using set_def by blast
      qed
    qed

    lemma Map_via_comp:
    assumes "arr f"
    shows "Map f = (\<lambda>x \<in> Dom f. Map (f \<cdot> MkElem (UP x) (dom f)) U)"
    proof
      fix x
      have "x \<notin> Dom f \<Longrightarrow> Map f x = (\<lambda>x \<in> Dom f. Map (f \<cdot> MkElem (UP x) (dom f)) U) x"
        using assms arr_char [of f] IntD1 extensional_arb restrict_apply by fastforce
      moreover have
           "x \<in> Dom f \<Longrightarrow> Map f x = (\<lambda>x \<in> Dom f. Map (f \<cdot> MkElem (UP x) (dom f)) U) x"
      proof -
        assume x: "x \<in> Dom f"
        let ?X = "MkElem (UP x) (dom f)"
        have "\<guillemotleft>?X : unity \<rightarrow> dom f\<guillemotright>"
          using assms x MkElem_in_hom by auto
        moreover have "Dom ?X = {U} \<and> Map ?X = (\<lambda>_ \<in> {U}. x)"
          using x by simp
        ultimately have
	    "Map (f \<cdot> MkElem (UP x) (dom f)) = compose {U} (Map f) (\<lambda>_ \<in> {U}. x)"
          using assms x Map_comp [of "MkElem (UP x) (dom f)" f]
          by (metis (mono_tags, lifting) Cod.simps(1) Dom_dom arr_iff_in_hom seqE seqI')
        thus ?thesis
          using x by (simp add: compose_eq restrict_apply' singletonI)
      qed
      ultimately show "Map f x = (\<lambda>x \<in> Dom f. Map (f \<cdot> MkElem (UP x) (dom f)) U) x"
        by auto
    qed

    theorem is_set_category:
    shows "set_category Comp"
    proof
      show "\<exists>img :: 'a setcat.arr \<Rightarrow> 'a setcat.arr. set_category_given_img Comp img"
      proof
        show "set_category_given_img (Comp :: 'a setcat.arr comp) Img"
        proof
          show "Univ \<noteq> {}" using terminal_char by blast
          fix a :: "'a setcat.arr"
          assume a: "ide a"
          show "Img \<in> hom unity a \<rightarrow> Univ" using Img_point terminal_unity by blast
          show "inj_on Img (hom unity a)" using a inj_Img terminal_unity by blast
          next
          fix t :: "'a setcat.arr"
          assume t: "terminal t"
          show "t \<in> Img ` hom unity t"
          proof -
            have "t \<in> set t"
              using t set_char [of t]
              by (metis (mono_tags, lifting) Dom.simps(1) image_insert insertI1 UP_def
                  terminal_char terminal_def)
            thus ?thesis
              using t set_def [of t] by simp
          qed
          next
          fix A :: "'a setcat.arr set"
          assume A: "A \<subseteq> Univ"
          show "\<exists>a. ide a \<and> set a = A"
          proof
            let ?a = "MkArr (DOWN ` A) (DOWN ` A) (\<lambda>x \<in> (DOWN ` A). x)"
            show "ide ?a \<and> set ?a = A"
            proof
              show 1: "ide ?a"
                using ide_char [of ?a] by simp
              show "set ?a = A"
              proof -
                have 2: "\<And>x. x \<in> A \<Longrightarrow> x = UP (DOWN x)"
                  using A UP_DOWN by force
                hence "UP ` DOWN ` A = A"
                  using A UP_DOWN by auto
                thus ?thesis
                  using 1 A set_char [of ?a] by simp
              qed
            qed
          qed
          next
          fix a b :: "'a setcat.arr"
          assume a: "ide a" and b: "ide b" and ab: "set a = set b"
          show "a = b"
            using a b ab set_char inj_UP inj_image_eq_iff dom_char in_homE ide_in_hom
            by (metis (mono_tags, lifting))
          next
          fix f f' :: "'a setcat.arr"
          assume par: "par f f'" and ff': "\<And>x. \<guillemotleft>x : unity \<rightarrow> dom f\<guillemotright> \<Longrightarrow> f \<cdot> x = f' \<cdot> x"
          show "f = f'" using par ff' arr_eqI' by blast
          next
          fix a b :: "'a setcat.arr" and F :: "'a setcat.arr \<Rightarrow> 'a setcat.arr"
          assume a: "ide a" and b: "ide b" and F: "F \<in> hom unity a \<rightarrow> hom unity b"
          show "\<exists>f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> (\<forall>x. \<guillemotleft>x : unity \<rightarrow> dom f\<guillemotright> \<longrightarrow> f \<cdot> x = F x)"
          proof
            let ?f = "MkArr (Dom a) (Dom b) (\<lambda>x \<in> Dom a. Map (F (MkElem (UP x) a)) U)"
            have 1: "\<guillemotleft>?f : a \<rightarrow> b\<guillemotright>"
            proof -
              have "(\<lambda>x \<in> Dom a. Map (F (MkElem (UP x) a)) U)
                      \<in> extensional (Dom a) \<inter> (Dom a \<rightarrow> Dom b)"
              proof
                show "(\<lambda>x \<in> Dom a. Map (F (MkElem (UP x) a)) U) \<in> extensional (Dom a)"
                  using a F by simp
                show "(\<lambda>x \<in> Dom a. Map (F (MkElem (UP x) a)) U) \<in> Dom a \<rightarrow> Dom b"
                proof
                  fix x
                  assume x: "x \<in> Dom a"
                  have "MkElem (UP x) a \<in> hom unity a"
                    using x a MkElem_in_hom [of a x] ide_char ideD(1-2) by force
                  hence 1: "F (MkElem (UP x) a) \<in> hom unity b"
                    using F by auto
                  moreover have "Dom (F (MkElem (UP x) a)) = {U}"
                    using 1 MkElem_Img
                    by (metis (mono_tags, lifting) Dom.simps(1))
                  moreover have "Cod (F (MkElem (UP x) a)) = Dom b"
                    using 1 by (metis (mono_tags, lifting) CollectD in_hom_char)
                  ultimately have "Map (F (MkElem (UP x) a)) \<in> {U} \<rightarrow> Dom b"
                    using arr_char [of "F (MkElem (UP x) a)"] by blast
                  thus "Map (F (MkElem (UP x) a)) U \<in> Dom b" by blast
                qed
              qed
              hence "\<guillemotleft>?f : MkIde (Dom a) \<rightarrow> MkIde (Dom b)\<guillemotright>"
                using a b MkArr_in_hom by blast
              thus ?thesis
                using a b by simp
            qed
            moreover have "\<And>x. \<guillemotleft>x : unity \<rightarrow> dom ?f\<guillemotright> \<Longrightarrow> ?f \<cdot> x = F x"
            proof -
              fix x
              assume x: "\<guillemotleft>x : unity \<rightarrow> dom ?f\<guillemotright>"
              have 2: "x = MkElem (Img x) a"
                using a x 1 MkElem_Img [of x a]
                by (metis (mono_tags, lifting) in_homE mem_Collect_eq)
              moreover have 5: "Dom x = {U} \<and> Cod x = Dom a \<and>
                                Map x = (\<lambda>_ \<in> {U}. DOWN (Img x))"
                using x 2
                by (metis (no_types, lifting) Cod.simps(1) Dom.simps(1) Map.simps(1))
              moreover have "Cod ?f = Dom b" using 1 by simp
              ultimately have
                   3: "?f \<cdot> x =
                       MkArr {U} (Dom b) (compose {U} (Map ?f) (\<lambda>_ \<in> {U}. DOWN (Img x)))"
                using 1 x comp_char [of ?f "MkElem (Img x) a"]
                by (metis (mono_tags, lifting) in_homE seqI)
              have 4: "compose {U} (Map ?f) (\<lambda>_ \<in> {U}. DOWN (Img x)) = Map (F x)"
              proof
                fix y
                have "y \<notin> {U} \<Longrightarrow>
                        compose {U} (Map ?f) (\<lambda>_ \<in> {U}. DOWN (Img x)) y = Map (F x) y"
                proof -
                  assume y: "y \<notin> {U}"
                  have "compose {U} (Map ?f) (\<lambda>_ \<in> {U}. DOWN (Img x)) y = undefined"
                    using y compose_def extensional_arb by simp
                  also have "... = Map (F x) y"
                  proof -
                    have 5: "F x \<in> hom unity b" using x F 1 by fastforce
                    hence "Dom (F x) = {U}"
                      by (metis (mono_tags, lifting) "2" CollectD Dom.simps(1) in_hom_char x)
                    thus ?thesis
                      using x y F 5 arr_char [of "F x"] extensional_arb [of "Map (F x)" "{U}" y]
                      by (metis (mono_tags, lifting) CollectD Int_iff in_hom_char)
                  qed
                  ultimately show ?thesis by auto
                qed
                moreover have
                    "y \<in> {U} \<Longrightarrow>
                       compose {U} (Map ?f) (\<lambda>_ \<in> {U}. DOWN (Img x)) y = Map (F x) y"
                proof -
                  assume y: "y \<in> {U}"
                  have "compose {U} (Map ?f) (\<lambda>_ \<in> {U}. DOWN (Img x)) y =
                        Map ?f (DOWN (Img x))"
                    using y by (simp add: compose_eq restrict_apply')
                  also have "... = (\<lambda>x. Map (F (MkElem (UP x) a)) U) (DOWN (Img x))"
                  proof -
                    have "DOWN (Img x) \<in> Dom a"
                      using x y a 5 arr_char in_homE restrict_apply
                      by (metis (mono_tags, lifting) IntD2 PiE)
                    thus ?thesis
                      using restrict_apply by simp
                  qed
                  also have "... = Map (F x) y"
                    using x y 1 2 MkElem_Img [of x a] by simp
                  finally show
                      "compose {U} (Map ?f) (\<lambda>_ \<in> {U}. DOWN (Img x)) y = Map (F x) y"
                    by auto
                qed
                ultimately show
                    "compose {U} (Map ?f) (\<lambda>_ \<in> {U}. DOWN (Img x)) y = Map (F x) y"
                  by auto
              qed
              show "?f \<cdot> x = F x"
              proof (intro arr_eqI)
                have 5: "?f \<cdot> x \<in> hom unity b" using 1 x by blast
                have 6: "F x \<in> hom unity b"
                  using x F 1
                  by (metis (mono_tags, lifting) PiE in_homE mem_Collect_eq)
                show "arr (Comp ?f x)" using 5 by blast
                show "arr (F x)" using 6 by blast
                show "Dom (Comp ?f x) = Dom (F x)"
                  using 5 6 by (metis (mono_tags, lifting) CollectD in_hom_char)
                show "Cod (Comp ?f x) = Cod (F x)"
                  using 5 6 by (metis (mono_tags, lifting) CollectD in_hom_char)
                show "Map (Comp ?f x) = Map (F x)"
                  using 3 4 by simp
              qed
            qed
            thus "\<guillemotleft>?f : a \<rightarrow> b\<guillemotright> \<and> (\<forall>x. \<guillemotleft>x : unity \<rightarrow> dom ?f\<guillemotright> \<longrightarrow> Comp ?f x = F x)"
              using 1 by blast
          qed
        qed
      qed
    qed

    text\<open>
      \<open>SetCat\<close> can be viewed as a concrete set category over its own element type
      @{typ 'a}, using @{term UP} as the required injection from @{typ 'a} to the universe
      of \<open>SetCat\<close>.
\<close>

    corollary is_concrete_set_category:
    shows "concrete_set_category Comp Univ UP"
    proof -
      interpret S: set_category Comp using is_set_category by auto
      show ?thesis
      proof
        show 1: "UP \<in> Univ \<rightarrow> S.Univ"
          using UP_def terminal_char by force
        show "inj_on UP Univ"
          by (metis (mono_tags, lifting) injD inj_UP inj_onI)
      qed
    qed

    text\<open>
      As a consequence of the categoricity of the \<open>set_category\<close> axioms,
      if @{term S} interprets \<open>set_category\<close>, and if @{term \<phi>} is a bijection between
      the universe of @{term S} and the elements of type @{typ 'a}, then @{term S} is isomorphic
      to the category \<open>SetCat\<close> of @{typ 'a} sets and functions between them constructed here.
\<close>

    corollary set_category_iso_SetCat:
    fixes S :: "'s comp" and \<phi> :: "'s \<Rightarrow> 'a"
    assumes "set_category S"
    and "bij_betw \<phi> (Collect (category.terminal S)) UNIV"
    shows "\<exists>\<Phi>. invertible_functor S (Comp :: 'a setcat.arr comp) \<Phi>
                 \<and> (\<forall>m. set_category.incl S m \<longrightarrow> set_category.incl Comp (\<Phi> m))"
    proof -
      interpret S: set_category S using assms by auto
      let ?\<psi> = "inv_into S.Univ \<phi>"
      have "bij_betw (UP o \<phi>) S.Univ (Collect terminal)"
      proof (intro bij_betwI)
        show "UP o \<phi> \<in> S.Univ \<rightarrow> Collect terminal"
          using assms(2) UP_mapsto by auto
        show "?\<psi> o DOWN \<in> Collect terminal \<rightarrow> S.Univ"
        proof
          fix x :: "'a setcat.arr"
          assume x: "x \<in> Univ"
          show "(inv_into S.Univ \<phi> \<circ> DOWN) x \<in> S.Univ"
            using x assms(2) bij_betw_def comp_apply inv_into_into
            by (metis UNIV_I)
        qed
        fix t
        assume "t \<in> S.Univ"
        thus "(?\<psi> o DOWN) ((UP o \<phi>) t) = t"
          using assms(2) bij_betw_inv_into_left
          by (metis comp_apply DOWN_UP)
        next
        fix t' :: "'a setcat.arr"
        assume "t' \<in> Collect terminal"
        thus "(UP o \<phi>) ((?\<psi> o DOWN) t') = t'"
          using assms(2) by (simp add: bij_betw_def f_inv_into_f)
      qed
      thus ?thesis
        using assms(1) set_category_is_categorical [of S Comp "UP o \<phi>"] is_set_category
        by auto
    qed

  end

  text \<open>
    The following context defines the entities that are intended to be exported
    from this theory.  The idea is to avoid exposing as little detail about the
    construction used in the @{locale setcat} locale as possible, so that proofs
    using the result of that construction will depend only on facts proved from
    axioms in the @{locale set_category} locale and not on concrete details from
    the construction of the interpretation.
\<close>

  context
  begin

    interpretation S: setcat .

    definition comp
    where "comp \<equiv> S.Comp"

    interpretation set_category comp
      unfolding comp_def using S.is_set_category by simp

    lemma is_set_category:
    shows "set_category comp"
      ..

    definition DOWN
    where "DOWN = S.DOWN"

    definition UP
    where "UP = S.UP"

    lemma UP_mapsto:
    shows "UP \<in> UNIV \<rightarrow> Univ"
      using S.UP_mapsto
      by (simp add: UP_def comp_def)

    lemma DOWN_mapsto:
    shows "DOWN \<in> Univ \<rightarrow> UNIV"
      by auto

    lemma DOWN_UP [simp]:
    shows "DOWN (UP x) = x"
      by (simp add: DOWN_def UP_def)

    lemma UP_DOWN [simp]:
    assumes "t \<in> Univ"
    shows "UP (DOWN t) = t"
      using assms DOWN_def UP_def
      by (simp add: DOWN_def UP_def comp_def)

    lemma inj_UP:
    shows "inj UP"
      by (metis DOWN_UP injI)

    lemma bij_UP:
    shows "bij_betw UP UNIV Univ"
      by (metis S.bij_UP UP_def comp_def)

  end

end