(*
Author: Alexander Katovsky
*)

section "Yoneda"

theory Yoneda
imports NatTrans SetCat
begin

definition "YFtorNT' C f \<equiv> \<lparr>NTDom = Hom\<^bsub>C\<^esub>[\<emdash>,dom\<^bsub>C\<^esub> f] , NTCod = Hom\<^bsub>C\<^esub>[\<emdash>,cod\<^bsub>C\<^esub> f] ,
                       NatTransMap = \<lambda> B . Hom\<^bsub>C\<^esub>[B,f]\<rparr>"

definition "YFtorNT C f \<equiv> MakeNT (YFtorNT' C f)"

lemmas YFtorNT_defs = YFtorNT'_def YFtorNT_def MakeNT_def

lemma YFtorNTCatDom: "NTCatDom (YFtorNT C f) = Op C"
by (simp add: YFtorNT_defs NTCatDom_def HomFtorContraDom)

lemma YFtorNTCatCod: "NTCatCod (YFtorNT C f) = SET"
by (simp add: YFtorNT_defs NTCatCod_def HomFtorContraCod)

lemma YFtorNTApp1: assumes "X \<in> Obj (NTCatDom (YFtorNT C f))" shows "(YFtorNT C f) $$ X = Hom\<^bsub>C\<^esub>[X,f]"
proof-
  have "(YFtorNT C f) $$ X = (YFtorNT' C f) $$ X" using assms by (simp add: MakeNTApp YFtorNT_def)
  thus ?thesis by (simp add: YFtorNT'_def)
qed

definition
  "YFtor' C \<equiv> \<lparr>
         CatDom = C ,
         CatCod = CatExp (Op C) SET ,
         MapM = \<lambda> f . YFtorNT C f
  \<rparr>"

definition "YFtor C \<equiv> MakeFtor(YFtor' C)"

lemmas YFtor_defs = YFtor'_def YFtor_def MakeFtor_def

lemma YFtorNTNatTrans':
  assumes "LSCategory C" and "f \<in> Mor C"
  shows "NatTransP (YFtorNT' C f)"
proof(auto simp only: NatTransP_def)
  have Fd: "Ftor (NTDom (YFtorNT' C f)) : (Op C) \<longrightarrow> SET" using assms
    by (simp add:  HomFtorContraFtor Category.Cdom YFtorNT'_def)
  have Fc: "Ftor (NTCod (YFtorNT' C f)) : (Op C) \<longrightarrow> SET" using assms
    by (simp add:  HomFtorContraFtor Category.Ccod YFtorNT'_def)
  show "Functor (NTDom (YFtorNT' C f))" using Fd by auto
  show "Functor (NTCod (YFtorNT' C f))" using Fc by auto
  show "NTCatDom (YFtorNT' C f) = CatDom (NTCod (YFtorNT' C f))"
    by(simp add: YFtorNT'_def NTCatDom_def HomFtorContraDom)
  show "NTCatCod (YFtorNT' C f) = CatCod (NTDom (YFtorNT' C f))"
    by(simp add: YFtorNT'_def NTCatCod_def HomFtorContraCod)
  {
    fix X assume a: "X \<in> Obj (NTCatDom (YFtorNT' C f))"
    show "(YFtorNT' C f) $$ X maps\<^bsub>NTCatCod (YFtorNT' C f)\<^esub> (NTDom (YFtorNT' C f) @@ X) to (NTCod (YFtorNT' C f) @@ X)"
    proof-
      have Obj: "X \<in> Obj C" using a by (simp add: NTCatDom_def YFtorNT'_def HomFtorContraDom OppositeCategory_def)
      have H1: "(Hom\<^bsub>C\<^esub>[\<emdash>,dom\<^bsub>C\<^esub> f]) @@ X = Hom\<^bsub>C \<^esub>X dom\<^bsub>C\<^esub> f " using assms Obj by(simp add: HomFtorOpObj Category.Cdom)
      have H2: "(Hom\<^bsub>C\<^esub>[\<emdash>,cod\<^bsub>C\<^esub> f]) @@ X = Hom\<^bsub>C \<^esub>X cod\<^bsub>C\<^esub> f " using assms Obj by(simp add: HomFtorOpObj Category.Ccod)
      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 Obj by (simp add: HomFtorMapsTo)
      thus ?thesis using H1 H2 by(simp add: YFtorNT'_def NTCatCod_def NTCatDom_def HomFtorContraCod)
    qed
  }
  {
    fix g X Y assume a: "g maps\<^bsub>NTCatDom (YFtorNT' C f)\<^esub> X to Y"
    show "((NTDom (YFtorNT' C f)) ## g) ;;\<^bsub>NTCatCod (YFtorNT' C f) \<^esub>(YFtorNT' C f $$ Y) =
       ((YFtorNT' C f) $$ X) ;;\<^bsub>NTCatCod (YFtorNT' C f) \<^esub>(NTCod (YFtorNT' C f) ## g)"
    proof-
      have M1: "g maps\<^bsub>Op C\<^esub> X to Y" using a by (auto simp add: NTCatDom_def YFtorNT'_def HomFtorContraDom)
      have D1: "dom\<^bsub>C\<^esub> g = Y" and C1: "cod\<^bsub>C\<^esub> g = X" using M1 by (auto simp add: OppositeCategory_def)
      have morf: "f \<in> Mor C" and morg: "g \<in> Mor C" using assms M1 by (auto simp add: OppositeCategory_def)
      have H1: "(HomC\<^bsub>C\<^esub>[g,dom\<^bsub>C\<^esub> f]) = (Hom\<^bsub>C\<^esub>[\<emdash>,dom\<^bsub>C\<^esub> f]) ## g"
        and H2: "(HomC\<^bsub>C\<^esub>[g,cod\<^bsub>C\<^esub> f]) = (Hom\<^bsub>C\<^esub>[\<emdash>,cod\<^bsub>C\<^esub> f]) ## g" using M1
        by (auto simp add: HomFtorContra_def HomFtorContra'_def MakeFtor_def)
      have "(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])" using assms morf morg
        by (simp add: HomCHom)
      hence "((Hom\<^bsub>C\<^esub>[\<emdash>,dom\<^bsub>C\<^esub> f]) ## g) ;;\<^bsub>SET\<^esub> (Hom\<^bsub>C\<^esub>[Y,f]) = (Hom\<^bsub>C\<^esub>[X,f]) ;;\<^bsub>SET\<^esub> ((Hom\<^bsub>C\<^esub>[\<emdash>,cod\<^bsub>C\<^esub> f]) ## g)"
        using H1 H2 D1 C1 by simp
      thus ?thesis by (simp add: YFtorNT'_def NTCatCod_def HomFtorContraCod)
    qed
  }
qed

lemma YFtorNTNatTrans:
  assumes "LSCategory C" and "f \<in> Mor C"
  shows "NatTrans (YFtorNT C f)"
by (simp add: assms YFtorNTNatTrans' YFtorNT_def MakeNT)

lemma YFtorNTMor:
  assumes "LSCategory C" and "f \<in> Mor C"
  shows "YFtorNT C f \<in> Mor (CatExp (Op C) SET)"
proof(auto simp add: CatExp_def CatExp'_def MakeCatMor)
  have "f \<in> Mor C" using assms by auto
  thus "NatTrans (YFtorNT C f)" using assms by (simp add: YFtorNTNatTrans)
  show "NTCatDom (YFtorNT C f) = Op C" by (simp add: YFtorNTCatDom)
  show "NTCatCod (YFtorNT C f) = SET" by (simp add: YFtorNTCatCod)
qed

lemma YFtorNtMapsTo:
  assumes "LSCategory C" and "f \<in> Mor C"
  shows "YFtorNT C f maps\<^bsub>CatExp (Op C) SET\<^esub> (Hom\<^bsub>C\<^esub>[\<emdash>,dom\<^bsub>C\<^esub> f]) to (Hom\<^bsub>C\<^esub>[\<emdash>,cod\<^bsub>C\<^esub> f])"
proof(rule MapsToI)
  have "f \<in> Mor C"  using assms by auto
  thus 1: "YFtorNT C f \<in> mor\<^bsub>CatExp (Op C) SET\<^esub>" using assms by (simp add: YFtorNTMor)
  show "dom\<^bsub>CatExp (Op C) SET\<^esub> YFtorNT C f = Hom\<^bsub>C\<^esub>[\<emdash>,dom\<^bsub>C\<^esub> f]" using 1 by(simp add:CatExpDom YFtorNT_defs)
  show "cod\<^bsub>CatExp (Op C) SET\<^esub> YFtorNT C f = Hom\<^bsub>C\<^esub>[\<emdash>,cod\<^bsub>C\<^esub> f]" using 1 by(simp add:CatExpCod YFtorNT_defs)
qed

lemma YFtorNTCompDef:
  assumes "LSCategory C" and "f \<approx>>\<^bsub>C\<^esub> g"
  shows "YFtorNT C f \<approx>>\<^bsub>CatExp (Op C) SET\<^esub> YFtorNT C g"
proof(rule CompDefinedI)
  have "f \<in> Mor C" and "g \<in> Mor C" using assms by auto
  hence 1: "YFtorNT C f maps\<^bsub>CatExp (Op C) SET\<^esub> (Hom\<^bsub>C\<^esub>[\<emdash>,dom\<^bsub>C\<^esub> f]) to (Hom\<^bsub>C\<^esub>[\<emdash>,cod\<^bsub>C\<^esub> f])"
    and 2: "YFtorNT C g maps\<^bsub>CatExp (Op C) SET\<^esub> (Hom\<^bsub>C\<^esub>[\<emdash>,dom\<^bsub>C\<^esub> g]) to (Hom\<^bsub>C\<^esub>[\<emdash>,cod\<^bsub>C\<^esub> g])"
    using assms by (simp add: YFtorNtMapsTo)+
  thus "YFtorNT C f \<in> mor\<^bsub>CatExp (Op C) SET\<^esub>"
    and "YFtorNT C g \<in> mor\<^bsub>CatExp (Op C) SET\<^esub>" by auto
  have "cod\<^bsub>CatExp (Op C) SET\<^esub> YFtorNT C f = (Hom\<^bsub>C\<^esub>[\<emdash>,cod\<^bsub>C\<^esub> f])" using 1 by auto
  moreover have "dom\<^bsub>CatExp (Op C) SET\<^esub> YFtorNT C g = (Hom\<^bsub>C\<^esub>[\<emdash>,dom\<^bsub>C\<^esub> g])" using 2 by auto
  moreover have "cod\<^bsub>C\<^esub> f = dom\<^bsub>C\<^esub> g" using assms by auto
  ultimately show "cod\<^bsub>CatExp (Op C) SET\<^esub> YFtorNT C f = dom\<^bsub>CatExp (Op C) SET\<^esub> YFtorNT C g" by simp
qed

lemma PreSheafCat: "LSCategory C \<Longrightarrow> Category (CatExp (Op C) SET)"
by(simp add: YFtor'_def OpCatCat SETCategory CatExpCat)

lemma YFtor'Obj1:
  assumes "X \<in> Obj (CatDom (YFtor' C))" and "LSCategory C"
  shows "(YFtor' C) ## (Id (CatDom (YFtor' C)) X) = Id (CatCod (YFtor' C)) (Hom\<^bsub>C \<^esub>[\<emdash>,X])"
proof(simp add: YFtor'_def, rule NatTransExt)
  have Obj: "X \<in> Obj C" using assms by (simp add: YFtor'_def)
  have HomObj: "(Hom\<^bsub>C\<^esub>[\<emdash>,X]) \<in> Obj (CatExp (Op C) SET)" using assms Obj by(simp add: CatExp_defs HomFtorContraFtor)
  hence Id: "Id (CatExp (Op C) SET) (Hom\<^bsub>C\<^esub>[\<emdash>,X]) \<in> Mor (CatExp (Op C) SET)" using assms
    by (simp add: PreSheafCat Category.CatIdInMor)
  have CAT: "Category(CatExp (Op C) SET)" using assms by (simp add: PreSheafCat)
  have HomObj: "(Hom\<^bsub>C\<^esub>[\<emdash>,X]) \<in> Obj (CatExp (Op C) SET)" using assms Obj
    by(simp add: CatExp_defs HomFtorContraFtor)
  show "NatTrans (YFtorNT C (Id C X))"
  proof(rule YFtorNTNatTrans)
    show "LSCategory C" using assms(2) .
    show "Id C X \<in> Mor C" using assms Obj by (simp add: Category.CatIdInMor)
  qed
  show "NatTrans(Id (CatExp (Op C) SET) (Hom\<^bsub>C\<^esub>[\<emdash>,X]))" using Id by (simp add: CatExp_defs)
  show "NTDom (YFtorNT C (Id C X)) = NTDom (Id (CatExp (Op C) SET) (Hom\<^bsub>C\<^esub>[\<emdash>,X]))"
  proof(simp add: YFtorNT_defs)
    have "Hom\<^bsub>C\<^esub>[\<emdash>,dom\<^bsub>C\<^esub> (Id C X)] = Hom\<^bsub>C\<^esub>[\<emdash>,X]" using assms Obj by (simp add: Category.CatIdDomCod)
    also have "... = dom\<^bsub>CatExp (Op C) SET\<^esub>  (Id (CatExp (Op C) SET) (Hom\<^bsub>C\<^esub>[\<emdash>,X]))" using CAT HomObj
      by (simp add: Category.CatIdDomCod)
    also have "... = NTDom (Id (CatExp (Op C) SET) (Hom\<^bsub>C\<^esub>[\<emdash>,X]))" using Id by (simp add: CatExpDom)
    finally show "Hom\<^bsub>C\<^esub>[\<emdash>,dom\<^bsub>C\<^esub> (Id C X)] = NTDom (Id (CatExp (Op C) SET) (Hom\<^bsub>C\<^esub>[\<emdash>,X]))" .
  qed
  show "NTCod (YFtorNT C (Id C X)) = NTCod (Id (CatExp (Op C) SET) (Hom\<^bsub>C\<^esub>[\<emdash>,X]))"
  proof(simp add: YFtorNT_defs)
    have "Hom\<^bsub>C\<^esub>[\<emdash>,cod\<^bsub>C\<^esub> (Id C X)] = Hom\<^bsub>C\<^esub>[\<emdash>,X]" using assms Obj by (simp add: Category.CatIdDomCod)
    also have "... = cod\<^bsub>CatExp (Op C) SET\<^esub>  (Id (CatExp (Op C) SET) (Hom\<^bsub>C\<^esub>[\<emdash>,X]))" using CAT HomObj
      by (simp add: Category.CatIdDomCod)
    also have "... = NTCod (Id (CatExp (Op C) SET) (Hom\<^bsub>C\<^esub>[\<emdash>,X]))" using Id by (simp add: CatExpCod)
    finally show "Hom\<^bsub>C\<^esub>[\<emdash>,cod\<^bsub>C\<^esub> (Id C X)] = NTCod (Id (CatExp (Op C) SET) (Hom\<^bsub>C\<^esub>[\<emdash>,X]))" .
  qed
  {
    fix Y assume a: "Y \<in> Obj (NTCatDom (YFtorNT C (Id C X)))"
    show "(YFtorNT C (Id C X)) $$ Y = (Id (CatExp (Op C) SET) (Hom\<^bsub>C\<^esub>[\<emdash>,X])) $$ Y"
    proof-
      have CD: "CatDom (Hom\<^bsub>C\<^esub>[\<emdash>,X]) = Op C" by (simp add: HomFtorContraDom)
      have CC: "CatCod (Hom\<^bsub>C\<^esub>[\<emdash>,X]) = SET" by (simp add: HomFtorContraCod)
      have ObjY: "Y \<in> Obj C" and ObjYOp: "Y \<in> Obj (Op C)" using a by(simp add: YFtorNTCatDom OppositeCategory_def)+
      have "(YFtorNT C (Id C X)) $$ Y = (Hom\<^bsub>C\<^esub>[Y,(Id C X)])" using a by (simp add: YFtorNTApp1)
      also have "... = id\<^bsub>SET\<^esub> (Hom\<^bsub>C \<^esub>Y X)" using Obj ObjY assms by (simp add: HomFtorId)
      also have "... = id\<^bsub>SET\<^esub> ((Hom\<^bsub>C\<^esub>[\<emdash>,X]) @@ Y)" using Obj ObjY assms by (simp add: HomFtorOpObj )
      also have "... = (IdNatTrans (Hom\<^bsub>C\<^esub>[\<emdash>,X])) $$ Y" using CD CC ObjYOp by (simp add: IdNatTrans_map)
      also have "... = (Id (CatExp (Op C) SET) (Hom\<^bsub>C\<^esub>[\<emdash>,X])) $$ Y" using HomObj by (simp add: CatExpId)
      finally show ?thesis .
    qed
  }
qed

lemma YFtorPreFtor:
  assumes "LSCategory C"
  shows   "PreFunctor (YFtor' C)"
proof(auto simp only: PreFunctor_def)
  have CAT: "Category(CatExp (Op C) SET)" using assms by (simp add: PreSheafCat)
  {
    fix f g assume a: "f \<approx>>\<^bsub>CatDom (YFtor' C)\<^esub> g"
    show "(YFtor' C) ## (f ;;\<^bsub>CatDom (YFtor' C)\<^esub> g) = ((YFtor' C) ## f) ;;\<^bsub>CatCod (YFtor' C)\<^esub> ((YFtor' C) ## g)"
    proof(simp add: YFtor'_def, rule NatTransExt)
      have CD: "f \<approx>>\<^bsub>C\<^esub> g" using a by (simp add: YFtor'_def)
      have CD2: "YFtorNT C f \<approx>>\<^bsub>CatExp (Op C) SET\<^esub> YFtorNT C g" using CD assms by (simp add: YFtorNTCompDef)
      have Mor1: "YFtorNT C f ;;\<^bsub>CatExp (Op C) SET\<^esub> YFtorNT C g \<in> Mor (CatExp (Op C) SET)" using CAT CD2
        by (simp add: Category.MapsToMorDomCod)
      show "NatTrans (YFtorNT C (f ;;\<^bsub>C\<^esub> g))" using assms by (simp add: Category.MapsToMorDomCod CD YFtorNTNatTrans)
      show "NatTrans (YFtorNT C f ;;\<^bsub>CatExp (Op C) SET\<^esub> YFtorNT C g)" using Mor1 by (simp add: CatExpMorNT)
      show "NTDom (YFtorNT C (f ;;\<^bsub>C\<^esub> g)) = NTDom (YFtorNT C f ;;\<^bsub>CatExp (Op C) SET\<^esub> YFtorNT C g)"
      proof-
        have 1: "YFtorNT C f \<in> mor\<^bsub>CatExp (Op C) SET\<^esub>" using CD2 by auto
        have "NTDom (YFtorNT C (f ;;\<^bsub>C\<^esub> g)) = Hom\<^bsub>C\<^esub>[\<emdash>,dom\<^bsub>C\<^esub> (f ;;\<^bsub>C\<^esub> g)]" by (simp add: YFtorNT_defs)
        also have "... = Hom\<^bsub>C\<^esub>[\<emdash>,dom\<^bsub>C\<^esub> f]" using CD assms by (simp add: Category.MapsToMorDomCod)
        also have "... = NTDom (YFtorNT C f)" by (simp add: YFtorNT_defs)
        also have "... = dom\<^bsub>CatExp (Op C) SET\<^esub> (YFtorNT C f)" using 1 by (simp add: CatExpDom)
        also have "... = dom\<^bsub>CatExp (Op C) SET\<^esub> (YFtorNT C f ;;\<^bsub>CatExp (Op C) SET\<^esub> YFtorNT C g)" using CD2 CAT
          by (simp add: Category.MapsToMorDomCod)
        finally show ?thesis using Mor1 by (simp add: CatExpDom)
      qed
      show "NTCod (YFtorNT C (f ;;\<^bsub>C\<^esub> g)) = NTCod (YFtorNT C f ;;\<^bsub>CatExp (Op C) SET\<^esub> YFtorNT C g)"
      proof-
        have 1: "YFtorNT C g \<in> mor\<^bsub>CatExp (Op C) SET\<^esub>" using CD2 by auto
        have "NTCod (YFtorNT C (f ;;\<^bsub>C\<^esub> g)) = Hom\<^bsub>C\<^esub>[\<emdash>,cod\<^bsub>C\<^esub> (f ;;\<^bsub>C\<^esub> g)]" by (simp add: YFtorNT_defs)
        also have "... = Hom\<^bsub>C\<^esub>[\<emdash>,cod\<^bsub>C\<^esub> g]" using CD assms by (simp add: Category.MapsToMorDomCod)
        also have "... = NTCod (YFtorNT C g)" by (simp add: YFtorNT_defs)
        also have "... = cod\<^bsub>CatExp (Op C) SET\<^esub> (YFtorNT C g)" using 1 by (simp add: CatExpCod)
        also have "... = cod\<^bsub>CatExp (Op C) SET\<^esub> (YFtorNT C f ;;\<^bsub>CatExp (Op C) SET\<^esub> YFtorNT C g)" using CD2 CAT
          by (simp add: Category.MapsToMorDomCod)
        finally show ?thesis using Mor1 by (simp add: CatExpCod)
      qed
      {
        fix X assume a: "X \<in> Obj (NTCatDom (YFtorNT C (f ;;\<^bsub>C\<^esub> g)))"
        show "YFtorNT C (f ;;\<^bsub>C\<^esub> g) $$ X = (YFtorNT C f ;;\<^bsub>CatExp (Op C) SET\<^esub> YFtorNT C g) $$ X"
        proof-
          have Obj: "X \<in> Obj C" and ObjOp: "X \<in> Obj (Op C)" using a by (simp add: YFtorNTCatDom OppositeCategory_def)+
          have App1: "(Hom\<^bsub>C\<^esub>[X,f]) = (YFtorNT C f) $$ X"
            and App2: "(Hom\<^bsub>C\<^esub>[X,g]) = (YFtorNT C g) $$ X" using a by (simp add: YFtorNTApp1 YFtorNTCatDom)+
          have "(YFtorNT C (f ;;\<^bsub>C\<^esub> g)) $$ X = (Hom\<^bsub>C\<^esub>[X,(f ;;\<^bsub>C\<^esub> g)])" using a by (simp add: YFtorNTApp1)
          also have "... = (Hom\<^bsub>C\<^esub>[X,f]) ;;\<^bsub>SET\<^esub> (Hom\<^bsub>C\<^esub>[X,g])" using CD assms Obj by (simp add: HomFtorDist)
          also have "... = ((YFtorNT C f) $$ X) ;;\<^bsub>SET\<^esub> ((YFtorNT C g) $$ X)" using App1 App2 by simp
          finally show ?thesis using ObjOp CD2 by (simp add: CatExpDist)
        qed
      }
    qed
  }
  {
    fix X assume a: "X \<in> Obj (CatDom (YFtor' C))"
    show "\<exists> Y \<in> Obj (CatCod (YFtor' C)) . YFtor' C ## (Id (CatDom (YFtor' C)) X) = Id (CatCod (YFtor' C)) Y"
    proof(rule_tac x="Hom\<^bsub>C \<^esub>[\<emdash>,X]" in Set.rev_bexI)
      have "X \<in> Obj C" using a by(simp add: YFtor'_def)
      thus "Hom\<^bsub>C \<^esub>[\<emdash>,X] \<in> Obj (CatCod (YFtor' C))" using assms by(simp add: YFtor'_def CatExp_defs HomFtorContraFtor)
      show "(YFtor' C) ## (Id (CatDom (YFtor' C)) X) = Id (CatCod (YFtor' C)) (Hom\<^bsub>C \<^esub>[\<emdash>,X])" using a assms
        by (simp add: YFtor'Obj1)
    qed
  }
  show "Category (CatDom (YFtor' C))" using assms by (simp add: YFtor'_def)
  show "Category (CatCod (YFtor' C))" using CAT by (simp add: YFtor'_def)
qed

lemma YFtor'Obj:
  assumes "X \<in> Obj (CatDom (YFtor' C))"
  and     "LSCategory C"
  shows   "(YFtor' C) @@ X = Hom\<^bsub>C \<^esub>[\<emdash>,X]"
proof(rule PreFunctor.FmToFo, simp_all add: assms YFtor'Obj1 YFtorPreFtor)
  have "X \<in> Obj C" using assms by(simp add: YFtor'_def)
  thus "Hom\<^bsub>C \<^esub>[\<emdash>,X] \<in> Obj (CatCod (YFtor' C))" using assms by(simp add: YFtor'_def CatExp_defs HomFtorContraFtor)
qed

lemma YFtorFtor':
  assumes "LSCategory C"
  shows   "FunctorM (YFtor' C)"
proof(auto simp only: FunctorM_def)
  show "PreFunctor (YFtor' C)" using assms by (rule YFtorPreFtor)
  show "FunctorM_axioms (YFtor' C)"
  proof(auto simp add:FunctorM_axioms_def)
    {
      fix f X Y assume aa: "f maps\<^bsub>CatDom (YFtor' C) \<^esub>X to Y"
      show "YFtor' C ## f maps\<^bsub>CatCod (YFtor' C)\<^esub> YFtor' C @@ X to YFtor' C @@ Y"
      proof-
        have Mor1: "f maps\<^bsub>C\<^esub> X to Y" using aa by (simp add: YFtor'_def)
        have "Category (CatDom (YFtor' C))" using assms by (simp add: YFtor'_def)
        hence Obj1: "X \<in> Obj (CatDom (YFtor' C))" and
              Obj2: "Y \<in> Obj (CatDom (YFtor' C))" using aa assms by (simp add: Category.MapsToObj)+
        have "(YFtor' C ## f) = YFtorNT C f" by (simp add: YFtor'_def)
        moreover have "YFtor' C @@ X = Hom\<^bsub>C \<^esub>[\<emdash>,X]"
          and "YFtor' C @@ Y = Hom\<^bsub>C \<^esub>[\<emdash>,Y]" using Obj1 Obj2 assms by (simp add: YFtor'Obj)+
        moreover have "CatCod (YFtor' C) = CatExp (Op C) SET" by (simp add: YFtor'_def)
        moreover have "YFtorNT C f maps\<^bsub>CatExp (Op C) SET\<^esub> (Hom\<^bsub>C \<^esub>[\<emdash>,X]) to (Hom\<^bsub>C \<^esub>[\<emdash>,Y])"
          using assms Mor1 by (auto simp add: YFtorNtMapsTo)
        ultimately show ?thesis by simp
      qed
    }
  qed
qed

lemma YFtorFtor: assumes "LSCategory C" shows "Ftor (YFtor C) : C \<longrightarrow> (CatExp (Op C) SET)"
proof(auto simp only: functor_abbrev_def)
  show "Functor (YFtor C)" using assms by(simp add: MakeFtor YFtor_def YFtorFtor')
  show "CatDom (YFtor C) = C" and "CatCod (YFtor C) = (CatExp (Op C) SET)"
    using assms by(simp add: MakeFtor_def YFtor_def YFtor'_def)+
qed

lemma YFtorObj:
  assumes "LSCategory C" and "X \<in> Obj C"
  shows "(YFtor C) @@ X = Hom\<^bsub>C \<^esub>[\<emdash>,X]"
proof-
  have "CatDom (YFtor' C) = C" by (simp add: YFtor'_def)
  moreover hence "(YFtor' C) @@ X = Hom\<^bsub>C \<^esub>[\<emdash>,X]" using assms by(simp add: YFtor'Obj)
  moreover have "PreFunctor (YFtor' C)" using assms by (simp add: YFtorPreFtor)
  ultimately show ?thesis using assms by (simp add: MakeFtorObj YFtor_def)
qed

lemma YFtorObj2:
  assumes "LSCategory C" and "X \<in> Obj C" and "Y \<in> Obj C"
  shows "((YFtor C) @@ Y) @@ X = Hom\<^bsub>C \<^esub>X Y"
proof-
  have "Hom\<^bsub>C \<^esub>X Y = ((Hom\<^bsub>C\<^esub>[\<emdash>,Y]) @@ X)" using assms by (simp add: HomFtorOpObj)
  also have "... = ((YFtor C @@ Y) @@ X)" using assms by (simp add: YFtorObj)
  finally show ?thesis by simp
qed

lemma YFtorMor: "\<lbrakk>LSCategory C ; f \<in> Mor C\<rbrakk> \<Longrightarrow> (YFtor C) ## f = YFtorNT C f"
by (simp add: YFtor_defs MakeFtorMor)

(*
We can't do this because the presheaf category may not be locally small
definition
  NatHom ("Nat\<index> _ _") where
  "NatHom C F G \<equiv> Hom\<^bsub>CatExp (Op C) SET\<^esub> F G"
*)

definition "YMap C X \<eta> \<equiv> (\<eta> $$ X) |@| (m2z\<^bsub>C\<^esub> (id\<^bsub>C \<^esub>X))"
definition "YMapInv' C X F x \<equiv> \<lparr>
      NTDom = ((YFtor C) @@ X),
      NTCod = F,
      NatTransMap = \<lambda> B . ZFfun (Hom\<^bsub>C\<^esub> B X) (F @@ B) (\<lambda> f . (F ## (z2m\<^bsub>C\<^esub> f)) |@| x)
  \<rparr>"
definition "YMapInv C X F x \<equiv> MakeNT (YMapInv' C X F x)"

lemma YMapInvApp:
  assumes "X \<in> Obj C" and "B \<in> Obj C" and "LSCategory C"
  shows "(YMapInv C X F x) $$ B = ZFfun (Hom\<^bsub>C\<^esub> B X) (F @@ B) (\<lambda> f . (F ## (z2m\<^bsub>C\<^esub> f)) |@| x)"
proof-
  have "NTCatDom (MakeNT (YMapInv' C X F x)) = CatDom (NTDom (YMapInv' C X F x))" by (simp add: MakeNT_def NTCatDom_def)
  also have "... = CatDom (Hom\<^bsub>C\<^esub>[\<emdash>,X])" using assms by (simp add: YFtorObj YMapInv'_def)
  also have "... = Op C" using assms HomFtorContraFtor[of C X] by auto
  finally have "NTCatDom (MakeNT (YMapInv' C X F x)) = Op C" .
  hence 1: "B \<in> Obj (NTCatDom (MakeNT (YMapInv' C X F x)))" using assms by (simp add: OppositeCategory_def)
  have "(YMapInv C X F x) $$ B = (MakeNT (YMapInv' C X F x)) $$ B" by (simp add: YMapInv_def)
  also have "... = (YMapInv' C X F x) $$ B" using 1 by(simp add: MakeNTApp)
  finally show ?thesis by (simp add: YMapInv'_def)
qed

lemma YMapImage:
  assumes "LSCategory C" and "Ftor F : (Op C) \<longrightarrow> SET" and "X \<in> Obj C"
  and "NT \<eta> : (YFtor C @@ X) \<Longrightarrow> F"
  shows "(YMap C X \<eta>) |\<in>| (F @@ X)"
proof(simp only: YMap_def)
  have "(YFtor C @@ X) = (Hom\<^bsub>C\<^esub>[\<emdash>,X])" using assms by (auto simp add: YFtorObj)
  moreover have "Ftor (Hom\<^bsub>C\<^esub>[\<emdash>,X]) : (Op C) \<longrightarrow> SET" using assms by (simp add: HomFtorContraFtor)
  ultimately have "CatDom (YFtor C @@ X) = Op C" by auto
  hence Obj: "X \<in> Obj (CatDom (YFtor C @@ X))" using assms by (simp add: OppositeCategory_def)
  moreover have "CatCod F  = SET" using assms by auto
  moreover have "\<eta> $$ X maps\<^bsub>CatCod F \<^esub>((YFtor C @@ X) @@ X) to (F @@ X)" using assms Obj by (simp add: NatTransMapsTo)
  ultimately have "\<eta> $$ X maps\<^bsub>SET\<^esub> ((YFtor C @@ X) @@ X) to (F @@ X)" by simp
  moreover have "(m2z\<^bsub>C \<^esub>(Id C X))  |\<in>| ((YFtor C @@ X) @@ X)"
  proof-
    have "(Id C X) maps\<^bsub>C \<^esub>X to X" using assms by (simp add: Category.Simps)
    moreover have "((YFtor C @@ X) @@ X) = Hom\<^bsub>C\<^esub> X X" using assms by (simp add: YFtorObj2)
    ultimately show ?thesis using assms by (simp add: LSCategory.m2zz2m)
  qed
  ultimately show "((\<eta> $$ X) |@| (m2z\<^bsub>C \<^esub>(Id C X))) |\<in>| (F @@ X)" by (simp add: SETfunDomAppCod)
qed

lemma YMapInvNatTransP:
  assumes "LSCategory C" and "Ftor F : (Op C) \<longrightarrow> SET" and xobj: "X \<in> Obj C" and xinF: "x |\<in>| (F @@ X)"
  shows "NatTransP (YMapInv' C X F x)"
proof(auto simp only: NatTransP_def, simp_all add: YMapInv'_def NTCatCod_def NTCatDom_def)
  have yf: "(YFtor C @@ X) = Hom\<^bsub>C\<^esub>[\<emdash>,X]" using assms by (simp add: YFtorObj)
  hence hf: "Ftor (YFtor C @@ X) : (Op C) \<longrightarrow> SET" using assms by (simp add: HomFtorContraFtor)
  thus "Functor (YFtor C @@ X)" by auto
  show ftf: "Functor F" using assms by auto
  have df: "CatDom F = Op C" and cf: "CatCod F = SET" using assms by auto
  have dy: "CatDom ((YFtor C) @@ X) = Op C" and cy: "CatCod ((YFtor C) @@ X) = SET" using hf by auto
  show "CatDom ((YFtor C) @@ X) = CatDom F" using df dy by simp
  show "CatCod F = CatCod ((YFtor C) @@ X)" using cf cy by simp
  {
    fix Y assume yobja: "Y \<in> Obj (CatDom ((YFtor C) @@ X))"
    show "ZFfun (Hom\<^bsub>C\<^esub> Y X) (F @@ Y) (\<lambda>f. (F ## (z2m\<^bsub>C \<^esub>f)) |@| x) maps\<^bsub>CatCod F\<^esub> ((YFtor C @@ X) @@ Y) to (F @@ Y)"
    proof(simp add: cf, rule MapsToI)
      have yobj: "Y \<in> Obj C" using yobja dy by (simp add: OppositeCategory_def)
      have zffun: "isZFfun (ZFfun (Hom\<^bsub>C\<^esub> Y X) (F @@ Y) (\<lambda>f. (F ## z2m\<^bsub>C\<^esub>f) |@| x))"
      proof(rule SETfun, rule allI, rule impI)
        {
          fix y assume yhom: "y |\<in>| (Hom\<^bsub>C\<^esub> Y X)" show "(F ## (z2m\<^bsub>C \<^esub>y)) |@| x |\<in>| (F @@ Y)"
          proof-
            let ?f = "(F ## (z2m\<^bsub>C \<^esub>y))"
            have "(z2m\<^bsub>C \<^esub>y) maps\<^bsub>C\<^esub> Y to X" using yhom yobj assms by (simp add: LSCategory.z2mm2z)
            hence "(z2m\<^bsub>C \<^esub>y) maps\<^bsub>Op C\<^esub> X to Y" by (simp add: MapsToOp)
            hence "?f maps\<^bsub>SET\<^esub> (F @@ X) to (F @@ Y)" using assms by (simp add: FunctorMapsTo)
            hence "isZFfun (?f)" and "|dom| ?f = F @@ X" and "|cod| ?f = F @@ Y" by (simp add: SETmapsTo)+
            thus "(?f |@| x) |\<in>| (F @@ Y)" using assms ZFfunDomAppCod[of ?f x] by simp
          qed
        }
      qed
      show "ZFfun (Hom\<^bsub>C\<^esub> Y X) (F @@ Y) (\<lambda>f. (F ## z2m\<^bsub>C\<^esub>f) |@| x) \<in> mor\<^bsub>SET\<^esub>" using zffun
        by(simp add: SETmor)
      show "cod\<^bsub>SET\<^esub> ZFfun (Hom\<^bsub>C\<^esub> Y X) (F @@ Y) (\<lambda>f. (F ## z2m\<^bsub>C\<^esub>f) |@| x) = F @@ Y" using zffun
        by(simp add: SETcod)
      have "(Hom\<^bsub>C\<^esub> Y X) = (YFtor C @@ X) @@ Y" using assms yobj by (simp add: YFtorObj2)
      thus "dom\<^bsub>SET\<^esub> ZFfun (Hom\<^bsub>C\<^esub> Y X) (F @@ Y) (\<lambda>f. (F ## z2m\<^bsub>C\<^esub>f) |@| x) = (YFtor C @@ X) @@ Y" using zffun
        by(simp add: SETdom)
    qed
  }
  {
    fix f Z Y assume fmaps: "f maps\<^bsub>CatDom ((YFtor C ) @@ X)\<^esub> Z to Y"
    have fmapsa: "f maps\<^bsub>Op C\<^esub> Z to Y" using fmaps dy by simp
    hence fmapsb: "f maps\<^bsub>C\<^esub> Y to Z" by (rule MapsToOpOp)
    hence fmor: "f \<in> Mor C" and fdom: "dom\<^bsub>C\<^esub> f = Y" and fcod: "cod\<^bsub>C\<^esub> f = Z" by (auto simp add: OppositeCategory_def)
    hence hc: "(Hom\<^bsub>C\<^esub>[\<emdash>,X]) ## f = (HomC\<^bsub>C\<^esub>[f,X])" using assms by (simp add: HomContraMor)
    have yobj: "Y \<in> Obj C" and zobj: "Z \<in> Obj C" using fmapsb assms by (simp add: Category.MapsToObj)+
    have Ffmaps: "(F ## f) maps\<^bsub>SET\<^esub> (F @@ Z) to (F @@ Y)" using assms fmapsa by (simp add: FunctorMapsTo)
    have Fzmaps: "\<And> h A B . \<lbrakk>h |\<in>| (Hom\<^bsub>C\<^esub> A B) ; A \<in> Obj C ; B \<in> Obj C\<rbrakk> \<Longrightarrow>
      (F ## (z2m\<^bsub>C \<^esub>h)) maps\<^bsub>SET\<^esub> (F @@ B) to (F @@ A)"
    proof-
      fix h A B assume h: "h |\<in>| (Hom\<^bsub>C\<^esub> A B)" and oA: "A \<in> Obj C" and oB: "B \<in> Obj C"
      have "(z2m\<^bsub>C \<^esub>h) maps\<^bsub>C\<^esub> A to B" using assms h oA oB by (simp add: LSCategory.z2mm2z)
      hence "(z2m\<^bsub>C \<^esub>h) maps\<^bsub>Op C\<^esub> B to A" by (rule MapsToOp)
      thus "(F ## (z2m\<^bsub>C \<^esub>h)) maps\<^bsub>SET\<^esub> (F @@ B) to (F @@ A)" using assms by (simp add: FunctorMapsTo)
    qed
    have hHomF: "\<And>h. h |\<in>| (Hom\<^bsub>C\<^esub> Z X) \<Longrightarrow> (F ## (z2m\<^bsub>C \<^esub>h)) |@| x |\<in>| (F @@ Z)" using xobj zobj xinF
    proof-
      fix h assume h: "h |\<in>| (Hom\<^bsub>C\<^esub> Z X)"
      have "(F ## (z2m\<^bsub>C \<^esub>h)) maps\<^bsub>SET\<^esub> (F @@ X) to (F @@ Z)" using xobj zobj h by (simp add: Fzmaps)
      thus "(F ## (z2m\<^bsub>C \<^esub>h)) |@| x |\<in>| (F @@ Z)"  using assms by (simp add: SETfunDomAppCod)
    qed
    have Ff: "F ## f = ZFfun (F @@ Z) (F @@ Y) (\<lambda>h. (F ## f) |@| h)" using Ffmaps by (simp add: SETZFfun)
    have compdefa: "ZFfun (Hom\<^bsub>C\<^esub> Z X) (Hom\<^bsub>C\<^esub> Y X) (\<lambda>h. m2z\<^bsub>C \<^esub>(f ;;\<^bsub>C\<^esub> (z2m\<^bsub>C \<^esub>h))) \<approx>>\<^bsub>SET\<^esub>
          ZFfun (Hom\<^bsub>C\<^esub> Y X) (F @@ Y) (\<lambda>h. (F ## (z2m\<^bsub>C \<^esub>h)) |@| x)"
    proof(rule CompDefinedI, simp_all add: SETmor[THEN sym])
      show "isZFfun (ZFfun (Hom\<^bsub>C\<^esub> Z X) (Hom\<^bsub>C\<^esub> Y X) (\<lambda>h. m2z\<^bsub>C \<^esub>(f ;;\<^bsub>C\<^esub> (z2m\<^bsub>C \<^esub>h))))"
      proof(rule SETfun, rule allI, rule impI)
        fix h assume h: "h |\<in>| (Hom\<^bsub>C\<^esub> Z X)"
        have "(z2m\<^bsub>C \<^esub>h) maps\<^bsub>C\<^esub> Z to X" using assms h xobj zobj by (simp add: LSCategory.z2mm2z)
        hence "f ;;\<^bsub>C\<^esub> (z2m\<^bsub>C \<^esub>h) maps\<^bsub>C\<^esub> Y to X" using fmapsb assms(1) by (simp add: Category.Ccompt)
        thus "(m2z\<^bsub>C\<^esub> (f ;;\<^bsub>C\<^esub> (z2m\<^bsub>C \<^esub>h))) |\<in>| (Hom\<^bsub>C\<^esub> Y X)" using assms by (simp add: LSCategory.m2zz2m)
      qed
      moreover show "isZFfun (ZFfun (Hom\<^bsub>C\<^esub> Y X) (F @@ Y) (\<lambda>h. (F ## (z2m\<^bsub>C \<^esub>h)) |@| x))"
      proof(rule SETfun, rule allI, rule impI)
        fix h assume h: "h |\<in>| (Hom\<^bsub>C\<^esub> Y X)"
        have "(F ## (z2m\<^bsub>C \<^esub>h)) maps\<^bsub>SET\<^esub> (F @@ X) to (F @@ Y)" using xobj yobj h by (simp add: Fzmaps)
        thus "(F ## (z2m\<^bsub>C \<^esub>h)) |@| x |\<in>| (F @@ Y)" using assms by (simp add: SETfunDomAppCod)
      qed
      ultimately show "cod\<^bsub>SET\<^esub>(ZFfun (Hom\<^bsub>C\<^esub> Z X) (Hom\<^bsub>C\<^esub> Y X) (\<lambda>h. m2z\<^bsub>C \<^esub>(f ;;\<^bsub>C\<^esub> (z2m\<^bsub>C \<^esub>h)))) =
        dom\<^bsub>SET\<^esub>(ZFfun (Hom\<^bsub>C\<^esub> Y X) (F @@ Y) (\<lambda>h. (F ## (z2m\<^bsub>C \<^esub>h)) |@| x))" by (simp add: SETcod SETdom)
    qed
    have compdefb: "ZFfun (Hom\<^bsub>C\<^esub> Z X) (F @@ Z) (\<lambda>h. (F ## (z2m\<^bsub>C \<^esub>h)) |@| x) \<approx>>\<^bsub>SET\<^esub>
          ZFfun (F @@ Z) (F @@ Y) (\<lambda>h. (F ## f) |@| h)"
    proof(rule CompDefinedI, simp_all add: SETmor[THEN sym])
      show "isZFfun (ZFfun (Hom\<^bsub>C\<^esub> Z X) (F @@ Z) (\<lambda>h. (F ## (z2m\<^bsub>C \<^esub>h)) |@| x))" using hHomF by (simp add: SETfun)
      moreover show "isZFfun (ZFfun (F @@ Z) (F @@ Y) (\<lambda>h. (F ## f) |@| h))"
      proof(rule SETfun, rule allI, rule impI)
        fix h assume h: "h |\<in>| (F @@ Z)"
        have "F ## f maps\<^bsub>SET\<^esub> F @@ Z to F @@ Y" using Ffmaps .
        thus "(F ## f) |@| h |\<in>| (F @@ Y)" using h by (simp add: SETfunDomAppCod)
      qed
      ultimately show "cod\<^bsub>SET\<^esub> (ZFfun (Hom\<^bsub>C\<^esub> Z X) (F @@ Z) (\<lambda>h. (F ## (z2m\<^bsub>C \<^esub>h)) |@| x)) =
            dom\<^bsub>SET\<^esub> (ZFfun (F @@ Z) (F @@ Y) (\<lambda>h. (F ## f) |@| h))" by (simp add: SETcod SETdom)
    qed
    have "ZFfun (Hom\<^bsub>C\<^esub> Z X) (Hom\<^bsub>C\<^esub> Y X) (\<lambda>h. m2z\<^bsub>C \<^esub>(f ;;\<^bsub>C\<^esub> (z2m\<^bsub>C \<^esub>h))) ;;\<^bsub>SET\<^esub>
          ZFfun (Hom\<^bsub>C\<^esub> Y X) (F @@ Y) (\<lambda>h. (F ## (z2m\<^bsub>C \<^esub>h)) |@| x) =
          ZFfun (Hom\<^bsub>C\<^esub> Z X) (Hom\<^bsub>C\<^esub> Y X) (\<lambda>h. m2z\<^bsub>C \<^esub>(f ;;\<^bsub>C\<^esub> (z2m\<^bsub>C \<^esub>h))) |o|
          ZFfun (Hom\<^bsub>C\<^esub> Y X) (F @@ Y) (\<lambda>h. (F ## (z2m\<^bsub>C \<^esub>h)) |@| x)" using Ff compdefa by (simp add: SETComp)
    also have "... = ZFfun (Hom\<^bsub>C\<^esub> Z X) (F @@ Y) ((\<lambda>h. (F ## (z2m\<^bsub>C \<^esub>h)) |@| x) o (\<lambda>h. m2z\<^bsub>C \<^esub>(f ;;\<^bsub>C\<^esub> (z2m\<^bsub>C \<^esub>h))))"
    proof(rule ZFfunComp, rule allI, rule impI)
      {
        fix h assume h: "h |\<in>| (Hom\<^bsub>C\<^esub> Z X)"
        show "(m2z\<^bsub>C \<^esub>(f ;;\<^bsub>C\<^esub> (z2m\<^bsub>C \<^esub>h))) |\<in>| (Hom\<^bsub>C\<^esub> Y X)"
        proof-
          have "Z \<in> Obj C" using fmapsb assms by (simp add: Category.MapsToObj)
          hence "(z2m\<^bsub>C \<^esub>h) maps\<^bsub>C\<^esub> Z to X" using assms h by (simp add: LSCategory.z2mm2z)
          hence "f ;;\<^bsub>C\<^esub> (z2m\<^bsub>C \<^esub>h) maps\<^bsub>C\<^esub> Y to X" using fmapsb assms(1) by (simp add: Category.Ccompt)
          thus ?thesis using assms by (simp add: LSCategory.m2zz2m)
        qed
      }
    qed
    also have "... = ZFfun (Hom\<^bsub>C\<^esub> Z X) (F @@ Y) ((\<lambda>h. (F ## f) |@| h) o (\<lambda>h. (F ## (z2m\<^bsub>C \<^esub>h)) |@| x))"
    proof(rule ZFfun_ext, rule allI, rule impI, simp)
      {
        fix h assume h: "h |\<in>| (Hom\<^bsub>C\<^esub> Z X)"
        have zObj: "Z \<in> Obj C" using fmapsb assms by (simp add: Category.MapsToObj)
        hence hmaps: "(z2m\<^bsub>C \<^esub>h) maps\<^bsub>C\<^esub> Z to X" using assms h by (simp add: LSCategory.z2mm2z)
        hence "(z2m\<^bsub>C \<^esub>h) \<in> Mor C" and "dom\<^bsub>C\<^esub> (z2m\<^bsub>C \<^esub>h) = cod\<^bsub>C\<^esub> f" using fcod by auto
        hence CompDef_hf: "f \<approx>>\<^bsub>C\<^esub> (z2m\<^bsub>C \<^esub>h)" using fmor by auto
        hence CompDef_hfOp: "(z2m\<^bsub>C \<^esub>h) \<approx>>\<^bsub>Op C\<^esub> f" by (simp add: CompDefOp)
        hence CompDef_FhfOp: "(F ## (z2m\<^bsub>C \<^esub>h)) \<approx>>\<^bsub>SET\<^esub> (F ## f)" using assms by (simp add: FunctorCompDef)
        hence "(z2m\<^bsub>C \<^esub>h) maps\<^bsub>Op C\<^esub> X to Z" using hmaps by (simp add: MapsToOp)
        hence "(F ## (z2m\<^bsub>C \<^esub>h)) maps\<^bsub>SET\<^esub> (F @@ X) to (F @@ Z)" using assms by (simp add: FunctorMapsTo)
        hence xin: "x |\<in>| |dom|(F ## (z2m\<^bsub>C \<^esub>h))" using assms by (simp add: SETmapsTo)
        have "(f ;;\<^bsub>C\<^esub> (z2m\<^bsub>C \<^esub>h)) \<in> Mor C" using CompDef_hf assms by(simp add: Category.MapsToMorDomCod)
        hence "(F ## (z2m\<^bsub>C \<^esub>(m2z\<^bsub>C \<^esub>(f ;;\<^bsub>C\<^esub> (z2m\<^bsub>C \<^esub>h))))) |@| x = (F ## (f ;;\<^bsub>C\<^esub> (z2m\<^bsub>C \<^esub>h))) |@| x"
          using assms by (simp add: LSCategory.m2zz2mInv)
        also have "... = (F ## ((z2m\<^bsub>C \<^esub>h) ;;\<^bsub>Op C\<^esub> f)) |@| x" by (simp add: OppositeCategory_def)
        also have "... = ((F ## (z2m\<^bsub>C \<^esub>h)) ;;\<^bsub>SET \<^esub>(F ## f)) |@| x" using assms CompDef_hfOp by (simp add: FunctorComp)
        also have "... = (F ## f) |@| ((F ## (z2m\<^bsub>C \<^esub>h)) |@| x)" using CompDef_FhfOp xin by(rule SETCompAt)
        finally show "(F ## (z2m\<^bsub>C \<^esub>(m2z\<^bsub>C \<^esub>(f ;;\<^bsub>C\<^esub> (z2m\<^bsub>C \<^esub>h))))) |@| x = (F ## f) |@| ((F ## (z2m\<^bsub>C \<^esub>h)) |@| x)" .
      }
    qed
    also have "... = ZFfun (Hom\<^bsub>C\<^esub> Z X) (F @@ Z) (\<lambda>h. (F ## (z2m\<^bsub>C \<^esub>h)) |@| x) |o|
          ZFfun (F @@ Z) (F @@ Y) (\<lambda>h. (F ## f) |@| h)"
      by(rule ZFfunComp[THEN sym], rule allI, rule impI, simp add: hHomF)
    also have "... = ZFfun (Hom\<^bsub>C\<^esub> Z X) (F @@ Z) (\<lambda>h. (F ## (z2m\<^bsub>C \<^esub>h)) |@| x) ;;\<^bsub>SET\<^esub> (F ## f)"
      using Ff compdefb by (simp add: SETComp)
    finally show "(((YFtor C) @@ X) ## f) ;;\<^bsub>CatCod F\<^esub> ZFfun (Hom\<^bsub>C\<^esub> Y X) (F @@ Y) (\<lambda>f. (F ## (z2m\<^bsub>C \<^esub>f)) |@| x) =
             ZFfun (Hom\<^bsub>C\<^esub> Z X) (F @@ Z) (\<lambda>f. (F ## (z2m\<^bsub>C \<^esub>f)) |@| x) ;;\<^bsub>CatCod F\<^esub> (F ## f)"
      by(simp add: cf yf hc fdom fcod HomFtorMapContra_def)
  }
qed

lemma YMapInvNatTrans:
  assumes "LSCategory C" and "Ftor F : (Op C) \<longrightarrow> SET" and "X \<in> Obj C" and "x |\<in>| (F @@ X)"
  shows "NatTrans (YMapInv C X F x)"
by (simp add: assms YMapInv_def MakeNT YMapInvNatTransP)

lemma YMapInvImage:
  assumes "LSCategory C" and "Ftor F : (Op C) \<longrightarrow> SET" and "X \<in> Obj C"
  and "x |\<in>| (F @@ X)"
  shows "NT (YMapInv C X F x) : (YFtor C @@ X) \<Longrightarrow> F"
proof(auto simp only: nt_abbrev_def)
  show "NatTrans (YMapInv C X F x)" using assms by (simp add: YMapInvNatTrans)
  show "NTDom (YMapInv C X F x) = YFtor C @@ X" by(simp add: YMapInv_def MakeNT_def YMapInv'_def)
  show "NTCod (YMapInv C X F x) = F" by(simp add: YMapInv_def MakeNT_def YMapInv'_def)
qed

lemma YMap1:
  assumes LSCat: "LSCategory C" and Fftor: "Ftor F : (Op C) \<longrightarrow> SET" and XObj: "X \<in> Obj C"
  and NT: "NT \<eta> : (YFtor C @@ X) \<Longrightarrow> F"
  shows "YMapInv C X F (YMap C X \<eta>) = \<eta>"
proof(rule NatTransExt)
  have "(YMap C X \<eta>) |\<in>| (F @@ X)" using assms by (simp add: YMapImage)
  hence 1: "NT (YMapInv C X F (YMap C X \<eta>)) : (YFtor C @@ X) \<Longrightarrow> F" using assms by (simp add: YMapInvImage)
  thus "NatTrans (YMapInv C X F (YMap C X \<eta>))" by auto
  show "NatTrans \<eta>" using assms by auto
  have NTDYI: "NTDom (YMapInv C X F (YMap C X \<eta>)) = (YFtor C @@ X)" using 1 by auto
  moreover have NTDeta: "NTDom \<eta> = (YFtor C @@ X)" using assms by auto
  ultimately show "NTDom (YMapInv C X F (YMap C X \<eta>)) = NTDom \<eta>" by simp
  have "NTCod (YMapInv C X F (YMap C X \<eta>)) = F" using 1 by auto
  moreover have NTCeta: "NTCod \<eta> = F" using assms by auto
  ultimately show "NTCod (YMapInv C X F (YMap C X \<eta>)) = NTCod \<eta>" by simp
  {
    fix Y assume Yobja: "Y \<in> Obj (NTCatDom (YMapInv C X F (YMap C X \<eta>)))"
    have CCF: "CatCod F = SET" using assms by auto
    have "Ftor (Hom\<^bsub>C\<^esub>[\<emdash>,X]) : (Op C) \<longrightarrow> SET" using LSCat XObj by (simp add: HomFtorContraFtor)
    hence CDH: "CatDom (Hom\<^bsub>C\<^esub>[\<emdash>,X]) = Op C" by auto
    hence CDYF: "CatDom (YFtor C @@ X) = Op C" using XObj LSCat by (auto simp add: YFtorObj)
    hence "NTCatDom (YMapInv C X F (YMap C X \<eta>)) = Op C" using LSCat XObj NTDYI CDH  by (simp add: NTCatDom_def)
    hence YObjOp: "Y \<in> Obj (Op C)" using Yobja by simp
    hence YObj: "Y \<in> Obj C" and XObjOp: "X \<in> Obj (Op C)" using XObj by (simp add: OppositeCategory_def)+
    have yinv_mapsTo: "((YMapInv C X F (YMap C X \<eta>)) $$ Y) maps\<^bsub>SET\<^esub> (Hom\<^bsub>C \<^esub>Y X) to (F @@ Y)"
    proof-
      have "((YMapInv C X F (YMap C X \<eta>)) $$ Y) maps\<^bsub>SET\<^esub> ((YFtor C @@ X) @@ Y) to (F @@ Y)"
        using 1 CCF CDYF YObjOp NatTransMapsTo[of "(YMapInv C X F (YMap C X \<eta>))" "(YFtor C @@ X)" F Y] by simp
      thus ?thesis using LSCat XObj YObj by (simp add: YFtorObj2)
    qed
    have eta_mapsTo: "(\<eta> $$ Y) maps\<^bsub>SET\<^esub> (Hom\<^bsub>C \<^esub>Y X) to (F @@ Y)"
    proof-
      have "(\<eta> $$ Y) maps\<^bsub>SET\<^esub> ((YFtor C @@ X) @@ Y) to (F @@ Y)"
        using NT CDYF CCF YObjOp NatTransMapsTo[of \<eta> "(YFtor C @@ X)" F Y] by simp
      thus ?thesis using LSCat XObj YObj by (simp add: YFtorObj2)
    qed
    show "(YMapInv C X F (YMap C X \<eta>)) $$ Y = \<eta> $$ Y"
    proof(rule ZFfunExt)
      show "|dom|(YMapInv C X F (YMap C X \<eta>) $$ Y) = |dom|(\<eta> $$ Y)"
        using yinv_mapsTo eta_mapsTo by (simp add: SETmapsTo)
      show "|cod|(YMapInv C X F (YMap C X \<eta>) $$ Y) = |cod|(\<eta> $$ Y)"
        using yinv_mapsTo eta_mapsTo by (simp add: SETmapsTo)
      show "isZFfun (YMapInv C X F (YMap C X \<eta>) $$ Y)"
        using yinv_mapsTo by (simp add: SETmapsTo)
      show "isZFfun (\<eta> $$ Y)"
        using eta_mapsTo by (simp add: SETmapsTo)
      {
        fix f assume fdomYinv: "f |\<in>| |dom|(YMapInv C X F (YMap C X \<eta>) $$ Y)"
        have fHom: "f |\<in>| (Hom\<^bsub>C\<^esub> Y X)" using yinv_mapsTo fdomYinv by (simp add: SETmapsTo)
        hence fMapsTo: "(z2m\<^bsub>C \<^esub>f) maps\<^bsub>C \<^esub>Y to X" using assms YObj by (simp add: LSCategory.z2mm2z)
        hence fCod: "(cod\<^bsub>C\<^esub> (z2m\<^bsub>C \<^esub>f)) = X" and fDom: "(dom\<^bsub>C\<^esub> (z2m\<^bsub>C \<^esub>f)) = Y" and fMor: "(z2m\<^bsub>C \<^esub>f) \<in> Mor C" by auto
        have "(YMapInv C X F (YMap C X \<eta>) $$ Y) |@| f =
              (F ## (z2m\<^bsub>C \<^esub>f)) |@| ((\<eta> $$ X) |@| (m2z\<^bsub>C \<^esub>(Id C X)))"
          using fHom assms YObj by (simp add: ZFfunApp YMapInvApp YMap_def)
        also have "... = ((\<eta> $$ X) ;;\<^bsub>SET\<^esub> (F ## (z2m\<^bsub>C \<^esub>f))) |@| (m2z\<^bsub>C \<^esub>(Id C X))"
        proof-
          have aa: "(\<eta> $$ X) maps\<^bsub>SET\<^esub> ((YFtor C @@ X) @@ X) to (F @@ X)"
            using NT CDYF CCF YObjOp XObjOp NatTransMapsTo[of \<eta> "(YFtor C @@ X)" F X] by simp
          have bb: "(F ## (z2m\<^bsub>C \<^esub>f)) maps\<^bsub>SET\<^esub> (F @@ X) to (F @@ Y)"
            using fMapsTo Fftor by (simp add: MapsToOp FunctorMapsTo)
          have "(\<eta> $$ X) \<approx>>\<^bsub>SET\<^esub> (F ## (z2m\<^bsub>C \<^esub>f))" using aa bb by (simp add: MapsToCompDef)
          moreover have "(m2z\<^bsub>C \<^esub>(Id C X)) |\<in>| |dom| (\<eta> $$ X)" using assms aa
            by (simp add: SETmapsTo YFtorObj2 Category.Cidm LSCategory.m2zz2m)
          ultimately show ?thesis by (simp add: SETCompAt)
        qed
        also have "... = ((HomC\<^bsub>C\<^esub>[z2m\<^bsub>C \<^esub>f,X]) ;;\<^bsub>SET\<^esub> (\<eta> $$ Y)) |@| (m2z\<^bsub>C \<^esub>(Id C X))"
        proof-
          have "NTDom \<eta> = (Hom\<^bsub>C\<^esub>[\<emdash>,X])" using NTDeta assms by (simp add: YFtorObj)
          moreover hence "NTCatDom \<eta> = Op C" by (simp add: NTCatDom_def HomFtorContraDom)
          moreover have "NTCatCod \<eta> = SET" using assms by (auto simp add: NTCatCod_def)
          moreover have "NatTrans \<eta>" and "NTCod \<eta> = F" using assms by auto
          moreover have "(z2m\<^bsub>C \<^esub>f) maps\<^bsub>Op C \<^esub>X to Y"
            using fMapsTo MapsToOp[where ?f = "(z2m\<^bsub>C \<^esub>f)" and ?X = Y and ?Y = X and ?C = C] by simp
          ultimately have "(\<eta> $$ X) ;;\<^bsub>SET\<^esub> (F ## (z2m\<^bsub>C \<^esub>f)) = ((Hom\<^bsub>C\<^esub>[\<emdash>,X]) ## (z2m\<^bsub>C \<^esub>f)) ;;\<^bsub>SET\<^esub> (\<eta> $$ Y)"
            using NatTransP.NatTrans[of \<eta> "(z2m\<^bsub>C \<^esub>f)" X Y] by simp
          moreover have "((Hom\<^bsub>C\<^esub>[\<emdash>,X]) ## (z2m\<^bsub>C \<^esub>f)) = (HomC\<^bsub>C\<^esub>[(z2m\<^bsub>C \<^esub>f),X])" using assms fMor by (simp add: HomContraMor)
          ultimately show ?thesis by simp
        qed
        also have "... = (\<eta> $$ Y) |@| ((HomC\<^bsub>C\<^esub>[z2m\<^bsub>C \<^esub>f,X]) |@| (m2z\<^bsub>C \<^esub>(Id C X)))"
        proof-
          have "(HomC\<^bsub>C\<^esub>[z2m\<^bsub>C \<^esub>f,X]) \<approx>>\<^bsub>SET\<^esub> (\<eta> $$ Y)"
            using fCod fDom XObj LSCat fMor HomFtorContraMapsTo[of C X "z2m\<^bsub>C \<^esub>f"] eta_mapsTo by (simp add: MapsToCompDef)
          moreover have "|dom| (HomC\<^bsub>C\<^esub>[z2m\<^bsub>C \<^esub>f,X]) = (Hom\<^bsub>C\<^esub> (cod\<^bsub>C\<^esub> (z2m\<^bsub>C \<^esub>f)) X)"
            by (simp add: ZFfunDom HomFtorMapContra_def)
          moreover have "(m2z\<^bsub>C \<^esub>(Id C X)) |\<in>| (Hom\<^bsub>C\<^esub> (cod\<^bsub>C\<^esub> (z2m\<^bsub>C \<^esub>f)) X)"
            using assms fCod by (simp add: Category.Cidm LSCategory.m2zz2m)
          ultimately show ?thesis by (simp add: SETCompAt)
        qed
        also have "... = (\<eta> $$ Y) |@| (m2z\<^bsub>C\<^esub> ((z2m\<^bsub>C \<^esub>f) ;;\<^bsub>C\<^esub> (z2m\<^bsub>C\<^esub> (m2z\<^bsub>C \<^esub>(Id C X)))))"
        proof-
          have "(Id C X) maps\<^bsub>C\<^esub> (cod\<^bsub>C\<^esub> (z2m\<^bsub>C \<^esub>f)) to X" using assms fCod by (simp add: Category.Cidm)
          hence "(m2z\<^bsub>C \<^esub>(Id C X)) |\<in>| (Hom\<^bsub>C\<^esub> (cod\<^bsub>C\<^esub> (z2m\<^bsub>C \<^esub>f)) X)" using assms by (simp add: LSCategory.m2zz2m)
          thus ?thesis by (simp add: HomContraAt)
        qed
        also have "... = (\<eta> $$ Y) |@| (m2z\<^bsub>C\<^esub> ((z2m\<^bsub>C \<^esub>f) ;;\<^bsub>C\<^esub> (Id C X)))"
          using assms by (simp add: LSCategory.m2zz2mInv Category.CatIdInMor)
        also have "... = (\<eta> $$ Y) |@| (m2z\<^bsub>C\<^esub> (z2m\<^bsub>C \<^esub>f))" using assms(1) fCod fMor Category.Cidr[of C "(z2m\<^bsub>C \<^esub>f)"] by (simp)
        also have "... = (\<eta> $$ Y) |@| f" using assms YObj fHom by (simp add: LSCategory.z2mm2z)
        finally show "(YMapInv C X F (YMap C X \<eta>) $$ Y) |@| f = (\<eta> $$ Y) |@| f" .
      }
    qed
  }
qed

lemma YMap2:
  assumes "LSCategory C" and "Ftor F : (Op C) \<longrightarrow> SET" and "X \<in> Obj C"
  and "x |\<in>| (F @@ X)"
  shows "YMap C X (YMapInv C X F x) = x"
proof(simp only: YMap_def)
  let ?\<eta> = "(YMapInv C X F x)"
  have "(?\<eta> $$ X) = ZFfun (Hom\<^bsub>C\<^esub> X X) (F @@ X) (\<lambda> f . (F ## (z2m\<^bsub>C\<^esub> f)) |@| x)" using assms by (simp add: YMapInvApp)
  moreover have "(m2z\<^bsub>C \<^esub>(Id C X)) |\<in>| (Hom\<^bsub>C\<^esub> X X)" using assms by (simp add: Category.Simps LSCategory.m2zz2m)
  ultimately have "(?\<eta> $$ X) |@| (m2z\<^bsub>C \<^esub>(Id C X)) = (F ## (z2m\<^bsub>C\<^esub> (m2z\<^bsub>C \<^esub>(Id C X)))) |@| x"
    by (simp add: ZFfunApp)
  also have "... = (F ## (Id C X)) |@| x" using assms by (simp add: Category.CatIdInMor LSCategory.m2zz2mInv)
  also have "... = (Id SET (F @@ X)) |@| x"
  proof-
    have "X \<in> Obj (Op C)" using assms by (auto simp add: OppositeCategory_def)
    hence "(F ## (Id (Op C) X)) = (Id SET (F @@ X))"
      using assms by(simp add: FunctorId)
    moreover have "(Id (Op C) X) = (Id C X)" using assms by (auto simp add: OppositeCategory_def)
    ultimately show ?thesis by simp
  qed
  also have "... = x" using assms by (simp add: SETId)
  finally show "(?\<eta> $$ X) |@| (m2z\<^bsub>C \<^esub>(Id C X)) = x" .
qed

lemma YFtorNT_YMapInv:
  assumes "LSCategory C" and "f maps\<^bsub>C\<^esub> X to Y"
  shows "YFtorNT C f = YMapInv C X (Hom\<^bsub>C\<^esub>[\<emdash>,Y]) (m2z\<^bsub>C\<^esub> f)"
proof(simp only: YFtorNT_def YMapInv_def, rule NatTransExt')
  have Cf: "cod\<^bsub>C\<^esub> f = Y" and Df: "dom\<^bsub>C\<^esub> f = X" using assms by auto
  thus "NTCod (YFtorNT' C f) = NTCod (YMapInv' C X (Hom\<^bsub>C\<^esub>[\<emdash>,Y]) (m2z\<^bsub>C\<^esub>f))"
    by(simp add: YFtorNT'_def YMapInv'_def )
  have "Hom\<^bsub>C\<^esub>[\<emdash>,dom\<^bsub>C\<^esub> f] = YFtor C @@ X" using Df assms by (simp add: YFtorObj Category.MapsToObj)
  thus "NTDom (YFtorNT' C f) = NTDom (YMapInv' C X (Hom\<^bsub>C\<^esub>[\<emdash>,Y]) (m2z\<^bsub>C\<^esub>f))"
    by(simp add: YFtorNT'_def YMapInv'_def )
  {
    fix Z assume ObjZ1: "Z \<in> Obj (NTCatDom (YFtorNT' C f))"
    have ObjZ2: "Z \<in> Obj C" using ObjZ1 by (simp add: YFtorNT'_def NTCatDom_def OppositeCategory_def HomFtorContraDom)
    moreover have ObjX: "X \<in> Obj C" and ObjY: "Y \<in> Obj C" using assms by (simp add: Category.MapsToObj)+
    moreover
    {
      fix x assume x: "x |\<in>| (Hom\<^bsub>C\<^esub> Z X)"
      have "m2z\<^bsub>C \<^esub>((z2m\<^bsub>C \<^esub>x) ;;\<^bsub>C\<^esub> f) = ((Hom\<^bsub>C\<^esub>[\<emdash>,Y]) ## (z2m\<^bsub>C \<^esub>x)) |@| (m2z\<^bsub>C\<^esub>f)"
      proof-
        have morf: "f \<in> Mor C" using assms by auto
        have mapsx: "(z2m\<^bsub>C \<^esub>x) maps\<^bsub>C\<^esub> Z to X" using x assms(1) ObjZ2 ObjX by (simp add: LSCategory.z2mm2z)
        hence morx: "(z2m\<^bsub>C \<^esub>x) \<in> Mor C" by auto
        hence "(Hom\<^bsub>C\<^esub>[\<emdash>,Y]) ## (z2m\<^bsub>C \<^esub>x) = (HomC\<^bsub>C\<^esub>[(z2m\<^bsub>C \<^esub>x),Y])" using assms by (simp add: HomContraMor)
        moreover have "(HomC\<^bsub>C\<^esub>[(z2m\<^bsub>C \<^esub>x),Y]) |@| (m2z\<^bsub>C \<^esub>f) = m2z\<^bsub>C \<^esub>((z2m\<^bsub>C \<^esub>x) ;;\<^bsub>C\<^esub> (z2m\<^bsub>C \<^esub>(m2z\<^bsub>C \<^esub>f)))"
        proof (rule HomContraAt)
          have "cod\<^bsub>C\<^esub> (z2m\<^bsub>C \<^esub>x) = X" using mapsx by auto
          thus "(m2z\<^bsub>C \<^esub>f) |\<in>| (Hom\<^bsub>C\<^esub> (cod\<^bsub>C\<^esub> (z2m\<^bsub>C \<^esub>x)) Y)" using assms by (simp add: LSCategory.m2zz2m)
        qed
        moreover have "(z2m\<^bsub>C \<^esub>(m2z\<^bsub>C \<^esub>f)) = f" using assms morf by (simp add: LSCategory.m2zz2mInv)
        ultimately show ?thesis by simp
      qed
    }
    ultimately show "(YFtorNT' C f) $$ Z = (YMapInv' C X (Hom\<^bsub>C\<^esub>[\<emdash>,Y]) (m2z\<^bsub>C\<^esub>f)) $$ Z" using Cf Df assms
      apply(simp add: YFtorNT'_def YMapInv'_def HomFtorMap_def HomFtorOpObj)
      apply(rule ZFfun_ext, rule allI, rule impI, simp)
      done
  }
qed

lemma YMapYoneda:
  assumes "LSCategory C" and "f maps\<^bsub>C\<^esub> X to Y"
  shows "YFtor C ## f = YMapInv C X (YFtor C @@ Y) (m2z\<^bsub>C\<^esub> f)"
proof-
  have "f \<in> Mor C" using assms by auto
  moreover have "Y \<in> Obj C" using assms by (simp add: Category.MapsToObj)
  moreover have "YFtorNT C f = YMapInv C X (Hom\<^bsub>C\<^esub>[\<emdash>,Y]) (m2z\<^bsub>C\<^esub> f)" using assms by (simp add: YFtorNT_YMapInv)
  ultimately show ?thesis using assms by (simp add: YFtorMor YFtorObj)
qed

lemma YonedaFull:
  assumes "LSCategory C" and "X \<in> Obj C" and "Y \<in> Obj C"
  and "NT \<eta> : (YFtor C @@ X) \<Longrightarrow> (YFtor C @@ Y)"
  shows "YFtor C ## (z2m\<^bsub>C\<^esub> (YMap C X \<eta>)) = \<eta>"
  and "z2m\<^bsub>C\<^esub> (YMap C X \<eta>) maps\<^bsub>C\<^esub> X to Y"
proof-
  have ftor: "Ftor (YFtor C @@ Y) : (Op C) \<longrightarrow> SET" using assms by (simp add: YFtorObj HomFtorContraFtor)
  hence "(YMap C X \<eta>) |\<in>| ((YFtor C @@ Y) @@ X)" using assms by (simp add: YMapImage)
  hence yh: "(YMap C X \<eta>) |\<in>| (Hom\<^bsub>C\<^esub> X Y)" using assms by (simp add: YFtorObj2)
  thus "(z2m\<^bsub>C\<^esub> (YMap C X \<eta>)) maps\<^bsub>C\<^esub> X to Y" using assms by (simp add: LSCategory.z2mm2z)
  hence "YFtor C ## (z2m\<^bsub>C\<^esub> (YMap C X \<eta>)) = YMapInv C X (YFtor C @@ Y) (m2z\<^bsub>C\<^esub> (z2m\<^bsub>C\<^esub> (YMap C X \<eta>)))"
    using assms yh by (simp add: YMapYoneda)
  also have "... = YMapInv C X (YFtor C @@ Y) (YMap C X \<eta>)"
    using assms yh by (simp add: LSCategory.z2mm2z)
  finally show "YFtor C ## (z2m\<^bsub>C\<^esub> (YMap C X \<eta>)) = \<eta>" using assms ftor by (simp add: YMap1)
qed

lemma YonedaFaithful:
  assumes "LSCategory C" and "f maps\<^bsub>C\<^esub> X to Y" and "g maps\<^bsub>C\<^esub> X to Y"
  and "YFtor C ## f = YFtor C ## g"
  shows "f = g"
proof-
  have ObjX: "X \<in> Obj C" and ObjY: "Y \<in> Obj C" using assms by (simp add: Category.MapsToObj)+
  have M2Zf: "(m2z\<^bsub>C\<^esub> f) |\<in>| ((YFtor C @@ Y) @@ X)" and M2Zg: "(m2z\<^bsub>C\<^esub> g) |\<in>| ((YFtor C @@ Y) @@ X)"
    using assms ObjX ObjY by (simp add: LSCategory.m2zz2m YFtorObj2)+
  have Ftor: "Ftor (YFtor C @@ Y) : (Op C) \<longrightarrow> SET" using assms ObjY by (simp add: YFtorObj HomFtorContraFtor)
  have Morf: "f \<in> Mor C" and Morg: "g \<in> Mor C" using assms by auto
  have "YMapInv C X (YFtor C @@ Y) (m2z\<^bsub>C\<^esub> f) = YMapInv C X (YFtor C @@ Y) (m2z\<^bsub>C\<^esub> g)"
    using assms by (simp add: YMapYoneda)
  hence "YMap C X (YMapInv C X (YFtor C @@ Y) (m2z\<^bsub>C\<^esub> f)) = YMap C X (YMapInv C X (YFtor C @@ Y) (m2z\<^bsub>C\<^esub> g))"
    by simp
  hence "(m2z\<^bsub>C\<^esub> f) = (m2z\<^bsub>C\<^esub> g)" using assms ObjX ObjY M2Zf M2Zg Ftor by (simp add: YMap2)
  thus "f = g" using assms Morf Morg by (simp add: LSCategory.mor2ZFInj)
qed

lemma YonedaEmbedding:
  assumes "LSCategory C" and "A \<in> Obj C" and "B \<in> Obj C" and "(YFtor C) @@ A = (YFtor C) @@ B"
  shows "A = B"
proof-
  have AObjOp: "A \<in> Obj (Op C)" and BObjOp: "B \<in> Obj (Op C)" using assms by (simp add: OppositeCategory_def)+
  hence FtorA: "Ftor (Hom\<^bsub>C\<^esub>[\<emdash>,A]) : (Op C) \<longrightarrow> SET" and FtorB: "Ftor (Hom\<^bsub>C\<^esub>[\<emdash>,B]) : (Op C) \<longrightarrow> SET"
    using assms by (simp add: HomFtorContraFtor)+
  have "Hom\<^bsub>C\<^esub>[\<emdash>,A] = Hom\<^bsub>C\<^esub>[\<emdash>,B]" using assms by (simp add: YFtorObj)
  hence "(Hom\<^bsub>C\<^esub>[\<emdash>,A]) ## (Id (Op C) A) = (Hom\<^bsub>C\<^esub>[\<emdash>,B]) ## (Id (Op C) A)" by simp
  hence "Id SET ((Hom\<^bsub>C\<^esub>[\<emdash>,A]) @@ A) = Id SET ((Hom\<^bsub>C\<^esub>[\<emdash>,B]) @@ A)"
    using AObjOp BObjOp FtorA FtorB by (simp add: FunctorId)
  hence "Id SET (Hom\<^bsub>C \<^esub>A A) = Id SET (Hom\<^bsub>C \<^esub>A B)" using assms by (simp add: HomFtorOpObj)
  hence "Hom\<^bsub>C \<^esub>A A = Hom\<^bsub>C \<^esub>A B" using SETCategory by (simp add: Category.IdInj SETobj[of "Hom\<^bsub>C \<^esub>A A"] SETobj[of "Hom\<^bsub>C \<^esub>A B"])
  moreover have "(m2z\<^bsub>C\<^esub> (Id C A)) |\<in>| (Hom\<^bsub>C \<^esub>A A)" using assms by (simp add: Category.Cidm LSCategory.m2zz2m)
  ultimately have "(m2z\<^bsub>C\<^esub> (Id C A)) |\<in>| (Hom\<^bsub>C \<^esub>A B)" by simp
  hence "(z2m\<^bsub>C\<^esub> (m2z\<^bsub>C\<^esub> (Id C A))) maps\<^bsub>C\<^esub> A to B" using assms by (simp add: LSCategory.z2mm2z)
  hence "(Id C A) maps\<^bsub>C\<^esub> A to B" using assms by (simp add: Category.CatIdInMor LSCategory.m2zz2mInv)
  hence "cod\<^bsub>C\<^esub> (Id C A) = B" by auto
  thus ?thesis using assms by (simp add: Category.CatIdDomCod)
qed

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_prop_70
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun t2 :: "Nat => Nat => bool" where
"t2 (Z) y = True"
| "t2 (S z) (Z) = False"
| "t2 (S z) (S x2) = t2 z x2"

theorem property0 :
  "((t2 m n) ==> (t2 m (S n)))"
  oops

end


theory LinearAlgebra_EuclideanSpaceIsNormedSpace_T
imports "$HETS_LIB/Isabelle/MainHCPairs"
uses "$HETS_LIB/Isabelle/prelude"
begin

ML "Header.initialize
    [\"subtype_def\", \"subtype_pred_def\",
     \"ga_assoc___Xx__\", \"ga_right_unit___Xx__\",
     \"ga_left_unit___Xx__\", \"inv_Group_2\", \"rinv_Group\",
     \"ga_comm___Xx__\", \"ga_assoc___Xx___1\",
     \"ga_right_unit___Xx___1\", \"ga_left_unit___Xx___1\",
     \"distr1_Ring\", \"distr2_Ring\", \"ga_comm___Xx___1\",
     \"noZeroDiv\", \"zeroNeqOne\", \"Ax1\", \"ga_assoc___Xx___2\",
     \"ga_right_unit___Xx___2\", \"ga_left_unit___Xx___2\",
     \"inv_Group_1\", \"rinv_Group_1\", \"binary_inverse\", \"Ax1_1\",
     \"refl\", \"trans\", \"antisym\", \"dichotomy_TotalOrder\",
     \"FWO_plus_left\", \"FWO_times_left\", \"FWO_plus_right\",
     \"FWO_times_right\", \"FWO_plus\", \"inf_def\",
     \"Real_completeness\", \"geq_def_ExtPartialOrder\",
     \"less_def_ExtPartialOrder\", \"greater_def_ExtPartialOrder\",
     \"ga_comm_inf\", \"ga_comm_sup\", \"inf_def_ExtPartialOrder\",
     \"sup_def_ExtPartialOrder\", \"ga_comm_min\", \"ga_comm_max\",
     \"ga_assoc_min\", \"ga_assoc_max\", \"ga_left_comm_min\",
     \"ga_left_comm_max\", \"min_def_ExtTotalOrder\",
     \"max_def_ExtTotalOrder\", \"min_inf_relation\",
     \"max_sup_relation\", \"RealNonNeg_pred_def\",
     \"RealPos_pred_def\", \"Ax3\", \"Ax4\", \"RealNonNeg_subtype\",
     \"RealPos_subtype\", \"abs_def\", \"ga_assoc___Xx___3\",
     \"ga_right_unit___Xx___3\", \"ga_left_unit___Xx___3\",
     \"inv_Group_3\", \"rinv_Group_2\", \"ga_comm___Xx___3\",
     \"binary_inverse_1\", \"unit\", \"mix_assoc\", \"distr_Field\",
     \"distr_Space\", \"zero_by_left_zero\", \"zero_by_right_zero\",
     \"inverse_by_XMinus1\", \"distributive\", \"homogeneous\",
     \"symmetric\", \"pos_definite\", \"right_distributive\",
     \"right_homogeneous\", \"non_degenerate\", \"sqr_def\",
     \"sqrt_def\", \"lindep_def\", \"lindep_reflexivity\",
     \"lindep_symmetry\", \"simple_lindep_condition\",
     \"lindep_nonlindep_transitivity\", \"norm_from_inner_prod_def\",
     \"proj_def\", \"orthcomp_def\", \"orthogonal_def\",
     \"orth_symmetric\", \"lindep_orth_transitive\",
     \"orthogonal_on_zero_projection\",
     \"orthogonal_projection_theorem\",
     \"orthogonal_decomposition_theorem\",
     \"unique_orthogonal_decomposition\", \"homogen\", \"triangle\",
     \"definit\", \"nonXMinusnegative\", \"posXMinusdefinite\",
     \"multiplic\", \"triangle_1\"]"

typedecl NonZero
typedecl Real
typedecl RealNonNeg
typedecl RealPos
typedecl Space

consts
X0X1 :: "Real" ("0''")
X0X2 :: "Space" ("0''''")
X1X1 :: "NonZero" ("1''")
X1X2 :: "Real" ("1''''")
XMinus__XX1 :: "Real => Real" ("(-''/ _)" [56] 56)
XMinus__XX2 :: "Space => Space" ("(-''''/ _)" [56] 56)
XVBarXVBar__XVBarXVBar :: "Space => Real" ("(||/ _/ ||)" [10] 999)
X_RealNonNeg_inj :: "RealNonNeg => Real" ("RealNonNeg'_inj/'(_')" [3] 999)
X_RealNonNeg_pred :: "Real => bool" ("RealNonNeg'_pred/'(_')" [3] 999)
X_RealNonNeg_proj :: "Real => RealNonNeg" ("RealNonNeg'_proj/'(_')" [3] 999)
X_RealPos_inj :: "RealPos => Real" ("RealPos'_inj/'(_')" [3] 999)
X_RealPos_pred :: "Real => bool" ("RealPos'_pred/'(_')" [3] 999)
X_RealPos_proj :: "Real => RealPos" ("RealPos'_proj/'(_')" [3] 999)
X__XGtXEq__X :: "Real => Real => bool" ("(_/ >=''/ _)" [44,44] 42)
X__XGt__X :: "Real => Real => bool" ("(_/ >''/ _)" [44,44] 42)
X__XLtXEq__X :: "Real => Real => bool" ("(_/ <=''/ _)" [44,44] 42)
X__XLt__X :: "Real => Real => bool" ("(_/ <''/ _)" [44,44] 42)
X__XMinus__XX1 :: "Real => Real => Real" ("(_/ -''/ _)" [54,54] 52)
X__XMinus__XX2 :: "Space => Space => Space" ("(_/ -''''/ _)" [54,54] 52)
X__XPlus__XX1 :: "Real => Real => Real" ("(_/ +''/ _)" [54,54] 52)
X__XPlus__XX2 :: "Space => Space => Space" ("(_/ +''''/ _)" [54,54] 52)
X__XSlash__X :: "Real => NonZero => Real" ("(_/ '/''/ _)" [54,54] 52)
X__Xx__XX1 :: "NonZero => NonZero => NonZero" ("(_/ *''/ _)" [54,54] 52)
X__Xx__XX2 :: "Real => Real => Real" ("(_/ *''''/ _)" [54,54] 52)
X__Xx__XX3 :: "Real => Space => Space" ("(_/ *'_3/ _)" [54,54] 52)
X__Xx__XX4 :: "Space => Space => Real" ("(_/ *'_4/ _)" [54,54] 52)
X_abs :: "Real => RealNonNeg" ("abs''/'(_')" [3] 999)
X_gn_inj :: "'a => 'b" ("gn'_inj/'(_')" [3] 999)
X_gn_proj :: "'a => 'b partial" ("gn'_proj/'(_')" [3] 999)
X_inv :: "NonZero => NonZero" ("inv''/'(_')" [3] 999)
X_isSubtype :: "('s => 't) => ('t => 's) => bool" ("isSubtype/'(_,/ _')" [3,3] 999)
X_isSubtypeWithPred :: "('t => bool) => ('s => 't) => ('t => 's) => bool" ("isSubtypeWithPred/'(_,/ _,/ _')" [3,3,3] 999)
X_lindep :: "Space => Space => bool" ("lindep/'(_,/ _')" [3,3] 999)
X_max :: "Real => Real => Real" ("max''/'(_,/ _')" [3,3] 999)
X_min :: "Real => Real => Real" ("min''/'(_,/ _')" [3,3] 999)
X_orth :: "Space => Space => bool" ("orth/'(_,/ _')" [3,3] 999)
X_orthcomp :: "Space => Space => Space" ("orthcomp/'(_,/ _')" [3,3] 999)
X_proj :: "Space => Space => Space" ("proj/'(_,/ _')" [3,3] 999)
X_sqr :: "Real => RealNonNeg" ("sqr/'(_')" [3] 999)
X_sqrt :: "RealNonNeg => RealNonNeg" ("sqrt/'(_')" [3] 999)
X_sup :: "Real => Real => Real partial" ("sup/'(_,/ _')" [3,3] 999)
infX1 :: "Real => Real => Real partial" ("inf''/'(_,/ _')" [3,3] 999)
infX2 :: "(Real => bool) => Real partial" ("inf''''/'(_')" [3] 999)

axioms
subtype_def [rule_format] :
"ALL injection.
 ALL projection.
 isSubtype(injection, projection) =
 (ALL x. x = projection (injection x))"

subtype_pred_def [rule_format] :
"ALL P.
 ALL injection.
 ALL projection.
 isSubtypeWithPred(P, injection, projection) =
 ((isSubtype(injection, projection) &
   (ALL x. P x --> x = injection (projection x))) &
  (ALL x. P (injection x)))"

ga_assoc___Xx__ [rule_format] :
"ALL x. ALL y. ALL z. (x +' y) +' z = x +' (y +' z)"

ga_right_unit___Xx__ [rule_format] : "ALL x. x +' 0' = x"

ga_left_unit___Xx__ [rule_format] : "ALL x. 0' +' x = x"

inv_Group_2 [rule_format] : "ALL x. -' x +' x = 0'"

rinv_Group [rule_format] : "ALL x. x +' -' x = 0'"

ga_comm___Xx__ [rule_format] : "ALL x. ALL y. x +' y = y +' x"

ga_assoc___Xx___1 [rule_format] :
"ALL x. ALL y. ALL z. (x *'' y) *'' z = x *'' (y *'' z)"

ga_right_unit___Xx___1 [rule_format] : "ALL x. x *'' 1'' = x"

ga_left_unit___Xx___1 [rule_format] : "ALL x. 1'' *'' x = x"

distr1_Ring [rule_format] :
"ALL x. ALL y. ALL z. (x +' y) *'' z = (x *'' z) +' (y *'' z)"

distr2_Ring [rule_format] :
"ALL x. ALL y. ALL z. z *'' (x +' y) = (z *'' x) +' (z *'' y)"

ga_comm___Xx___1 [rule_format] : "ALL x. ALL y. x *'' y = y *'' x"

noZeroDiv [rule_format] :
"ALL x. ALL y. x *'' y = 0' --> x = 0' | y = 0'"

zeroNeqOne [rule_format] : "~ 1'' = 0'"

Ax1 [rule_format] : "ALL x. defOp (gn_proj(x)) = (~ x = 0')"

ga_assoc___Xx___2 [rule_format] :
"ALL x. ALL y. ALL z. (x *' y) *' z = x *' (y *' z)"

ga_right_unit___Xx___2 [rule_format] : "ALL x. x *' 1' = x"

ga_left_unit___Xx___2 [rule_format] : "ALL x. 1' *' x = x"

inv_Group_1 [rule_format] : "ALL x. inv'(x) *' x = 1'"

rinv_Group_1 [rule_format] : "ALL x. x *' inv'(x) = 1'"

binary_inverse [rule_format] : "ALL x. ALL y. x -' y = x +' -' y"

Ax1_1 [rule_format] :
"ALL x. ALL y. x /' y = x *'' gn_inj(inv'(y))"

refl [rule_format] : "ALL x. x <=' x"

trans [rule_format] :
"ALL x. ALL y. ALL z. x <=' y & y <=' z --> x <=' z"

antisym [rule_format] : "ALL x. ALL y. x <=' y & y <=' x --> x = y"

dichotomy_TotalOrder [rule_format] :
"ALL x. ALL y. x <=' y | y <=' x"

FWO_plus_left [rule_format] :
"ALL a. ALL b. ALL c. a <=' b --> a +' c <=' b +' c"

FWO_times_left [rule_format] :
"ALL a. ALL b. ALL c. a <=' b & 0' <=' c --> a *'' c <=' b *'' c"

FWO_plus_right [rule_format] :
"ALL a. ALL b. ALL c. b <=' c --> a +' b <=' a +' c"

FWO_times_right [rule_format] :
"ALL a. ALL b. ALL c. b <=' c & 0' <=' a --> a *'' b <=' a *'' c"

FWO_plus [rule_format] :
"ALL a.
 ALL b. ALL c. ALL d. a <=' c & b <=' d --> a +' b <=' c +' d"

inf_def [rule_format] :
"ALL S.
 ALL m.
 inf''(S) = makePartial m =
 (ALL m2. (ALL x. S x --> x <=' m2) --> m <=' m2)"

Real_completeness [rule_format] :
"ALL S.
 (EX x. S x) & (EX B. ALL x. S x --> x <=' B) -->
 (EX m. makePartial m = inf''(S))"

geq_def_ExtPartialOrder [rule_format] :
"ALL x. ALL y. (x >=' y) = (y <=' x)"

less_def_ExtPartialOrder [rule_format] :
"ALL x. ALL y. (x <' y) = (x <=' y & ~ x = y)"

greater_def_ExtPartialOrder [rule_format] :
"ALL x. ALL y. (x >' y) = (y <' x)"

ga_comm_inf [rule_format] : "ALL x. ALL y. inf'(x, y) = inf'(y, x)"

ga_comm_sup [rule_format] : "ALL x. ALL y. sup(x, y) = sup(y, x)"

inf_def_ExtPartialOrder [rule_format] :
"ALL x.
 ALL y.
 ALL z.
 inf'(x, y) = makePartial z =
 (z <=' x & z <=' y & (ALL t. t <=' x & t <=' y --> t <=' z))"

sup_def_ExtPartialOrder [rule_format] :
"ALL x.
 ALL y.
 ALL z.
 sup(x, y) = makePartial z =
 (x <=' z & y <=' z & (ALL t. x <=' t & y <=' t --> z <=' t))"

ga_comm_min [rule_format] : "ALL x. ALL y. min'(x, y) = min'(y, x)"

ga_comm_max [rule_format] : "ALL x. ALL y. max'(x, y) = max'(y, x)"

ga_assoc_min [rule_format] :
"ALL x. ALL y. ALL z. min'(min'(x, y), z) = min'(x, min'(y, z))"

ga_assoc_max [rule_format] :
"ALL x. ALL y. ALL z. max'(max'(x, y), z) = max'(x, max'(y, z))"

ga_left_comm_min [rule_format] :
"ALL x. ALL y. ALL z. min'(x, min'(y, z)) = min'(y, min'(x, z))"

ga_left_comm_max [rule_format] :
"ALL x. ALL y. ALL z. max'(x, max'(y, z)) = max'(y, max'(x, z))"

min_def_ExtTotalOrder [rule_format] :
"ALL x. ALL y. min'(x, y) = (if x <=' y then x else y)"

max_def_ExtTotalOrder [rule_format] :
"ALL x. ALL y. max'(x, y) = (if x <=' y then y else x)"

min_inf_relation [rule_format] :
"ALL x. ALL y. makePartial (min'(x, y)) = inf'(x, y)"

max_sup_relation [rule_format] :
"ALL x. ALL y. makePartial (max'(x, y)) = sup(x, y)"

RealNonNeg_pred_def [rule_format] :
"ALL x. RealNonNeg_pred(x) = (x >=' 0')"

RealPos_pred_def [rule_format] :
"ALL x. RealPos_pred(x) = (x >' 0')"

Ax3 [rule_format] :
"ALL x. defOp (gn_proj(x)) = RealNonNeg_pred(x)"

Ax4 [rule_format] : "ALL x. defOp (gn_proj(x)) = RealPos_pred(x)"

RealNonNeg_subtype [rule_format] :
"isSubtypeWithPred(X_RealNonNeg_pred, X_RealNonNeg_inj,
 X_RealNonNeg_proj)"

RealPos_subtype [rule_format] :
"isSubtypeWithPred(X_RealPos_pred, X_RealPos_inj, X_RealPos_proj)"

abs_def [rule_format] :
"ALL x.
 makePartial (abs'(x)) =
 (if 0' <=' x then gn_proj(x) else gn_proj(-' x))"

ga_assoc___Xx___3 [rule_format] :
"ALL x. ALL y. ALL z. (x +'' y) +'' z = x +'' (y +'' z)"

ga_right_unit___Xx___3 [rule_format] : "ALL x. x +'' 0'' = x"

ga_left_unit___Xx___3 [rule_format] : "ALL x. 0'' +'' x = x"

inv_Group_3 [rule_format] : "ALL x. -'' x +'' x = 0''"

rinv_Group_2 [rule_format] : "ALL x. x +'' -'' x = 0''"

ga_comm___Xx___3 [rule_format] : "ALL x. ALL y. x +'' y = y +'' x"

binary_inverse_1 [rule_format] :
"ALL x. ALL y. x -'' y = x +'' -'' y"

unit [rule_format] : "ALL x. gn_inj(1') *_3 x = x"

mix_assoc [rule_format] :
"ALL r. ALL s. ALL x. (r *'' s) *_3 x = r *_3 (s *_3 x)"

distr_Field [rule_format] :
"ALL r. ALL s. ALL x. (r +' s) *_3 x = (r *_3 x) +'' (s *_3 x)"

distr_Space [rule_format] :
"ALL r. ALL x. ALL y. r *_3 (x +'' y) = (r *_3 x) +'' (r *_3 y)"

zero_by_left_zero [rule_format] : "ALL x. 0' *_3 x = 0''"

zero_by_right_zero [rule_format] : "ALL r. r *_3 0'' = 0''"

inverse_by_XMinus1 [rule_format] :
"ALL x. -' gn_inj(1') *_3 x = -'' x"

distributive [rule_format] :
"ALL v. ALL v'. ALL w. (v +'' v') *_4 w = (v *_4 w) +' (v' *_4 w)"

homogeneous [rule_format] :
"ALL a. ALL v. ALL w. (a *_3 v) *_4 w = a *'' (v *_4 w)"

symmetric [rule_format] : "ALL v. ALL w. v *_4 w = w *_4 v"

pos_definite [rule_format] : "ALL v. ~ v = 0'' --> v *_4 v >' 0'"

right_distributive [rule_format] :
"ALL v. ALL v'. ALL w. w *_4 (v +'' v') = (w *_4 v) +' (w *_4 v')"

right_homogeneous [rule_format] :
"ALL a. ALL v. ALL w. v *_4 (a *_3 w) = a *'' (v *_4 w)"

non_degenerate [rule_format] : "ALL v. v *_4 v = 0' --> v = 0''"

sqr_def [rule_format] :
"ALL r. gn_inj(sqr(r)) = makePartial (r *'' r)"

sqrt_def [rule_format] : "ALL q. sqr(gn_inj(sqrt(q))) = q"

lindep_def [rule_format] :
"ALL x. ALL y. lindep(x, y) = (y = 0'' | (EX r. x = r *_3 y))"

lindep_reflexivity [rule_format] : "ALL x. lindep(x, x)"

lindep_symmetry [rule_format] :
"ALL x. ALL y. lindep(x, y) --> lindep(y, x)"

simple_lindep_condition [rule_format] :
"ALL r. ALL x. ALL y. x = r *_3 y --> lindep(x, y)"

lindep_nonlindep_transitivity [rule_format] :
"ALL x.
 ALL y.
 ALL z.
 (~ x = 0'' & lindep(x, y)) & ~ lindep(y, z) --> ~ lindep(x, z)"

norm_from_inner_prod_def [rule_format] :
"ALL x.
 makePartial ( || x || ) =
 restrictOp (gn_proj(sqrt(makeTotal (gn_proj(x *_4 x)))))
 (defOp (gn_proj(x *_4 x)))"

proj_def [rule_format] :
"ALL v.
 ALL w.
 makePartial (proj(v, w)) =
 (if w = 0'' then makePartial 0''
     else restrictOp
          (makePartial (((v *_4 w) /' makeTotal (gn_proj(w *_4 w))) *_3 w))
          (defOp (gn_proj(w *_4 w))))"

orthcomp_def [rule_format] :
"ALL v. ALL w. orthcomp(v, w) = v -'' proj(v, w)"

orthogonal_def [rule_format] :
"ALL x. ALL y. orth(x, y) = (x *_4 y = 0')"

orth_symmetric [rule_format] :
"ALL x. ALL y. orth(x, y) --> orth(y, x)"

lindep_orth_transitive [rule_format] :
"ALL x. ALL y. ALL z. lindep(x, y) & orth(y, z) --> orth(x, z)"

orthogonal_on_zero_projection [rule_format] :
"ALL x. ALL y. proj(x, y) = 0'' --> orth(x, y)"

orthogonal_projection_theorem [rule_format] :
"ALL x. ALL y. orth(orthcomp(x, y), y)"

orthogonal_decomposition_theorem [rule_format] :
"ALL x. ALL y. proj(x, y) +'' orthcomp(x, y) = x"

unique_orthogonal_decomposition [rule_format] :
"ALL v.
 ALL w.
 ALL x.
 ALL y.
 ALL z.
 ((((~ z = 0'' & x +'' y = v +'' w) & lindep(x, z)) &
   lindep(v, z)) &
  orth(z, y)) &
 orth(z, w) -->
 x = v & y = w"

declare ga_assoc___Xx__ [simp]
declare ga_right_unit___Xx__ [simp]
declare ga_left_unit___Xx__ [simp]
declare inv_Group_2 [simp]
declare rinv_Group [simp]
declare ga_comm___Xx__ [simp]
declare ga_assoc___Xx___1 [simp]
declare ga_right_unit___Xx___1 [simp]
declare ga_left_unit___Xx___1 [simp]
declare ga_comm___Xx___1 [simp]
declare ga_assoc___Xx___2 [simp]
declare ga_right_unit___Xx___2 [simp]
declare ga_left_unit___Xx___2 [simp]
declare inv_Group_1 [simp]
declare rinv_Group_1 [simp]
declare refl [simp]
declare FWO_plus_left [simp]
declare FWO_plus_right [simp]
declare ga_comm_inf [simp]
declare ga_comm_sup [simp]
declare ga_comm_min [simp]
declare ga_comm_max [simp]
declare ga_assoc_min [simp]
declare ga_assoc_max [simp]
declare ga_left_comm_min [simp]
declare ga_left_comm_max [simp]
declare min_inf_relation [simp]
declare max_sup_relation [simp]
declare Ax3 [simp]
declare Ax4 [simp]
declare RealNonNeg_subtype [simp]
declare RealPos_subtype [simp]
declare ga_assoc___Xx___3 [simp]
declare ga_right_unit___Xx___3 [simp]
declare ga_left_unit___Xx___3 [simp]
declare inv_Group_3 [simp]
declare rinv_Group_2 [simp]
declare ga_comm___Xx___3 [simp]
declare unit [simp]
declare zero_by_left_zero [simp]
declare zero_by_right_zero [simp]
declare inverse_by_XMinus1 [simp]
declare sqrt_def [simp]
declare lindep_reflexivity [simp]
declare lindep_symmetry [simp]
declare orth_symmetric [simp]
declare orthogonal_on_zero_projection [simp]
declare orthogonal_projection_theorem [simp]
declare orthogonal_decomposition_theorem [simp]

theorem homogen :
"ALL a. ALL v. || a *_3 v || = gn_inj(abs'(a)) *'' || v ||"
using subtype_def subtype_pred_def Ax1_1 inf_def
      RealNonNeg_pred_def RealPos_pred_def abs_def sqr_def sqrt_def
      lindep_def norm_from_inner_prod_def proj_def orthcomp_def
      orthogonal_def
by (auto)

ML "Header.record \"homogen\""

theorem triangle :
"ALL v. ALL w. || v +'' w || <=' || v || +' || w ||"
using subtype_def subtype_pred_def Ax1_1 inf_def
      RealNonNeg_pred_def RealPos_pred_def abs_def sqr_def sqrt_def
      lindep_def norm_from_inner_prod_def proj_def orthcomp_def
      orthogonal_def
by (auto)

ML "Header.record \"triangle\""

theorem definit : "ALL v. || v || = 0' = (v = 0'')"
using subtype_def subtype_pred_def Ax1_1 inf_def
      RealNonNeg_pred_def RealPos_pred_def abs_def sqr_def sqrt_def
      lindep_def norm_from_inner_prod_def proj_def orthcomp_def
      orthogonal_def
by (auto)

ML "Header.record \"definit\""

theorem nonXMinusnegative : "ALL x. gn_inj(abs'(x)) >=' 0'"
using subtype_def subtype_pred_def Ax1_1 inf_def
      RealNonNeg_pred_def RealPos_pred_def abs_def sqr_def sqrt_def
      lindep_def norm_from_inner_prod_def proj_def orthcomp_def
      orthogonal_def
by (auto)

ML "Header.record \"nonXMinusnegative\""

theorem posXMinusdefinite :
"ALL x. gn_inj(abs'(x)) = makePartial 0' = (x = 0')"
using subtype_def subtype_pred_def Ax1_1 inf_def
      RealNonNeg_pred_def RealPos_pred_def abs_def sqr_def sqrt_def
      lindep_def norm_from_inner_prod_def proj_def orthcomp_def
      orthogonal_def
by (auto)

ML "Header.record \"posXMinusdefinite\""

theorem multiplic :
"ALL x.
 ALL y.
 gn_inj(abs'(x *'' y)) =
 makePartial (gn_inj(abs'(x)) *'' gn_inj(abs'(y)))"
using subtype_def subtype_pred_def Ax1_1 inf_def
      RealNonNeg_pred_def RealPos_pred_def abs_def sqr_def sqrt_def
      lindep_def norm_from_inner_prod_def proj_def orthcomp_def
      orthogonal_def
by (auto)

ML "Header.record \"multiplic\""

theorem triangle_1 :
"ALL x.
 ALL y. gn_inj(abs'(x +' y)) <=' gn_inj(abs'(x)) +' gn_inj(abs'(y))"
using subtype_def subtype_pred_def Ax1_1 inf_def
      RealNonNeg_pred_def RealPos_pred_def abs_def sqr_def sqrt_def
      lindep_def norm_from_inner_prod_def proj_def orthcomp_def
      orthogonal_def
by (auto)

ML "Header.record \"triangle_1\""

end


(*File: IMP.thy*)
(*Authors: Lennart Beringer and Martin Hofmann, LMU Munich 2008*)
theory IMP imports Main begin
section \<open>The language IMP\<close>

text\<open>\label{sec:IMP}In this section we define a simple imperative programming
language. Syntax and operational semantics are as in \cite{Winskel93},
except that we enrich the language with a single unnamed,
parameterless procedure. Both, this section and the following one
merely set the basis for the development described in the later
sections and largely follow the approach to formalize program logics
advocated by Kleymann, Nipkow, and others - see for example
\cite{KleymannPhD,Nipkow-CSL02,Nipkow-AFP-AHL}.\<close>

subsection\<open>Syntax\<close>

text\<open>We start from unspecified categories of program variables and
values.\<close>

typedecl Var
typedecl Val

text\<open>Arithmetic expressions are inductively built up from variables,
values, and binary operators which are modeled as meta-logical
functions over values. Similarly, boolean expressions are built up
from arithmetic expressions using binary boolean operators which are
modeled as functions of the ambient logic HOL.\<close>

datatype Expr =
   varE Var
 | valE Val
 | opE "Val \<Rightarrow> Val \<Rightarrow> Val" Expr Expr

datatype BExpr = compB "Val \<Rightarrow> Val \<Rightarrow> bool" Expr Expr

text\<open>Commands are the usual ones for an imperative language, plus the
command $\mathit{Call}$ which stands for the invocation of a single
(unnamed, parameterless) procedure.\<close>

datatype IMP =
    Skip
  | Assign Var Expr
  | Comp IMP IMP
  | While BExpr IMP
  | Iff BExpr IMP IMP
  | Call

text\<open>The body of this procedure is identified by the following
constant.\<close>

consts body :: IMP

subsection\<open>Dynamic semantics\<close>

text\<open>States are given by stores - in our case, HOL functions
mapping program variables to values.\<close>

type_synonym State = "Var \<Rightarrow> Val"

definition update :: "State \<Rightarrow> Var \<Rightarrow> Val \<Rightarrow> State"
where "update s x v = (\<lambda> y . if x=y then v else s y)"

text\<open>The evaluation of expressions is defined inductively, as
standard.\<close>

primrec evalE::"Expr \<Rightarrow> State \<Rightarrow> Val"
where
"evalE (varE x) s = s x" |
"evalE (valE v) s = v" |
"evalE (opE f e1 e2) s = f (evalE e1 s) (evalE e2 s)"

primrec evalB::"BExpr \<Rightarrow> State \<Rightarrow> bool"
where
"evalB (compB f e1 e2) s = f (evalE e1 s) (evalE e2 s)"

text\<open>The operational semantics is a standard big-step relation, with
a height index that facilitates the Kleymann-Nipkow-style~\cite{KleymannPhD,Nipkow-CSL02}
soundness proof of the program logic.\<close>

inductive_set Semn :: "(State \<times> IMP \<times> nat \<times> State) set" where
 SemSkip: "(s,Skip,1,s) : Semn"

| SemAssign:
  "\<lbrakk> t = update s x (evalE e s)\<rbrakk> \<Longrightarrow> (s,Assign x e,1,t):Semn"

| SemComp:
  "\<lbrakk> (s,c1,n,r):Semn; (r,c2,m,t):Semn; k=(max n m)+1\<rbrakk>
   \<Longrightarrow> (s,Comp c1 c2,k,t):Semn"

| SemWhileT:
  "\<lbrakk>evalB b s; (s,c,n,r):Semn; (r,While b c,m,t):Semn;
       k=((max n m)+1)\<rbrakk>
   \<Longrightarrow> (s,While b c,k,t):Semn"

| SemWhileF: "\<lbrakk>\<not> (evalB b s); t=s\<rbrakk> \<Longrightarrow> (s,While b c,1,t):Semn"

| SemTrue:
  "\<lbrakk>evalB b s; (s,c1,n,t):Semn \<rbrakk> \<Longrightarrow> (s,Iff b c1 c2,n+1,t):Semn"

| SemFalse:
  "\<lbrakk>\<not> (evalB b s); (s,c2,n,t):Semn\<rbrakk> \<Longrightarrow> (s,Iff b c1 c2,n+1,t):Semn"

| SemCall: "(s,body,n,t):Semn \<Longrightarrow> (s,Call,n+1,t):Semn"
(*
 SemSkip:  "(s,Skip \<longrightarrow>\<^sub>1 s"
 SemAssign:"\<lbrakk> t = update s x (evalE e s)\<rbrakk> \<Longrightarrow> s,(Assign x e) \<longrightarrow>\<^sub>1 t"
SemComp:  "\<lbrakk> s,c1 \<longrightarrow>\<^sub>n r; r,c2 \<longrightarrow>\<^sub>m t; k=(max n m)+1\<rbrakk>
          \<Longrightarrow> s,(Comp c1 c2) \<longrightarrow>\<^sub>k t"
 SemWhileT:"\<lbrakk>evalB b s; s,c \<longrightarrow>\<^sub>n r; r,(While b c) \<longrightarrow>\<^sub>m t;
             k=((max n m)+1)\<rbrakk>
          \<Longrightarrow> s,(While b c) \<longrightarrow>\<^sub>k t"
 SemWhileF:"\<lbrakk>\<not> (evalB b s); t=s\<rbrakk> \<Longrightarrow> s,(While b c) \<longrightarrow>\<^sub>1 t"
 SemTrue:  "\<lbrakk>evalB b s; s,c1 \<longrightarrow>\<^sub>n t\<rbrakk> \<Longrightarrow> s,(Iff b c1 c2) \<longrightarrow>\<^sub>(n+1) t"
 SemFalse: "\<lbrakk>\<not> (evalB b s); s,c2 \<longrightarrow>\<^sub>n t\<rbrakk>
          \<Longrightarrow> s,(Iff b c1 c2) \<longrightarrow>\<^sub>(n+1) t"
 SemCall:  "\<lbrakk> s,body \<longrightarrow>\<^sub>n t\<rbrakk> \<Longrightarrow> s,Call \<longrightarrow>\<^sub>(n+1) t"
*)

abbreviation
SemN  :: "[State, IMP, nat, State] \<Rightarrow> bool"   (" _ , _ \<rightarrow>\<^sub>_  _ ")
where
"s,c \<rightarrow>\<^sub>n t == (s,c,n,t) : Semn"

text\<open>Often, the height index does not matter, so we define a notion
hiding it.\<close>

definition Sem :: "[State, IMP, State] \<Rightarrow> bool" ("_ , _ \<Down> _ " 1000)
where "s,c \<Down> t = (\<exists> n. s,c \<rightarrow>\<^sub>n t)"

text\<open>Inductive elimination rules for the (indexed) dynamic semantics:\<close>

inductive_cases Sem_eval_cases:
 "s,Skip \<rightarrow>\<^sub>n t"
 "s,(Assign x e) \<rightarrow>\<^sub>n t"
 "s,(Comp c1 c2) \<rightarrow>\<^sub>n t"
 "s,(While b c) \<rightarrow>\<^sub>n t"
 "s,(Iff b c1 c2) \<rightarrow>\<^sub>n t"
 "s, Call \<rightarrow>\<^sub>n t"

(*<*)
lemma Sem_no_zero_height_derivsAux: "\<forall> s t. ((s, c \<rightarrow>\<^sub>0 t) --> False)"
by (induct_tac c, auto elim: Sem_eval_cases)
(*>*)

text\<open>An induction on $c$ shows that no derivations of height
$0$ exist.\<close>

lemma Sem_no_zero_height_derivs: "(s, c \<rightarrow>\<^sub>0 t) ==> False"
(*<*)by (insert Sem_no_zero_height_derivsAux, fastforce)(*>*)

(*<*)
lemma SemnDeterm[rule_format]:
"(s, c \<rightarrow>\<^sub>n t) ==> (\<forall> r m . (s, c \<rightarrow>\<^sub>m r) --> m=n \<and> r=t)"
apply (erule Semn.induct)
apply(clarsimp, elim Sem_eval_cases, simp)
(*Assign*)
apply (rule allI)+ apply rule
apply(elim Sem_eval_cases)
apply simp
(*Comp*)
apply (rule allI)+ apply rule
apply(elim Sem_eval_cases)
apply simp
(*WhileT*)
apply (rule allI)+ apply rule
apply (rotate_tac 3) apply (erule thin_rl)
apply (erule Sem_eval_cases) apply clarify
  apply (rotate_tac -4)
  apply (erule_tac x=rb in allE) apply (erule_tac x=na in allE) apply clarsimp
  apply clarify
(*WhileF*)
apply (rule allI)+ apply rule
apply (erule Sem_eval_cases) apply clarify
  apply simp
(*True*)
apply (rule allI)+ apply rule
apply(elim Sem_eval_cases)
apply simp
apply fast
(*False*)
apply (rule allI)+ apply rule
apply(elim Sem_eval_cases)
apply fast
apply simp
(*Call*)
apply clarify
apply(elim Sem_eval_cases)
apply simp
done
(*>*)

text\<open>The proof of determinism is by induction on the
      (indexed) operational semantics.\<close>

lemma SemDeterm: "\<lbrakk>s, c \<Down> t; s, c \<Down> r\<rbrakk> \<Longrightarrow> r=t"
(*<*)
apply (simp add: Sem_def, clarsimp)
apply (drule SemnDeterm, assumption)
apply simp
done
(*>*)

text\<open>End of theory IMP\<close>
end


theory RubyEquality
imports RecComb
begin

lemma comp_right_eq: "A = B \<Longrightarrow> A;;C = B;;C"
apply(auto)
done

lemma comp_left_eq: "A = B \<Longrightarrow> C;;A = C;;B"
apply(auto)
done

lemmas comp_eq = comp_right_eq comp_left_eq

lemma beside_right_eq: "A = B \<Longrightarrow> A || C = B || C"
apply(auto)
done

lemma beside_left_eq: "A = B \<Longrightarrow> C || A = C || B"
apply(auto)
done

lemmas beside_eq = beside_right_eq beside_left_eq

theorem comp_assoc: "\<lbrakk> R:A<~>B; S:B<~>C; T:C<~>D \<rbrakk> \<Longrightarrow> (R;;S);;T = R;;(S;;T)"
apply(rule, auto)
apply(subgoal_tac "R ;; S ;; T : A<~>D", typecheck, simp_all)
apply(drule subsetD, simp, safe)
apply(elim compE, typecheck, simp_all)
apply(intro RubyI, simp_all)
apply(subgoal_tac "R ;; (S ;; T) : A<~>D", typecheck, simp_all)
apply(drule subsetD, simp, safe)
apply(elim compE, typecheck, simp_all)
apply(intro RubyI, simp_all)
done

theorem Id_left[simp]: "R:A<~>B \<Longrightarrow> Id(A) ;; R = R"
apply(rule, auto)
apply(subgoal_tac "Id(A) ;; R : A<~>B", typecheck)
apply(simp, drule subsetD, simp, safe)
apply(erule compE, typecheck, simp)
apply(elim RubyE, simp, blast)
apply(drule subsetD, simp, safe)
apply(intro RubyI)
defer
apply(simp, rule IdI, simp)
done

theorem Id_right[simp]: "R:B<~>A \<Longrightarrow> R ;; Id(A) = R"
apply(rule, auto)
apply(subgoal_tac "R ;; Id(A) : B<~>A", typecheck)
apply(simp, drule subsetD, simp, safe)
apply(erule compE, typecheck, simp)
apply(elim RubyE, simp, blast)
apply(drule subsetD, simp, safe)
apply(intro RubyI, simp, rule IdI, simp)
done

theorem Id_inv: "Id(A)~ = Id(A)"
apply(rule, auto)
apply(subgoal_tac "Id(A)~ : A<~>A", typecheck)
apply(simp, drule subsetD, simp, safe)
apply(elim RubyE, typecheck, simp, rule IdI, simp)
apply(insert Id_type[of A], simp, drule subsetD, simp, safe)
apply(elim RubyE, simp, intro RubyI, simp+)
done

theorem powf_succ2: "\<lbrakk> n:nat; R:A<~>A \<rbrakk> \<Longrightarrow> pow(A,succ(n), R) = R ;; pow(A,n,R)"
apply(induct_tac n)
apply(subst powf_succ)
apply((subst powf_zero_iff)+)
apply(simp)
apply(subst powf_succ, simp)
apply(subst (asm) powf_succ, simp)
apply(subst comp_assoc, simp_all)
apply(rule PowD, rule powf_type, simp, typecheck, simp)
done

lemma pow_disturb_lemma:
  "\<lbrakk> Q:A<~>A; R:A<~>A; n:nat; Q;;R = R;;Q \<rbrakk>
  \<Longrightarrow> Q ;; pow(A,n,R) = pow(A,n,R) ;; Q"
apply(induct_tac n)
apply(simp add: powf_zero_iff)
apply(subst powf_succ, simp)
apply(subst comp_assoc[THEN sym])
apply(typecheck, simp+)
apply(subst comp_assoc, typecheck, simp+)
apply(subst comp_assoc[THEN sym], typecheck, simp+)
apply(subst powf_succ, simp)
done

theorem pow_distrib:
  "\<lbrakk> Q:A<~>A; R:A<~>A; n:nat; Q;;R = R;;Q \<rbrakk>
  \<Longrightarrow> pow(A,n,Q) ;; pow(A,n,R) = pow(A,n,(Q;;R))"
apply(induct_tac n)
apply((subst powf_zero_iff)+)
apply(rule Id_left, typecheck)
apply(subst powf_succ, simp)
apply(subst comp_assoc, typecheck, simp+)
apply(subst powf_succ, simp)
apply(subst comp_assoc[of Q _ _ "powf(A, _, \<lambda>_\<in>nat. R)" _ R, THEN sym])
apply(typecheck, simp+)
apply(subst pow_disturb_lemma, simp_all)
apply(subst comp_assoc[THEN sym])
apply(typecheck, simp+)
apply(subst comp_assoc[THEN sym])
apply(typecheck, simp+)
apply(subst comp_assoc)
apply(typecheck, simp+)
apply(subst powf_succ, simp)
done

theorem compinv: "\<lbrakk> R:A<~>B; S:B<~>C \<rbrakk> \<Longrightarrow> (R ;; S)~ = S~ ;; R~"
apply(rule, rule)
apply(subgoal_tac "(R;;S)~ : C<~>A", typecheck)
apply(simp, drule subsetD, simp, safe)
apply(elim RubyE, typecheck, simp+)
apply(intro RubyI, typecheck)
apply(subgoal_tac "S~ ;; R~ : C<~>A", typecheck, simp_all)
apply(drule subsetD, simp+, safe)
apply(elim RubyE, typecheck, simp+)
apply(intro RubyI, simp+)
done

theorem invinv[simp]: "R:A<~>B \<Longrightarrow> (R~)~ = R"
apply(rule, auto)
apply(subgoal_tac "R~~ : A<~>B", typecheck, simp_all)
apply(drule subsetD, simp, safe)
apply(elim RubyE, typecheck, simp_all)
apply(drule subsetD, simp, safe)
apply(intro RubyI, simp_all)
done

theorem Id_comp_left: "R:A<~>B \<Longrightarrow> Id(A) ;; R = R"
apply(simp)
done

theorem NNILinv: "NNIL~ = NNIL"
apply(rule, auto)
apply(insert NNIL_type[of A B])
apply(drule inv_type[of NNIL], simp)
apply(drule subsetD, simp, safe)
apply(elim RubyE, typecheck, simp+)
apply(intro RubyI)
apply(drule subsetD, simp, safe)
apply(elim RubyE, simp+)
apply(intro RubyI, simp+)
done

theorem crossover:
  "\<lbrakk> R:A<~>B; S:C<~>D \<rbrakk> \<Longrightarrow>
    [[R,S]] ;; cross(B,D) = cross(A,C) ;; [[S,R]]"
apply(rule, auto)
apply(subgoal_tac "[[R,S]];;cross(B,D) : A*C<~>D*B", typecheck, simp_all)
apply(drule subsetD, simp, safe)
apply(elim sig_pairE, simp)
apply(elim compE, typecheck, simp_all)
apply(elim sig_pairE, simp, elim RubyE, simp_all)
apply(intro RubyI, rule crossI, simp+)
apply(intro RubyI, simp_all)
apply(subgoal_tac "cross(A,C) ;; [[S,R]] : A*C<~>D*B", typecheck, simp_all)
apply(drule subsetD, simp, safe)
apply(elim sig_pairE, simp)
apply(elim compE, typecheck, simp_all)
apply(elim sig_pairE, simp, elim RubyE, simp_all)
apply(intro RubyI)
defer
apply(rule crossI, simp_all)
apply(rule parI, simp_all)
done

theorem fstsndpar[simp]: "\<lbrakk> R:A<~>B; S:C<~>D \<rbrakk> \<Longrightarrow> Fst(C,R) ;; Snd(B,S) = [[R,S]]"
apply(rule, safe)
apply(subgoal_tac "Fst(C,R);;Snd(B,S):A*C<~>B*D", typecheck, simp_all)
apply(drule subsetD, simp, safe, elim sig_pairE, simp)
apply(elim compE, typecheck, simp_all)
apply(elim sig_pairE, simp, elim RubyE, simp+)
apply(intro RubyI, simp_all)
apply(insert par_type[of R A B S C D], simp)
apply(drule subsetD, simp, safe, elim sig_pairE, simp)
apply(elim RubyE, simp_all)
apply(intro RubyI, rule parI, simp, rule IdI, simp_all)
apply(intro RubyI, simp+)
done

theorem par_inv_distrib: "\<lbrakk> R:A<~>B; S:C<~>D \<rbrakk> \<Longrightarrow> [[R,S]]~ = [[R~,S~]]"
apply(rule, auto)
apply(subgoal_tac "[[R,S]]~ : B*D<~>A*C", typecheck, simp_all)
apply(drule subsetD, simp)
apply(safe, elim sig_pairE, simp)
apply(elim RubyE, typecheck, simp_all)
apply(intro RubyI, simp_all)
apply(subgoal_tac "[[R~,S~]] : B*D<~>A*C", typecheck, simp_all)
apply(drule subsetD, simp)
apply(safe, elim sig_pairE, simp)
apply(elim RubyE, typecheck, simp_all)
apply(intro RubyI, simp_all)
done

theorem par_comb:
  "\<lbrakk> R:A<~>B; S:B<~>C; T:D<~>E; U:E<~>F \<rbrakk>
    \<Longrightarrow> [[R,T]] ;; [[S,U]] = [[R;;S, T;;U]]"
apply(rule, auto)
apply(subgoal_tac "[[R,T]] ;; [[S,U]] : A*D<~>C*F", typecheck, simp_all)
apply(drule subsetD, simp)
apply(safe, elim sig_pairE, simp)
apply(elim compE, typecheck, simp_all)
apply(elim sig_pairE, simp)
apply(elim RubyE, simp_all)
apply(intro RubyI, simp_all)
apply(subgoal_tac "[[R;;S,T;;U]] : A*D<~>C*F", typecheck, simp_all)
apply(drule subsetD, simp)
apply(safe, elim sig_pairE, simp)
apply(elim RubyE, simp_all)
apply(intro RubyI)
apply(subgoal_tac "\<langle><a#b>, <ya#yb>\<rangle> \<in> [[R,T]]", simp)
apply((intro RubyI, simp_all)+)
done

lemma B_not_zero: "B \<noteq> 0 \<Longrightarrow> sig(B) \<noteq> 0"
apply(blast)
done

theorem p1id: "B \<noteq> 0 \<Longrightarrow> p1(A,B)~ ;; p1(A,B) = Id(A)"
apply(rule, auto)
apply(subgoal_tac "p1(A,B)~ ;; p1(A,B) : A<~>A", typecheck)
apply(simp, drule subsetD, simp, safe)
apply(elim RubyE, typecheck, simp)
apply(elim sig_pairE, simp, elim RubyE, simp_all)
apply(intro RubyI, simp)
apply(insert Id_type[of A], simp)
apply(drule subsetD, simp, safe)
apply(elim RubyE, simp)
apply(drule B_not_zero)
apply(drule Choose_def)
apply(intro RubyI)
apply(rule p1I, simp+)
apply(rule p1I, simp+)
done

theorem comp_inv: "\<lbrakk> R:A<~>B; S:B<~>C \<rbrakk> \<Longrightarrow> (R;;S)~ = S~;;R~"
apply(rule, auto)
apply(subgoal_tac "(R ;; S)~ : C<~>A", typecheck)
apply(simp, drule subsetD, simp, simp_all, safe)
apply(elim RubyE, typecheck, simp+)
apply(intro RubyI, simp+)
apply(subgoal_tac "S~ ;; R~ : C<~>A", typecheck)
apply(simp, drule subsetD, simp, simp_all, safe)
apply(elim RubyE, typecheck, simp+)
apply(intro RubyI, simp+)
done

theorem par_Id: "[[Id(A), Id(B)]] = Id(A*B)"
apply(rule, auto)
apply(subgoal_tac "[[Id(A), Id(B)]] : _<~>_", typecheck)
apply(simp, drule subsetD, simp)
apply(safe, elim sig_pairE, simp)
apply(elim RubyE, typecheck, simp+)
apply(intro RubyI, simp)
apply(subgoal_tac "Id(A*B):_<~>_", typecheck)
apply(simp, drule subsetD, simp)
apply(safe, elim sig_pairE, simp+)
apply(elim RubyE, typecheck, simp+)
apply(intro RubyI, simp+)
done

theorem apr_apr_inv_Id: "apr(A,x) ;; apr(A,x)~ = Id(nlist[x]A \<times> A)"
apply(rule, auto)
apply(subgoal_tac "apr(A,x);;apr(A,x)~ : _<~>_", typecheck)
apply(simp, drule subsetD, simp, safe, elim sig_pairE, simp)
apply(elim compE, typecheck, elim sig_ssnocE, simp)
apply(elim aprE, simp+)
apply(elim RubyE, typecheck, simp, intro IdI, simp)
apply(subgoal_tac "Id(nlist[x]A*A):_<~>_", typecheck)
apply(simp, drule subsetD, simp, safe, elim sig_pairE, simp)
apply(elim RubyE, simp+)
apply(intro RubyI, simp+)
apply((rule aprI, simp+)+)
done

theorem reorg_reorg_inv_Id: "reorg(A,B,C) ;; reorg(A,B,C)~ = Id((A*B)*C)"
apply(rule, auto)
apply(subgoal_tac "reorg(A,B,C) ;; reorg(A,B,C)~ : _<~>_", typecheck)
apply(simp, drule subsetD, simp, safe, elim sig_pairE, simp)
apply(elim compE, typecheck, elim sig_pairE, simp)
apply(elim RubyE, typecheck, simp)
apply(intro IdI, simp)
apply(subgoal_tac "Id((A*B)*C):_<~>_", typecheck)
apply(simp, drule subsetD, simp, safe, elim sig_pairE, simp)
apply(elim RubyE, simp+)
apply(intro RubyI, simp+)
apply((rule reorgI, simp+)+)
done

theorem reorg_reorg_inv_Id2: "reorg(A,B,C)~ ;; reorg(A,B,C) = Id(A*B*C)"
apply(rule, auto)
apply(subgoal_tac "reorg(A,B,C)~ ;; reorg(A,B,C) : _<~>_", typecheck)
apply(simp, drule subsetD, simp, safe, elim sig_pairE, simp)
apply(elim compE, typecheck, elim sig_pairE, simp)
apply(elim RubyE, typecheck, simp)
apply(intro IdI, simp)
apply(subgoal_tac "Id(A*B*C):_<~>_", typecheck)
apply(simp, drule subsetD, simp, safe, elim sig_pairE, simp)
apply(elim RubyE, simp+)
apply(intro RubyI, simp+)
apply((rule reorgI, simp+)+)
done

theorem Fst_par_comp: "\<lbrakk> R:C<~>D; S:D<~>E; T:A<~>B \<rbrakk> \<Longrightarrow> Fst(A,R);;[[S,T]] = [[R;;S,T]]"
apply(subst Id_left[of T A B, THEN sym], simp) back
apply(subst par_comb[THEN sym], typecheck)
apply(intro comp_eq)
apply(subst Fst_def, simp)
done

theorem Fst_par_comp2: "\<lbrakk> R:C<~>D; S:D<~>E; T:A<~>B \<rbrakk> \<Longrightarrow> [[R,T]];;Fst(B,S) = [[R;;S,T]]"
apply(subst Id_right[of T A B, THEN sym], simp) back
apply(subst par_comb[THEN sym], typecheck)
apply(intro comp_eq)
apply(subst Fst_def, simp)
done

theorem Snd_par_comp: "\<lbrakk> R:C<~>D; S:D<~>E; T:A<~>B \<rbrakk> \<Longrightarrow> Snd(A,R);;[[T,S]] = [[T,R;;S]]"
apply(subst Id_left[of T A B, THEN sym], simp) back
apply(subst par_comb[THEN sym], typecheck)
apply(intro comp_eq)
apply(subst Snd_def, simp)
done

theorem par_reorg_assoc:
  "\<lbrakk> R:A<~>B; S:C<~>D; T:E<~>F \<rbrakk>
    \<Longrightarrow> [[R,[[S,T]]]] = reorg(A,C,E)~ ;; [[[[R,S]],T]] ;; reorg(B,D,F)"
apply(rule, auto)
apply(subgoal_tac "[[R,[[S,T]]]] : _<~>_", typecheck, simp_all)
apply(drule subsetD, simp, safe, elim sig_pairE, simp)
apply(elim RubyE, typecheck)
apply(intro RubyI)
apply(rule reorgI, simp+)
apply(subgoal_tac "<<<a#ab>#bb>, <<aa#ac>#bc>> : [[[[R,S]],T]]", simp)
apply(intro RubyI, simp+)
apply(rule reorgI, simp+)
apply(subgoal_tac "reorg(A, C, E)~ ;; [[[[R,S]],T]] ;; reorg(B, D, F) : _<~>_", typecheck, simp_all)
apply(drule subsetD, simp, safe, elim sig_pairE, simp)
apply(elim compE, typecheck, simp_all)
apply(elim sig_pairE, simp)
apply(elim RubyE, typecheck, simp)
apply(intro RubyI, simp+)
done

theorem par_reorg_assoc2:
  "\<lbrakk> R:A<~>B; S:C<~>D; T:E<~>F \<rbrakk>
    \<Longrightarrow> [[[[R,S]],T]] = reorg(A,C,E) ;; [[R,[[S,T]]]] ;; reorg(B,D,F)~"
apply(subst par_reorg_assoc, simp_all)
apply((subst comp_assoc, typecheck, simp+)+)
apply(subst reorg_reorg_inv_Id)
apply(subst Id_right, typecheck, simp_all)
apply((subst comp_assoc[THEN sym], typecheck, simp+)+)
apply(subst reorg_reorg_inv_Id)
apply(subst Id_left, typecheck, simp_all)
done

theorem Fst_distrib: "\<lbrakk> R:A<~>B; S:B<~>C \<rbrakk> \<Longrightarrow> Fst(D, R;;S) = Fst(D,R) ;; Fst(D,S)"
apply((subst Fst_def)+)
apply(subst par_comb, typecheck)
apply(subst Id_left, typecheck, simp)
done

theorem comp_p1_inv: "R:A<~>A \<Longrightarrow> R;;p1(A,B)~ = p1(A,B)~;;Fst(B,R)"
apply(rule, auto)
apply(subgoal_tac "R;;p1(A,B)~ : _<~>_", typecheck, simp_all)
apply(drule subsetD, simp, safe, elim sig_pairE, simp)
apply(elim compE, typecheck, simp+)
apply(elim RubyE, typecheck, simp)
apply(intro RubyI, rule p1I, simp+, rule parI, simp+, rule IdI, simp+)
apply(subgoal_tac "p1(A,B)~;;Fst(B,R):_<~>_", typecheck, simp_all)
apply(drule subsetD, simp, safe, elim sig_pairE, simp)
apply(elim compE, typecheck, simp+, elim sig_pairE, simp)
apply(elim RubyE, typecheck, simp)
apply(intro RubyI, simp, rule p1I, simp+)
done

theorem par_Fst_reorg_inv:
  " \<lbrakk> R:A<~>C; S:B<~>D \<rbrakk> \<Longrightarrow>
    [[R,Fst(F,S)]];;reorg(C,D,F)~ = reorg(A,B,F)~ ;; Fst(F, [[R,S]])"
apply(rule, auto)
apply(subgoal_tac "[[R,Fst(F, S)]] ;; reorg(C, D, F)~ : _<~>_", typecheck, simp_all)
apply(drule subsetD, simp, safe, elim sig_pairE, simp)
apply(elim compE, typecheck, simp+, elim sig_pairE, simp)
apply(erule invE, typecheck, erule reorgE, typecheck, simp)
apply(erule parE, simp+, erule FstE, erule parE, simp+, erule IdE, simp)
apply(intro RubyI, rule reorgI, simp+)
apply(intro RubyI, simp+)
apply(subgoal_tac "reorg(A, B, F)~ ;; Fst(F, [[R,S]]) : _<~>_", typecheck, simp_all)
apply(drule subsetD, simp, safe, elim sig_pairE, simp)
apply(elim compE, typecheck, simp+, elim sig_pairE, simp)
apply(erule invE, typecheck, erule reorgE, typecheck, simp)
apply(erule FstE, erule parE, simp+, elim RubyE, simp+)
apply(intro RubyI)
defer
apply(rule reorgI, simp+, intro RubyI, simp+)
done

theorem duplicate: "\<lbrakk> R:A<~>B; function(R) \<rbrakk> \<Longrightarrow> R;;dub(B) = dub(A);;[[R,R]]"
apply(rule, auto)
apply(subgoal_tac "R ;; dub(B) : _<~>_", typecheck, simp_all)
apply(drule subsetD, simp, safe, elim sig_pairE, simp)
apply(elim compE, typecheck, simp, elim dubE, typecheck)
apply(intro RubyI, rule dubI, simp)
apply(intro RubyI, simp+)
apply(subgoal_tac "dub(A) ;; [[R,R]] : _<~>_", typecheck, simp_all)
apply(drule subsetD, simp, safe, elim sig_pairE, simp)
apply(elim compE, typecheck, simp_all)
apply(elim sig_pairE, simp, elim RubyE, typecheck, simp)
apply(drule function_apply_equality, simp)
apply(frule function_apply_equality, simp+)
apply(intro RubyI, simp+)
apply(intro RubyI, simp)
done

theorem pow_pow_comp:
  "\<lbrakk> r:nat; w:nat; R:A<~>A \<rbrakk> \<Longrightarrow>
    pow(A,r,R) ;; pow(A,w,R) = pow(A, r #+ w, R)"
apply(induct_tac w, simp)
apply(subst powf_zero_iff, rule Id_right, typecheck, simp)
apply(subst powf_succ, simp)
apply(subst comp_assoc[THEN sym], typecheck, simp+)
apply(subst powf_succ, simp)
done

theorem pow_pow_comp_comm:
  "\<lbrakk> r:nat; w:nat; R:A<~>A \<rbrakk> \<Longrightarrow>
    pow(A,r,R) ;; pow(A,w,R) = pow(A,w,R) ;; pow(A,r,R)"
apply(induct_tac w)
apply((subst powf_zero_iff)+)
apply((subst Id_right Id_left, typecheck)+, simp)
apply(subst powf_succ)
apply(subst powf_succ2, simp+)
apply(subst comp_assoc[THEN sym], typecheck, simp+)
apply(subst pow_pow_comp, simp+)
apply(subst comp_assoc, typecheck, simp+)
apply(subst pow_pow_comp, simp+)
apply(subst powf_succ2[THEN sym], simp+)
apply(subst powf_succ, simp)
done

end