theory Symmetric_Closed_Monoidal_Category
  imports Closed_Monoidal_Category

begin

section \<open>Symmetric closed monoidal category\<close>

locale SymmetricMonClosedCat =
LM: LeftClosedMonCatBifunctor domain codomain composition nonex T \<alpha> \<mu> \<rho> \<e> Impl \<Phi> \<Psi> +
Sym: Symmetry domain codomain composition nonex T \<alpha> \<gamma>
for
  domain::"'a\<Rightarrow>'a" ("dom _") and
  codomain::"'a\<Rightarrow>'a" ("cod _") and
  composition::"'a\<Rightarrow>'a\<Rightarrow>'a" (infix "\<cdot>" 110) and
  nonex :: "'a" ("*") and
  T :: "'a * 'a \<Rightarrow> 'a" and
  \<alpha> :: "'a * 'a * 'a \<Rightarrow> 'a" and
  \<mu> :: "'a \<Rightarrow> 'a" and
  \<rho> :: "'a \<Rightarrow> 'a" and
  \<e> :: "'a" and
  \<gamma> :: "'a * 'a \<Rightarrow> 'a" and
  Impl :: "'a * 'a \<Rightarrow> 'a" and
  \<Phi> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" and
  \<Psi> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" +
fixes
  FalseM :: "'a" ("\<bottom>\<^sub>m")
assumes
  FM: "LM.A.IdEx (\<bottom>\<^sub>m)"
begin

subsection \<open>Definition of right closed structure via left closed structure\<close>

abbreviation Impr
  where "Impr AB \<equiv> Impl AB"

abbreviation ImprA (infix "\<circ>-" 56)
  where "y \<circ>- x \<equiv> Impr(y,x)"

abbreviation \<Phi>r :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"
  where "\<Phi>r b a x \<equiv> \<Phi> a b (x\<cdot>\<gamma>(a,b))"

abbreviation \<Psi>r :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"
  where "\<Psi>r a c x \<equiv> (\<Psi> a c x)\<cdot>\<gamma>(dom x,a)"

lemma \<Phi>r_simp[simp]:
  assumes "LM.A.Id a \<and> LM.A.Id b"
  shows "\<Phi>r b a x = \<Phi> a b (x\<cdot>\<gamma>(a,b))" by blast

lemma RCS_A1:
  assumes "LM.A.Id a \<and> LM.A.Id b" and "E f"
  shows "T(b,f)\<cdot>\<gamma>(dom f,b) \<cong> \<gamma>(cod f,b)\<cdot>T(f,b)"
  by (smt LM.A.Ex_two_ob2 LM.A.Id3 LM.A.S5 LM.A.S6 LM.M.AxA.Ex2 LM.M.T.BiF.reflects_morp Sym.Braid.Br.\<eta>.naturality Sym.Braid.Br.\<eta>.nntExists Sym.Braid.Br.\<eta>.preserves_comp assms(1) assms(2) fst_conv snd_conv)

lemma RCS_B1:
  assumes "LM.A.Id a \<and> LM.A.Id b" and "E f"
  shows "T(f,a)\<cdot>\<gamma>(a,dom f) \<cong> \<gamma>(a,cod f)\<cdot>T(a,f)"
  using Sym.Braid.Br.\<eta>.naturality by (smt LM.A.Ex_two_ob1 LM.A.Id3 LM.Impl.AopxA.prod_S5 LM.M.AxA.Ex LM.M.T.BiF.reflects_morp Sym.Braid.Br.\<eta>.nntExists Sym.Braid.Br.\<eta>.preserves_comp assms(1) assms(2) fst_conv snd_conv)

lemma RCS_A:
  assumes "(f:(b\<otimes>a)\<rightarrow>\<^sub>Ac) \<and> (LM.A.IdEx a) \<and> (LM.A.IdEx b) \<and> ((cod x) = a)"
  shows "(\<Phi>r b (dom x) (f \<cdot> (b\<otimes>x)) \<simeq> (x\<circ>-c)\<cdot>(\<Phi>r b a f))"
proof-
  have 01: "E x" using LM.A.S2 assms by blast
  have 1: "LM.A.from_hom_seta (f\<cdot>\<gamma>(a,b)) (T(a,b)) c" by (smt LM.A.Id2 LM.A.Id_ex LM.A.S3 LM.A.S5 LM.A.cod_of_comp LM.A.dom_of_comp LM.M.tensor_ide Sym.Braid.Br.\<eta>.presCod Sym.Braid.Br.\<eta>.presDom assms fst_conv snd_conv)
  then have 2: "(x-\<circ>c)\<cdot>(\<Phi> a b (f\<cdot>\<gamma>(a,b))) \<simeq> (\<Phi> (dom x) b ((f\<cdot>\<gamma>(a,b))\<cdot>T(x,b)))" using LM.NaturalityA by (metis assms)
  also have 3: "(\<Phi>r b (dom x) (f \<cdot> (T(b,x))) = (\<Phi> (dom x) b ((f\<cdot>T(b,x))\<cdot>\<gamma>((dom x),b))))" by blast
  have 4: "(\<Phi> (dom x) b ((f\<cdot>T(b,x))\<cdot>\<gamma>((dom x),b))) = (\<Phi> (dom x) b (f\<cdot>(T(b,x)\<cdot>\<gamma>((dom x),b))))" by (smt "01" LM.A.Ex_from_hom_set LM.A.FHS LM.A.Id2 LM.A.Id3 LM.A.Id_ex2 LM.A.S3 LM.A.dom_of_comp LM.A.from_hom_set_def LM.Aop.S3 LM.Aop.S4 LM.Aop.S6 LM.Aop.dom_cod LM.M.T.BiF.pres1 LM.M.T.BiF.pres2 LM.M.T.BiF.reflects_morp LM.M.tensor_arrow_2 LM.M.tensor_codomain LM.M.tensor_domain Sym.Braid.Br.G.ntExists Sym.Braid.Br.\<eta>.ntExists Sym.Braid.Br_inv.presCod Sym.symmetry assms fst_eqD snd_eqD)
  have 5: "T(b,x)\<cdot>\<gamma>((dom x),b) = (\<gamma>(a,b)\<cdot>T(x,b))" by (smt "01" LM.A.Ex_two_ob2 LM.A.S5 LM.A.S6 LM.M.T.BiF.reflects_morp LM.M.tensor_arrow_2 Sym.Braid.Br.\<eta>.naturality Sym.Braid.Br.\<eta>.preserves_comp assms fst_conv snd_conv)
  then have 6: "(\<Phi> (dom x) b (f\<cdot>(T(b,x)\<cdot>\<gamma>((dom x),b)))) = (\<Phi> (dom x) b (f\<cdot>(\<gamma>(a,b)\<cdot>T(x,b))))" by presburger
  then have 7: "(\<Phi>r b (dom x) (f \<cdot> (T(b,x))) \<simeq> (x\<circ>-c)\<cdot>(\<Phi>r b a f))" by (metis "1" "4" LM.A.S1 LM.A.S4 LM.Aop.ExDomCod(1) LM.M.tensor_morph assms calculation)
  then show ?thesis by blast
qed

lemma RCS_B:
  assumes "(f:(b\<otimes>a)\<rightarrow>\<^sub>Ac) \<and> (LM.A.IdEx a) \<and> (LM.A.IdEx b) \<and> ((cod y) = b)"
  shows "(\<Phi>r (dom y) a (f \<cdot> (y\<otimes>a)) \<simeq> (\<Phi>r b a f)\<cdot>y)"
proof-
  have 01: "E f" using LM.A.par_ex2 assms by blast
  have 1: "LM.A.from_hom_seta (f\<cdot>\<gamma>(a,b)) (T(a,b)) c" by (smt LM.A.Id_ex LM.A.Id_ex2 LM.A.S3 LM.A.cod_of_comp LM.A.dom_of_comp LM.Aop.dom_cod LM.M.tensor_arrow_2 LM.M.tensor_ide Sym.Braid.Br.\<eta>.presCod Sym.Braid.Br.\<eta>.presDom assms fst_conv snd_conv)
  then have 2: "((\<Phi> a (dom y) ((f\<cdot>\<gamma>(a,b)) \<cdot> (T(a,y))) \<simeq> (\<Phi> a b (f\<cdot>\<gamma>(a,b)))\<cdot>y))" using LM.NaturalityB using assms by blast
  also have 3: "(\<Phi>r (dom y) a (f \<cdot> (T(y,a))) = (\<Phi> a (dom y) ((f\<cdot>T(y,a))\<cdot>\<gamma>(a,(dom y)))))" by blast
  have 4: "(\<Phi> a (dom y) ((f\<cdot>T(y,a))\<cdot>\<gamma>(a,(dom y)))) = (\<Phi> a (dom y) (f\<cdot>(T(y,a)\<cdot>\<gamma>(a,(dom y)))))" by (smt LM.A.Ex_two_ob2 LM.A.S1 LM.A.S3 LM.A.S4 LM.A.S5 LM.M.AxA.Ex2 Sym.Braid.Br.\<eta>.naturality assms calculation fst_conv snd_conv)
  have 5: "T(y,a)\<cdot>\<gamma>(a,(dom y)) = \<gamma>(a,cod y)\<cdot>T(a,y)" by (smt LM.A.Id_ex2 LM.Aop.Ex_two_ob1 LM.Aop.S6 LM.M.AxA.Ex RCS_B1 Sym.Braid.Br.\<eta>.naturality assms calculation fst_conv snd_conv)
  then have 6: "(\<Phi> a (dom y) (f\<cdot>(T(y,a)\<cdot>\<gamma>(a,(dom y))))) = (\<Phi> a (dom y) (f\<cdot>(\<gamma>(a,cod y)\<cdot>T(a,y))))" by presburger
  then have 7: "((\<Phi>r (dom y) a (f \<cdot> (T(y,a))) \<simeq> (\<Phi>r b a f)\<cdot>y))" by (smt LM.A.S1 LM.A.S3 LM.A.S4 LM.A.S5 LM.A.S6 LM.M.T.BiF.reflects_morp LM.M.tensor_arrow_2 Sym.Braid.Br.\<eta>.naturality assms calculation fst_conv snd_conv)
  then show ?thesis by blast
qed

lemma RCS_C:
  assumes "(f:(b\<otimes>a)\<rightarrow>\<^sub>Ac) \<and> (LM.A.IdEx a) \<and> (LM.A.IdEx b) \<and> ((dom z) = c)"
  shows "(\<Phi>r b a (z \<cdot> f) \<simeq> ((a\<circ>-z))\<cdot>(\<Phi>r b a f))"
proof-
  have 01: "E f" using assms LM.A.S1 by blast
  have 1: "LM.A.from_hom_seta (f\<cdot>\<gamma>(a,b)) (T(a,b)) c" by (smt LM.A.Id_ex LM.A.Id_ex2 LM.A.S3 LM.A.cod_of_comp LM.A.dom_of_comp LM.Aop.dom_cod LM.M.tensor_arrow_2 LM.M.tensor_ide Sym.Braid.Br.\<eta>.presCod Sym.Braid.Br.\<eta>.presDom assms fst_conv snd_conv)
  then have 2: "(\<Phi> a b (z \<cdot> (f\<cdot>\<gamma>(a,b))) \<simeq> (a-\<circ>z)\<cdot>(\<Phi> a b (f\<cdot>\<gamma>(a,b))))" using LM.NaturalityC using assms by blast
  also have 3: "\<Phi>r b a (z \<cdot> f) = (\<Phi> a b ((z \<cdot> f) \<cdot>\<gamma>(a,b)))" by blast
  then have 4: "((\<Phi>r b a (z \<cdot> f) \<simeq> (a\<circ>-z)\<cdot>\<Phi>r b a f))" by (metis "1" LM.A.S3 LM.A.S4 assms calculation)
  then show ?thesis by blast
qed

lemma RCS_ABC:
  assumes "((f:(b\<otimes>a)\<rightarrow>\<^sub>Ac) \<and> (LM.A.IdEx a) \<and> (LM.A.IdEx b) \<and> ((cod x) = a) \<and> ((cod y) = b) \<and> ((dom z) = c))"
  shows "(\<Phi>r (dom y) (dom x) (z\<cdot>(f\<cdot>(y\<otimes>x))) \<simeq> (Impr(x,z))\<cdot>((\<Phi>r b a f)\<cdot>y))"
proof-
  have 1: "(((f\<cdot>\<gamma>(a,b)):(a\<otimes>b)\<rightarrow>\<^sub>Ac) \<and> (LM.A.IdEx a) \<and> (LM.A.IdEx b) \<and> ((cod x) = a) \<and> ((cod y) = b) \<and> ((dom z) = c))" by (smt LM.A.Id_ex LM.A.Id_ex2 LM.A.S3 LM.A.cod_of_comp LM.A.dom_of_comp LM.Aop.dom_cod LM.M.tensor_arrow_2 LM.M.tensor_ide Sym.Braid.Br.\<eta>.presCod Sym.Braid.Br.\<eta>.presDom assms fst_conv snd_conv)
  then have 2: "(\<Phi> (dom x) (dom y) (z\<cdot>((f\<cdot>\<gamma>(a,b))\<cdot>(x\<otimes>y)))) \<simeq> (Impl(x,z))\<cdot>((\<Phi> a b (f\<cdot>\<gamma>(a,b)))\<cdot>y)" using LM.NaturalityD\<Phi> by blast
  have 3: "(z\<cdot>((f\<cdot>\<gamma>(a,b))\<cdot>(x\<otimes>y))) \<simeq> (z\<cdot>(f\<cdot>(\<gamma>(a,b)\<cdot>(x\<otimes>y))))" by (smt "1" LM.A.FHS LM.A.S2 LM.A.S3 LM.A.S4 LM.Aop.ExDomCod(1) LM.M.tensor_codomain)
  have 4: "\<gamma>(cod x,cod y)\<cdot>(x\<otimes>y) \<cong> (y\<otimes>x)\<cdot>\<gamma>(dom x, dom y)" using Sym.Braid.Br.\<eta>.naturality by (smt LM.A.Ex_two_ob1 LM.A.Ex_two_ob2 LM.A.FHS LM.A.S6 LM.A.cod_of_comp LM.M.AxA.Ex2 LM.M.T.BiF.nntExists LM.M.tensor_codomain Sym.Braid.Br.\<eta>.ActOnMorph fst_eqD snd_eqD)
  then show ?thesis using 2 3 by (metis "1" LM.A.Ex_two_ob2 LM.A.S4)
qed

interpretation RightClosedStr: RightClosedMonCatBifunctor domain codomain composition nonex T \<alpha> \<mu> \<rho> \<e> Impr \<Phi>r \<Psi>r
  apply unfold_locales
  apply (smt LM.A.Id_ex LM.A.S3 LM.A.cod_of_comp LM.A.dom_of_comp LM.Aop.dom_cod LM.FunctionSet\<Phi> LM.M.AxA.Ex2 LM.M.T.BiF.reflects_morp LM.M.tensor_arrow_2 LM.M.tensor_ide Sym.Braid.Br.\<eta>.presCod Sym.Braid.Br.\<eta>.presDom fst_conv snd_conv)
  apply (smt LM.A.Id_ex LM.A.Id_ex2 LM.A.S3 LM.A.S5 LM.A.cod_of_comp LM.A.dom_of_comp LM.Aop.double_cod LM.FunctionSet\<Psi> LM.Impl.BiF.nntExists LM.M.AxA.Ex2 LM.M.tensor_ide Sym.Braid.Br.\<eta>.presCod Sym.Braid.Br.\<eta>.presDom fst_conv snd_conv)
  apply (smt LM.A.Id_ex LM.A.Id_ex2 LM.A.S3 LM.A.S4 LM.A.S5 LM.A.arrow_and_inv1 LM.A.cod_of_comp LM.BijectionOne LM.FunctionSet\<Phi> LM.M.AxA.Ex2 LM.M.tensor_ide Sym.Braid.Br.\<eta>.ntExists Sym.Braid.Br_inv.comp_iso Sym.Braid.Br_inv.identity_under_map Sym.Braid.Br_inv.int1 Sym.symmetry fst_conv snd_conv)
  apply (smt LM.A.Id_ex2 LM.A.S3 LM.A.S4 LM.A.S5 LM.A.arrow_and_inv1 LM.A.from_hom_set_def LM.Aop.double_cod LM.BijectionTwo LM.FunctionSet\<Psi> LM.M.AxA.Ex2 Sym.Braid.Br.comp_iso Sym.Braid.Br_inv.identity_under_map Sym.Braid.Br_inv.int1 Sym.symmetry fst_conv snd_conv)
  using RCS_ABC by blast

theorem RightMonoidalStructure:
  shows "RightClosedMonCatBifunctor domain codomain composition nonex T \<alpha> \<mu> \<rho> \<e> Impr \<Phi>r \<Psi>r"
  using RightClosedStr.RightClosedMonCatBifunctor_axioms by blast

subsection \<open>Naturality of inverse bijection\<close>

lemma NaturalityInvA:
  assumes "((x:b\<rightarrow>\<^sub>A(a-\<circ>c)) \<and> LM.A.Id a \<and> LM.A.Id c) \<and> ((cod f) = a)"
  shows "((\<Psi> a c x)\<cdot>T(f,b)) \<simeq> (\<Psi> (dom f) c ((f-\<circ>c)\<cdot>x))"
proof
  assume n:  "\<^bold>\<not> (E ((f \<otimes> b) \<cdot>op \<Psi> a c x)) \<^bold>\<or>
    \<^bold>\<not> (\<^bold>\<not> (\<^bold>\<not> (E (\<Psi> (LM.Aop.codop f) c (x \<cdot>op RightClosedStr.RImplication f c))) \<^bold>\<or>
             (f \<otimes> b) \<cdot>op \<Psi> a c x \<noteq>
             \<Psi> (LM.Aop.codop f) c (x \<cdot>op RightClosedStr.RImplication f c)))"
  hence n2: "\<not>((\<Psi> a c x)\<cdot>T(f,b) \<simeq> \<Psi> (dom f) c ((f-\<circ>c)\<cdot>x))" by blast
  have 1: "\<not>((\<Psi> a c x)\<cdot>T(f,b) \<simeq> \<Psi> (dom f) c ((f-\<circ>c)\<cdot>(\<Phi> a b (\<Psi> a c x))))" by (metis LM.A.Id_ex LM.BijectionTwo LM.Impl.BiF.nntExists LM.M.AxA.Ex assms n)
  hence 2: "\<not>(\<Phi> (dom f) b ((\<Psi> a c x)\<cdot>T(f,b)) \<simeq> \<Phi> (dom f) b (\<Psi> (dom f) c ((f-\<circ>c)\<cdot>(\<Phi> a b (\<Psi> a c x)))))" by (smt LM.A.Ex_two_ob2 LM.A.Id_ex LM.A.S2 LM.A.S5 LM.Aop.double_cod LM.BijectionOne LM.FunctionSet\<Psi> LM.Impl.BiF.nntExists LM.M.AxA.Ex2 LM.M.tensor_morph LM.NaturalityA assms)
  also have 3: "\<Phi> (dom f) b ((\<Psi> a c x)\<cdot>T(f,b)) \<simeq> ((f-\<circ>c)\<cdot>(\<Phi> a b (\<Psi> a c x)))" by (smt LM.A.Id_ex LM.Aop.double_cod LM.FunctionSet\<Psi> LM.Impl.BiF.nntExists LM.M.AxA.Ex2 LM.NaturalityA assms)
  show False using 2 3 LM.FunctionSet\<Psi> LM.BijectionOne by (smt LM.A.Id_ex LM.A.S3 LM.A.S5 LM.A.dom_of_comp LM.BijectionTwo LM.Impl.BiF.nntExists LM.Impl_morph LM.M.AxA.Ex2 assms)
qed

lemma NaturalityInvB:
  assumes "(x:b\<rightarrow>\<^sub>A(a-\<circ>c)) \<and> LM.A.Id a \<and> LM.A.Id c \<and> ((cod f) = b)"
  shows "(\<Psi> a c x)\<cdot>T(a,f) \<simeq> \<Psi> a c (x\<cdot>f)"
proof
  assume n: "\<^bold>\<not> (E (T (a, f) \<cdot>op \<Psi> a c x)) \<^bold>\<or>
    \<^bold>\<not> (\<^bold>\<not> (\<^bold>\<not> (E (\<Psi> a c (f \<cdot>op x))) \<^bold>\<or> T (a, f) \<cdot>op \<Psi> a c x \<noteq> \<Psi> a c (f \<cdot>op x)))"
  then have n2: "\<not>((\<Psi> a c x)\<cdot>T(a,f) \<simeq> \<Psi> a c (x\<cdot>f))" by blast
  have 1: "\<not>((\<Psi> a c x)\<cdot>T(a,f) \<simeq> \<Psi> a c ((\<Phi> a b (\<Psi> a c x))\<cdot>f))" by (metis LM.A.Id_ex LM.BijectionTwo LM.Impl.BiF.reflects_morp LM.M.AxA.Ex assms n)
  hence 2: "\<not>(\<Phi> a (dom f) ((\<Psi> a c x)\<cdot>T(a,f)) \<simeq> \<Phi> a (dom f) (\<Psi> a c ((\<Phi> a b (\<Psi> a c x))\<cdot>f)))" by (smt LM.A.FHS LM.A.Id_ex LM.A.S3 LM.A.S5 LM.A.cod_of_comp LM.A.dom_of_comp LM.BijectionOne LM.BijectionTwo LM.FunctionSet\<Psi> LM.Impl.BiF.nntExists LM.M.AxA.Ex2 LM.M.tensor_codomain LM.M.tensor_domain assms)
  also have 3: "\<Phi> a (dom f) ((\<Psi> a c x)\<cdot>T(a,f)) \<simeq> (\<Phi> a b (\<Psi> a c x))\<cdot>f" by (metis LM.A.Id_ex LM.Aop.double_cod LM.FunctionSet\<Psi> LM.Impl.BiF.nntExists LM.M.AxA.Ex2 LM.NaturalityB assms)
  thus False by (smt LM.A.Ex_two_ob2 LM.A.Id_ex LM.A.S5 LM.A.cod_of_comp LM.A.dom_of_comp LM.BijectionTwo LM.Impl.BiF.nntExists LM.M.AxA.Ex2 assms calculation)
qed

lemma NaturalityInvC:
  assumes "((x:b\<rightarrow>\<^sub>A(Impl(a,c))) \<and> LM.A.Id a \<and> LM.A.Id c) \<and> ((dom f) = c)"
  shows "(f\<cdot>(\<Psi> a c x)) \<simeq> (\<Psi> a (cod f) ((a-\<circ>f)\<cdot>x))"
proof
  assume n:  "\<^bold>\<not> (E (\<Psi> a c x \<cdot>op f)) \<^bold>\<or>
    \<^bold>\<not> (\<^bold>\<not> (\<^bold>\<not> (E (\<Psi> a (LM.Aop.domop f) (x \<cdot>op RightClosedStr.RImplication a f))) \<^bold>\<or>
             \<Psi> a c x \<cdot>op f \<noteq> \<Psi> a (LM.Aop.domop f) (x \<cdot>op RightClosedStr.RImplication a f)))"
  hence n2: "\<not>((f\<cdot>(\<Psi> a c x)) \<simeq> (\<Psi> a (cod f) (Impl(a,f)\<cdot>x)))" by blast
  hence 1: "\<not>(\<Phi> a b (f\<cdot>(\<Psi> a c x)) \<simeq> \<Phi> a b (\<Psi> a (cod f) (Impl(a,f)\<cdot>x)))" by (smt LM.A.Id_ex LM.A.S3 LM.A.S6 LM.A.cod_of_comp LM.A.dom_of_comp LM.Aop.double_cod LM.BijectionOne LM.BijectionTwo LM.FunctionSet\<Psi> LM.Impl.BiF.nntExists LM.M.AxA.Ex2 LM.NaturalityC assms)
  also have 2: "\<Phi> a b (f\<cdot>(\<Psi> a c x)) \<simeq> \<Phi> a b (\<Psi> a (cod f) (Impl(a,f)\<cdot>x))" by (smt LM.A.Ex_from_hom_set LM.A.Id_ex LM.A.S3 LM.A.cod_of_comp LM.A.dom_of_comp LM.A.from_hom_set_def LM.Aop.double_cod LM.BijectionOne LM.BijectionTwo LM.FunctionSet\<Psi> LM.Impl.BiF.nntExists LM.M.AxA.Ex2 LM.NaturalityC assms)
  thus False using calculation by blast
qed

subsection \<open>Double negation\<close>

lemma Delta1:
  assumes "f:a\<rightarrow>\<^sub>Aa'"
  shows "((f-\<circ>\<bottom>\<^sub>m)-\<circ>\<bottom>\<^sub>m)\<cdot>(\<Phi>r a (a-\<circ>\<bottom>\<^sub>m) (\<Psi> a \<bottom>\<^sub>m (a-\<circ>\<bottom>\<^sub>m)))
       = (\<Phi>r a' (a'-\<circ>\<bottom>\<^sub>m) (\<Psi> a' \<bottom>\<^sub>m (a'-\<circ>\<bottom>\<^sub>m)))\<cdot>f"
proof-
  have 1: "LM.A.from_hom_seta ((\<Phi>r a' (a'-\<circ>\<bottom>\<^sub>m) (\<Psi> a' \<bottom>\<^sub>m (a'-\<circ>\<bottom>\<^sub>m)))\<cdot>f) a ((a'-\<circ>\<bottom>\<^sub>m)-\<circ>\<bottom>\<^sub>m)"
    by (smt FM LM.A.Id_ex2 LM.A.cod_of_comp LM.A.dom_of_comp LM.Aop.Id20 LM.Aop.cod_dom LM.FunctionSet\<Phi> LM.FunctionSet\<Psi> LM.Impl.BiF.ntExists LM.Impl_dom LM.M.AxA.Ex2 RCS_B RightClosedStr.FunctionSet\<Psi> assms fst_conv snd_conv)
  have 2: "((((f-\<circ>\<bottom>\<^sub>m)-\<circ>\<bottom>\<^sub>m)\<cdot>(\<Phi>r a (a-\<circ>\<bottom>\<^sub>m) (\<Psi> a \<bottom>\<^sub>m (a-\<circ>\<bottom>\<^sub>m)))):a\<rightarrow>\<^sub>A((a'-\<circ>\<bottom>\<^sub>m)-\<circ>\<bottom>\<^sub>m))"
    by (smt "1" FM LM.A.Ex_two_ob1 LM.A.Id2 LM.A.S1 LM.A.S2 LM.A.S5 LM.A.S6 LM.Aop.dom_cod LM.Aop.double_cod LM.FunctionSet\<Psi> LM.Impl.BiF.ntExists LM.Impl_dom LM.Impl_morph LM.M.AxA.Ex2 RightClosedStr.FunctionSet\<Phi> Sym.Braid.Br.\<eta>.ntExists Sym.Braid.Br.\<eta>.presCod assms fst_conv snd_conv)
  have 3: "\<Psi> a \<bottom>\<^sub>m (f-\<circ>\<bottom>\<^sub>m) \<simeq> (\<Psi> a' \<bottom>\<^sub>m (a'-\<circ>\<bottom>\<^sub>m))\<cdot>(f\<otimes>(a'-\<circ>\<bottom>\<^sub>m))"
    using NaturalityInvA[where ?x = \<open>(a'-\<circ>\<bottom>\<^sub>m)\<close> and ?b = \<open>(a'-\<circ>\<bottom>\<^sub>m)\<close> and ?a = \<open>a'\<close> and ?c = \<open>\<bottom>\<^sub>m\<close> and ?f = \<open>f\<close>]
    by (smt FM LM.A.Id_def LM.A.S3 LM.Aop.S2 LM.Aop.S5 LM.Aop.S6 LM.Impl.BiF.ntExists LM.LeftClosedMonCatBifunctor_axioms LM.M.AxA.Ex2 LeftClosedMonCatBifunctor.Impl_dom assms)
  have 4: "(\<Psi> a \<bottom>\<^sub>m (a-\<circ>\<bottom>\<^sub>m))\<cdot>(a\<otimes>(f-\<circ>\<bottom>\<^sub>m)) \<simeq> \<Psi> a \<bottom>\<^sub>m (f-\<circ>\<bottom>\<^sub>m)"
    using NaturalityInvB[where ?x = \<open>(a-\<circ>\<bottom>\<^sub>m)\<close> and ?b = \<open>(a-\<circ>\<bottom>\<^sub>m)\<close> and ?c = \<open>\<bottom>\<^sub>m\<close> and ?a = \<open>a\<close> and ?f = \<open>(a'-\<circ>\<bottom>\<^sub>m)\<close>]
    by (smt "2" FM LM.A.Id2 LM.A.S2 LM.A.cod_of_comp LM.Aop.S5 LM.Aop.S6 LM.Aop.dom_cod LM.Impl.BiF.nntExists LM.Impl_dom LM.Impl_morph LM.M.AxA.Ex2 NaturalityInvB assms)
  have 5: "LM.A.from_hom_seta (\<Psi> a' \<bottom>\<^sub>m (a'-\<circ>\<bottom>\<^sub>m)) (T(a',(a'-\<circ>\<bottom>\<^sub>m))) \<bottom>\<^sub>m"
    by (smt FM LM.Aop.Id20 LM.Aop.cod_dom LM.FunctionSet\<Psi> LM.Impl.BiF.ntExists LM.Impl_dom LM.M.AxA.Ex2 assms)
  have 6: "LM.A.from_hom_seta (\<Psi> a \<bottom>\<^sub>m ((a-\<circ>\<bottom>\<^sub>m))) (T(a,(a-\<circ>\<bottom>\<^sub>m))) \<bottom>\<^sub>m"
    by (smt "1" FM LM.Aop.Id20 LM.Aop.double_cod LM.FunctionSet\<Psi> LM.Impl.BiF.ntExists LM.Impl_dom LM.M.AxA.Ex2)
  obtain a1 where pa1: "a1 = (\<Psi> a' \<bottom>\<^sub>m ((a'-\<circ>\<bottom>\<^sub>m)))" by blast
  obtain a2 where pa2: "a2 = (\<Psi> a \<bottom>\<^sub>m ((a-\<circ>\<bottom>\<^sub>m)))" by blast
  have 7: "(\<Phi>r a' ((a'-\<circ>\<bottom>\<^sub>m)) a1)\<cdot>f \<simeq> \<Phi>r a ((a'-\<circ>\<bottom>\<^sub>m)) (a1\<cdot>T(f,(a'-\<circ>\<bottom>\<^sub>m)))"
    by (smt "5" LM.Aop.cod_dom LM.Aop.double_dom LM.Impl.BiF.ntExists LM.Impl_dom LM.M.AxA.Ex2 RCS_B assms pa1)
  have 8: "(((f-\<circ>\<bottom>\<^sub>m)-\<circ>\<bottom>\<^sub>m))\<cdot>(\<Phi>r a ((a-\<circ>\<bottom>\<^sub>m)) a2) \<simeq> \<Phi>r a ((a'-\<circ>\<bottom>\<^sub>m)) (a2\<cdot>T(a,(f-\<circ>\<bottom>\<^sub>m)))"
    by (smt "6" FM LM.A.S1 LM.Aop.dom_cod LM.Aop.double_cod LM.Impl.BiF.ntExists LM.Impl.BiF.pres2 LM.Impl_dom LM.M.AxA.Ex2 RCS_A assms fst_conv pa2 snd_conv)
  have 9: "(\<Phi>r a' ((a'-\<circ>\<bottom>\<^sub>m)) (\<Psi> a' \<bottom>\<^sub>m ((a'-\<circ>\<bottom>\<^sub>m))))\<cdot>f \<simeq>
           (\<Phi>r a ((a'-\<circ>\<bottom>\<^sub>m)) (\<Psi> a \<bottom>\<^sub>m ((f-\<circ>\<bottom>\<^sub>m))))" by (metis "3" "7" pa1)
  have 10: "(((f-\<circ>\<bottom>\<^sub>m)-\<circ>\<bottom>\<^sub>m))\<cdot>(\<Phi>r a ((a-\<circ>\<bottom>\<^sub>m)) (\<Psi> a \<bottom>\<^sub>m ((a-\<circ>\<bottom>\<^sub>m)))) \<simeq>
           (\<Phi>r a ((a'-\<circ>\<bottom>\<^sub>m)) (\<Psi> a \<bottom>\<^sub>m ((f-\<circ>\<bottom>\<^sub>m))))" by (metis "4" "8" pa2)
  show ?thesis using "10" "9" by presburger
qed

abbreviation \<delta> :: "'a \<Rightarrow> 'a"
  where "\<delta> a \<equiv>  \<Phi>r a (a-\<circ>\<bottom>\<^sub>m) (\<Psi> a \<bottom>\<^sub>m (a-\<circ>\<bottom>\<^sub>m))"

lemma Delta20:
  assumes "LM.A.from_hom_seta f a a'"
  shows "LM.A.commSquareEx (((f-\<circ>\<bottom>\<^sub>m)-\<circ>\<bottom>\<^sub>m)) (\<delta> a) f (\<delta> a')"
proof-
  have 1: "LM.A.IdEx a" by (metis LM.Aop.double_cod assms)
  have 2: "LM.A.IdEx a'" by (metis LM.Aop.cod_dom assms)
  then have 3: "\<delta> a' = \<Phi>r a' ((a'-\<circ>\<bottom>\<^sub>m)) (\<Psi> a' \<bottom>\<^sub>m ((a'-\<circ>\<bottom>\<^sub>m)))" by presburger
  also have 4: "\<delta> a = \<Phi>r a ((a-\<circ>\<bottom>\<^sub>m)) (\<Psi> a \<bottom>\<^sub>m ((a-\<circ>\<bottom>\<^sub>m)))" using 1 by presburger
  then have 5: "E((((f-\<circ>\<bottom>\<^sub>m)-\<circ>\<bottom>\<^sub>m))\<cdot>(\<delta> a))"
    by (smt "1" FM LM.A.Id_ex2 LM.A.S1 LM.A.S3 LM.Aop.Id20 LM.FunctionSet\<Phi> LM.Impl.BiF.ntExists LM.Impl.BiF.pres2 LM.Impl_dom LM.M.AxA.Ex2 RightClosedStr.FunctionSet\<Psi> assms fst_conv snd_conv)
  have 6: "E((\<delta> a')\<cdot>f)" using 3 1 by (smt "5" Delta1 assms)
  show ?thesis using Delta1 1 2 3 4 5 6 by (smt assms)
qed

lemma Delta3:
  assumes "LM.A.IdEx a"
  shows "(\<delta> a):a\<rightarrow>\<^sub>A((a-\<circ>\<bottom>\<^sub>m)-\<circ>\<bottom>\<^sub>m)"
  by (smt FM LM.A.Id_ex2 LM.Aop.Id20 LM.FunctionSet\<Phi> LM.Impl.BiF.ntExists LM.Impl_dom LM.M.AxA.Ex2 RightClosedStr.FunctionSet\<Psi> assms fst_conv snd_conv)

interpretation DeltaNatId: naturalTransformationViaIdentities domain codomain composition nonex
                         domain codomain composition nonex LM.A.map "\<lambda>f. ((f-\<circ>\<bottom>\<^sub>m)-\<circ>\<bottom>\<^sub>m)" \<delta>
  apply unfold_locales
  using FM LM.Impl.BiF.ntExists LM.M.AxA.Ex2 apply blast
  using LM.Impl.BiF.nntExists LM.M.AxA.Ex2 apply blast
  apply (smt Delta20 Delta3 LM.A.ExDomCod(1) LM.A.S3 LM.Aop.S6 LM.Aop.double_cod LM.Impl.BiF.nntExists LM.M.AxA.Ex2)
  apply (metis FM LM.Aop.ExDomCod(2) LM.Aop.dom_cod LM.Impl.BiF.nntExists LM.Impl.BiF.ntExists LM.Impl.BiF.pres2 LM.Impl_dom LM.M.AxA.Ex2 fst_conv snd_conv)
  apply (metis FM LM.Aop.S6 LM.Impl.BiF.nntExists LM.Impl.BiF.preserves_comp LM.M.AxA.Ex2 fst_conv snd_conv)
  using Delta3 LM.A.from_hom_set_def LM.Aop.map_def apply presburger
  by (metis Delta20 LM.A.ExDomCod(1) LM.A.Ex_two_ob1 LM.A.Ex_two_ob2 LM.Aop.S6 LM.Aop.map_def LM.Impl.BiF.nntExists LM.M.AxA.Ex2)

interpretation DeltaNat: naturalTransformation domain codomain composition nonex
                         domain codomain composition nonex LM.A.map "\<lambda>f. Impl(Impl(f,\<bottom>\<^sub>m),\<bottom>\<^sub>m)" DeltaNatId.map
  using DeltaNatId.naturalTransformation_axioms by blast

theorem DeltaNatTh:
  shows "naturalTransformation domain codomain composition nonex
                         domain codomain composition nonex LM.A.map (\<lambda>f. Impl(Impl(f,\<bottom>\<^sub>m),\<bottom>\<^sub>m)) DeltaNatId.map"
  using DeltaNatId.naturalTransformation_axioms by blast

subsection \<open>Universal property of closed structure\<close>

abbreviation Ev :: "'a * 'a => 'a"
where "Ev AB \<equiv> \<Psi> (fst AB) (snd AB) (fst AB -\<circ> snd AB)"

lemma LCS1:
  assumes "((LM.A.IdEx x) \<and> (LM.A.IdEx y))"
  shows "((Ev(x,y)):(x\<otimes>(x-\<circ>y))\<rightarrow>\<^sub>Ay)"
  by (smt LM.Aop.Id20 LM.FunctionSet\<Psi> LM.Impl.BiF.ntExists LM.Impl_dom LM.M.AxA.Ex2 assms fst_conv snd_conv)

lemma LCS2:
  assumes "((x:(a\<otimes>b)\<rightarrow>\<^sub>Ac) \<and> (LM.A.Id a) \<and> (LM.A.Id b))"
  shows "(\<exists>!h. ((h:b\<rightarrow>\<^sub>A(a-\<circ>c)) \<and> (x \<simeq> Ev(a,c)\<cdot>(a\<otimes>h))))"
proof
  let ?a = "\<Phi> a b x "
  have 1: "(?a:b\<rightarrow>\<^sub>A(a-\<circ>c))" by (metis LM.A.Id_ex LM.FunctionSet\<Phi> LM.M.AxA.Ex2 LM.M.T.BiF.reflects_morp assms)
  have 01: "((LM.A.from_hom_seta (Impl(a,c)) (Impl(a,c)) (Impl(a,c))) \<and> LM.A.Id a \<and> LM.A.Id c) \<and> ((cod ?a) = (Impl(a,c)))" by (metis "1" LM.A.Id2 LM.Aop.Id40 LM.Aop.double_dom assms)
  have 2: "x \<simeq> Ev(a,c)\<cdot>(T(a,?a))" using NaturalityInvB by (metis "01" "1" LM.A.Id_ex LM.A.S1 LM.A.S6 LM.BijectionOne LM.M.AxA.Ex2 LM.M.T.BiF.reflects_morp assms fst_conv snd_conv)
  then show "((LM.A.from_hom_seta ?a b (Impl(a,c))) \<and> (x \<simeq> Ev(a,c)\<cdot>(T(a,?a))))" using 1 by blast
  fix h
  assume "((LM.A.from_hom_seta h b (Impl(a,c))) \<and> (x \<simeq> Ev(a,c)\<cdot>(T(a,h))))"
  then have 3: "h \<^bold>= \<Phi> a b x" using NaturalityInvB by (metis "01" LM.A.Id_ex LM.A.S6 LM.BijectionTwo LM.M.AxA.Ex2 LM.M.T.BiF.reflects_morp assms fst_conv snd_conv)
  then show "h \<^bold>= \<Phi> a b x" by blast
qed

lemma LCS31:
  assumes "((LM.A.IdEx a) \<and> (E g))"
  shows "((a-\<circ>g):(a -\<circ> dom g)\<rightarrow>\<^sub>A(a-\<circ> cod g)) \<and> (g\<cdot>Ev(a,dom g)) \<simeq> (Ev(a,cod g)\<cdot>T(a,Impl(a,g)))"
proof-
  have 1: "(LM.A.from_hom_seta (Impl(a,g)) (Impl(a,dom g)) (Impl(a,cod g)))" by (metis (no_types, hide_lams) LM.A.Ex_from_hom_set LM.A.from_hom_set_def LM.Aop.dom_cod LM.Impl.BiF.ntExists LM.Impl.BiF.pres1 LM.Impl.BiF.pres2 LM.M.T.BiF.reflects_morp LM.M.tensor_codomain assms fst_conv snd_conv)
  have 2: "(g\<cdot>Ev(a,dom g)) \<simeq> (Ev(a,cod g)\<cdot>T(a,Impl(a,g)))" by (smt "1" LM.A.Id_ex2 LM.A.S3 LM.A.S6 LM.Aop.S6 LM.Aop.cod_dom NaturalityInvB NaturalityInvC assms fst_conv snd_conv)
  thus ?thesis using 1 by blast
qed

lemma LCS3:
  shows "((LM.A.IdEx a) \<and> (E g)) \<longrightarrow> (((a-\<circ>g):(a -\<circ> dom g)\<rightarrow>\<^sub>A(a -\<circ> cod g)) \<and> (g\<cdot>Ev(a,dom g)) \<simeq> (Ev(a,cod g)\<cdot>(a\<otimes>(a-\<circ>g))))"
  using LCS31[where ?a = \<open>a\<close> and ?g = \<open>g\<close>] Free_Impl[where ?A = \<open>((LM.A.IdEx a) \<and> (E g))\<close> and ?B = \<open>((LM.A.from_hom_set (Impl(a,g)) (Impl(a,dom g)) (Impl(a,cod g))) \<and> (g\<cdot>Ev(a,dom g)) \<simeq> (Ev(a,cod g)\<cdot>T(a,Impl(a,g))))\<close>]
  using LM.A.from_hom_set_def by blast

section \<open>Intuitionistic Linear Logic Rules\<close>

lemma RuleIdEx:
  assumes "LM.A.IdEx a"
  shows "a:a\<rightarrow>\<^sub>Aa"
  using LM.A.Id30 assms by blast

lemma RuleExchange:
  assumes "f:(((\<Gamma>\<otimes>(A\<otimes>B))\<otimes>\<Delta>))\<rightarrow>\<^sub>AC" and "LM.A.Id A" and "LM.A.Id B" and "LM.A.Id \<Gamma>" and "LM.A.Id \<Delta>"
  shows "(f\<cdot>(((\<Gamma>\<otimes>\<gamma>(B,A))\<otimes>\<Delta>))):(((\<Gamma>\<otimes>(B\<otimes>A))\<otimes>\<Delta>))\<rightarrow>\<^sub>AC"
proof-
  have 1: "LM.A.from_hom_seta (\<gamma>(B,A)) (T(B,A)) (T(A,B))" by (smt LM.A.Id_def LM.A.Id_hom LM.M.AxA.Ex2 LM.M.T.BiF.reflects_morp LM.M.tensor_codomain LM.M.tensor_ide Sym.Braid.Br.\<eta>.presCod Sym.Braid.Br.\<eta>.presDom assms(1) assms(2) assms(3) fst_conv snd_conv)
  then have 2: "LM.A.from_hom_seta (T(\<Gamma>,\<gamma>(B,A))) (T(\<Gamma>,T(B,A))) (T(\<Gamma>,T(A,B)))" by (smt LM.A.FHS LM.A.Id_def LM.A.Id_hom LM.Aop.ExDomCod(1) LM.M.AxA.Ex2 LM.M.T.BiF.pres1 LM.M.T.BiF.reflects_morp LM.M.tensor_codomain assms(1) assms(4) fst_conv snd_conv)
  then have 3: "LM.A.from_hom_seta (T(T(\<Gamma>,\<gamma>(B,A)),\<Delta>)) (T(T(\<Gamma>,T(B,A)),\<Delta>)) (T(T(\<Gamma>,T(A,B)),\<Delta>))" by (smt LM.A.FHS LM.A.Id_def LM.A.Id_hom LM.Aop.ExDomCod(1) LM.M.AxA.Ex2 LM.M.T.BiF.pres1 LM.M.T.BiF.reflects_morp LM.M.tensor_codomain assms(1) assms(5) fst_conv snd_conv)
  thus "LM.A.from_hom_seta (f\<cdot>(T(T(\<Gamma>,\<gamma>(B,A)),\<Delta>))) (T(T(\<Gamma>,T(B,A)),\<Delta>)) C" by (metis "2" LM.A.Id_def LM.M.AxA.Ex2 LM.M.T.BiF.reflects_morp LM.M.tensor_morph assms(1) assms(5))
qed

lemma RuleCut:
  assumes "f:\<Gamma>\<rightarrow>\<^sub>AA" and "g:(A\<otimes>\<Delta>)\<rightarrow>\<^sub>AB" and "LM.A.Id \<Delta>"
  shows "LM.A.from_hom_seta (g\<cdot>T(f,\<Delta>)) (T(\<Gamma>,\<Delta>)) B"
  using LM.A.Id_ex LM.M.AxA.Ex2 LM.M.T.BiF.reflects_morp LM.M.tensor_morph assms(1) assms(2) assms(3) by blast

lemma RuleTensorR:
  assumes "f:\<Gamma>\<rightarrow>\<^sub>AA" and "g:\<Delta>\<rightarrow>\<^sub>AB"
  shows "(f\<otimes>g):(\<Gamma>\<otimes>\<Delta>)\<rightarrow>\<^sub>A(A\<otimes>B)"
  by (metis LM.A.FHS LM.M.tensor_codomain LM.M.tensor_domain assms(1) assms(2))

lemma RuleTensorL:
  assumes "f:(((\<Gamma>\<otimes>A)\<otimes>B))\<rightarrow>\<^sub>AC" and "LM.A.Id A" and "LM.A.Id B" and "LM.A.Id \<Gamma>"
  shows "(f\<cdot>(\<alpha>\<^sup>-\<^sup>1(\<Gamma>,A,B))):((\<Gamma>\<otimes>(A\<otimes>B)))\<rightarrow>\<^sub>AC"
  by (metis (no_types, lifting) LM.A.Id3 LM.A.Id_def LM.A.S3 LM.A.cod_of_comp LM.A.dom_of_comp LM.M.AxA.Ex2 LM.M.T.BiF.reflects_morp LM.M.T.TAT_simp LM.M.T.TTA_simp RuleTensorR Sym.Braid.\<alpha>_inv.presCod Sym.Braid.\<alpha>_inv.presDom assms(1) assms(2) assms(3) assms(4))

lemma RuleImplicationR:
  assumes "f:(\<Gamma>\<otimes>A)\<rightarrow>\<^sub>AB" and "LM.A.Id A" and "LM.A.Id \<Gamma>"
  shows "(\<Phi>r \<Gamma> A f):\<Gamma>\<rightarrow>\<^sub>A(A-\<circ>B)"
  using RightClosedStr.FunctionSet\<Phi> assms(1) assms(2) assms(3) by blast

lemma RuleImplicationL:
  assumes "f:\<Gamma>\<rightarrow>\<^sub>AA" and "g:B\<otimes>\<Delta>\<rightarrow>\<^sub>AC" and "LM.A.Id B" and "LM.A.Id \<Delta>"
  shows "((g\<cdot>(Ev(A,B)\<otimes>\<Delta>))\<cdot>((f\<otimes>(A-\<circ>B))\<otimes>\<Delta>)):((\<Gamma>\<otimes>(A-\<circ>B))\<otimes>\<Delta>)\<rightarrow>\<^sub>AC"
  by (smt LCS1 LCS31 LM.A.Id3 LM.Aop.cod_dom LM.M.AxA.Ex2 LM.M.T.BiF.reflects_morp RuleCut RuleTensorR assms(1) assms(2) assms(3) assms(4))

lemma RuleUnitR:
  shows "LM.A.IdEx \<e>"
  using LM.M.unit_object by blast

lemma RuleUnitL:
  assumes "f:(\<Gamma>\<otimes>\<Delta>)\<rightarrow>\<^sub>AA" and "LM.A.Id \<Gamma>" and "LM.A.Id \<Delta>"
  shows "(f\<cdot>(\<Gamma>\<otimes>(\<mu> \<Delta>))):(\<Gamma>\<otimes>(\<e>\<otimes>\<Delta>))\<rightarrow>\<^sub>AA"
proof-
  have 1: "(\<mu> \<Delta>):(\<e>\<otimes>\<Delta>)\<rightarrow>\<^sub>A\<Delta>" by (metis LCS2 LM.A.Id3 LM.A.Id_def LM.A.S3 LM.Ae1 LM.Ae8 LM.M.\<mu>.\<eta>.presDom RuleTensorR RuleUnitR assms(1) assms(2) assms(3))
  have 2: "(\<Gamma>\<otimes>(\<mu> \<Delta>)):(\<Gamma>\<otimes>(\<e>\<otimes>\<Delta>))\<rightarrow>\<^sub>A(\<Gamma>\<otimes>\<Delta>)" by (metis "1" LM.A.Id3 LM.A.Id_ex LM.M.AxA.Ex2 LM.M.T.BiF.reflects_morp RuleTensorR assms(1) assms(2))
  then have 3: "(f\<cdot>(\<Gamma>\<otimes>(\<mu> \<Delta>))):(\<Gamma>\<otimes>(\<e>\<otimes>\<Delta>))\<rightarrow>\<^sub>AA" using LM.A.S3 LM.A.cod_of_comp LM.A.dom_of_comp assms(1) by presburger
  thus ?thesis by blast
qed

lemmas ILL = RuleIdEx RuleExchange RuleCut RuleTensorR RuleTensorL RuleImplicationR RuleImplicationL

end

sublocale SymmetricMonClosedCat \<subseteq> RightClosedMonCatBifunctor domain codomain composition * T \<alpha> \<mu> \<rho> \<e> Impr \<Phi>r \<Psi>r
  using RightMonoidalStructure by linarith

sublocale SymmetricMonClosedCat \<subseteq> LeftClosedMonCatBifunctor domain codomain composition * T \<alpha> \<mu> \<rho> \<e> Impl \<Phi> \<Psi>
  by (simp add: LM.LeftClosedMonCatBifunctor_axioms)

end


(*  Title:      HOL/MicroJava/DFA/LBVComplete.thy
    Author:     Gerwin Klein
    Copyright   2000 Technische Universitaet Muenchen
*)

section \<open>Completeness of the LBV\<close>

theory LBVComplete
imports LBVSpec Typing_Framework
begin

definition is_target :: "['s step_type, 's list, nat] \<Rightarrow> bool" where
  "is_target step phi pc' \<longleftrightarrow>
     (\<exists>pc s'. pc' \<noteq> pc+1 \<and> pc < length phi \<and> (pc',s') \<in> set (step pc (phi!pc)))"

definition make_cert :: "['s step_type, 's list, 's] \<Rightarrow> 's certificate" where
  "make_cert step phi B =
     map (\<lambda>pc. if is_target step phi pc then phi!pc else B) [0..<length phi] @ [B]"

locale lbvc = lbv +
  fixes phi :: "'a list" ("\<phi>")
  fixes c   :: "'a list"
  defines cert_def: "c \<equiv> make_cert step \<phi> \<bottom>"

  assumes mono: "mono r step (length \<phi>) A"
  assumes pres: "pres_type step (length \<phi>) A"
  assumes phi:  "\<forall>pc < length \<phi>. \<phi>!pc \<in> A \<and> \<phi>!pc \<noteq> \<top>"
  assumes bounded: "bounded step (length \<phi>)"

  assumes B_neq_T: "\<bottom> \<noteq> \<top>"

lemma (in lbvc) cert: "cert_ok c (length \<phi>) \<top> \<bottom> A"
proof (unfold cert_ok_def, intro strip conjI)
  note [simp] = make_cert_def cert_def nth_append

  show "c!length \<phi> = \<bottom>" by simp

  fix pc assume pc: "pc < length \<phi>"
  from pc phi B_A show "c!pc \<in> A" by simp
  from pc phi B_neq_T show "c!pc \<noteq> \<top>" by simp
qed

lemmas [simp del] = split_paired_Ex

lemma (in lbvc) cert_target [intro?]:
  "\<lbrakk> (pc',s') \<in> set (step pc (\<phi>!pc));
      pc' \<noteq> pc+1; pc < length \<phi>; pc' < length \<phi> \<rbrakk>
  \<Longrightarrow> c!pc' = \<phi>!pc'"
  by (auto simp add: cert_def make_cert_def nth_append is_target_def)

lemma (in lbvc) cert_approx [intro?]:
  "\<lbrakk> pc < length \<phi>; c!pc \<noteq> \<bottom> \<rbrakk>
  \<Longrightarrow> c!pc = \<phi>!pc"
  by (auto simp add: cert_def make_cert_def nth_append)

lemma (in lbv) le_top [simp, intro]:
  "x <=_r \<top>"
  using top by simp

lemma (in lbv) merge_mono:
  assumes less:  "ss2 \<le>|r| ss1"
  assumes x:     "x \<in> A"
  assumes ss1:   "snd`set ss1 \<subseteq> A"
  assumes ss2:   "snd`set ss2 \<subseteq> A"
  shows "merge c pc ss2 x <=_r merge c pc ss1 x" (is "?s2 <=_r ?s1")
proof-
  have "?s1 = \<top> \<Longrightarrow> ?thesis" by simp
  moreover {
    assume merge: "?s1 \<noteq> T"
    from x ss1 have "?s1 =
      (if \<forall>(pc', s')\<in>set ss1. pc' \<noteq> pc + 1 \<longrightarrow> s' <=_r c!pc'
      then (map snd [(p', t') \<leftarrow> ss1 . p'=pc+1]) ++_f x
      else \<top>)"
      by (rule merge_def)
    with merge obtain
      app: "\<forall>(pc',s')\<in>set ss1. pc' \<noteq> pc+1 \<longrightarrow> s' <=_r c!pc'"
           (is "?app ss1") and
      sum: "(map snd [(p',t') \<leftarrow> ss1 . p' = pc+1] ++_f x) = ?s1"
           (is "?map ss1 ++_f x = _" is "?sum ss1 = _")
      by (simp split: if_split_asm)
    from app less
    have "?app ss2" by (blast dest: trans_r lesub_step_typeD)
    moreover {
      from ss1 have map1: "set (?map ss1) \<subseteq> A" by auto
      with x have "?sum ss1 \<in> A" by (auto intro!: plusplus_closed semilat)
      with sum have "?s1 \<in> A" by simp
      moreover
      have mapD: "\<And>x ss. x \<in> set (?map ss) \<Longrightarrow> \<exists>p. (p,x) \<in> set ss \<and> p=pc+1" by auto
      from x map1
      have "\<forall>x \<in> set (?map ss1). x <=_r ?sum ss1"
        by clarify (rule pp_ub1)
      with sum have "\<forall>x \<in> set (?map ss1). x <=_r ?s1" by simp
      with less have "\<forall>x \<in> set (?map ss2). x <=_r ?s1"
        by (fastforce dest!: mapD lesub_step_typeD intro: trans_r)
      moreover
      from map1 x have "x <=_r (?sum ss1)" by (rule pp_ub2)
      with sum have "x <=_r ?s1" by simp
      moreover
      from ss2 have "set (?map ss2) \<subseteq> A" by auto
      ultimately
      have "?sum ss2 <=_r ?s1" using x by - (rule pp_lub)
    }
    moreover
    from x ss2 have
      "?s2 =
      (if \<forall>(pc', s')\<in>set ss2. pc' \<noteq> pc + 1 \<longrightarrow> s' <=_r c!pc'
      then map snd [(p', t') \<leftarrow> ss2 . p' = pc + 1] ++_f x
      else \<top>)"
      by (rule merge_def)
    ultimately have ?thesis by simp
  }
  ultimately show ?thesis by (cases "?s1 = \<top>") auto
qed

lemma (in lbvc) wti_mono:
  assumes less: "s2 <=_r s1"
  assumes pc:   "pc < length \<phi>"
  assumes s1:   "s1 \<in> A"
  assumes s2:   "s2 \<in> A"
  shows "wti c pc s2 <=_r wti c pc s1" (is "?s2' <=_r ?s1'")
proof -
  from mono pc s2 less have "step pc s2 \<le>|r| step pc s1" by (rule monoD)
  moreover
  from cert B_A pc have "c!Suc pc \<in> A" by (rule cert_okD3)
  moreover
  from pres s1 pc
  have "snd`set (step pc s1) \<subseteq> A" by (rule pres_typeD2)
  moreover
  from pres s2 pc
  have "snd`set (step pc s2) \<subseteq> A" by (rule pres_typeD2)
  ultimately
  show ?thesis by (simp add: wti merge_mono)
qed

lemma (in lbvc) wtc_mono:
  assumes less: "s2 <=_r s1"
  assumes pc:   "pc < length \<phi>"
  assumes s1:   "s1 \<in> A"
  assumes s2:   "s2 \<in> A"
  shows "wtc c pc s2 <=_r wtc c pc s1" (is "?s2' <=_r ?s1'")
proof (cases "c!pc = \<bottom>")
  case True
  moreover from less pc s1 s2 have "wti c pc s2 <=_r wti c pc s1" by (rule wti_mono)
  ultimately show ?thesis by (simp add: wtc)
next
  case False
  have "?s1' = \<top> \<Longrightarrow> ?thesis" by simp
  moreover {
    assume "?s1' \<noteq> \<top>"
    with False have c: "s1 <=_r c!pc" by (simp add: wtc split: if_split_asm)
    with less have "s2 <=_r c!pc" ..
    with False c have ?thesis by (simp add: wtc)
  }
  ultimately show ?thesis by (cases "?s1' = \<top>") auto
qed

lemma (in lbv) top_le_conv [simp]:
  "\<top> <=_r x = (x = \<top>)"
  using semilat by (simp add: top)

lemma (in lbv) neq_top [simp, elim]:
  "\<lbrakk> x <=_r y; y \<noteq> \<top> \<rbrakk> \<Longrightarrow> x \<noteq> \<top>"
  by (cases "x = T") auto

lemma (in lbvc) stable_wti:
  assumes stable:  "stable r step \<phi> pc"
  assumes pc:      "pc < length \<phi>"
  shows "wti c pc (\<phi>!pc) \<noteq> \<top>"
proof -
  let ?step = "step pc (\<phi>!pc)"
  from stable
  have less: "\<forall>(q,s')\<in>set ?step. s' <=_r \<phi>!q" by (simp add: stable_def)

  from cert B_A pc
  have cert_suc: "c!Suc pc \<in> A" by (rule cert_okD3)
  moreover
  from phi pc have "\<phi>!pc \<in> A" by simp
  from pres this pc
  have stepA: "snd`set ?step \<subseteq> A" by (rule pres_typeD2)
  ultimately
  have "merge c pc ?step (c!Suc pc) =
    (if \<forall>(pc',s')\<in>set ?step. pc'\<noteq>pc+1 \<longrightarrow> s' <=_r c!pc'
    then map snd [(p',t') \<leftarrow> ?step.p'=pc+1] ++_f c!Suc pc
    else \<top>)" unfolding mrg_def by (rule lbv.merge_def [OF lbvc.axioms(1), OF lbvc_axioms])
  moreover {
    fix pc' s' assume s': "(pc', s') \<in> set ?step" and suc_pc: "pc' \<noteq> pc+1"
    with less have "s' <=_r \<phi>!pc'" by auto
    also
    from bounded pc s' have "pc' < length \<phi>" by (rule boundedD)
    with s' suc_pc pc have "c!pc' = \<phi>!pc'" ..
    hence "\<phi>!pc' = c!pc'" ..
    finally have "s' <=_r c!pc'" .
  } hence "\<forall>(pc',s')\<in>set ?step. pc'\<noteq>pc+1 \<longrightarrow> s' <=_r c!pc'" by auto
  moreover
  from pc have "Suc pc = length \<phi> \<or> Suc pc < length \<phi>" by auto
  hence "map snd [(p',t') \<leftarrow> ?step.p'=pc+1] ++_f c!Suc pc \<noteq> \<top>"
         (is "?map ++_f _ \<noteq> _")
  proof (rule disjE)
    assume pc': "Suc pc = length \<phi>"
    with cert have "c!Suc pc = \<bottom>" by (simp add: cert_okD2)
    moreover
    from pc' bounded pc
    have "\<forall>(p',t')\<in>set ?step. p'\<noteq>pc+1" by clarify (drule boundedD, auto)
    hence "[(p',t') \<leftarrow> ?step.p'=pc+1] = []" by (blast intro: filter_False)
    hence "?map = []" by simp
    ultimately show ?thesis by (simp add: B_neq_T)
  next
    assume pc': "Suc pc < length \<phi>"
    from pc' phi have "\<phi>!Suc pc \<in> A" by simp
    moreover note cert_suc
    moreover from stepA
    have "set ?map \<subseteq> A" by auto
    moreover
    have "\<And>s. s \<in> set ?map \<Longrightarrow> \<exists>t. (Suc pc, t) \<in> set ?step" by auto
    with less have "\<forall>s' \<in> set ?map. s' <=_r \<phi>!Suc pc" by auto
    moreover
    from pc' have "c!Suc pc <=_r \<phi>!Suc pc"
      by (cases "c!Suc pc = \<bottom>") (auto dest: cert_approx)
    ultimately
    have "?map ++_f c!Suc pc <=_r \<phi>!Suc pc" by (rule pp_lub)
    moreover
    from pc' phi have "\<phi>!Suc pc \<noteq> \<top>" by simp
    ultimately
    show ?thesis by auto
  qed
  ultimately
  have "merge c pc ?step (c!Suc pc) \<noteq> \<top>" by simp
  thus ?thesis by (simp add: wti)
qed

lemma (in lbvc) wti_less:
  assumes stable:  "stable r step \<phi> pc"
  assumes suc_pc:   "Suc pc < length \<phi>"
  shows "wti c pc (\<phi>!pc) <=_r \<phi>!Suc pc" (is "?wti <=_r _")
proof -
  let ?step = "step pc (\<phi>!pc)"

  from stable
  have less: "\<forall>(q,s')\<in>set ?step. s' <=_r \<phi>!q" by (simp add: stable_def)

  from suc_pc have pc: "pc < length \<phi>" by simp
  with cert B_A have cert_suc: "c!Suc pc \<in> A" by (rule cert_okD3)
  moreover
  from phi pc have "\<phi>!pc \<in> A" by simp
  with pres pc have stepA: "snd`set ?step \<subseteq> A" by - (rule pres_typeD2)
  moreover
  from stable pc have "?wti \<noteq> \<top>" by (rule stable_wti)
  hence "merge c pc ?step (c!Suc pc) \<noteq> \<top>" by (simp add: wti)
  ultimately
  have "merge c pc ?step (c!Suc pc) =
    map snd [(p',t')\<leftarrow> ?step.p'=pc+1] ++_f c!Suc pc" by (rule merge_not_top_s)
  hence "?wti = \<dots>" (is "_ = (?map ++_f _)" is "_ = ?sum") by (simp add: wti)
  also {
    from suc_pc phi have "\<phi>!Suc pc \<in> A" by simp
    moreover note cert_suc
    moreover from stepA have "set ?map \<subseteq> A" by auto
    moreover
    have "\<And>s. s \<in> set ?map \<Longrightarrow> \<exists>t. (Suc pc, t) \<in> set ?step" by auto
    with less have "\<forall>s' \<in> set ?map. s' <=_r \<phi>!Suc pc" by auto
    moreover
    from suc_pc have "c!Suc pc <=_r \<phi>!Suc pc"
      by (cases "c!Suc pc = \<bottom>") (auto dest: cert_approx)
    ultimately
    have "?sum <=_r \<phi>!Suc pc" by (rule pp_lub)
  }
  finally show ?thesis .
qed

lemma (in lbvc) stable_wtc:
  assumes stable:  "stable r step phi pc"
  assumes pc:      "pc < length \<phi>"
  shows "wtc c pc (\<phi>!pc) \<noteq> \<top>"
proof -
  from stable pc have wti: "wti c pc (\<phi>!pc) \<noteq> \<top>" by (rule stable_wti)
  show ?thesis
  proof (cases "c!pc = \<bottom>")
    case True with wti show ?thesis by (simp add: wtc)
  next
    case False
    with pc have "c!pc = \<phi>!pc" ..
    with False wti show ?thesis by (simp add: wtc)
  qed
qed

lemma (in lbvc) wtc_less:
  assumes stable: "stable r step \<phi> pc"
  assumes suc_pc: "Suc pc < length \<phi>"
  shows "wtc c pc (\<phi>!pc) <=_r \<phi>!Suc pc" (is "?wtc <=_r _")
proof (cases "c!pc = \<bottom>")
  case True
  moreover from stable suc_pc have "wti c pc (\<phi>!pc) <=_r \<phi>!Suc pc"
    by (rule wti_less)
  ultimately show ?thesis by (simp add: wtc)
next
  case False
  from suc_pc have pc: "pc < length \<phi>" by simp
  with stable have "?wtc \<noteq> \<top>" by (rule stable_wtc)
  with False have "?wtc = wti c pc (c!pc)"
    by (unfold wtc) (simp split: if_split_asm)
  also from pc False have "c!pc = \<phi>!pc" ..
  finally have "?wtc = wti c pc (\<phi>!pc)" .
  also from stable suc_pc have "wti c pc (\<phi>!pc) <=_r \<phi>!Suc pc" by (rule wti_less)
  finally show ?thesis .
qed

lemma (in lbvc) wt_step_wtl_lemma:
  assumes wt_step: "wt_step r \<top> step \<phi>"
  shows "\<And>pc s. pc+length ls = length \<phi> \<Longrightarrow> s <=_r \<phi>!pc \<Longrightarrow> s \<in> A \<Longrightarrow> s\<noteq>\<top> \<Longrightarrow>
                wtl ls c pc s \<noteq> \<top>"
  (is "\<And>pc s. _ \<Longrightarrow> _ \<Longrightarrow> _ \<Longrightarrow> _ \<Longrightarrow> ?wtl ls pc s \<noteq> _")
proof (induct ls)
  fix pc s assume "s\<noteq>\<top>" thus "?wtl [] pc s \<noteq> \<top>" by simp
next
  fix pc s i ls
  assume "\<And>pc s. pc+length ls=length \<phi> \<Longrightarrow> s <=_r \<phi>!pc \<Longrightarrow> s \<in> A \<Longrightarrow> s\<noteq>\<top> \<Longrightarrow>
                  ?wtl ls pc s \<noteq> \<top>"
  moreover
  assume pc_l: "pc + length (i#ls) = length \<phi>"
  hence suc_pc_l: "Suc pc + length ls = length \<phi>" by simp
  ultimately
  have IH: "\<And>s. s <=_r \<phi>!Suc pc \<Longrightarrow> s \<in> A \<Longrightarrow> s \<noteq> \<top> \<Longrightarrow> ?wtl ls (Suc pc) s \<noteq> \<top>" .

  from pc_l obtain pc: "pc < length \<phi>" by simp
  with wt_step have stable: "stable r step \<phi> pc" by (simp add: wt_step_def)
  from this pc have wt_phi: "wtc c pc (\<phi>!pc) \<noteq> \<top>" by (rule stable_wtc)
  assume s_phi: "s <=_r \<phi>!pc"
  from phi pc have phi_pc: "\<phi>!pc \<in> A" by simp
  assume s: "s \<in> A"
  with s_phi pc phi_pc have wt_s_phi: "wtc c pc s <=_r wtc c pc (\<phi>!pc)" by (rule wtc_mono)
  with wt_phi have wt_s: "wtc c pc s \<noteq> \<top>" by simp
  moreover
  assume s': "s \<noteq> \<top>"
  ultimately
  have "ls = [] \<Longrightarrow> ?wtl (i#ls) pc s \<noteq> \<top>" by simp
  moreover {
    assume "ls \<noteq> []"
    with pc_l have suc_pc: "Suc pc < length \<phi>" by (auto simp add: neq_Nil_conv)
    with stable have "wtc c pc (phi!pc) <=_r \<phi>!Suc pc" by (rule wtc_less)
    with wt_s_phi have "wtc c pc s <=_r \<phi>!Suc pc" by (rule trans_r)
    moreover
    from cert suc_pc have "c!pc \<in> A" "c!(pc+1) \<in> A"
      by (auto simp add: cert_ok_def)
    from pres this s pc have "wtc c pc s \<in> A" by (rule wtc_pres)
    ultimately
    have "?wtl ls (Suc pc) (wtc c pc s) \<noteq> \<top>" using IH wt_s by blast
    with s' wt_s have "?wtl (i#ls) pc s \<noteq> \<top>" by simp
  }
  ultimately show "?wtl (i#ls) pc s \<noteq> \<top>" by (cases ls) blast+
qed

theorem (in lbvc) wtl_complete:
  assumes wt: "wt_step r \<top> step \<phi>"
    and s: "s <=_r \<phi>!0" "s \<in> A" "s \<noteq> \<top>"
    and len: "length ins = length phi"
  shows "wtl ins c 0 s \<noteq> \<top>"
proof -
  from len have "0+length ins = length phi" by simp
  from wt this s show ?thesis by (rule wt_step_wtl_lemma)
qed

end


(*  Title:      ZF/UNITY/AllocBase.thy
    Author:     Sidi O Ehmety, Cambridge University Computer Laboratory
    Copyright   2001  University of Cambridge
*)

section\<open>Common declarations for Chandy and Charpentier's Allocator\<close>

theory AllocBase imports Follows MultisetSum Guar begin

abbreviation (input)
  tokbag   :: i  (* tokbags could be multisets...or any ordered type?*)
where
  "tokbag \<equiv> nat"

axiomatization
  NbT :: i and  (* Number of tokens in system *)
  Nclients :: i  (* Number of clients *)
where
  NbT_pos: "NbT \<in> nat-{0}" and
  Nclients_pos: "Nclients \<in> nat-{0}"

text\<open>This function merely sums the elements of a list\<close>
consts tokens :: "i \<Rightarrow>i"
       item :: i (* Items to be merged/distributed *)
primrec
  "tokens(Nil) = 0"
  "tokens (Cons(x,xs)) = x #+ tokens(xs)"

consts bag_of :: "i \<Rightarrow> i"
primrec
  "bag_of(Nil)    = 0"
  "bag_of(Cons(x,xs)) = {#x#} +# bag_of(xs)"

text\<open>Definitions needed in Client.thy.  We define a recursive predicate
using 0 and 1 to code the truth values.\<close>
consts all_distinct0 :: "i\<Rightarrow>i"
primrec
  "all_distinct0(Nil) = 1"
  "all_distinct0(Cons(a, l)) =
     (if a \<in> set_of_list(l) then 0 else all_distinct0(l))"

definition
  all_distinct  :: "i\<Rightarrow>o"  where
   "all_distinct(l) \<equiv> all_distinct0(l)=1"

definition
  state_of :: "i \<Rightarrow>i" \<comment> \<open>coersion from anyting to state\<close>  where
   "state_of(s) \<equiv> if s \<in> state then s else st0"

definition
  lift :: "i \<Rightarrow>(i\<Rightarrow>i)" \<comment> \<open>simplifies the expression of programs\<close>  where
   "lift(x) \<equiv> \<lambda>s. s`x"

text\<open>function to show that the set of variables is infinite\<close>
consts
  nat_list_inj :: "i\<Rightarrow>i"
  var_inj      :: "i\<Rightarrow>i"

primrec
  "nat_list_inj(0) = Nil"
  "nat_list_inj(succ(n)) = Cons(n, nat_list_inj(n))"

primrec
  "var_inj(Var(l)) = length(l)"

definition
  nat_var_inj  :: "i\<Rightarrow>i"  where
  "nat_var_inj(n) \<equiv> Var(nat_list_inj(n))"

subsection\<open>Various simple lemmas\<close>

lemma Nclients_NbT_gt_0 [simp]: "0 < Nclients \<and> 0 < NbT"
apply (cut_tac Nclients_pos NbT_pos)
apply (auto intro: Ord_0_lt)
done

lemma Nclients_NbT_not_0 [simp]: "Nclients \<noteq> 0 \<and> NbT \<noteq> 0"
by (cut_tac Nclients_pos NbT_pos, auto)

lemma Nclients_type [simp,TC]: "Nclients\<in>nat"
by (cut_tac Nclients_pos NbT_pos, auto)

lemma NbT_type [simp,TC]: "NbT\<in>nat"
by (cut_tac Nclients_pos NbT_pos, auto)

lemma INT_Nclient_iff [iff]:
     "b\<in>\<Inter>(RepFun(Nclients, B)) \<longleftrightarrow> (\<forall>x\<in>Nclients. b\<in>B(x))"
by (force simp add: INT_iff)

lemma setsum_fun_mono [rule_format]:
     "n\<in>nat \<Longrightarrow>
      (\<forall>i\<in>nat. i<n \<longrightarrow> f(i) $\<le> g(i)) \<longrightarrow>
      setsum(f, n) $\<le> setsum(g,n)"
apply (induct_tac "n", simp_all)
apply (subgoal_tac "Finite(x) \<and> x\<notin>x")
 prefer 2 apply (simp add: nat_into_Finite mem_not_refl, clarify)
apply (simp (no_asm_simp) add: succ_def)
apply (subgoal_tac "\<forall>i\<in>nat. i<x\<longrightarrow> f(i) $\<le> g(i) ")
 prefer 2 apply (force dest: leI)
apply (rule zadd_zle_mono, simp_all)
done

lemma tokens_type [simp,TC]: "l\<in>list(A) \<Longrightarrow> tokens(l)\<in>nat"
by (erule list.induct, auto)

lemma tokens_mono_aux [rule_format]:
     "xs\<in>list(A) \<Longrightarrow> \<forall>ys\<in>list(A). \<langle>xs, ys\<rangle>\<in>prefix(A)
   \<longrightarrow> tokens(xs) \<le> tokens(ys)"
apply (induct_tac "xs")
apply (auto dest: gen_prefix.dom_subset [THEN subsetD] simp add: prefix_def)
done

lemma tokens_mono: "\<langle>xs, ys\<rangle>\<in>prefix(A) \<Longrightarrow> tokens(xs) \<le> tokens(ys)"
apply (cut_tac prefix_type)
apply (blast intro: tokens_mono_aux)
done

lemma mono_tokens [iff]: "mono1(list(A), prefix(A), nat, Le,tokens)"
  unfolding mono1_def
apply (auto intro: tokens_mono simp add: Le_def)
done

lemma tokens_append [simp]:
"\<lbrakk>xs\<in>list(A); ys\<in>list(A)\<rbrakk> \<Longrightarrow> tokens(xs@ys) = tokens(xs) #+ tokens(ys)"
apply (induct_tac "xs", auto)
done

subsection\<open>The function \<^term>\<open>bag_of\<close>\<close>

lemma bag_of_type [simp,TC]: "l\<in>list(A) \<Longrightarrow>bag_of(l)\<in>Mult(A)"
apply (induct_tac "l")
apply (auto simp add: Mult_iff_multiset)
done

lemma bag_of_multiset:
     "l\<in>list(A) \<Longrightarrow> multiset(bag_of(l)) \<and> mset_of(bag_of(l))<=A"
apply (drule bag_of_type)
apply (auto simp add: Mult_iff_multiset)
done

lemma bag_of_append [simp]:
    "\<lbrakk>xs\<in>list(A); ys\<in>list(A)\<rbrakk> \<Longrightarrow> bag_of(xs@ys) = bag_of(xs) +# bag_of(ys)"
apply (induct_tac "xs")
apply (auto simp add: bag_of_multiset munion_assoc)
done

lemma bag_of_mono_aux [rule_format]:
     "xs\<in>list(A) \<Longrightarrow> \<forall>ys\<in>list(A). \<langle>xs, ys\<rangle>\<in>prefix(A)
      \<longrightarrow> <bag_of(xs), bag_of(ys)>\<in>MultLe(A, r)"
apply (induct_tac "xs", simp_all, clarify)
apply (frule_tac l = ys in bag_of_multiset)
apply (auto intro: empty_le_MultLe simp add: prefix_def)
apply (rule munion_mono)
apply (force simp add: MultLe_def Mult_iff_multiset)
apply (blast dest: gen_prefix.dom_subset [THEN subsetD])
done

lemma bag_of_mono [intro]:
     "\<lbrakk>\<langle>xs, ys\<rangle>\<in>prefix(A); xs\<in>list(A); ys\<in>list(A)\<rbrakk>
      \<Longrightarrow> <bag_of(xs), bag_of(ys)>\<in>MultLe(A, r)"
apply (blast intro: bag_of_mono_aux)
done

lemma mono_bag_of [simp]:
     "mono1(list(A), prefix(A), Mult(A), MultLe(A,r), bag_of)"
by (auto simp add:  mono1_def bag_of_type)

subsection\<open>The function \<^term>\<open>msetsum\<close>\<close>

lemmas nat_into_Fin = eqpoll_refl [THEN [2] Fin_lemma]

lemma list_Int_length_Fin: "l \<in> list(A) \<Longrightarrow> C \<inter> length(l) \<in> Fin(length(l))"
apply (drule length_type)
apply (rule Fin_subset)
apply (rule Int_lower2)
apply (erule nat_into_Fin)
done

lemma mem_Int_imp_lt_length:
     "\<lbrakk>xs \<in> list(A); k \<in> C \<inter> length(xs)\<rbrakk> \<Longrightarrow> k < length(xs)"
by (simp add: ltI)

lemma Int_succ_right:
     "A \<inter> succ(k) = (if k \<in> A then cons(k, A \<inter> k) else A \<inter> k)"
by auto

lemma bag_of_sublist_lemma:
     "\<lbrakk>C \<subseteq> nat; x \<in> A; xs \<in> list(A)\<rbrakk>
  \<Longrightarrow>  msetsum(\<lambda>i. {#nth(i, xs @ [x])#}, C \<inter> succ(length(xs)), A) =
       (if length(xs) \<in> C then
          {#x#} +# msetsum(\<lambda>x. {#nth(x, xs)#}, C \<inter> length(xs), A)
        else msetsum(\<lambda>x. {#nth(x, xs)#}, C \<inter> length(xs), A))"
apply (simp add: subsetD nth_append lt_not_refl mem_Int_imp_lt_length cong add: msetsum_cong)
apply (simp add: Int_succ_right)
apply (simp add: lt_not_refl mem_Int_imp_lt_length cong add: msetsum_cong, clarify)
apply (subst msetsum_cons)
apply (rule_tac [3] succI1)
apply (blast intro: list_Int_length_Fin subset_succI [THEN Fin_mono, THEN subsetD])
apply (simp add: mem_not_refl)
apply (simp add: nth_type lt_not_refl)
apply (blast intro: nat_into_Ord ltI length_type)
apply (simp add: lt_not_refl mem_Int_imp_lt_length cong add: msetsum_cong)
done

lemma bag_of_sublist_lemma2:
     "l\<in>list(A) \<Longrightarrow>
  C \<subseteq> nat \<Longrightarrow>
  bag_of(sublist(l, C)) =
      msetsum(\<lambda>i. {#nth(i, l)#}, C \<inter> length(l), A)"
apply (erule list_append_induct)
apply (simp (no_asm))
apply (simp (no_asm_simp) add: sublist_append nth_append bag_of_sublist_lemma munion_commute bag_of_sublist_lemma msetsum_multiset munion_0)
done

lemma nat_Int_length_eq: "l \<in> list(A) \<Longrightarrow> nat \<inter> length(l) = length(l)"
apply (rule Int_absorb1)
apply (rule OrdmemD, auto)
done

(*eliminating the assumption C<=nat*)
lemma bag_of_sublist:
     "l\<in>list(A) \<Longrightarrow>
  bag_of(sublist(l, C)) = msetsum(\<lambda>i. {#nth(i, l)#}, C \<inter> length(l), A)"
apply (subgoal_tac " bag_of (sublist (l, C \<inter> nat)) = msetsum (\<lambda>i. {#nth (i, l) #}, C \<inter> length (l), A) ")
apply (simp add: sublist_Int_eq)
apply (simp add: bag_of_sublist_lemma2 Int_lower2 Int_assoc nat_Int_length_eq)
done

lemma bag_of_sublist_Un_Int:
"l\<in>list(A) \<Longrightarrow>
  bag_of(sublist(l, B \<union> C)) +# bag_of(sublist(l, B \<inter> C)) =
      bag_of(sublist(l, B)) +# bag_of(sublist(l, C))"
apply (subgoal_tac "B \<inter> C \<inter> length (l) = (B \<inter> length (l)) \<inter> (C \<inter> length (l))")
prefer 2 apply blast
apply (simp (no_asm_simp) add: bag_of_sublist Int_Un_distrib2 msetsum_Un_Int)
apply (rule msetsum_Un_Int)
apply (erule list_Int_length_Fin)+
 apply (simp add: ltI nth_type)
done

lemma bag_of_sublist_Un_disjoint:
     "\<lbrakk>l\<in>list(A); B \<inter> C = 0\<rbrakk>
      \<Longrightarrow> bag_of(sublist(l, B \<union> C)) =
          bag_of(sublist(l, B)) +# bag_of(sublist(l, C))"
by (simp add: bag_of_sublist_Un_Int [symmetric] bag_of_multiset)

lemma bag_of_sublist_UN_disjoint [rule_format]:
     "\<lbrakk>Finite(I); \<forall>i\<in>I. \<forall>j\<in>I. i\<noteq>j \<longrightarrow> A(i) \<inter> A(j) = 0;
        l\<in>list(B)\<rbrakk>
      \<Longrightarrow> bag_of(sublist(l, \<Union>i\<in>I. A(i))) =
          (msetsum(\<lambda>i. bag_of(sublist(l, A(i))), I, B)) "
apply (simp (no_asm_simp) del: UN_simps
           add: UN_simps [symmetric] bag_of_sublist)
apply (subst  msetsum_UN_disjoint [of _ _ _ "length (l)"])
apply (drule Finite_into_Fin, assumption)
prefer 3 apply force
apply (auto intro!: Fin_IntI2 Finite_into_Fin simp add: ltI nth_type length_type nat_into_Finite)
done

lemma part_ord_Lt [simp]: "part_ord(nat, Lt)"
  unfolding part_ord_def Lt_def irrefl_def trans_on_def
apply (auto intro: lt_trans)
done

subsubsection\<open>The function \<^term>\<open>all_distinct\<close>\<close>

lemma all_distinct_Nil [simp]: "all_distinct(Nil)"
by (unfold all_distinct_def, auto)

lemma all_distinct_Cons [simp]:
    "all_distinct(Cons(a,l)) \<longleftrightarrow>
      (a\<in>set_of_list(l) \<longrightarrow> False) \<and> (a \<notin> set_of_list(l) \<longrightarrow> all_distinct(l))"
  unfolding all_distinct_def
apply (auto elim: list.cases)
done

subsubsection\<open>The function \<^term>\<open>state_of\<close>\<close>

lemma state_of_state: "s\<in>state \<Longrightarrow> state_of(s)=s"
by (unfold state_of_def, auto)
declare state_of_state [simp]

lemma state_of_idem: "state_of(state_of(s))=state_of(s)"

apply (unfold state_of_def, auto)
done
declare state_of_idem [simp]

lemma state_of_type [simp,TC]: "state_of(s)\<in>state"
by (unfold state_of_def, auto)

lemma lift_apply [simp]: "lift(x, s)=s`x"
by (simp add: lift_def)

(** Used in ClientImp **)

lemma gen_Increains_state_of_eq:
     "Increasing(A, r, \<lambda>s. f(state_of(s))) = Increasing(A, r, f)"
apply (unfold Increasing_def, auto)
done

lemmas Increasing_state_ofD1 =
      gen_Increains_state_of_eq [THEN equalityD1, THEN subsetD]
lemmas Increasing_state_ofD2 =
      gen_Increains_state_of_eq [THEN equalityD2, THEN subsetD]

lemma Follows_state_of_eq:
     "Follows(A, r, \<lambda>s. f(state_of(s)), \<lambda>s. g(state_of(s))) =
      Follows(A, r, f, g)"
apply (unfold Follows_def Increasing_def, auto)
done

lemmas Follows_state_ofD1 =
      Follows_state_of_eq [THEN equalityD1, THEN subsetD]
lemmas Follows_state_ofD2 =
      Follows_state_of_eq [THEN equalityD2, THEN subsetD]

lemma nat_list_inj_type: "n\<in>nat \<Longrightarrow> nat_list_inj(n)\<in>list(nat)"
by (induct_tac "n", auto)

lemma length_nat_list_inj: "n\<in>nat \<Longrightarrow> length(nat_list_inj(n)) = n"
by (induct_tac "n", auto)

lemma var_infinite_lemma:
  "(\<lambda>x\<in>nat. nat_var_inj(x))\<in>inj(nat, var)"
  unfolding nat_var_inj_def
apply (rule_tac d = var_inj in lam_injective)
apply (auto simp add: var.intros nat_list_inj_type)
apply (simp add: length_nat_list_inj)
done

lemma nat_lepoll_var: "nat \<lesssim> var"
  unfolding lepoll_def
apply (rule_tac x = " (\<lambda>x\<in>nat. nat_var_inj (x))" in exI)
apply (rule var_infinite_lemma)
done

lemma var_not_Finite: "\<not>Finite(var)"
apply (insert nat_not_Finite)
apply (blast intro: lepoll_Finite [OF nat_lepoll_var])
done

lemma not_Finite_imp_exist: "\<not>Finite(A) \<Longrightarrow> \<exists>x. x\<in>A"
apply (subgoal_tac "A\<noteq>0")
apply (auto simp add: Finite_0)
done

lemma Inter_Diff_var_iff:
     "Finite(A) \<Longrightarrow> b\<in>(\<Inter>(RepFun(var-A, B))) \<longleftrightarrow> (\<forall>x\<in>var-A. b\<in>B(x))"
apply (subgoal_tac "\<exists>x. x\<in>var-A", auto)
apply (subgoal_tac "\<not>Finite (var-A) ")
apply (drule not_Finite_imp_exist, auto)
apply (cut_tac var_not_Finite)
apply (erule swap)
apply (rule_tac B = A in Diff_Finite, auto)
done

lemma Inter_var_DiffD:
     "\<lbrakk>b\<in>\<Inter>(RepFun(var-A, B)); Finite(A); x\<in>var-A\<rbrakk> \<Longrightarrow> b\<in>B(x)"
by (simp add: Inter_Diff_var_iff)

(* \<lbrakk>Finite(A); (\<forall>x\<in>var-A. b\<in>B(x))\<rbrakk> \<Longrightarrow> b\<in>\<Inter>(RepFun(var-A, B)) *)
lemmas Inter_var_DiffI = Inter_Diff_var_iff [THEN iffD2]

declare Inter_var_DiffI [intro!]

lemma Acts_subset_Int_Pow_simp [simp]:
     "Acts(F)<= A \<inter> Pow(state*state)  \<longleftrightarrow> Acts(F)<=A"
by (insert Acts_type [of F], auto)

lemma setsum_nsetsum_eq:
     "\<lbrakk>Finite(A); \<forall>x\<in>A. g(x)\<in>nat\<rbrakk>
      \<Longrightarrow> setsum(\<lambda>x. $#(g(x)), A) = $# nsetsum(\<lambda>x. g(x), A)"
apply (erule Finite_induct)
apply (auto simp add: int_of_add)
done

lemma nsetsum_cong:
     "\<lbrakk>A=B;  \<forall>x\<in>A. f(x)=g(x);  \<forall>x\<in>A. g(x)\<in>nat;  Finite(A)\<rbrakk>
      \<Longrightarrow> nsetsum(f, A) = nsetsum(g, B)"
apply (subgoal_tac "$# nsetsum (f, A) = $# nsetsum (g, B)", simp)
apply (simp add: setsum_nsetsum_eq [symmetric] cong: setsum_cong)
done

end


(* Author: Lukas Bulwahn, TU Muenchen *)

section \<open>The Random-Predicate Monad\<close>

theory Random_Pred
imports Quickcheck_Random
begin

fun iter' :: "'a itself \<Rightarrow> natural \<Rightarrow> natural \<Rightarrow> Random.seed \<Rightarrow> ('a::random) Predicate.pred"
where
  "iter' T nrandom sz seed = (if nrandom = 0 then bot_class.bot else
     let ((x, _), seed') = Quickcheck_Random.random sz seed
   in Predicate.Seq (%u. Predicate.Insert x (iter' T (nrandom - 1) sz seed')))"

definition iter :: "natural \<Rightarrow> natural \<Rightarrow> Random.seed \<Rightarrow> ('a::random) Predicate.pred"
where
  "iter nrandom sz seed = iter' (TYPE('a)) nrandom sz seed"

type_synonym 'a random_pred = "Random.seed \<Rightarrow> ('a Predicate.pred \<times> Random.seed)"

definition empty :: "'a random_pred"
  where "empty = Pair bot"

definition single :: "'a => 'a random_pred"
  where "single x = Pair (Predicate.single x)"

definition bind :: "'a random_pred \<Rightarrow> ('a \<Rightarrow> 'b random_pred) \<Rightarrow> 'b random_pred"
  where
    "bind R f = (\<lambda>s. let
       (P, s') = R s;
       (s1, s2) = Random.split_seed s'
     in (Predicate.bind P (%a. fst (f a s1)), s2))"

definition union :: "'a random_pred \<Rightarrow> 'a random_pred \<Rightarrow> 'a random_pred"
where
  "union R1 R2 = (\<lambda>s. let
     (P1, s') = R1 s; (P2, s'') = R2 s'
   in (sup_class.sup P1 P2, s''))"

definition if_randompred :: "bool \<Rightarrow> unit random_pred"
where
  "if_randompred b = (if b then single () else empty)"

definition iterate_upto :: "(natural \<Rightarrow> 'a) => natural \<Rightarrow> natural \<Rightarrow> 'a random_pred"
where
  "iterate_upto f n m = Pair (Predicate.iterate_upto f n m)"

definition not_randompred :: "unit random_pred \<Rightarrow> unit random_pred"
where
  "not_randompred P = (\<lambda>s. let
     (P', s') = P s
   in if Predicate.eval P' () then (Orderings.bot, s') else (Predicate.single (), s'))"

definition Random :: "(Random.seed \<Rightarrow> ('a \<times> (unit \<Rightarrow> term)) \<times> Random.seed) \<Rightarrow> 'a random_pred"
  where "Random g = scomp g (Pair \<circ> (Predicate.single \<circ> fst))"

definition map :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a random_pred \<Rightarrow> 'b random_pred"
  where "map f P = bind P (single \<circ> f)"

hide_const (open) iter' iter empty single bind union if_randompred
  iterate_upto not_randompred Random map

hide_fact iter'.simps

hide_fact (open) iter_def empty_def single_def bind_def union_def
  if_randompred_def iterate_upto_def not_randompred_def Random_def map_def

end


(*  Title:      HOL/Proofs/Lambda/Standardization.thy
    Author:     Stefan Berghofer
    Copyright   2005 TU Muenchen
*)

section \<open>Standardization\<close>

theory Standardization
imports NormalForm
begin

text \<open>
Based on lecture notes by Ralph Matthes @{cite "Matthes-ESSLLI2000"},
original proof idea due to Ralph Loader @{cite Loader1998}.
\<close>

subsection \<open>Standard reduction relation\<close>

declare listrel_mono [mono_set]

inductive
  sred :: "dB \<Rightarrow> dB \<Rightarrow> bool"  (infixl "\<rightarrow>\<^sub>s" 50)
  and sredlist :: "dB list \<Rightarrow> dB list \<Rightarrow> bool"  (infixl "[\<rightarrow>\<^sub>s]" 50)
where
  "s [\<rightarrow>\<^sub>s] t \<equiv> listrelp op \<rightarrow>\<^sub>s s t"
| Var: "rs [\<rightarrow>\<^sub>s] rs' \<Longrightarrow> Var x \<degree>\<degree> rs \<rightarrow>\<^sub>s Var x \<degree>\<degree> rs'"
| Abs: "r \<rightarrow>\<^sub>s r' \<Longrightarrow> ss [\<rightarrow>\<^sub>s] ss' \<Longrightarrow> Abs r \<degree>\<degree> ss \<rightarrow>\<^sub>s Abs r' \<degree>\<degree> ss'"
| Beta: "r[s/0] \<degree>\<degree> ss \<rightarrow>\<^sub>s t \<Longrightarrow> Abs r \<degree> s \<degree>\<degree> ss \<rightarrow>\<^sub>s t"

lemma refl_listrelp: "\<forall>x\<in>set xs. R x x \<Longrightarrow> listrelp R xs xs"
  by (induct xs) (auto intro: listrelp.intros)

lemma refl_sred: "t \<rightarrow>\<^sub>s t"
  by (induct t rule: Apps_dB_induct) (auto intro: refl_listrelp sred.intros)

lemma refl_sreds: "ts [\<rightarrow>\<^sub>s] ts"
  by (simp add: refl_sred refl_listrelp)

lemma listrelp_conj1: "listrelp (\<lambda>x y. R x y \<and> S x y) x y \<Longrightarrow> listrelp R x y"
  by (erule listrelp.induct) (auto intro: listrelp.intros)

lemma listrelp_conj2: "listrelp (\<lambda>x y. R x y \<and> S x y) x y \<Longrightarrow> listrelp S x y"
  by (erule listrelp.induct) (auto intro: listrelp.intros)

lemma listrelp_app:
  assumes xsys: "listrelp R xs ys"
  shows "listrelp R xs' ys' \<Longrightarrow> listrelp R (xs @ xs') (ys @ ys')" using xsys
  by (induct arbitrary: xs' ys') (auto intro: listrelp.intros)

lemma lemma1:
  assumes r: "r \<rightarrow>\<^sub>s r'" and s: "s \<rightarrow>\<^sub>s s'"
  shows "r \<degree> s \<rightarrow>\<^sub>s r' \<degree> s'" using r
proof induct
  case (Var rs rs' x)
  then have "rs [\<rightarrow>\<^sub>s] rs'" by (rule listrelp_conj1)
  moreover have "[s] [\<rightarrow>\<^sub>s] [s']" by (iprover intro: s listrelp.intros)
  ultimately have "rs @ [s] [\<rightarrow>\<^sub>s] rs' @ [s']" by (rule listrelp_app)
  hence "Var x \<degree>\<degree> (rs @ [s]) \<rightarrow>\<^sub>s Var x \<degree>\<degree> (rs' @ [s'])" by (rule sred.Var)
  thus ?case by (simp only: app_last)
next
  case (Abs r r' ss ss')
  from Abs(3) have "ss [\<rightarrow>\<^sub>s] ss'" by (rule listrelp_conj1)
  moreover have "[s] [\<rightarrow>\<^sub>s] [s']" by (iprover intro: s listrelp.intros)
  ultimately have "ss @ [s] [\<rightarrow>\<^sub>s] ss' @ [s']" by (rule listrelp_app)
  with \<open>r \<rightarrow>\<^sub>s r'\<close> have "Abs r \<degree>\<degree> (ss @ [s]) \<rightarrow>\<^sub>s Abs r' \<degree>\<degree> (ss' @ [s'])"
    by (rule sred.Abs)
  thus ?case by (simp only: app_last)
next
  case (Beta r u ss t)
  hence "r[u/0] \<degree>\<degree> (ss @ [s]) \<rightarrow>\<^sub>s t \<degree> s'" by (simp only: app_last)
  hence "Abs r \<degree> u \<degree>\<degree> (ss @ [s]) \<rightarrow>\<^sub>s t \<degree> s'" by (rule sred.Beta)
  thus ?case by (simp only: app_last)
qed

lemma lemma1':
  assumes ts: "ts [\<rightarrow>\<^sub>s] ts'"
  shows "r \<rightarrow>\<^sub>s r' \<Longrightarrow> r \<degree>\<degree> ts \<rightarrow>\<^sub>s r' \<degree>\<degree> ts'" using ts
  by (induct arbitrary: r r') (auto intro: lemma1)

lemma lemma2_1:
  assumes beta: "t \<rightarrow>\<^sub>\<beta> u"
  shows "t \<rightarrow>\<^sub>s u" using beta
proof induct
  case (beta s t)
  have "Abs s \<degree> t \<degree>\<degree> [] \<rightarrow>\<^sub>s s[t/0] \<degree>\<degree> []" by (iprover intro: sred.Beta refl_sred)
  thus ?case by simp
next
  case (appL s t u)
  thus ?case by (iprover intro: lemma1 refl_sred)
next
  case (appR s t u)
  thus ?case by (iprover intro: lemma1 refl_sred)
next
  case (abs s t)
  hence "Abs s \<degree>\<degree> [] \<rightarrow>\<^sub>s Abs t \<degree>\<degree> []" by (iprover intro: sred.Abs listrelp.Nil)
  thus ?case by simp
qed

lemma listrelp_betas:
  assumes ts: "listrelp op \<rightarrow>\<^sub>\<beta>\<^sup>* ts ts'"
  shows "\<And>t t'. t \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<Longrightarrow> t \<degree>\<degree> ts \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<degree>\<degree> ts'" using ts
  by induct auto

lemma lemma2_2:
  assumes t: "t \<rightarrow>\<^sub>s u"
  shows "t \<rightarrow>\<^sub>\<beta>\<^sup>* u" using t
  by induct (auto dest: listrelp_conj2
    intro: listrelp_betas apps_preserves_beta converse_rtranclp_into_rtranclp)

lemma sred_lift:
  assumes s: "s \<rightarrow>\<^sub>s t"
  shows "lift s i \<rightarrow>\<^sub>s lift t i" using s
proof (induct arbitrary: i)
  case (Var rs rs' x)
  hence "map (\<lambda>t. lift t i) rs [\<rightarrow>\<^sub>s] map (\<lambda>t. lift t i) rs'"
    by induct (auto intro: listrelp.intros)
  thus ?case by (cases "x < i") (auto intro: sred.Var)
next
  case (Abs r r' ss ss')
  from Abs(3) have "map (\<lambda>t. lift t i) ss [\<rightarrow>\<^sub>s] map (\<lambda>t. lift t i) ss'"
    by induct (auto intro: listrelp.intros)
  thus ?case by (auto intro: sred.Abs Abs)
next
  case (Beta r s ss t)
  thus ?case by (auto intro: sred.Beta)
qed

lemma lemma3:
  assumes r: "r \<rightarrow>\<^sub>s r'"
  shows "s \<rightarrow>\<^sub>s s' \<Longrightarrow> r[s/x] \<rightarrow>\<^sub>s r'[s'/x]" using r
proof (induct arbitrary: s s' x)
  case (Var rs rs' y)
  hence "map (\<lambda>t. t[s/x]) rs [\<rightarrow>\<^sub>s] map (\<lambda>t. t[s'/x]) rs'"
    by induct (auto intro: listrelp.intros Var)
  moreover have "Var y[s/x] \<rightarrow>\<^sub>s Var y[s'/x]"
  proof (cases "y < x")
    case True thus ?thesis by simp (rule refl_sred)
  next
    case False
    thus ?thesis
      by (cases "y = x") (auto simp add: Var intro: refl_sred)
  qed
  ultimately show ?case by simp (rule lemma1')
next
  case (Abs r r' ss ss')
  from Abs(4) have "lift s 0 \<rightarrow>\<^sub>s lift s' 0" by (rule sred_lift)
  hence "r[lift s 0/Suc x] \<rightarrow>\<^sub>s r'[lift s' 0/Suc x]" by (fast intro: Abs.hyps)
  moreover from Abs(3) have "map (\<lambda>t. t[s/x]) ss [\<rightarrow>\<^sub>s] map (\<lambda>t. t[s'/x]) ss'"
    by induct (auto intro: listrelp.intros Abs)
  ultimately show ?case by simp (rule sred.Abs)
next
  case (Beta r u ss t)
  thus ?case by (auto simp add: subst_subst intro: sred.Beta)
qed

lemma lemma4_aux:
  assumes rs: "listrelp (\<lambda>t u. t \<rightarrow>\<^sub>s u \<and> (\<forall>r. u \<rightarrow>\<^sub>\<beta> r \<longrightarrow> t \<rightarrow>\<^sub>s r)) rs rs'"
  shows "rs' => ss \<Longrightarrow> rs [\<rightarrow>\<^sub>s] ss" using rs
proof (induct arbitrary: ss)
  case Nil
  thus ?case by cases (auto intro: listrelp.Nil)
next
  case (Cons x y xs ys)
  note Cons' = Cons
  show ?case
  proof (cases ss)
    case Nil with Cons show ?thesis by simp
  next
    case (Cons y' ys')
    hence ss: "ss = y' # ys'" by simp
    from Cons Cons' have "y \<rightarrow>\<^sub>\<beta> y' \<and> ys' = ys \<or> y' = y \<and> ys => ys'" by simp
    hence "x # xs [\<rightarrow>\<^sub>s] y' # ys'"
    proof
      assume H: "y \<rightarrow>\<^sub>\<beta> y' \<and> ys' = ys"
      with Cons' have "x \<rightarrow>\<^sub>s y'" by blast
      moreover from Cons' have "xs [\<rightarrow>\<^sub>s] ys" by (iprover dest: listrelp_conj1)
      ultimately have "x # xs [\<rightarrow>\<^sub>s] y' # ys" by (rule listrelp.Cons)
      with H show ?thesis by simp
    next
      assume H: "y' = y \<and> ys => ys'"
      with Cons' have "x \<rightarrow>\<^sub>s y'" by blast
      moreover from H have "xs [\<rightarrow>\<^sub>s] ys'" by (blast intro: Cons')
      ultimately show ?thesis by (rule listrelp.Cons)
    qed
    with ss show ?thesis by simp
  qed
qed

lemma lemma4:
  assumes r: "r \<rightarrow>\<^sub>s r'"
  shows "r' \<rightarrow>\<^sub>\<beta> r'' \<Longrightarrow> r \<rightarrow>\<^sub>s r''" using r
proof (induct arbitrary: r'')
  case (Var rs rs' x)
  then obtain ss where rs: "rs' => ss" and r'': "r'' = Var x \<degree>\<degree> ss"
    by (blast dest: head_Var_reduction)
  from Var(1) rs have "rs [\<rightarrow>\<^sub>s] ss" by (rule lemma4_aux)
  hence "Var x \<degree>\<degree> rs \<rightarrow>\<^sub>s Var x \<degree>\<degree> ss" by (rule sred.Var)
  with r'' show ?case by simp
next
  case (Abs r r' ss ss')
  from \<open>Abs r' \<degree>\<degree> ss' \<rightarrow>\<^sub>\<beta> r''\<close> show ?case
  proof
    fix s
    assume r'': "r'' = s \<degree>\<degree> ss'"
    assume "Abs r' \<rightarrow>\<^sub>\<beta> s"
    then obtain r''' where s: "s = Abs r'''" and r''': "r' \<rightarrow>\<^sub>\<beta> r'''" by cases auto
    from r''' have "r \<rightarrow>\<^sub>s r'''" by (blast intro: Abs)
    moreover from Abs have "ss [\<rightarrow>\<^sub>s] ss'" by (iprover dest: listrelp_conj1)
    ultimately have "Abs r \<degree>\<degree> ss \<rightarrow>\<^sub>s Abs r''' \<degree>\<degree> ss'" by (rule sred.Abs)
    with r'' s show "Abs r \<degree>\<degree> ss \<rightarrow>\<^sub>s r''" by simp
  next
    fix rs'
    assume "ss' => rs'"
    with Abs(3) have "ss [\<rightarrow>\<^sub>s] rs'" by (rule lemma4_aux)
    with \<open>r \<rightarrow>\<^sub>s r'\<close> have "Abs r \<degree>\<degree> ss \<rightarrow>\<^sub>s Abs r' \<degree>\<degree> rs'" by (rule sred.Abs)
    moreover assume "r'' = Abs r' \<degree>\<degree> rs'"
    ultimately show "Abs r \<degree>\<degree> ss \<rightarrow>\<^sub>s r''" by simp
  next
    fix t u' us'
    assume "ss' = u' # us'"
    with Abs(3) obtain u us where
      ss: "ss = u # us" and u: "u \<rightarrow>\<^sub>s u'" and us: "us [\<rightarrow>\<^sub>s] us'"
      by cases (auto dest!: listrelp_conj1)
    have "r[u/0] \<rightarrow>\<^sub>s r'[u'/0]" using Abs(1) and u by (rule lemma3)
    with us have "r[u/0] \<degree>\<degree> us \<rightarrow>\<^sub>s r'[u'/0] \<degree>\<degree> us'" by (rule lemma1')
    hence "Abs r \<degree> u \<degree>\<degree> us \<rightarrow>\<^sub>s r'[u'/0] \<degree>\<degree> us'" by (rule sred.Beta)
    moreover assume "Abs r' = Abs t" and "r'' = t[u'/0] \<degree>\<degree> us'"
    ultimately show "Abs r \<degree>\<degree> ss \<rightarrow>\<^sub>s r''" using ss by simp
  qed
next
  case (Beta r s ss t)
  show ?case
    by (rule sred.Beta) (rule Beta)+
qed

lemma rtrancl_beta_sred:
  assumes r: "r \<rightarrow>\<^sub>\<beta>\<^sup>* r'"
  shows "r \<rightarrow>\<^sub>s r'" using r
  by induct (iprover intro: refl_sred lemma4)+

subsection \<open>Leftmost reduction and weakly normalizing terms\<close>

inductive
  lred :: "dB \<Rightarrow> dB \<Rightarrow> bool"  (infixl "\<rightarrow>\<^sub>l" 50)
  and lredlist :: "dB list \<Rightarrow> dB list \<Rightarrow> bool"  (infixl "[\<rightarrow>\<^sub>l]" 50)
where
  "s [\<rightarrow>\<^sub>l] t \<equiv> listrelp op \<rightarrow>\<^sub>l s t"
| Var: "rs [\<rightarrow>\<^sub>l] rs' \<Longrightarrow> Var x \<degree>\<degree> rs \<rightarrow>\<^sub>l Var x \<degree>\<degree> rs'"
| Abs: "r \<rightarrow>\<^sub>l r' \<Longrightarrow> Abs r \<rightarrow>\<^sub>l Abs r'"
| Beta: "r[s/0] \<degree>\<degree> ss \<rightarrow>\<^sub>l t \<Longrightarrow> Abs r \<degree> s \<degree>\<degree> ss \<rightarrow>\<^sub>l t"

lemma lred_imp_sred:
  assumes lred: "s \<rightarrow>\<^sub>l t"
  shows "s \<rightarrow>\<^sub>s t" using lred
proof induct
  case (Var rs rs' x)
  then have "rs [\<rightarrow>\<^sub>s] rs'"
    by induct (iprover intro: listrelp.intros)+
  then show ?case by (rule sred.Var)
next
  case (Abs r r')
  from \<open>r \<rightarrow>\<^sub>s r'\<close>
  have "Abs r \<degree>\<degree> [] \<rightarrow>\<^sub>s Abs r' \<degree>\<degree> []" using listrelp.Nil
    by (rule sred.Abs)
  then show ?case by simp
next
  case (Beta r s ss t)
  from \<open>r[s/0] \<degree>\<degree> ss \<rightarrow>\<^sub>s t\<close>
  show ?case by (rule sred.Beta)
qed

inductive WN :: "dB => bool"
  where
    Var: "listsp WN rs \<Longrightarrow> WN (Var n \<degree>\<degree> rs)"
  | Lambda: "WN r \<Longrightarrow> WN (Abs r)"
  | Beta: "WN ((r[s/0]) \<degree>\<degree> ss) \<Longrightarrow> WN ((Abs r \<degree> s) \<degree>\<degree> ss)"

lemma listrelp_imp_listsp1:
  assumes H: "listrelp (\<lambda>x y. P x) xs ys"
  shows "listsp P xs" using H
  by induct auto

lemma listrelp_imp_listsp2:
  assumes H: "listrelp (\<lambda>x y. P y) xs ys"
  shows "listsp P ys" using H
  by induct auto

lemma lemma5:
  assumes lred: "r \<rightarrow>\<^sub>l r'"
  shows "WN r" and "NF r'" using lred
  by induct
    (iprover dest: listrelp_conj1 listrelp_conj2
     listrelp_imp_listsp1 listrelp_imp_listsp2 intro: WN.intros
     NF.intros [simplified listall_listsp_eq])+

lemma lemma6:
  assumes wn: "WN r"
  shows "\<exists>r'. r \<rightarrow>\<^sub>l r'" using wn
proof induct
  case (Var rs n)
  then have "\<exists>rs'. rs [\<rightarrow>\<^sub>l] rs'"
    by induct (iprover intro: listrelp.intros)+
  then show ?case by (iprover intro: lred.Var)
qed (iprover intro: lred.intros)+

lemma lemma7:
  assumes r: "r \<rightarrow>\<^sub>s r'"
  shows "NF r' \<Longrightarrow> r \<rightarrow>\<^sub>l r'" using r
proof induct
  case (Var rs rs' x)
  from \<open>NF (Var x \<degree>\<degree> rs')\<close> have "listall NF rs'"
    by cases simp_all
  with Var(1) have "rs [\<rightarrow>\<^sub>l] rs'"
  proof induct
    case Nil
    show ?case by (rule listrelp.Nil)
  next
    case (Cons x y xs ys)
    hence "x \<rightarrow>\<^sub>l y" and "xs [\<rightarrow>\<^sub>l] ys" by simp_all
    thus ?case by (rule listrelp.Cons)
  qed
  thus ?case by (rule lred.Var)
next
  case (Abs r r' ss ss')
  from \<open>NF (Abs r' \<degree>\<degree> ss')\<close>
  have ss': "ss' = []" by (rule Abs_NF)
  from Abs(3) have ss: "ss = []" using ss'
    by cases simp_all
  from ss' Abs have "NF (Abs r')" by simp
  hence "NF r'" by cases simp_all
  with Abs have "r \<rightarrow>\<^sub>l r'" by simp
  hence "Abs r \<rightarrow>\<^sub>l Abs r'" by (rule lred.Abs)
  with ss ss' show ?case by simp
next
  case (Beta r s ss t)
  hence "r[s/0] \<degree>\<degree> ss \<rightarrow>\<^sub>l t" by simp
  thus ?case by (rule lred.Beta)
qed

lemma WN_eq: "WN t = (\<exists>t'. t \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<and> NF t')"
proof
  assume "WN t"
  then have "\<exists>t'. t \<rightarrow>\<^sub>l t'" by (rule lemma6)
  then obtain t' where t': "t \<rightarrow>\<^sub>l t'" ..
  then have NF: "NF t'" by (rule lemma5)
  from t' have "t \<rightarrow>\<^sub>s t'" by (rule lred_imp_sred)
  then have "t \<rightarrow>\<^sub>\<beta>\<^sup>* t'" by (rule lemma2_2)
  with NF show "\<exists>t'. t \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<and> NF t'" by iprover
next
  assume "\<exists>t'. t \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<and> NF t'"
  then obtain t' where t': "t \<rightarrow>\<^sub>\<beta>\<^sup>* t'" and NF: "NF t'"
    by iprover
  from t' have "t \<rightarrow>\<^sub>s t'" by (rule rtrancl_beta_sred)
  then have "t \<rightarrow>\<^sub>l t'" using NF by (rule lemma7)
  then show "WN t" by (rule lemma5)
qed

end