section {* Quasi-Terms with Swapping and Freshness *}

theory QuasiTerms_Swap_Fresh imports Preliminaries
begin

text{*
This section defines and studies the (totally free) datatype of quasi-terms
and the notions of freshness and
swapping variables for them.
``Quasi" refers to the fact that these items are not (yet) factored to alpha-equivalence.
 We shall later call ``terms" those alpha-equivalence classes.  *}

subsection {* The datatype of quasi-terms with bindings *}

datatype
('index,'bindex,'varSort,'var,'opSym)qTerm =
   qVar 'varSort 'var
  |qOp 'opSym "('index, (('index,'bindex,'varSort,'var,'opSym)qTerm))input"
              "('bindex, (('index,'bindex,'varSort,'var,'opSym)qAbs)) input"
and
('index,'bindex,'varSort,'var,'opSym)qAbs =
  qAbs 'varSort 'var "('index,'bindex,'varSort,'var,'opSym)qTerm"

text{* Above:
\begin{itemize}
\item ``Var" stands for ``variable injection"
\item ``Op" stands for ``operation"
\item ``opSym" stands for ``operation symbol"
\item ``q" stands for ``quasi"
\item ``Abs" stands for ``abstraction"
\end{itemize}

Thus, a quasi-term is either (an injection of) a variable, or an operation symbol applied
to a term-input and an abstraction-input
(where, for any type $T$, $T$-inputs are partial
maps from indexes to $T$. A quasi-abstraction is
essentially a pair (variable,quasi-term).
 *}

type_synonym ('index,'bindex,'varSort,'var,'opSym)qTermItem =
"('index,'bindex,'varSort,'var,'opSym)qTerm +
 ('index,'bindex,'varSort,'var,'opSym)qAbs"

abbreviation termIn ::
"('index,'bindex,'varSort,'var,'opSym)qTerm \<Rightarrow> ('index,'bindex,'varSort,'var,'opSym)qTermItem"
where "termIn X == Inl X"

abbreviation absIn ::
"('index,'bindex,'varSort,'var,'opSym)qAbs \<Rightarrow> ('index,'bindex,'varSort,'var,'opSym)qTermItem"
where "absIn A == Inr A"

subsection {* Induction principles *}

definition qTermLess :: "('index,'bindex,'varSort,'var,'opSym)qTermItem rel"
where
"qTermLess == {(termIn X, termIn(qOp delta inp binp))| X delta inp binp i. inp i = Some X} \<union>
              {(absIn A, termIn(qOp delta inp binp))| A delta inp binp i. binp i = Some A} \<union>
              {(termIn X, absIn (qAbs xs x X))| X xs x. True}"

text{* This induction will be used only temporarily, until we
   get a better one, involving swapping:  *}

lemma qTerm_rawInduct[case_names Var Op Abs]:
fixes X :: "('index,'bindex,'varSort,'var,'opSym)qTerm" and
      A :: "('index,'bindex,'varSort,'var,'opSym)qAbs" and phi phiAbs
assumes
  Var: "\<And> xs x. phi (qVar xs x)" and
  Op: "\<And> delta inp binp. \<lbrakk>liftAll phi inp; liftAll phiAbs binp\<rbrakk> \<Longrightarrow> phi (qOp delta inp binp)" and
  Abs: "\<And> xs x X. phi X \<Longrightarrow> phiAbs (qAbs xs x X)"
shows "phi X \<and> phiAbs A"
by (induct rule: qTerm_qAbs.induct)
   (fastforce intro!: Var Op Abs rangeI simp: liftAll_def)+

lemma qTermLess_wf: "wf qTermLess"
unfolding wf_def proof safe
  fix chi item
  assume *: "\<forall>item. (\<forall>item'. (item', item) \<in> qTermLess \<longrightarrow> chi item') \<longrightarrow> chi item"
  show "chi item"
  proof-
    {fix X A
     have "chi (termIn X) \<and> chi (absIn A)"
     apply(induct rule: qTerm_rawInduct)
     using * unfolding qTermLess_def liftAll_def by blast+
    }
    thus ?thesis by(cases item) auto
  qed
qed

lemma qTermLessPlus_wf: "wf (qTermLess ^+)"
using qTermLess_wf wf_trancl by auto

text{* The skeleton of a quasi-term item -- this is the generalization
   of the size function from the case of finitary syntax.
   We use the skeleton later for proving correct various recursive function definitions, notably that of ``alpha". *}

function
qSkel :: "('index,'bindex,'varSort,'var,'opSym)qTerm \<Rightarrow> ('index,'bindex)tree"
and
qSkelAbs :: "('index,'bindex,'varSort,'var,'opSym)qAbs \<Rightarrow> ('index,'bindex)tree"
where
"qSkel (qVar xs x) = Branch (\<lambda>i. None) (\<lambda>i. None)"
|
"qSkel (qOp delta inp binp) = Branch (lift qSkel inp) (lift qSkelAbs binp)"
|
"qSkelAbs (qAbs xs x X) = Branch (\<lambda>i. Some(qSkel X)) (\<lambda>i. None)"
by(pat_completeness, auto)
termination by(relation qTermLess, simp add: qTermLess_wf, auto simp add: qTermLess_def)

text{* Next is a template for generating induction principles whenever we come up
  with relation on terms included in the kernel of the skeleton operator.  *}

lemma qTerm_templateInduct[case_names Var Op Abs]:
fixes X :: "('index,'bindex,'varSort,'var,'opSym)qTerm"
and A :: "('index,'bindex,'varSort,'var,'opSym)qAbs"
and phi phiAbs and rel
assumes
REL: "\<And> X Y. (X,Y) \<in> rel \<Longrightarrow> qSkel Y = qSkel X" and
Var: "\<And> xs x. phi (qVar xs x)" and
Op: "\<And> delta inp binp. \<lbrakk>liftAll phi inp; liftAll phiAbs binp\<rbrakk>
                       \<Longrightarrow> phi (qOp delta inp binp)" and
Abs: "\<And> xs x X. (\<And> Y. (X,Y) \<in> rel \<Longrightarrow> phi Y) \<Longrightarrow> phiAbs (qAbs xs x X)"
shows "phi X \<and> phiAbs A"
proof-
  {fix T
   have "\<forall> X A. (T = qSkel X \<longrightarrow> phi X) \<and> (T = qSkelAbs A \<longrightarrow> phiAbs A)"
   proof(induct rule: treeLess_induct)
     case (1 T')
     show ?case apply safe
      subgoal for X _
      using assms 1 unfolding treeLess_def liftAll_def
      by (cases X) (auto simp add: lift_def, metis option.simps(5))
     subgoal for _ A apply (cases A)
     using assms 1 unfolding treeLess_def by simp .
   qed
  }
  thus ?thesis by blast
qed

text{* A modification of the canonical immediate-subterm
relation on quasi-terms, that takes into account a relation assumed included in the skeleton kernel.  *}

definition qTermLess_modulo ::
"('index,'bindex,'varSort,'var,'opSym)qTerm rel \<Rightarrow>
 ('index,'bindex,'varSort,'var,'opSym)qTermItem rel"
where
"qTermLess_modulo rel ==
 {(termIn X, termIn(qOp delta inp binp))| X delta inp binp i. inp i = Some X} \<union>
 {(absIn A, termIn(qOp delta inp binp))| A delta inp binp j. binp j = Some A} \<union>
 {(termIn Y, absIn (qAbs xs x X))| X Y xs x. (X,Y) \<in> rel}"

lemma qTermLess_modulo_wf:
fixes rel::"('index,'bindex,'varSort,'var,'opSym)qTerm rel"
assumes "\<And> X Y. (X,Y) \<in> rel \<Longrightarrow> qSkel Y = qSkel X"
shows "wf (qTermLess_modulo rel)"
proof(unfold wf_def, auto)
  fix chi item
  assume *:
  "\<forall>item. (\<forall>item'. (item', item) \<in> qTermLess_modulo rel  \<longrightarrow> chi item')
           \<longrightarrow> chi item"
  show "chi item"
  proof-
    obtain phi where phi_def: "phi = (\<lambda> X. chi (termIn X))" by blast
    obtain phiAbs where phiAbs_def: "phiAbs = (\<lambda> A. chi (absIn A))" by blast
    {fix X A
     have "chi (termIn X) \<and> chi (absIn A)"
     apply(induct rule: qTerm_templateInduct[of rel])
     using * assms unfolding qTermLess_modulo_def liftAll_def by blast+
    }
    thus ?thesis unfolding phi_def phiAbs_def
    by(cases item, auto)
  qed
qed

subsection {* Swap and substitution on variables  *}

definition sw :: "'varSort \<Rightarrow> 'var \<Rightarrow> 'var \<Rightarrow> 'varSort \<Rightarrow> 'var \<Rightarrow> 'var"
where
"sw ys y1 y2 xs x ==
 if ys = xs then if x = y1 then y2
            else if x = y2 then y1
                           else x
 else x"

abbreviation sw_abbrev :: "'var \<Rightarrow> 'varSort \<Rightarrow> 'var \<Rightarrow> 'var \<Rightarrow> 'varSort \<Rightarrow> 'var"
("_ @_[_ \<and> _]'__" 200)
where "(x @xs[y1 \<and> y2]_ys) == sw ys y1 y2 xs x"

definition sb :: "'varSort \<Rightarrow> 'var \<Rightarrow> 'var \<Rightarrow> 'varSort \<Rightarrow> 'var \<Rightarrow> 'var"
where
"sb ys y1 y2 xs x ==
 if ys = xs then if x = y2 then y1
                           else x
 else x"

abbreviation sb_abbrev :: "'var \<Rightarrow> 'varSort \<Rightarrow> 'var \<Rightarrow> 'var \<Rightarrow> 'varSort \<Rightarrow> 'var"
("_ @_[_ '/ _]'__" 200)
where "(x @xs[y1 / y2]_ys) == sb ys y1 y2 xs x"

theorem sw_simps1[simp]: "(x @xs[x \<and> y]_xs) = y"
unfolding sw_def by simp

theorem sw_simps2[simp]: "(x @xs[y \<and> x]_xs) = y"
unfolding sw_def by simp

theorem sw_simps3[simp]:
"(zs \<noteq> xs \<or> x \<notin> {z1,z2}) \<Longrightarrow> (x @xs[z1 \<and> z2]_zs) = x"
unfolding sw_def by simp

lemmas sw_simps = sw_simps1 sw_simps2 sw_simps3

theorem sw_ident[simp]: "(x @xs[y \<and> y]_ys) = x"
unfolding sw_def by auto

theorem sw_compose:
"((z @zs[x \<and> y]_xs) @zs[x' \<and> y']_xs') =
 ((z @zs[x' \<and> y']_xs') @zs[(x @xs[x' \<and> y']_xs') \<and> (y @xs[x' \<and> y']_xs')]_xs)"
by(unfold sw_def, auto)

theorem sw_commute:
assumes "zs \<noteq> zs' \<or> {x,y} Int {x',y'} = {}"
shows "((u @us[x \<and> y]_zs) @us[x' \<and> y']_zs') = ((u @us[x' \<and> y']_zs') @us[x \<and> y]_zs)"
using assms by(unfold sw_def, auto)

theorem sw_involutive[simp]:
"((z @zs[x \<and> y]_xs) @zs[x \<and> y]_xs) = z"
by(unfold sw_def, auto)

theorem sw_inj[simp]:
"((z @zs[x \<and> y]_xs) = (z' @zs[x \<and> y]_xs)) = (z = z')"
by (simp add: sw_def)

lemma sw_preserves_mship[simp]:
assumes "{y1,y2} \<subseteq> Var ys"
shows "((x @xs[y1 \<and> y2]_ys) \<in> Var xs) = (x \<in> Var xs)"
using assms unfolding sw_def by auto

theorem sw_sym:
"(z @zs[x \<and> y]_xs) = (z @zs[y \<and> x]_xs)"
by (unfold sw_def) auto

theorem sw_involutive2[simp]:
"((z @zs[x \<and> y]_xs) @zs[y \<and> x]_xs) = z"
by (unfold sw_def) auto

theorem sw_trans:
"us \<noteq> zs \<or> u \<notin> {y,z} \<Longrightarrow>
 ((u @us[y \<and> x]_zs) @us[z \<and> y]_zs) = (u @us[z \<and> x]_zs)"
by (unfold sw_def) auto

lemmas sw_otherSimps =
sw_ident sw_involutive sw_inj sw_preserves_mship sw_involutive2

theorem sb_simps1[simp]: "(x @xs[y / x]_xs) = y"
unfolding sb_def by simp

theorem sb_simps2[simp]:
"(zs \<noteq> xs \<or> z2 \<noteq> x) \<Longrightarrow> (x @xs[z1 / z2]_zs) = x"
unfolding sb_def by auto

lemmas sb_simps = sb_simps1 sb_simps2

theorem sb_ident[simp]: "(x @xs[y / y]_ys) = x"
unfolding sb_def by auto

theorem sb_compose1:
"((z @zs[y1 / x]_xs) @zs[y2 / x]_xs) = (z @zs[(y1 @xs[y2 / x]_xs) / x]_xs)"
by(unfold sb_def, auto)

theorem sb_compose2:
"ys \<noteq> xs \<or> (x2 \<notin> {y1,y2}) \<Longrightarrow>
 ((z @zs[x1 / x2]_xs) @zs[y1 / y2]_ys) =
 ((z @zs[y1 / y2]_ys) @zs[(x1 @xs[y1 / y2]_ys) / x2]_xs)"
by (unfold sb_def) auto

theorem sb_commute:
assumes "zs \<noteq> zs' \<or> {x,y} Int {x',y'} = {}"
shows "((u @us[x / y]_zs) @us[x' / y']_zs') = ((u @us[x' / y']_zs') @us[x / y]_zs)"
using assms by (unfold sb_def) auto

theorem sb_idem[simp]:
"((z @zs[x / y]_xs) @zs[x / y]_xs) = (z @zs[x / y]_xs)"
by (unfold sb_def) auto

lemma sb_preserves_mship[simp]:
assumes "{y1,y2} \<subseteq> Var ys"
shows "((x @xs[y1 / y2]_ys) \<in> Var xs) = (x \<in> Var xs)"
using assms by (unfold sb_def) auto

theorem sb_trans:
"us \<noteq> zs \<or> u \<noteq> y \<Longrightarrow>
 ((u @us[y / x]_zs) @us[z / y]_zs) = (u @us[z / x]_zs)"
by (unfold sb_def) auto

lemmas sb_otherSimps =
sb_ident sb_idem sb_preserves_mship

subsection {* The swapping and freshness operators *}

text {* For establishing the preliminary results quickly, we use both the notion of
binding-sensitive freshness (operator ``qFresh")
       and that of ``absolute" freshness, ignoring bindings (operator ``qAFresh").  Later,
       for alpha-equivalence classes, ``qAFresh" will not make sense.  *}

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

lemma qTermLess_ingoreFirst3_wf:
"wf(inv_image qTermLess aux_qSwap_ignoreFirst3)"
using qTermLess_wf wf_inv_image by auto

function
qSwap :: "'varSort \<Rightarrow> 'var \<Rightarrow> 'var \<Rightarrow> ('index,'bindex,'varSort,'var,'opSym)qTerm \<Rightarrow>
          ('index,'bindex,'varSort,'var,'opSym)qTerm"
and
qSwapAbs :: "'varSort \<Rightarrow> 'var \<Rightarrow> 'var \<Rightarrow> ('index,'bindex,'varSort,'var,'opSym)qAbs \<Rightarrow>
             ('index,'bindex,'varSort,'var,'opSym)qAbs"
where
"qSwap zs x y (qVar zs' z) = qVar zs' (z @zs'[x \<and> y]_zs)"
|
"qSwap zs x y (qOp delta inp binp) =
 qOp delta (lift (qSwap zs x y) inp) (lift (qSwapAbs zs x y) binp)"
|
"qSwapAbs zs x y (qAbs zs' z X) = qAbs zs' (z @zs'[x \<and> y]_zs) (qSwap zs x y X)"
by(pat_completeness, auto)
termination
by(relation "inv_image qTermLess aux_qSwap_ignoreFirst3",
   simp add: qTermLess_ingoreFirst3_wf,
   auto simp add: qTermLess_def aux_qSwap_ignoreFirst3_def)

lemmas qSwapAll_simps = qSwap.simps qSwapAbs.simps

abbreviation qSwap_abbrev ::
  "('index,'bindex,'varSort,'var,'opSym)qTerm \<Rightarrow> 'var \<Rightarrow> 'var \<Rightarrow> 'varSort \<Rightarrow>
   ('index,'bindex,'varSort,'var,'opSym)qTerm" ("_ #[[_ \<and> _]]'__" 200)
where "(X #[[z1 \<and> z2]]_zs) == qSwap zs z1 z2 X"

abbreviation qSwapAbs_abbrev ::
  "('index,'bindex,'varSort,'var,'opSym)qAbs \<Rightarrow> 'var \<Rightarrow> 'var \<Rightarrow> 'varSort \<Rightarrow>
   ('index,'bindex,'varSort,'var,'opSym)qAbs" ("_ $[[_ \<and> _]]'__" 200)
where "(A $[[z1 \<and> z2]]_zs) == qSwapAbs zs z1 z2 A"

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

lemma qTermLess_ingoreFirst2_wf: "wf(inv_image qTermLess aux_qFresh_ignoreFirst2)"
using qTermLess_wf wf_inv_image by auto

text{* The quasi absolutely-fresh predicate:
  (note that this is not an oxymoron: ``quasi" refers
   to being an operator on quasi-terms, and not on
terms, i.e., on alpha-equivalence  classes;
   ``absolutely'' refers to not ignoring bindings in the notion of freshness,
and thus counting absolutely all the variables. *}

function
qAFresh :: "'varSort \<Rightarrow> 'var \<Rightarrow> ('index,'bindex,'varSort,'var,'opSym)qTerm \<Rightarrow> bool"
and
qAFreshAbs :: "'varSort \<Rightarrow> 'var \<Rightarrow> ('index,'bindex,'varSort,'var,'opSym)qAbs \<Rightarrow> bool"
where
"qAFresh xs x (qVar ys y) = (xs \<noteq> ys \<or> x \<noteq> y)"
|
"qAFresh xs x (qOp delta inp binp) =
 (liftAll (qAFresh xs x) inp \<and> liftAll (qAFreshAbs xs x) binp)"
|
"qAFreshAbs xs x (qAbs ys y X) = ((xs \<noteq> ys \<or> x \<noteq> y) \<and> qAFresh xs x X)"
by(pat_completeness, auto)
termination
by(relation "inv_image qTermLess aux_qFresh_ignoreFirst2",
   simp add: qTermLess_ingoreFirst2_wf,
   auto simp add: qTermLess_def aux_qFresh_ignoreFirst2_def)

lemmas qAFreshAll_simps = qAFresh.simps qAFreshAbs.simps

text{* The next is standard freshness -- note that its definition differs from that
of absolute freshness only at the clause for abstractions.  *}

function
qFresh :: "'varSort \<Rightarrow> 'var \<Rightarrow> ('index,'bindex,'varSort,'var,'opSym)qTerm \<Rightarrow> bool"
and
qFreshAbs :: "'varSort \<Rightarrow> 'var \<Rightarrow> ('index,'bindex,'varSort,'var,'opSym)qAbs \<Rightarrow> bool"
where
"qFresh xs x (qVar ys y) = (xs \<noteq> ys \<or> x \<noteq> y)"
|
"qFresh xs x (qOp delta inp binp) =
 (liftAll (qFresh xs x) inp \<and> liftAll (qFreshAbs xs x) binp)"
|
"qFreshAbs xs x (qAbs ys y X) = ((xs = ys \<and> x = y) \<or> qFresh xs x X)"
by(pat_completeness, auto)
termination
by(relation "inv_image qTermLess aux_qFresh_ignoreFirst2",
   simp add: qTermLess_ingoreFirst2_wf,
   auto simp add: qTermLess_def aux_qFresh_ignoreFirst2_def)

lemmas qFreshAll_simps = qFresh.simps qFreshAbs.simps

subsection {* Compositional properties of swapping  *}

lemma qSwapAll_ident:
fixes X::"('index,'bindex,'varSort,'var,'opSym)qTerm" and
      A::"('index,'bindex,'varSort,'var,'opSym)qAbs"
    shows "(X #[[x \<and> x]]_zs) = X \<and> (A $[[x \<and> x]]_zs) = A"
  by (induct rule: qTerm_rawInduct)
     (auto simp add: liftAll_def lift_cong lift_ident)

corollary qSwap_ident[simp]: "(X #[[x \<and> x]]_zs) = X"
by(simp add: qSwapAll_ident)

lemma qSwapAll_compose:
fixes X::"('index,'bindex,'varSort,'var,'opSym)qTerm"  and
      A::"('index,'bindex,'varSort,'var,'opSym)qAbs" and zs x y x' y'
shows
"((X #[[x \<and> y]]_zs) #[[x' \<and> y']]_zs') =
 ((X #[[x' \<and> y']]_zs') #[[(x @zs[x' \<and> y']_zs') \<and> (y @zs[x' \<and> y']_zs')]]_zs)
\<and>
 ((A $[[x \<and> y]]_zs) $[[x' \<and> y']]_zs') =
 ((A $[[x' \<and> y']]_zs') $[[(x @zs[x' \<and> y']_zs') \<and> (y @zs[x' \<and> y']_zs')]]_zs)"
proof(induct rule: qTerm_rawInduct[of _ _ X A])
  case (Op delta inp binp)
  then show ?case by (auto intro!: lift_cong simp: liftAll_def lift_comp)
qed (auto simp add: sw_def sw_compose)

corollary qSwap_compose:
"((X #[[x \<and> y]]_zs) #[[x' \<and> y']]_zs') =
 ((X #[[x' \<and> y']]_zs') #[[(x @zs[x' \<and> y']_zs') \<and> (y @zs[x' \<and> y']_zs')]]_zs)"
by (meson qSwapAll_compose)

lemma qSwap_commute:
assumes "zs \<noteq> zs' \<or> {x,y} Int {x',y'} = {}"
shows "((X #[[x \<and> y]]_zs) #[[x' \<and> y']]_zs') = ((X #[[x' \<and> y']]_zs') #[[x \<and> y]]_zs)"
by (metis assms disjoint_insert(1) qSwapAll_compose sw_simps3)

lemma qSwapAll_involutive:
fixes X::"('index,'bindex,'varSort,'var,'opSym)qTerm" and
      A::"('index,'bindex,'varSort,'var,'opSym)qAbs" and zs x y
shows "((X #[[x \<and> y]]_zs) #[[x \<and> y]]_zs) = X \<and>
       ((A $[[x \<and> y]]_zs) $[[x \<and> y]]_zs) = A"
proof(induct rule: qTerm_rawInduct[of _ _ X A])
  case (Op delta inp binp)
  then show ?case
    unfolding qSwapAll_simps(2) liftAll_lift_ext
    lift_comp o_def
    by (simp add: lift_ident)
qed(auto)

corollary qSwap_involutive[simp]:
"((X #[[x \<and> y]]_zs) #[[x \<and> y]]_zs) = X"
by(simp add: qSwapAll_involutive)

lemma qSwapAll_sym:
fixes X::"('index,'bindex,'varSort,'var,'opSym)qTerm" and
      A::"('index,'bindex,'varSort,'var,'opSym)qAbs" and zs x y
shows "(X #[[x \<and> y]]_zs) = (X #[[y \<and> x]]_zs) \<and>
       (A $[[x \<and> y]]_zs) = (A $[[y \<and> x]]_zs)"
by (induct rule: qTerm_rawInduct[of _ _ X A])
   (auto simp: sw_sym lift_comp liftAll_lift_ext)

corollary qSwap_sym:
"(X #[[x \<and> y]]_zs) = (X #[[y \<and> x]]_zs)"
by(simp add: qSwapAll_sym)

lemma qAFreshAll_qSwapAll_id:
fixes X::"('index,'bindex,'varSort,'var,'opSym)qTerm" and
      A::"('index,'bindex,'varSort,'var,'opSym)qAbs" and zs z1 z2
shows "(qAFresh zs z1 X \<and> qAFresh zs z2 X  \<longrightarrow> (X #[[z1 \<and> z2]]_zs) = X) \<and>
       (qAFreshAbs zs z1 A \<and> qAFreshAbs zs z2 A  \<longrightarrow> (A $[[z1 \<and> z2]]_zs) = A)"
by (induct rule: qTerm_rawInduct[of _ _ X A])
   (auto intro!: ext simp: liftAll_def lift_def option.case_eq_if)

corollary qAFresh_qSwap_id[simp]:
"\<lbrakk>qAFresh zs z1 X; qAFresh zs z2 X\<rbrakk>  \<Longrightarrow> (X #[[z1 \<and> z2]]_zs) = X"
by(simp add: qAFreshAll_qSwapAll_id)

lemma qAFreshAll_qSwapAll_compose:
fixes X::"('index,'bindex,'varSort,'var,'opSym)qTerm" and
      A::"('index,'bindex,'varSort,'var,'opSym)qAbs"and zs x y z
shows  "(qAFresh zs y X \<and> qAFresh zs z X \<longrightarrow>
         ((X #[[y \<and> x]]_zs) #[[z \<and> y]]_zs) = (X #[[z \<and> x]]_zs)) \<and>
        (qAFreshAbs zs y A \<and> qAFreshAbs zs z A \<longrightarrow>
         ((A $[[y \<and> x]]_zs) $[[z \<and> y]]_zs) = (A $[[z \<and> x]]_zs))"
by (induct rule: qTerm_rawInduct[of _ _ X A])
   (auto intro!: ext simp: sw_trans lift_comp lift_def liftAll_def option.case_eq_if)

corollary qAFresh_qSwap_compose:
"\<lbrakk>qAFresh zs y X; qAFresh zs z X\<rbrakk> \<Longrightarrow>
 ((X #[[y \<and> x]]_zs) #[[z \<and> y]]_zs) = (X #[[z \<and> x]]_zs)"
by(simp add: qAFreshAll_qSwapAll_compose)

subsection {* Induction and well-foundedness modulo swapping  *}

lemma qSkel_qSwapAll:
fixes  X::"('index,'bindex,'varSort,'var,'opSym)qTerm" and
       A::"('index,'bindex,'varSort,'var,'opSym)qAbs" and x y zs
shows "qSkel(X #[[x \<and> y]]_zs) = qSkel X \<and>
       qSkelAbs(A $[[x \<and> y]]_zs) = qSkelAbs A"
proof(induct rule: qTerm_rawInduct[of _ _ X A])
  case (Op delta inp binp)
  then show ?case
    unfolding qSwapAll_simps(2) liftAll_lift_ext qSkel.simps(2)
    lift_comp comp_apply by simp
qed auto

corollary qSkel_qSwap: "qSkel(X #[[x \<and> y]]_zs) = qSkel X"
by(simp add: qSkel_qSwapAll)

text{*
  For induction modulo swapping, one may wish to swap not just once,
   but several times at the
   induction hypothesis (an example of this will be the proof of compatibility
   of ``qSwap" with alpha) -- for this, we introduce the following relation
  (the suffix ``Raw" signifies the fact that the involved variables are
  not required to be well-sorted):   *}

inductive_set qSwapped :: "('index,'bindex,'varSort,'var,'opSym)qTerm rel"
where
Refl: "(X,X) \<in> qSwapped"
|
Trans: "\<lbrakk>(X,Y) \<in> qSwapped; (Y,Z) \<in> qSwapped\<rbrakk> \<Longrightarrow> (X,Z) \<in> qSwapped"
|
Swap: "(X,Y) \<in> qSwapped \<Longrightarrow> (X, Y #[[x \<and> y]]_zs) \<in> qSwapped"

lemmas qSwapped_Clauses = qSwapped.Refl qSwapped.Trans qSwapped.Swap

lemma qSwap_qSwapped: "(X, X #[[x \<and> y]]_zs): qSwapped"
by (auto simp add: qSwapped_Clauses)

lemma qSwapped_qSkel:
"(X,Y) \<in> qSwapped  \<Longrightarrow> qSkel Y = qSkel X"
by(erule qSwapped.induct, auto simp add: qSkel_qSwap)

text{* The following is henceforth our main induction principle for quasi-terms.  At the
 clause for abstractions, the user may choose among the two
 induction hypotheses (IHs):
 \\-(1) IH for all swapped terms
 \\-(2) IH for all terms with the same skeleton.

The user may choose only one of the above, and ignore the others, but may of course also
assume both.  (2) is stronger than (1),
but we offer both of them for convenience in proofs.
Most of the times, (1) will be the most convenient. *}

lemma qTerm_induct[case_names Var Op Abs]:
fixes X :: "('index,'bindex,'varSort,'var,'opSym)qTerm"
and A :: "('index,'bindex,'varSort,'var,'opSym)qAbs"  and phi phiAbs
assumes
  Var: "\<And> xs x. phi (qVar xs x)" and
  Op: "\<And> delta inp binp. \<lbrakk>liftAll phi inp; liftAll phiAbs binp\<rbrakk>
                         \<Longrightarrow> phi (qOp delta inp binp)" and
  Abs: "\<And> xs x X. \<lbrakk>\<And> Y. (X,Y) \<in> qSwapped \<Longrightarrow> phi Y;
                    \<And> Y. qSkel Y = qSkel X \<Longrightarrow> phi Y\<rbrakk>
                    \<Longrightarrow> phiAbs (qAbs xs x X)"
shows "phi X \<and> phiAbs A"
  by (induct rule: qTerm_templateInduct[of "qSwapped \<union> {(X,Y). qSkel Y = qSkel X}"],
      auto simp add: qSwapped_qSkel assms)

text{* The following relation will be needed for proving alpha-equivalence well-defined: *}

definition qTermQSwappedLess :: "('index,'bindex,'varSort,'var,'opSym)qTermItem rel"
where "qTermQSwappedLess = qTermLess_modulo qSwapped"

lemma qTermQSwappedLess_wf: "wf qTermQSwappedLess"
unfolding qTermQSwappedLess_def
using qSwapped_qSkel qTermLess_modulo_wf[of qSwapped] by blast

subsection{* More properties connecting swapping and freshness *}

lemma qSwap_3commute:
assumes *: "qAFresh ys y X" and **: "qAFresh ys y0 X"
and ***: "ys \<noteq> zs \<or> y0 \<notin> {z1,z2}"
shows "((X #[[z1 \<and> z2]]_zs) #[[y0 \<and> x @ys[z1 \<and> z2]_zs]]_ys) =
       (((X #[[y \<and> x]]_ys) #[[y0 \<and> y]]_ys) #[[z1 \<and> z2]]_zs)"
proof-
  have "y0 = (y0 @ys[z1 \<and> z2]_zs)" using *** unfolding sw_def by auto
  hence "((X #[[z1 \<and> z2]]_zs) #[[y0 \<and> x @ys[z1 \<and> z2]_zs]]_ys) =
         ((X #[[y0 \<and> x]]_ys) #[[z1 \<and> z2]]_zs)"
  by(simp add: qSwap_compose[of _ z1])
  also have "((X #[[y0 \<and> x]]_ys) #[[z1 \<and> z2]]_zs) =
             (((X #[[y \<and> x]]_ys) #[[y0 \<and> y]]_ys) #[[z1 \<and> z2]]_zs)"
  using * ** by (simp add: qAFresh_qSwap_compose)
  finally show ?thesis .
qed

lemma qAFreshAll_imp_qFreshAll:
fixes X::"('index,'bindex,'varSort,'var,'opSym)qTerm" and
      A::"('index,'bindex,'varSort,'var,'opSym)qAbs" and xs x
shows "(qAFresh xs x X \<longrightarrow> qFresh xs x X) \<and>
       (qAFreshAbs xs x A \<longrightarrow> qFreshAbs xs x A)"
by(induct rule: qTerm_rawInduct, auto simp add: liftAll_def)

corollary qAFresh_imp_qFresh:
"qAFresh xs x X \<Longrightarrow> qFresh xs x X"
by(simp add: qAFreshAll_imp_qFreshAll)

lemma qSwapAll_preserves_qAFreshAll:
fixes X::"('index,'bindex,'varSort,'var,'opSym)qTerm" and
      A::"('index,'bindex,'varSort,'var,'opSym)qAbs" and ys y zs z1 z2
shows
"(qAFresh ys (y @ys[z1 \<and> z2]_zs) (X #[[z1 \<and> z2]]_zs) = qAFresh ys y X) \<and>
 (qAFreshAbs ys (y @ys[z1 \<and> z2]_zs) (A $[[z1 \<and> z2]]_zs) = qAFreshAbs ys y A)"
proof(induct rule: qTerm_rawInduct[of _ _ X A])
  case (Op delta inp binp)
  then show ?case
    unfolding qAFreshAll_simps(2) qSwapAll_simps(2) liftAll_lift_comp o_def
    unfolding liftAll_def by presburger
qed(auto simp add: sw_def)

corollary qSwap_preserves_qAFresh[simp]:
"(qAFresh ys (y @ys[z1 \<and> z2]_zs) (X #[[z1 \<and> z2]]_zs) = qAFresh ys y X)"
by(simp add: qSwapAll_preserves_qAFreshAll)

lemma qSwap_preserves_qAFresh_distinct:
assumes "ys \<noteq> zs \<or> y \<notin> {z1,z2}"
shows "qAFresh ys y (X #[[z1 \<and> z2]]_zs) = qAFresh ys y X"
proof-
  have "y = (y @ys[z1 \<and> z2]_zs)" using assms unfolding sw_def by auto
  thus ?thesis using qSwap_preserves_qAFresh[of ys zs z1 z2 y] by auto
qed

lemma qAFresh_qSwap_exchange1:
"qAFresh zs z2 (X #[[z1 \<and> z2]]_zs) = qAFresh zs z1 X"
proof-
  have "z2 = (z1 @zs[z1 \<and> z2]_zs)" unfolding sw_def by auto
  thus ?thesis using qSwap_preserves_qAFresh[of zs zs z1 z2 z1 X] by auto
qed

lemma qAFresh_qSwap_exchange2:
"qAFresh zs z2 (X #[[z2 \<and> z1]]_zs) = qAFresh zs z1 X"
by(auto simp add: qAFresh_qSwap_exchange1 qSwap_sym)

lemma qSwapAll_preserves_qFreshAll:
fixes X::"('index,'bindex,'varSort,'var,'opSym)qTerm" and
      A::"('index,'bindex,'varSort,'var,'opSym)qAbs" and ys y zs z1 z2
shows
"(qFresh ys (y @ys[z1 \<and> z2]_zs) (X #[[z1 \<and> z2]]_zs) = qFresh ys y X) \<and>
 (qFreshAbs ys (y @ys[z1 \<and> z2]_zs) (A $[[z1 \<and> z2]]_zs) = qFreshAbs ys y A)"
proof(induct rule: qTerm_rawInduct[of _ _ X A])
  case (Op delta inp binp)
  then show ?case
   unfolding qFreshAll_simps(2) qSwapAll_simps(2) liftAll_lift_comp o_def
   unfolding liftAll_def by presburger
qed (auto simp add: sw_def)

corollary qSwap_preserves_qFresh:
"(qFresh ys (y @ys[z1 \<and> z2]_zs) (X #[[z1 \<and> z2]]_zs) = qFresh ys y X)"
by(simp add: qSwapAll_preserves_qFreshAll)

lemma qSwap_preserves_qFresh_distinct:
assumes "ys \<noteq> zs \<or> y \<notin> {z1,z2}"
shows "qFresh ys y (X #[[z1 \<and> z2]]_zs) = qFresh ys y X"
proof-
  have "y = (y @ys[z1 \<and> z2]_zs)" using assms unfolding sw_def by auto
  thus ?thesis using qSwap_preserves_qFresh[of ys zs z1 z2 y] by auto
qed

lemma qFresh_qSwap_exchange1:
"qFresh zs z2 (X #[[z1 \<and> z2]]_zs) = qFresh zs z1 X"
proof-
  have "z2 = (z1 @zs[z1 \<and> z2]_zs)" unfolding sw_def by auto
  thus ?thesis using qSwap_preserves_qFresh[of zs zs z1 z2 z1 X] by auto
qed

lemma qFresh_qSwap_exchange2:
"qFresh zs z1 X = qFresh zs z2 (X #[[z2 \<and> z1]]_zs)"
by (auto simp add: qFresh_qSwap_exchange1 qSwap_sym)

lemmas qSwap_qAFresh_otherSimps =
qSwap_ident qSwap_involutive qAFresh_qSwap_id qSwap_preserves_qAFresh

end


section \<open>Parametricity Theorems for HOL\<close>
theory Param_HOL
imports Param_Tool
begin

subsection \<open>Sets\<close>

lemma param_empty[param]:
  "({},{})\<in>\<langle>R\<rangle>set_rel" by (auto simp: set_rel_def)

lemma param_member[param]:
  "\<lbrakk>single_valued R; single_valued (R\<inverse>)\<rbrakk> \<Longrightarrow> ((\<in>), (\<in>)) \<in> R \<rightarrow> \<langle>R\<rangle>set_rel \<rightarrow> bool_rel"
  unfolding set_rel_def
  by (blast dest: single_valuedD)

lemma param_insert[param]:
  "(insert,insert)\<in>R\<rightarrow>\<langle>R\<rangle>set_rel\<rightarrow>\<langle>R\<rangle>set_rel"
  by (auto simp: set_rel_def)

lemma param_union[param]:
  "((\<union>), (\<union>)) \<in> \<langle>R\<rangle>set_rel \<rightarrow> \<langle>R\<rangle>set_rel \<rightarrow> \<langle>R\<rangle>set_rel"
  by (auto simp: set_rel_def)

lemma param_inter[param]:
  assumes "single_valued R" "single_valued (R\<inverse>)"
  shows "((\<inter>), (\<inter>)) \<in> \<langle>R\<rangle>set_rel \<rightarrow> \<langle>R\<rangle>set_rel \<rightarrow> \<langle>R\<rangle>set_rel"
  using assms
  unfolding set_rel_def
  by (blast dest: single_valuedD)

lemma param_diff[param]:
  assumes "single_valued R" "single_valued (R\<inverse>)"
  shows "((-), (-)) \<in> \<langle>R\<rangle>set_rel \<rightarrow> \<langle>R\<rangle>set_rel \<rightarrow> \<langle>R\<rangle>set_rel"
  using assms
  unfolding set_rel_def
  by (blast dest: single_valuedD)

lemma param_subseteq[param]:
  "\<lbrakk>single_valued R; single_valued (R\<inverse>)\<rbrakk> \<Longrightarrow> ((\<subseteq>), (\<subseteq>)) \<in> \<langle>R\<rangle>set_rel \<rightarrow> \<langle>R\<rangle>set_rel \<rightarrow> bool_rel"
  unfolding set_rel_def
  by (blast dest: single_valuedD)

lemma param_subset[param]:
  "\<lbrakk>single_valued R; single_valued (R\<inverse>)\<rbrakk> \<Longrightarrow> ((\<subset>), (\<subset>)) \<in> \<langle>R\<rangle>set_rel \<rightarrow> \<langle>R\<rangle>set_rel \<rightarrow> bool_rel"
  unfolding set_rel_def
  by (blast dest: single_valuedD)

lemma param_Ball[param]: "(Ball,Ball)\<in>\<langle>Ra\<rangle>set_rel\<rightarrow>(Ra\<rightarrow>Id)\<rightarrow>Id"
  by (force simp: set_rel_alt dest: fun_relD)

lemma param_Bex[param]: "(Bex,Bex)\<in>\<langle>Ra\<rangle>set_rel\<rightarrow>(Ra\<rightarrow>Id)\<rightarrow>Id"
  by (fastforce simp: set_rel_def dest: fun_relD)

lemma param_set[param]:
  "single_valued Ra \<Longrightarrow> (set,set)\<in>\<langle>Ra\<rangle>list_rel \<rightarrow> \<langle>Ra\<rangle>set_rel"
proof
  fix l l'
  assume A: "single_valued Ra"
  assume "(l,l')\<in>\<langle>Ra\<rangle>list_rel"
  thus "(set l, set l')\<in>\<langle>Ra\<rangle>set_rel"
    apply (induct)
    apply simp
    apply simp
    using A apply (parametricity)
    done
qed

lemma param_Collect[param]:
  "\<lbrakk>Domain A = UNIV; Range A = UNIV\<rbrakk> \<Longrightarrow> (Collect,Collect)\<in>(A\<rightarrow>bool_rel) \<rightarrow> \<langle>A\<rangle>set_rel"
  unfolding set_rel_def
  apply (clarsimp; safe)
  subgoal using fun_relD1 by fastforce
  subgoal using fun_relD2 by fastforce
  done

lemma param_finite[param]: "\<lbrakk>
    single_valued R; single_valued (R\<inverse>)
  \<rbrakk> \<Longrightarrow> (finite,finite) \<in> \<langle>R\<rangle>set_rel \<rightarrow> bool_rel"
  using finite_set_rel_transfer finite_set_rel_transfer_back by blast

subsection \<open>Standard HOL Constructs\<close>

lemma param_if[param]:
  assumes "(c,c')\<in>Id"
  assumes "\<lbrakk>c;c'\<rbrakk> \<Longrightarrow> (t,t')\<in>R"
  assumes "\<lbrakk>\<not>c;\<not>c'\<rbrakk> \<Longrightarrow> (e,e')\<in>R"
  shows "(If c t e, If c' t' e')\<in>R"
  using assms by auto

lemma param_Let[param]:
  "(Let,Let)\<in>Ra \<rightarrow> (Ra\<rightarrow>Rr) \<rightarrow> Rr"
  by (auto dest: fun_relD)

subsection \<open>Functions\<close>

lemma param_id[param]: "(id,id)\<in>R\<rightarrow>R" unfolding id_def by parametricity

lemma param_fun_comp[param]: "((o), (o)) \<in> (Ra\<rightarrow>Rb) \<rightarrow> (Rc\<rightarrow>Ra) \<rightarrow> Rc\<rightarrow>Rb"
  unfolding comp_def[abs_def] by parametricity

lemma param_fun_upd[param]: "
  ((=), (=)) \<in> Ra\<rightarrow>Ra\<rightarrow>Id
  \<Longrightarrow> (fun_upd,fun_upd) \<in> (Ra\<rightarrow>Rb) \<rightarrow> Ra \<rightarrow> Rb \<rightarrow> Ra \<rightarrow> Rb"
  unfolding fun_upd_def[abs_def]
  by (parametricity)

subsection \<open>Boolean\<close>

lemma rec_bool_is_case: "old.rec_bool = case_bool"
  by (rule ext)+ (auto split: bool.split)

lemma param_bool[param]:
  "(True,True)\<in>Id"
  "(False,False)\<in>Id"
  "(conj,conj)\<in>Id\<rightarrow>Id\<rightarrow>Id"
  "(disj,disj)\<in>Id\<rightarrow>Id\<rightarrow>Id"
  "(Not,Not)\<in>Id\<rightarrow>Id"
  "(case_bool,case_bool)\<in>R\<rightarrow>R\<rightarrow>Id\<rightarrow>R"
  "(old.rec_bool,old.rec_bool)\<in>R\<rightarrow>R\<rightarrow>Id\<rightarrow>R"
  "((\<longleftrightarrow>), (\<longleftrightarrow>))\<in>Id\<rightarrow>Id\<rightarrow>Id"
  "((\<longrightarrow>), (\<longrightarrow>))\<in>Id\<rightarrow>Id\<rightarrow>Id"
  by (auto split: bool.split simp: rec_bool_is_case)

lemma param_and_cong1: "\<lbrakk> (a,a')\<in>bool_rel; \<lbrakk>a; a'\<rbrakk> \<Longrightarrow> (b,b')\<in>bool_rel \<rbrakk> \<Longrightarrow> (a\<and>b,a'\<and>b')\<in>bool_rel"
  by blast
lemma param_and_cong2: "\<lbrakk> (a,a')\<in>bool_rel; \<lbrakk>a; a'\<rbrakk> \<Longrightarrow> (b,b')\<in>bool_rel \<rbrakk> \<Longrightarrow> (b\<and>a,b'\<and>a')\<in>bool_rel"
  by blast

subsection \<open>Nat\<close>

lemma param_nat1[param]:
  "(0, 0::nat) \<in> Id"
  "(Suc, Suc) \<in> Id \<rightarrow> Id"
  "(1, 1::nat) \<in> Id"
  "(numeral n::nat,numeral n::nat) \<in> Id"
  "((<), (<) ::nat \<Rightarrow> _) \<in> Id \<rightarrow> Id \<rightarrow> Id"
  "((\<le>), (\<le>) ::nat \<Rightarrow> _) \<in> Id \<rightarrow> Id \<rightarrow> Id"
  "((=), (=) ::nat \<Rightarrow> _) \<in> Id \<rightarrow> Id \<rightarrow> Id"
  "((+) ::nat\<Rightarrow>_,(+))\<in>Id\<rightarrow>Id\<rightarrow>Id"
  "((-) ::nat\<Rightarrow>_,(-))\<in>Id\<rightarrow>Id\<rightarrow>Id"
  "((*) ::nat\<Rightarrow>_,(*))\<in>Id\<rightarrow>Id\<rightarrow>Id"
  "((div) ::nat\<Rightarrow>_,(div))\<in>Id\<rightarrow>Id\<rightarrow>Id"
  "((mod) ::nat\<Rightarrow>_,(mod))\<in>Id\<rightarrow>Id\<rightarrow>Id"
  by auto

lemma param_case_nat[param]:
  "(case_nat,case_nat)\<in>Ra \<rightarrow> (Id \<rightarrow> Ra) \<rightarrow> Id \<rightarrow> Ra"
  apply (intro fun_relI)
  apply (auto split: nat.split dest: fun_relD)
  done

lemma param_rec_nat[param]:
  "(rec_nat,rec_nat) \<in> R \<rightarrow> (Id \<rightarrow> R \<rightarrow> R) \<rightarrow> Id \<rightarrow> R"
proof (intro fun_relI, goal_cases)
  case (1 s s' f f' n n') thus ?case
    apply (induct n' arbitrary: n s s')
    apply (fastforce simp: fun_rel_def)+
    done
qed

subsection \<open>Int\<close>

lemma param_int[param]:
  "(0, 0::int) \<in> Id"
  "(1, 1::int) \<in> Id"
  "(numeral n::int,numeral n::int) \<in> Id"
  "((<), (<) ::int \<Rightarrow> _) \<in> Id \<rightarrow> Id \<rightarrow> Id"
  "((\<le>), (\<le>) ::int \<Rightarrow> _) \<in> Id \<rightarrow> Id \<rightarrow> Id"
  "((=), (=) ::int \<Rightarrow> _) \<in> Id \<rightarrow> Id \<rightarrow> Id"
  "((+) ::int\<Rightarrow>_,(+))\<in>Id\<rightarrow>Id\<rightarrow>Id"
  "((-) ::int\<Rightarrow>_,(-))\<in>Id\<rightarrow>Id\<rightarrow>Id"
  "((*) ::int\<Rightarrow>_,(*))\<in>Id\<rightarrow>Id\<rightarrow>Id"
  "((div) ::int\<Rightarrow>_,(div))\<in>Id\<rightarrow>Id\<rightarrow>Id"
  "((mod) ::int\<Rightarrow>_,(mod))\<in>Id\<rightarrow>Id\<rightarrow>Id"
  by auto

subsection \<open>Product\<close>

lemma param_unit[param]: "((),())\<in>unit_rel" by auto

lemma rec_prod_is_case: "old.rec_prod = case_prod"
  by (rule ext)+ (auto split: bool.split)

lemma param_prod[param]:
  "(Pair,Pair)\<in>Ra \<rightarrow> Rb \<rightarrow> \<langle>Ra,Rb\<rangle>prod_rel"
  "(case_prod,case_prod) \<in> (Ra \<rightarrow> Rb \<rightarrow> Rr) \<rightarrow> \<langle>Ra,Rb\<rangle>prod_rel \<rightarrow> Rr"
  "(old.rec_prod,old.rec_prod) \<in> (Ra \<rightarrow> Rb \<rightarrow> Rr) \<rightarrow> \<langle>Ra,Rb\<rangle>prod_rel \<rightarrow> Rr"
  "(fst,fst)\<in>\<langle>Ra,Rb\<rangle>prod_rel \<rightarrow> Ra"
  "(snd,snd)\<in>\<langle>Ra,Rb\<rangle>prod_rel \<rightarrow> Rb"
  by (auto dest: fun_relD split: prod.split
    simp: prod_rel_def rec_prod_is_case)

lemma param_case_prod':
  "\<lbrakk> (p,p')\<in>\<langle>Ra,Rb\<rangle>prod_rel;
     \<And>a b a' b'. \<lbrakk> p=(a,b); p'=(a',b'); (a,a')\<in>Ra; (b,b')\<in>Rb \<rbrakk>
      \<Longrightarrow> (f a b, f' a' b')\<in>R
    \<rbrakk> \<Longrightarrow> (case_prod f p, case_prod f' p') \<in> R"
  by (auto split: prod.split)

lemma param_case_prod'': (* TODO: Really needed? *)
  "\<lbrakk>
    \<And>a b a' b'. \<lbrakk>p=(a,b); p'=(a',b')\<rbrakk> \<Longrightarrow> (f a b,f' a' b')\<in>R
  \<rbrakk> \<Longrightarrow> (case_prod f p, case_prod f' p')\<in>R"
  by (auto split: prod.split)

lemma param_map_prod[param]:
  "(map_prod, map_prod)
  \<in> (Ra\<rightarrow>Rb) \<rightarrow> (Rc\<rightarrow>Rd) \<rightarrow> \<langle>Ra,Rc\<rangle>prod_rel \<rightarrow> \<langle>Rb,Rd\<rangle>prod_rel"
  unfolding map_prod_def[abs_def]
  by parametricity

lemma param_apfst[param]:
  "(apfst,apfst)\<in>(Ra\<rightarrow>Rb)\<rightarrow>\<langle>Ra,Rc\<rangle>prod_rel\<rightarrow>\<langle>Rb,Rc\<rangle>prod_rel"
  unfolding apfst_def[abs_def] by parametricity

lemma param_apsnd[param]:
  "(apsnd,apsnd)\<in>(Rb\<rightarrow>Rc)\<rightarrow>\<langle>Ra,Rb\<rangle>prod_rel\<rightarrow>\<langle>Ra,Rc\<rangle>prod_rel"
  unfolding apsnd_def[abs_def] by parametricity

lemma param_curry[param]:
  "(curry,curry) \<in> (\<langle>Ra,Rb\<rangle>prod_rel \<rightarrow> Rc) \<rightarrow> Ra \<rightarrow> Rb \<rightarrow> Rc"
  unfolding curry_def by parametricity

lemma param_uncurry[param]: "(uncurry,uncurry) \<in> (A\<rightarrow>B\<rightarrow>C) \<rightarrow> A\<times>\<^sub>rB\<rightarrow>C"
  unfolding uncurry_def[abs_def] by parametricity

lemma param_prod_swap[param]: "(prod.swap, prod.swap)\<in>A\<times>\<^sub>rB \<rightarrow> B\<times>\<^sub>rA" by auto

context partial_function_definitions begin
  lemma
    assumes M: "monotone le_fun le_fun F"
    and M': "monotone le_fun le_fun F'"
    assumes ADM:
      "admissible (\<lambda>a. \<forall>x xa. (x, xa) \<in> Rb \<longrightarrow> (a x, fixp_fun F' xa) \<in> Ra)"
    assumes bot: "\<And>x xa. (x, xa) \<in> Rb \<Longrightarrow> (lub {}, fixp_fun F' xa) \<in> Ra"
    assumes F: "(F,F')\<in>(Rb\<rightarrow>Ra)\<rightarrow>Rb\<rightarrow>Ra"
    assumes A: "(x,x')\<in>Rb"
    shows "(fixp_fun F x, fixp_fun F' x')\<in>Ra"
    using A
    apply (induct arbitrary: x x' rule: ccpo.fixp_induct[OF ccpo _ M])
    apply (rule ADM)
    apply(simp add: fun_lub_def bot)
    apply (subst ccpo.fixp_unfold[OF ccpo M'])
    apply (parametricity add: F)
    done
end

subsection \<open>Option\<close>

lemma param_option[param]:
  "(None,None)\<in>\<langle>R\<rangle>option_rel"
  "(Some,Some)\<in>R \<rightarrow> \<langle>R\<rangle>option_rel"
  "(case_option,case_option)\<in>Rr\<rightarrow>(R \<rightarrow> Rr)\<rightarrow>\<langle>R\<rangle>option_rel \<rightarrow> Rr"
  "(rec_option,rec_option)\<in>Rr\<rightarrow>(R \<rightarrow> Rr)\<rightarrow>\<langle>R\<rangle>option_rel \<rightarrow> Rr"
  by (auto split: option.split
    simp: option_rel_def case_option_def[symmetric]
    dest: fun_relD)

lemma param_map_option[param]: "(map_option, map_option) \<in> (A \<rightarrow> B) \<rightarrow> \<langle>A\<rangle>option_rel \<rightarrow> \<langle>B\<rangle>option_rel"
  apply (intro fun_relI)
  apply (auto elim!: option_relE dest: fun_relD)
  done

lemma param_case_option':
  "\<lbrakk> (x,x')\<in>\<langle>Rv\<rangle>option_rel;
     \<lbrakk>x=None; x'=None \<rbrakk> \<Longrightarrow> (fn,fn')\<in>R;
     \<And>v v'. \<lbrakk> x=Some v; x'=Some v'; (v,v')\<in>Rv \<rbrakk> \<Longrightarrow> (fs v, fs' v')\<in>R
   \<rbrakk> \<Longrightarrow> (case_option fn fs x, case_option fn' fs' x') \<in> R"
  by (auto split: option.split)

lemma the_paramL: "\<lbrakk>l\<noteq>None; (l,r)\<in>\<langle>R\<rangle>option_rel\<rbrakk> \<Longrightarrow> (the l, the r)\<in>R"
  apply (cases l)
  by (auto elim: option_relE)

lemma the_paramR: "\<lbrakk>r\<noteq>None; (l,r)\<in>\<langle>R\<rangle>option_rel\<rbrakk> \<Longrightarrow> (the l, the r)\<in>R"
  apply (cases l)
  by (auto elim: option_relE)

lemma the_default_param[param]:
  "(the_default, the_default) \<in> R \<rightarrow> \<langle>R\<rangle>option_rel \<rightarrow> R"
  unfolding the_default_def
  by parametricity

subsection \<open>Sum\<close>

lemma rec_sum_is_case: "old.rec_sum = case_sum"
  by (rule ext)+ (auto split: sum.split)

lemma param_sum[param]:
  "(Inl,Inl) \<in> Rl \<rightarrow> \<langle>Rl,Rr\<rangle>sum_rel"
  "(Inr,Inr) \<in> Rr \<rightarrow> \<langle>Rl,Rr\<rangle>sum_rel"
  "(case_sum,case_sum) \<in> (Rl \<rightarrow> R) \<rightarrow> (Rr \<rightarrow> R) \<rightarrow> \<langle>Rl,Rr\<rangle>sum_rel \<rightarrow> R"
  "(old.rec_sum,old.rec_sum) \<in> (Rl \<rightarrow> R) \<rightarrow> (Rr \<rightarrow> R) \<rightarrow> \<langle>Rl,Rr\<rangle>sum_rel \<rightarrow> R"
  by (fastforce split: sum.split dest: fun_relD
    simp: rec_sum_is_case)+

lemma param_case_sum':
  "\<lbrakk> (s,s')\<in>\<langle>Rl,Rr\<rangle>sum_rel;
     \<And>l l'. \<lbrakk> s=Inl l; s'=Inl l'; (l,l')\<in>Rl \<rbrakk> \<Longrightarrow> (fl l, fl' l')\<in>R;
     \<And>r r'. \<lbrakk> s=Inr r; s'=Inr r'; (r,r')\<in>Rr \<rbrakk> \<Longrightarrow> (fr r, fr' r')\<in>R
   \<rbrakk> \<Longrightarrow> (case_sum fl fr s, case_sum fl' fr' s')\<in>R"
  by (auto split: sum.split)

primrec is_Inl where "is_Inl (Inl _) = True" | "is_Inl (Inr _) = False"
primrec is_Inr where "is_Inr (Inr _) = True" | "is_Inr (Inl _) = False"

lemma is_Inl_param[param]: "(is_Inl,is_Inl) \<in> \<langle>Ra,Rb\<rangle>sum_rel \<rightarrow> bool_rel"
  unfolding is_Inl_def by parametricity
lemma is_Inr_param[param]: "(is_Inr,is_Inr) \<in> \<langle>Ra,Rb\<rangle>sum_rel \<rightarrow> bool_rel"
  unfolding is_Inr_def by parametricity

lemma sum_projl_param[param]:
  "\<lbrakk>is_Inl s; (s',s)\<in>\<langle>Ra,Rb\<rangle>sum_rel\<rbrakk>
  \<Longrightarrow> (Sum_Type.sum.projl s',Sum_Type.sum.projl s) \<in> Ra"
  apply (cases s)
  apply (auto elim: sum_relE)
  done

lemma sum_projr_param[param]:
  "\<lbrakk>is_Inr s; (s',s)\<in>\<langle>Ra,Rb\<rangle>sum_rel\<rbrakk>
  \<Longrightarrow> (Sum_Type.sum.projr s',Sum_Type.sum.projr s) \<in> Rb"
  apply (cases s)
  apply (auto elim: sum_relE)
  done

subsection \<open>List\<close>

lemma list_rel_append1: "(as @ bs, l) \<in> \<langle>R\<rangle>list_rel
  \<longleftrightarrow> (\<exists>cs ds. l = cs@ds \<and> (as,cs)\<in>\<langle>R\<rangle>list_rel \<and> (bs,ds)\<in>\<langle>R\<rangle>list_rel)"
  apply (simp add: list_rel_def list_all2_append1)
  apply auto
  apply (metis list_all2_lengthD)
  done

lemma list_rel_append2: "(l,as @ bs) \<in> \<langle>R\<rangle>list_rel
  \<longleftrightarrow> (\<exists>cs ds. l = cs@ds \<and> (cs,as)\<in>\<langle>R\<rangle>list_rel \<and> (ds,bs)\<in>\<langle>R\<rangle>list_rel)"
  apply (simp add: list_rel_def list_all2_append2)
  apply auto
  apply (metis list_all2_lengthD)
  done

lemma param_append[param]:
  "(append, append)\<in>\<langle>R\<rangle>list_rel \<rightarrow> \<langle>R\<rangle>list_rel \<rightarrow> \<langle>R\<rangle>list_rel"
  by (auto simp: list_rel_def list_all2_appendI)

lemma param_list1[param]:
  "(Nil,Nil)\<in>\<langle>R\<rangle>list_rel"
  "(Cons,Cons)\<in>R \<rightarrow> \<langle>R\<rangle>list_rel \<rightarrow> \<langle>R\<rangle>list_rel"
  "(case_list,case_list)\<in>Rr\<rightarrow>(R\<rightarrow>\<langle>R\<rangle>list_rel\<rightarrow>Rr)\<rightarrow>\<langle>R\<rangle>list_rel\<rightarrow>Rr"
  apply (force dest: fun_relD split: list.split)+
  done

lemma param_rec_list[param]:
  "(rec_list,rec_list)
  \<in> Ra \<rightarrow> (Rb \<rightarrow> \<langle>Rb\<rangle>list_rel \<rightarrow> Ra \<rightarrow> Ra) \<rightarrow> \<langle>Rb\<rangle>list_rel \<rightarrow> Ra"
proof (intro fun_relI, goal_cases)
  case prems: (1 a a' f f' l l')
  from prems(3) show ?case
    using prems(1,2)
    apply (induct arbitrary: a a')
    apply simp
    apply (fastforce dest: fun_relD)
    done
qed

lemma param_case_list':
  "\<lbrakk> (l,l')\<in>\<langle>Rb\<rangle>list_rel;
     \<lbrakk>l=[]; l'=[]\<rbrakk> \<Longrightarrow> (n,n')\<in>Ra;
     \<And>x xs x' xs'. \<lbrakk> l=x#xs; l'=x'#xs'; (x,x')\<in>Rb; (xs,xs')\<in>\<langle>Rb\<rangle>list_rel \<rbrakk>
     \<Longrightarrow> (c x xs, c' x' xs')\<in>Ra
   \<rbrakk> \<Longrightarrow> (case_list n c l, case_list n' c' l') \<in> Ra"
  by (auto split: list.split)

lemma param_map[param]:
  "(map,map)\<in>(R1\<rightarrow>R2) \<rightarrow> \<langle>R1\<rangle>list_rel \<rightarrow> \<langle>R2\<rangle>list_rel"
  unfolding map_rec[abs_def] by (parametricity)

lemma param_fold[param]:
  "(fold,fold)\<in>(Re\<rightarrow>Rs\<rightarrow>Rs) \<rightarrow> \<langle>Re\<rangle>list_rel \<rightarrow> Rs \<rightarrow> Rs"
  "(foldl,foldl)\<in>(Rs\<rightarrow>Re\<rightarrow>Rs) \<rightarrow> Rs \<rightarrow> \<langle>Re\<rangle>list_rel \<rightarrow> Rs"
  "(foldr,foldr)\<in>(Re\<rightarrow>Rs\<rightarrow>Rs) \<rightarrow> \<langle>Re\<rangle>list_rel \<rightarrow> Rs \<rightarrow> Rs"
  unfolding List.fold_def List.foldr_def List.foldl_def
  by (parametricity)+

  lemma param_list_all[param]: "(list_all,list_all) \<in> (A\<rightarrow>bool_rel) \<rightarrow> \<langle>A\<rangle>list_rel \<rightarrow> bool_rel"
    by (fold rel2p_def) (simp add: rel2p List.list_all_transfer)

context begin
  private primrec list_all2_alt :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> bool" where
    "list_all2_alt P [] ys \<longleftrightarrow> (case ys of [] \<Rightarrow> True | _ \<Rightarrow> False)"
  | "list_all2_alt P (x#xs) ys \<longleftrightarrow> (case ys of [] \<Rightarrow> False | y#ys \<Rightarrow> P x y \<and> list_all2_alt P xs ys)"

  private lemma list_all2_alt: "list_all2 P xs ys = list_all2_alt P xs ys"
    by (induction xs arbitrary: ys) (auto split: list.splits)

  lemma param_list_all2[param]: "(list_all2, list_all2) \<in> (A\<rightarrow>B\<rightarrow>bool_rel) \<rightarrow> \<langle>A\<rangle>list_rel \<rightarrow> \<langle>B\<rangle>list_rel \<rightarrow> bool_rel"
    unfolding list_all2_alt[abs_def]
    unfolding list_all2_alt_def[abs_def]
    by parametricity

end

lemma param_hd[param]: "l\<noteq>[] \<Longrightarrow> (l',l)\<in>\<langle>A\<rangle>list_rel \<Longrightarrow> (hd l', hd l)\<in>A"
  unfolding hd_def by (auto split: list.splits)

lemma param_last[param]:
  assumes "y \<noteq> []"
  assumes "(x, y) \<in> \<langle>A\<rangle>list_rel"
  shows "(last x, last y) \<in> A"
  using assms(2,1)
  by (induction rule: list_rel_induct) auto

lemma param_rotate1[param]: "(rotate1, rotate1) \<in> \<langle>A\<rangle>list_rel \<rightarrow> \<langle>A\<rangle>list_rel"
  unfolding rotate1_def by parametricity

schematic_goal param_take[param]: "(take,take)\<in>(?R::(_\<times>_) set)"
  unfolding take_def
  by (parametricity)

schematic_goal param_drop[param]: "(drop,drop)\<in>(?R::(_\<times>_) set)"
  unfolding drop_def
  by (parametricity)

schematic_goal param_length[param]:
  "(length,length)\<in>(?R::(_\<times>_) set)"
  unfolding size_list_overloaded_def size_list_def
  by (parametricity)

fun list_eq :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
  "list_eq eq [] [] \<longleftrightarrow> True"
| "list_eq eq (a#l) (a'#l')
     \<longleftrightarrow> (if eq a a' then list_eq eq l l' else False)"
| "list_eq _ _ _ \<longleftrightarrow> False"

lemma param_list_eq[param]: "
  (list_eq,list_eq) \<in>
    (R \<rightarrow> R \<rightarrow> Id) \<rightarrow> \<langle>R\<rangle>list_rel \<rightarrow> \<langle>R\<rangle>list_rel \<rightarrow> Id"
proof (intro fun_relI, goal_cases)
  case prems: (1 eq eq' l1 l1' l2 l2')
  thus ?case
    apply -
    apply (induct eq' l1' l2' arbitrary: l1 l2 rule: list_eq.induct)
    apply (simp_all only: list_eq.simps |
      elim list_relE |
      parametricity)+
    done
qed

lemma id_list_eq_aux[simp]: "(list_eq (=)) = (=)"
proof (intro ext)
  fix l1 l2 :: "'a list"
  show "list_eq (=) l1 l2 = (l1 = l2)"
    apply (induct "(=) :: 'a \<Rightarrow> _" l1 l2 rule: list_eq.induct)
    apply simp_all
    done
qed

lemma param_list_equals[param]:
  "\<lbrakk> ((=), (=)) \<in> R\<rightarrow>R\<rightarrow>Id \<rbrakk>
  \<Longrightarrow> ((=), (=)) \<in> \<langle>R\<rangle>list_rel \<rightarrow> \<langle>R\<rangle>list_rel \<rightarrow> Id"
  unfolding id_list_eq_aux[symmetric]
  by (parametricity)

lemma param_tl[param]:
  "(tl,tl) \<in> \<langle>R\<rangle>list_rel \<rightarrow> \<langle>R\<rangle>list_rel"
  unfolding tl_def[abs_def]
  by (parametricity)

primrec list_all_rec where
  "list_all_rec P [] \<longleftrightarrow> True"
| "list_all_rec P (a#l) \<longleftrightarrow> P a \<and> list_all_rec P l"

primrec list_ex_rec where
  "list_ex_rec P [] \<longleftrightarrow> False"
| "list_ex_rec P (a#l) \<longleftrightarrow> P a \<or> list_ex_rec P l"

lemma list_all_rec_eq: "(\<forall>x\<in>set l. P x) = list_all_rec P l"
  by (induct l) auto

lemma list_ex_rec_eq: "(\<exists>x\<in>set l. P x) = list_ex_rec P l"
  by (induct l) auto

lemma param_list_ball[param]:
  "\<lbrakk>(P,P')\<in>(Ra\<rightarrow>Id); (l,l')\<in>\<langle>Ra\<rangle> list_rel\<rbrakk>
    \<Longrightarrow> (\<forall>x\<in>set l. P x, \<forall>x\<in>set l'. P' x) \<in> Id"
  unfolding list_all_rec_eq
  unfolding list_all_rec_def
  by (parametricity)

lemma param_list_bex[param]:
  "\<lbrakk>(P,P')\<in>(Ra\<rightarrow>Id); (l,l')\<in>\<langle>Ra\<rangle> list_rel\<rbrakk>
    \<Longrightarrow> (\<exists>x\<in>set l. P x, \<exists>x\<in>set l'. P' x) \<in> Id"
  unfolding list_ex_rec_eq[abs_def]
  unfolding list_ex_rec_def
  by (parametricity)

lemma param_rev[param]: "(rev,rev) \<in> \<langle>R\<rangle>list_rel \<rightarrow> \<langle>R\<rangle>list_rel"
  unfolding rev_def
  by (parametricity)

lemma param_foldli[param]: "(foldli, foldli)
  \<in> \<langle>Re\<rangle>list_rel \<rightarrow> (Rs\<rightarrow>Id) \<rightarrow> (Re\<rightarrow>Rs\<rightarrow>Rs) \<rightarrow> Rs \<rightarrow> Rs"
  unfolding foldli_def
  by parametricity

lemma param_foldri[param]: "(foldri, foldri)
  \<in> \<langle>Re\<rangle>list_rel \<rightarrow> (Rs\<rightarrow>Id) \<rightarrow> (Re\<rightarrow>Rs\<rightarrow>Rs) \<rightarrow> Rs \<rightarrow> Rs"
  unfolding foldri_def[abs_def]
  by parametricity

lemma param_nth[param]:
  assumes I: "i'<length l'"
  assumes IR: "(i,i')\<in>nat_rel"
  assumes LR: "(l,l')\<in>\<langle>R\<rangle>list_rel"
  shows "(l!i,l'!i') \<in> R"
  using LR I IR
  by (induct arbitrary: i i' rule: list_rel_induct)
     (auto simp: nth.simps split: nat.split)

lemma param_replicate[param]:
  "(replicate,replicate) \<in> nat_rel \<rightarrow> R \<rightarrow> \<langle>R\<rangle>list_rel"
  unfolding replicate_def by parametricity

term list_update
lemma param_list_update[param]:
  "(list_update,list_update) \<in> \<langle>Ra\<rangle>list_rel \<rightarrow> nat_rel \<rightarrow> Ra \<rightarrow> \<langle>Ra\<rangle>list_rel"
  unfolding list_update_def[abs_def] by parametricity

lemma param_zip[param]:
  "(zip, zip) \<in> \<langle>Ra\<rangle>list_rel \<rightarrow> \<langle>Rb\<rangle>list_rel \<rightarrow> \<langle>\<langle>Ra,Rb\<rangle>prod_rel\<rangle>list_rel"
    unfolding zip_def by parametricity

lemma param_upt[param]:
  "(upt, upt) \<in> nat_rel \<rightarrow> nat_rel \<rightarrow> \<langle>nat_rel\<rangle>list_rel"
   unfolding upt_def[abs_def] by parametricity

lemma param_concat[param]: "(concat, concat) \<in>
    \<langle>\<langle>R\<rangle>list_rel\<rangle>list_rel \<rightarrow> \<langle>R\<rangle>list_rel"
unfolding concat_def[abs_def] by parametricity

lemma param_all_interval_nat[param]:
  "(List.all_interval_nat, List.all_interval_nat)
  \<in> (nat_rel \<rightarrow> bool_rel) \<rightarrow> nat_rel \<rightarrow> nat_rel \<rightarrow> bool_rel"
  unfolding List.all_interval_nat_def[abs_def]
  apply parametricity
  apply simp
  done

lemma param_dropWhile[param]:
  "(dropWhile, dropWhile) \<in> (a \<rightarrow> bool_rel) \<rightarrow> \<langle>a\<rangle>list_rel \<rightarrow> \<langle>a\<rangle>list_rel"
  unfolding dropWhile_def by parametricity

lemma param_takeWhile[param]:
  "(takeWhile, takeWhile) \<in> (a \<rightarrow> bool_rel) \<rightarrow> \<langle>a\<rangle>list_rel \<rightarrow> \<langle>a\<rangle>list_rel"
  unfolding takeWhile_def by parametricity

end


(* Copyright 2020 (C) Mihails Milehins *)

section\<open>Orders\<close>
theory CZH_ECAT_Order
  imports
    CZH_ECAT_Functor
begin

subsection\<open>Background\<close>

named_theorems cat_order_cs_simps
named_theorems cat_order_cs_intros

subsection\<open>Preorder category\<close>

text\<open>See Chapter I-2 in \<^cite>\<open>"mac_lane_categories_2010"\<close>.\<close>

locale cat_preorder = category \<alpha> \<CC> for \<alpha> \<CC> +
  assumes cat_peo:
    "\<lbrakk> a \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>; b \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr> \<rbrakk> \<Longrightarrow>
      (\<exists>f. Hom \<CC> a b = set {f}) \<or> (Hom \<CC> a b = 0)"

text\<open>Rules.\<close>

lemma (in cat_preorder) cat_preorder_axioms'[cat_order_cs_intros]:
  assumes "\<alpha>' = \<alpha>"
  shows "cat_preorder \<alpha>' \<CC>"
  unfolding assms by (rule cat_preorder_axioms)

mk_ide rf cat_preorder_def[unfolded cat_preorder_axioms_def]
  |intro cat_preorderI|
  |dest cat_preorderD[dest]|
  |elim cat_preorderE[elim]|

lemmas [cat_order_cs_intros] = cat_preorderD(1)

text\<open>Elementary properties.\<close>

lemma (in cat_preorder) cat_peo_HomE:
  assumes "a \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>" and "b \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
  obtains f where \<open>Hom \<CC> a b = set {f}\<close> | \<open>Hom \<CC> a b = 0\<close>
  using cat_peo[OF assms] by auto

lemma (in cat_preorder) cat_peo_is_thin_category:
  \<comment>\<open>
  The statement of the lemma appears in
  nLab \cite{noauthor_nlab_nodate}\footnote{
  \url{https://ncatlab.org/nlab/show/preorder}
  }.\<close>
  assumes "f : a \<mapsto>\<^bsub>\<CC>\<^esub> b" and "g : a \<mapsto>\<^bsub>\<CC>\<^esub> b"
  shows "f = g"
proof-
  note f = cat_is_arrD[OF assms(1)]
  from assms have "Hom \<CC> a b \<noteq> 0" by (metis HomI eq0_iff)
  with cat_peo_HomE[OF f(2,3)] obtain h where "Hom \<CC> a b = set {h}" by auto
  moreover from assms have "f \<in>\<^sub>\<circ> Hom \<CC> a b" and "g \<in>\<^sub>\<circ> Hom \<CC> a b" by auto
  ultimately have "h = f" and "h = g" by auto
  then show ?thesis by auto
qed

subsection\<open>Order relation\<close>

subsubsection\<open>Definition and elementary properties\<close>

definition is_le :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> bool" (infix \<open>\<le>\<^sub>O\<index>\<close> 50)
  where "a \<le>\<^sub>O\<^bsub>\<CC>\<^esub> b \<longleftrightarrow> Hom \<CC> a b \<noteq> 0"

text\<open>Rules.\<close>

mk_ide is_le_def
  |intro is_leI|
  |dest is_leD[dest]|
  |elim is_leE[elim]|

text\<open>Elementary properties.\<close>

lemma (in cat_preorder) cat_peo_is_le[cat_order_cs_intros]:
  assumes "f : a \<mapsto>\<^bsub>\<CC>\<^esub> b"
  shows "a \<le>\<^sub>O\<^bsub>\<CC>\<^esub> b"
  using assms by (force intro: is_leI)

lemmas [cat_order_cs_intros] = cat_preorder.cat_peo_is_le

lemma (in cat_preorder) cat_peo_is_le_ex1:
  assumes "a \<le>\<^sub>O\<^bsub>\<CC>\<^esub> b" and "a \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>" and "b \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
  shows "\<exists>!f. f : a \<mapsto>\<^bsub>\<CC>\<^esub> b"
proof-
  from assms have "Hom \<CC> a b \<noteq> 0" by auto
  with assms cat_peo obtain f where Hom_ab: "Hom \<CC> a b = set {f}" by meson
  show "\<exists>!f. f : a \<mapsto>\<^bsub>\<CC>\<^esub> b"
  proof(intro ex1I)
    from Hom_ab show "f : a \<mapsto>\<^bsub>\<CC>\<^esub> b" by auto
    fix g assume "g : a \<mapsto>\<^bsub>\<CC>\<^esub> b"
    with Hom_ab show "g = f" by auto
  qed
qed

lemma (in cat_preorder) cat_peo_is_le_ex[elim]:
  assumes "a \<le>\<^sub>O\<^bsub>\<CC>\<^esub> b" and "a \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>" and "b \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
  obtains f where "f : a \<mapsto>\<^bsub>\<CC>\<^esub> b"
  using cat_peo_is_le_ex1[OF assms] that by clarsimp

subsubsection\<open>Order relation on a preorder category is a preorder\<close>

lemma (in cat_preorder) is_le_refl:
  assumes "a \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
  shows "a \<le>\<^sub>O\<^bsub>\<CC>\<^esub> a"
proof(intro is_leI)
  from assms have "\<CC>\<lparr>CId\<rparr>\<lparr>a\<rparr> \<in>\<^sub>\<circ> Hom \<CC> a a"
    by (cs_concl cs_shallow cs_intro: cat_cs_intros)
  then show "Hom \<CC> a a \<noteq> 0" by force
qed

lemma (in cat_preorder) is_le_trans:
  assumes "a \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
    and "b \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
    and "c \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
    and "a \<le>\<^sub>O\<^bsub>\<CC>\<^esub> b"
    and "b \<le>\<^sub>O\<^bsub>\<CC>\<^esub> c"
  shows "a \<le>\<^sub>O\<^bsub>\<CC>\<^esub> c"
proof(intro is_leI)
  from assms obtain f where f: "f : a \<mapsto>\<^bsub>\<CC>\<^esub> b" by auto
  from assms obtain g where g: "g : b \<mapsto>\<^bsub>\<CC>\<^esub> c" by auto
  from f g have "g \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> f : a \<mapsto>\<^bsub>\<CC>\<^esub> c"
    by (cs_concl cs_shallow cs_intro: cat_cs_intros)
  then show "Hom \<CC> a c \<noteq> 0" by force
qed

subsection\<open>Partial order category\<close>

text\<open>See Chapter I-2 in \<^cite>\<open>"mac_lane_categories_2010"\<close>.\<close>

locale cat_partial_order = cat_preorder \<alpha> \<CC> for \<alpha> \<CC> +
  assumes cat_po: "\<lbrakk> a \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>; b \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>; a \<le>\<^sub>O\<^bsub>\<CC>\<^esub> b; b \<le>\<^sub>O\<^bsub>\<CC>\<^esub> a \<rbrakk> \<Longrightarrow> a = b"

text\<open>Rules.\<close>

lemma (in cat_partial_order) cat_partial_order_axioms'[cat_order_cs_intros]:
  assumes "\<alpha>' = \<alpha>"
  shows "cat_partial_order \<alpha>' \<CC>"
  unfolding assms by (rule cat_partial_order_axioms)

mk_ide rf cat_partial_order_def[unfolded cat_partial_order_axioms_def]
  |intro cat_partial_orderI|
  |dest cat_partial_orderD[dest]|
  |elim cat_partial_orderE[elim]|

lemmas [cat_order_cs_intros] = cat_partial_orderD(1)

subsection\<open>Linear order category\<close>

text\<open>See Chapter I-2 in \<^cite>\<open>"mac_lane_categories_2010"\<close>.\<close>

locale cat_linear_order = cat_partial_order \<alpha> \<CC> for \<alpha> \<CC> +
  assumes cat_lo: "\<lbrakk> a \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>; b \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr> \<rbrakk> \<Longrightarrow> a \<le>\<^sub>O\<^bsub>\<CC>\<^esub> b \<or> b \<le>\<^sub>O\<^bsub>\<CC>\<^esub> a"

text\<open>Rules.\<close>

lemma (in cat_linear_order) cat_linear_order_axioms'[cat_order_cs_intros]:
  assumes "\<alpha>' = \<alpha>"
  shows "cat_linear_order \<alpha>' \<CC>"
  unfolding assms by (rule cat_linear_order_axioms)

mk_ide rf cat_linear_order_def[unfolded cat_linear_order_axioms_def]
  |intro cat_linear_orderI|
  |dest cat_linear_orderD[dest]|
  |elim cat_linear_orderE[elim]|

lemmas [cat_order_cs_intros] = cat_linear_orderD(1)

subsection\<open>Preorder functor\<close>

subsubsection\<open>Definition and elementary properties\<close>

text\<open>
See \<^cite>\<open>"noauthor_nlab_nodate"\<close>\footnote{
\url{https://ncatlab.org/nlab/show/monotone+function}
}.
\<close>

locale is_preorder_functor =
  is_functor \<alpha> \<AA> \<BB> \<FF> + HomDom: cat_preorder \<alpha> \<AA> + HomCod: cat_preorder \<alpha> \<BB>
  for \<alpha> \<AA> \<BB> \<FF>

syntax "_is_preorder_functor" :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> bool"
  (\<open>(_ :/ _ \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<index> _)\<close> [51, 51, 51] 51)
translations "\<FF> : \<AA> \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^bsub>\<alpha>\<^esub> \<BB>" \<rightleftharpoons> "CONST is_preorder_functor \<alpha> \<AA> \<BB> \<FF>"

text\<open>Rules.\<close>

lemma (in is_preorder_functor) is_preorder_functor_axioms'[cat_order_cs_intros]:
  assumes "\<alpha>' = \<alpha>" and "\<AA>' = \<AA>" and "\<BB>' = \<BB>"
  shows "\<FF> : \<AA>' \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^bsub>\<alpha>'\<^esub> \<BB>'"
  unfolding assms by (rule is_preorder_functor_axioms)

mk_ide rf is_preorder_functor_def
  |intro is_preorder_functorI|
  |dest is_preorder_functorD[dest]|
  |elim is_preorder_functorE[elim]|

lemmas [cat_order_cs_intros] = is_preorder_functorD

subsubsection\<open>A preorder functor is a faithful functor\<close>

sublocale is_preorder_functor \<subseteq> is_ft_functor
proof(intro is_ft_functorI')
  fix a b assume "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>" "b \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
  show "v11 (\<FF>\<lparr>ArrMap\<rparr> \<restriction>\<^sup>l\<^sub>\<circ> Hom \<AA> a b)"
  proof
    (
      intro vsv.vsv_valeq_v11I,
      unfold vdomain_vlrestriction cat_cs_simps vintersection_iff;
      (elim conjE)?
    )
    fix g f assume "g : a \<mapsto>\<^bsub>\<AA>\<^esub> b" "f : a \<mapsto>\<^bsub>\<AA>\<^esub> b"
    then show "g = f" by (auto simp: HomDom.cat_peo_is_thin_category)
  qed simp
qed (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)

lemmas (in is_preorder_functor) is_preorder_functor_is_ft_functor =
  is_ft_functor_axioms

lemmas [cat_order_cs_intros] =
  is_preorder_functor.is_preorder_functor_is_ft_functor

subsubsection\<open>A preorder functor is a monotone function\<close>

lemma (in is_preorder_functor) cat_peo:
  \<comment>\<open>
  Based on \cite{noauthor_nlab_nodate}\footnote{
  \url{https://ncatlab.org/nlab/show/monotone+function}
  }\<close>
  assumes "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>" and "b \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>" and "a \<le>\<^sub>O\<^bsub>\<AA>\<^esub> b"
  shows "\<FF>\<lparr>ObjMap\<rparr>\<lparr>a\<rparr> \<le>\<^sub>O\<^bsub>\<BB>\<^esub> \<FF>\<lparr>ObjMap\<rparr>\<lparr>b\<rparr>"
proof-
  from assms obtain f where "f : a \<mapsto>\<^bsub>\<AA>\<^esub> b" by auto
  then have "\<FF>\<lparr>ArrMap\<rparr>\<lparr>f\<rparr> : \<FF>\<lparr>ObjMap\<rparr>\<lparr>a\<rparr> \<mapsto>\<^bsub>\<BB>\<^esub> \<FF>\<lparr>ObjMap\<rparr>\<lparr>b\<rparr>"
    by (simp add: cf_ArrMap_is_arr)
  then show "\<FF>\<lparr>ObjMap\<rparr>\<lparr>a\<rparr> \<le>\<^sub>O\<^bsub>\<BB>\<^esub> \<FF>\<lparr>ObjMap\<rparr>\<lparr>b\<rparr>"
    by (cs_concl cs_shallow cs_intro: cat_order_cs_intros)
qed

subsubsection\<open>Composition of preorder functors\<close>

lemma cf_comp_is_preorder_functor[cat_order_cs_intros]:
  assumes "\<GG> : \<BB> \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^bsub>\<alpha>\<^esub> \<CC>" and "\<FF> : \<AA> \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^bsub>\<alpha>\<^esub> \<BB>"
  shows "\<GG> \<circ>\<^sub>C\<^sub>F \<FF> : \<AA> \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^bsub>\<alpha>\<^esub> \<CC>"
proof-
  interpret \<GG>: is_preorder_functor \<alpha> \<BB> \<CC> \<GG> by (rule assms(1))
  interpret \<FF>: is_preorder_functor \<alpha> \<AA> \<BB> \<FF> by (rule assms(2))
  show ?thesis
    by (intro is_preorder_functorI)
      (cs_concl cs_intro: cat_cs_intros cat_order_cs_intros)+
qed

lemma (in cat_preorder) cat_peo_cf_is_preorder_functor:
  "cf_id \<CC> : \<CC> \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^bsub>\<alpha>\<^esub> \<CC>"
  by (intro is_preorder_functorI)
    (cs_concl cs_intro: cat_cs_intros cat_order_cs_intros)+

lemma (in cat_preorder) cat_peo_cf_is_preorder_functor'[cat_order_cs_intros]:
  assumes "\<AA>' = \<CC>" and "\<BB>' = \<CC>"
  shows "cf_id \<CC> : \<AA>' \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^bsub>\<alpha>\<^esub> \<BB>'"
  unfolding assms by (rule cat_peo_cf_is_preorder_functor)

lemmas [cat_order_cs_intros] = cat_preorder.cat_peo_cf_is_preorder_functor'

end


(*  File:       Result.thy
    Copyright   2021  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Jonas Kraemer, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Karsten Diekhoff, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Michael Kirsten, Karlsruhe Institute of Technology (KIT)"\<close>

section \<open>Electoral Result\<close>

theory Result
  imports Main
begin

text \<open>
  An electoral result is the principal result type of the composable modules
  voting framework, as it is a generalization of the set of winning
  alternatives from social choice functions. Electoral results are selections
  of the received (possibly empty) set of alternatives into the three disjoint
  groups of elected, rejected and deferred alternatives.
  Any of those sets, e.g., the set of winning (elected) alternatives, may also
  be left empty, as long as they collectively still hold all the received
  alternatives.
\<close>

subsection \<open>Definition\<close>

text \<open>
  A result contains three sets of alternatives:
  elected, rejected, and deferred alternatives.
\<close>

type_synonym 'a Result = "'a set * 'a set * 'a set"

subsection \<open>Auxiliary Functions\<close>

text \<open>
  A partition of a set A are pairwise disjoint sets that "set equals
  partition" A. For this specific predicate, we have three disjoint sets
  in a three-tuple.
\<close>

fun disjoint3 :: "'a Result \<Rightarrow> bool" where
  "disjoint3 (e, r, d) =
    ((e \<inter> r = {}) \<and>
      (e \<inter> d = {}) \<and>
      (r \<inter> d = {}))"

fun set_equals_partition :: "'a set \<Rightarrow>'a Result \<Rightarrow> bool" where
  "set_equals_partition A (e, r, d) = (e \<union> r \<union> d = A)"

fun well_formed :: "'a set \<Rightarrow> 'a Result \<Rightarrow> bool" where
  "well_formed A result = (disjoint3 result \<and> set_equals_partition A result)"

text \<open>
  These three functions return the elect, reject, or defer set of a result.
\<close>

abbreviation elect_r :: "'a Result \<Rightarrow> 'a set" where
  "elect_r r \<equiv> fst r"

abbreviation reject_r :: "'a Result \<Rightarrow> 'a set" where
  "reject_r r \<equiv> fst (snd r)"

abbreviation defer_r :: "'a Result \<Rightarrow> 'a set" where
  "defer_r r \<equiv> snd (snd r)"

subsection \<open>Auxiliary Lemmata\<close>

lemma result_imp_rej:
  assumes "well_formed A (e, r, d)"
  shows "A - (e \<union> d) = r"
proof (safe)
  fix x :: "'a"
  assume
    x_in_A: "x \<in> A" and
    x_not_rej: "x \<notin> r" and
    x_not_def: "x \<notin> d"
  from assms have
    "(e \<inter> r = {}) \<and> (e \<inter> d = {}) \<and>
    (r \<inter> d = {}) \<and> (e \<union> r \<union> d = A)"
    by simp
  thus "x \<in> e"
    using x_in_A x_not_rej x_not_def
    by auto
next
  fix x :: "'a"
  assume x_rej: "x \<in> r"
  from assms have
    "(e \<inter> r = {}) \<and> (e \<inter> d = {}) \<and>
    (r \<inter> d = {}) \<and> (e \<union> r \<union> d = A)"
    by simp
  thus "x \<in> A"
    using x_rej
    by auto
next
  fix x :: "'a"
  assume
    x_rej:  "x \<in> r" and
    x_elec: "x \<in> e"
  from assms have
    "(e \<inter> r = {}) \<and> (e \<inter> d = {}) \<and>
    (r \<inter> d = {}) \<and> (e \<union> r \<union> d = A)"
    by simp
  thus False
    using x_rej x_elec
    by auto
next
  fix x :: "'a"
  assume
    x_rej: "x \<in> r" and
    x_def: "x \<in> d"
  from assms have
    "(e \<inter> r = {}) \<and> (e \<inter> d = {}) \<and>
    (r \<inter> d = {}) \<and> (e \<union> r \<union> d = A)"
    by simp
  thus False
    using x_rej x_def
    by auto
qed

lemma result_count:
  assumes
    wf: "well_formed A (e, r, d)" and
    fin_A: "finite A"
  shows "card A = card e + card r + card d"
proof -
  from wf have disj:
    "(e \<inter> r = {}) \<and> (e \<inter> d = {}) \<and> (r \<inter> d = {})"
    by simp
  from wf have set_partit:
    "e \<union> r \<union> d = A"
    by simp
  show ?thesis
    using fin_A disj set_partit Int_Un_distrib2 finite_Un
          card_Un_disjoint sup_bot.right_neutral
    by metis
qed

lemma defer_subset:
  assumes "well_formed A result"
  shows "defer_r result \<subseteq> A"
proof (safe)
  fix x :: "'a"
  assume def_x: "x \<in> defer_r result"
  obtain
    alts :: "'a Result \<Rightarrow> 'a set \<Rightarrow> 'a set" and
    res :: "'a Result \<Rightarrow> 'a set \<Rightarrow> 'a Result" where
    wf: "A = alts result A \<and> result = res result A \<and> disjoint3 (res result A) \<and>
            set_equals_partition (alts result A) (res result A)"
    using assms
    by simp
  hence
    "\<forall> p A. \<exists> elec rej def.
      set_equals_partition (A::'a set) p \<longrightarrow> (elec, rej, def) = p \<and> elec \<union> rej \<union> def = A"
    by simp
  thus "x \<in> A"
    using UnCI def_x wf snd_conv
    by metis
qed

lemma elect_subset:
  assumes "well_formed A result"
  shows "elect_r result \<subseteq> A"
proof (safe)
  fix x :: "'a"
  assume elec_res: "x \<in> elect_r result"
  obtain
    alts :: "'a Result \<Rightarrow> 'a set \<Rightarrow> 'a set" and
    res :: "'a Result \<Rightarrow> 'a set \<Rightarrow> 'a Result" where
    wf: "A = alts result A \<and> result = res result A \<and> disjoint3 (res result A) \<and>
            set_equals_partition (alts result A) (res result A)"
    using assms
    by simp
  hence
    "\<forall> p A. \<exists> elec rej def.
      set_equals_partition (A::'a set) p \<longrightarrow> (elec, rej, def) = p \<and> elec \<union> rej \<union> def = A"
    by simp
  thus "x \<in> A"
    using UnCI elec_res wf assms fst_conv
    by metis
qed

lemma reject_subset:
  assumes "well_formed A result"
  shows "reject_r result \<subseteq> A"
proof (safe)
  fix a :: "'a"
  assume rej_a: "a \<in> reject_r result"
  obtain
    alts :: "'a Result \<Rightarrow> 'a set \<Rightarrow> 'a set" and
    res :: "'a Result \<Rightarrow> 'a set \<Rightarrow> 'a Result" where
    wf: "A = alts result A \<and> result = res result A \<and> disjoint3 (res result A) \<and>
            set_equals_partition (alts result A) (res result A)"
    using assms
    by simp
  hence
    "\<forall> p A. \<exists> elec rej def.
      set_equals_partition (A::'a set) p \<longrightarrow> (elec, rej, def) = p \<and> elec \<union> rej \<union> def = A"
    by simp
  thus "a \<in> A"
    using UnCI assms rej_a wf fst_conv snd_conv disjoint3.cases
    by metis
qed

end