(*
Title: 2-Catoids
Author: Georg Struth
Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
*)

section \<open>2-Catoids\<close>

theory Two_Catoid
  imports Catoid

begin

text\<open>We define 2-catoids and in particular (strict) 2-categories as local functional 2-catoids. With Isabelle
we first need to make two copies of catoids for the 0-structure and 1-structure.\<close>

subsection \<open>0-structures and 1-structures.\<close>

text \<open>We could define the n-catoids and omega-catoids directly. But how can I add i to a subscript?\<close>

class multimagma0 =
  fixes mcomp0 :: "'a \<Rightarrow> 'a \<Rightarrow> 'a set" (infixl "\<odot>\<^sub>0" 70)

begin

sublocale mm0: multimagma mcomp0.

abbreviation "\<Delta>\<^sub>0 \<equiv> mm0.\<Delta>"

abbreviation conv0 :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a set" (infixl "*\<^sub>0" 70) where
 "X *\<^sub>0 Y \<equiv> mm0.conv X Y"

lemma "X *\<^sub>0 Y = \<Union>{x \<odot>\<^sub>0 y |x y. x \<in> X \<and> y \<in> Y}"
  by (simp add: mm0.conv_def)

end

class multimagma1 =
  fixes mcomp1 :: "'a \<Rightarrow> 'a \<Rightarrow> 'a set" (infixl "\<odot>\<^sub>1" 70)

begin

sublocale mm1: multimagma mcomp1.

abbreviation "\<Delta>\<^sub>1 \<equiv> mm1.\<Delta>"

abbreviation conv1 :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a set" (infixl "*\<^sub>1" 70) where
  "X *\<^sub>1 Y \<equiv> mm1.conv X Y"

end

class multisemigroup0 = multimagma0 +
  assumes assoc: "\<Union>{x \<odot>\<^sub>0 v |v. v \<in> y \<odot>\<^sub>0 z} = \<Union>{v \<odot>\<^sub>0 z |v. v \<in> x \<odot>\<^sub>0 y}"

sublocale multisemigroup0 \<subseteq> msg0: multisemigroup mcomp0
  by (unfold_locales, simp add: local.assoc)

class multisemigroup1 = multimagma1 +
  assumes assoc: "\<Union>{x \<odot>\<^sub>1 v |v. v \<in> y \<odot>\<^sub>1 z} = \<Union>{v \<odot>\<^sub>1 z |v. v \<in> x \<odot>\<^sub>1 y}"

sublocale  multisemigroup1 \<subseteq> msg1: multisemigroup mcomp1
  by (unfold_locales, simp add: local.assoc)

class st_multimagma0 = multimagma0 +
fixes \<sigma>\<^sub>0 :: "'a \<Rightarrow> 'a"
  and \<tau>\<^sub>0 :: "'a \<Rightarrow> 'a"
  assumes Dst0: "x \<odot>\<^sub>0 y \<noteq> {} \<Longrightarrow> \<tau>\<^sub>0 x = \<sigma>\<^sub>0 y"
  and src0_absorb [simp]: "\<sigma>\<^sub>0 x \<odot>\<^sub>0 x = {x}"
  and tgt0_absorb [simp]: "x \<odot>\<^sub>0 \<tau>\<^sub>0 x = {x}"

sublocale st_multimagma0 \<subseteq> stmm0: st_multimagma mcomp0 \<sigma>\<^sub>0 \<tau>\<^sub>0
  by (unfold_locales, simp_all add: local.Dst0)

abbreviation (in st_multimagma0)
  "s0fix \<equiv> stmm0.sfix"

abbreviation (in st_multimagma0)
  "t0fix \<equiv> stmm0.tfix"

abbreviation (in st_multimagma0)
  "Src\<^sub>0 \<equiv> stmm0.Src"

abbreviation (in st_multimagma0)
  "Tgt\<^sub>0 \<equiv> stmm0.Tgt"

class st_multimagma1 = multimagma1 +
fixes \<sigma>\<^sub>1 :: "'a \<Rightarrow> 'a"
  and \<tau>\<^sub>1 :: "'a \<Rightarrow> 'a"
  assumes Dst1: "x \<odot>\<^sub>1 y \<noteq> {} \<Longrightarrow> \<tau>\<^sub>1 x = \<sigma>\<^sub>1 y"
  and src1_absorb [simp]: "\<sigma>\<^sub>1 x \<odot>\<^sub>1 x = {x}"
  and tgt1_absorb [simp]: "x \<odot>\<^sub>1 \<tau>\<^sub>1 x = {x}"

sublocale  st_multimagma1 \<subseteq> stmm1:  st_multimagma mcomp1  \<sigma>\<^sub>1 \<tau>\<^sub>1
  by (unfold_locales, simp_all add: local.Dst1)

abbreviation (in st_multimagma1)
  "s1fix \<equiv> stmm1.sfix"

abbreviation (in st_multimagma1)
  "t1fix \<equiv> stmm1.tfix"

abbreviation (in st_multimagma1)
  "Src\<^sub>1 \<equiv> stmm1.Src"

abbreviation (in st_multimagma1)
  "Tgt\<^sub>1 \<equiv> stmm1.Tgt"

class catoid0 = st_multimagma0 + multisemigroup0

sublocale catoid0 \<subseteq> stmsg0: catoid mcomp0 \<sigma>\<^sub>0 \<tau>\<^sub>0..

class catoid1 = st_multimagma1 + multisemigroup1

sublocale catoid1 \<subseteq> stmsg1: catoid mcomp1 \<sigma>\<^sub>1 \<tau>\<^sub>1..

class local_catoid0 = catoid0 +
  assumes src0_local: "Src\<^sub>0 (x \<odot>\<^sub>0 \<sigma>\<^sub>0 y) \<subseteq> Src\<^sub>0 (x \<odot>\<^sub>0 y)"
  and tgt0_local: "Tgt\<^sub>0 (\<tau>\<^sub>0 x \<odot>\<^sub>0 y) \<subseteq> Tgt\<^sub>0 (x \<odot>\<^sub>0 y)"

class local_catoid1 = catoid1 +
  assumes l1_local: "Src\<^sub>1 (x \<odot>\<^sub>1 \<sigma>\<^sub>1 y) \<subseteq> Src\<^sub>1 (x \<odot>\<^sub>1 y)"
  and r1_local: "Tgt\<^sub>1 (\<tau>\<^sub>1 x \<odot>\<^sub>1 y) \<subseteq> Tgt\<^sub>1 (x \<odot>\<^sub>1 y)"

sublocale local_catoid0 \<subseteq> ssmsg0: local_catoid mcomp0 \<sigma>\<^sub>0 \<tau>\<^sub>0
  apply unfold_locales
  using local.src0_local apply presburger
  using local.tgt0_local by blast

sublocale local_catoid1 \<subseteq> stmsg1: local_catoid mcomp1 \<sigma>\<^sub>1 \<tau>\<^sub>1
  apply unfold_locales using local.l1_local local.r1_local by auto

class functional_magma0 = multimagma0 +
  assumes functionality0: "x \<in> y \<odot>\<^sub>0 z \<Longrightarrow> x' \<in> y \<odot>\<^sub>0 z \<Longrightarrow> x = x'"

sublocale functional_magma0 \<subseteq> pm0: functional_magma mcomp0
  by (unfold_locales, simp add: local.functionality0)

class functional_magma1 = multimagma1 +
  assumes functionality1: "x \<in> y \<odot>\<^sub>1 z \<Longrightarrow> x' \<in> y \<odot>\<^sub>1 z \<Longrightarrow> x = x'"

sublocale functional_magma1 \<subseteq> pm1: functional_magma mcomp1
  by (unfold_locales, simp add: local.functionality1)

class functional_semigroup0 = functional_magma0 + multisemigroup0

sublocale functional_semigroup0 \<subseteq> psg0: functional_semigroup mcomp0..

class functional_semigroup1 = functional_magma1 + multisemigroup1

sublocale functional_semigroup1 \<subseteq> psg1: functional_semigroup mcomp1..

class functional_catoid0 = functional_semigroup0 + catoid0

sublocale functional_catoid0 \<subseteq> psg0: functional_catoid mcomp0  \<sigma>\<^sub>0 \<tau>\<^sub>0..

class functional_catoid1 = functional_semigroup1 + catoid1

sublocale functional_catoid1 \<subseteq> psg1: functional_catoid mcomp1 \<sigma>\<^sub>1 \<tau>\<^sub>1..

class single_set_category0 = functional_catoid0 + local_catoid0

sublocale single_set_category0 \<subseteq> sscat0: single_set_category mcomp0 \<sigma>\<^sub>0 \<tau>\<^sub>0..

class single_set_category1 = functional_catoid1 + local_catoid1

sublocale single_set_category1 \<subseteq> sscat1: single_set_category mcomp1  \<sigma>\<^sub>1 \<tau>\<^sub>1..

subsection \<open>2-Catoids\<close>

text \<open>Next we define 2-catoids and 2-categories.\<close>

class two_st_multimagma = st_multimagma0 + st_multimagma1 +
  assumes comm_s0s1: "\<sigma>\<^sub>0 (\<sigma>\<^sub>1 x) = \<sigma>\<^sub>1 (\<sigma>\<^sub>0 x)"
  and comm_s0t1: "\<sigma>\<^sub>0 (\<tau>\<^sub>1 x) = \<tau>\<^sub>1 (\<sigma>\<^sub>0 x)"
  and comm_t0s1: "\<tau>\<^sub>0 (\<sigma>\<^sub>1 x) = \<sigma>\<^sub>1 (\<tau>\<^sub>0 x)"
  and comm_t0t1: "\<tau>\<^sub>0 (\<tau>\<^sub>1 x) = \<tau>\<^sub>1 (\<tau>\<^sub>0 x)"
  assumes interchange: "(w \<odot>\<^sub>1 x) *\<^sub>0 (y \<odot>\<^sub>1 z) \<subseteq> (w \<odot>\<^sub>0 y) *\<^sub>1 (x \<odot>\<^sub>0 z)"
  and s1_hom: "Src\<^sub>1 (x \<odot>\<^sub>0 y) = \<sigma>\<^sub>1 x \<odot>\<^sub>0 \<sigma>\<^sub>1 y"
  and t1_hom: "Tgt\<^sub>1 (x \<odot>\<^sub>0 y) = \<tau>\<^sub>1 x \<odot>\<^sub>0 \<tau>\<^sub>1 y"
  and s0_weak_hom: "Src\<^sub>0 (x \<odot>\<^sub>1 y) \<subseteq> \<sigma>\<^sub>0 x \<odot>\<^sub>1 \<sigma>\<^sub>0 y"
  and t0_weak_hom: "Tgt\<^sub>0 (x \<odot>\<^sub>1 y) \<subseteq> \<tau>\<^sub>0 x \<odot>\<^sub>1 \<tau>\<^sub>0 y"
  and s1s0 [simp]: "\<sigma>\<^sub>1 (\<sigma>\<^sub>0 x) = \<sigma>\<^sub>0 x"
  and s1t0 [simp]: "\<sigma>\<^sub>1 (\<tau>\<^sub>0 x) = \<tau>\<^sub>0 x"
  and t1s0 [simp]: "\<tau>\<^sub>1 (\<sigma>\<^sub>0 x) = \<sigma>\<^sub>0 x"
  and t1t0 [simp]: "\<tau>\<^sub>1 (\<tau>\<^sub>0 x) = \<tau>\<^sub>0 x"

sublocale two_st_multimagma \<subseteq> twolropp: two_st_multimagma "\<lambda>x y. y \<odot>\<^sub>0 x" "\<tau>\<^sub>0" "\<sigma>\<^sub>0" "\<lambda>x y. y \<odot>\<^sub>1 x" "\<tau>\<^sub>1" "\<sigma>\<^sub>1"
  apply unfold_locales
                    apply (simp_all add: stmm0.stopp.Dst stmm1.stopp.Dst comm_t0t1 comm_t0s1 comm_s0t1 comm_s0s1 s1_hom t1_hom s0_weak_hom t0_weak_hom)
  by (metis local.interchange local.stmm0.stopp.conv_exp local.stmm1.stopp.conv_exp multimagma.conv_exp)

lemma (in two_st_multimagma) s0s1 [simp]:
  "\<sigma>\<^sub>0 (\<sigma>\<^sub>1 x) = \<sigma>\<^sub>0 x"
  by (simp add: local.comm_s0s1)

lemma (in two_st_multimagma) s0t1 [simp]:
  "\<sigma>\<^sub>0 (\<tau>\<^sub>1 x) = \<sigma>\<^sub>0 x"
  by (simp add: local.comm_s0t1)

lemma (in two_st_multimagma) t0s1:
  "\<tau>\<^sub>0 (\<sigma>\<^sub>1 x) = \<tau>\<^sub>0 x"
  by simp

lemma (in two_st_multimagma) t1t1:
  "\<tau>\<^sub>0 (\<tau>\<^sub>1 x) = \<tau>\<^sub>0 x"
  by simp

text \<open>We lift the axioms to the powerset level.\<close>

lemma (in two_st_multimagma) comm_S0S1:
  "Src\<^sub>0 (Src\<^sub>1 X) = Src\<^sub>1 (Src\<^sub>0 X)"
  by (simp add: image_image)

lemma (in two_st_multimagma) comm_T0T1:
  "Tgt\<^sub>0 (Tgt\<^sub>1 X) = Tgt\<^sub>1 (Tgt\<^sub>0 X)"
  using local.twolropp.comm_S0S1 by presburger

lemma (in two_st_multimagma) comm_S0T1:
  "Src\<^sub>0 (Tgt\<^sub>1 x) = Tgt\<^sub>1 (Src\<^sub>0 x)"
  by (simp add: image_image)

lemma (in two_st_multimagma) comm_T0S1:
  "Tgt\<^sub>0 (Src\<^sub>1 x) = Src\<^sub>1 (Tgt\<^sub>0 x)"
  using local.twolropp.comm_S0T1 by presburger

lemma (in two_st_multimagma) interchange_lifting:
  "(W *\<^sub>1 X) *\<^sub>0 (Y *\<^sub>1 Z) \<subseteq> (W *\<^sub>0 Y) *\<^sub>1 (X *\<^sub>0 Z)"
proof-
  {fix a
  assume "a \<in> (W *\<^sub>1 X) *\<^sub>0 (Y *\<^sub>1 Z)"
  hence "\<exists>w \<in> W. \<exists>x \<in> X. \<exists>y \<in> Y. \<exists>z \<in> Z. a \<in> (w \<odot>\<^sub>1 x) *\<^sub>0 (y \<odot>\<^sub>1 z)"
    by (smt (verit, del_insts) mm0.conv_exp2 mm1.conv_exp2)
  hence "\<exists>w \<in> W. \<exists>x \<in> X. \<exists>y \<in> Y. \<exists>z \<in> Z. a \<in> (w \<odot>\<^sub>0 y) *\<^sub>1 (x \<odot>\<^sub>0 z)"
    using local.interchange by blast
  hence "a \<in> (W *\<^sub>0 Y) *\<^sub>1 (X *\<^sub>0 Z)"
    by (smt (verit, del_insts) multimagma.conv_exp2)}
  thus ?thesis..
qed

lemma (in two_st_multimagma) Src1_hom:
  "Src\<^sub>1 (X *\<^sub>0 Y) = Src\<^sub>1 X *\<^sub>0 Src\<^sub>1 Y"
proof-
  {fix a
  have "(a \<in> Src\<^sub>1 (X *\<^sub>0 Y)) = (\<exists>b \<in> X *\<^sub>0 Y. a = \<sigma>\<^sub>1 b)"
    by blast
  also have "\<dots> = (\<exists>b. \<exists>c \<in> X. \<exists>d \<in> Y. a = \<sigma>\<^sub>1 b \<and> b \<in> c \<odot>\<^sub>0 d)"
    by (metis multimagma.conv_exp2)
  also have "\<dots> = (\<exists>c \<in> X. \<exists>d \<in> Y. a \<in> Src\<^sub>1 (c \<odot>\<^sub>0 d))"
    by blast
  also have "\<dots> = (\<exists>c \<in> X. \<exists>d \<in> Y. a \<in> \<sigma>\<^sub>1 c \<odot>\<^sub>0 \<sigma>\<^sub>1 d)"
    using local.s1_hom by presburger
  also have "\<dots> = (\<exists>c \<in> Src\<^sub>1 X. \<exists>d \<in> Src\<^sub>1 Y. a \<in> c \<odot>\<^sub>0 d)"
    by blast
  also have "\<dots> = (a \<in> Src\<^sub>1 X *\<^sub>0 Src\<^sub>1 Y)"
    using local.mm0.conv_exp2 by auto
  finally have "(a \<in> Src\<^sub>1 (X *\<^sub>0 Y)) = (a \<in> Src\<^sub>1 X *\<^sub>0 Src\<^sub>1 Y)".}
  thus ?thesis
    by force
qed

lemma (in two_st_multimagma) codcomp:
  "Tgt\<^sub>1 (X *\<^sub>0 Y) = Tgt\<^sub>1 X *\<^sub>0 Tgt\<^sub>1 Y"
proof-
  {fix a
  have "(a \<in> Tgt\<^sub>1 (X *\<^sub>0 Y)) = (\<exists>c \<in> X. \<exists>d \<in> Y. a \<in> Tgt\<^sub>1 (c \<odot>\<^sub>0 d))"
    by (smt (verit, best) image_iff multimagma.conv_exp2)
  also have "\<dots> = (\<exists>c \<in> X. \<exists>d \<in> Y. a \<in> \<tau>\<^sub>1 c \<odot>\<^sub>0 \<tau>\<^sub>1 d)"
    using local.t1_hom by presburger
  also have "\<dots> = (a \<in> Tgt\<^sub>1 X *\<^sub>0 Tgt\<^sub>1 Y)"
    using local.mm0.conv_exp2 by auto
  finally have "(a \<in> Tgt\<^sub>1 (X *\<^sub>0 Y)) = (a \<in> Tgt\<^sub>1 X *\<^sub>0 Tgt\<^sub>1 Y)".}
  thus ?thesis
    by force
qed

lemma (in two_st_multimagma) Src0_weak_hom:
  "Src\<^sub>0 (X *\<^sub>1 Y) \<subseteq> Src\<^sub>0 X *\<^sub>1 Src\<^sub>0 Y"
proof-
  {fix a
  assume "a \<in> Src\<^sub>0 (X *\<^sub>1 Y)"
  hence "\<exists>c \<in> X. \<exists>d \<in> Y. a \<in> Src\<^sub>0 (c \<odot>\<^sub>1 d)"
    using local.mm1.conv_exp2 by fastforce
  hence "\<exists>c \<in> X. \<exists>d \<in> Y. a \<in> \<sigma>\<^sub>0 c \<odot>\<^sub>1 \<sigma>\<^sub>0 d"
    using local.s0_weak_hom by blast
  hence "a \<in> Src\<^sub>0 X *\<^sub>1 Src\<^sub>0 Y"
    using local.mm1.conv_exp2 by auto}
  thus ?thesis
    by force
qed

lemma (in two_st_multimagma) Tgt0_weak_hom:
  "Tgt\<^sub>0 (X *\<^sub>1 Y) \<subseteq> Tgt\<^sub>0 X *\<^sub>1 Tgt\<^sub>0 Y"
proof-
  {fix a
  assume "a \<in> Tgt\<^sub>0 (X *\<^sub>1 Y)"
  hence "\<exists>c \<in> X. \<exists>d \<in> Y. a \<in> Tgt\<^sub>0 (c \<odot>\<^sub>1 d)"
    using local.mm1.conv_exp2 by fastforce
  hence "\<exists>c \<in> X. \<exists>d \<in> Y. a \<in> \<tau>\<^sub>0 c \<odot>\<^sub>1 \<tau>\<^sub>0 d"
    using local.t0_weak_hom by blast
  hence "a \<in> Tgt\<^sub>0 X *\<^sub>1 Tgt\<^sub>0 Y"
    using local.mm1.conv_exp2 by auto}
  thus ?thesis
    by force
qed

lemma (in two_st_multimagma) S1S0 [simp]:
  "Src\<^sub>1 (Src\<^sub>0 X) = Src\<^sub>0 X"
  by force

lemma (in two_st_multimagma) S1T0 [simp]:
  "Src\<^sub>1 (Tgt\<^sub>0 X) = Tgt\<^sub>0 X"
  by force

lemma (in two_st_multimagma) T1S0:
  "Tgt\<^sub>1 (Src\<^sub>0 X) = Src\<^sub>0 X"
  by simp

lemma (in two_st_multimagma) T1T0:
  "Tgt\<^sub>1 (Tgt\<^sub>0 X) = Tgt\<^sub>0 X"
  by simp

lemma (in two_st_multimagma) id1_comp0:
  "s1fix *\<^sub>0 s1fix \<subseteq> s1fix"
proof-
  {fix a
  have "(a \<in> s1fix *\<^sub>0 s1fix) = (\<exists>b \<in> s1fix.\<exists>c \<in> s1fix. a \<in> b \<odot>\<^sub>0 c)"
    by (meson local.mm0.conv_exp2)
  also have "\<dots> = (\<exists>b c. a \<in> \<sigma>\<^sub>1 b \<odot>\<^sub>0 \<sigma>\<^sub>1 c)"
    by (metis image_iff local.stmm1.stopp.tfix_im rangeI)
  finally have "(a \<in> s1fix *\<^sub>0 s1fix) = (\<exists>b c. a \<in> Src\<^sub>1 (b \<odot>\<^sub>0 c))"
    using local.twolropp.t1_hom by presburger
  hence "(a \<in> s1fix *\<^sub>0 s1fix) \<Longrightarrow> (\<exists>b. a = \<sigma>\<^sub>1 b)"
    by blast
  hence  "(a \<in> s1fix *\<^sub>0 s1fix) \<Longrightarrow> (a \<in> s1fix)"
    using local.stmm1.stopp.Tgt_subid by blast}
  thus ?thesis
    by blast
qed

lemma (in two_st_multimagma) id1_comp0_eq [simp]:
  "s1fix *\<^sub>0 s1fix = s1fix"
proof-
  {fix a
    have "(a \<in> s1fix) = (\<exists>b. a = \<sigma>\<^sub>1 b)"
      by (metis image_iff local.stmm1.stopp.tfix_im range_eqI)
    also have "\<dots> = (\<exists>b. a \<in> \<sigma>\<^sub>0 (\<sigma>\<^sub>1 b) \<odot>\<^sub>0 \<sigma>\<^sub>1 b)"
      using local.src0_absorb by blast
  finally have "(a \<in> s1fix) = (\<exists>b. a \<in> \<sigma>\<^sub>1 (\<sigma>\<^sub>0 b) \<odot>\<^sub>0 \<sigma>\<^sub>1 b)"
    by fastforce
  hence "(a \<in> s1fix) \<Longrightarrow> (\<exists>b c. a \<in> \<sigma>\<^sub>1 c \<odot>\<^sub>0 \<sigma>\<^sub>1 b)"
    by blast
  hence "(a \<in> s1fix) \<Longrightarrow> (a \<in> s1fix *\<^sub>0 s1fix)"
    by (metis (mono_tags, lifting) local.mm0.conv_exp2 local.stmm1.stopp.tfix_im range_eqI)}
  thus ?thesis
    using local.id1_comp0 by blast
qed

lemma (in two_st_multimagma) id01:
  "s0fix \<subseteq> s1fix"
proof-
  {fix a
    have "(a \<in> s0fix) = (\<exists>b. a = \<sigma>\<^sub>0 b)"
      by (metis imageE local.stmm0.stopp.tfix_im rangeI)
    hence "(a \<in> s0fix) = (\<exists>b. a = \<sigma>\<^sub>1 (\<sigma>\<^sub>0 b))"
    by fastforce
  hence "(a \<in> s0fix) \<Longrightarrow> (\<exists>b. a = \<sigma>\<^sub>1 b)"
    by blast
  hence "(a \<in> s0fix) \<Longrightarrow> (a \<in> s1fix)"
    using local.stmm1.stopp.tfix_im by blast}
  thus ?thesis
    by blast
qed

subsection\<open>2-Catoids and single-set 2-categories\<close>

class two_catoid = two_st_multimagma + catoid0 + catoid1

class local_two_catoid = two_st_multimagma + local_catoid0 + local_catoid1

class two_category = two_catoid + single_set_category0 + single_set_category1

lemma (in two_category) conv0_sgl:
  "a \<in> x \<odot>\<^sub>0 y \<Longrightarrow> {a} = x \<odot>\<^sub>0 y"
  using local.functionality0 by fastforce

lemma (in two_category) conv1_sgl:
  "a \<in> {x} *\<^sub>1 {y} \<Longrightarrow> {a} = {x} *\<^sub>1 {y}"
  using local.functionality1 local.mm1.conv_exp by force

text \<open>Next we derive some simple globular properties.\<close>

lemma (in two_category) strong_interchange_St1:
  assumes "a \<in> (w \<odot>\<^sub>0 x) *\<^sub>1 (y \<odot>\<^sub>0 z)"
  shows "Tgt\<^sub>1 (w \<odot>\<^sub>0 x) = Src\<^sub>1 (y \<odot>\<^sub>0 z)"
  apply safe
  using assms local.Dst1 local.functionality0 local.stmm1.stopp.conv_exp2 apply fastforce
  by (smt (verit, ccfv_SIG) assms equals0D image_eqI local.Dst1 local.functionality0 local.mm1.conv_exp2)

lemma (in two_category) strong_interchange_ll0:
  assumes "a \<in> (w \<odot>\<^sub>0 x) *\<^sub>1 (y \<odot>\<^sub>0 z)"
  shows "\<sigma>\<^sub>0 w = \<sigma>\<^sub>0 y"
  by (metis assms local.mm1.conv_exp2 local.s0s1 local.s0t1 local.stmsg1.ts_msg.src_comp_aux local.stmsg1.ts_msg.tgt_comp_aux stmsg0.src_comp_aux)

text \<open>There is no strong interchange law, and the homomorphism laws stay weak, too.\<close>

lemma (in two_category) "(w \<odot>\<^sub>1 y) *\<^sub>0 (x \<odot>\<^sub>1 z) = (w \<odot>\<^sub>0 x) *\<^sub>1 (y \<odot>\<^sub>0 z)"
  nitpick
  oops

lemma (in two_category) "R\<^sub>0 (x \<odot>\<^sub>1 y) = r\<^sub>0 x \<odot>\<^sub>1 r\<^sub>0 y"
  nitpick
  oops

lemma (in two_category) "L\<^sub>0 (x \<odot>\<^sub>1 y) = l\<^sub>0 x \<odot>\<^sub>1 l\<^sub>0 y"
  nitpick
  oops

lemma (in two_category) "(W *\<^sub>0 Y) *\<^sub>1 (X *\<^sub>0 Z) = (W *\<^sub>1 X) *\<^sub>0 (Y *\<^sub>1 Z)"
  nitpick
  oops

subsection \<open>Reduced axiomatisations\<close>

class two_st_multimagma_red = st_multimagma0 + st_multimagma1 +
  assumes interchange: "(w \<odot>\<^sub>1 x) *\<^sub>0 (y \<odot>\<^sub>1 z) \<subseteq> (w \<odot>\<^sub>0 y) *\<^sub>1 (x \<odot>\<^sub>0 z)" (* irredundant *)
  assumes src1_hom: "Src\<^sub>1 (x \<odot>\<^sub>0 y) = \<sigma>\<^sub>1 x \<odot>\<^sub>0 \<sigma>\<^sub>1 y"  (* irredundant *)
  and tgt1_hom: "Tgt\<^sub>1 (x \<odot>\<^sub>0 y) = \<tau>\<^sub>1 x \<odot>\<^sub>0 \<tau>\<^sub>1 y" (* irredundant *)
  and src0_weak_hom: "Src\<^sub>0 (x \<odot>\<^sub>1 y) \<subseteq> \<sigma>\<^sub>0 x \<odot>\<^sub>1 \<sigma>\<^sub>0 y" (* no proof no counterexample *)
  and tgt0_weak_hom: "Tgt\<^sub>0 (x \<odot>\<^sub>1 y) \<subseteq> \<sigma>\<^sub>0 x \<odot>\<^sub>1 \<sigma>\<^sub>0 y" (* no proof no counterexample *)

lemma (in two_st_multimagma_red) s0t1s0 [simp]:
  "\<sigma>\<^sub>0 (\<tau>\<^sub>1 (\<sigma>\<^sub>0 x)) = \<sigma>\<^sub>0 x"
proof-
  have "{\<tau>\<^sub>1 (\<sigma>\<^sub>0 x)} = Tgt\<^sub>1 (\<sigma>\<^sub>0 x \<odot>\<^sub>0 \<sigma>\<^sub>0 x)"
    by simp
  also have "\<dots> = \<tau>\<^sub>1 (\<sigma>\<^sub>0 x) \<odot>\<^sub>0 \<tau>\<^sub>1 (\<sigma>\<^sub>0 x)"
    by (meson local.tgt1_hom)
  also have "\<dots> = \<tau>\<^sub>1 (\<sigma>\<^sub>0 x) \<odot>\<^sub>0 \<tau>\<^sub>1 (\<tau>\<^sub>1 (\<sigma>\<^sub>0 x))"
    by simp
  also have "\<dots> = Tgt\<^sub>1 (\<sigma>\<^sub>0 x \<odot>\<^sub>0 \<tau>\<^sub>1 (\<sigma>\<^sub>0 x))"
    by (simp add: local.tgt1_hom)
  finally have "Tgt\<^sub>1 (\<sigma>\<^sub>0 x \<odot>\<^sub>0 \<tau>\<^sub>1 (\<sigma>\<^sub>0 x)) \<noteq> {}"
    by force
  hence "\<sigma>\<^sub>0 x \<odot>\<^sub>0 \<tau>\<^sub>1 (\<sigma>\<^sub>0 x) \<noteq> {}"
    by blast
  thus ?thesis
    using stmm0.s_absorb_var3 by auto
qed

lemma (in two_st_multimagma_red) t0s1s0 [simp]:
  "\<tau>\<^sub>0 (\<sigma>\<^sub>1 (\<sigma>\<^sub>0 x)) = \<sigma>\<^sub>0 x"
proof-
  have "{\<sigma>\<^sub>1 (\<sigma>\<^sub>0 x)} = Src\<^sub>1 (\<sigma>\<^sub>0 x \<odot>\<^sub>0 \<sigma>\<^sub>0 x)"
    by simp
  also have "\<dots> =  \<sigma>\<^sub>1 (\<sigma>\<^sub>0 x) \<odot>\<^sub>0 \<sigma>\<^sub>1 (\<sigma>\<^sub>0 x)"
    by (meson local.src1_hom)
  also have "\<dots> = \<sigma>\<^sub>1 (\<sigma>\<^sub>1 (\<sigma>\<^sub>0 x)) \<odot>\<^sub>0 \<sigma>\<^sub>1 (\<sigma>\<^sub>0 x)"
    by simp
  also have "\<dots> = Src\<^sub>1 (\<sigma>\<^sub>1 (\<sigma>\<^sub>0 x) \<odot>\<^sub>0 \<sigma>\<^sub>0 x)"
    using local.src1_hom by force
  finally  have "Src\<^sub>1 (\<sigma>\<^sub>1 (\<sigma>\<^sub>0 x) \<odot>\<^sub>0 \<sigma>\<^sub>0 x) \<noteq> {}"
    by force
  hence "\<sigma>\<^sub>1 (\<sigma>\<^sub>0 x) \<odot>\<^sub>0 \<sigma>\<^sub>0 x \<noteq> {}"
    by blast
  thus ?thesis
    by (simp add: local.Dst0)
qed

lemma (in two_st_multimagma_red) s1s0 [simp]:
  "\<sigma>\<^sub>1 (\<sigma>\<^sub>0 x) = \<sigma>\<^sub>0 x"
proof-
  have "{\<sigma>\<^sub>0 x} = \<sigma>\<^sub>0 x \<odot>\<^sub>0 \<sigma>\<^sub>0 x"
    by simp
  also have "\<dots> = (\<sigma>\<^sub>1 (\<sigma>\<^sub>0 x) \<odot>\<^sub>1 \<sigma>\<^sub>0 x) *\<^sub>0 (\<sigma>\<^sub>0 x \<odot>\<^sub>1 \<tau>\<^sub>1 (\<sigma>\<^sub>0 x))"
    by (simp add: multimagma.conv_atom)
  also have "\<dots> \<subseteq> (\<sigma>\<^sub>1 (\<sigma>\<^sub>0 x) \<odot>\<^sub>0 \<sigma>\<^sub>0 x) *\<^sub>1 (\<sigma>\<^sub>0 x \<odot>\<^sub>0 \<tau>\<^sub>1 (\<sigma>\<^sub>0 x))"
    using local.interchange by blast
  also have "\<dots> = (\<sigma>\<^sub>1 (\<sigma>\<^sub>0 x) \<odot>\<^sub>0 \<tau>\<^sub>0 (\<sigma>\<^sub>1 (\<sigma>\<^sub>0 x))) *\<^sub>1 (\<sigma>\<^sub>0 (\<tau>\<^sub>1 (\<sigma>\<^sub>0 x)) \<odot>\<^sub>0 \<tau>\<^sub>1 (\<sigma>\<^sub>0 x))"
    by simp
  also have "\<dots> = \<sigma>\<^sub>1 (\<sigma>\<^sub>0 x) \<odot>\<^sub>1 \<tau>\<^sub>1 (\<sigma>\<^sub>0 x)"
    using local.mm1.conv_atom local.src0_absorb local.tgt0_absorb by presburger
  finally have "{\<sigma>\<^sub>0 x} \<subseteq> \<sigma>\<^sub>1 (\<sigma>\<^sub>0 x) \<odot>\<^sub>1 \<tau>\<^sub>1 (\<sigma>\<^sub>0 x)".
  thus ?thesis
    by (metis empty_iff insert_subset singletonD stmm1.st_comm stmm1.st_prop stmm1.t_idem)
qed

lemma (in two_st_multimagma_red) s1t0 [simp]:
  "\<sigma>\<^sub>1 (\<tau>\<^sub>0 x) = \<tau>\<^sub>0 x"
  by (metis local.s1s0 local.stmm0.stopp.ts_compat)

lemma (in two_st_multimagma_red) t1s0 [simp]:
  "\<tau>\<^sub>1 (\<sigma>\<^sub>0 x) = \<sigma>\<^sub>0 x"
  by (simp add: stmm1.st_fix)

lemma (in two_st_multimagma_red) t1t0 [simp]:
  "\<tau>\<^sub>1 (\<tau>\<^sub>0 x) = \<tau>\<^sub>0 x"
  by (simp add: stmm1.st_fix)

lemma (in two_st_multimagma_red) comm_s0s1:
  "\<sigma>\<^sub>0 (\<sigma>\<^sub>1 x) = \<sigma>\<^sub>1 (\<sigma>\<^sub>0 x)"
proof-
  have "{\<sigma>\<^sub>1 x} = \<sigma>\<^sub>1 (\<sigma>\<^sub>0 x) \<odot>\<^sub>0 \<sigma>\<^sub>1 x"
    by (smt (verit, best) local.Dst0 local.s1s0 local.src0_absorb local.src1_hom)
  also have "\<dots> = \<sigma>\<^sub>0 x \<odot>\<^sub>0 \<sigma>\<^sub>1 x"
    by simp
  finally have "\<sigma>\<^sub>0 x \<odot>\<^sub>0 \<sigma>\<^sub>1 x \<noteq> {}"
    by force
  hence "\<tau>\<^sub>0 (\<sigma>\<^sub>0 x) = \<sigma>\<^sub>0 (\<sigma>\<^sub>1 x)"
    by (meson local.Dst0)
  hence "\<sigma>\<^sub>0 x = \<sigma>\<^sub>0 (\<sigma>\<^sub>1 x)"
    by simp
  thus ?thesis
    by simp
qed

lemma (in two_st_multimagma_red) comm_s0t1:
  "\<sigma>\<^sub>0 (\<tau>\<^sub>1 x) = \<tau>\<^sub>1 (\<sigma>\<^sub>0 x)"
proof-
  have "{\<tau>\<^sub>1 x} = \<tau>\<^sub>1 (\<sigma>\<^sub>0 x) \<odot>\<^sub>0 \<tau>\<^sub>1 x"
    by (metis local.src0_absorb local.t1s0 local.tgt1_hom stmm0.s_absorb_var)
  hence "\<tau>\<^sub>1 (\<sigma>\<^sub>0 x) \<odot>\<^sub>0 \<tau>\<^sub>1 x \<noteq> {}"
    by force
  hence "\<tau>\<^sub>0 (\<tau>\<^sub>1 (\<sigma>\<^sub>0 x)) = \<sigma>\<^sub>0 (\<tau>\<^sub>1 x)"
    using local.Dst0 by blast
  thus ?thesis
    by simp
qed

lemma (in two_st_multimagma_red) comm_t0s1:
  "\<tau>\<^sub>0 (\<sigma>\<^sub>1 x) = \<sigma>\<^sub>1 (\<tau>\<^sub>0 x)"
proof-
  have "{\<sigma>\<^sub>1 x} = \<sigma>\<^sub>1 x \<odot>\<^sub>0 \<sigma>\<^sub>1 (\<tau>\<^sub>0 x)"
    by (metis local.s1t0 local.src1_hom local.stmm0.stopp.s_absorb_var local.tgt0_absorb)
  hence "\<sigma>\<^sub>1 x \<odot>\<^sub>0 \<sigma>\<^sub>1 (\<tau>\<^sub>0 x) \<noteq> {}"
    by force
  hence "\<tau>\<^sub>0 (\<sigma>\<^sub>1 x) = \<tau>\<^sub>0 (\<sigma>\<^sub>1 (\<tau>\<^sub>0 x))"
    by (metis local.s1t0 local.stmm0.stopp.s_absorb_var stmm0.tt_idem)
  thus ?thesis
    by simp
qed

lemma (in two_st_multimagma_red) comm_t0t1:
  "\<tau>\<^sub>0 (\<tau>\<^sub>1 x) = \<tau>\<^sub>1 (\<tau>\<^sub>0 x)"
  by (metis local.s1t0 local.stmm0.stopp.s_absorb_var3 local.tgt1_hom stmm1.st_fix)

lemma (in two_st_multimagma_red) "\<sigma>\<^sub>0 x = \<sigma>\<^sub>1 x"
  nitpick
  oops

lemma (in two_st_multimagma_red) "\<sigma>\<^sub>0 x = \<tau>\<^sub>1 x"
  nitpick
  oops

lemma (in two_st_multimagma_red) "\<tau>\<^sub>0 x = \<tau>\<^sub>1 x"
  nitpick
  oops

lemma (in two_st_multimagma_red) "\<sigma>\<^sub>0 x = \<tau>\<^sub>0 x"
  nitpick
  oops
lemma (in two_st_multimagma_red) "\<sigma>\<^sub>1 x = \<tau>\<^sub>1 x"
  nitpick
  oops

lemma (in two_st_multimagma_red) "x \<odot>\<^sub>0 y = x \<odot>\<^sub>1 y"
  nitpick
  oops

lemma (in two_st_multimagma_red) "x \<odot>\<^sub>0 y = y \<odot>\<^sub>0 x"
  nitpick
  oops

lemma  (in two_st_multimagma_red) "x \<odot>\<^sub>1 y = y \<odot>\<^sub>1 x"
  nitpick
  oops

class two_catoid_red = catoid0 + catoid1 +
  assumes interchange: "(w \<odot>\<^sub>1 x) *\<^sub>0 (y \<odot>\<^sub>1 z) \<subseteq> (w \<odot>\<^sub>0 y) *\<^sub>1 (x \<odot>\<^sub>0 z)" (* irredundant *)
  and s1_hom: "Src\<^sub>1 (x \<odot>\<^sub>0 y) = \<sigma>\<^sub>1 x \<odot>\<^sub>0 \<sigma>\<^sub>1 y"  (* irredundant *)
  and t1_hom: "Tgt\<^sub>1 (x \<odot>\<^sub>0 y) = \<tau>\<^sub>1 x \<odot>\<^sub>0 \<tau>\<^sub>1 y" (* irredundant *)

lemma (in two_catoid_red) s0t1s0 [simp]:
  "\<sigma>\<^sub>0 (\<tau>\<^sub>1 (\<sigma>\<^sub>0 x)) = \<sigma>\<^sub>0 x"
proof-
  have "{\<tau>\<^sub>1 (\<sigma>\<^sub>0 x)} = Tgt\<^sub>1 (\<sigma>\<^sub>0 x \<odot>\<^sub>0 \<sigma>\<^sub>0 x)"
    by simp
  also have "\<dots> = \<tau>\<^sub>1 (\<sigma>\<^sub>0 x) \<odot>\<^sub>0 \<tau>\<^sub>1 (\<sigma>\<^sub>0 x)"
    using local.t1_hom by blast
  also have "\<dots> = \<tau>\<^sub>1 (\<sigma>\<^sub>0 x) \<odot>\<^sub>0 \<tau>\<^sub>1 (\<tau>\<^sub>1 (\<sigma>\<^sub>0 x))"
    by simp
  also have "\<dots> = Tgt\<^sub>1 (\<sigma>\<^sub>0 x \<odot>\<^sub>0 \<tau>\<^sub>1 (\<sigma>\<^sub>0 x))"
    by (simp add: local.t1_hom)
  finally have "Tgt\<^sub>1 (\<sigma>\<^sub>0 x \<odot>\<^sub>0 \<tau>\<^sub>1 (\<sigma>\<^sub>0 x)) \<noteq> {}"
    by force
  hence "\<sigma>\<^sub>0 x \<odot>\<^sub>0 \<tau>\<^sub>1 (\<sigma>\<^sub>0 x) \<noteq> {}"
    by blast
  thus ?thesis
    using stmm0.s_absorb_var3 by blast
qed

lemma (in two_catoid_red) t0s1s0 [simp]:
  "\<tau>\<^sub>0 (\<sigma>\<^sub>1 (\<sigma>\<^sub>0 x)) = \<sigma>\<^sub>0 x"
proof-
  have "{\<sigma>\<^sub>1 (\<sigma>\<^sub>0 x)} = Src\<^sub>1 (\<sigma>\<^sub>0 x \<odot>\<^sub>0 \<sigma>\<^sub>0 x)"
    by simp
  also have "\<dots> = \<sigma>\<^sub>1 (\<sigma>\<^sub>0 x) \<odot>\<^sub>0 \<sigma>\<^sub>1 (\<sigma>\<^sub>0 x)"
    using local.s1_hom by blast
  also have "\<dots> = \<sigma>\<^sub>1 (\<sigma>\<^sub>1 (\<sigma>\<^sub>0 x)) \<odot>\<^sub>0 \<sigma>\<^sub>1 (\<sigma>\<^sub>0 x)"
    by simp
  also have "\<dots> = Src\<^sub>1 (\<sigma>\<^sub>1 (\<sigma>\<^sub>0 x) \<odot>\<^sub>0 \<sigma>\<^sub>0 x)"
    using local.s1_hom by auto
  finally  have "Src\<^sub>1 (\<sigma>\<^sub>1 (\<sigma>\<^sub>0 x) \<odot>\<^sub>0 \<sigma>\<^sub>0 x) \<noteq> {}"
    by force
  hence "\<sigma>\<^sub>1 (\<sigma>\<^sub>0 x) \<odot>\<^sub>0 \<sigma>\<^sub>0 x \<noteq> {}"
    by blast
  thus ?thesis
    by (simp add: local.Dst0)
qed

lemma (in two_catoid_red) s1s0 [simp]:
  "\<sigma>\<^sub>1 (\<sigma>\<^sub>0 x) = \<sigma>\<^sub>0 x"
proof-
  have "{\<sigma>\<^sub>0 x} = \<sigma>\<^sub>0 x \<odot>\<^sub>0 \<sigma>\<^sub>0 x"
    by simp
  also have "\<dots> = (\<sigma>\<^sub>1 (\<sigma>\<^sub>0 x) \<odot>\<^sub>1 \<sigma>\<^sub>0 x) *\<^sub>0 (\<sigma>\<^sub>0 x \<odot>\<^sub>1 \<tau>\<^sub>1 (\<sigma>\<^sub>0 x))"
    by (simp add: multimagma.conv_atom)
  also have "\<dots> \<subseteq> (\<sigma>\<^sub>1 (\<sigma>\<^sub>0 x) \<odot>\<^sub>0 \<sigma>\<^sub>0 x) *\<^sub>1 (\<sigma>\<^sub>0 x \<odot>\<^sub>0 \<tau>\<^sub>1 (\<sigma>\<^sub>0 x))"
    using local.interchange by blast
  also have "\<dots> = (\<sigma>\<^sub>1 (\<sigma>\<^sub>0 x) \<odot>\<^sub>0 \<tau>\<^sub>0 (\<sigma>\<^sub>1 (\<sigma>\<^sub>0 x))) *\<^sub>1 (\<sigma>\<^sub>0 (\<tau>\<^sub>1 (\<sigma>\<^sub>0 x)) \<odot>\<^sub>0 \<tau>\<^sub>1 (\<sigma>\<^sub>0 x))"
    by simp
  also have "\<dots> = \<sigma>\<^sub>1 (\<sigma>\<^sub>0 x) \<odot>\<^sub>1 \<tau>\<^sub>1 (\<sigma>\<^sub>0 x)"
    using local.mm1.conv_atom local.src0_absorb local.tgt0_absorb by presburger
  finally have "{\<sigma>\<^sub>0 x} \<subseteq> \<sigma>\<^sub>1 (\<sigma>\<^sub>0 x) \<odot>\<^sub>1 \<tau>\<^sub>1 (\<sigma>\<^sub>0 x)".
  thus ?thesis
    using local.stmm1.stopp.Dst by fastforce
qed

lemma (in two_catoid_red) s1t0 [simp]:
  "\<sigma>\<^sub>1 (\<tau>\<^sub>0 x) = \<tau>\<^sub>0 x"
  by (metis local.s1s0 local.stmm0.stopp.ts_compat)

lemma (in two_catoid_red) t1s0 [simp]:
  "\<tau>\<^sub>1 (\<sigma>\<^sub>0 x) = \<sigma>\<^sub>0 x"
  by (simp add: stmm1.st_fix)

lemma (in two_catoid_red) t1t0 [simp]:
  "\<tau>\<^sub>1 (\<tau>\<^sub>0 x) = \<tau>\<^sub>0 x"
  by (simp add: stmm1.st_fix)

lemma (in two_catoid_red) comm_s0s1:
  "\<sigma>\<^sub>0 (\<sigma>\<^sub>1 x) = \<sigma>\<^sub>1 (\<sigma>\<^sub>0 x)"
  by (metis local.s1_hom local.s1s0 stmm0.s_absorb_var)

lemma (in two_catoid_red) comm_s0t1:
  "\<sigma>\<^sub>0 (\<tau>\<^sub>1 x) = \<tau>\<^sub>1 (\<sigma>\<^sub>0 x)"
  by (metis local.t1_hom local.t1s0 stmm0.s_absorb_var)

lemma (in two_catoid_red) comm_t0s1:
  "\<tau>\<^sub>0 (\<sigma>\<^sub>1 x) = \<sigma>\<^sub>1 (\<tau>\<^sub>0 x)"
  by (metis empty_not_insert local.Dst0 local.s1_hom local.s1t0 local.tgt0_absorb)

lemma (in two_catoid_red) comm_t0t1:
  "\<tau>\<^sub>0 (\<tau>\<^sub>1 x) = \<tau>\<^sub>1 (\<tau>\<^sub>0 x)"
  using local.t1_hom local.stmm0.stopp.s_absorb_var2 by fastforce

lemma (in two_catoid_red) s0_weak_hom:
  "Src\<^sub>0 (x \<odot>\<^sub>1 y) \<subseteq> \<sigma>\<^sub>0 x \<odot>\<^sub>1 \<sigma>\<^sub>0 y"
proof cases
  assume "Src\<^sub>0 (x \<odot>\<^sub>1 y) = {}"
  thus ?thesis
    by auto
next
  assume h: "Src\<^sub>0 (x \<odot>\<^sub>1 y) \<noteq> {}"
  hence h1: "\<tau>\<^sub>1 x = \<sigma>\<^sub>1 y"
    by (simp add: local.Dst1)
  hence "Src\<^sub>0 (x \<odot>\<^sub>1 y) = Src\<^sub>0 (Src\<^sub>1 (x \<odot>\<^sub>1 y))"
    unfolding image_def using local.comm_s0s1 by auto
  also have "\<dots> = Src\<^sub>0 (Src\<^sub>1 (x \<odot>\<^sub>1 \<sigma>\<^sub>1 y))"
    using h stmsg1.src_local_cond by auto
  also have "\<dots> = Src\<^sub>0 (Src\<^sub>1 (x \<odot>\<^sub>1 \<tau>\<^sub>1 x))"
    using h1 by presburger
  also have  "\<dots> = {\<sigma>\<^sub>0 x}"
    by (simp add: local.comm_s0s1)
  also have "\<dots> = \<sigma>\<^sub>0 x \<odot>\<^sub>1 \<tau>\<^sub>1 (\<sigma>\<^sub>0 x)"
    using local.tgt1_absorb by presburger
  also have "\<dots> = \<sigma>\<^sub>0 x \<odot>\<^sub>1 \<sigma>\<^sub>0 (\<tau>\<^sub>1 x)"
    by (simp add: local.comm_s0t1)
  also have "\<dots> = \<sigma>\<^sub>0 x \<odot>\<^sub>1 \<sigma>\<^sub>0 (\<sigma>\<^sub>1 y)"
    by (simp add: h1)
  also have "\<dots> = \<sigma>\<^sub>0 x \<odot>\<^sub>1 \<sigma>\<^sub>0 y"
    by (simp add: local.comm_s0s1)
  finally show ?thesis
    by blast
qed

lemma (in two_catoid_red) t0_weak_hom:
  "Tgt\<^sub>0 (x \<odot>\<^sub>1 y) \<subseteq> \<tau>\<^sub>0 x \<odot>\<^sub>1 \<tau>\<^sub>0 y"

  by (metis equals0D image_subsetI insertI1 local.comm_t0s1 local.comm_t0t1 local.stmm1.stopp.Dst local.t1t0 local.tgt1_absorb stmsg1.tgt_comp_aux)

(*
subsection \<open>Cubical catoids\<close>

class cubical_two_st_multimagma = st_multimagma0 + st_multimagma1 +
  (*assumes comm_s0s1: "\<sigma>\<^sub>0 (\<sigma>\<^sub>1 x) = \<sigma>\<^sub>1 (\<sigma>\<^sub>0 x)"*)
  (*assumes comm_s0t1: "\<sigma>\<^sub>0 (\<tau>\<^sub>1 x) = \<tau>\<^sub>1 (\<sigma>\<^sub>0 x)"*)
  (*and comm_t0s1: "\<tau>\<^sub>0 (\<sigma>\<^sub>1 x) = \<sigma>\<^sub>1 (\<tau>\<^sub>0 x)"*)
  (*and comm_t0t1: "\<tau>\<^sub>0 (\<tau>\<^sub>1 x) = \<tau>\<^sub>1 (\<tau>\<^sub>0 x)"*)
  (*assumes interchange: "(w \<odot>\<^sub>1 x) *\<^sub>0 (y \<odot>\<^sub>1 z) \<noteq> {} \<Longrightarrow> (w \<odot>\<^sub>0 y) *\<^sub>1 (x \<odot>\<^sub>0 z) \<noteq> {} \<Longrightarrow> (w \<odot>\<^sub>1 x) *\<^sub>0 (y \<odot>\<^sub>1 z) = (w \<odot>\<^sub>0 y) *\<^sub>1 (x \<odot>\<^sub>0 z)"*)
  assumes s1_hom: "Src\<^sub>1 (x \<odot>\<^sub>0 y) \<subseteq> \<sigma>\<^sub>1 x \<odot>\<^sub>0 \<sigma>\<^sub>1 y"
  (*and t1_hom: "Tgt\<^sub>1 (x \<odot>\<^sub>0 y) \<subseteq> \<tau>\<^sub>1 x \<odot>\<^sub>0 \<tau>\<^sub>1 y"*)
  assumes s0_weak_hom: "Src\<^sub>0 (x \<odot>\<^sub>1 y) \<subseteq> \<sigma>\<^sub>0 x \<odot>\<^sub>1 \<sigma>\<^sub>0 y"
  (*and t0_weak_hom: "Tgt\<^sub>0 (x \<odot>\<^sub>1 y) \<subseteq> \<tau>\<^sub>0 x \<odot>\<^sub>1 \<tau>\<^sub>0 y"*)
  assumes s1s0 [simp]: "\<sigma>\<^sub>1 (\<sigma>\<^sub>0 x) = \<sigma>\<^sub>0 (\<sigma>\<^sub>0 x)"
  (*and s1t0 [simp]: "\<sigma>\<^sub>1 (\<tau>\<^sub>0 x) = \<sigma>\<^sub>0 (\<tau>\<^sub>0 x)"*)
  (*and t1s0 [simp]: "\<tau>\<^sub>1 (\<sigma>\<^sub>0 x) = \<tau>\<^sub>0 (\<sigma>\<^sub>0 x)"*)
  (*and t1t0 [simp]: "\<tau>\<^sub>1 (\<tau>\<^sub>0 x) = \<tau>\<^sub>0 (\<tau>\<^sub>0 x)"*)
  and s1s0x [simp]: "\<sigma>\<^sub>1 (\<sigma>\<^sub>1 x) = \<sigma>\<^sub>0 (\<sigma>\<^sub>1 x)"
  (*and s1t0x [simp]: "\<sigma>\<^sub>1 (\<tau>\<^sub>1 x) = \<sigma>\<^sub>0 (\<tau>\<^sub>1 x)"*)
  (*and t1s0x [simp]: "\<tau>\<^sub>1 (\<sigma>\<^sub>1 x) = \<tau>\<^sub>0 (\<sigma>\<^sub>1 x)"*)
  (*and t1t0x [simp]: "\<tau>\<^sub>1 (\<tau>\<^sub>1 x) = \<tau>\<^sub>0 (\<tau>\<^sub>1 x)"*)

begin

lemma bad1: "\<sigma>\<^sub>0 x = \<sigma>\<^sub>1 x"
  by (metis local.s1_hom local.s1s0 local.s1s0x local.src0_absorb local.src1_absorb local.stmm0.stopp.tt_idem stmm0.st_prop stmm0.ts_compat stmm1.s_export stmm1.s_ortho_iff subset_empty)

lemma bad2: "\<sigma>\<^sub>0 x = \<tau>\<^sub>0 x"
  by (metis empty_iff image_insert insert_subset local.Dst0 local.Dst1 local.s0_weak_hom local.s1_hom local.s1s0 local.s1s0x local.src1_absorb local.stmm0.stopp.ts_compat local.tgt0_absorb stmm0.ts_compat)

lemma bad3: "\<tau>\<^sub>0 x =\<tau>\<^sub>1 x"
  by (metis empty_not_insert ex_in_conv bad1 bad2 image_subset_iff local.Dst1 local.s0_weak_hom local.tgt1_absorb stmm1.ts_compat)

lemma bad4: "\<sigma>\<^sub>1 x =\<tau>\<^sub>1 x"
  using bad1 bad2 bad3 by fastforce

lemma comm_s0s1: "\<sigma>\<^sub>0 (\<sigma>\<^sub>1 x) = \<sigma>\<^sub>1 (\<sigma>\<^sub>0 x)"
  by (metis bot.extremum_unique local.s0_weak_hom local.s1s0x local.src0_absorb local.src1_absorb local.stmm0.stopp.t_idem stmm0.s_export stmm1.s_absorb_var)

lemma comm_s0t1: "\<sigma>\<^sub>0 (\<tau>\<^sub>1 x) = \<tau>\<^sub>1 (\<sigma>\<^sub>0 x)"
  by (metis bot.extremum_unique local.s0_weak_hom local.s1s0 local.src0_absorb local.stmm0.stopp.t_export local.stmm0.stopp.tt_idem local.tgt1_absorb stmm1.s_absorb_var3 stmm1.ts_compat)

lemma comm_t0s1: "\<tau>\<^sub>0 (\<sigma>\<^sub>1 x) = \<sigma>\<^sub>1 (\<tau>\<^sub>0 x)"
  by (metis local.s1_hom local.s1s0 local.src1_absorb local.stmm0.stopp.s_absorb_var2 local.stmm0.stopp.ts_compat local.stmm1.stopp.t_export local.tgt0_absorb stmm1.s_ortho_iff subset_antisym)

lemma comm_t0t1: "\<tau>\<^sub>0 (\<tau>\<^sub>1 x) = \<tau>\<^sub>1 (\<tau>\<^sub>0 x)"
  using local.comm_s0s1 local.comm_s0t1 local.comm_t0s1 local.s1s0x by force

lemma t1_hom: "Tgt\<^sub>1 (x \<odot>\<^sub>0 y) \<subseteq> \<tau>\<^sub>1 x \<odot>\<^sub>0 \<tau>\<^sub>1 y"
  using local.comm_s0s1 local.comm_s0t1 local.s1_hom local.s1s0x local.stmm1.stopp.ts_compat stmm1.ts_compat by auto

lemma t0_weak_hom: "Tgt\<^sub>0 (x \<odot>\<^sub>1 y) \<subseteq> \<tau>\<^sub>0 x \<odot>\<^sub>1 \<tau>\<^sub>0 y"
  using local.comm_s0s1 local.comm_t0s1 local.s0_weak_hom local.s1s0x by auto

lemma s1t0 [simp]: "\<sigma>\<^sub>1 (\<tau>\<^sub>0 x) = \<sigma>\<^sub>0 (\<tau>\<^sub>0 x)"
  by (metis local.s1s0 local.stmm0.stopp.ts_compat)

lemma t1s0 [simp]: "\<tau>\<^sub>1 (\<sigma>\<^sub>0 x) = \<tau>\<^sub>0 (\<sigma>\<^sub>0 x)"
  by (simp add: stmm1.st_fix)

lemma t1t0 [simp]: "\<tau>\<^sub>1 (\<tau>\<^sub>0 x) = \<tau>\<^sub>0 (\<tau>\<^sub>0 x)"
  by (simp add: stmm1.st_fix)

lemma s1t0x [simp]: "\<sigma>\<^sub>1 (\<tau>\<^sub>1 x) = \<sigma>\<^sub>0 (\<tau>\<^sub>1 x)"
  using local.comm_s0s1 local.s1s0x by force

lemma t1s0x [simp]: "\<tau>\<^sub>1 (\<sigma>\<^sub>1 x) = \<tau>\<^sub>0 (\<sigma>\<^sub>1 x)"
  by (metis local.s1s0x local.stmm1.stopp.tt_idem local.t1s0)

lemma t1t0x [simp]: "\<tau>\<^sub>1 (\<tau>\<^sub>1 x) = \<tau>\<^sub>0 (\<tau>\<^sub>1 x)"
  by (metis local.s1t0x local.stmm1.stopp.ts_compat local.t1s0)

lemma s0s1s0s0: "\<sigma>\<^sub>0 (\<sigma>\<^sub>1 x) = \<sigma>\<^sub>0 (\<sigma>\<^sub>0 x)"
  using local.comm_s0t1 local.comm_t0s1 local.comm_t0t1 local.s1t0x by auto

lemma s0t0t0s0: "\<sigma>\<^sub>0 (\<tau>\<^sub>1 x) = \<tau>\<^sub>0 (\<sigma>\<^sub>0 x)"
  by (simp add: local.comm_s0t1)

lemma t0s1s0t0: "\<tau>\<^sub>0 (\<sigma>\<^sub>1 x) = \<sigma>\<^sub>0 (\<tau>\<^sub>0 x)"
  by (simp add: local.comm_t0s1)

lemma t0t1t0t0: "\<tau>\<^sub>0 (\<tau>\<^sub>1 x) = \<tau>\<^sub>0 (\<tau>\<^sub>0 x)"
  by (simp add: local.comm_t0t1)

end

class cubical_two_catoid = cubical_two_st_multimagma + catoid0 + catoid1

begin

lemma "x \<odot>\<^sub>0 y = x \<odot>\<^sub>1 y"
  nitpick
  oops

lemma "x \<odot>\<^sub>0 y = y \<odot>\<^sub>0 x"
  nitpick
  oops

lemma "x \<odot>\<^sub>1 y = y \<odot>\<^sub>1 x"
  nitpick
  oops
*)

end


(*
  Title: Public-key Needham Schroeder Review
  Author: Felipe Rodopoulos de Oliveira
*)

theory Public_NS

imports "~~/src/HOL/Auth/Public"

begin

consts ns_public :: "event list set"

inductive_set nspublic :: "event list set" where

  Nil: "[] \<in> nspublic"

  | Fake: "\<lbrakk>evsf \<in> nspublic; X \<in> synth (analz (knows Spy evsf))\<rbrakk>
    \<Longrightarrow> Says Spy B X # evsf \<in> nspublic"

  | NS1: "\<lbrakk>evs1 \<in> nspublic; Nonce Na \<notin> used evs1\<rbrakk>
    \<Longrightarrow> Says A B (Crypt (pubK B) \<lbrace>Nonce Na, Agent A\<rbrace>) # evs1 \<in> nspublic"

  | NS2: "\<lbrakk>evs2 \<in> nspublic; Nonce Nb \<notin> used evs2;
         Says A' B (Crypt (pubK B) \<lbrace>Nonce Na, Agent A\<rbrace>) \<in> set evs2 \<rbrakk>
    \<Longrightarrow> Says B A (Crypt (pubK A) \<lbrace>Nonce Na, Nonce Nb, Agent B\<rbrace>) # evs2 \<in> nspublic"

  | NS3: "\<lbrakk>evs3 \<in> nspublic;
           Says A B (Crypt (pubK B) \<lbrace>Nonce Na, Agent A\<rbrace>) \<in> set evs3;
           Says B' A (Crypt (pubK A) \<lbrace>Nonce Na, Nonce Nb, Agent B\<rbrace>) \<in> set evs3\<rbrakk>
    \<Longrightarrow> Says A B (Crypt (pubK B) (Nonce Nb)) # evs3 \<in> nspublic"

(* Avaiable lemmas proved along Inductive Method theory *)
declare knows_Spy_partsEs [elim]
declare analz_into_parts [dest]
declare Fake_parts_insert_in_Un [dest]

section\<open>POSSIBILITY LEMMA\<close>

(* Prove that the protocol reaches an end *)
lemma Protocol_terminates :
  "\<exists>Nb. \<exists>evs \<in> nspublic. Says A B (Crypt (pubK B) (Nonce Nb)) \<in> set evs"
  apply (intro exI bexI)
  apply (rule_tac [2] nspublic.NS3)
  apply (rule_tac [2] nspublic.NS2)
  apply (rule_tac [2] nspublic.NS1)
  apply (rule_tac [2] nspublic.Nil)
  apply (possibility)
  done

section\<open>REGULARITY LEMMAS\<close>

lemma Spy_only_see_compromised_keys [simp] :
  "evs \<in> nspublic \<Longrightarrow> (Key (priK A) \<in> parts (knows Spy evs)) = (A \<in> bad)"
  apply (erule nspublic.induct) (* apply protocol steps *)
  (* Just simply everything. Agent A private key never appears in any message *)
  apply (simp_all)
  (* We are left with one subgoal. We have the two first premises.
     Luckily, the third one is presented in Inductive Method theory
  *)
  apply (frule Fake_parts_insert)
  (* Simplify everything. Proof is done. *)
  apply (auto)
  done

lemma Spy_only_see_leaked_keys [simp] :
  "evs \<in> nspublic \<Longrightarrow> (Key (priK A) \<in> analz (knows Spy evs)) = (A \<in> bad)"
  (* This is obvious given that analz H \<subseteq> parts H *)
  apply (auto)
  done

section\<open>UNICITY LEMMAS\<close>

(* Nonces Na and Nb can't be the same in a given trace.
   Otherwise, one of them was generated by the Spy.
*)
lemma No_repeated_nonces [rule_format, simp]:
  "\<lbrakk>Crypt (pubK C) \<lbrace>Na', Nonce Na, Agent D\<rbrace> \<in> parts (knows Spy evs);
    Crypt (pubK B) \<lbrace>Nonce Na, Agent A\<rbrace> \<in> parts (knows Spy evs);
    evs \<in> nspublic\<rbrakk>
  \<Longrightarrow> Nonce Na \<in> analz (knows Spy evs)"
  apply (erule rev_mp)
  apply (erule rev_mp)
  apply (erule nspublic.induct, simp_all)
  apply (blast intro: analz_insertI)+
  done

(* Nonce Na identifies Agents A and B. Thus, if we have two messages with
   the same signature as NS1, their components are the same. *)
lemma Na_uniqueness :
  "\<lbrakk>Crypt (pubK B) \<lbrace>Nonce Na, Agent A\<rbrace> \<in> parts (knows Spy evs);
    Crypt (pubK B') \<lbrace>Nonce Na, Agent A'\<rbrace> \<in> parts (knows Spy evs);
    Nonce Na \<notin> analz (knows Spy evs); evs \<in> nspublic\<rbrakk>
  \<Longrightarrow> A = A' \<and> B = B'"
apply (erule rev_mp)
apply (erule rev_mp)
apply (erule rev_mp)
apply (erule nspublic.induct, simp_all)
apply (auto intro: analz_insertI)
done

(* Nonce Nb identify Agents A and B and, consequently, Nonce Na
   Therefore, if we have two messages with the same signature as NS2
   their components are the same.
*)
lemma Nb_uniqueness [dest] :
  "\<lbrakk>Crypt (pubK A) \<lbrace>Nonce Na, Nonce Nb, Agent B\<rbrace> \<in> parts (knows Spy evs);
    Crypt (pubK A') \<lbrace>Nonce Na', Nonce Nb, Agent B'\<rbrace> \<in> parts (knows Spy evs);
    Nonce Nb \<notin> analz (knows Spy evs); evs \<in> nspublic\<rbrakk>
   \<Longrightarrow> A = A' \<and> B = B' \<and> Na = Na'"
apply (erule rev_mp)
apply (erule rev_mp)
apply (erule rev_mp)
apply (erule nspublic.induct, simp_all)
apply (auto intro: analz_insertI)
done

section\<open>SECRECY LEMMAS\<close>
lemma Na_secrecy :
  "\<lbrakk>Says A B (Crypt (pubK B) \<lbrace>Nonce Na, Agent A\<rbrace>) \<in> set evs;
    A \<notin> bad; B \<notin> bad; evs \<in> nspublic\<rbrakk>
  \<Longrightarrow> Nonce Na \<notin> analz (knows Spy evs)"
apply (erule rev_mp)
apply (erule nspublic.induct, simp_all, spy_analz)
apply (auto intro: No_repeated_nonces dest: Na_uniqueness)
done

(* If B sends message 2 to A and both agents are uncompromised, then Nonce Nb is secure *)
lemma Nb_secrecy :
  "\<lbrakk>Says B A (Crypt (pubK A) \<lbrace>Nonce Na, Nonce Nb, Agent B\<rbrace>) \<in> set evs;
    A \<notin> bad; B \<notin> bad; evs \<in> nspublic\<rbrakk>
    \<Longrightarrow> Nonce Nb \<notin> analz (knows Spy evs)"
apply (erule rev_mp)
apply (erule nspublic.induct, simp_all, spy_analz)
apply (auto intro: No_repeated_nonces)
done

section\<open>TRUST LEMMAS\<close>

lemma A_trusts_NS2 [rule_format] :
  "\<lbrakk>Crypt (pubK A) \<lbrace>Nonce Na, Nonce Nb, Agent B\<rbrace> \<in> parts (knows Spy evs);
    Says A B (Crypt (pubK B) \<lbrace>Nonce Na, Agent A\<rbrace>) \<in> set evs;
    A \<notin> bad; B \<notin> bad; evs \<in> nspublic\<rbrakk>
  \<Longrightarrow> Says B A (Crypt (pubK A) \<lbrace>Nonce Na, Nonce Nb, Agent B\<rbrace>) \<in> set evs"
apply (erule rev_mp, erule rev_mp)
apply (erule nspublic.induct, simp_all)
apply (auto dest: Na_secrecy)
done

(* A trust in B is established when A receives NS2
   containing Nonce Na, sent in the first message
*)
lemma A_trusts_B :
  "\<lbrakk>Says A B (Crypt (pubK B) \<lbrace>Nonce Na, Agent A\<rbrace>) \<in> set evs;
    Says B' A (Crypt (pubK A) \<lbrace>Nonce Na, Nonce Nb, Agent B\<rbrace>) \<in> set evs;
    A \<notin> bad; B \<notin> bad; evs \<in> nspublic\<rbrakk>
  \<Longrightarrow> Says B A (Crypt (pubK A) \<lbrace>Nonce Na, Nonce Nb, Agent B\<rbrace>) \<in> set evs"
by (auto intro: A_trusts_NS2)

(* Step NS1 produces a nonce that can only belong to A, if the Spy doesn't know it *)
lemma B_trusts_NS1 :
  "\<lbrakk>Crypt (pubK B) \<lbrace>Nonce Na, Agent A\<rbrace> \<in> parts (knows Spy evs);
    Nonce Na \<notin> analz (knows Spy evs); evs \<in> nspublic\<rbrakk>
  \<Longrightarrow> Says A B (Crypt (pubK B) \<lbrace>Nonce Na, Agent A\<rbrace>) \<in> set evs"
apply (erule rev_mp, erule rev_mp)
apply (erule nspublic.induct, simp_all)
apply (auto intro: analz_insertI)
done

(* Step NS3 produces relays in a valid nonce Nb given that A and B are uncompromised *)
lemma B_trusts_NS3 :
  "\<lbrakk>Crypt (pubK B) (Nonce Nb) \<in> parts (knows Spy evs);
    Says B A (Crypt (pubK A) \<lbrace>Nonce Na, Nonce Nb, Agent B\<rbrace>) \<in> set evs;
    A \<notin> bad; B \<notin> bad; evs \<in> nspublic\<rbrakk>
  \<Longrightarrow> Says A B (Crypt (pubK B) (Nonce Nb)) \<in> set evs"
apply (erule rev_mp, erule rev_mp)
apply (erule nspublic.induct, simp_all)
apply (auto dest: Nb_secrecy)
done

(* B trust in A is established when B receives NS3
   containing Nonce Nb, sent on NS2
*)
lemma B_trusts_A :
  "\<lbrakk>Says B A (Crypt (pubK A) \<lbrace>Nonce Na, Nonce Nb, Agent B\<rbrace>) \<in> set evs;
    Says A' B (Crypt (pubK B) (Nonce Nb)) \<in> set evs;
    A \<notin> bad; B \<notin> bad; evs \<in> nspublic\<rbrakk>
  \<Longrightarrow> Says A B (Crypt (pubK B) (Nonce Nb)) \<in> set evs"
by (auto intro: B_trusts_NS3)

end


theory PreferenceLogicTests2      (*** Benzmüller & Fuenmayor, 2020 ***)
   imports PreferenceLogicCeterisParibus
begin (*** Tests for the SSE of van Benthem et al, JPL 2009 ***)
(**** Section 5: Equality-based Ceteris Paribus Preference Logic ****)
(*Some tests: dualities*)
lemma "\<lfloor>(\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<preceq>\<phi>) \<^bold>\<leftrightarrow> \<^bold>\<not>([\<Gamma>]\<^sup>\<preceq>\<^bold>\<not>\<phi>)\<rfloor>"  by auto
lemma "\<lfloor>(\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<prec>\<phi>) \<^bold>\<leftrightarrow> \<^bold>\<not>([\<Gamma>]\<^sup>\<prec>\<^bold>\<not>\<phi>)\<rfloor>"  by auto
lemma "\<lfloor>(\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<phi>)  \<^bold>\<leftrightarrow> \<^bold>\<not>([\<Gamma>]\<^bold>\<not>\<phi>)\<rfloor>"    by auto
(*Lemma 2*)
lemma lemma2_1: "(\<^bold>\<diamond>\<^sup>\<preceq>\<phi>) w \<longleftrightarrow> (\<^bold>\<langle>\<^bold>\<emptyset>\<^bold>\<rangle>\<^sup>\<preceq>\<phi>) w" by auto
lemma lemma2_2: "(\<^bold>\<diamond>\<^sup>\<prec>\<phi>) w \<longleftrightarrow> (\<^bold>\<langle>\<^bold>\<emptyset>\<^bold>\<rangle>\<^sup>\<prec>\<phi>) w" by auto
lemma lemma2_3: "((\<^bold>E\<phi>) w \<longleftrightarrow> (\<^bold>\<langle>\<^bold>\<emptyset>\<^bold>\<rangle>\<phi>) w) \<and> ((\<^bold>A\<phi>) w \<longleftrightarrow> ([\<^bold>\<emptyset>]\<phi>) w)" by auto
(**Axiomatization:**)
(*inclusion and interaction axioms *)
lemma Inc1: "\<lfloor>(\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<prec>\<phi>) \<^bold>\<rightarrow> (\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<preceq>\<phi>)\<rfloor>" by auto
lemma Inc2: "\<lfloor>(\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<preceq>\<phi>) \<^bold>\<rightarrow> (\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<phi>)\<rfloor>"  by auto
lemma Int3: "\<lfloor>(\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<preceq>(\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<preceq>\<phi>)) \<^bold>\<rightarrow>(\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<preceq>\<phi>)\<rfloor>"  by (meson tBR)
lemma Int4: "\<lfloor>(\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<prec>(\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<preceq>\<phi>)) \<^bold>\<rightarrow>(\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<prec>\<phi>)\<rfloor>"  by (metis tBR)
lemma Int5: "\<lfloor>(\<psi>\<^bold>\<and>(\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<preceq>\<phi>)) \<^bold>\<rightarrow> ((\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<prec>\<phi>)\<^bold>\<or>(\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<preceq>(\<phi>\<^bold>\<and>(\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<preceq>\<phi>))))\<rfloor>"
  by (metis rBR)
(*ceteris paribus reflexivity*)
lemma CetPar6: "\<phi> \<^bold>\<in> \<Gamma> \<longrightarrow> \<lfloor>(\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<phi>) \<^bold>\<rightarrow> \<phi>\<rfloor>"    by blast
lemma CetPar7: "\<phi> \<^bold>\<in> \<Gamma> \<longrightarrow> \<lfloor>(\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^bold>\<not>\<phi>) \<^bold>\<rightarrow> \<^bold>\<not>\<phi>\<rfloor>" by blast
(*monotonicity*)
lemma CetPar8:  "\<Gamma> \<^bold>\<subseteq> \<Gamma>' \<longrightarrow> \<lfloor>(\<^bold>\<langle>\<Gamma>'\<^bold>\<rangle>\<phi>) \<^bold>\<rightarrow> (\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<phi>)\<rfloor>"   by auto
lemma CetPar9:  "\<Gamma> \<^bold>\<subseteq> \<Gamma>' \<longrightarrow> \<lfloor>(\<^bold>\<langle>\<Gamma>'\<^bold>\<rangle>\<^sup>\<preceq>\<phi>) \<^bold>\<rightarrow> (\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<preceq>\<phi>)\<rfloor>" by auto
lemma CetPar10: "\<Gamma> \<^bold>\<subseteq> \<Gamma>' \<longrightarrow> \<lfloor>(\<^bold>\<langle>\<Gamma>'\<^bold>\<rangle>\<^sup>\<prec>\<phi>) \<^bold>\<rightarrow> (\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<prec>\<phi>)\<rfloor>" by auto
(*increase (decrease) of ceteris paribus sets*)
lemma CetPar11a: "\<lfloor>(\<phi> \<^bold>\<and> (\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>(\<alpha> \<^bold>\<and> \<phi>) )) \<^bold>\<rightarrow> (\<^bold>\<langle>\<Gamma>\<^bold>\<union>\<^bold>{\<phi>\<^bold>}\<^bold>\<rangle>\<alpha>)\<rfloor>"       by auto
lemma CetPar11b: "\<lfloor>((\<^bold>\<not>\<phi>) \<^bold>\<and> (\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>(\<alpha> \<^bold>\<and> \<^bold>\<not>\<phi>))) \<^bold>\<rightarrow> (\<^bold>\<langle>\<Gamma>\<^bold>\<union>\<^bold>{\<phi>\<^bold>}\<^bold>\<rangle>\<alpha>)\<rfloor>"   by auto
lemma CetPar12a: "\<lfloor>(\<phi> \<^bold>\<and> (\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<preceq>(\<alpha> \<^bold>\<and> \<phi>) )) \<^bold>\<rightarrow> (\<^bold>\<langle>\<Gamma>\<^bold>\<union>\<^bold>{\<phi>\<^bold>}\<^bold>\<rangle>\<^sup>\<preceq>\<alpha>)\<rfloor>"     by auto
lemma CetPar12b: "\<lfloor>((\<^bold>\<not>\<phi>) \<^bold>\<and> (\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<preceq>(\<alpha> \<^bold>\<and> \<^bold>\<not>\<phi>))) \<^bold>\<rightarrow> (\<^bold>\<langle>\<Gamma>\<^bold>\<union>\<^bold>{\<phi>\<^bold>}\<^bold>\<rangle>\<^sup>\<preceq>\<alpha>)\<rfloor>" by auto
lemma CetPar13a: "\<lfloor>(\<phi> \<^bold>\<and> (\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<prec>(\<alpha> \<^bold>\<and> \<phi>) )) \<^bold>\<rightarrow> (\<^bold>\<langle>\<Gamma>\<^bold>\<union>\<^bold>{\<phi>\<^bold>}\<^bold>\<rangle>\<^sup>\<prec>\<alpha>)\<rfloor>"     by auto
lemma CetPar13b: "\<lfloor>((\<^bold>\<not>\<phi>) \<^bold>\<and> (\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<prec>(\<alpha> \<^bold>\<and> \<^bold>\<not>\<phi>))) \<^bold>\<rightarrow> (\<^bold>\<langle>\<Gamma>\<^bold>\<union>\<^bold>{\<phi>\<^bold>}\<^bold>\<rangle>\<^sup>\<prec>\<alpha>)\<rfloor>" by auto
(*Example 1, Lemma 4, Corollary 1 and Lemma5*)
lemma Ex1:  "\<lfloor>(([\<Gamma>]\<^sup>\<preceq>\<phi>) \<^bold>\<and> (\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<preceq>\<alpha>)) \<^bold>\<rightarrow> (\<^bold>\<langle>\<Gamma>\<^bold>\<union>\<^bold>{\<phi>\<^bold>}\<^bold>\<rangle>\<^sup>\<preceq>\<alpha>)\<rfloor>" using rBR by auto
lemma Lemma4: "(\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<preceq>\<phi>) w \<longrightarrow> (\<exists>v. (w \<^bold>\<unlhd>\<^sub>\<Gamma> v) \<and> (\<phi> v))"  by simp
lemma Cor1:   "(\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<phi>)  w \<longrightarrow> (\<exists>v. (w \<^bold>\<equiv>\<^sub>\<Gamma> v) \<and> (\<phi> v))"  by simp
lemma Lemma5: "(w \<^bold>\<unlhd>\<^sub>\<Gamma> v) \<longleftrightarrow> ((w \<preceq> v) \<and> (w \<^bold>\<equiv>\<^sub>\<Gamma> v))"    by auto
(**** Section 6: Ceteris Paribus Counterparts ****)
(*AA-variant (drawing upon von Wright's)*)
lemma "(\<phi> \<^bold>\<prec>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>) u \<longleftrightarrow> (\<phi> \<prec>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>) u" nitpick oops (*Ctm*)
lemma "(\<phi> \<^bold>\<prec>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>) u \<longrightarrow> (\<phi> \<prec>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>) u" nitpick oops (*Ctm*)
lemma "(\<phi> \<prec>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>) u \<longrightarrow> (\<phi> \<^bold>\<prec>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>) u" by auto
lemma "is_total SBR \<longrightarrow> (\<phi> \<^bold>\<prec>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>) u \<longleftrightarrow> (\<phi> \<prec>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>) u" by smt
lemma "(\<phi> \<^bold>\<preceq>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>) u  \<longleftrightarrow> (\<phi> \<preceq>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>) u" nitpick oops (*Ctm*)
lemma "(\<phi> \<^bold>\<preceq>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>) u \<longrightarrow> (\<phi> \<preceq>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>) u"  nitpick oops (*Ctm*)
lemma "(\<phi> \<preceq>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>) u \<longrightarrow> (\<phi> \<^bold>\<preceq>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>) u"  by auto
lemma "is_total SBR \<longrightarrow> (\<phi> \<^bold>\<preceq>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>) u \<longleftrightarrow> (\<phi> \<preceq>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>) u"  by smt
(*AE-variant*)
lemma leAE_cp_pref: "(\<phi> \<^bold>\<preceq>\<^sub>A\<^sub>E\<^sup>\<Gamma> \<psi>) u \<longleftrightarrow> (\<phi> \<preceq>\<^sub>A\<^sub>E\<^sup>\<Gamma> \<psi>) u" by auto
lemma leqAE_cp_pref: "(\<phi> \<^bold>\<prec>\<^sub>A\<^sub>E\<^sup>\<Gamma> \<psi>) u \<longleftrightarrow> (\<phi> \<prec>\<^sub>A\<^sub>E\<^sup>\<Gamma> \<psi>) u" by auto
(*miscelaneous tests*)
lemma "let \<Gamma>=\<^bold>\<emptyset> in \<lfloor>(\<phi>\<^bold>\<prec>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>) \<^bold>\<leftrightarrow> (\<phi>\<^bold>\<prec>\<^sub>A\<^sub>A \<psi>)\<rfloor>" by simp
lemma "let \<Gamma>=\<^bold>{\<^bold>\<bottom>\<^bold>} in \<lfloor>(\<phi>\<^bold>\<prec>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>) \<^bold>\<leftrightarrow> (\<phi>\<^bold>\<prec>\<^sub>A\<^sub>A \<psi>)\<rfloor>" by simp
lemma "let \<Gamma>=\<^bold>{\<^bold>\<bottom>,A\<^bold>} in \<lfloor>(\<phi>\<^bold>\<prec>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>) \<^bold>\<leftrightarrow> (\<phi>\<^bold>\<prec>\<^sub>A\<^sub>A \<psi>)\<rfloor>" nitpick oops (*Ctm*)
lemma "let \<Gamma>=\<^bold>{A\<^bold>} in \<lfloor>(\<phi>\<^bold>\<prec>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>) \<^bold>\<rightarrow> (A \<^bold>\<rightarrow> (\<phi>\<^bold>\<prec>\<^sub>A\<^sub>A \<psi>))\<rfloor>" nitpick oops (*Ctm*)
lemma "let \<Gamma>=\<^bold>{A\<^bold>} in \<lfloor>(A \<^bold>\<rightarrow> (\<phi>\<^bold>\<prec>\<^sub>A\<^sub>A \<psi>)) \<^bold>\<rightarrow> (\<phi>\<^bold>\<prec>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>)\<rfloor>" nitpick oops (*Ctm*)
lemma "let \<Gamma>=\<^bold>\<emptyset> in \<lfloor>(\<phi>\<^bold>\<prec>\<^sub>A\<^sub>E\<^sup>\<Gamma> \<psi>) \<^bold>\<leftrightarrow> (\<phi>\<^bold>\<prec>\<^sub>A\<^sub>E \<psi>)\<rfloor>" by simp
lemma "let \<Gamma>=\<^bold>{\<^bold>\<bottom>\<^bold>} in \<lfloor>(\<phi>\<^bold>\<prec>\<^sub>A\<^sub>E\<^sup>\<Gamma> \<psi>) \<^bold>\<leftrightarrow> (\<phi>\<^bold>\<prec>\<^sub>A\<^sub>E \<psi>)\<rfloor>" by simp
lemma "let \<Gamma>=\<^bold>{\<^bold>\<bottom>,A\<^bold>} in \<lfloor>(\<phi>\<^bold>\<prec>\<^sub>A\<^sub>E\<^sup>\<Gamma> \<psi>) \<^bold>\<leftrightarrow> (\<phi>\<^bold>\<prec>\<^sub>A\<^sub>E \<psi>)\<rfloor>" nitpick oops (*Ctm*)
lemma "let \<Gamma>=\<^bold>{A\<^bold>} in \<lfloor>(\<phi>\<^bold>\<prec>\<^sub>A\<^sub>E\<^sup>\<Gamma> \<psi>) \<^bold>\<rightarrow> (A \<^bold>\<rightarrow> (\<phi>\<^bold>\<prec>\<^sub>A\<^sub>E \<psi>))\<rfloor>" by auto
lemma "let \<Gamma>=\<^bold>{A,B\<^bold>} in \<lfloor>(\<phi>\<^bold>\<prec>\<^sub>A\<^sub>E\<^sup>\<Gamma> \<psi>) \<^bold>\<rightarrow> ((A \<^bold>\<and> B) \<^bold>\<rightarrow> (\<phi>\<^bold>\<prec>\<^sub>A\<^sub>E \<psi>))\<rfloor>" by auto
lemma "let \<Gamma>=\<^bold>{A\<^bold>} in \<lfloor>(A \<^bold>\<rightarrow> (\<phi>\<^bold>\<prec>\<^sub>A\<^sub>E \<psi>)) \<^bold>\<rightarrow> (\<phi> \<^bold>\<prec>\<^sub>A\<^sub>E\<^sup>\<Gamma> \<psi>)\<rfloor>" nitpick oops (*Ctm*)
end


(* Copyright 2021 (C) Mihails Milehins *)

section\<open>Smallness for semifunctors\<close>
theory CZH_SMC_Small_Semifunctor
  imports
    CZH_DG_Small_DGHM
    CZH_SMC_Semifunctor
    CZH_SMC_Small_Semicategory
begin

subsection\<open>Semifunctor with tiny maps\<close>

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

locale is_tm_semifunctor = is_semifunctor \<alpha> \<AA> \<BB> \<FF> for \<alpha> \<AA> \<BB> \<FF> +
  assumes tm_smcf_is_tm_dghm[slicing_intros]:
    "smcf_dghm \<FF> : smc_dg \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> smc_dg \<BB>"

syntax "_is_tm_semifunctor" :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> bool"
  (\<open>(_ :/ _ \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>m\<index> _)\<close> [51, 51, 51] 51)
translations "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> \<BB>" \<rightleftharpoons> "CONST is_tm_semifunctor \<alpha> \<AA> \<BB> \<FF>"

abbreviation (input) is_cn_tm_semifunctor :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> bool"
  where "is_cn_tm_semifunctor \<alpha> \<AA> \<BB> \<FF> \<equiv> \<FF> : op_dg \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> \<BB>"

syntax "_is_cn_tm_semifunctor" :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> bool"
  (\<open>(_ :/ _ \<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>m\<mapsto>\<mapsto>\<index> _)\<close> [51, 51, 51] 51)
translations "\<FF> : \<AA> \<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>m\<mapsto>\<mapsto>\<^bsub>\<alpha>\<^esub> \<BB>" \<rightharpoonup> "CONST is_cn_tm_semifunctor \<alpha> \<AA> \<BB> \<FF>"

abbreviation all_tm_smcfs :: "V \<Rightarrow> V"
  where "all_tm_smcfs \<alpha> \<equiv> set {\<FF>. \<exists>\<AA> \<BB>. \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> \<BB>}"

abbreviation small_tm_smcfs :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V"
  where "small_tm_smcfs \<alpha> \<AA> \<BB> \<equiv> set {\<FF>. \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> \<BB>}"

lemma (in is_tm_semifunctor) tm_smcf_is_tm_dghm':
  assumes "\<alpha>' = \<alpha>"
    and "\<AA>' = smc_dg \<AA>"
    and "\<BB>' = smc_dg \<BB>"
  shows "smcf_dghm \<FF> : \<AA>' \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>'\<^esub> \<BB>'"
  unfolding assms by (rule tm_smcf_is_tm_dghm)

lemmas [slicing_intros] = is_tm_semifunctor.tm_smcf_is_tm_dghm'

text\<open>Rules.\<close>

lemma (in is_tm_semifunctor) is_tm_semifunctor_axioms'[smc_small_cs_intros]:
  assumes "\<alpha>' = \<alpha>" and "\<AA>' = \<AA>" and "\<BB>' = \<BB>"
  shows "\<FF> : \<AA>' \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>'\<^esub> \<BB>'"
  unfolding assms by (rule is_tm_semifunctor_axioms)

mk_ide rf is_tm_semifunctor_def[unfolded is_tm_semifunctor_axioms_def]
  |intro is_tm_semifunctorI|
  |dest is_tm_semifunctorD[dest]|
  |elim is_tm_semifunctorE[elim]|

lemmas [smc_small_cs_intros] = is_tm_semifunctorD(1)

text\<open>Slicing.\<close>

context is_tm_semifunctor
begin

interpretation dghm: is_tm_dghm \<alpha> \<open>smc_dg \<AA>\<close> \<open>smc_dg \<BB>\<close> \<open>smcf_dghm \<FF>\<close>
  by (rule tm_smcf_is_tm_dghm)

lemmas_with [unfolded slicing_simps]:
  tm_smcf_ObjMap_in_Vset[smc_small_cs_intros] = dghm.tm_dghm_ObjMap_in_Vset
  and tm_smcf_ArrMap_in_Vset[smc_small_cs_intros] = dghm.tm_dghm_ArrMap_in_Vset

end

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

sublocale is_tm_semifunctor \<subseteq> HomDom: tiny_semicategory \<alpha> \<AA>
proof(rule tiny_semicategoryI')
  show "\<AA>\<lparr>Obj\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
    by (rule vdomain_in_VsetI[OF tm_smcf_ObjMap_in_Vset, unfolded smc_cs_simps])
  show "\<AA>\<lparr>Arr\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
    by (rule vdomain_in_VsetI[OF tm_smcf_ArrMap_in_Vset, unfolded smc_cs_simps])
qed (simp add: smc_cs_intros)

text\<open>Further rules.\<close>

lemma is_tm_semifunctorI':
  assumes [simp]: "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
    and [simp]: "\<FF>\<lparr>ObjMap\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
    and [simp]: "\<FF>\<lparr>ArrMap\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
    and [simp]: "semicategory \<alpha> \<BB>"
  shows "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> \<BB>"
proof(intro is_tm_semifunctorI)
  interpret is_semifunctor \<alpha> \<AA> \<BB> \<FF> by (rule assms(1))
  show "smcf_dghm \<FF> : smc_dg \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> smc_dg \<BB>"
    by (intro is_tm_dghmI', unfold slicing_simps) (auto simp: slicing_intros)
qed simp_all

lemma is_tm_semifunctorD':
  assumes "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> \<BB>"
  shows "semicategory \<alpha> \<BB>"
    and "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
    and "\<FF>\<lparr>ObjMap\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
    and "\<FF>\<lparr>ArrMap\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
proof-
  interpret is_tm_semifunctor \<alpha> \<AA> \<BB> \<FF> by (rule assms(1))
  show "semicategory \<alpha> \<BB>"
    and "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
    and "\<FF>\<lparr>ObjMap\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
    and "\<FF>\<lparr>ArrMap\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
    by (auto intro: smc_cs_intros smc_small_cs_intros)
qed

lemmas [smc_small_cs_intros] = is_tm_semifunctorD'(1)

lemma is_tm_semifunctorE':
  assumes "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> \<BB>"
  obtains "semicategory \<alpha> \<BB>"
    and "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
    and "\<FF>\<lparr>ObjMap\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
    and "\<FF>\<lparr>ArrMap\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
  using is_tm_semifunctorD'[OF assms] by simp

text\<open>Size.\<close>

lemma small_all_tm_smcfs[simp]: "small {\<FF>. \<exists>\<AA> \<BB>. \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> \<BB>}"
proof(rule down)
  show
    "{\<FF>. \<exists>\<AA> \<BB>. \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> \<BB>} \<subseteq>
      elts (set {\<FF>. \<exists>\<AA> \<BB>. \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>})"
  proof
    (
      simp only: elts_of_set small_all_smcfs if_True,
      rule subsetI,
      unfold mem_Collect_eq
    )
    fix \<FF> assume "\<exists>\<AA> \<BB>. \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> \<BB>"
    then obtain \<AA> \<BB> where "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> \<BB>" by clarsimp
    then interpret is_tm_semifunctor \<alpha> \<AA> \<BB> \<FF> by simp
    show "\<exists>\<AA> \<BB>. \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>" by (auto intro: is_semifunctor_axioms)
  qed
qed

subsubsection\<open>Opposite semifunctor with tiny maps\<close>

lemma (in is_tm_semifunctor) is_tm_semifunctor_op:
  "op_smcf \<FF> : op_smc \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> op_smc \<BB>"
  by (intro is_tm_semifunctorI', unfold smc_op_simps)
    (cs_concl cs_intro: smc_cs_intros smc_op_intros smc_small_cs_intros)

lemma (in is_tm_semifunctor) is_tm_semifunctor_op'[smc_op_intros]:
  assumes "\<AA>' = op_smc \<AA>" and "\<BB>' = op_smc \<BB>" and "\<alpha>' = \<alpha>"
  shows "op_smcf \<FF> : \<AA>' \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>'\<^esub> \<BB>'"
  unfolding assms by (rule is_tm_semifunctor_op)

lemmas is_tm_semifunctor_op[smc_op_intros] = is_tm_semifunctor.is_tm_semifunctor_op'

subsubsection\<open>Composition of semifunctors with tiny maps\<close>

lemma smcf_comp_is_tm_semifunctor[smc_small_cs_intros]:
  assumes "\<GG> : \<BB> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> \<CC>" and "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> \<BB>"
  shows "\<GG> \<circ>\<^sub>S\<^sub>M\<^sub>C\<^sub>F \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> \<CC>"
proof(rule is_tm_semifunctorI)
  interpret \<FF>: is_tm_semifunctor \<alpha> \<AA> \<BB> \<FF> by (rule assms(2))
  interpret \<GG>: is_tm_semifunctor \<alpha> \<BB> \<CC> \<GG> by (rule assms(1))
  show "smcf_dghm (\<GG> \<circ>\<^sub>S\<^sub>M\<^sub>C\<^sub>F \<FF>) : smc_dg \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> smc_dg \<CC>"
    unfolding slicing_commute[symmetric]
    using \<FF>.tm_smcf_is_tm_dghm \<GG>.tm_smcf_is_tm_dghm
    by (auto simp: dg_small_cs_intros)
  show "\<GG> \<circ>\<^sub>S\<^sub>M\<^sub>C\<^sub>F \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>" by (auto intro: smc_cs_intros)
qed

subsubsection\<open>Finite semicategories and semifunctors with tiny maps\<close>

lemma (in is_semifunctor) smcf_is_tm_semifunctor_if_HomDom_finite_semicategory:
  assumes "finite_semicategory \<alpha> \<AA>"
  shows "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> \<BB>"
proof(intro is_tm_semifunctorI)
  interpret \<AA>: finite_semicategory \<alpha> \<AA> by (rule assms(1))
  show "smcf_dghm \<FF> : smc_dg \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> smc_dg \<BB>"
    by
      (
        rule is_dghm.dghm_is_tm_dghm_if_HomDom_finite_digraph[
          OF smcf_is_dghm \<AA>.fin_smc_finite_digraph
          ]
      )
qed (auto intro: smc_cs_intros)

subsubsection\<open>Constant semifunctor with tiny maps\<close>

lemma smcf_const_is_tm_semifunctor:
  assumes "tiny_semicategory \<alpha> \<CC>"
    and "semicategory \<alpha> \<DD>"
    and "f : a \<mapsto>\<^bsub>\<DD>\<^esub> a"
    and "f \<circ>\<^sub>A\<^bsub>\<DD>\<^esub> f = f"
  shows "smcf_const \<CC> \<DD> a f : \<CC> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> \<DD>"
proof(intro is_tm_semifunctorI)
  interpret \<CC>: tiny_semicategory \<alpha> \<CC> by (rule assms(1))
  interpret \<DD>: semicategory \<alpha> \<DD> by (rule assms(2))
  show "smcf_dghm (smcf_const \<CC> \<DD> a f) : smc_dg \<CC> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> smc_dg \<DD>"
    unfolding slicing_commute[symmetric]
    by (rule dghm_const_is_tm_dghm)
      (auto simp: slicing_simps \<CC>.tiny_smc_tiny_digraph assms(3) \<DD>.smc_digraph)
  from assms show "smcf_const \<CC> \<DD> a f : \<CC> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
    by (cs_concl cs_shallow cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
qed

lemma smcf_const_is_tm_semifunctor':
  assumes "tiny_semicategory \<alpha> \<CC>"
    and "semicategory \<alpha> \<DD>"
    and "f : a \<mapsto>\<^bsub>\<DD>\<^esub> a"
    and "f \<circ>\<^sub>A\<^bsub>\<DD>\<^esub> f = f"
    and "\<CC>' = \<CC>"
    and "\<DD>' = \<DD>"
  shows "smcf_const \<CC> \<DD> a f : \<CC>' \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> \<DD>'"
  using assms(1-4) unfolding assms(5,6) by (rule smcf_const_is_tm_semifunctor)

lemmas [smc_small_cs_intros] = smcf_const_is_tm_semifunctor'

subsection\<open>Tiny semifunctor\<close>

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

locale is_tiny_semifunctor = is_semifunctor \<alpha> \<AA> \<BB> \<FF> for \<alpha> \<AA> \<BB> \<FF> +
  assumes tiny_smcf_is_tiny_dghm[slicing_intros]:
    "smcf_dghm \<FF> : smc_dg \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<alpha>\<^esub> smc_dg \<BB>"

syntax "_is_tiny_semifunctor" :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> bool"
  (\<open>(_ :/ _ \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<index> _)\<close> [51, 51, 51] 51)
translations "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<alpha>\<^esub> \<BB>" \<rightleftharpoons> "CONST is_tiny_semifunctor \<alpha> \<AA> \<BB> \<FF>"

abbreviation (input) is_cn_tiny_smcf :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> bool"
  where "is_cn_tiny_smcf \<alpha> \<AA> \<BB> \<FF> \<equiv> \<FF> : op_smc \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<alpha>\<^esub> \<BB>"

syntax "_is_cn_tiny_smcf" :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> bool"
  (\<open>(_ :/ _ \<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<mapsto>\<mapsto>\<index> _)\<close> [51, 51, 51] 51)
translations "\<FF> : \<AA> \<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<mapsto>\<mapsto>\<^bsub>\<alpha>\<^esub> \<BB>" \<rightharpoonup> "CONST is_cn_tiny_smcf \<alpha> \<AA> \<BB> \<FF>"

abbreviation all_tiny_smcfs :: "V \<Rightarrow> V"
  where "all_tiny_smcfs \<alpha> \<equiv> set {\<FF>. \<exists>\<AA> \<BB>. \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<alpha>\<^esub> \<BB>}"

abbreviation tiny_smcfs :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V"
  where "tiny_smcfs \<alpha> \<AA> \<BB> \<equiv> set {\<FF>. \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<alpha>\<^esub> \<BB>}"

lemmas [slicing_intros] = is_tiny_semifunctor.tiny_smcf_is_tiny_dghm

text\<open>Rules.\<close>

lemma (in is_tiny_semifunctor) is_tiny_semifunctor_axioms'[smc_small_cs_intros]:
  assumes "\<alpha>' = \<alpha>" and "\<AA>' = \<AA>" and "\<BB>' = \<BB>"
  shows "\<FF> : \<AA>' \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<alpha>'\<^esub> \<BB>'"
  unfolding assms by (rule is_tiny_semifunctor_axioms)

mk_ide rf is_tiny_semifunctor_def[unfolded is_tiny_semifunctor_axioms_def]
  |intro is_tiny_semifunctorI|
  |dest is_tiny_semifunctorD[dest]|
  |elim is_tiny_semifunctorE[elim]|

lemmas [smc_small_cs_intros] = is_tiny_semifunctorD(1)

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

sublocale is_tiny_semifunctor \<subseteq> HomDom: tiny_semicategory \<alpha> \<AA>
proof(intro tiny_semicategoryI')
  interpret dghm: is_tiny_dghm \<alpha> \<open>smc_dg \<AA>\<close> \<open>smc_dg \<BB>\<close> \<open>smcf_dghm \<FF>\<close>
    by (rule tiny_smcf_is_tiny_dghm)
  show "\<AA>\<lparr>Obj\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
    by (rule dghm.HomDom.tiny_dg_Obj_in_Vset[unfolded slicing_simps])
  show "\<AA>\<lparr>Arr\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
    by (rule dghm.HomDom.tiny_dg_Arr_in_Vset[unfolded slicing_simps])
qed (auto simp: smc_cs_intros)

sublocale is_tiny_semifunctor \<subseteq> HomCod: tiny_semicategory \<alpha> \<BB>
proof(intro tiny_semicategoryI')
  interpret dghm: is_tiny_dghm \<alpha> \<open>smc_dg \<AA>\<close> \<open>smc_dg \<BB>\<close> \<open>smcf_dghm \<FF>\<close>
    by (rule tiny_smcf_is_tiny_dghm)
  show "\<BB>\<lparr>Obj\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
    by (rule dghm.HomCod.tiny_dg_Obj_in_Vset[unfolded slicing_simps])
  show "\<BB>\<lparr>Arr\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
    by (rule dghm.HomCod.tiny_dg_Arr_in_Vset[unfolded slicing_simps])
qed (auto simp: smc_cs_intros)

sublocale is_tiny_semifunctor \<subseteq> is_tm_semifunctor
proof(intro is_tm_semifunctorI')
  interpret dghm: is_tiny_dghm \<alpha> \<open>smc_dg \<AA>\<close> \<open>smc_dg \<BB>\<close> \<open>smcf_dghm \<FF>\<close>
    by (rule tiny_smcf_is_tiny_dghm)
  note Vset[unfolded slicing_simps] =
    dghm.tiny_dghm_ObjMap_in_Vset
    dghm.tiny_dghm_ArrMap_in_Vset
  show "\<FF>\<lparr>ObjMap\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>" "\<FF>\<lparr>ArrMap\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>" by (intro Vset)+
qed (auto simp: smc_cs_intros)

text\<open>Further rules.\<close>

lemma is_tiny_semifunctorI':
  assumes "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
    and "tiny_semicategory \<alpha> \<AA>"
    and "tiny_semicategory \<alpha> \<BB>"
  shows "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<alpha>\<^esub> \<BB>"
  using assms
  by
    (
      auto simp:
        smc_cs_simps
        smc_cs_intros
        is_semifunctor.smcf_is_dghm
        is_tiny_dghm.intro
        is_tiny_semifunctorI
        tiny_semicategory.tiny_smc_tiny_digraph
    )

lemma is_tiny_semifunctorD':
  assumes "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<alpha>\<^esub> \<BB>"
  shows "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
    and "tiny_semicategory \<alpha> \<AA>"
    and "tiny_semicategory \<alpha> \<BB>"
proof-
  interpret is_tiny_semifunctor \<alpha> \<AA> \<BB> \<FF> by (rule assms(1))
  show "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
    and "tiny_semicategory \<alpha> \<AA>"
    and "tiny_semicategory \<alpha> \<BB>"
    by (auto intro: smc_small_cs_intros)
qed

lemmas [smc_small_cs_intros] = is_tiny_semifunctorD'(2,3)

lemma is_tiny_semifunctorE':
  assumes "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<alpha>\<^esub> \<BB>"
  obtains "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
    and "tiny_semicategory \<alpha> \<AA>"
    and "tiny_semicategory \<alpha> \<BB>"
  using is_tiny_semifunctorD'[OF assms] by auto

lemma is_tiny_semifunctor_iff:
  "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<alpha>\<^esub> \<BB> \<longleftrightarrow>
    (\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB> \<and> tiny_semicategory \<alpha> \<AA> \<and> tiny_semicategory \<alpha> \<BB>)"
  by (auto intro: is_tiny_semifunctorI' dest: is_tiny_semifunctorD'(2,3))

text\<open>Size.\<close>

lemma (in is_tiny_semifunctor) tiny_smcf_in_Vset: "\<FF> \<in>\<^sub>\<circ> Vset \<alpha>"
proof-
  note [smc_cs_intros] =
    tm_smcf_ObjMap_in_Vset
    tm_smcf_ArrMap_in_Vset
    HomDom.tiny_smc_in_Vset
    HomCod.tiny_smc_in_Vset
  show ?thesis
    by (subst smcf_def)
      (
        cs_concl cs_shallow
          cs_simp: smc_cs_simps cs_intro: smc_cs_intros V_cs_intros
      )
qed

lemma small_all_tiny_smcfs[simp]: "small {\<FF>. \<exists>\<AA> \<BB>. \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<alpha>\<^esub> \<BB>}"
proof(rule down)
  show
    "{\<FF>. \<exists>\<AA> \<BB>. \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<alpha>\<^esub> \<BB>} \<subseteq>
      elts (set {\<FF>. \<exists>\<AA> \<BB>. \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>})"
  proof
    (
      simp only: elts_of_set small_all_smcfs if_True,
      rule subsetI,
      unfold mem_Collect_eq
    )
    fix \<FF> assume "\<exists>\<AA> \<BB>. \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<alpha>\<^esub> \<BB>"
    then obtain \<AA> \<BB> where "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<alpha>\<^esub> \<BB>" by clarsimp
    then interpret is_tiny_semifunctor \<alpha> \<AA> \<BB> \<FF> by simp
    show "\<exists>\<AA> \<BB>. \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>" using is_semifunctor_axioms by auto
  qed
qed

lemma tiny_smcfs_vsubset_Vset[simp]:
  "set {\<FF>. \<exists>\<AA> \<BB>. \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<alpha>\<^esub> \<BB>} \<subseteq>\<^sub>\<circ> Vset \<alpha>"
proof(rule vsubsetI)
  fix \<FF> assume "\<FF> \<in>\<^sub>\<circ> all_tiny_smcfs \<alpha>"
  then obtain \<AA> \<BB> where \<FF>: "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<alpha>\<^esub> \<BB>" by clarsimp
  then show "\<FF> \<in>\<^sub>\<circ> Vset \<alpha>" by (auto simp: is_tiny_semifunctor.tiny_smcf_in_Vset)
qed

lemma (in is_semifunctor) smcf_is_tiny_semifunctor_if_ge_Limit:
  assumes "\<Z> \<beta>" and "\<alpha> \<in>\<^sub>\<circ> \<beta>"
  shows "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<beta>\<^esub> \<BB>"
proof(intro is_tiny_semifunctorI)
  show "smcf_dghm \<FF> : smc_dg \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<beta>\<^esub> smc_dg \<BB>"
    by
      (
        rule is_dghm.dghm_is_tiny_dghm_if_ge_Limit,
        rule smcf_is_dghm;
        intro assms
      )
qed (simp add: smcf_is_semifunctor_if_ge_Limit assms)

subsubsection\<open>Opposite tiny semifunctor\<close>

lemma (in is_tiny_semifunctor) is_tiny_semifunctor_op:
  "op_smcf \<FF> : op_smc \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<alpha>\<^esub> op_smc \<BB>"
  by (intro is_tiny_semifunctorI')
    (cs_concl cs_shallow cs_intro: smc_small_cs_intros smc_op_intros)+

lemma (in is_tiny_semifunctor) is_tiny_semifunctor_op'[smc_op_intros]:
  assumes "\<AA>' = op_smc \<AA>" and "\<BB>' = op_smc \<BB>" and "\<alpha>' = \<alpha>"
  shows "op_smcf \<FF> : \<AA>' \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<alpha>'\<^esub> \<BB>'"
  unfolding assms by (rule is_tiny_semifunctor_op)

lemmas is_tiny_semifunctor_op[smc_op_intros] =
  is_tiny_semifunctor.is_tiny_semifunctor_op'

subsubsection\<open>Composition of tiny semifunctors\<close>

lemma smcf_comp_is_tiny_semifunctor[smc_small_cs_intros]:
  assumes "\<GG> : \<BB> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<alpha>\<^esub> \<CC>" and "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<alpha>\<^esub> \<BB>"
  shows "\<GG> \<circ>\<^sub>S\<^sub>M\<^sub>C\<^sub>F \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<alpha>\<^esub> \<CC>"
proof-
  interpret \<FF>: is_tiny_semifunctor \<alpha> \<AA> \<BB> \<FF> by (rule assms(2))
  interpret \<GG>: is_tiny_semifunctor \<alpha> \<BB> \<CC> \<GG> by (rule assms(1))
  show ?thesis
    by (rule is_tiny_semifunctorI')
      (cs_concl cs_intro: smc_cs_intros smc_small_cs_intros)
qed

subsubsection\<open>Tiny constant semifunctor\<close>

lemma smcf_const_is_tiny_semifunctor:
  assumes "tiny_semicategory \<alpha> \<CC>"
    and "tiny_semicategory \<alpha> \<DD>"
    and "f : a \<mapsto>\<^bsub>\<DD>\<^esub> a"
    and "f \<circ>\<^sub>A\<^bsub>\<DD>\<^esub> f = f"
  shows "smcf_const \<CC> \<DD> a f : \<CC> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<alpha>\<^esub> \<DD>"
proof(intro is_tiny_semifunctorI')
  from assms show "smcf_const \<CC> \<DD> a f : \<CC> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
    by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_small_cs_intros)
qed (auto simp: assms(1,2))

lemma smcf_const_is_tiny_semifunctor'[smc_small_cs_intros]:
  assumes "tiny_semicategory \<alpha> \<CC>"
    and "tiny_semicategory \<alpha> \<DD>"
    and "f : a \<mapsto>\<^bsub>\<DD>\<^esub> a"
    and "f \<circ>\<^sub>A\<^bsub>\<DD>\<^esub> f = f"
    and "\<CC>' = \<CC>"
    and "\<DD>' = \<DD>"
  shows "smcf_const \<CC> \<DD> a f : \<CC>' \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<alpha>\<^esub> \<DD>'"
  using assms(1-4) unfolding assms(5,6) by (rule smcf_const_is_tiny_semifunctor)

text\<open>\newpage\<close>

end


theory LiftEnv
  imports PermEnvMisc
begin

fun lift_use_env where
  "lift_use_env env NoPerm = env"
| "lift_use_env env UsePerm = env"
| "lift_use_env env OwnPerm = (\<lambda> x. if env x = NoPerm then NoPerm else OwnPerm)"

  (*
      only value types can be sent with no permission.
      function types may only be sent with ownership if they themselves do not
      require ownership.
      array types may use onwership if they are sent with ownership
   *)

fun safe_use_lift where
  "safe_use_lift env UsePerm = (\<forall> x. env x \<noteq> OwnPerm)"
| "safe_use_lift env NoPerm = (\<forall> x. env x = NoPerm)"
| "safe_use_lift env OwnPerm = True"

lemma lift_use_none: "\<lbrakk> r_s x = NoPerm \<rbrakk> \<Longrightarrow> lift_use_env r_s r x = NoPerm"
  apply (case_tac r)
    apply (auto)
  done

lemma lift_use_own: "\<lbrakk> r_s x = OwnPerm; safe_use_lift r_s r \<rbrakk> \<Longrightarrow> lift_use_env r_s r x = OwnPerm"
  apply (case_tac r)
    apply (auto)
  done

    (*
      ####################################
        P1. lift equality lemmas
      ####################################
    *)

    (* - simple lift lemmas *)

lemma cancel_lift_use_env_gen: "\<lbrakk> leq_perm r' r \<rbrakk> \<Longrightarrow> lift_use_env (lift_use_env r_s r') r = lift_use_env r_s r"
  apply (case_tac "\<forall> x. lift_use_env (lift_use_env r_s r') r x = lift_use_env r_s r x")
   apply (auto)
  apply (case_tac r')
    apply (auto)
  apply (case_tac r)
    apply (auto)
  done

lemma cancel_lift_use_env: "lift_use_env (lift_use_env r_s r) r = lift_use_env r_s r"
  apply (rule_tac cancel_lift_use_env_gen)
  apply (case_tac r)
    apply (auto)
  done

lemma ann_lift_use_env: "\<lbrakk> r = OwnPerm \<rbrakk> \<Longrightarrow> diff_use_env (lift_use_env r_s q) (lift_use_env r_s r) = empty_use_env"
  apply (case_tac "\<forall> x. diff_use_env (lift_use_env r_s q) (lift_use_env r_s r) x = empty_use_env x")
   apply (auto)
  apply (simp add: diff_use_env_def)
  apply (simp add: empty_use_env_def)
  apply (case_tac q)
    apply (auto)
    apply (case_tac "r_s x")
      apply (auto)
   apply (case_tac "r_s x")
     apply (auto)
  apply (case_tac "r_s x")
    apply (auto)
  done

lemma lift_rem_use_env: "lift_use_env (rem_use_env r_s x) r = rem_use_env (lift_use_env r_s r) x"
  apply (case_tac "\<forall> x'. lift_use_env (rem_use_env r_s x) r x' = rem_use_env (lift_use_env r_s r) x x'")
   apply (auto)
  apply (simp add: rem_use_env_def)
  apply (case_tac r)
    apply (auto)
  done

lemma lift_empty_use_env: "lift_use_env empty_use_env r = empty_use_env"
  apply (case_tac "\<forall> x. lift_use_env empty_use_env r x = empty_use_env x")
   apply (auto)
  apply (case_tac r)
    apply (auto)
  apply (simp add: empty_use_env_def)
  done

    (* - diff / lift lemmas *)

lemma lift_diff_use_env: "diff_use_env (lift_use_env r_s r) r_x = lift_use_env (diff_use_env r_s r_x) r"
  apply (case_tac "\<forall> x. diff_use_env (lift_use_env r_s r) r_x x = lift_use_env (diff_use_env r_s r_x) r x")
   apply (auto)
  apply (simp add: diff_use_env_def)
  apply (case_tac r)
    apply (auto)
  apply (case_tac "r_x x")
    apply (auto)
  done

lemma cancel_diff_lift_use_env: "\<lbrakk> is_own r \<rbrakk> \<Longrightarrow> diff_use_env (lift_use_env r_x q) (lift_use_env r_x r) = empty_use_env"
  apply (case_tac "\<forall> x. diff_use_env (lift_use_env r_x q) (lift_use_env r_x r) x = empty_use_env x")
   apply (auto)
  apply (simp add: diff_use_env_def)
  apply (simp add: empty_use_env_def)
  apply (simp add: is_own_def)
  apply (case_tac q)
    apply (auto)
    apply (case_tac "r_x x")
      apply (auto)
   apply (case_tac "r_x x")
     apply (auto)
  apply (case_tac "r_x x")
    apply (auto)
  done

lemma lhs_lift_diff_use_env: "\<lbrakk> leq_use_env r_x r_s \<rbrakk> \<Longrightarrow> diff_use_env r_x (lift_use_env r_s r) = diff_use_env (lift_use_env r_x r) (lift_use_env r_s r)"
  apply (case_tac "\<forall> x. diff_use_env r_x (lift_use_env r_s r) x = diff_use_env (lift_use_env r_x r) (lift_use_env r_s r) x")
   apply (auto)
  apply (simp add: leq_use_env_def)
  apply (erule_tac x="x" in allE)
  apply (simp add: diff_use_env_def)
  apply (case_tac r)
    apply (auto)
  apply (case_tac "r_x x")
    apply (auto)
  apply (case_tac "r_s x")
    apply (auto)
  done
(*
lemma comm_lift_diff_use_env: "diff_use_env (lift_use_env r_s r) r_x = lift_use_env (diff_use_env r_s r_x) r"
  apply (case_tac "\<forall> x. lift_use_env (diff_use_env r_s r_x) r x = diff_use_env (lift_use_env r_s r) r_x x")
   apply (auto)
  apply (simp add: diff_use_env_def)
  apply (simp add: minus_use_env_def)
  apply (simp add: neg_use_env_def)
  apply (case_tac r)
    apply (auto)
  apply (case_tac "r_s x")
    apply (auto)
   apply (case_tac "r_x x")
     apply (auto)
  apply (case_tac "r_x x")
    apply (auto)
  done*)

lemma outer_lift_diff_use_env: "lift_use_env (diff_use_env r_s r_x) r = diff_use_env (lift_use_env r_s r) r_x"
  apply (case_tac "\<forall> x. lift_use_env (diff_use_env r_s r_x) r x = diff_use_env (lift_use_env r_s r) r_x x")
   apply (auto)
  apply (simp add: diff_use_env_def)
  apply (case_tac r)
    apply (auto)
  apply (case_tac "r_x x")
    apply (auto)
  done

        (* - comp / lift lemmas *)

lemma lift_comp_use_env: "lift_use_env (comp_use_env r_s r_x) r = comp_use_env (lift_use_env r_s r) (lift_use_env r_x r)"
  apply (case_tac "\<forall> x. lift_use_env (comp_use_env r_s r_x) r x = comp_use_env (lift_use_env r_s r) (lift_use_env r_x r) x")
   apply (auto)
  apply (simp add: comp_use_env_def)
  apply (case_tac "r")
    apply (auto)
  apply (case_tac "r_s x")
    apply (auto)
   apply (case_tac "r_x x")
     apply (auto)
  apply (case_tac "r_x x")
    apply (auto)
  done

lemma foil_comp_lift_use_env: "lift_use_env r_s (comp_use_env r_xa r_xb x) = comp_use_env (lift_use_env r_s (r_xa x)) (lift_use_env r_s (r_xb x))"
  apply (case_tac "\<not> (\<forall> x'. lift_use_env r_s (comp_use_env r_xa r_xb x) x' = comp_use_env (lift_use_env r_s (r_xa x)) (lift_use_env r_s (r_xb x)) x')")
   apply (auto)
  apply (simp add: comp_use_env_def)
  apply (case_tac "r_xa x")
    apply (auto)
    apply (case_tac "r_xb x")
      apply (auto)
      apply (case_tac "r_s x'")
        apply (auto)
     apply (case_tac "r_s x'")
       apply (auto)
    apply (case_tac "r_s x'")
      apply (auto)
   apply (case_tac "r_xb x")
     apply (auto)
     apply (case_tac "r_s x'")
       apply (auto)
    apply (case_tac "r_s x'")
      apply (auto)
   apply (case_tac "r_s x'")
     apply (auto)
  apply (case_tac "r_s x'")
    apply (auto)
  apply (case_tac "r_xb x")
    apply (auto)
  done

    (*
      ####################################
        P1. lift ordering lemmas
      ####################################
    *)

lemma self_lift_leq_use_env: "leq_use_env r_s (lift_use_env r_s r)"
  apply (simp add: leq_use_env_def)
  apply (case_tac r)
    apply (auto)
   apply (case_tac "r_s x")
     apply (auto)
  apply (case_tac "r_s x")
    apply (auto)
  done

lemma lift_leq_use_env: "\<lbrakk> leq_use_env r_x r_s \<rbrakk> \<Longrightarrow> leq_use_env r_x (lift_use_env r_s r)"
  apply (rule_tac r_sb="r_s" in trans_leq_use_env)
   apply (rule_tac self_lift_leq_use_env)
  apply (simp)
  done

lemma lift_leq_use_env_rev: "\<lbrakk> leq_use_env (lift_use_env r_x r) r_s \<rbrakk> \<Longrightarrow> leq_use_env r_x r_s"
  apply (rule_tac r_sb="lift_use_env r_x r" in trans_leq_use_env)
   apply (simp)
  apply (rule_tac self_lift_leq_use_env)
  done

lemma dist_lift_leq_use_env: "\<lbrakk> leq_use_env r_x r_s \<rbrakk> \<Longrightarrow> leq_use_env (lift_use_env r_x r) (lift_use_env r_s r)"
  apply (simp add: leq_use_env_def)
  apply (auto)
  apply (erule_tac x="x" in allE)
  apply (case_tac r)
    apply (auto)
  apply (case_tac "r_x x")
  apply (auto)
  done

lemma dist_lift_leq_use_env_gen: "\<lbrakk> leq_perm q r \<rbrakk> \<Longrightarrow> leq_use_env (lift_use_env r_s q) (lift_use_env r_s r)"
  apply (case_tac q)
    apply (auto)
    apply (rule_tac self_lift_leq_use_env)
   apply (rule_tac self_lift_leq_use_env)
  apply (case_tac r)
    apply (auto)
  apply (simp add: leq_use_env_def)
  done

lemma lhs_lift_leq_use_env: "\<lbrakk> leq_use_env r_x (lift_use_env r_s r); is_own r \<rbrakk> \<Longrightarrow> leq_use_env (lift_use_env r_x q) (lift_use_env r_s r)"
  apply (simp add: leq_use_env_def)
  apply (auto)
  apply (erule_tac x="x" in allE)
  apply (simp add: is_own_def)
  apply (auto)
  apply (case_tac "r_x x")
    apply (auto)
  apply (case_tac q)
    apply (auto)
  done

lemma lhs_lift_leq_use_env_gen: "\<lbrakk> leq_use_env r_x (lift_use_env r_s r); leq_perm q r \<rbrakk> \<Longrightarrow> leq_use_env (lift_use_env r_x q) (lift_use_env r_s r)"
  apply (simp add: leq_use_env_def)
  apply (auto)
  apply (erule_tac x="x" in allE)
  apply (case_tac r)
    apply (auto)
    apply (case_tac q)
      apply (auto)
   apply (case_tac q)
     apply (auto)
  apply (case_tac "r_x x")
    apply (auto)
  apply (case_tac q)
    apply (auto)
  done

    (* - diff / lift lemmas *)

lemma spec_diff_lift_leq_use_env: "leq_use_env (diff_use_env (lift_use_env r_s r) (lift_use_env r_s r)) (diff_use_env r_s (lift_use_env r_s r))"
  apply (simp add: leq_use_env_def)
  apply (simp add: diff_use_env_def)
  apply (case_tac r)
    apply (auto)
   apply (case_tac "r_s x")
     apply (auto)
  apply (case_tac "r_s x")
    apply (auto)
  done

lemma spec_diff_lift_leq_use_env_gen: "\<lbrakk> leq_perm q r \<rbrakk> \<Longrightarrow>
  leq_use_env (diff_use_env (lift_use_env r_s q) (lift_use_env r_s r)) (diff_use_env r_s (lift_use_env r_s r))"
  apply (simp add: leq_use_env_def)
  apply (simp add: diff_use_env_def)
  apply (case_tac q)
    apply (auto)
     apply (case_tac r)
       apply (auto)
      apply (case_tac "r_s x")
        apply (auto)
     apply (case_tac "r_s x")
       apply (auto)
    apply (case_tac r)
      apply (auto)
    apply (case_tac "r_s x")
      apply (auto)
      apply (case_tac "r_s x")
        apply (auto)
   apply (case_tac r)
     apply (auto)
  apply (case_tac r)
    apply (auto)
  done

lemma cancel_lift_leq_use_env: "\<lbrakk> is_own r \<rbrakk> \<Longrightarrow> leq_use_env (diff_use_env (lift_use_env r_s r) (lift_use_env r_s r)) r_ex"
  apply (simp add: is_own_def)
  apply (simp add: diff_use_env_def)
  apply (simp add: leq_use_env_def)
  done

    (*
      ####################################
        P1. misc lift lemmas
      ####################################
    *)

lemma disj_lift_use_envr: "\<lbrakk> disj_use_env r_s (lift_use_env r_x r) \<rbrakk> \<Longrightarrow> disj_use_env r_s r_x"
  apply (rule_tac r_s="lift_use_env r_x r" in disj_leq_use_env2)
   apply (auto)
  apply (rule_tac self_lift_leq_use_env)
  done

lemma weak_lift_use_env: "\<lbrakk> weak_use_env r_s; r \<noteq> OwnPerm \<rbrakk> \<Longrightarrow> weak_use_env (lift_use_env r_s r)"
  apply (simp add: weak_use_env_def)
  apply (auto)
  apply (erule_tac x="x" in allE)
  apply (case_tac r)
    apply (auto)
  done

lemma weak_lift_empty_use_env: "weak_use_env (lift_use_env empty_use_env r)"
  apply (simp add: weak_use_env_def)
  apply (auto)
  apply (case_tac r)
    apply (auto)
    apply (simp add: empty_use_env_def)
   apply (simp add: empty_use_env_def)
  apply (simp add: empty_use_env_def)
  done

    (*
      ####################################
        P1. lift safety lemmas
      ####################################
    *)

lemma self_safe_leq_perm: "\<lbrakk> safe_use_lift r_s r \<rbrakk> \<Longrightarrow> leq_perm (r_s x) r"
  apply (case_tac r)
    apply (auto)
  apply (case_tac "r_s x")
    apply (auto)
  done

lemma safe_lift_leq_use_env: "\<lbrakk> leq_use_env r_x r_s; safe_use_lift r_s r \<rbrakk> \<Longrightarrow> safe_use_lift r_x r"
  apply (simp add: leq_use_env_def)
  apply (case_tac r)
    apply (auto)
   apply (erule_tac x="x" in allE)
   apply (case_tac "r_x x")
    apply (auto)
  apply (erule_tac x="x" in allE)
  apply (erule_tac x="x" in allE)
  apply (case_tac "r_s x")
    apply (auto)
  done

lemma safe_lift_empty_use_env: "\<lbrakk> safe_use_lift r_s r \<rbrakk> \<Longrightarrow> safe_use_lift empty_use_env r"
  apply (case_tac r)
    apply (simp_all add: empty_use_env_def)
  done

lemma safe_lift_rem_use_env: "\<lbrakk> safe_use_lift r_s r \<rbrakk> \<Longrightarrow> safe_use_lift (rem_use_env r_s x) r"
  apply (simp add: rem_use_env_def)
  apply (case_tac r)
    apply (auto)
  done

lemma safe_lift_leq_perm: "\<lbrakk> safe_use_lift r_s r'; leq_perm r' r \<rbrakk> \<Longrightarrow> safe_use_lift r_s r"
  apply (case_tac r)
    apply (auto)
   apply (case_tac r')
     apply (auto)
  apply (case_tac r')
    apply (auto)
  done

lemma safe_lift_comp_use_env: "\<lbrakk> safe_use_lift r_s r; safe_use_lift r_x r \<rbrakk> \<Longrightarrow> safe_use_lift (comp_use_env r_s r_x) r"
  apply (case_tac r)
    apply (auto)
  apply (erule_tac x="x" in allE)
  apply (erule_tac x="x" in allE)
  apply (simp add: comp_use_env_def)
  apply (simp add: comp_use_env_def)
  apply (case_tac "r_s x")
    apply (auto)
   apply (case_tac "r_x x")
     apply (auto)
  apply (case_tac "r_x x")
    apply (auto)
  done
(*
lemma safe_lift_perm_use_env: "\<lbrakk> leq_perm q r; safe_use_lift r_s q \<rbrakk> \<Longrightarrow> safe_use_lift r_s r"
  apply (case_tac q)
    apply (auto)
   apply (case_tac r)
     apply (auto)
  apply (case_tac r)
    apply (auto)
  done*)

lemma safe_lift_cancel_use_env: "\<lbrakk> safe_use_lift r_x q; r = OwnPerm \<rbrakk> \<Longrightarrow> safe_use_lift (diff_use_env r_s (lift_use_env r_s r)) q"
  apply (auto)
  apply (simp add: diff_use_env_def)
  apply (case_tac q)
    apply (auto)
  done

lemma safe_lift_diff_use_env: "\<lbrakk> safe_use_lift r_s r \<rbrakk> \<Longrightarrow> safe_use_lift (diff_use_env r_s r_x) r"
  apply (case_tac r)
    apply (auto)
   apply (simp add: diff_use_env_def)
   apply (case_tac "r_x x")
     apply (auto)
  apply (simp add: diff_use_env_def)
  apply (erule_tac x="x" in allE)
  apply (case_tac "r_x x")
    apply (auto)
  done

lemma safe_lift_twice_use_env: "\<lbrakk> safe_use_lift r_s q; leq_perm q r \<rbrakk> \<Longrightarrow> safe_use_lift (lift_use_env r_s q) r"
  apply (case_tac q)
    apply (auto)
   apply (case_tac r)
     apply (auto)
  apply (case_tac r)
    apply (auto)
  apply (case_tac r)
    apply (auto)
  done

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_weird_nat_add3acc_comm13
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun add3acc :: "Nat => Nat => Nat => Nat" where
"add3acc (Z) (Z) z = z"
| "add3acc (Z) (S x3) z = add3acc Z x3 (S z)"
| "add3acc (S x2) y z = add3acc x2 (S y) z"

theorem property0 :
  "((add3acc x y z) = (add3acc z y x))"
  oops

end