(*
Author: Alexander Katovsky
*)

header "The Category of Sets"

theory SetCat
imports Functors Universe
begin

notation (xsymbols) Elem (infixl "|\<in>|" 70)
notation (xsymbols) HOLZF.subset (infixl "|\<subseteq>|" 71)
notation (xsymbols) CartProd (infixl "|\<times>|" 75)

definition
  ZFfun :: "ZF \<Rightarrow> ZF \<Rightarrow> (ZF \<Rightarrow> ZF) \<Rightarrow> ZF" where
  "ZFfun d r f \<equiv> Opair (Opair d r) (Lambda d f)"

definition
  ZFfunDom :: "ZF \<Rightarrow> ZF" ("|dom|_" [72] 72) where
  "ZFfunDom f \<equiv> Fst (Fst f)"

definition
  ZFfunCod :: "ZF \<Rightarrow> ZF" ("|cod|_" [72] 72) where
  "ZFfunCod f \<equiv> Snd (Fst f)"

definition
  ZFfunApp :: "ZF \<Rightarrow> ZF \<Rightarrow> ZF" (infixl "|@|" 73) where
  "ZFfunApp f x \<equiv> app (Snd f) x"

definition
  ZFfunComp :: "ZF \<Rightarrow> ZF \<Rightarrow> ZF" (infixl "|o|" 72) where
  "ZFfunComp f g \<equiv> ZFfun ( |dom| f) ( |cod| g) (\<lambda>x. g |@| (f |@| x))"

definition
  isZFfun :: "ZF \<Rightarrow> bool" where
  "isZFfun drf \<equiv> let f = Snd drf in
                 isOpair drf \<and> isOpair (Fst drf) \<and> isFun f \<and> (f |\<subseteq>| (Domain f) |\<times>| (Range f))
                 \<and> (Domain f = |dom| drf) \<and> (Range f |\<subseteq>| |cod| drf)"

lemma isZFfunE[elim]: "\<lbrakk>isZFfun f ;
  \<lbrakk>isOpair f ; isOpair (Fst f) ; isFun (Snd f) ;
  ((Snd f) |\<subseteq>| (Domain (Snd f)) |\<times>| (Range (Snd f))) ;
  (Domain (Snd f) = |dom| f) \<and> (Range (Snd f) |\<subseteq>| |cod| f)\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  by (auto simp add: isZFfun_def Let_def)

definition
  SET' :: "(ZF, ZF) Category" where
  "SET' \<equiv> \<lparr>
      Category.Obj = {x . True} ,
      Category.Mor = {f . isZFfun f} ,
      Category.Dom = ZFfunDom ,
      Category.Cod = ZFfunCod ,
      Category.Id = \<lambda>x. ZFfun x x (\<lambda>x . x) ,
      Category.Comp = ZFfunComp
  \<rparr>"

definition "SET \<equiv> MakeCat SET'"

lemma ZFfunDom: "|dom| (ZFfun A B f) = A"
by (auto simp add: ZFfun_def ZFfunDom_def Fst)

lemma ZFfunCod: "|cod| (ZFfun A B f) = B"
by (auto simp add: ZFfun_def ZFfunCod_def Snd Fst)

lemma SETfun:
  assumes "\<forall> x . x |\<in>| A \<longrightarrow> (f x) |\<in>| B"
  shows   "isZFfun (ZFfun A B f)"
proof(auto simp add: isZFfun_def ZFfun_def isOpair Fst Snd
    ZFfunCod_def ZFfunDom_def isFun_Lambda domain_Lambda Let_def)
  {
    fix x
    have "x |\<in>| Range (Lambda A f) \<Longrightarrow> x |\<in>| B"
      apply(insert isFun_Lambda[of A f])
      apply (drule fun_range_witness[of "Lambda A f" x], simp)
      by (auto simp add: domain_Lambda Lambda_app assms)
  }
  thus "subset (Range (Lambda A f)) B"
    by (auto simp add: subset_def)
  {
    fix x
    have "x |\<in>| (Lambda A f) \<Longrightarrow> x |\<in>| A |\<times>| Range (Lambda A f)"
      by(auto simp add: CartProd Lambda_def Repl Range)
  }
  thus "(Lambda A f) |\<subseteq>| (A |\<times>| Range (Lambda A f))"
    by (auto simp add: HOLZF.subset_def)
qed

lemma ZFCartProd:
  assumes "x |\<in>| A |\<times>| B"
  shows   "Fst x |\<in>| A \<and> Snd x |\<in>| B \<and> isOpair x"
proof-
  from CartProd obtain a b
    where "a |\<in>| A"
    and   "b |\<in>| B"
    and   "x = Opair a b" using assms by auto
  thus ?thesis using assms by (auto simp add: Fst Snd isOpair_def)
qed

lemma ZFfunDomainOpair:
  assumes "isFun f"
  and     "x |\<in>| Domain f"
  shows   "Opair x (app f x) |\<in>| f"
proof-
  have "\<exists>! y . Opair x y |\<in>| f" using assms by (auto simp add: unique_fun_value)
  thus "Opair x (app f x) |\<in>| f" by (auto simp add: app_def intro: theI')
qed

lemma ZFFunToLambda:
  assumes 1: "isFun f"
  and     2: "f |\<subseteq>| (Domain f) |\<times>| (Range f)"
  shows   "f = Lambda (Domain f) (\<lambda>x. app f x)"
proof(subst Ext, rule allI, rule iffI)
  {
    fix x assume a: "x |\<in>| f" show "x |\<in>| Lambda (Domain f) (\<lambda>x. app f x)"
    proof(simp add: Lambda_def Repl, rule exI[of _ "(Fst x)"], rule conjI)
      have b:"isOpair x \<and> Fst x |\<in>| Domain f" using 2 a by (auto simp add: subset_def ZFCartProd)
      thus "Fst x |\<in>| Domain f" ..
      hence "Opair (Fst x) (app f (Fst x)) |\<in>| f" using 1 by (simp add: ZFfunDomainOpair)
      moreover have "Opair (Fst x) (Snd x) |\<in>| f" using a 2 by (auto simp add: FstSnd subset_def b)
      ultimately have "Snd x = (app f (Fst x))" using 1 by (auto simp add: isFun_def)
      hence "Opair (Fst x) (app f (Fst x)) = Opair (Fst x) (Snd x)" by simp
      also have "... = x"  using b by (simp add: FstSnd)
      finally show "x = Opair (Fst x) (app f (Fst x))" ..
    qed
  }
  moreover
  {
    fix x assume a: "x |\<in>| Lambda (Domain f) (\<lambda>x. app f x)" show "x |\<in>| f"
      proof-
        from Lambda_def obtain a where "a |\<in>| Domain f \<and> x = Opair a (app f a)"
          using a by (auto simp add: Repl)
        thus ?thesis using a 1 by (auto simp add: ZFfunDomainOpair)
      qed
  }
qed

lemma ZFfunApp:
  assumes "x |\<in>| A"
  shows   "(ZFfun A B f) |@| x = f x"
proof-
  have "(ZFfun A B f) |@| x = app (Lambda A f) x" by (simp add: ZFfun_def ZFfunApp_def Snd)
  also have "... = f x" using assms by (simp add: Lambda_app)
  finally show ?thesis .
qed

lemma ZFfun:
  assumes "isZFfun f"
  shows   "f = ZFfun ( |dom| f) ( |cod| f) (\<lambda>x. f |@| x)"
proof(auto simp add: ZFfun_def)
  have "isOpair f \<and> isOpair (Fst f)" using assms by (simp add: isZFfun_def[of f] Let_def)
  hence "f = Opair (Opair (Fst (Fst f)) (Snd (Fst f))) (Snd f)" by (simp add: FstSnd)
  hence "f = Opair (Opair ( |dom| f) ( |cod| f)) (Snd f)" using assms by (simp add: ZFfunDom_def ZFfunCod_def)
  moreover have "Snd f = Lambda ( |dom| f) (\<lambda>x . f |@| x)"
  proof-
    have "|dom| f = Domain (Snd f)" using assms by (simp add: isZFfun_def[of f] Let_def)
    moreover have "isFun (Snd f)" using assms by (simp add: isZFfun_def[of f] Let_def)
    moreover have "(\<lambda>x . f |@| x) = (\<lambda>x . app (Snd f) x)"  by(simp add: ZFfunApp_def)
    moreover have "(Snd f) |\<subseteq>| (Domain (Snd f)) |\<times>| (Range (Snd f))" using assms
      by (auto simp add: isZFfun_def[of f] Let_def)
    ultimately show ?thesis apply simp by(rule ZFFunToLambda[of "Snd f"])
  qed
  ultimately show "f = Opair (Opair ( |dom| f) ( |cod| f)) (Lambda ( |dom| f) (\<lambda>x . f |@| x))" by simp
qed

lemma ZFfun_ext:
  assumes "\<forall> x . x |\<in>| A \<longrightarrow> f x = g x"
  shows   "(ZFfun A B f) = (ZFfun A B g)"
proof-
  have "Lambda A f = Lambda A g" using assms by (auto simp add: Lambda_ext)
  thus ?thesis by (simp add: ZFfun_def)
qed

lemma ZFfunExt:
  assumes "|dom| f = |dom| g" and "|cod| f = |cod| g" and funf: "isZFfun f" and fung: "isZFfun g"
  and "\<And> x . x |\<in>| ( |dom| f) \<Longrightarrow> f |@| x = g |@| x"
  shows "f = g"
proof-
  have 1: "f = ZFfun ( |dom| f) ( |cod| f) (\<lambda>x. f |@| x)" using funf by (rule ZFfun)
  have "g = ZFfun ( |dom| g) ( |cod| g) (\<lambda>x. g |@| x)" using fung by (rule ZFfun)
  hence 2: "g = ZFfun ( |dom| f) ( |cod| f) (\<lambda>x. g |@| x)" using assms by simp
  have "ZFfun ( |dom| f) ( |cod| f) (\<lambda>x. f |@| x) = ZFfun ( |dom| f) ( |cod| f) (\<lambda>x. g |@| x)"
    using assms by (simp add: ZFfun_ext)
  thus ?thesis using 1 2 by simp
qed

lemma ZFfunDomAppCod:
  assumes "isZFfun f"
  and     "x |\<in>| |dom|f"
  shows   "f |@| x |\<in>| |cod|f"
proof(simp add: ZFfunApp_def)
  have "app (Snd f) x |\<in>| Range (Snd f)" using assms by (auto simp add: fun_value_in_range )
  thus "app (Snd f) x |\<in>| |cod|f" using assms by (auto simp add: HOLZF.subset_def)
qed

lemma ZFfunComp:
  assumes "\<forall> x . x |\<in>| A \<longrightarrow> f x |\<in>| B"
  shows   "(ZFfun A B f) |o| (ZFfun B C g) = ZFfun A C (g o f)"
proof (simp add: ZFfunComp_def ZFfunDom ZFfunCod)
  {
    fix x assume a: "x |\<in>| A"
    have "ZFfun B C g  |@| (ZFfun A B f |@| x) = (g o f) x"
      proof-
        have "(ZFfun A B f |@| x) = f x" using a by (simp add: ZFfunApp)
        hence "ZFfun B C g  |@| (ZFfun A B f |@| x) = g (f x)" using assms a by (simp add: ZFfunApp)
        thus ?thesis by simp
      qed
  }
  thus "ZFfun A C (\<lambda>x. ZFfun B C g |@| (ZFfun A B f |@| x)) = ZFfun A C (g \<circ> f)"
    by (simp add: ZFfun_ext)
qed

lemma ZFfunCompApp:
  assumes a:"isZFfun f" and b:"isZFfun g" and c:"|dom|g = |cod|f"
  shows "f |o| g = ZFfun ( |dom| f) ( |cod| g) (\<lambda> x . g |@| (f |@| x))"
proof-
  have 1: "f = ZFfun ( |dom| f) ( |cod| f) (\<lambda> x . f |@| x)" using a by (rule ZFfun)
  have 2: "g = ZFfun ( |dom| g) ( |cod| g) (\<lambda> x . g |@| x)" using b by (rule ZFfun)
  have 3: "\<forall> x . x |\<in>| |dom|f \<longrightarrow> (\<lambda>x. f |@| x) x |\<in>| |cod|f" using a by (simp add: ZFfunDomAppCod)
  hence 4: "\<forall> x . x |\<in>| |dom|f \<longrightarrow> (\<lambda>x. g |@| (f |@| x)) x |\<in>| |cod|g"
    using a b c by (simp add: ZFfunDomAppCod)
  have "f |o| g = ZFfun ( |dom| f) ( |cod| f) (\<lambda> x . f |@| x) |o|
    ZFfun ( |cod| f) ( |cod| g) (\<lambda> x . g |@| x)" using 1 2 c by simp
  hence "f |o| g = ZFfun ( |dom| f) ( |cod| g) (\<lambda> x . g |@| (f |@| x))"
    using 3 by (simp add: ZFfunComp comp_def)
  thus ?thesis using 4 by (simp add: SETfun)
qed

lemma ZFfunCompAppZFfun:
  assumes "isZFfun f" and "isZFfun g" and "|dom|g = |cod|f"
  shows   "isZFfun (f |o| g)"
proof-
  have "f |o| g = ZFfun ( |dom| f) ( |cod| g) (\<lambda> x . g |@| (f |@| x))" using assms
    by (simp add: ZFfunCompApp)
  moreover have "\<forall> x . x |\<in>| |dom|f \<longrightarrow> ((\<lambda> x . g |@| (f |@| x)) x) |\<in>| |cod|g" using assms
    by (simp add: ZFfunDomAppCod)
  ultimately show ?thesis by (simp add: SETfun)
qed

lemma ZFfunCompAssoc:
  assumes a: "isZFfun f" and b:"isZFfun h" and c:"|cod|g = |dom|h"
  and d:"isZFfun g" and e:"|cod|f = |dom|g"
  shows "f |o| g |o| h = f |o| (g |o| h)"
proof-
  have 1: "f = ZFfun ( |dom| f) ( |cod| f) (\<lambda> x . f |@| x)" using a by (rule ZFfun)
  have 2: "g = ZFfun ( |dom| g) ( |cod| g) (\<lambda> x . g |@| x)" using d by (rule ZFfun)
  have 3: "h = ZFfun ( |dom| h) ( |cod| h) (\<lambda> x . h |@| x)" using b by (rule ZFfun)
  have 4: "\<forall> x . x |\<in>| |dom|f \<longrightarrow> (\<lambda>x. f |@| x) x |\<in>| |cod|f" using a by (simp add: ZFfunDomAppCod)
  have "(f |o| g) |o| h = ZFfun ( |dom| f) ( |cod| h) (\<lambda> x . h |@| (g |@| (f |@| x)))"
  proof-
    have 5: "\<forall> x . x |\<in>| |dom|f \<longrightarrow> (\<lambda>x. g |@| (f |@| x)) x |\<in>| |cod|g"
      using 4 e d by (simp add: ZFfunDomAppCod)
    have "(f |o| g) |o| h = (ZFfun ( |dom| f) ( |cod| f) (\<lambda> x . f |@| x) |o|
      ZFfun ( |cod| f) ( |cod| g) (\<lambda> x . g |@| x)) |o|
      ZFfun ( |cod| g) ( |cod| h) (\<lambda> x . h |@| x)"
      using 1 2 3 c e by (simp)
    thus ?thesis using 4 5 by (simp add: ZFfunComp comp_def)
  qed
  moreover have "f |o| (g |o| h) = ZFfun ( |dom| f) ( |cod| h) (\<lambda> x . h |@| (g |@| (f |@| x)))"
  proof-
    have 5: "\<forall> x . x |\<in>| |dom|g \<longrightarrow> (\<lambda>x. g |@| x) x |\<in>| |cod|g" using d by (simp add: ZFfunDomAppCod)
    have "f |o| (g |o| h) = ZFfun ( |dom| f) ( |dom| g) (\<lambda> x . f |@| x) |o|
      (ZFfun ( |dom| g) ( |cod| g) (\<lambda> x . g |@| x) |o|
      ZFfun ( |cod| g) ( |cod| h) (\<lambda> x . h |@| x))"
      using 1 2 3 c e by (simp)
    thus ?thesis using 4 e 5 by (simp add: ZFfunComp comp_def)
  qed
  ultimately show ?thesis by simp
qed

lemma ZFfunCompAppDomCod:
  assumes "isZFfun f" and "isZFfun g" and "|dom|g = |cod|f"
  shows   "|dom| (f |o| g) = |dom| f \<and> |cod| (f |o| g) = |cod| g"
proof-
  have "f |o| g = ZFfun ( |dom| f) ( |cod| g) (\<lambda> x . g |@| (f |@| x))" using assms
    by (simp add: ZFfunCompApp)
  thus ?thesis by (simp add: ZFfunDom ZFfunCod)
qed

lemma ZFfunIdLeft:
  assumes a: "isZFfun f" shows "(ZFfun ( |dom|f) ( |dom|f) (\<lambda>x. x)) |o| f = f"
proof-
  let ?g = "(ZFfun ( |dom|f) ( |dom|f) (\<lambda>x. x))"
  have "ZFfun ( |dom| f) ( |cod| f) (\<lambda> x . f |@| x) = ?g |o| f" using a
    by (simp add: ZFfun_ext ZFfunApp ZFfunCompApp SETfun ZFfunCod ZFfunDom)
  moreover have "f = ZFfun ( |dom| f) ( |cod| f) (\<lambda> x . f |@| x)" using a by (rule ZFfun)
  ultimately show ?thesis by simp
qed

lemma ZFfunIdRight:
  assumes a: "isZFfun f" shows "f |o| (ZFfun ( |cod|f) ( |cod|f) (\<lambda>x. x)) = f"
proof-
  let ?g = "(ZFfun ( |cod|f) ( |cod|f) (\<lambda>x. x))"
  have 1: "\<forall> x . x |\<in>| |dom|f \<longrightarrow> (\<lambda>x. f |@| x) x |\<in>| |cod|f" using a by (simp add: ZFfunDomAppCod)
  have "ZFfun ( |dom| f) ( |cod| f) (\<lambda> x . f |@| x) = f |o| ?g" using a 1
    by (simp add: ZFfun_ext ZFfunApp ZFfunCompApp SETfun ZFfunCod ZFfunDom)
  moreover have "f = ZFfun ( |dom| f) ( |cod| f) (\<lambda> x . f |@| x)" using a by (rule ZFfun)
  ultimately show ?thesis by simp
qed

lemma SETCategory: "Category(SET)"
proof-
  have "Category_axioms SET'"
    by (auto simp add: Category_axioms_def SET'_def ZFfunCompAppDomCod
      ZFfunCompAppZFfun ZFfunCompAssoc ZFfunIdLeft ZFfunIdRight ZFfunDom ZFfunCod SETfun MapsTo_def CompDefined_def)
  thus ?thesis by (auto simp add: SET_def MakeCat)
qed

lemma SETobj: "X \<in> Obj (SET)"
by (simp add: SET_def SET'_def MakeCat_def)

lemma SETcod: "isZFfun (ZFfun A B f) \<Longrightarrow> cod\<^bsub>SET\<^esub> ZFfun A B f = B"
by(simp add: SET_def MakeCat_def SET'_def ZFfunCod)

lemma SETmor: "(isZFfun f) = (f \<in> mor\<^bsub>SET\<^esub>)"
by(simp add: SET_def MakeCat_def SET'_def)

lemma SETdom: "isZFfun (ZFfun A B f) \<Longrightarrow> dom\<^bsub>SET\<^esub> ZFfun A B f = A"
by(simp add: SET_def MakeCat_def SET'_def ZFfunDom)

lemma SETId: assumes "x |\<in>| X" shows "(Id SET X) |@| x = x"
proof-
  have "X \<in> Obj SET" by (simp add: SET_def SET'_def MakeCat_def)
  hence "isZFfun(Id SET X)" by (simp add: SETCategory Category.CatIdInMor SETmor)
  moreover have "(Id SET X) = ZFfun X X (\<lambda>x. x)" using assms by (simp add: SET_def SET'_def MakeCat_def)
  ultimately show ?thesis using assms by (simp add: ZFfunApp)
qed

lemma SETCompE[elim]: "\<lbrakk>f \<approx>>\<^bsub>SET\<^esub> g ; \<lbrakk>isZFfun f ; isZFfun g ; |cod| f = |dom| g\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
by (auto simp add: SET_def SET'_def MakeCat_def)

lemma SETmapsTo: "f maps\<^bsub>SET\<^esub> X to Y \<Longrightarrow> isZFfun f \<and> |dom| f = X \<and> |cod| f = Y"
by(auto simp add: MapsTo_def SET_def SET'_def MakeCat_def)

lemma SETComp: assumes "f \<approx>>\<^bsub>SET\<^esub> g" shows "f ;;\<^bsub>SET\<^esub> g = f |o| g"
proof-
  have a: "f \<approx>>\<^bsub>MakeCat SET'\<^esub> g" using assms by (simp add: SET_def)
  have "f ;;\<^bsub>SET\<^esub> g = f ;;\<^bsub>MakeCat SET'\<^esub> g" by (simp add: SET_def)
  also have "... = f ;;\<^bsub>SET'\<^esub> g" using a  by (simp  add: MakeCatComp2)
  finally show ?thesis by (simp add: SET'_def)
qed

lemma SETCompAt:
  assumes "f \<approx>>\<^bsub>SET \<^esub>g" and "x |\<in>|  |dom| f" shows "(f ;;\<^bsub>SET \<^esub>g) |@| x = g |@| (f |@| x)"
proof-
  have "f ;;\<^bsub>SET\<^esub> g = f |o| g" using assms by (simp add: SETComp)
  also have "... = ZFfun ( |dom| f) ( |cod| g) (\<lambda> x . g |@| (f |@| x))" using assms by (auto simp add: ZFfunCompApp)
  finally show ?thesis using assms by (simp add: ZFfunApp)
qed

lemma SETZFfun:
  assumes "f maps\<^bsub>SET\<^esub> X to Y" shows "f = ZFfun X Y (\<lambda>x . f |@| x)"
proof-
  have "isZFfun f"  using assms by (auto simp add: SETmor)
  hence "f = ZFfun ( |dom| f) ( |cod| f) (\<lambda>x. f |@| x)" by (simp add: ZFfun)
  moreover have "|dom| f = X" and "|cod| f = Y" using assms by (auto simp add: SET_def SET'_def MakeCat_def)
  ultimately show ?thesis by (simp)
qed

lemma SETfunDomAppCod:
  assumes "f maps\<^bsub>SET \<^esub>X to Y" and "x |\<in>| X"
  shows "f |@| x |\<in>| Y"
proof-
  have 1: "isZFfun f" and "|dom| f = X" and 2: "|cod| f = Y" using assms by (auto simp add: SETmapsTo)
  hence "x |\<in>| |dom| f" using assms by simp
  hence "f |@| x |\<in>| |cod| f" using 1 by (simp add: ZFfunDomAppCod)
  thus ?thesis using 2 by simp
qed

(*Locally Small Category has an injective map from the morphisms to ZF*)
record ('o,'m) LSCategory = "('o,'m) Category" +
  mor2ZF :: "'m \<Rightarrow> ZF" ("m2z\<index>_" [70] 70)

definition
  ZF2mor ("z2m\<index>_" [70] 70) where
  "ZF2mor C f \<equiv> THE m . m \<in> mor\<^bsub>C\<^esub> \<and> m2z\<^bsub>C\<^esub> m = f"

definition
  "HOMCollection C X Y \<equiv> {m2z\<^bsub>C\<^esub> f | f . f maps\<^bsub>C\<^esub> X to Y}"

definition
  HomSet ("Hom\<index> _ _" [65, 65] 65)  where
  "HomSet C X Y \<equiv> implode (HOMCollection C X Y)"

locale LSCategory = Category +
  assumes mor2ZFInj: "\<lbrakk>x \<in> mor ; y \<in> mor ; m2z x = m2z y\<rbrakk> \<Longrightarrow> x = y"
  and HOMSetIsSet: "\<lbrakk>X \<in> obj ; Y \<in> obj\<rbrakk> \<Longrightarrow> HOMCollection C X Y \<in> range explode"
  and m2zExt: "mor2ZF C \<in> extensional (Mor C)"

lemma [elim]: "\<lbrakk>LSCategory C ;
  \<lbrakk>Category C ; \<lbrakk>x \<in> mor\<^bsub>C\<^esub> ; y \<in> mor\<^bsub>C\<^esub> ; m2z\<^bsub>C\<^esub> x = m2z\<^bsub>C\<^esub> y\<rbrakk> \<Longrightarrow>  x = y;
  \<lbrakk>X \<in> obj\<^bsub>C\<^esub> ; Y \<in> obj\<^bsub>C\<^esub>\<rbrakk> \<Longrightarrow> HOMCollection C X Y \<in> range explode\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
by(simp add: LSCategory_def LSCategory_axioms_def)

definition
  HomFtorMap :: "('o,'m,'a) LSCategory_scheme \<Rightarrow> 'o \<Rightarrow> 'm \<Rightarrow> ZF" ("Hom\<index>[_,_]" [65,65] 65) where
  "HomFtorMap C X g \<equiv> ZFfun (Hom\<^bsub>C\<^esub> X (dom\<^bsub>C\<^esub> g)) (Hom\<^bsub>C\<^esub> X (cod\<^bsub>C\<^esub> g)) (\<lambda> f . m2z\<^bsub>C\<^esub> ((z2m\<^bsub>C\<^esub> f) ;;\<^bsub>C\<^esub> g))"

definition
  HomFtor' :: "('o,'m,'a) LSCategory_scheme \<Rightarrow> 'o \<Rightarrow>
      ('o,ZF,'m,ZF,\<lparr>mor2ZF :: 'm \<Rightarrow> ZF, \<dots> :: 'a\<rparr>,unit) Functor" ("HomP\<index>[_,\<emdash>]" [65] 65) where
  "HomFtor' C X \<equiv> \<lparr>
        CatDom = C,
        CatCod = SET ,
        MapM   = \<lambda> g . Hom\<^bsub>C\<^esub>[X,g]
  \<rparr>"

definition HomFtor ("Hom\<index>[_,\<emdash>]" [65] 65) where "HomFtor C X \<equiv> MakeFtor (HomFtor' C X)"

lemma (in LSCategory) m2zz2m:
  assumes "f maps X to Y" shows "(m2z f) |\<in>| (Hom X Y)"
proof-
  have "X \<in> Obj C" and "Y \<in> Obj C" using assms by (simp add: MapsToObj)+
  hence "HOMCollection C X Y \<in> range explode" using assms by (simp add: HOMSetIsSet)
  moreover have "(m2z f) \<in> HOMCollection C X Y" using assms by (auto simp add: HOMCollection_def)
  ultimately have "(m2z f) |\<in>| implode (HOMCollection C X Y)" by (simp add: Elem_implode)
  thus ?thesis by (simp add: HomSet_def)
qed

lemma (in LSCategory) m2zz2mInv:
  assumes "f \<in> mor"
  shows "z2m (m2z f) = f"
proof-
  have 1: "f \<in> mor \<and> m2z f = m2z f" using assms by simp
  moreover have "\<exists>! m . m \<in> mor \<and> m2z m = (m2z f)"
  proof(rule ex_ex1I)
    show "\<exists> m . m \<in> mor \<and> m2z m = (m2z f)"
      by(rule exI[of _ f], insert 1, simp)
    {
      fix m y assume "m \<in> mor \<and> m2z m = (m2z f)" and "y \<in> mor \<and> m2z y = (m2z f)"
      thus "m = y" by(simp add: mor2ZFInj)
    }
  qed
  ultimately show ?thesis by(simp add: ZF2mor_def the1_equality)
qed

lemma (in LSCategory) z2mm2z:
  assumes "X \<in> obj" and "Y \<in> obj" and "f |\<in>| (Hom X Y)"
  shows "z2m f maps X to Y \<and> m2z (z2m f) = f"
proof-
  have 1: "\<exists> m . m maps X to Y \<and> m2z m = f"
  proof-
    have "HOMCollection C X Y \<in> range explode" using assms by (simp add: HOMSetIsSet)
    moreover have "f |\<in>| implode (HOMCollection C X Y)" using assms(3) by (simp add: HomSet_def)
    ultimately have "f \<in> HOMCollection C X Y" by (simp add: HOLZF.Elem_implode)
    thus ?thesis by (auto simp add: HOMCollection_def)
  qed
  have 2: "\<exists>! m . m \<in> mor \<and> m2z m = f"
  proof(rule ex_ex1I)
    show "\<exists> m . m \<in> mor \<and> m2z m = f"
    proof-
      from 1 obtain m where "m \<in> mor \<and> m2z m = f" by auto
      thus ?thesis by auto
    qed
    {
      fix m y assume "m \<in> mor \<and> m2z m = f" and "y \<in> mor \<and> m2z y = f"
      thus "m = y" by(simp add: mor2ZFInj)
    }
  qed
  thus ?thesis
  proof-
    from 1 obtain a where 3: "a maps X to Y \<and> m2z a = f" by auto
    have 4: "a \<in> mor" using 3 by auto
    have "z2m f = a"
      apply (auto simp add: 3 ZF2mor_def[of _ f])
      apply (rule the1_equality[of "\<lambda> m . m \<in> mor \<and> m2z m = f" a])
      apply (auto simp add: 2 3 4)
      done
    thus ?thesis by (simp add: 3)
  qed
qed

lemma  HomFtorMapLemma1:
  assumes a: "LSCategory C" and b: "X \<in> obj\<^bsub>C\<^esub>" and c: "f \<in> mor\<^bsub>C\<^esub>" and d: "x |\<in>| (Hom\<^bsub>C\<^esub> X (dom\<^bsub>C\<^esub> f))"
  shows "(m2z\<^bsub>C \<^esub>((z2m\<^bsub>C \<^esub>x) ;;\<^bsub>C\<^esub> f)) |\<in>| (Hom\<^bsub>C\<^esub> X (cod\<^bsub>C\<^esub> f))"
proof-
  have 1: "dom\<^bsub>C\<^esub> f \<in> obj\<^bsub>C\<^esub>" and 2: "cod\<^bsub>C\<^esub> f \<in> obj\<^bsub>C\<^esub>" using a c by (simp add: Category.Simps)+
  have "z2m\<^bsub>C\<^esub> x maps\<^bsub>C\<^esub> X to (dom\<^bsub>C\<^esub> f)"  using a b d 1 by (auto simp add: LSCategory.z2mm2z)
  hence "(z2m\<^bsub>C\<^esub> x) ;;\<^bsub>C\<^esub> f maps\<^bsub>C\<^esub> X to (cod\<^bsub>C\<^esub> f)" using a c by (auto intro: Category.Ccompt)
  hence "(m2z\<^bsub>C\<^esub> ((z2m\<^bsub>C\<^esub> x) ;;\<^bsub>C\<^esub> f)) |\<in>| (Hom\<^bsub>C\<^esub> X (cod\<^bsub>C\<^esub> f))" using a b d 2
    by (auto simp add: LSCategory.m2zz2m)
  thus ?thesis using c by (simp add: Category.Simps)
qed

lemma HomFtorInMor':
  assumes "LSCategory C" and "X \<in> obj\<^bsub>C\<^esub>" and "f \<in> mor\<^bsub>C\<^esub>"
  shows "Hom\<^bsub>C\<^esub>[X,f] \<in> mor\<^bsub>SET'\<^esub>"
proof(simp add: HomFtorMap_def)
  {
    fix x assume "x |\<in>| (Hom\<^bsub>C\<^esub> X dom\<^bsub>C\<^esub> f)"
    hence "m2z\<^bsub>C \<^esub>((z2m\<^bsub>C \<^esub>x) ;;\<^bsub>C\<^esub> f) |\<in>| (Hom\<^bsub>C\<^esub> X cod\<^bsub>C\<^esub> f)" using assms by (blast intro: HomFtorMapLemma1)
  }
  hence "\<forall> x . x |\<in>| (Hom\<^bsub>C\<^esub> X dom\<^bsub>C\<^esub> f) \<longrightarrow> (m2z\<^bsub>C \<^esub>((z2m\<^bsub>C \<^esub>x) ;;\<^bsub>C\<^esub> f)) |\<in>| (Hom\<^bsub>C\<^esub> X cod\<^bsub>C\<^esub> f)" by (simp)
  hence "isZFfun (ZFfun (Hom\<^bsub>C\<^esub> X dom\<^bsub>C\<^esub> f) (Hom\<^bsub>C\<^esub> X cod\<^bsub>C\<^esub> f) (\<lambda> x . m2z\<^bsub>C \<^esub>((z2m\<^bsub>C \<^esub>x) ;;\<^bsub>C\<^esub> f)))"
    by (simp add: SETfun)
  thus "ZFfun (Hom\<^bsub>C\<^esub> X dom\<^bsub>C\<^esub> f) (Hom\<^bsub>C\<^esub> X cod\<^bsub>C\<^esub> f) (\<lambda> x . m2z\<^bsub>C \<^esub>((z2m\<^bsub>C \<^esub>x) ;;\<^bsub>C\<^esub> f)) \<in> mor\<^bsub>SET'\<^esub>"
    by (simp add: SET'_def)
qed

lemma HomFtorMor':
  assumes "LSCategory C" and "X \<in> obj\<^bsub>C\<^esub>" and "f \<in> mor\<^bsub>C\<^esub>"
  shows   "Hom\<^bsub>C\<^esub>[X,f] maps\<^bsub>SET'\<^esub> Hom\<^bsub>C \<^esub>X (dom\<^bsub>C\<^esub> f) to Hom\<^bsub>C \<^esub>X (cod\<^bsub>C\<^esub> f)"
proof-
  have "Hom\<^bsub>C\<^esub>[X,f] \<in> mor\<^bsub>SET'\<^esub>" using assms by (simp add: HomFtorInMor')
  moreover have "dom\<^bsub>SET'\<^esub> (Hom\<^bsub>C\<^esub>[X,f]) = Hom\<^bsub>C \<^esub>X (dom\<^bsub>C\<^esub> f)"
    by(simp add: HomFtorMap_def SET'_def ZFfunDom)
  moreover have "cod\<^bsub>SET'\<^esub> (Hom\<^bsub>C\<^esub>[X,f]) = Hom\<^bsub>C \<^esub>X (cod\<^bsub>C\<^esub> f)"
    by(simp add: HomFtorMap_def SET'_def ZFfunCod)
  ultimately show ?thesis by (auto simp add: SET_def)
qed

lemma HomFtorMor:
  assumes "LSCategory C" and "X \<in> obj\<^bsub>C\<^esub>" and "f \<in> mor\<^bsub>C\<^esub>"
  shows "Hom\<^bsub>C\<^esub>[X,f] \<in> Mor SET" and "dom\<^bsub>SET\<^esub> (Hom\<^bsub>C\<^esub>[X,f]) = Hom\<^bsub>C \<^esub>X (dom\<^bsub>C\<^esub> f)"
  and "cod\<^bsub>SET\<^esub> (Hom\<^bsub>C\<^esub>[X,f]) = Hom\<^bsub>C \<^esub>X (cod\<^bsub>C\<^esub> f)"
proof-
  have "Hom\<^bsub>C\<^esub>[X,f] maps\<^bsub>SET\<^esub> Hom\<^bsub>C \<^esub>X (dom\<^bsub>C\<^esub> f) to Hom\<^bsub>C \<^esub>X (cod\<^bsub>C\<^esub> f)" using assms by (simp add: HomFtorMapsTo)
  thus "Hom\<^bsub>C\<^esub>[X,f] \<in> Mor SET" and "dom\<^bsub>SET\<^esub> (Hom\<^bsub>C\<^esub>[X,f]) = Hom\<^bsub>C \<^esub>X (dom\<^bsub>C\<^esub> f)" and "cod\<^bsub>SET\<^esub> (Hom\<^bsub>C\<^esub>[X,f]) = Hom\<^bsub>C \<^esub>X (cod\<^bsub>C\<^esub> f)"
    by auto
qed

lemma HomFtorCompDef':
  assumes "LSCategory C" and "X \<in> obj\<^bsub>C\<^esub>" and "f \<approx>>\<^bsub>C\<^esub> g"
  shows   "(Hom\<^bsub>C\<^esub>[X,f]) \<approx>>\<^bsub>SET' \<^esub>(Hom\<^bsub>C\<^esub>[X,g])"
proof(rule CompDefinedI)
  have a: "f \<in> mor\<^bsub>C\<^esub>" and b: "g \<in> mor\<^bsub>C\<^esub>" using assms(3) by auto
  thus "Hom\<^bsub>C\<^esub>[X,f] \<in> mor\<^bsub>SET'\<^esub>" and "Hom\<^bsub>C\<^esub>[X,g] \<in> mor\<^bsub>SET'\<^esub>" using assms by (simp add:HomFtorInMor')+
  have "(Hom\<^bsub>C\<^esub>[X,f]) maps\<^bsub>SET'\<^esub> Hom\<^bsub>C\<^esub> X dom\<^bsub>C\<^esub> f to Hom\<^bsub>C\<^esub> X cod\<^bsub>C\<^esub> f"
    and "(Hom\<^bsub>C\<^esub>[X,g]) maps\<^bsub>SET'\<^esub> Hom\<^bsub>C\<^esub> X dom\<^bsub>C\<^esub> g to Hom\<^bsub>C\<^esub> X cod\<^bsub>C\<^esub> g" using assms a b by (simp add: HomFtorMor')+
  hence "cod\<^bsub>SET'\<^esub> (Hom\<^bsub>C\<^esub>[X,f]) = Hom\<^bsub>C\<^esub> X (cod\<^bsub>C\<^esub> f)"
    and "dom\<^bsub>SET'\<^esub> (Hom\<^bsub>C\<^esub>[X,g]) = Hom\<^bsub>C\<^esub> X (dom\<^bsub>C\<^esub> g)" by auto
  moreover have "(cod\<^bsub>C\<^esub> f) = (dom\<^bsub>C\<^esub> g)" using assms(3) by auto
  ultimately show "cod\<^bsub>SET'\<^esub> (Hom\<^bsub>C\<^esub>[X,f]) = dom\<^bsub>SET'\<^esub> (Hom\<^bsub>C\<^esub>[X,g])" by simp
qed

lemma HomFtorDist':
  assumes a: "LSCategory C" and b: "X \<in> obj\<^bsub>C\<^esub>" and c: "f \<approx>>\<^bsub>C\<^esub> g"
  shows   "(Hom\<^bsub>C\<^esub>[X,f]) ;;\<^bsub>SET'\<^esub> (Hom\<^bsub>C\<^esub>[X,g]) = Hom\<^bsub>C\<^esub>[X,f ;;\<^bsub>C\<^esub> g]"
proof-
  let ?A = "(Hom\<^bsub>C\<^esub> X dom\<^bsub>C\<^esub> f)"
  let ?B = "(Hom\<^bsub>C\<^esub> X dom\<^bsub>C\<^esub> g)"
  let ?C = "(Hom\<^bsub>C\<^esub> X cod\<^bsub>C\<^esub> g)"
  let ?f = "(\<lambda>h. m2z\<^bsub>C \<^esub>((z2m\<^bsub>C \<^esub>h) ;;\<^bsub>C\<^esub> f))"
  let ?g = "(\<lambda>f. m2z\<^bsub>C \<^esub>((z2m\<^bsub>C \<^esub>f) ;;\<^bsub>C\<^esub> g))"
  have 1: "cod\<^bsub>C\<^esub> f = dom\<^bsub>C\<^esub> g" using c by auto
  have 2: "dom\<^bsub>C\<^esub> (f ;;\<^bsub>C\<^esub> g) = dom\<^bsub>C\<^esub> f" and 3: "cod\<^bsub>C\<^esub> (f ;;\<^bsub>C\<^esub> g) = cod\<^bsub>C\<^esub> g" using assms
    by (auto simp add: Category.MapsToMorDomCod)
  have "(Hom\<^bsub>C\<^esub>[X,f]) ;;\<^bsub>SET'\<^esub> (Hom\<^bsub>C\<^esub>[X,g]) = (ZFfun ?A (Hom\<^bsub>C\<^esub> X cod\<^bsub>C\<^esub> f) ?f) |o| (ZFfun ?B ?C ?g)"
    by (simp add: HomFtorMap_def SET'_def)
  also have "... = (ZFfun ?A ?B ?f) |o| (ZFfun ?B ?C ?g)" using 1 by simp
  also have "... = ZFfun ?A ?C (?g o ?f)"
  proof(rule ZFfunComp, rule allI, rule impI)
    {
      fix h assume aa: "h |\<in>| ?A" show "?f h |\<in>| ?B"
      proof-
        have "f \<in> mor\<^bsub>C\<^esub>" using assms by auto
        hence "?f h |\<in>| (Hom\<^bsub>C\<^esub> X cod\<^bsub>C\<^esub> f)" using assms aa by (simp add: HomFtorMapLemma1)
        thus ?thesis using 1 by simp
      qed
    }
  qed
  also have "... = ZFfun ?A ?C (\<lambda>h. m2z\<^bsub>C \<^esub>((z2m\<^bsub>C \<^esub>h) ;;\<^bsub>C\<^esub> (f ;;\<^bsub>C\<^esub> g)))"
  proof(rule ZFfun_ext, rule allI, rule impI, simp add: comp_def)
    {
      fix h assume aa: "h |\<in>| ?A"
      show "m2z\<^bsub>C\<^esub> ((z2m\<^bsub>C\<^esub> (m2z\<^bsub>C\<^esub>((z2m\<^bsub>C\<^esub> h) ;;\<^bsub>C\<^esub> f))) ;;\<^bsub>C\<^esub> g) = m2z\<^bsub>C\<^esub> ((z2m\<^bsub>C\<^esub> h) ;;\<^bsub>C\<^esub> (f ;;\<^bsub>C\<^esub> g))"
      proof-
        have bb: "(z2m\<^bsub>C\<^esub> h) \<approx>>\<^bsub>C\<^esub> f"
        proof(rule CompDefinedI)
          show "f \<in> mor\<^bsub>C\<^esub>" using c by auto
          hence "dom\<^bsub>C\<^esub> f \<in> obj\<^bsub>C\<^esub>" using a by (simp add: Category.Cdom)
          hence "(z2m\<^bsub>C\<^esub> h) maps\<^bsub>C\<^esub> X to dom\<^bsub>C\<^esub> f" using assms aa by (simp add: LSCategory.z2mm2z)
          thus "(z2m\<^bsub>C\<^esub> h) \<in> mor\<^bsub>C\<^esub>" and "cod\<^bsub>C\<^esub> (z2m\<^bsub>C\<^esub> h) = dom\<^bsub>C\<^esub> f" by auto
        qed
        hence "(z2m\<^bsub>C\<^esub> h) ;;\<^bsub>C\<^esub> f \<in> mor\<^bsub>C\<^esub>" using a by (simp add: Category.MapsToMorDomCod)
        hence "z2m\<^bsub>C\<^esub> (m2z\<^bsub>C\<^esub> ((z2m\<^bsub>C\<^esub> h) ;;\<^bsub>C\<^esub> f)) = (z2m\<^bsub>C\<^esub> h) ;;\<^bsub>C\<^esub> f" using a by (simp add: LSCategory.m2zz2mInv)
        hence "m2z\<^bsub>C\<^esub> ((z2m\<^bsub>C\<^esub> (m2z\<^bsub>C\<^esub>((z2m\<^bsub>C\<^esub> h) ;;\<^bsub>C\<^esub> f))) ;;\<^bsub>C\<^esub> g) = m2z\<^bsub>C\<^esub> (((z2m\<^bsub>C\<^esub> h) ;;\<^bsub>C\<^esub> f) ;;\<^bsub>C\<^esub> g)" by simp
        also have "... = m2z\<^bsub>C\<^esub> ((z2m\<^bsub>C\<^esub> h) ;;\<^bsub>C\<^esub> (f ;;\<^bsub>C\<^esub> g))" using bb c a by (simp add: Category.Cassoc)
        finally show ?thesis .
      qed
    }
  qed
  also have "... = ZFfun (Hom\<^bsub>C\<^esub> X dom\<^bsub>C\<^esub> (f ;;\<^bsub>C\<^esub> g)) (Hom\<^bsub>C\<^esub> X cod\<^bsub>C\<^esub> (f ;;\<^bsub>C\<^esub> g)) (\<lambda>h. m2z\<^bsub>C \<^esub>((z2m\<^bsub>C \<^esub>h) ;;\<^bsub>C\<^esub> (f ;;\<^bsub>C\<^esub> g)))"
    using 2 3 by simp
  also have "... = Hom\<^bsub>C\<^esub>[X,f ;;\<^bsub>C\<^esub> g]" by (simp add:  HomFtorMap_def)
  finally show ?thesis by (auto simp add: SET_def)
qed

lemma HomFtorDist:
  assumes "LSCategory C" and "X \<in> obj\<^bsub>C\<^esub>" and "f \<approx>>\<^bsub>C\<^esub> g"
  shows   "(Hom\<^bsub>C\<^esub>[X,f]) ;;\<^bsub>SET\<^esub> (Hom\<^bsub>C\<^esub>[X,g]) = Hom\<^bsub>C\<^esub>[X,f ;;\<^bsub>C\<^esub> g]"
proof-
  have "(Hom\<^bsub>C\<^esub>[X,f]) ;;\<^bsub>SET'\<^esub> (Hom\<^bsub>C\<^esub>[X,g]) = Hom\<^bsub>C\<^esub>[X,f ;;\<^bsub>C\<^esub> g]" using assms by (simp add: HomFtorDist')
  moreover have "(Hom\<^bsub>C\<^esub>[X,f]) \<approx>>\<^bsub>SET'\<^esub> (Hom\<^bsub>C\<^esub>[X,g])" using assms by (simp add: HomFtorCompDef')
  ultimately show ?thesis by (simp add: MakeCatComp SET_def)
qed

lemma HomFtorId':
  assumes a: "LSCategory C" and b: "X \<in> obj\<^bsub>C\<^esub>" and c: "Y \<in> obj\<^bsub>C\<^esub>"
  shows   "Hom\<^bsub>C\<^esub>[X,id\<^bsub>C\<^esub> Y] = id\<^bsub>SET'\<^esub> (Hom\<^bsub>C \<^esub>X Y)"
proof-
  have "(id\<^bsub>C\<^esub> Y) maps\<^bsub>C\<^esub> Y to Y" using a c by (simp add: Category.Simps)
  hence 1: "(dom\<^bsub>C\<^esub> (id\<^bsub>C\<^esub> Y)) = Y" and 2: "(cod\<^bsub>C\<^esub> (id\<^bsub>C\<^esub> Y)) = Y" by auto
  have "Hom\<^bsub>C\<^esub>[X,id\<^bsub>C\<^esub> Y] = ZFfun (Hom\<^bsub>C \<^esub>X (dom\<^bsub>C\<^esub> (id\<^bsub>C\<^esub> Y))) (Hom\<^bsub>C \<^esub>X (cod\<^bsub>C\<^esub> (id\<^bsub>C\<^esub> Y))) (\<lambda> f . m2z\<^bsub>C\<^esub> ((z2m\<^bsub>C\<^esub> f) ;;\<^bsub>C\<^esub> (id\<^bsub>C\<^esub> Y)))"
    by (simp add: HomFtorMap_def)
  also have "... = ZFfun (Hom\<^bsub>C \<^esub>X Y) (Hom\<^bsub>C \<^esub>X Y) (\<lambda> f . m2z\<^bsub>C\<^esub> ((z2m\<^bsub>C\<^esub> f) ;;\<^bsub>C\<^esub> (id\<^bsub>C\<^esub> Y)))" using 1 2 by simp
  also have "... = ZFfun (Hom\<^bsub>C \<^esub>X Y) (Hom\<^bsub>C \<^esub>X Y) (\<lambda> f . f)"
  proof(rule ZFfun_ext, rule allI, rule impI)
    {
      fix h assume aa: "h |\<in>| (Hom\<^bsub>C\<^esub> X Y)" show "m2z\<^bsub>C\<^esub> ((z2m\<^bsub>C\<^esub> h) ;;\<^bsub>C\<^esub> (id\<^bsub>C\<^esub> Y)) = h"
      proof-
        have "(z2m\<^bsub>C\<^esub> h) maps\<^bsub>C\<^esub> X to Y" and bb: "m2z\<^bsub>C\<^esub> (z2m\<^bsub>C\<^esub> h) = h"
          using assms aa by (simp add: LSCategory.z2mm2z)+
        hence "(z2m\<^bsub>C\<^esub> h) ;;\<^bsub>C\<^esub> (id\<^bsub>C\<^esub> Y) = (z2m\<^bsub>C\<^esub> h)" using a by (auto simp add: Category.Simps)
        hence "m2z\<^bsub>C\<^esub> ((z2m\<^bsub>C\<^esub> h) ;;\<^bsub>C\<^esub> (id\<^bsub>C\<^esub> Y)) = m2z\<^bsub>C\<^esub> (z2m\<^bsub>C\<^esub> h)" by simp
        also have "... = h" using bb .
        finally show ?thesis .
      qed
    }
  qed
  finally show ?thesis by (simp add: SET'_def)
qed

lemma HomFtorId:
  assumes "LSCategory C" and "X \<in> obj\<^bsub>C\<^esub>" and "Y \<in> obj\<^bsub>C\<^esub>"
  shows   "Hom\<^bsub>C\<^esub>[X,id\<^bsub>C\<^esub> Y] = id\<^bsub>SET\<^esub> (Hom\<^bsub>C \<^esub>X Y)"
proof-
  have "Hom\<^bsub>C\<^esub>[X,id\<^bsub>C\<^esub> Y] = id\<^bsub>SET'\<^esub> (Hom\<^bsub>C \<^esub>X Y)" using assms by (simp add: HomFtorId')
  moreover have "(Hom\<^bsub>C \<^esub>X Y) \<in> obj\<^bsub>SET'\<^esub>" by (simp add: SET'_def)
  ultimately show ?thesis by (simp add: MakeCatId SET_def)
qed

lemma HomFtorObj':
  assumes a: "LSCategory C"
  and     b: "PreFunctor (HomP\<^bsub>C\<^esub>[X,\<emdash>])"  and c: "X \<in> obj\<^bsub>C\<^esub>" and d: "Y \<in> obj\<^bsub>C\<^esub>"
  shows   "(HomP\<^bsub>C\<^esub>[X,\<emdash>]) @@ Y = Hom\<^bsub>C \<^esub>X Y"
proof-
  let ?F = "(HomFtor' C X)"
  have "?F ## (id\<^bsub>CatDom ?F\<^esub> Y) = Hom\<^bsub>C\<^esub>[X,id\<^bsub>C\<^esub> Y]" by (simp add: HomFtor'_def)
  also have "... = id\<^bsub>CatCod ?F\<^esub> (Hom\<^bsub>C \<^esub>X Y)" using assms by (simp add: HomFtorId HomFtor'_def)
  finally have "?F ## (id\<^bsub>CatDom ?F\<^esub> Y) = id\<^bsub>CatCod ?F\<^esub> (Hom\<^bsub>C \<^esub>X Y)" by simp
  moreover have "Hom\<^bsub>C \<^esub>X Y \<in> obj\<^bsub>CatCod ?F\<^esub>" using assms
    by (simp add: HomFtorId HomFtor'_def SET_def SET'_def MakeCatObj)
  moreover have "Y \<in> obj\<^bsub>CatDom ?F\<^esub>" using d by (simp add: HomFtor'_def)
  ultimately show ?thesis using b by(simp add: PreFunctor.FmToFo[of ?F Y "Hom\<^bsub>C \<^esub>X Y"])
qed

lemma HomFtorFtor':
  assumes a: "LSCategory C"
  and     b: "X \<in> obj\<^bsub>C\<^esub>"
  shows   "FunctorM (HomP\<^bsub>C\<^esub>[X,\<emdash>])"
proof(intro_locales)
  show PF: "PreFunctor (HomP\<^bsub>C\<^esub>[X,\<emdash>])"
  proof(auto simp add: HomFtor'_def PreFunctor_def SETCategory a HomFtorDist b)
    {
      fix Z assume aa: "Z \<in> obj\<^bsub>C\<^esub>"
      show "\<exists> Y \<in> obj\<^bsub>SET \<^esub>. Hom\<^bsub>C\<^esub>[X,id\<^bsub>C\<^esub> Z] = id\<^bsub>SET\<^esub> Y"
      proof(rule_tac x="Hom\<^bsub>C \<^esub>X Z" in Set.rev_bexI)
        show "Hom\<^bsub>C\<^esub> X Z \<in> obj\<^bsub>SET\<^esub>" by (simp add: SET_def SET'_def MakeCatObj)
        show "Hom\<^bsub>C\<^esub>[X,id\<^bsub>C\<^esub> Z] = id\<^bsub>SET\<^esub> (Hom\<^bsub>C\<^esub> X Z)" using assms aa by(simp add:HomFtorId)
      qed
    }
  qed
  {
    fix f Z Y assume aa: "f maps\<^bsub>C \<^esub>Z to Y"
    have "(HomP\<^bsub>C\<^esub>[X,\<emdash>]) ## f maps\<^bsub>SET\<^esub> ((HomP\<^bsub>C\<^esub>[X,\<emdash>]) @@ Z) to ((HomP\<^bsub>C\<^esub>[X,\<emdash>]) @@ Y)"
    proof-
      have bb: "Z \<in> obj\<^bsub>C\<^esub>" and cc: "Y \<in> obj\<^bsub>C\<^esub>" using aa a by (simp add: Category.MapsToObj)+
      have dd: "dom\<^bsub>C\<^esub> f = Z" and ee: "cod\<^bsub>C\<^esub> f = Y" and ff: "f \<in> mor\<^bsub>C\<^esub>" using aa by auto
      have "(HomP\<^bsub>C\<^esub>[X,\<emdash>]) ## f = Hom\<^bsub>C\<^esub>[X,f]" by (simp add: HomFtor'_def)
      moreover have "(HomP\<^bsub>C\<^esub>[X,\<emdash>]) @@ Z = Hom\<^bsub>C \<^esub>X Z"
        and "(HomP\<^bsub>C\<^esub>[X,\<emdash>]) @@ Y = Hom\<^bsub>C \<^esub>X Y" using assms bb cc PF by (simp add: HomFtorObj')+
      moreover have "Hom\<^bsub>C\<^esub>[X,f] maps\<^bsub>SET\<^esub> (Hom\<^bsub>C \<^esub>X (dom\<^bsub>C\<^esub> f)) to (Hom\<^bsub>C \<^esub>X (cod\<^bsub>C\<^esub> f))"
        using assms ff by (simp add: HomFtorMapsTo)
      ultimately show ?thesis using dd ee by simp
    qed
  }
  thus "FunctorM_axioms (HomP\<^bsub>C\<^esub>[X,\<emdash>])" using PF by (auto simp add: FunctorM_axioms_def HomFtor'_def)
qed

lemma HomFtorFtor:
  assumes a: "LSCategory C"
  and     b: "X \<in> obj\<^bsub>C\<^esub>"
  shows   "Functor (Hom\<^bsub>C\<^esub>[X,\<emdash>])"
proof-
  have "FunctorM (HomP\<^bsub>C\<^esub>[X,\<emdash>])" using assms by (rule HomFtorFtor')
  thus ?thesis by (simp add: HomFtor_def MakeFtor)
qed

lemma HomFtorObj:
  assumes "LSCategory C"
  and     "X \<in> obj\<^bsub>C\<^esub>" and "Y \<in> obj\<^bsub>C\<^esub>"
  shows   "(Hom\<^bsub>C\<^esub>[X,\<emdash>]) @@ Y = Hom\<^bsub>C \<^esub>X Y"
proof-
  have "FunctorM (HomP\<^bsub>C\<^esub>[X,\<emdash>])" using assms by (simp add: HomFtorFtor')
  hence 1: "PreFunctor (HomP\<^bsub>C\<^esub>[X,\<emdash>])" by (simp add: FunctorM_def)
  moreover have "CatDom (HomP\<^bsub>C\<^esub>[X,\<emdash>]) = C" by (simp add: HomFtor'_def)
  ultimately have "(Hom\<^bsub>C\<^esub>[X,\<emdash>]) @@ Y = (HomP\<^bsub>C\<^esub>[X,\<emdash>]) @@ Y" using assms by (simp add: MakeFtorObj HomFtor_def)
  thus ?thesis using assms 1 by (simp add: HomFtorObj')
qed

definition
  HomFtorMapContra :: "('o,'m,'a) LSCategory_scheme \<Rightarrow> 'm \<Rightarrow> 'o \<Rightarrow> ZF" ("HomC\<index>[_,_]" [65,65] 65) where
  "HomFtorMapContra C g X \<equiv> ZFfun (Hom\<^bsub>C\<^esub> (cod\<^bsub>C\<^esub> g) X) (Hom\<^bsub>C\<^esub> (dom\<^bsub>C\<^esub> g) X) (\<lambda> f . m2z\<^bsub>C\<^esub> (g ;;\<^bsub>C\<^esub> (z2m\<^bsub>C\<^esub> f)))"

definition
  HomFtorContra' :: "('o,'m,'a) LSCategory_scheme \<Rightarrow> 'o \<Rightarrow>
      ('o,ZF,'m,ZF,\<lparr>mor2ZF :: 'm \<Rightarrow> ZF, \<dots> :: 'a\<rparr>,unit) Functor" ("HomP\<index>[\<emdash>,_]" [65] 65) where
  "HomFtorContra' C X \<equiv> \<lparr>
        CatDom = (Op C),
        CatCod = SET ,
        MapM   = \<lambda> g . HomC\<^bsub>C\<^esub>[g,X]
  \<rparr>"

definition HomFtorContra ("Hom\<index>[\<emdash>,_]" [65] 65) where "HomFtorContra C X \<equiv> MakeFtor(HomFtorContra' C X)"

lemma HomContraAt: "x |\<in>| (Hom\<^bsub>C \<^esub>(cod\<^bsub>C\<^esub> f) X) \<Longrightarrow> (HomC\<^bsub>C\<^esub>[f,X]) |@| x = m2z\<^bsub>C\<^esub> (f ;;\<^bsub>C\<^esub> (z2m\<^bsub>C\<^esub> x))"
  by (simp add: HomFtorMapContra_def ZFfunApp)

lemma mor2ZF_Op: "mor2ZF (Op C) = mor2ZF C"
apply (cases C)
apply (simp add: OppositeCategory_def)
done

lemma mor_Op: "mor\<^bsub>Op C\<^esub> = mor\<^bsub>C\<^esub>" by (simp add: OppositeCategory_def)
lemma obj_Op: "obj\<^bsub>Op C\<^esub> = obj\<^bsub>C\<^esub>" by (simp add: OppositeCategory_def)

lemma ZF2mor_Op: "ZF2mor (Op C) f = ZF2mor C f"
by (simp add: ZF2mor_def mor2ZF_Op mor_Op)

lemma mapsTo_Op: "f maps\<^bsub>Op C\<^esub> Y to X = f maps\<^bsub>C\<^esub> X to Y"
by (auto simp add: OppositeCategory_def mor_Op MapsTo_def)

lemma HOMCollection_Op: "HOMCollection (Op C) X Y = HOMCollection C Y X"
by (simp add: HOMCollection_def mapsTo_Op mor2ZF_Op)

lemma Hom_Op: "Hom\<^bsub>Op C\<^esub> X Y = Hom\<^bsub>C\<^esub> Y X"
by (simp add: HomSet_def HOMCollection_Op)

lemma HomFtorContra': "HomP\<^bsub>C\<^esub>[\<emdash>,X] = HomP\<^bsub>Op C\<^esub>[X,\<emdash>]"
apply (simp add:  HomFtorContra'_def
                      HomFtor'_def HomFtorMapContra_def HomFtorMap_def mor2ZF_Op ZF2mor_Op Hom_Op)
by (simp add: OppositeCategory_def)

lemma HomFtorContra: "Hom\<^bsub>C\<^esub>[\<emdash>,X] = Hom\<^bsub>Op C\<^esub>[X,\<emdash>]"
by (auto simp add: HomFtorContra' HomFtorContra_def HomFtor_def)

lemma HomFtorContraDom: "CatDom (Hom\<^bsub>C\<^esub>[\<emdash>,X]) = Op C"
by(simp add: HomFtorContra_def HomFtorContra'_def MakeFtor_def)

lemma HomFtorContraCod: "CatCod (Hom\<^bsub>C\<^esub>[\<emdash>,X]) = SET"
by(simp add: HomFtorContra_def HomFtorContra'_def MakeFtor_def)

lemma LSCategory_Op: assumes "LSCategory C" shows "LSCategory (Op C)"
proof(auto simp only: LSCategory_def)
  show "Category (Op C)" using assms by (simp add: OpCatCat)
  show "LSCategory_axioms (Op C)" using assms
    by (simp add: LSCategory_axioms_def mor_Op obj_Op mor2ZF_Op HOMCollection_Op
                     LSCategory.mor2ZFInj LSCategory.HOMSetIsSet LSCategory.m2zExt)
qed

lemma HomFtorContraFtor:
  assumes "LSCategory C"
  and     "X \<in> obj\<^bsub>C\<^esub>"
  shows   "Ftor (Hom\<^bsub>C\<^esub>[\<emdash>,X]) : (Op C) \<longrightarrow> SET"
proof(auto simp only: functor_abbrev_def)
  show "Functor (Hom\<^bsub>C\<^esub>[\<emdash>,X])"
  proof-
    have "Hom\<^bsub>C\<^esub>[\<emdash>,X] = Hom\<^bsub>Op C\<^esub>[X,\<emdash>]" by (simp add: HomFtorContra)
    moreover have "LSCategory (Op C)" using assms by (simp add: LSCategory_Op)
    moreover have "X \<in> obj\<^bsub>Op C\<^esub>" using assms by (simp add: OppositeCategory_def)
    ultimately show ?thesis using assms by (simp add: HomFtorFtor)
  qed
  show "CatDom (Hom\<^bsub>C\<^esub>[\<emdash>,X]) = Op C" by(simp add: HomFtorContra_def HomFtorContra'_def MakeFtor_def)
  show "CatCod (Hom\<^bsub>C\<^esub>[\<emdash>,X]) = SET" by(simp add: HomFtorContra_def HomFtorContra'_def MakeFtor_def)
qed

lemma HomFtorOpObj:
  assumes "LSCategory C"
  and     "X \<in> obj\<^bsub>C\<^esub>" and "Y \<in> obj\<^bsub>C\<^esub>"
  shows   "(Hom\<^bsub>C\<^esub>[\<emdash>,X]) @@ Y = Hom\<^bsub>C \<^esub>Y X"
proof-
  have 1: "X \<in> Obj (Op C)" and 2: "Y \<in> Obj (Op C)" using assms by (simp add: OppositeCategory_def)+
  have "(Hom\<^bsub>C\<^esub>[\<emdash>,X]) @@ Y = (Hom\<^bsub>Op C\<^esub>[X,\<emdash>]) @@ Y" by (simp add: HomFtorContra)
  also have "... = (Hom\<^bsub>Op C \<^esub>X Y)" using assms(1) 1 2 by (simp add: LSCategory_Op HomFtorObj)
  also have "... = (Hom\<^bsub>C \<^esub>Y X)" by (simp add: Hom_Op)
  finally show ?thesis .
qed

lemma HomCHomOp: "HomC\<^bsub>C\<^esub>[g,X] = Hom\<^bsub>Op C\<^esub>[X,g]"
apply (simp add:  HomFtorContra'_def
                      HomFtor'_def HomFtorMapContra_def HomFtorMap_def mor2ZF_Op ZF2mor_Op Hom_Op)
by (simp add: OppositeCategory_def)

lemma HomFtorContraMapsTo:
  assumes "LSCategory C" and "X \<in> obj\<^bsub>C\<^esub>" and "f \<in> mor\<^bsub>C\<^esub>"
  shows "HomC\<^bsub>C\<^esub>[f,X] maps\<^bsub>SET\<^esub> Hom\<^bsub>C \<^esub>(cod\<^bsub>C\<^esub> f) X  to Hom\<^bsub>C \<^esub>(dom\<^bsub>C\<^esub> f) X"
proof-
  have "LSCategory (Op C)" using assms by(simp add: LSCategory_Op)
  moreover have "X \<in> Obj (Op C)" using assms by (simp add: OppositeCategory_def)
  moreover have "f \<in> Mor (Op C)" using assms by (simp add: OppositeCategory_def)
  ultimately have "Hom\<^bsub>Op C\<^esub>[X,f] maps\<^bsub>SET\<^esub> Hom\<^bsub>Op C \<^esub>X (dom\<^bsub>Op C\<^esub> f) to Hom\<^bsub>Op C \<^esub>X (cod\<^bsub>Op C\<^esub> f)" using assms
    by (simp add: HomFtorMapsTo)
  moreover have "HomC\<^bsub>C\<^esub>[f,X] = Hom\<^bsub>Op C\<^esub>[X,f]" by (simp add: HomCHomOp)
  moreover have "Hom\<^bsub>Op C \<^esub>X (dom\<^bsub>Op C\<^esub> f) = Hom\<^bsub>C \<^esub>(cod\<^bsub>C\<^esub> f) X"
  proof-
    have "Hom\<^bsub>Op C \<^esub>X (dom\<^bsub>Op C\<^esub> f) = Hom\<^bsub>C\<^esub> (dom\<^bsub>Op C\<^esub> f) X" by (simp add: Hom_Op)
    thus ?thesis by (simp add:  OppositeCategory_def)
  qed
  moreover have "Hom\<^bsub>Op C \<^esub>X (cod\<^bsub>Op C\<^esub> f) = Hom\<^bsub>C \<^esub>(dom\<^bsub>C\<^esub> f) X"
  proof-
    have "Hom\<^bsub>Op C \<^esub>X (cod\<^bsub>Op C\<^esub> f) = Hom\<^bsub>C\<^esub> (cod\<^bsub>Op C\<^esub> f) X" by (simp add: Hom_Op)
    thus ?thesis by (simp add:  OppositeCategory_def)
  qed
  ultimately show ?thesis by simp
qed

lemma HomFtorContraMor:
  assumes "LSCategory C" and "X \<in> obj\<^bsub>C\<^esub>" and "f \<in> mor\<^bsub>C\<^esub>"
  shows "HomC\<^bsub>C\<^esub>[f,X] \<in> Mor SET" and "dom\<^bsub>SET\<^esub> (HomC\<^bsub>C\<^esub>[f,X]) = Hom\<^bsub>C \<^esub>(cod\<^bsub>C\<^esub> f) X"
  and "cod\<^bsub>SET\<^esub> (HomC\<^bsub>C\<^esub>[f,X]) = Hom\<^bsub>C \<^esub>(dom\<^bsub>C\<^esub> f) X"
proof-
  have "HomC\<^bsub>C\<^esub>[f,X] maps\<^bsub>SET\<^esub> Hom\<^bsub>C \<^esub>(cod\<^bsub>C\<^esub> f) X  to Hom\<^bsub>C \<^esub>(dom\<^bsub>C\<^esub> f) X" using assms by (simp add: HomFtorContraMapsTo)
  thus "HomC\<^bsub>C\<^esub>[f,X] \<in> Mor SET" and "dom\<^bsub>SET\<^esub> (HomC\<^bsub>C\<^esub>[f,X]) = Hom\<^bsub>C \<^esub>(cod\<^bsub>C\<^esub> f) X"
  and "cod\<^bsub>SET\<^esub> (HomC\<^bsub>C\<^esub>[f,X]) = Hom\<^bsub>C \<^esub>(dom\<^bsub>C\<^esub> f) X"
    by auto
qed

lemma HomContraMor:
  assumes "LSCategory C" and "f \<in> Mor C"
  shows "(Hom\<^bsub>C\<^esub>[\<emdash>,X]) ## f = HomC\<^bsub>C\<^esub>[f,X]"
by(simp add: HomFtorContra_def HomFtorContra'_def MakeFtor_def assms OppositeCategory_def)

(*This is used in the proof of the naturality of the Yoneda trans*)
lemma HomCHom:
  assumes "LSCategory C" and "f \<in> Mor C" and "g \<in> Mor C"
  shows "(HomC\<^bsub>C\<^esub>[g,dom\<^bsub>C\<^esub> f]) ;;\<^bsub>SET\<^esub> (Hom\<^bsub>C\<^esub>[dom\<^bsub>C\<^esub> g,f]) = (Hom\<^bsub>C\<^esub>[cod\<^bsub>C\<^esub> g,f]) ;;\<^bsub>SET\<^esub> (HomC\<^bsub>C\<^esub>[g,cod\<^bsub>C\<^esub> f])"
proof-
  have ObjDf: "dom\<^bsub>C\<^esub> f \<in> obj\<^bsub>C\<^esub>" and ObjDg: "dom\<^bsub>C\<^esub> g \<in> obj\<^bsub>C\<^esub>" using assms by (simp add: Category.Cdom)+
  have ObjCg: "cod\<^bsub>C\<^esub> g \<in> obj\<^bsub>C\<^esub>" and ObjCf: "cod\<^bsub>C\<^esub> f \<in> obj\<^bsub>C\<^esub>" using assms by (simp add: Category.Ccod)+
  have "(HomC\<^bsub>C\<^esub>[g,dom\<^bsub>C\<^esub> f]) ;;\<^bsub>SET\<^esub> (Hom\<^bsub>C\<^esub>[dom\<^bsub>C\<^esub> g,f]) = (HomC\<^bsub>C\<^esub>[g,dom\<^bsub>C\<^esub> f]) |o| (Hom\<^bsub>C\<^esub>[dom\<^bsub>C\<^esub> g,f])"
  proof-
    have "(HomC\<^bsub>C\<^esub>[g,dom\<^bsub>C\<^esub> f]) \<approx>>\<^bsub>SET\<^esub> (Hom\<^bsub>C\<^esub>[dom\<^bsub>C\<^esub> g,f])"
    proof(rule CompDefinedI)
      show "Hom\<^bsub>C\<^esub>[dom\<^bsub>C\<^esub> g,f] \<in> Mor SET" using assms ObjDg by (simp add: HomFtorMor)
      show "HomC\<^bsub>C\<^esub>[g,dom\<^bsub>C\<^esub> f] \<in> Mor SET" using assms ObjDf by (simp add: HomFtorContraMor)
      show "cod\<^bsub>SET\<^esub> (HomC\<^bsub>C\<^esub>[g,dom\<^bsub>C\<^esub> f]) = dom\<^bsub>SET\<^esub> (Hom\<^bsub>C\<^esub>[dom\<^bsub>C\<^esub> g,f])" using assms ObjDg ObjDf
        by (simp add: HomFtorMor HomFtorContraMor)
    qed
    thus ?thesis by(simp add: SET_def SET'_def MakeCatComp2)
  qed
  also have "... = ZFfun (Hom\<^bsub>C\<^esub> (cod\<^bsub>C\<^esub> g) (dom\<^bsub>C\<^esub> f)) (Hom\<^bsub>C\<^esub> (dom\<^bsub>C\<^esub> g) (cod\<^bsub>C\<^esub> f))
              ((\<lambda> h . m2z\<^bsub>C\<^esub> ((z2m\<^bsub>C\<^esub> h) ;;\<^bsub>C\<^esub> f)) o (\<lambda> h . m2z\<^bsub>C\<^esub> (g ;;\<^bsub>C\<^esub> (z2m\<^bsub>C\<^esub> h))))"
  proof(simp add: HomFtorMapContra_def HomFtorMap_def, rule ZFfunComp, rule allI, rule impI)
    {
      fix x assume aa: "x |\<in>| (Hom\<^bsub>C\<^esub> (cod\<^bsub>C\<^esub> g) (dom\<^bsub>C\<^esub> f))"
      show "(m2z\<^bsub>C \<^esub>(g ;;\<^bsub>C\<^esub> (z2m\<^bsub>C \<^esub>x))) |\<in>| (Hom\<^bsub>C\<^esub> (dom\<^bsub>C\<^esub> g) (dom\<^bsub>C\<^esub> f))"
      proof(rule LSCategory.m2zz2m, simp_all add: assms(1) ObjDg ObjDf)
        have "g maps\<^bsub>C\<^esub> (dom\<^bsub>C\<^esub> g) to (cod\<^bsub>C\<^esub> g)" using assms by auto
        moreover have "(z2m\<^bsub>C \<^esub>x) maps\<^bsub>C\<^esub> (cod\<^bsub>C\<^esub> g) to (dom\<^bsub>C\<^esub> f)" using aa ObjCg ObjDf assms(1)
          by (simp add: LSCategory.z2mm2z)
        ultimately show "g ;;\<^bsub>C\<^esub> (z2m\<^bsub>C \<^esub>x) maps\<^bsub>C\<^esub> (dom\<^bsub>C\<^esub> g) to (dom\<^bsub>C\<^esub> f)" using assms(1)
          by (simp add: Category.Ccompt)
      qed
    }
  qed
  also have "... = ZFfun (Hom\<^bsub>C\<^esub> (cod\<^bsub>C\<^esub> g) (dom\<^bsub>C\<^esub> f)) (Hom\<^bsub>C\<^esub> (dom\<^bsub>C\<^esub> g) (cod\<^bsub>C\<^esub> f))
              ((\<lambda> h . m2z\<^bsub>C\<^esub> (g ;;\<^bsub>C\<^esub> (z2m\<^bsub>C\<^esub> h))) o (\<lambda> h . m2z\<^bsub>C\<^esub> ((z2m\<^bsub>C\<^esub> h) ;;\<^bsub>C\<^esub> f)))"
  proof(rule ZFfun_ext, rule allI, rule impI)
    {
      fix h assume aa: "h |\<in>| (Hom\<^bsub>C\<^esub> (cod\<^bsub>C\<^esub> g) (dom\<^bsub>C\<^esub> f))"
      show "((\<lambda> h . m2z\<^bsub>C\<^esub> ((z2m\<^bsub>C\<^esub> h) ;;\<^bsub>C\<^esub> f)) o (\<lambda> h . m2z\<^bsub>C\<^esub> (g ;;\<^bsub>C\<^esub> (z2m\<^bsub>C\<^esub> h)))) h =
        ((\<lambda> h . m2z\<^bsub>C\<^esub> (g ;;\<^bsub>C\<^esub> (z2m\<^bsub>C\<^esub> h))) o (\<lambda> h . m2z\<^bsub>C\<^esub> ((z2m\<^bsub>C\<^esub> h) ;;\<^bsub>C\<^esub> f))) h"
      proof-
        have MapsTo1: "(z2m\<^bsub>C\<^esub> h) maps\<^bsub>C\<^esub> (cod\<^bsub>C\<^esub> g) to (dom\<^bsub>C\<^esub> f)" using assms(1) ObjCg ObjDf aa by (simp add: LSCategory.z2mm2z)
        have CompDef1: "(z2m\<^bsub>C\<^esub> h) \<approx>>\<^bsub>C\<^esub> f"
        proof(rule CompDefinedI)
          show "f \<in> mor\<^bsub>C\<^esub>" using assms by simp
          show "(z2m\<^bsub>C\<^esub> h) \<in> mor\<^bsub>C\<^esub>" and "cod\<^bsub>C\<^esub> (z2m\<^bsub>C\<^esub> h) = dom\<^bsub>C\<^esub> f" using MapsTo1 by auto
        qed
        have CompDef2: "g \<approx>>\<^bsub>C\<^esub> (z2m\<^bsub>C\<^esub> h)"
        proof(rule CompDefinedI)
          show "g \<in> mor\<^bsub>C\<^esub>" using assms by simp
          thus "(z2m\<^bsub>C\<^esub> h) \<in> mor\<^bsub>C\<^esub>" and "cod\<^bsub>C\<^esub> g = dom\<^bsub>C\<^esub> (z2m\<^bsub>C\<^esub> h)" using MapsTo1 by auto
        qed
        have c1: "(z2m\<^bsub>C\<^esub> h) ;;\<^bsub>C\<^esub> f \<in> Mor C" using assms CompDef1 by (simp add: Category.MapsToMorDomCod)
        have c2: "g ;;\<^bsub>C\<^esub> (z2m\<^bsub>C\<^esub> h) \<in> Mor C" using assms CompDef2 by (simp add: Category.MapsToMorDomCod)
        have "g ;;\<^bsub>C\<^esub> (z2m\<^bsub>C\<^esub> (m2z\<^bsub>C\<^esub> ((z2m\<^bsub>C\<^esub> h) ;;\<^bsub>C\<^esub> f))) = g ;;\<^bsub>C\<^esub> ((z2m\<^bsub>C\<^esub> h) ;;\<^bsub>C\<^esub> f)" using assms(1) c1
          by (simp add: LSCategory.m2zz2mInv)
        also have "... = (g ;;\<^bsub>C\<^esub> (z2m\<^bsub>C\<^esub> h)) ;;\<^bsub>C\<^esub> f" using CompDef1 CompDef2 assms by (simp add: Category.Cassoc)
        also have "... = (z2m\<^bsub>C\<^esub> (m2z\<^bsub>C\<^esub> (g ;;\<^bsub>C\<^esub> (z2m\<^bsub>C\<^esub> h)))) ;;\<^bsub>C\<^esub> f" using assms(1) c2
          by (simp add: LSCategory.m2zz2mInv)
        finally have "g ;;\<^bsub>C\<^esub> (z2m\<^bsub>C\<^esub> (m2z\<^bsub>C\<^esub> ((z2m\<^bsub>C\<^esub> h) ;;\<^bsub>C\<^esub> f))) = (z2m\<^bsub>C\<^esub> (m2z\<^bsub>C\<^esub> (g ;;\<^bsub>C\<^esub> (z2m\<^bsub>C\<^esub> h)))) ;;\<^bsub>C\<^esub> f" .
        thus ?thesis by simp
      qed
    }
  qed
  also have "... = (Hom\<^bsub>C\<^esub>[cod\<^bsub>C\<^esub> g,f]) |o| (HomC\<^bsub>C\<^esub>[g,cod\<^bsub>C\<^esub> f])"
  proof(simp add: HomFtorMapContra_def HomFtorMap_def, rule ZFfunComp[THEN sym], rule allI, rule impI)
    {
      fix x assume aa: "x |\<in>| (Hom\<^bsub>C\<^esub> cod\<^bsub>C\<^esub> g dom\<^bsub>C\<^esub> f)"
      show "m2z\<^bsub>C \<^esub>((z2m\<^bsub>C \<^esub>x) ;;\<^bsub>C\<^esub> f) |\<in>| (Hom\<^bsub>C\<^esub> cod\<^bsub>C\<^esub> g cod\<^bsub>C\<^esub> f)"
      proof(rule LSCategory.m2zz2m, simp_all add: assms(1) ObjCg ObjCf)
        have "f maps\<^bsub>C\<^esub> (dom\<^bsub>C\<^esub> f) to (cod\<^bsub>C\<^esub> f)" using assms by auto
        moreover have "(z2m\<^bsub>C \<^esub>x) maps\<^bsub>C\<^esub> (cod\<^bsub>C\<^esub> g) to (dom\<^bsub>C\<^esub> f)" using aa ObjCg ObjDf assms(1)
          by (simp add: LSCategory.z2mm2z)
        ultimately show "(z2m\<^bsub>C \<^esub>x) ;;\<^bsub>C\<^esub> f maps\<^bsub>C\<^esub> cod\<^bsub>C\<^esub> g to cod\<^bsub>C\<^esub> f" using assms(1)
          by (simp add: Category.Ccompt)
      qed
    }
  qed
  also have "... = (Hom\<^bsub>C\<^esub>[cod\<^bsub>C\<^esub> g,f]) ;;\<^bsub>SET\<^esub> (HomC\<^bsub>C\<^esub>[g,cod\<^bsub>C\<^esub> f])"
  proof-
    have "(Hom\<^bsub>C\<^esub>[cod\<^bsub>C\<^esub> g,f]) \<approx>>\<^bsub>SET\<^esub> (HomC\<^bsub>C\<^esub>[g,cod\<^bsub>C\<^esub> f])"
    proof(rule CompDefinedI)
      show "Hom\<^bsub>C\<^esub>[cod\<^bsub>C\<^esub> g,f] \<in> Mor SET" using assms ObjCg by (simp add: HomFtorMor)
      show "HomC\<^bsub>C\<^esub>[g,cod\<^bsub>C\<^esub> f] \<in> Mor SET" using assms ObjCf by (simp add: HomFtorContraMor)
      show "cod\<^bsub>SET\<^esub> (Hom\<^bsub>C\<^esub>[cod\<^bsub>C\<^esub> g,f]) = dom\<^bsub>SET\<^esub> (HomC\<^bsub>C\<^esub>[g,cod\<^bsub>C\<^esub> f])" using assms ObjCg ObjCf
        by (simp add: HomFtorMor HomFtorContraMor)
    qed
    thus ?thesis by(simp add: SET_def SET'_def MakeCatComp2)
  qed
  finally show ?thesis .
qed

end


(*
 * Copyright Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

section \<open>Legacy aliases\<close>

theory Legacy_Aliases
  imports "HOL-Library.Word"
begin

abbreviation (input) test_bit :: \<open>'a::semiring_bits \<Rightarrow> nat \<Rightarrow> bool\<close>
  where \<open>test_bit \<equiv> bit\<close>

abbreviation (input) bin_nth :: \<open>int \<Rightarrow> nat \<Rightarrow> bool\<close>
  where \<open>bin_nth \<equiv> bit\<close>

abbreviation (input) bin_last :: \<open>int \<Rightarrow> bool\<close>
  where \<open>bin_last \<equiv> odd\<close>

abbreviation (input) bin_rest :: \<open>int \<Rightarrow> int\<close>
  where \<open>bin_rest w \<equiv> w div 2\<close>

abbreviation (input) bintrunc :: \<open>nat \<Rightarrow> int \<Rightarrow> int\<close>
  where \<open>bintrunc \<equiv> take_bit\<close>

abbreviation (input) sbintrunc :: \<open>nat \<Rightarrow> int \<Rightarrow> int\<close>
  where \<open>sbintrunc \<equiv> signed_take_bit\<close>

abbreviation (input) bin_cat :: \<open>int \<Rightarrow> nat \<Rightarrow> int \<Rightarrow> int\<close>
  where \<open>bin_cat k n l \<equiv> concat_bit n l k\<close>

abbreviation (input) norm_sint :: \<open>nat \<Rightarrow> int \<Rightarrow> int\<close>
  where \<open>norm_sint n \<equiv> signed_take_bit (n - 1)\<close>

abbreviation (input) max_word :: \<open>'a::len word\<close>
  where \<open>max_word \<equiv> - 1\<close>

abbreviation (input) complement :: \<open>'a::len word \<Rightarrow> 'a word\<close>
  where \<open>complement \<equiv> not\<close>

lemma complement_mask:
  "complement (2 ^ n - 1) = NOT (mask n)"
  unfolding mask_eq_decr_exp by simp

abbreviation (input) shiftl1 :: \<open>'a::len word \<Rightarrow> 'a word\<close>
  where \<open>shiftl1 \<equiv> (*) 2\<close>

abbreviation (input)  shiftr1 :: \<open>'a::len word \<Rightarrow> 'a word\<close>
  where \<open>shiftr1 w \<equiv> w div 2\<close>

abbreviation (input) sshiftr1 :: \<open>'a::len word \<Rightarrow> 'a word\<close>
  where \<open>sshiftr1 \<equiv> signed_drop_bit (Suc 0)\<close>

abbreviation (input) bshiftr1 :: \<open>bool \<Rightarrow> 'a::len word \<Rightarrow> 'a word\<close>
  where \<open>bshiftr1 b w \<equiv> w div 2 OR push_bit (LENGTH('a) - Suc 0) (of_bool b) \<close>

lemma shiftr1_1: "shiftr1 (1::'a::len word) = 0"
  by (fact bits_1_div_2)

lemma sshiftr1_eq:
  \<open>sshiftr1 w = word_of_int (sint w div 2)\<close>
  by (rule bit_word_eqI) (auto simp add: bit_simps min_def simp flip: bit_Suc elim: le_SucE)

lemma shiftl1_eq:
  \<open>shiftl1 w = word_of_int (2 * uint w)\<close>
  by (rule bit_word_eqI) (simp add: bit_simps)

lemma bit_shiftl1_iff:
  \<open>bit (shiftl1 w) n \<longleftrightarrow> 0 < n \<and> n < LENGTH('a) \<and> bit w (n - 1)\<close>
  for w :: \<open>'a::len word\<close>
  by (auto simp add: bit_simps)

lemma bit_shiftr1_iff:
  \<open>bit (shiftr1 w) n \<longleftrightarrow> bit w (Suc n)\<close>
  by (simp add: bit_Suc)

lemma shiftr1_eq:
  \<open>shiftr1 w = word_of_int (uint w div 2)\<close>
  by (rule bit_word_eqI) (simp add: bit_simps flip: bit_Suc)

lemma shiftl1_rev:
  "shiftl1 w = word_reverse (shiftr1 (word_reverse w))"
  by (rule bit_word_eqI) (auto simp add: bit_simps Suc_diff_Suc simp flip: bit_Suc)

lemma shiftl1_p:
  "shiftl1 w = w + w"
  for w :: "'a::len word"
  by (fact mult_2)

lemma shiftr1_bintr:
  "(shiftr1 (numeral w) :: 'a::len word) =
    word_of_int (take_bit LENGTH('a) (numeral w) div 2)"
  by (rule bit_word_eqI) (simp add: bit_simps flip: bit_Suc)

lemma sshiftr1_sbintr:
  "(sshiftr1 (numeral w) :: 'a::len word) =
    word_of_int (signed_take_bit (LENGTH('a) - 1) (numeral w) div 2)"
  apply (cases \<open>LENGTH('a)\<close>)
  apply simp_all
  apply (rule bit_word_eqI)
  apply (auto simp add: bit_simps min_def simp flip: bit_Suc elim: le_SucE)
  done

lemma shiftl1_wi:
  "shiftl1 (word_of_int w) = word_of_int (2 * w)"
  by transfer simp

lemma shiftl1_numeral:
  "shiftl1 (numeral w) = numeral (Num.Bit0 w)"
  unfolding word_numeral_alt shiftl1_wi by simp

lemma shiftl1_neg_numeral:
  "shiftl1 (- numeral w) = - numeral (Num.Bit0 w)"
  unfolding word_neg_numeral_alt shiftl1_wi by simp

lemma shiftl1_0:
  "shiftl1 0 = 0"
  by (fact mult_zero_right)

lemma shiftl1_def_u:
  "shiftl1 w = word_of_int (2 * uint w)"
  by (fact shiftl1_eq)

lemma shiftl1_def_s:
  "shiftl1 w = word_of_int (2 * sint w)"
  by simp

lemma shiftr1_0:
  "shiftr1 0 = 0"
  by (fact bits_div_0)

lemma sshiftr1_0:
  "sshiftr1 0 = 0"
  by (fact signed_drop_bit_of_0)

lemma sshiftr1_n1:
  "sshiftr1 (- 1) = - 1"
  by (fact signed_drop_bit_of_minus_1)

lemma uint_shiftr1:
  "uint (shiftr1 w) = uint w div 2"
  by (rule bit_eqI) (simp add: bit_simps flip: bit_Suc)

lemma shiftr1_div_2:
  "uint (shiftr1 w) = uint w div 2"
  by (fact uint_shiftr1)

lemma sshiftr1_div_2:
  "sint (sshiftr1 w) = sint w div 2"
  by (rule bit_eqI) (auto simp add: bit_simps ac_simps min_def simp flip: bit_Suc elim: le_SucE)

lemma bit_sshiftr1_iff:
  \<open>bit (sshiftr1 w) n \<longleftrightarrow> bit w (if n = LENGTH('a) - 1 then LENGTH('a) - 1 else Suc n)\<close>
    for w :: \<open>'a::len word\<close>
  by (auto simp add: bit_simps)

lemma bit_bshiftr1_iff:
  \<open>bit (bshiftr1 b w) n \<longleftrightarrow> b \<and> n = LENGTH('a) - 1 \<or> bit w (Suc n)\<close>
    for w :: \<open>'a::len word\<close>
  by (auto simp add: bit_simps simp flip: bit_Suc)

lemma nth_shiftl1:
  "bit (shiftl1 w) n \<longleftrightarrow> n < size w \<and> n > 0 \<and> bit w (n - 1)"
  by (auto simp add: word_size bit_simps)

lemma nth_shiftr1:
  "bit (shiftr1 w) n = bit w (Suc n)"
  by (simp add: bit_Suc)

lemma nth_sshiftr1: "bit (sshiftr1 w) n = (if n = size w - 1 then bit w n else bit w (Suc n))"
  by (auto simp add: word_size bit_simps)

lemma shiftl_power:
  "(shiftl1 ^^ x) (y::'a::len word) = 2 ^ x * y"
  by (induction x) simp_all

lemma le_shiftr1:
  \<open>shiftr1 u \<le> shiftr1 v\<close> if \<open>u \<le> v\<close>
  using that by (simp add: word_le_nat_alt unat_div div_le_mono)

lemma le_shiftr1':
  "\<lbrakk> shiftr1 u \<le> shiftr1 v ; shiftr1 u \<noteq> shiftr1 v \<rbrakk> \<Longrightarrow> u \<le> v"
  by (meson dual_order.antisym le_cases le_shiftr1)

abbreviation (input) setBit :: \<open>'a::len word \<Rightarrow> nat \<Rightarrow> 'a word\<close>
  where \<open>setBit w n \<equiv> set_bit n w\<close>

abbreviation (input) clearBit :: \<open>'a::len word \<Rightarrow> nat \<Rightarrow> 'a word\<close>
  where \<open>clearBit w n \<equiv> unset_bit n w\<close>

lemma bit_setBit_iff:
  \<open>bit (setBit w m) n \<longleftrightarrow> (m = n \<and> n < LENGTH('a) \<or> bit w n)\<close>
  for w :: \<open>'a::len word\<close>
  by (auto simp add: bit_simps)

lemma bit_clearBit_iff:
  \<open>bit (clearBit w m) n \<longleftrightarrow> m \<noteq> n \<and> bit w n\<close>
  for w :: \<open>'a::len word\<close>
  by (auto simp add: bit_simps)

lemmas less_def = less_eq [symmetric]
lemmas le_def = not_less [symmetric, where ?'a = nat]

end


(*  Title:      HOL/UNITY/WFair.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1998  University of Cambridge

Conditional Fairness versions of transient, ensures, leadsTo.

From Misra, "A Logic for Concurrent Programming", 1994
*)

section{*Progress*}

theory WFair imports UNITY begin

text{*The original version of this theory was based on weak fairness.  (Thus,
the entire UNITY development embodied this assumption, until February 2003.)
Weak fairness states that if a command is enabled continuously, then it is
eventually executed.  Ernie Cohen suggested that I instead adopt unconditional
fairness: every command is executed infinitely often.

In fact, Misra's paper on "Progress" seems to be ambiguous about the correct
interpretation, and says that the two forms of fairness are equivalent.  They
differ only on their treatment of partial transitions, which under
unconditional fairness behave magically.  That is because if there are partial
transitions then there may be no fair executions, making all leads-to
properties hold vacuously.

Unconditional fairness has some great advantages.  By distinguishing partial
transitions from total ones that are the identity on part of their domain, it
is more expressive.  Also, by simplifying the definition of the transient
property, it simplifies many proofs.  A drawback is that some laws only hold
under the assumption that all transitions are total.  The best-known of these
is the impossibility law for leads-to.
*}

definition

  --{*This definition specifies conditional fairness.  The rest of the theory
      is generic to all forms of fairness.  To get weak fairness, conjoin
      the inclusion below with @{term "A \<subseteq> Domain act"}, which specifies
      that the action is enabled over all of @{term A}.*}
  transient :: "'a set => 'a program set" where
    "transient A == {F. \<exists>act\<in>Acts F. act``A \<subseteq> -A}"

definition
  ensures :: "['a set, 'a set] => 'a program set"       (infixl "ensures" 60) where
    "A ensures B == (A-B co A \<union> B) \<inter> transient (A-B)"

inductive_set
  leads :: "'a program => ('a set * 'a set) set"
    --{*LEADS-TO constant for the inductive definition*}
  for F :: "'a program"
  where

    Basis:  "F \<in> A ensures B ==> (A,B) \<in> leads F"

  | Trans:  "[| (A,B) \<in> leads F;  (B,C) \<in> leads F |] ==> (A,C) \<in> leads F"

  | Union:  "\<forall>A \<in> S. (A,B) \<in> leads F ==> (Union S, B) \<in> leads F"

definition leadsTo :: "['a set, 'a set] => 'a program set" (infixl "leadsTo" 60) where
     --{*visible version of the LEADS-TO relation*}
    "A leadsTo B == {F. (A,B) \<in> leads F}"

definition wlt :: "['a program, 'a set] => 'a set" where
     --{*predicate transformer: the largest set that leads to @{term B}*}
    "wlt F B == Union {A. F \<in> A leadsTo B}"

notation (xsymbols)
  leadsTo  (infixl "\<longmapsto>" 60)

subsection{*transient*}

lemma stable_transient:
    "[| F \<in> stable A; F \<in> transient A |] ==> \<exists>act\<in>Acts F. A \<subseteq> - (Domain act)"
apply (simp add: stable_def constrains_def transient_def, clarify)
apply (rule rev_bexI, auto)
done

lemma stable_transient_empty:
    "[| F \<in> stable A; F \<in> transient A; all_total F |] ==> A = {}"
apply (drule stable_transient, assumption)
apply (simp add: all_total_def)
done

lemma transient_strengthen:
    "[| F \<in> transient A; B \<subseteq> A |] ==> F \<in> transient B"
apply (unfold transient_def, clarify)
apply (blast intro!: rev_bexI)
done

lemma transientI:
    "[| act: Acts F;  act``A \<subseteq> -A |] ==> F \<in> transient A"
by (unfold transient_def, blast)

lemma transientE:
    "[| F \<in> transient A;
        !!act. [| act: Acts F;  act``A \<subseteq> -A |] ==> P |]
     ==> P"
by (unfold transient_def, blast)

lemma transient_empty [simp]: "transient {} = UNIV"
by (unfold transient_def, auto)

text{*This equation recovers the notion of weak fairness.  A totalized
      program satisfies a transient assertion just if the original program
      contains a suitable action that is also enabled.*}
lemma totalize_transient_iff:
   "(totalize F \<in> transient A) = (\<exists>act\<in>Acts F. A \<subseteq> Domain act & act``A \<subseteq> -A)"
apply (simp add: totalize_def totalize_act_def transient_def
                 Un_Image, safe)
apply (blast intro!: rev_bexI)+
done

lemma totalize_transientI:
    "[| act: Acts F;  A \<subseteq> Domain act;  act``A \<subseteq> -A |]
     ==> totalize F \<in> transient A"
by (simp add: totalize_transient_iff, blast)

subsection{*ensures*}

lemma ensuresI:
    "[| F \<in> (A-B) co (A \<union> B); F \<in> transient (A-B) |] ==> F \<in> A ensures B"
by (unfold ensures_def, blast)

lemma ensuresD:
    "F \<in> A ensures B ==> F \<in> (A-B) co (A \<union> B) & F \<in> transient (A-B)"
by (unfold ensures_def, blast)

lemma ensures_weaken_R:
    "[| F \<in> A ensures A'; A'<=B' |] ==> F \<in> A ensures B'"
apply (unfold ensures_def)
apply (blast intro: constrains_weaken transient_strengthen)
done

text{*The L-version (precondition strengthening) fails, but we have this*}
lemma stable_ensures_Int:
    "[| F \<in> stable C;  F \<in> A ensures B |]
    ==> F \<in> (C \<inter> A) ensures (C \<inter> B)"
apply (unfold ensures_def)
apply (auto simp add: ensures_def Int_Un_distrib [symmetric] Diff_Int_distrib [symmetric])
prefer 2 apply (blast intro: transient_strengthen)
apply (blast intro: stable_constrains_Int constrains_weaken)
done

lemma stable_transient_ensures:
     "[| F \<in> stable A;  F \<in> transient C;  A \<subseteq> B \<union> C |] ==> F \<in> A ensures B"
apply (simp add: ensures_def stable_def)
apply (blast intro: constrains_weaken transient_strengthen)
done

lemma ensures_eq: "(A ensures B) = (A unless B) \<inter> transient (A-B)"
by (simp (no_asm) add: ensures_def unless_def)

subsection{*leadsTo*}

lemma leadsTo_Basis [intro]: "F \<in> A ensures B ==> F \<in> A leadsTo B"
apply (unfold leadsTo_def)
apply (blast intro: leads.Basis)
done

lemma leadsTo_Trans:
     "[| F \<in> A leadsTo B;  F \<in> B leadsTo C |] ==> F \<in> A leadsTo C"
apply (unfold leadsTo_def)
apply (blast intro: leads.Trans)
done

lemma leadsTo_Basis':
     "[| F \<in> A co A \<union> B; F \<in> transient A |] ==> F \<in> A leadsTo B"
apply (drule_tac B = "A-B" in constrains_weaken_L)
apply (drule_tac [2] B = "A-B" in transient_strengthen)
apply (rule_tac [3] ensuresI [THEN leadsTo_Basis])
apply (blast+)
done

lemma transient_imp_leadsTo: "F \<in> transient A ==> F \<in> A leadsTo (-A)"
by (simp (no_asm_simp) add: leadsTo_Basis ensuresI Compl_partition)

text{*Useful with cancellation, disjunction*}
lemma leadsTo_Un_duplicate: "F \<in> A leadsTo (A' \<union> A') ==> F \<in> A leadsTo A'"
by (simp add: Un_ac)

lemma leadsTo_Un_duplicate2:
     "F \<in> A leadsTo (A' \<union> C \<union> C) ==> F \<in> A leadsTo (A' \<union> C)"
by (simp add: Un_ac)

text{*The Union introduction rule as we should have liked to state it*}
lemma leadsTo_Union:
    "(!!A. A \<in> S ==> F \<in> A leadsTo B) ==> F \<in> (Union S) leadsTo B"
apply (unfold leadsTo_def)
apply (blast intro: leads.Union)
done

lemma leadsTo_Union_Int:
 "(!!A. A \<in> S ==> F \<in> (A \<inter> C) leadsTo B) ==> F \<in> (Union S \<inter> C) leadsTo B"
apply (unfold leadsTo_def)
apply (simp only: Int_Union_Union)
apply (blast intro: leads.Union)
done

lemma leadsTo_UN:
    "(!!i. i \<in> I ==> F \<in> (A i) leadsTo B) ==> F \<in> (\<Union>i \<in> I. A i) leadsTo B"
apply (subst Union_image_eq [symmetric])
apply (blast intro: leadsTo_Union)
done

text{*Binary union introduction rule*}
lemma leadsTo_Un:
     "[| F \<in> A leadsTo C; F \<in> B leadsTo C |] ==> F \<in> (A \<union> B) leadsTo C"
  using leadsTo_Union [of "{A, B}" F C] by auto

lemma single_leadsTo_I:
     "(!!x. x \<in> A ==> F \<in> {x} leadsTo B) ==> F \<in> A leadsTo B"
by (subst UN_singleton [symmetric], rule leadsTo_UN, blast)

text{*The INDUCTION rule as we should have liked to state it*}
lemma leadsTo_induct:
  "[| F \<in> za leadsTo zb;
      !!A B. F \<in> A ensures B ==> P A B;
      !!A B C. [| F \<in> A leadsTo B; P A B; F \<in> B leadsTo C; P B C |]
               ==> P A C;
      !!B S. \<forall>A \<in> S. F \<in> A leadsTo B & P A B ==> P (Union S) B
   |] ==> P za zb"
apply (unfold leadsTo_def)
apply (drule CollectD, erule leads.induct)
apply (blast+)
done

lemma subset_imp_ensures: "A \<subseteq> B ==> F \<in> A ensures B"
by (unfold ensures_def constrains_def transient_def, blast)

lemmas subset_imp_leadsTo = subset_imp_ensures [THEN leadsTo_Basis]

lemmas leadsTo_refl = subset_refl [THEN subset_imp_leadsTo]

lemmas empty_leadsTo = empty_subsetI [THEN subset_imp_leadsTo, simp]

lemmas leadsTo_UNIV = subset_UNIV [THEN subset_imp_leadsTo, simp]

(** Variant induction rule: on the preconditions for B **)

text{*Lemma is the weak version: can't see how to do it in one step*}
lemma leadsTo_induct_pre_lemma:
  "[| F \<in> za leadsTo zb;
      P zb;
      !!A B. [| F \<in> A ensures B;  P B |] ==> P A;
      !!S. \<forall>A \<in> S. P A ==> P (Union S)
   |] ==> P za"
txt{*by induction on this formula*}
apply (subgoal_tac "P zb --> P za")
txt{*now solve first subgoal: this formula is sufficient*}
apply (blast intro: leadsTo_refl)
apply (erule leadsTo_induct)
apply (blast+)
done

lemma leadsTo_induct_pre:
  "[| F \<in> za leadsTo zb;
      P zb;
      !!A B. [| F \<in> A ensures B;  F \<in> B leadsTo zb;  P B |] ==> P A;
      !!S. \<forall>A \<in> S. F \<in> A leadsTo zb & P A ==> P (Union S)
   |] ==> P za"
apply (subgoal_tac "F \<in> za leadsTo zb & P za")
apply (erule conjunct2)
apply (erule leadsTo_induct_pre_lemma)
prefer 3 apply (blast intro: leadsTo_Union)
prefer 2 apply (blast intro: leadsTo_Trans)
apply (blast intro: leadsTo_refl)
done

lemma leadsTo_weaken_R: "[| F \<in> A leadsTo A'; A'<=B' |] ==> F \<in> A leadsTo B'"
by (blast intro: subset_imp_leadsTo leadsTo_Trans)

lemma leadsTo_weaken_L:
     "[| F \<in> A leadsTo A'; B \<subseteq> A |] ==> F \<in> B leadsTo A'"
by (blast intro: leadsTo_Trans subset_imp_leadsTo)

text{*Distributes over binary unions*}
lemma leadsTo_Un_distrib:
     "F \<in> (A \<union> B) leadsTo C  =  (F \<in> A leadsTo C & F \<in> B leadsTo C)"
by (blast intro: leadsTo_Un leadsTo_weaken_L)

lemma leadsTo_UN_distrib:
     "F \<in> (\<Union>i \<in> I. A i) leadsTo B  =  (\<forall>i \<in> I. F \<in> (A i) leadsTo B)"
by (blast intro: leadsTo_UN leadsTo_weaken_L)

lemma leadsTo_Union_distrib:
     "F \<in> (Union S) leadsTo B  =  (\<forall>A \<in> S. F \<in> A leadsTo B)"
by (blast intro: leadsTo_Union leadsTo_weaken_L)

lemma leadsTo_weaken:
     "[| F \<in> A leadsTo A'; B \<subseteq> A; A'<=B' |] ==> F \<in> B leadsTo B'"
by (blast intro: leadsTo_weaken_R leadsTo_weaken_L leadsTo_Trans)

text{*Set difference: maybe combine with @{text leadsTo_weaken_L}??*}
lemma leadsTo_Diff:
     "[| F \<in> (A-B) leadsTo C; F \<in> B leadsTo C |]   ==> F \<in> A leadsTo C"
by (blast intro: leadsTo_Un leadsTo_weaken)

lemma leadsTo_UN_UN:
   "(!! i. i \<in> I ==> F \<in> (A i) leadsTo (A' i))
    ==> F \<in> (\<Union>i \<in> I. A i) leadsTo (\<Union>i \<in> I. A' i)"
apply (simp only: Union_image_eq [symmetric])
apply (blast intro: leadsTo_Union leadsTo_weaken_R)
done

text{*Binary union version*}
lemma leadsTo_Un_Un:
     "[| F \<in> A leadsTo A'; F \<in> B leadsTo B' |]
      ==> F \<in> (A \<union> B) leadsTo (A' \<union> B')"
by (blast intro: leadsTo_Un leadsTo_weaken_R)

(** The cancellation law **)

lemma leadsTo_cancel2:
     "[| F \<in> A leadsTo (A' \<union> B); F \<in> B leadsTo B' |]
      ==> F \<in> A leadsTo (A' \<union> B')"
by (blast intro: leadsTo_Un_Un subset_imp_leadsTo leadsTo_Trans)

lemma leadsTo_cancel_Diff2:
     "[| F \<in> A leadsTo (A' \<union> B); F \<in> (B-A') leadsTo B' |]
      ==> F \<in> A leadsTo (A' \<union> B')"
apply (rule leadsTo_cancel2)
prefer 2 apply assumption
apply (simp_all (no_asm_simp))
done

lemma leadsTo_cancel1:
     "[| F \<in> A leadsTo (B \<union> A'); F \<in> B leadsTo B' |]
    ==> F \<in> A leadsTo (B' \<union> A')"
apply (simp add: Un_commute)
apply (blast intro!: leadsTo_cancel2)
done

lemma leadsTo_cancel_Diff1:
     "[| F \<in> A leadsTo (B \<union> A'); F \<in> (B-A') leadsTo B' |]
    ==> F \<in> A leadsTo (B' \<union> A')"
apply (rule leadsTo_cancel1)
prefer 2 apply assumption
apply (simp_all (no_asm_simp))
done

text{*The impossibility law*}
lemma leadsTo_empty: "[|F \<in> A leadsTo {}; all_total F|] ==> A={}"
apply (erule leadsTo_induct_pre)
apply (simp_all add: ensures_def constrains_def transient_def all_total_def, clarify)
apply (drule bspec, assumption)+
apply blast
done

subsection{*PSP: Progress-Safety-Progress*}

text{*Special case of PSP: Misra's "stable conjunction"*}
lemma psp_stable:
   "[| F \<in> A leadsTo A'; F \<in> stable B |]
    ==> F \<in> (A \<inter> B) leadsTo (A' \<inter> B)"
apply (unfold stable_def)
apply (erule leadsTo_induct)
prefer 3 apply (blast intro: leadsTo_Union_Int)
prefer 2 apply (blast intro: leadsTo_Trans)
apply (rule leadsTo_Basis)
apply (simp add: ensures_def Diff_Int_distrib2 [symmetric] Int_Un_distrib2 [symmetric])
apply (blast intro: transient_strengthen constrains_Int)
done

lemma psp_stable2:
   "[| F \<in> A leadsTo A'; F \<in> stable B |] ==> F \<in> (B \<inter> A) leadsTo (B \<inter> A')"
by (simp add: psp_stable Int_ac)

lemma psp_ensures:
   "[| F \<in> A ensures A'; F \<in> B co B' |]
    ==> F \<in> (A \<inter> B') ensures ((A' \<inter> B) \<union> (B' - B))"
apply (unfold ensures_def constrains_def, clarify) (*speeds up the proof*)
apply (blast intro: transient_strengthen)
done

lemma psp:
     "[| F \<in> A leadsTo A'; F \<in> B co B' |]
      ==> F \<in> (A \<inter> B') leadsTo ((A' \<inter> B) \<union> (B' - B))"
apply (erule leadsTo_induct)
  prefer 3 apply (blast intro: leadsTo_Union_Int)
 txt{*Basis case*}
 apply (blast intro: psp_ensures)
txt{*Transitivity case has a delicate argument involving "cancellation"*}
apply (rule leadsTo_Un_duplicate2)
apply (erule leadsTo_cancel_Diff1)
apply (simp add: Int_Diff Diff_triv)
apply (blast intro: leadsTo_weaken_L dest: constrains_imp_subset)
done

lemma psp2:
     "[| F \<in> A leadsTo A'; F \<in> B co B' |]
    ==> F \<in> (B' \<inter> A) leadsTo ((B \<inter> A') \<union> (B' - B))"
by (simp (no_asm_simp) add: psp Int_ac)

lemma psp_unless:
   "[| F \<in> A leadsTo A';  F \<in> B unless B' |]
    ==> F \<in> (A \<inter> B) leadsTo ((A' \<inter> B) \<union> B')"

apply (unfold unless_def)
apply (drule psp, assumption)
apply (blast intro: leadsTo_weaken)
done

subsection{*Proving the induction rules*}

(** The most general rule: r is any wf relation; f is any variant function **)

lemma leadsTo_wf_induct_lemma:
     "[| wf r;
         \<forall>m. F \<in> (A \<inter> f-`{m}) leadsTo
                    ((A \<inter> f-`(r^-1 `` {m})) \<union> B) |]
      ==> F \<in> (A \<inter> f-`{m}) leadsTo B"
apply (erule_tac a = m in wf_induct)
apply (subgoal_tac "F \<in> (A \<inter> (f -` (r^-1 `` {x}))) leadsTo B")
 apply (blast intro: leadsTo_cancel1 leadsTo_Un_duplicate)
apply (subst vimage_eq_UN)
apply (simp only: UN_simps [symmetric])
apply (blast intro: leadsTo_UN)
done

(** Meta or object quantifier ? **)
lemma leadsTo_wf_induct:
     "[| wf r;
         \<forall>m. F \<in> (A \<inter> f-`{m}) leadsTo
                    ((A \<inter> f-`(r^-1 `` {m})) \<union> B) |]
      ==> F \<in> A leadsTo B"
apply (rule_tac t = A in subst)
 defer 1
 apply (rule leadsTo_UN)
 apply (erule leadsTo_wf_induct_lemma)
 apply assumption
apply fast (*Blast_tac: Function unknown's argument not a parameter*)
done

lemma bounded_induct:
     "[| wf r;
         \<forall>m \<in> I. F \<in> (A \<inter> f-`{m}) leadsTo
                      ((A \<inter> f-`(r^-1 `` {m})) \<union> B) |]
      ==> F \<in> A leadsTo ((A - (f-`I)) \<union> B)"
apply (erule leadsTo_wf_induct, safe)
apply (case_tac "m \<in> I")
apply (blast intro: leadsTo_weaken)
apply (blast intro: subset_imp_leadsTo)
done

(*Alternative proof is via the lemma F \<in> (A \<inter> f-`(lessThan m)) leadsTo B*)
lemma lessThan_induct:
     "[| !!m::nat. F \<in> (A \<inter> f-`{m}) leadsTo ((A \<inter> f-`{..<m}) \<union> B) |]
      ==> F \<in> A leadsTo B"
apply (rule wf_less_than [THEN leadsTo_wf_induct])
apply (simp (no_asm_simp))
apply blast
done

lemma lessThan_bounded_induct:
     "!!l::nat. [| \<forall>m \<in> greaterThan l.
            F \<in> (A \<inter> f-`{m}) leadsTo ((A \<inter> f-`(lessThan m)) \<union> B) |]
      ==> F \<in> A leadsTo ((A \<inter> (f-`(atMost l))) \<union> B)"
apply (simp only: Diff_eq [symmetric] vimage_Compl Compl_greaterThan [symmetric])
apply (rule wf_less_than [THEN bounded_induct])
apply (simp (no_asm_simp))
done

lemma greaterThan_bounded_induct:
     "(!!l::nat. \<forall>m \<in> lessThan l.
                 F \<in> (A \<inter> f-`{m}) leadsTo ((A \<inter> f-`(greaterThan m)) \<union> B))
      ==> F \<in> A leadsTo ((A \<inter> (f-`(atLeast l))) \<union> B)"
apply (rule_tac f = f and f1 = "%k. l - k"
       in wf_less_than [THEN wf_inv_image, THEN leadsTo_wf_induct])
apply (simp (no_asm) add:Image_singleton)
apply clarify
apply (case_tac "m<l")
 apply (blast intro: leadsTo_weaken_R diff_less_mono2)
apply (blast intro: not_leE subset_imp_leadsTo)
done

subsection{*wlt*}

text{*Misra's property W3*}
lemma wlt_leadsTo: "F \<in> (wlt F B) leadsTo B"
apply (unfold wlt_def)
apply (blast intro!: leadsTo_Union)
done

lemma leadsTo_subset: "F \<in> A leadsTo B ==> A \<subseteq> wlt F B"
apply (unfold wlt_def)
apply (blast intro!: leadsTo_Union)
done

text{*Misra's property W2*}
lemma leadsTo_eq_subset_wlt: "F \<in> A leadsTo B = (A \<subseteq> wlt F B)"
by (blast intro!: leadsTo_subset wlt_leadsTo [THEN leadsTo_weaken_L])

text{*Misra's property W4*}
lemma wlt_increasing: "B \<subseteq> wlt F B"
apply (simp (no_asm_simp) add: leadsTo_eq_subset_wlt [symmetric] subset_imp_leadsTo)
done

text{*Used in the Trans case below*}
lemma lemma1:
   "[| B \<subseteq> A2;
       F \<in> (A1 - B) co (A1 \<union> B);
       F \<in> (A2 - C) co (A2 \<union> C) |]
    ==> F \<in> (A1 \<union> A2 - C) co (A1 \<union> A2 \<union> C)"
by (unfold constrains_def, clarify,  blast)

text{*Lemma (1,2,3) of Misra's draft book, Chapter 4, "Progress"*}
lemma leadsTo_123:
     "F \<in> A leadsTo A'
      ==> \<exists>B. A \<subseteq> B & F \<in> B leadsTo A' & F \<in> (B-A') co (B \<union> A')"
apply (erule leadsTo_induct)
  txt{*Basis*}
  apply (blast dest: ensuresD)
 txt{*Trans*}
 apply clarify
 apply (rule_tac x = "Ba \<union> Bb" in exI)
 apply (blast intro: lemma1 leadsTo_Un_Un leadsTo_cancel1 leadsTo_Un_duplicate)
txt{*Union*}
apply (clarify dest!: ball_conj_distrib [THEN iffD1] bchoice)
apply (rule_tac x = "\<Union>A \<in> S. f A" in exI)
apply (auto intro: leadsTo_UN)
(*Blast_tac says PROOF FAILED*)
apply (rule_tac I1=S and A1="%i. f i - B" and A'1="%i. f i \<union> B"
       in constrains_UN [THEN constrains_weaken], auto)
done

text{*Misra's property W5*}
lemma wlt_constrains_wlt: "F \<in> (wlt F B - B) co (wlt F B)"
proof -
  from wlt_leadsTo [of F B, THEN leadsTo_123]
  show ?thesis
  proof (elim exE conjE)
(* assumes have to be in exactly the form as in the goal displayed at
   this point.  Isar doesn't give you any automation. *)
    fix C
    assume wlt: "wlt F B \<subseteq> C"
       and lt:  "F \<in> C leadsTo B"
       and co:  "F \<in> C - B co C \<union> B"
    have eq: "C = wlt F B"
    proof -
      from lt and wlt show ?thesis
           by (blast dest: leadsTo_eq_subset_wlt [THEN iffD1])
    qed
    from co show ?thesis by (simp add: eq wlt_increasing Un_absorb2)
  qed
qed

subsection{*Completion: Binary and General Finite versions*}

lemma completion_lemma :
     "[| W = wlt F (B' \<union> C);
       F \<in> A leadsTo (A' \<union> C);  F \<in> A' co (A' \<union> C);
       F \<in> B leadsTo (B' \<union> C);  F \<in> B' co (B' \<union> C) |]
    ==> F \<in> (A \<inter> B) leadsTo ((A' \<inter> B') \<union> C)"
apply (subgoal_tac "F \<in> (W-C) co (W \<union> B' \<union> C) ")
 prefer 2
 apply (blast intro: wlt_constrains_wlt [THEN [2] constrains_Un,
                                         THEN constrains_weaken])
apply (subgoal_tac "F \<in> (W-C) co W")
 prefer 2
 apply (simp add: wlt_increasing Un_assoc Un_absorb2)
apply (subgoal_tac "F \<in> (A \<inter> W - C) leadsTo (A' \<inter> W \<union> C) ")
 prefer 2 apply (blast intro: wlt_leadsTo psp [THEN leadsTo_weaken])
(** LEVEL 6 **)
apply (subgoal_tac "F \<in> (A' \<inter> W \<union> C) leadsTo (A' \<inter> B' \<union> C) ")
 prefer 2
 apply (rule leadsTo_Un_duplicate2)
 apply (blast intro: leadsTo_Un_Un wlt_leadsTo
                         [THEN psp2, THEN leadsTo_weaken] leadsTo_refl)
apply (drule leadsTo_Diff)
apply (blast intro: subset_imp_leadsTo)
apply (subgoal_tac "A \<inter> B \<subseteq> A \<inter> W")
 prefer 2
 apply (blast dest!: leadsTo_subset intro!: subset_refl [THEN Int_mono])
apply (blast intro: leadsTo_Trans subset_imp_leadsTo)
done

lemmas completion = completion_lemma [OF refl]

lemma finite_completion_lemma:
     "finite I ==> (\<forall>i \<in> I. F \<in> (A i) leadsTo (A' i \<union> C)) -->
                   (\<forall>i \<in> I. F \<in> (A' i) co (A' i \<union> C)) -->
                   F \<in> (\<Inter>i \<in> I. A i) leadsTo ((\<Inter>i \<in> I. A' i) \<union> C)"
apply (erule finite_induct, auto)
apply (rule completion)
   prefer 4
   apply (simp only: INT_simps [symmetric])
   apply (rule constrains_INT, auto)
done

lemma finite_completion:
     "[| finite I;
         !!i. i \<in> I ==> F \<in> (A i) leadsTo (A' i \<union> C);
         !!i. i \<in> I ==> F \<in> (A' i) co (A' i \<union> C) |]
      ==> F \<in> (\<Inter>i \<in> I. A i) leadsTo ((\<Inter>i \<in> I. A' i) \<union> C)"
by (blast intro: finite_completion_lemma [THEN mp, THEN mp])

lemma stable_completion:
     "[| F \<in> A leadsTo A';  F \<in> stable A';
         F \<in> B leadsTo B';  F \<in> stable B' |]
    ==> F \<in> (A \<inter> B) leadsTo (A' \<inter> B')"
apply (unfold stable_def)
apply (rule_tac C1 = "{}" in completion [THEN leadsTo_weaken_R])
apply (force+)
done

lemma finite_stable_completion:
     "[| finite I;
         !!i. i \<in> I ==> F \<in> (A i) leadsTo (A' i);
         !!i. i \<in> I ==> F \<in> stable (A' i) |]
      ==> F \<in> (\<Inter>i \<in> I. A i) leadsTo (\<Inter>i \<in> I. A' i)"
apply (unfold stable_def)
apply (rule_tac C1 = "{}" in finite_completion [THEN leadsTo_weaken_R])
apply (simp_all (no_asm_simp))
apply blast+
done

end


(*
 * Copyright 2019, NTU
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 *  Author: Albert Rizaldi, NTU Singapore
 *)

theory Dflipflop_Typed2
  imports VHDL_Hoare_Typed
begin

text \<open>datatype for all signals\<close>

datatype sig = D | CLK | OUT

definition dflipflop :: "sig conc_stmt" where
  "dflipflop \<equiv> process {CLK} : Bguarded (Bsig CLK) (Bassign_trans OUT (Bsig D) 1) Bnull"

text \<open>The following positive edge is only defined for a scalar signal.\<close>

abbreviation is_posedge2 :: "'signal worldline_init \<Rightarrow> 'signal \<Rightarrow> nat \<Rightarrow>  bool" where
  "is_posedge2 w s j \<equiv> (snd w s (j - 1) = Bv False \<and> snd w s j = Bv True)"

locale ff_typed =
  fixes \<Gamma> :: "sig tyenv"
  assumes tyd: "\<Gamma> D = Bty" and tyclk: "\<Gamma> CLK = Bty" and tyout: "\<Gamma> OUT = Bty"
begin

definition inv :: "sig assn2" where
  "inv tw \<equiv> 1 < fst tw \<longrightarrow> wline_of tw OUT (fst tw) = (if is_posedge2 (snd tw) CLK (fst tw - 1) then wline_of tw D (fst tw - 1) else wline_of tw OUT (fst tw - 1))"

definition inv2 :: "sig assn2" where
  "inv2 tw \<equiv> disjnt {CLK} (event_of tw) \<or> wline_of tw CLK (fst tw) \<noteq> (Bv True) \<longrightarrow> (\<forall>i > fst tw. wline_of tw OUT i = wline_of tw OUT (fst tw))"

lemma conc_stmt_wf_mult:
  "conc_stmt_wf dflipflop"
  unfolding dflipflop_def conc_stmt_wf_def by auto

lemma nonneg_delay_conc_mult:
  "nonneg_delay_conc dflipflop"
  unfolding dflipflop_def by auto

lemma nonneg_delay_conc_mult':
  "  nonneg_delay_conc ( process {CLK} : Bguarded (Bsig CLK) (Bassign_trans OUT (Bsig D) 1) Bnull)"
  using nonneg_delay_conc_mult unfolding dflipflop_def by auto

lemma well_typed:
  "seq_wt \<Gamma> (Bguarded (Bsig CLK) (Bassign_trans OUT (Bsig D) 1) Bnull)"
  by (metis bexp_wt.intros(3) seq_wt.intros(1) seq_wt.intros(3) seq_wt.intros(4) tyclk tyd tyout)

lemma conc_wt_mult:
  "conc_wt \<Gamma> dflipflop"
  unfolding dflipflop_def by (meson conc_wt.intros(1) well_typed)

lemma conc_wt_mult':
  "conc_wt \<Gamma> ( process {CLK} : Bguarded (Bsig CLK) (Bassign_trans OUT (Bsig D) 1) Bnull)"
  using conc_wt_mult unfolding dflipflop_def by auto

lemma inv_next_time:
  fixes tw
  assumes "\<not> disjnt {CLK} (event_of tw)"
  defines "v \<equiv> eval_world_raw2 tw (Bsig D)"
  assumes "eval_world_raw2 tw (Bsig CLK) = Bv True"
  defines "tw' \<equiv> tw[OUT, 1 :=\<^sub>2 v]"
  assumes "wityping \<Gamma> (snd tw)"
  assumes "inv tw"
  shows   "inv (fst tw' + 1, snd tw')"
proof -
  { assume "1 < fst tw' + 1"
    hence "0 < fst tw"
      unfolding tw'_def worldline_upd2_def worldline_upd_def by auto
    have bexpIN1: "bexp_wt \<Gamma> (Bsig CLK) (Bty)"
      using ff_typed_axioms unfolding ff_typed_def by (metis bexp_wt.intros(3))+
    have *: "wline_of tw CLK (fst tw) \<noteq> wline_of tw CLK (fst tw - 1)"
      using assms(1) `0 < fst tw` unfolding event_of_alt_def by auto
    have **: "wline_of tw CLK (fst tw) = Bv True"
      using assms(3) by auto
    have "is_posedge2 (snd tw) CLK (fst tw)"
    proof -
      from * have neq: "wline_of tw CLK (fst tw) \<noteq> wline_of tw CLK (fst tw - 1)"
        by auto
      obtain bool where "wline_of tw CLK (fst tw - 1) = Bv bool"
        using eval_world_raw_bv[OF bexpIN1 `wityping \<Gamma> (snd tw)`, of "fst tw - 1"] by auto
      then show ?thesis
        using ** neq by auto
    qed
    have "wline_of tw' OUT (fst tw + 1) = v"
      unfolding tw'_def worldline_upd2_def worldline_upd_def by auto
    also have "... = wline_of tw D (fst tw)"
      using assms(2) unfolding v_def eval_world_raw.simps eval_arith.simps  Let_def comp_def by auto
    also have "... = (if is_posedge2 (snd tw) CLK (fst tw) then wline_of tw D (fst tw) else wline_of tw OUT (fst tw))"
      using `is_posedge2 (snd tw) CLK (fst tw)` by auto
    finally have "wline_of tw' OUT (fst tw + 1) = (if is_posedge2 (snd tw) CLK (fst tw) then wline_of tw D (fst tw) else wline_of tw OUT (fst tw))"
      by auto }
  thus ?thesis
    unfolding inv_def tw'_def worldline_upd2_def worldline_upd_def  by fastforce
qed

lemma inv2_next_time:
  fixes tw v
  defines "tw' \<equiv> tw[OUT, 1 :=\<^sub>2 v]"
  shows   "inv2 (fst tw' + 1, snd tw')"
  unfolding inv2_def  tw'_def worldline_upd2_def worldline_upd_def by auto

lemma conc_hoare:
  "\<And>tw. inv tw \<and> inv2 tw \<and> (disjnt {CLK} (event_of tw) \<or> wline_of tw CLK (fst tw) \<noteq> (Bv True)) \<Longrightarrow> inv (fst tw + 1, snd tw)"
proof -
  fix tw
  assume "inv tw \<and> inv2 tw \<and> (disjnt {CLK} (event_of tw) \<or> wline_of tw CLK (fst tw) \<noteq> (Bv True))"
  hence "inv tw" and "inv2 tw" and "disjnt {CLK} (event_of tw) \<or> wline_of tw CLK (fst tw) \<noteq> (Bv True)"
    by auto
  { assume "1 < fst tw"
    have "wline_of tw OUT (fst tw + 1) = wline_of tw OUT (fst tw)"
      using `inv2 tw` `disjnt {CLK} (event_of tw) \<or> wline_of tw CLK (fst tw) \<noteq> (Bv True)` unfolding inv2_def by auto
    also have *: "... = (if is_posedge2 (snd tw) CLK (get_time tw - 1) then wline_of tw D (get_time tw - 1) else wline_of tw OUT (get_time tw - 1))"
      using `inv tw` `1 < fst tw` unfolding inv_def by auto
    also have "... = (if is_posedge2 (snd tw) CLK (get_time tw) then wline_of tw D (get_time tw) else wline_of tw OUT (get_time tw))"
      using `disjnt {CLK} (event_of tw) \<or> wline_of tw CLK (fst tw) \<noteq> (Bv True)`  unfolding event_of_alt_def   using *
      by (smt comp_apply diff_is_0_eq' disjnt_insert1 le_numeral_extra(1) mem_Collect_eq val.inject(1))
    finally have "wline_of tw OUT (fst tw + 1) = (if is_posedge2 (snd tw) CLK (get_time tw) then wline_of tw D (get_time tw) else wline_of tw OUT (get_time tw))"
      by auto }
  thus "inv (fst tw + 1, snd tw)"
    unfolding inv_def using \<open>local.inv tw\<close> local.inv_def
    by (smt \<open>local.inv tw \<and> inv2 tw \<and> (disjnt {CLK} (event_of tw) \<or> wline_of tw CLK (get_time tw) \<noteq>
    Bv True)\<close> add_diff_cancel_right' comp_def disjnt_insert1 event_of_alt_def1 fst_conv inv2_def
    less_add_one mem_Collect_eq snd_conv val.inject(1) zero_less_diff)
qed

lemma conc_hoare2:
  "\<And>tw. inv2 tw \<and> (disjnt {CLK} (event_of tw) \<or> wline_of tw CLK (fst tw) \<noteq> (Bv True)) \<Longrightarrow> inv2 (fst tw + 1, snd tw)"
  unfolding inv2_def by auto

lemma conc_sim2':
  "\<Gamma> \<turnstile>\<^sub>s \<lbrace>\<lambda>tw. inv tw \<and> inv2 tw\<rbrace> dflipflop \<lbrace>\<lambda>tw. inv tw \<and> inv2 tw\<rbrace>"
  apply (rule While_Suc)
  apply (rule Conseq'[where P="wp3_conc \<Gamma> dflipflop (\<lambda>tw. inv  (fst tw + 1, snd tw) \<and>
                                                          inv2 (fst tw + 1, snd tw))", rotated])
  apply (rule wp3_conc_is_pre, rule conc_stmt_wf_mult, rule nonneg_delay_conc_mult, rule conc_wt_mult, simp)
  unfolding dflipflop_def  wp3_conc_single'[OF conc_wt_mult' nonneg_delay_conc_mult'] wp3_fun.simps
  using inv_next_time inv2_next_time conc_hoare conc_hoare2 by auto

subsection \<open>Initialisation satisfies @{term "inv"} and @{term "inv2"}\<close>

lemma nonneg_delay:
  "nonneg_delay ( Bguarded (Bsig CLK) (Bassign_trans OUT (Bsig D) 1) Bnull)"
  using nonneg_delay_conc_mult' by auto

lemma inv_next_time0:
  assumes "fst tw = 0"
  defines "v \<equiv> eval_world_raw2 tw (Bsig D)"
  defines "tw' \<equiv> tw[ OUT, 1 :=\<^sub>2 v]"
  shows   "inv (fst tw' + 1, snd tw')"
  unfolding inv_def by (simp add: assms(1) tw'_def)

lemma inv2_next_time0:
  assumes "fst tw = 0"
  assumes "eval_world_raw2 tw (Bsig CLK) \<noteq> Bv True"
  assumes "\<forall>i. wline_of tw OUT i = wline_of tw OUT 0"
  shows   "inv2 (fst tw + 1, snd tw)"
  using assms unfolding inv2_def  by (metis comp_apply snd_conv)

lemma inv_next_time0'':
  assumes "fst tw = 0"
  shows   "inv (fst tw + 1, snd tw)"
  unfolding inv_def  by (simp add: assms(1))

lemma init_sat_nand_inv_comb:
  "init_sim2_hoare_wt \<Gamma> (\<lambda>tw. fst tw = 0 \<and> (\<forall>i. wline_of tw OUT i = wline_of tw OUT 0)) dflipflop (\<lambda>tw. inv tw \<and> inv2 tw)"
  unfolding dflipflop_def
  apply (rule AssignI_suc, rule SingleI)
  apply (rule Conseq3[where Q="\<lambda>tw. inv (fst tw + 1, snd tw) \<and> inv2 (fst tw + 1, snd tw)", rotated])
  apply (rule wp3_fun_is_pre[OF well_typed nonneg_delay], simp)
  unfolding wp3_fun.simps using inv_next_time inv2_next_time inv_next_time0 inv2_next_time0 inv_next_time0''
  by auto

lemma
  assumes "sim_fin2 w (i + 2) dflipflop tw'"
  assumes "\<forall>i. wline_of (0, w) OUT i = wline_of (0, w) OUT 0"
  assumes " conc_wt \<Gamma> dflipflop" and "wityping \<Gamma> w"
  shows "wline_of tw' OUT (i + 2) = (if is_posedge2 (snd tw') CLK (i + 1) then wline_of tw' D (i + 1) else wline_of tw' OUT (i + 1))"
  using grand_correctness2[OF assms(1) assms(4) conc_stmt_wf_mult conc_wt_mult nonneg_delay_conc_mult conc_sim2' assms(2) init_sat_nand_inv_comb]
  unfolding inv_def
  by (metis (no_types, lifting) add.assoc add_diff_cancel_right' assms(1) discrete le_add2 one_add_one sim_fin2.cases world_maxtime_lt_fst_tres)

end


(*
   Title: The Calculus of Communicating Systems
   Author/Maintainer: Jesper Bengtson (jebe@itu.dk), 2012
*)
theory Weak_Cong_Sim
  imports Weak_Cong_Semantics Weak_Sim Strong_Sim
begin

definition weakCongSimulation :: "ccs \<Rightarrow> (ccs \<times> ccs) set \<Rightarrow> ccs \<Rightarrow> bool"   ("_ \<leadsto><_> _" [80, 80, 80] 80)
where
  "P \<leadsto><Rel> Q \<equiv> \<forall>a Q'. Q \<longmapsto>a \<prec> Q' \<longrightarrow> (\<exists>P'. P \<Longrightarrow>a \<prec> P' \<and> (P', Q') \<in> Rel)"

lemma weakSimI[case_names Sim]:
  fixes P   :: ccs
  and   Rel :: "(ccs \<times> ccs) set"
  and   Q   :: ccs

  assumes "\<And>\<alpha> Q'. Q \<longmapsto>\<alpha> \<prec> Q' \<Longrightarrow> \<exists>P'. P \<Longrightarrow>\<alpha> \<prec> P' \<and> (P', Q') \<in> Rel"

  shows "P \<leadsto><Rel> Q"
using assms
by(auto simp add: weakCongSimulation_def)

lemma weakSimE:
  fixes P   :: ccs
  and   Rel :: "(ccs \<times> ccs) set"
  and   Q   :: ccs
  and   \<alpha>   :: act
  and   Q'  :: ccs

  assumes "P \<leadsto><Rel> Q"
  and     "Q \<longmapsto>\<alpha> \<prec> Q'"

  obtains P' where "P \<Longrightarrow>\<alpha> \<prec> P'" and "(P', Q') \<in> Rel"
using assms
by(auto simp add: weakCongSimulation_def)

lemma simWeakSim:
  fixes P   :: ccs
  and   Rel :: "(ccs \<times> ccs) set"
  and   Q   :: ccs

  assumes "P \<leadsto>[Rel] Q"

  shows "P \<leadsto><Rel> Q"
using assms
by(rule_tac weakSimI, auto)
  (blast dest: simE transitionWeakCongTransition)

lemma weakCongSimWeakSim:
  fixes P   :: ccs
  and   Rel :: "(ccs \<times> ccs) set"
  and   Q   :: ccs

  assumes "P \<leadsto><Rel> Q"

  shows "P \<leadsto>\<^sup>^<Rel> Q"
using assms
by(rule_tac Weak_Sim.weakSimI, auto)
  (blast dest: weakSimE weakCongTransitionWeakTransition)

lemma test:
  assumes "P \<Longrightarrow>\<^sub>\<tau> P'"

  shows "P = P' \<or> (\<exists>P''. P \<longmapsto>\<tau> \<prec> P'' \<and> P'' \<Longrightarrow>\<^sub>\<tau> P')"
using assms
by(induct rule: tauChainInduct) auto

lemma tauChainCasesSym[consumes 1, case_names cTauNil cTauStep]:
  assumes "P \<Longrightarrow>\<^sub>\<tau> P'"
  and     "Prop P"
  and     "\<And>P''. \<lbrakk>P \<longmapsto>\<tau> \<prec> P''; P'' \<Longrightarrow>\<^sub>\<tau> P'\<rbrakk> \<Longrightarrow> Prop P'"

  shows "Prop P'"
using assms
by(blast dest: test)

lemma simE2:
  fixes P   :: ccs
  and   Rel :: "(ccs \<times> ccs) set"
  and   Q   :: ccs
  and   \<alpha>   :: act
  and   Q'  :: ccs

  assumes "P \<leadsto><Rel> Q"
  and     "Q \<Longrightarrow>\<alpha> \<prec> Q'"
  and     Sim: "\<And>R S. (R, S) \<in> Rel \<Longrightarrow> R \<leadsto>\<^sup>^<Rel> S"

  obtains P' where "P \<Longrightarrow>\<alpha> \<prec> P'" and "(P', Q') \<in> Rel"
proof -
  assume Goal: "\<And>P'. \<lbrakk>P \<Longrightarrow>\<alpha> \<prec> P'; (P', Q') \<in> Rel\<rbrakk> \<Longrightarrow> thesis"
  from \<open>Q \<Longrightarrow>\<alpha> \<prec> Q'\<close> obtain Q''' Q''
    where QChain: "Q \<Longrightarrow>\<^sub>\<tau> Q'''" and Q'''Trans: "Q''' \<longmapsto>\<alpha> \<prec> Q''" and Q''Chain: "Q'' \<Longrightarrow>\<^sub>\<tau> Q'"
    by(rule weakCongTransE)
  from QChain Q'''Trans show ?thesis
  proof(induct rule: tauChainCasesSym)
    case cTauNil
    from \<open>P \<leadsto><Rel> Q\<close> \<open>Q \<longmapsto>\<alpha> \<prec> Q''\<close> obtain P''' where PTrans: "P \<Longrightarrow>\<alpha> \<prec> P'''" and "(P''', Q'') \<in> Rel"
      by(blast dest: weakSimE)
    moreover from Q''Chain \<open>(P''', Q'') \<in> Rel\<close> Sim obtain P' where P''Chain: "P''' \<Longrightarrow>\<^sub>\<tau> P'" and "(P', Q') \<in> Rel"
      by(rule simTauChain)
    with PTrans P''Chain show ?thesis
      by(force intro: Goal simp add: weakCongTrans_def weakTrans_def)
  next
    case(cTauStep Q'''')
    from \<open>P \<leadsto><Rel> Q\<close> \<open>Q \<longmapsto>\<tau> \<prec> Q''''\<close> obtain P'''' where  PChain: "P \<Longrightarrow>\<tau> \<prec> P''''" and "(P'''', Q'''') \<in> Rel"
      by(drule_tac weakSimE) auto
    from \<open>Q'''' \<Longrightarrow>\<^sub>\<tau> Q'''\<close> \<open>(P'''', Q'''') \<in> Rel\<close> Sim obtain P''' where P''''Chain: "P'''' \<Longrightarrow>\<^sub>\<tau> P'''" and "(P''', Q''') \<in> Rel"
      by(rule simTauChain)
    from \<open>(P''', Q''') \<in> Rel\<close> have "P''' \<leadsto>\<^sup>^<Rel> Q'''" by(rule Sim)
    then obtain P'' where P'''Trans: "P''' \<Longrightarrow>\<^sup>^\<alpha> \<prec> P''" and "(P'', Q'') \<in> Rel" using Q'''Trans by(rule Weak_Sim.weakSimE)
    from Q''Chain \<open>(P'', Q'') \<in> Rel\<close> Sim obtain P' where P''Chain: "P'' \<Longrightarrow>\<^sub>\<tau> P'" and "(P', Q') \<in> Rel"
      by(rule simTauChain)
    from PChain P''''Chain P'''Trans P''Chain
    have "P \<Longrightarrow>\<alpha> \<prec> P'"
      apply(auto simp add: weakCongTrans_def weakTrans_def)
      apply(rule_tac x=P''aa in exI)
      apply auto
      defer
      apply blast
      by(auto simp add: tauChain_def)

    with \<open>(P', Q') \<in> Rel\<close> show ?thesis
      by(force intro: Goal simp add: weakCongTrans_def weakTrans_def)
  qed
qed

lemma reflexive:
  fixes P   :: ccs
  and   Rel :: "(ccs \<times> ccs) set"

  assumes "Id \<subseteq> Rel"

  shows "P \<leadsto><Rel> P"
using assms
by(auto simp add: weakCongSimulation_def intro: transitionWeakCongTransition)

lemma weakMonotonic:
  fixes P :: ccs
  and   A :: "(ccs \<times> ccs) set"
  and   Q :: ccs
  and   B :: "(ccs \<times> ccs) set"

  assumes "P \<leadsto><A> Q"
  and     "A \<subseteq> B"

  shows "P \<leadsto><B> Q"
using assms
by(fastforce simp add: weakCongSimulation_def)

end