(* Author: Tobias Nipkow *)

theory Abs_Int2
imports Abs_Int1
begin

instantiation prod :: (order,order) order
begin

definition "less_eq_prod p1 p2 = (fst p1 \<le> fst p2 \<and> snd p1 \<le> snd p2)"
definition "less_prod p1 p2 = (p1 \<le> p2 \<and> \<not> p2 \<le> (p1::'a*'b))"

instance
proof
  case goal1 show ?case by(rule less_prod_def)
next
  case goal2 show ?case by(simp add: less_eq_prod_def)
next
  case goal3 thus ?case unfolding less_eq_prod_def by(metis order_trans)
next
  case goal4 thus ?case by(simp add: less_eq_prod_def)(metis eq_iff surjective_pairing)
qed

end

subsection "Backward Analysis of Expressions"

subclass (in bounded_lattice) semilattice_sup_top ..

locale Val_lattice_gamma = Gamma_semilattice where \<gamma> = \<gamma>
  for \<gamma> :: "'av::bounded_lattice \<Rightarrow> val set" +
assumes inter_gamma_subset_gamma_inf:
  "\<gamma> a1 \<inter> \<gamma> a2 \<subseteq> \<gamma>(a1 \<sqinter> a2)"
and gamma_bot[simp]: "\<gamma> \<bottom> = {}"
begin

lemma in_gamma_inf: "x : \<gamma> a1 \<Longrightarrow> x : \<gamma> a2 \<Longrightarrow> x : \<gamma>(a1 \<sqinter> a2)"
by (metis IntI inter_gamma_subset_gamma_inf set_mp)

lemma gamma_inf: "\<gamma>(a1 \<sqinter> a2) = \<gamma> a1 \<inter> \<gamma> a2"
by(rule equalityI[OF _ inter_gamma_subset_gamma_inf])
  (metis inf_le1 inf_le2 le_inf_iff mono_gamma)

end

locale Val_inv = Val_lattice_gamma where \<gamma> = \<gamma>
   for \<gamma> :: "'av::bounded_lattice \<Rightarrow> val set" +
fixes test_num' :: "val \<Rightarrow> 'av \<Rightarrow> bool"
and inv_plus' :: "'av \<Rightarrow> 'av \<Rightarrow> 'av \<Rightarrow> 'av * 'av"
and inv_less' :: "bool \<Rightarrow> 'av \<Rightarrow> 'av \<Rightarrow> 'av * 'av"
assumes test_num': "test_num' i a = (i : \<gamma> a)"
and inv_plus': "inv_plus' a a1 a2 = (a\<^sub>1',a\<^sub>2') \<Longrightarrow>
  i1 : \<gamma> a1 \<Longrightarrow> i2 : \<gamma> a2 \<Longrightarrow> i1+i2 : \<gamma> a \<Longrightarrow> i1 : \<gamma> a\<^sub>1' \<and> i2 : \<gamma> a\<^sub>2'"
and inv_less': "inv_less' (i1<i2) a1 a2 = (a\<^sub>1',a\<^sub>2') \<Longrightarrow>
  i1 : \<gamma> a1 \<Longrightarrow> i2 : \<gamma> a2 \<Longrightarrow> i1 : \<gamma> a\<^sub>1' \<and> i2 : \<gamma> a\<^sub>2'"

locale Abs_Int_inv = Val_inv where \<gamma> = \<gamma>
  for \<gamma> :: "'av::bounded_lattice \<Rightarrow> val set"
begin

lemma in_gamma_sup_UpI:
  "s : \<gamma>\<^sub>o S1 \<or> s : \<gamma>\<^sub>o S2 \<Longrightarrow> s : \<gamma>\<^sub>o(S1 \<squnion> S2)"
by (metis (hide_lams, no_types) sup_ge1 sup_ge2 mono_gamma_o subsetD)

fun aval'' :: "aexp \<Rightarrow> 'av st option \<Rightarrow> 'av" where
"aval'' e None = \<bottom>" |
"aval'' e (Some S) = aval' e S"

lemma aval''_correct: "s : \<gamma>\<^sub>o S \<Longrightarrow> aval a s : \<gamma>(aval'' a S)"
by(cases S)(auto simp add: aval'_correct split: option.splits)

subsubsection "Backward analysis"

fun inv_aval' :: "aexp \<Rightarrow> 'av \<Rightarrow> 'av st option \<Rightarrow> 'av st option" where
"inv_aval' (N n) a S = (if test_num' n a then S else None)" |
"inv_aval' (V x) a S = (case S of None \<Rightarrow> None | Some S \<Rightarrow>
  let a' = fun S x \<sqinter> a in
  if a' = \<bottom> then None else Some(update S x a'))" |
"inv_aval' (Plus e1 e2) a S =
 (let (a1,a2) = inv_plus' a (aval'' e1 S) (aval'' e2 S)
  in inv_aval' e1 a1 (inv_aval' e2 a2 S))"

text{* The test for @{const bot} in the @{const V}-case is important: @{const
bot} indicates that a variable has no possible values, i.e.\ that the current
program point is unreachable. But then the abstract state should collapse to
@{const None}. Put differently, we maintain the invariant that in an abstract
state of the form @{term"Some s"}, all variables are mapped to non-@{const
bot} values. Otherwise the (pointwise) sup of two abstract states, one of
which contains @{const bot} values, may produce too large a result, thus
making the analysis less precise. *}

fun inv_bval' :: "bexp \<Rightarrow> bool \<Rightarrow> 'av st option \<Rightarrow> 'av st option" where
"inv_bval' (Bc v) res S = (if v=res then S else None)" |
"inv_bval' (Not b) res S = inv_bval' b (\<not> res) S" |
"inv_bval' (And b1 b2) res S =
  (if res then inv_bval' b1 True (inv_bval' b2 True S)
   else inv_bval' b1 False S \<squnion> inv_bval' b2 False S)" |
"inv_bval' (Less e1 e2) res S =
  (let (a1,a2) = inv_less' res (aval'' e1 S) (aval'' e2 S)
   in inv_aval' e1 a1 (inv_aval' e2 a2 S))"

lemma inv_aval'_correct: "s : \<gamma>\<^sub>o S \<Longrightarrow> aval e s : \<gamma> a \<Longrightarrow> s : \<gamma>\<^sub>o (inv_aval' e a S)"
proof(induction e arbitrary: a S)
  case N thus ?case by simp (metis test_num')
next
  case (V x)
  obtain S' where "S = Some S'" and "s : \<gamma>\<^sub>s S'" using `s : \<gamma>\<^sub>o S`
    by(auto simp: in_gamma_option_iff)
  moreover hence "s x : \<gamma> (fun S' x)"
    by(simp add: \<gamma>_st_def)
  moreover have "s x : \<gamma> a" using V(2) by simp
  ultimately show ?case
    by(simp add: Let_def \<gamma>_st_def)
      (metis mono_gamma emptyE in_gamma_inf gamma_bot subset_empty)
next
  case (Plus e1 e2) thus ?case
    using inv_plus'[OF _ aval''_correct aval''_correct]
    by (auto split: prod.split)
qed

lemma inv_bval'_correct: "s : \<gamma>\<^sub>o S \<Longrightarrow> bv = bval b s \<Longrightarrow> s : \<gamma>\<^sub>o(inv_bval' b bv S)"
proof(induction b arbitrary: S bv)
  case Bc thus ?case by simp
next
  case (Not b) thus ?case by simp
next
  case (And b1 b2) thus ?case
    by simp (metis And(1) And(2) in_gamma_sup_UpI)
next
  case (Less e1 e2) thus ?case
    apply hypsubst_thin
    apply (auto split: prod.split)
    apply (metis (lifting) inv_aval'_correct aval''_correct inv_less')
    done
qed

definition "step' = Step
  (\<lambda>x e S. case S of None \<Rightarrow> None | Some S \<Rightarrow> Some(update S x (aval' e S)))
  (\<lambda>b S. inv_bval' b True S)"

definition AI :: "com \<Rightarrow> 'av st option acom option" where
"AI c = pfp (step' \<top>) (bot c)"

lemma strip_step'[simp]: "strip(step' S c) = strip c"
by(simp add: step'_def)

lemma top_on_inv_aval': "\<lbrakk> top_on_opt S X;  vars e \<subseteq> -X \<rbrakk> \<Longrightarrow> top_on_opt (inv_aval' e a S) X"
by(induction e arbitrary: a S) (auto simp: Let_def split: option.splits prod.split)

lemma top_on_inv_bval': "\<lbrakk>top_on_opt S X; vars b \<subseteq> -X\<rbrakk> \<Longrightarrow> top_on_opt (inv_bval' b r S) X"
by(induction b arbitrary: r S) (auto simp: top_on_inv_aval' top_on_sup split: prod.split)

lemma top_on_step': "top_on_acom C (- vars C) \<Longrightarrow> top_on_acom (step' \<top> C) (- vars C)"
unfolding step'_def
by(rule top_on_Step)
  (auto simp add: top_on_top top_on_inv_bval' split: option.split)

subsubsection "Correctness"

lemma step_step': "step (\<gamma>\<^sub>o S) (\<gamma>\<^sub>c C) \<le> \<gamma>\<^sub>c (step' S C)"
unfolding step_def step'_def
by(rule gamma_Step_subcomm)
  (auto simp: intro!: aval'_correct inv_bval'_correct in_gamma_update split: option.splits)

lemma AI_correct: "AI c = Some C \<Longrightarrow> CS c \<le> \<gamma>\<^sub>c C"
proof(simp add: CS_def AI_def)
  assume 1: "pfp (step' \<top>) (bot c) = Some C"
  have pfp': "step' \<top> C \<le> C" by(rule pfp_pfp[OF 1])
  have 2: "step (\<gamma>\<^sub>o \<top>) (\<gamma>\<^sub>c C) \<le> \<gamma>\<^sub>c C"  --"transfer the pfp'"
  proof(rule order_trans)
    show "step (\<gamma>\<^sub>o \<top>) (\<gamma>\<^sub>c C) \<le> \<gamma>\<^sub>c (step' \<top> C)" by(rule step_step')
    show "... \<le> \<gamma>\<^sub>c C" by (metis mono_gamma_c[OF pfp'])
  qed
  have 3: "strip (\<gamma>\<^sub>c C) = c" by(simp add: strip_pfp[OF _ 1] step'_def)
  have "lfp c (step (\<gamma>\<^sub>o \<top>)) \<le> \<gamma>\<^sub>c C"
    by(rule lfp_lowerbound[simplified,where f="step (\<gamma>\<^sub>o \<top>)", OF 3 2])
  thus "lfp c (step UNIV) \<le> \<gamma>\<^sub>c C" by simp
qed

end

subsubsection "Monotonicity"

locale Abs_Int_inv_mono = Abs_Int_inv +
assumes mono_plus': "a1 \<le> b1 \<Longrightarrow> a2 \<le> b2 \<Longrightarrow> plus' a1 a2 \<le> plus' b1 b2"
and mono_inv_plus': "a1 \<le> b1 \<Longrightarrow> a2 \<le> b2 \<Longrightarrow> r \<le> r' \<Longrightarrow>
  inv_plus' r a1 a2 \<le> inv_plus' r' b1 b2"
and mono_inv_less': "a1 \<le> b1 \<Longrightarrow> a2 \<le> b2 \<Longrightarrow>
  inv_less' bv a1 a2 \<le> inv_less' bv b1 b2"
begin

lemma mono_aval':
  "S1 \<le> S2 \<Longrightarrow> aval' e S1 \<le> aval' e S2"
by(induction e) (auto simp: mono_plus' mono_fun)

lemma mono_aval'':
  "S1 \<le> S2 \<Longrightarrow> aval'' e S1 \<le> aval'' e S2"
apply(cases S1)
 apply simp
apply(cases S2)
 apply simp
by (simp add: mono_aval')

lemma mono_inv_aval': "r1 \<le> r2 \<Longrightarrow> S1 \<le> S2 \<Longrightarrow> inv_aval' e r1 S1 \<le> inv_aval' e r2 S2"
apply(induction e arbitrary: r1 r2 S1 S2)
   apply(auto simp: test_num' Let_def inf_mono split: option.splits prod.splits)
   apply (metis mono_gamma subsetD)
  apply (metis le_bot inf_mono le_st_iff)
 apply (metis inf_mono mono_update le_st_iff)
apply(metis mono_aval'' mono_inv_plus'[simplified less_eq_prod_def] fst_conv snd_conv)
done

lemma mono_inv_bval': "S1 \<le> S2 \<Longrightarrow> inv_bval' b bv S1 \<le> inv_bval' b bv S2"
apply(induction b arbitrary: bv S1 S2)
   apply(simp)
  apply(simp)
 apply simp
 apply(metis order_trans[OF _ sup_ge1] order_trans[OF _ sup_ge2])
apply (simp split: prod.splits)
apply(metis mono_aval'' mono_inv_aval' mono_inv_less'[simplified less_eq_prod_def] fst_conv snd_conv)
done

theorem mono_step': "S1 \<le> S2 \<Longrightarrow> C1 \<le> C2 \<Longrightarrow> step' S1 C1 \<le> step' S2 C2"
unfolding step'_def
by(rule mono2_Step) (auto simp: mono_aval' mono_inv_bval' split: option.split)

lemma mono_step'_top: "C1 \<le> C2 \<Longrightarrow> step' \<top> C1 \<le> step' \<top> C2"
by (metis mono_step' order_refl)

end

end


theory LinearAlgebra_ExtEuclideanVectorSpace_E1
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_Group1\", \"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\", \"lindep_def\",
     \"lindep_reflexivity\", \"lindep_symmetry\",
     \"simple_lindep_condition\", \"lindep_nonlindep_transitivity\",
     \"sqr_def\", \"sqrt_def\", \"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\"]"

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''"

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)"

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"

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')"

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 lindep_reflexivity [simp]
declare lindep_symmetry [simp]
declare sqrt_def [simp]

theorem orth_symmetric : "ALL x. ALL y. orth(x, y) --> orth(y, x)"
using subtype_def subtype_pred_def Ax1_1 inf_def
      RealNonNeg_pred_def RealPos_pred_def abs_def lindep_def sqr_def
      sqrt_def norm_from_inner_prod_def proj_def orthcomp_def
      orthogonal_def
by (auto)

ML "Header.record \"orth_symmetric\""

theorem lindep_orth_transitive :
"ALL x. ALL y. ALL z. lindep(x, y) & orth(y, z) --> orth(x, z)"
using subtype_def subtype_pred_def Ax1_1 inf_def
      RealNonNeg_pred_def RealPos_pred_def abs_def lindep_def sqr_def
      sqrt_def norm_from_inner_prod_def proj_def orthcomp_def
      orthogonal_def
by (auto)

ML "Header.record \"lindep_orth_transitive\""

theorem orthogonal_on_zero_projection :
"ALL x. ALL y. proj(x, y) = 0'' --> orth(x, y)"
using subtype_def subtype_pred_def Ax1_1 inf_def
      RealNonNeg_pred_def RealPos_pred_def abs_def lindep_def sqr_def
      sqrt_def norm_from_inner_prod_def proj_def orthcomp_def
      orthogonal_def
by (auto)

ML "Header.record \"orthogonal_on_zero_projection\""

theorem orthogonal_projection_theorem :
"ALL x. ALL y. orth(orthcomp(x, y), y)"
using subtype_def subtype_pred_def Ax1_1 inf_def
      RealNonNeg_pred_def RealPos_pred_def abs_def lindep_def sqr_def
      sqrt_def norm_from_inner_prod_def proj_def orthcomp_def
      orthogonal_def
by (auto)

ML "Header.record \"orthogonal_projection_theorem\""

theorem orthogonal_decomposition_theorem :
"ALL x. ALL y. proj(x, y) +'' orthcomp(x, y) = x"
using subtype_def subtype_pred_def Ax1_1 inf_def
      RealNonNeg_pred_def RealPos_pred_def abs_def lindep_def sqr_def
      sqrt_def norm_from_inner_prod_def proj_def orthcomp_def
      orthogonal_def
by (auto)

ML "Header.record \"orthogonal_decomposition_theorem\""

theorem unique_orthogonal_decomposition :
"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"
using subtype_def subtype_pred_def Ax1_1 inf_def
      RealNonNeg_pred_def RealPos_pred_def abs_def lindep_def sqr_def
      sqrt_def norm_from_inner_prod_def proj_def orthcomp_def
      orthogonal_def
by (auto)

ML "Header.record \"unique_orthogonal_decomposition\""

end


(*
Author: Alexander Katovsky
*)

section "The Category of Sets"

theory SetCat
imports Functors Universe
begin

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

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

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

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

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

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

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

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

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

definition "SET \<equiv> MakeCat SET'"

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

end