(*  Author: Tobias Nipkow  *)

section \<open>Completeness Proofs under hypothetical computations\<close>

theory Relative_Completeness
imports ArchCompProps
begin

definition Archive :: "vertex fgraph set" where
"Archive \<equiv> set(Tri @ Quad @ Pent @ Hex)"

locale archive_by_computation =
  assumes pre_iso_test3: "\<forall>g \<in> set Tri. pre_iso_test g"
  assumes pre_iso_test4: "\<forall>g \<in> set Quad. pre_iso_test g"
  assumes pre_iso_test5: "\<forall>g \<in> set Pent. pre_iso_test g"
  assumes pre_iso_test6: "\<forall>g \<in> set Hex. pre_iso_test g"
  assumes same3: "samet (tameEnumFilter 0) Tri"
  assumes same4: "samet (tameEnumFilter 1) Quad"
  assumes same5: "samet (tameEnumFilter 2) Pent"
  assumes same6: "samet (tameEnumFilter 3) Hex"
begin

theorem TameEnum_Archive:  "fgraph ` TameEnum \<subseteq>\<^sub>\<simeq> Archive"
using combine_evals_filter[OF pre_iso_test3 same3]
      combine_evals_filter[OF pre_iso_test4 same4]
      combine_evals_filter[OF pre_iso_test5 same5]
      combine_evals_filter[OF pre_iso_test6 same6]
by(fastforce simp:TameEnum_def Archive_def image_def qle_gr.defs
       eval_nat_numeral le_Suc_eq)

lemma TameEnum_comp:
assumes "Seed\<^bsub>p\<^esub> [next_plane\<^bsub>p\<^esub>]\<rightarrow>* g" and "final g" and "tame g"
shows "Seed\<^bsub>p\<^esub> [next_tame\<^bsub>p\<^esub>]\<rightarrow>* g"
proof -
  from assms have "Seed\<^bsub>p\<^esub> [next_tame0 p]\<rightarrow>* g" by(rule next_tame0_comp)
  with assms show "Seed\<^bsub>p\<^esub> [next_tame\<^bsub>p\<^esub>]\<rightarrow>* g" by(blast intro: next_tame_comp)
qed

(* final not necessary but slightly simpler because of lemmas *)
lemma tame5:
assumes g: "Seed\<^bsub>p\<^esub> [next_plane0\<^bsub>p\<^esub>]\<rightarrow>* g" and "final g" and "tame g"
shows "p \<le> 3"
proof -
  from \<open>tame g\<close> have bound: "\<forall>f \<in> \<F> g. |vertices f| \<le> 6"
    by (simp add: tame_def tame9a_def)
  show "p \<le> 3"
  proof (rule ccontr)
    assume 6: "\<not> p \<le> 3"
    obtain f where "f \<in> set (finals g) \<and> |vertices f| = p+3"
      using max_face_ex[OF g] by auto
    also from \<open>final g\<close> have "set (finals g) = set (faces g)" by simp
    finally have "f \<in> \<F> g \<and> 6 < |vertices f|" using 6 by arith
    with bound show False by auto
  qed
qed

theorem completeness:
assumes "g \<in> PlaneGraphs" and "tame g" shows "fgraph g \<in>\<^sub>\<simeq> Archive"
proof -
  from \<open>g \<in> PlaneGraphs\<close> obtain p where g1: "Seed\<^bsub>p\<^esub> [next_plane\<^bsub>p\<^esub>]\<rightarrow>* g"
    and "final g"
    by(auto simp:PlaneGraphs_def PlaneGraphsP_def)
  have "Seed\<^bsub>p\<^esub> [next_plane0\<^bsub>p\<^esub>]\<rightarrow>* g"
    by(rule RTranCl_subset2[OF g1])
      (blast intro:inv_mgp inv_Seed mgp_next_plane0_if_next_plane
        dest:RTranCl_inv[OF inv_inv_next_plane])
  with \<open>tame g\<close> \<open>final g\<close> have "p \<le> 3" by(blast intro:tame5)
  with g1 \<open>tame g\<close> \<open>final g\<close> show ?thesis using TameEnum_Archive
    by(simp add: qle_gr.defs TameEnum_def TameEnumP_def)
      (blast intro: TameEnum_comp)
qed

end

end


section \<open>Addition with fixpoint of successor\<close>

theory Ex3
imports "../LCF"
begin

axiomatization
  s     :: "'a \<Rightarrow> 'a" and
  p     :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
where
  p_strict:     "p(UU) = UU" and
  p_s:          "p(s(x),y) = s(p(x,y))"

declare p_strict [simp] p_s [simp]

lemma example: "p(FIX(s),y) = FIX(s)"
  apply (induct s)
  apply simp
  apply simp
  done

end


theory Inverses imports AbiEncodeCorrect AbiDecodeCorrect
begin

lemma abi_encode_correct :
  assumes H : "encode (v::abi_value) = Ok (code::8 word list)"
  shows "can_encode_as v (code::8 word list) (0)"
proof(-)
  show ?thesis using abi_encode_succeed[of v code "[]" "[]"] H
    by auto
qed

lemma abi_encode_correct_converse :
  assumes H : "can_encode_as v (code::8 word list) (0)"
  assumes Hbound : "sint_value_valid (256 :: nat) (abi_dynamic_size_bound v)"
  shows "\<exists> (code' :: 8 word list) . encode (v::abi_value) = Ok (code'::8 word list)"
proof(-)
  show ?thesis using encode_correct_converse[OF H Hbound]
    by auto
qed

(* "Round-trip" theorem 1:
   Decoding an encoded result gives the original input *)
theorem encode_decode :
  assumes H : "encode v = Ok bytes"
  shows "decode (abi_get_type v) bytes = Ok v"
proof(-)

  have 0 : "can_encode_as v bytes 0" using abi_encode_correct[OF H] by auto

  show ?thesis using abi_decode_correct[OF 0] by auto
qed

(* why the extra "abi_dynamic_size_bound" premise here?
   this is to guard against decoding a "highly compressed" huge byte string
   that has no canonical encoding due to its size *)
theorem decode_encode :
  assumes H : "decode (abi_get_type v) bytes = Ok v"
  assumes Hbound : "sint_value_valid (256 :: nat) (abi_dynamic_size_bound v)"

shows "\<exists> bytes' . encode v = Ok bytes'"
proof(-)

  have 0 : "can_encode_as v bytes 0" using abi_decode_correct_converse[OF H] by auto

  show ?thesis using abi_encode_correct_converse[OF 0 Hbound] by auto
qed

(* "Round-trip" theorem 2:
   Encoder will succeed when run on decoded data
   (because encoder only produces canonical encodings, the re-encoding is not
   guaranteed to be the same, but will decode to the same data) *)
theorem decode_encode_decode :
  assumes Hdec : "decode (abi_get_type v) bytes = Ok v"
  assumes Hbound : "sint_value_valid (256 :: nat) (abi_dynamic_size_bound v)"
  shows "\<exists> bytes' . encode v = Ok bytes' \<and>
         decode (abi_get_type v) bytes' = Ok v"
proof(-)

  obtain bytes' where 0 : "encode v = Ok bytes'"
    using decode_encode[OF Hdec Hbound] by auto

  have 1 : "decode (abi_get_type v) bytes' = Ok v"
    using encode_decode[OF 0] by auto

  show ?thesis using 0 1 by auto
qed

end


(*  Title:      HOL/Hoare/Pointers0.thy
    Author:     Tobias Nipkow
    Copyright   2002 TUM

This is like Pointers.thy, but instead of a type constructor 'a ref
that adjoins Null to a type, Null is simply a distinguished element of
the address type. This avoids the Ref constructor and thus simplifies
specifications (a bit). However, the proofs don't seem to get simpler
- in fact in some case they appear to get (a bit) more complicated.
*)

theory Pointers0 imports Hoare_Logic begin

subsection "References"

class ref =
  fixes Null :: 'a

subsection "Field access and update"

syntax
  "_fassign"  :: "'a::ref => id => 'v => 's com"
   ("(2_^._ :=/ _)" [70,1000,65] 61)
  "_faccess"  :: "'a::ref => ('a::ref \<Rightarrow> 'v) => 'v"
   ("_^._" [65,1000] 65)
translations
  "p^.f := e"  =>  "f := CONST fun_upd f p e"
  "p^.f"       =>  "f p"

text "An example due to Suzuki:"

lemma "VARS v n
  {distinct[w,x,y,z]}
  w^.v := (1::int); w^.n := x;
  x^.v := 2; x^.n := y;
  y^.v := 3; y^.n := z;
  z^.v := 4; x^.n := z
  {w^.n^.n^.v = 4}"
by vcg_simp

section "The heap"

subsection "Paths in the heap"

primrec Path :: "('a::ref \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a \<Rightarrow> bool"
where
  "Path h x [] y = (x = y)"
| "Path h x (a#as) y = (x \<noteq> Null \<and> x = a \<and> Path h (h a) as y)"

lemma [simp]: "\<And>x. Path f x (as@bs) z = (\<exists>y. Path f x as y \<and> Path f y bs z)"
by(induct as, simp+)

lemma [simp]: "\<And>x. u \<notin> set as \<Longrightarrow> Path (f(u := v)) x as y = Path f x as y"
by(induct as, simp, simp add:eq_sym_conv)

subsection "Lists on the heap"

subsubsection "Relational abstraction"

definition List :: "('a::ref \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> bool"
  where "List h x as = Path h x as Null"

lemma [simp]: "List h x [] = (x = Null)"
by(simp add:List_def)

lemma [simp]: "List h x (a#as) = (x \<noteq> Null \<and> x = a \<and> List h (h a) as)"
by(simp add:List_def)

lemma [simp]: "List h Null as = (as = [])"
by(case_tac as, simp_all)

lemma List_Ref[simp]:
 "a \<noteq> Null \<Longrightarrow> List h a as = (\<exists>bs. as = a#bs \<and> List h (h a) bs)"
by(case_tac as, simp_all, fast)

declare fun_upd_apply[simp del]fun_upd_same[simp] fun_upd_other[simp]

lemma List_unique: "\<And>x bs. List h x as \<Longrightarrow> List h x bs \<Longrightarrow> as = bs"
by(induct as, simp, clarsimp)

lemma List_unique1: "List h p as \<Longrightarrow> \<exists>!as. List h p as"
by(blast intro:List_unique)

lemma List_app: "\<And>x. List h x (as@bs) = (\<exists>y. Path h x as y \<and> List h y bs)"
by(induct as, simp, clarsimp)

lemma List_hd_not_in_tl[simp]: "List h (h a) as \<Longrightarrow> a \<notin> set as"
apply (clarsimp simp add:in_set_conv_decomp)
apply(frule List_app[THEN iffD1])
apply(fastforce dest: List_unique)
done

lemma List_distinct[simp]: "\<And>x. List h x as \<Longrightarrow> distinct as"
apply(induct as, simp)
apply(fastforce dest:List_hd_not_in_tl)
done

subsection "Functional abstraction"

definition islist :: "('a::ref \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> bool"
  where "islist h p \<longleftrightarrow> (\<exists>as. List h p as)"

definition list :: "('a::ref \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a list"
  where "list h p = (SOME as. List h p as)"

lemma List_conv_islist_list: "List h p as = (islist h p \<and> as = list h p)"
apply(simp add:islist_def list_def)
apply(rule iffI)
apply(rule conjI)
apply blast
apply(subst some1_equality)
  apply(erule List_unique1)
 apply assumption
apply(rule refl)
apply simp
apply(rule someI_ex)
apply fast
done

lemma [simp]: "islist h Null"
by(simp add:islist_def)

lemma [simp]: "a \<noteq> Null \<Longrightarrow> islist h a = islist h (h a)"
by(simp add:islist_def)

lemma [simp]: "list h Null = []"
by(simp add:list_def)

lemma list_Ref_conv[simp]:
 "\<lbrakk> a \<noteq> Null; islist h (h a) \<rbrakk> \<Longrightarrow> list h a = a # list h (h a)"
apply(insert List_Ref[of _ h])
apply(fastforce simp:List_conv_islist_list)
done

lemma [simp]: "islist h (h a) \<Longrightarrow> a \<notin> set(list h (h a))"
apply(insert List_hd_not_in_tl[of h])
apply(simp add:List_conv_islist_list)
done

lemma list_upd_conv[simp]:
 "islist h p \<Longrightarrow> y \<notin> set(list h p) \<Longrightarrow> list (h(y := q)) p = list h p"
apply(drule notin_List_update[of _ _ h q p])
apply(simp add:List_conv_islist_list)
done

lemma islist_upd[simp]:
 "islist h p \<Longrightarrow> y \<notin> set(list h p) \<Longrightarrow> islist (h(y := q)) p"
apply(frule notin_List_update[of _ _ h q p])
apply(simp add:List_conv_islist_list)
done

section "Verifications"

subsection "List reversal"

text "A short but unreadable proof:"

lemma "VARS tl p q r
  {List tl p Ps \<and> List tl q Qs \<and> set Ps \<inter> set Qs = {}}
  WHILE p \<noteq> Null
  INV {\<exists>ps qs. List tl p ps \<and> List tl q qs \<and> set ps \<inter> set qs = {} \<and>
                 rev ps @ qs = rev Ps @ Qs}
  DO r := p; p := p^.tl; r^.tl := q; q := r OD
  {List tl q (rev Ps @ Qs)}"
apply vcg_simp
  apply fastforce
 apply(fastforce intro:notin_List_update[THEN iffD2])
(* explicily:
 apply clarify
 apply(rename_tac ps qs)
 apply clarsimp
 apply(rename_tac ps')
 apply(rule_tac x = ps' in exI)
 apply simp
 apply(rule_tac x = "p#qs" in exI)
 apply simp
*)
apply fastforce
done

text "A longer readable version:"

lemma "VARS tl p q r
  {List tl p Ps \<and> List tl q Qs \<and> set Ps \<inter> set Qs = {}}
  WHILE p \<noteq> Null
  INV {\<exists>ps qs. List tl p ps \<and> List tl q qs \<and> set ps \<inter> set qs = {} \<and>
               rev ps @ qs = rev Ps @ Qs}
  DO r := p; p := p^.tl; r^.tl := q; q := r OD
  {List tl q (rev Ps @ Qs)}"
proof vcg
  fix tl p q r
  assume "List tl p Ps \<and> List tl q Qs \<and> set Ps \<inter> set Qs = {}"
  thus "\<exists>ps qs. List tl p ps \<and> List tl q qs \<and> set ps \<inter> set qs = {} \<and>
                rev ps @ qs = rev Ps @ Qs" by fastforce
next
  fix tl p q r
  assume "(\<exists>ps qs. List tl p ps \<and> List tl q qs \<and> set ps \<inter> set qs = {} \<and>
                   rev ps @ qs = rev Ps @ Qs) \<and> p \<noteq> Null"
         (is "(\<exists>ps qs. ?I ps qs) \<and> _")
  then obtain ps qs where I: "?I ps qs \<and> p \<noteq> Null" by fast
  then obtain ps' where "ps = p # ps'" by fastforce
  hence "List (tl(p := q)) (p^.tl) ps' \<and>
         List (tl(p := q)) p       (p#qs) \<and>
         set ps' \<inter> set (p#qs) = {} \<and>
         rev ps' @ (p#qs) = rev Ps @ Qs"
    using I by fastforce
  thus "\<exists>ps' qs'. List (tl(p := q)) (p^.tl) ps' \<and>
                  List (tl(p := q)) p       qs' \<and>
                  set ps' \<inter> set qs' = {} \<and>
                  rev ps' @ qs' = rev Ps @ Qs" by fast
next
  fix tl p q r
  assume "(\<exists>ps qs. List tl p ps \<and> List tl q qs \<and> set ps \<inter> set qs = {} \<and>
                   rev ps @ qs = rev Ps @ Qs) \<and> \<not> p \<noteq> Null"
  thus "List tl q (rev Ps @ Qs)" by fastforce
qed

text\<open>Finaly, the functional version. A bit more verbose, but automatic!\<close>

lemma "VARS tl p q r
  {islist tl p \<and> islist tl q \<and>
   Ps = list tl p \<and> Qs = list tl q \<and> set Ps \<inter> set Qs = {}}
  WHILE p \<noteq> Null
  INV {islist tl p \<and> islist tl q \<and>
       set(list tl p) \<inter> set(list tl q) = {} \<and>
       rev(list tl p) @ (list tl q) = rev Ps @ Qs}
  DO r := p; p := p^.tl; r^.tl := q; q := r OD
  {islist tl q \<and> list tl q = rev Ps @ Qs}"
apply vcg_simp
  apply clarsimp
 apply clarsimp
apply clarsimp
done

subsection "Searching in a list"

text\<open>What follows is a sequence of successively more intelligent proofs that
a simple loop finds an element in a linked list.

We start with a proof based on the @{term List} predicate. This means it only
works for acyclic lists.\<close>

lemma "VARS tl p
  {List tl p Ps \<and> X \<in> set Ps}
  WHILE p \<noteq> Null \<and> p \<noteq> X
  INV {p \<noteq> Null \<and> (\<exists>ps. List tl p ps \<and> X \<in> set ps)}
  DO p := p^.tl OD
  {p = X}"
apply vcg_simp
  apply(case_tac "p = Null")
   apply clarsimp
  apply fastforce
 apply clarsimp
 apply fastforce
apply clarsimp
done

text\<open>Using @{term Path} instead of @{term List} generalizes the correctness
statement to cyclic lists as well:\<close>

lemma "VARS tl p
  {Path tl p Ps X}
  WHILE p \<noteq> Null \<and> p \<noteq> X
  INV {\<exists>ps. Path tl p ps X}
  DO p := p^.tl OD
  {p = X}"
apply vcg_simp
  apply blast
 apply fastforce
apply clarsimp
done

text\<open>Now it dawns on us that we do not need the list witness at all --- it
suffices to talk about reachability, i.e.\ we can use relations directly.\<close>

lemma "VARS tl p
  {(p,X) \<in> {(x,y). y = tl x & x \<noteq> Null}^*}
  WHILE p \<noteq> Null \<and> p \<noteq> X
  INV {(p,X) \<in> {(x,y). y = tl x & x \<noteq> Null}^*}
  DO p := p^.tl OD
  {p = X}"
apply vcg_simp
 apply clarsimp
 apply(erule converse_rtranclE)
  apply simp
 apply(simp)
apply(fastforce elim:converse_rtranclE)
done

subsection "Merging two lists"

text"This is still a bit rough, especially the proof."

fun merge :: "'a list * 'a list * ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list" where
"merge(x#xs,y#ys,f) = (if f x y then x # merge(xs,y#ys,f)
                                else y # merge(x#xs,ys,f))" |
"merge(x#xs,[],f) = x # merge(xs,[],f)" |
"merge([],y#ys,f) = y # merge([],ys,f)" |
"merge([],[],f) = []"

lemma imp_disjCL: "(P|Q \<longrightarrow> R) = ((P \<longrightarrow> R) \<and> (~P \<longrightarrow> Q \<longrightarrow> R))"
by blast

declare disj_not1[simp del] imp_disjL[simp del] imp_disjCL[simp]

lemma "VARS hd tl p q r s
 {List tl p Ps \<and> List tl q Qs \<and> set Ps \<inter> set Qs = {} \<and>
  (p \<noteq> Null \<or> q \<noteq> Null)}
 IF if q = Null then True else p ~= Null & p^.hd \<le> q^.hd
 THEN r := p; p := p^.tl ELSE r := q; q := q^.tl FI;
 s := r;
 WHILE p \<noteq> Null \<or> q \<noteq> Null
 INV {EX rs ps qs. Path tl r rs s \<and> List tl p ps \<and> List tl q qs \<and>
      distinct(s # ps @ qs @ rs) \<and> s \<noteq> Null \<and>
      merge(Ps,Qs,\<lambda>x y. hd x \<le> hd y) =
      rs @ s # merge(ps,qs,\<lambda>x y. hd x \<le> hd y) \<and>
      (tl s = p \<or> tl s = q)}
 DO IF if q = Null then True else p \<noteq> Null \<and> p^.hd \<le> q^.hd
    THEN s^.tl := p; p := p^.tl ELSE s^.tl := q; q := q^.tl FI;
    s := s^.tl
 OD
 {List tl r (merge(Ps,Qs,\<lambda>x y. hd x \<le> hd y))}"
apply vcg_simp

apply (fastforce)

apply clarsimp
apply(rule conjI)
apply clarsimp
apply(simp add:eq_sym_conv)
apply(rule_tac x = "rs @ [s]" in exI)
apply simp
apply(rule_tac x = "bs" in exI)
apply (fastforce simp:eq_sym_conv)

apply clarsimp
apply(rule conjI)
apply clarsimp
apply(rule_tac x = "rs @ [s]" in exI)
apply simp
apply(rule_tac x = "bsa" in exI)
apply(rule conjI)
apply (simp add:eq_sym_conv)
apply(rule exI)
apply(rule conjI)
apply(rule_tac x = bs in exI)
apply(rule conjI)
apply(rule refl)
apply (simp add:eq_sym_conv)
apply (simp add:eq_sym_conv)

apply(rule conjI)
apply clarsimp
apply(rule_tac x = "rs @ [s]" in exI)
apply simp
apply(rule_tac x = bs in exI)
apply (simp add:eq_sym_conv)
apply clarsimp
apply(rule_tac x = "rs @ [s]" in exI)
apply (simp add:eq_sym_conv)
apply(rule exI)
apply(rule conjI)
apply(rule_tac x = bsa in exI)
apply(rule conjI)
apply(rule refl)
apply (simp add:eq_sym_conv)
apply(rule_tac x = bs in exI)
apply (simp add:eq_sym_conv)

apply(clarsimp simp add:List_app)
done

(* TODO: merging with islist/list instead of List: an improvement?
   needs (is)path, which is not so easy to prove either. *)

subsection "Storage allocation"

definition new :: "'a set \<Rightarrow> 'a::ref"
  where "new A = (SOME a. a \<notin> A & a \<noteq> Null)"

lemma new_notin:
 "\<lbrakk> ~finite(UNIV::('a::ref)set); finite(A::'a set); B \<subseteq> A \<rbrakk> \<Longrightarrow>
  new (A) \<notin> B & new A \<noteq> Null"
apply(unfold new_def)
apply(rule someI2_ex)
 apply (fast dest:ex_new_if_finite[of "insert Null A"])
apply (fast)
done

lemma "~finite(UNIV::('a::ref)set) \<Longrightarrow>
  VARS xs elem next alloc p q
  {Xs = xs \<and> p = (Null::'a)}
  WHILE xs \<noteq> []
  INV {islist next p \<and> set(list next p) \<subseteq> set alloc \<and>
       map elem (rev(list next p)) @ xs = Xs}
  DO q := new(set alloc); alloc := q#alloc;
     q^.next := p; q^.elem := hd xs; xs := tl xs; p := q
  OD
  {islist next p \<and> map elem (rev(list next p)) = Xs}"
apply vcg_simp
 apply (clarsimp simp: subset_insert_iff neq_Nil_conv fun_upd_apply new_notin)
apply fastforce
done

end


(*
Author: Alexander Katovsky
*)

section "Yoneda"

theory Yoneda
imports NatTrans SetCat
begin

definition "YFtorNT' C f \<equiv> \<lparr>NTDom = Hom\<^bsub>C\<^esub>[\<midarrow>,dom\<^bsub>C\<^esub> f] , NTCod = Hom\<^bsub>C\<^esub>[\<midarrow>,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>[\<midarrow>,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>[\<midarrow>,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>[\<midarrow>,dom\<^bsub>C\<^esub> f]) ## g"
        and H2: "(HomC\<^bsub>C\<^esub>[g,cod\<^bsub>C\<^esub> f]) = (Hom\<^bsub>C\<^esub>[\<midarrow>,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>[\<midarrow>,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>[\<midarrow>,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>[\<midarrow>,dom\<^bsub>C\<^esub> f]) to (Hom\<^bsub>C\<^esub>[\<midarrow>,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>[\<midarrow>,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>[\<midarrow>,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>[\<midarrow>,dom\<^bsub>C\<^esub> f]) to (Hom\<^bsub>C\<^esub>[\<midarrow>,cod\<^bsub>C\<^esub> f])"
    and 2: "YFtorNT C g maps\<^bsub>CatExp (Op C) SET\<^esub> (Hom\<^bsub>C\<^esub>[\<midarrow>,dom\<^bsub>C\<^esub> g]) to (Hom\<^bsub>C\<^esub>[\<midarrow>,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>[\<midarrow>,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>[\<midarrow>,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>[\<midarrow>,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>[\<midarrow>,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>[\<midarrow>,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>[\<midarrow>,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>[\<midarrow>,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>[\<midarrow>,X]))"
  proof(simp add: YFtorNT_defs)
    have "Hom\<^bsub>C\<^esub>[\<midarrow>,dom\<^bsub>C\<^esub> (Id C X)] = Hom\<^bsub>C\<^esub>[\<midarrow>,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>[\<midarrow>,X]))" using CAT HomObj
      by (simp add: Category.CatIdDomCod)
    also have "... = NTDom (Id (CatExp (Op C) SET) (Hom\<^bsub>C\<^esub>[\<midarrow>,X]))" using Id by (simp add: CatExpDom)
    finally show "Hom\<^bsub>C\<^esub>[\<midarrow>,dom\<^bsub>C\<^esub> (Id C X)] = NTDom (Id (CatExp (Op C) SET) (Hom\<^bsub>C\<^esub>[\<midarrow>,X]))" .
  qed
  show "NTCod (YFtorNT C (Id C X)) = NTCod (Id (CatExp (Op C) SET) (Hom\<^bsub>C\<^esub>[\<midarrow>,X]))"
  proof(simp add: YFtorNT_defs)
    have "Hom\<^bsub>C\<^esub>[\<midarrow>,cod\<^bsub>C\<^esub> (Id C X)] = Hom\<^bsub>C\<^esub>[\<midarrow>,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>[\<midarrow>,X]))" using CAT HomObj
      by (simp add: Category.CatIdDomCod)
    also have "... = NTCod (Id (CatExp (Op C) SET) (Hom\<^bsub>C\<^esub>[\<midarrow>,X]))" using Id by (simp add: CatExpCod)
    finally show "Hom\<^bsub>C\<^esub>[\<midarrow>,cod\<^bsub>C\<^esub> (Id C X)] = NTCod (Id (CatExp (Op C) SET) (Hom\<^bsub>C\<^esub>[\<midarrow>,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>[\<midarrow>,X])) $$ Y"
    proof-
      have CD: "CatDom (Hom\<^bsub>C\<^esub>[\<midarrow>,X]) = Op C" by (simp add: HomFtorContraDom)
      have CC: "CatCod (Hom\<^bsub>C\<^esub>[\<midarrow>,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>[\<midarrow>,X]) @@ Y)" using Obj ObjY assms by (simp add: HomFtorOpObj )
      also have "... = (IdNatTrans (Hom\<^bsub>C\<^esub>[\<midarrow>,X])) $$ Y" using CD CC ObjYOp by (simp add: IdNatTrans_map)
      also have "... = (Id (CatExp (Op C) SET) (Hom\<^bsub>C\<^esub>[\<midarrow>,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>[\<midarrow>,dom\<^bsub>C\<^esub> (f ;;\<^bsub>C\<^esub> g)]" by (simp add: YFtorNT_defs)
        also have "... = Hom\<^bsub>C\<^esub>[\<midarrow>,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>[\<midarrow>,cod\<^bsub>C\<^esub> (f ;;\<^bsub>C\<^esub> g)]" by (simp add: YFtorNT_defs)
        also have "... = Hom\<^bsub>C\<^esub>[\<midarrow>,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>[\<midarrow>,X]" in Set.rev_bexI)
      have "X \<in> Obj C" using a by(simp add: YFtor'_def)
      thus "Hom\<^bsub>C \<^esub>[\<midarrow>,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>[\<midarrow>,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>[\<midarrow>,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>[\<midarrow>,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>[\<midarrow>,X]"
          and "YFtor' C @@ Y = Hom\<^bsub>C \<^esub>[\<midarrow>,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>[\<midarrow>,X]) to (Hom\<^bsub>C \<^esub>[\<midarrow>,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>[\<midarrow>,X]"
proof-
  have "CatDom (YFtor' C) = C" by (simp add: YFtor'_def)
  moreover hence "(YFtor' C) @@ X = Hom\<^bsub>C \<^esub>[\<midarrow>,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>[\<midarrow>,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>[\<midarrow>,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>[\<midarrow>,X])" using assms by (auto simp add: YFtorObj)
  moreover have "Ftor (Hom\<^bsub>C\<^esub>[\<midarrow>,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>[\<midarrow>,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>[\<midarrow>,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>[\<midarrow>,X]) : (Op C) \<longrightarrow> SET" using LSCat XObj by (simp add: HomFtorContraFtor)
    hence CDH: "CatDom (Hom\<^bsub>C\<^esub>[\<midarrow>,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>[\<midarrow>,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>[\<midarrow>,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>[\<midarrow>,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>[\<midarrow>,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>[\<midarrow>,Y]) (m2z\<^bsub>C\<^esub>f))"
    by(simp add: YFtorNT'_def YMapInv'_def )
  have "Hom\<^bsub>C\<^esub>[\<midarrow>,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>[\<midarrow>,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>[\<midarrow>,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>[\<midarrow>,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>[\<midarrow>,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>[\<midarrow>,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>[\<midarrow>,A]) : (Op C) \<longrightarrow> SET" and FtorB: "Ftor (Hom\<^bsub>C\<^esub>[\<midarrow>,B]) : (Op C) \<longrightarrow> SET"
    using assms by (simp add: HomFtorContraFtor)+
  have "Hom\<^bsub>C\<^esub>[\<midarrow>,A] = Hom\<^bsub>C\<^esub>[\<midarrow>,B]" using assms by (simp add: YFtorObj)
  hence "(Hom\<^bsub>C\<^esub>[\<midarrow>,A]) ## (Id (Op C) A) = (Hom\<^bsub>C\<^esub>[\<midarrow>,B]) ## (Id (Op C) A)" by simp
  hence "Id SET ((Hom\<^bsub>C\<^esub>[\<midarrow>,A]) @@ A) = Id SET ((Hom\<^bsub>C\<^esub>[\<midarrow>,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


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

theory DataStructures
imports "~~/src/HOL/Main"
begin

(*
 * Proofs on abstract data structures that should be applicable
 * to concrete C proofs.
 *)

(*
 * Singly-linked list definitions and lemmas adapted from:
 *
 *   "Proving Pointer Programs in Higher-Order Logic"
 *   Farhad Mehta, Tobias Nipkow
 *)

locale linked_list =
  (* Fetch next pointer from object. *)
  fixes list_next :: "'a \<Rightarrow> 'p"
  (* Null pointer. *)
  and NULL :: "'p"

context linked_list begin

primrec
  list :: "('p \<Rightarrow> 'a option) \<Rightarrow> 'p list \<Rightarrow> 'p \<Rightarrow> bool"
where
  "list s [] i = (i = NULL)"
| "list s (x#xs) i =
    (i = x \<and> x \<noteq> NULL \<and> (\<exists>a. s x = Some a \<and>  list s xs (list_next a)))"

definition
  is_list :: "('p \<Rightarrow> 'a option) \<Rightarrow> 'p \<Rightarrow> bool"
where
  "is_list s p \<equiv> \<exists>xs. list s xs p"

definition
  the_list :: "('p \<Rightarrow> 'a option) \<Rightarrow> 'p \<Rightarrow> 'p list"
where
  "the_list s p \<equiv> (THE xs. list s xs p)"

lemma list_empty [simp]: "list s xs NULL = (xs = [])"
  by (case_tac "xs", auto)

lemma is_list_empty [simp]: "is_list s NULL"
  by (clarsimp simp: is_list_def)

lemma the_list_empty [simp]: "the_list s NULL = []"
  by (clarsimp simp: the_list_def)

lemma list_unique: "\<lbrakk> list s xs p; list s ys p \<rbrakk> \<Longrightarrow> xs = ys"
  apply (induct xs arbitrary: ys p)
   apply simp
  apply (case_tac ys, auto)
  done

lemma list_ptr_unique: "\<lbrakk> list s xs p; list s xs p' \<rbrakk> \<Longrightarrow> p = p'"
  by (metis linked_list.list.simps(1) linked_list.list.simps(2) neq_Nil_conv)

lemma list_non_NULL:
  "p \<noteq> NULL \<Longrightarrow>
    list s xs p = (\<exists>ys. xs= p#ys \<and> (\<exists>a. s p = Some a \<and> list s ys (list_next a)))"
  by (case_tac xs, auto)

lemma is_list_non_NULL:
  "p \<noteq> NULL \<Longrightarrow>
    is_list s p = (\<exists>a. s p = Some a \<and> is_list s (list_next a))"
  apply (clarsimp simp: is_list_def list_non_NULL)
  apply force
  done

lemma the_list_non_NULL:
  "\<lbrakk> p \<noteq> NULL; is_list s p \<rbrakk> \<Longrightarrow>
    the_list s p = (p # (the_list s (list_next (the (s p)))))"
  apply (clarsimp simp: the_list_def is_list_def list_non_NULL)
  apply (rule the_equality)
   apply (clarsimp simp: list_unique)
   apply (metis (lifting) list_unique the_equality)
  apply clarsimp
  apply (metis (lifting) list_unique the_equality)
  done

lemma list_is_list: "list s xs p \<Longrightarrow> is_list s p"
  apply (clarsimp simp: is_list_def)
  apply force
  done

lemma list_the_list: "list s xs p \<Longrightarrow> the_list s p = xs"
  apply (clarsimp simp: the_list_def)
  apply (metis (lifting) list_unique the_equality)
  done

lemma the_list_empty' [simp]:
    "is_list s p \<Longrightarrow> (the_list s p = []) = (p = NULL)"
  by (metis is_list_def list_empty list_ptr_unique list_the_list)

lemma list_last_is_NULL:
    "\<lbrakk> is_list s p; the_list s p = l; p \<noteq> NULL \<rbrakk> \<Longrightarrow> list_next (the (s (last l))) = NULL"
  apply (induct l arbitrary: p)
   apply clarsimp
  apply (metis is_list_non_NULL last_ConsL last_ConsR linked_list.the_list_non_NULL option.sel the_list_empty' list.sel(3))
  done

lemma list_in_Some:
  "\<lbrakk> list s xs p; x \<in> set xs \<rbrakk> \<Longrightarrow> \<exists>a. s x = Some a"
  apply (induct xs arbitrary: p, auto)
  done

lemma list_mem: "\<lbrakk> list s xs p; p \<noteq> NULL \<rbrakk> \<Longrightarrow> p \<in> set xs"
  by (case_tac xs, auto)

lemma list_ign [iff]: "\<lbrakk> x \<notin> set xs \<rbrakk> \<Longrightarrow> list (s(x := v)) xs p = list s xs p"
  apply (induct xs arbitrary: p)
   apply clarsimp
  apply atomize
  apply clarsimp
  done

lemma list_ign_ext' [intro, iff]:
    "\<lbrakk> \<forall>x \<in> set xs. (\<exists>a. s x = Some a) = (\<exists>a. s' x = Some a) \<and> (list_next (the (s x)) = list_next (the (s' x)))  \<rbrakk> \<Longrightarrow> list s xs p = list s' xs p"
  apply (induct xs arbitrary: p, auto)
  done

lemma list_ign_ext [iff?]: "\<lbrakk> \<forall>x \<in> set xs. s x = s' x \<rbrakk> \<Longrightarrow> list s xs p = list s' xs p"
  apply force
  done

lemma list_append_Ex:
  "list s (xs@ys) p \<Longrightarrow> (\<exists>q. list s ys q)"
  apply (induct xs arbitrary: ys p)
   apply force
  apply force
  done

lemma list_head_not_in_list: "\<lbrakk> list s xs (list_next a); s p = Some a \<rbrakk> \<Longrightarrow> p \<notin> set xs"
  apply (rule ccontr)
  apply clarsimp
  apply (frule split_list)
  apply clarsimp
  apply (frule list_append_Ex)
  apply clarsimp
  apply (drule (1) list_unique)
  apply clarsimp
  done

lemma list_distinct: "list s xs x \<Longrightarrow> distinct xs"
  apply (induct xs arbitrary: x)
   apply clarsimp
  apply clarsimp
  apply (drule (1) list_head_not_in_list)
  apply clarsimp
  done

lemma list_next: "\<lbrakk> list s xs x; s x = Some a; x \<noteq> NULL \<rbrakk> \<Longrightarrow> list s (tl xs) (list_next a)"
  apply (case_tac xs)
   apply clarsimp
  apply clarsimp
  done

primrec
  path :: "('p \<Rightarrow> 'a option) \<Rightarrow> 'p \<Rightarrow> 'p list \<Rightarrow> 'p \<Rightarrow> bool"
where
  "path s x [] y = (x = y)"
| "path s x (a#as) y = (x \<noteq> NULL \<and> x = a \<and> (\<exists>v. s x = Some v \<and> path s (list_next v) as y))"

lemma path_null [simp]: "path s NULL as x = (as = [] \<and> x = NULL)"
  by (case_tac as, auto)

lemma path_no_null [simp]: "\<lbrakk> path s a xs b \<rbrakk> \<Longrightarrow> NULL \<notin> set xs"
  apply (induct xs arbitrary: a)
   apply clarsimp
  apply clarsimp
  done

lemma path_next:
  "\<lbrakk> x \<noteq> NULL \<rbrakk> \<Longrightarrow> path s x as y = ((as = [] \<and> x = y)
    \<or> (\<exists>bs. as = x # bs \<and> (\<exists>a. s x = Some a \<and> path s (list_next a) bs y)))"
  apply (case_tac as, auto)
  done

lemma path_null_list: "path s a xs NULL = list s xs a"
  apply (induct xs arbitrary: a, auto)
  done

lemma path_ign [iff]: "u \<notin> set as \<Longrightarrow> path (s(u := v)) x as y = path s x as y"
  by (induct as arbitrary: x y, auto)

lemma path_split [simp]: "path s x (as @ bs) z = (\<exists>y. path s x as y \<and> path s y bs z)"
  apply (induct as arbitrary: x, auto)
  done

lemma list_split [simp]: "list s (as @ bs) x = (\<exists>y. path s x as y \<and> list s bs y)"
  by (induct as arbitrary: x, auto)

end

(*
 * Doubly-linked list, with NULL pointers.
 *)
locale dbl_linked_list =
  linked_list +
  constrains list_next :: "'a \<Rightarrow> 'p" and NULL :: "'p"
  (* Fetch prev pointer from object. *)
  fixes list_prev :: "'a \<Rightarrow> 'p"

context dbl_linked_list begin

primrec
  dbl_list_tail :: "('p \<Rightarrow> 'a option) \<Rightarrow> 'p \<Rightarrow> 'p list \<Rightarrow> 'p \<Rightarrow> bool"
where
  "dbl_list_tail s p [] h = (h = NULL)"
| "dbl_list_tail s p (x#xs) h =
    (h = x \<and> x \<noteq> NULL \<and> (\<exists>a. s x = Some a \<and> list_prev a = p \<and> dbl_list_tail s x xs (list_next a)))"

abbreviation
  dbl_list :: "('p \<Rightarrow> 'a option) \<Rightarrow> 'p list \<Rightarrow> 'p \<Rightarrow> bool"
where
  "dbl_list s l h \<equiv> dbl_list_tail s NULL l h"

lemma dbl_list_null_empty [simp]: "dbl_list_tail s p [] NULL"
  by simp

lemma dbl_list_empty [simp]: "dbl_list_tail s p xs NULL = (xs = [])"
  by (case_tac xs, auto)

lemma dbl_list_single: "\<lbrakk> s x = Some y; list_prev y = NULL; list_next y = NULL; x \<noteq> NULL \<rbrakk> \<Longrightarrow> dbl_list s [x] x"
  by simp

lemma dbl_list_tail_non_NULL:
  "h \<noteq> NULL \<Longrightarrow>
    dbl_list_tail s p xs h =
      (\<exists>ys. xs= h#ys \<and> (\<exists>a. s h = Some a \<and> list_prev a = p \<and> dbl_list_tail s h ys (list_next a)))"
  apply (case_tac xs, auto)
  done

lemma dbl_list_tail_in_Some:
  "\<lbrakk> dbl_list_tail s p xs h; x \<in> set xs \<rbrakk> \<Longrightarrow> \<exists>a. s x = Some a"
  apply (induct xs arbitrary: p h, auto)
  done

lemma dbl_list_tail_mem: "\<lbrakk> dbl_list_tail s p xs h; h \<noteq> NULL \<rbrakk> \<Longrightarrow> h \<in> set xs"
  by (case_tac xs, auto)

lemma dbl_list_ign [iff]: "\<lbrakk> x \<notin> set xs \<rbrakk> \<Longrightarrow> dbl_list_tail (s(x := v)) p xs h = dbl_list_tail s p xs h"
  apply (induct xs arbitrary: p h)
   apply clarsimp
  apply atomize
  apply clarsimp
  done

lemma dbl_list_ign_ext' [intro, iff]:
    "\<lbrakk> \<forall>x \<in> set xs.
        (\<exists>a. s x = Some a) = (\<exists>a. s' x = Some a)
        \<and> (list_next (the (s x)) = list_next (the (s' x)))
        \<and> (list_prev (the (s x)) = list_prev (the (s' x))) \<rbrakk> \<Longrightarrow>
     dbl_list_tail s p xs h = dbl_list_tail s' p xs h"
  apply (induct xs arbitrary: p h, auto)
  done

lemma dbl_list_ign_ext [iff?]: "\<lbrakk> \<forall>x \<in> set xs. s x = s' x \<rbrakk> \<Longrightarrow> dbl_list_tail s p xs h = dbl_list_tail s' p xs h"
  apply force
  done

lemma dbl_list_unique: "\<lbrakk> dbl_list_tail s p xs h; dbl_list_tail s p' ys h \<rbrakk> \<Longrightarrow> xs = ys"
  apply (induct xs arbitrary: ys p p' h)
   apply simp
  apply (case_tac ys, auto)
  done

lemma dbl_list_append_Ex:
  "dbl_list_tail s p (xs@ys) h \<Longrightarrow> (\<exists>q. dbl_list_tail s (last (p#xs)) ys q)"
  apply (induct xs arbitrary: ys p h)
   apply force
  apply force
  done

lemma dbl_list_head_not_in_list: "\<lbrakk> dbl_list_tail s p xs (list_next a); s h = Some a \<rbrakk> \<Longrightarrow> h \<notin> set xs"
  apply (rule ccontr)
  apply clarsimp
  apply (frule split_list)
  apply clarsimp
  apply (frule dbl_list_append_Ex)
  apply clarsimp
  apply (drule (1) dbl_list_unique)
  apply clarsimp
  done

lemma dbl_list_distinct: "dbl_list_tail s p xs x \<Longrightarrow> distinct xs"
  apply (induct xs arbitrary: x p)
   apply clarsimp
  apply clarsimp
  apply (drule (1) dbl_list_head_not_in_list)
  apply clarsimp
  done

lemma dbl_list_next: "\<lbrakk> dbl_list_tail s p xs x; s x = Some a; x \<noteq> NULL \<rbrakk> \<Longrightarrow> dbl_list_tail s x (tl xs) (list_next a)"
  apply (case_tac xs)
   apply clarsimp
  apply clarsimp
  done

end

(*
 * Circular-linked list, with a head node.
 *)
locale circ_linked_list =
  (* Fetch next pointer from object. *)
  fixes list_next :: "'a \<Rightarrow> 'p"
  (* Fetch previous pointer from object. *)
  fixes list_prev :: "'a \<Rightarrow> 'p"

context circ_linked_list begin

fun
  circ_list_tail :: "('p \<Rightarrow> 'a option) \<Rightarrow> 'p \<Rightarrow> 'p \<Rightarrow> 'p list \<Rightarrow> 'p \<Rightarrow> bool"
where
  "circ_list_tail s head prev [] current = (current = head)"
| "circ_list_tail s head prev (x#xs) current =
        (current = x \<and> current \<noteq> head \<and>
          (\<exists>a. s x = Some a \<and> list_prev a = prev
            \<and> circ_list_tail s head x xs (list_next a)))"

lemma circ_list_defn_test: "
  \<lbrakk> s head = Some headNode;
    s n1 = Some node1;
    s n2 = Some node2;
    list_next headNode = n1; list_next node1 = n2; list_next node2 = head;
    list_prev headNode = n2; list_prev node1 = head; list_prev node2 = n1;
    n1 \<noteq> head; n2 \<noteq> head \<rbrakk> \<Longrightarrow>
   circ_list_tail s head head [n1, n2] n1"
  apply clarsimp
  done

definition
  circ_list :: "('p \<Rightarrow> 'a option) \<Rightarrow> 'p \<Rightarrow> 'p list \<Rightarrow> bool"
where
  "circ_list s head l \<equiv> (\<exists>a. s head = Some a \<and> (list_prev a = (last (head # l))) \<and> (circ_list_tail s head head l (list_next a)))"

lemma circ_list_tail_empty [simp]: "circ_list_tail s head p xs head = (xs = [])"
  apply (case_tac xs)
   apply clarsimp
  apply clarsimp
  done

lemma circ_list_empty: "\<lbrakk> s head = Some a; list_next a = head; list_prev a = head \<rbrakk> \<Longrightarrow> circ_list s head []"
  apply (clarsimp simp: circ_list_def)
  done

lemma circ_list_single: "\<lbrakk>
    x \<noteq> head;
    s x = Some a; list_next a = head; list_prev a = head;
    s head = Some b; list_next b = x; list_prev b = x
  \<rbrakk> \<Longrightarrow> circ_list s head [x]"
  apply (clarsimp simp: circ_list_def)
  done

lemma circ_list_tail_in_Some:
  "\<lbrakk> circ_list_tail s head p xs h; x \<in> set xs \<rbrakk> \<Longrightarrow> \<exists>a. s x = Some a"
  apply (induct xs arbitrary: p h, auto)
  done

lemma circ_list_tail_ign [iff]: "\<lbrakk> x \<notin> set xs \<rbrakk> \<Longrightarrow> circ_list_tail (s(x := v)) head p xs h = circ_list_tail s head p xs h"
  apply (induct xs arbitrary: p h)
   apply clarsimp
  apply clarsimp
  done

lemma circ_list_ign [iff]: "\<lbrakk> x \<notin> set xs; x \<noteq> head \<rbrakk> \<Longrightarrow> circ_list (s(x := v)) head xs = circ_list s head xs"
  apply (clarsimp simp: circ_list_def)
  done

theorems circ_list_tail_ign' [iff] = circ_list_tail_ign [unfolded fun_upd_def]
theorems circ_list_ign' [iff] = circ_list_ign [unfolded fun_upd_def]

lemma circ_list_tail_ign_ext' [intro?, iff?]:
    "\<lbrakk> \<forall>x \<in> set xs.
        (\<exists>a. s x = Some a) = (\<exists>a. s' x = Some a)
        \<and> (list_next (the (s x)) = list_next (the (s' x)))
        \<and> (list_prev (the (s x)) = list_prev (the (s' x))) \<rbrakk> \<Longrightarrow>
     circ_list_tail s head p xs h = circ_list_tail s' head p xs h"
  apply (induct xs arbitrary: p h, auto)
  done

lemma circ_list_ign_ext' [intro?, iff?]:
    "\<lbrakk> \<forall>x \<in> set xs.
        (\<exists>a. s x = Some a) = (\<exists>a. s' x = Some a)
        \<and> (list_next (the (s x)) = list_next (the (s' x)))
        \<and> (list_prev (the (s x)) = list_prev (the (s' x)));
       (\<exists>a. s head = Some a) = (\<exists>a. s' head = Some a);
       (list_next (the (s head)) = list_next (the (s' head)));
       (list_prev (the (s head)) = list_prev (the (s' head))) \<rbrakk> \<Longrightarrow>
     circ_list s head xs = circ_list s' head xs"
  apply (clarsimp simp: circ_list_def)
  apply (case_tac xs)
   apply force
  apply (clarsimp, safe, auto iff: circ_list_tail_ign_ext')
  done

lemma circ_list_tail_ign_ext [iff?]: "\<lbrakk> \<forall>x \<in> set xs. s x = s' x \<rbrakk> \<Longrightarrow> circ_list_tail s head p xs h = circ_list_tail s' head p xs h"
  apply (force iff: circ_list_tail_ign_ext')
  done

lemma circ_list_ign_ext [iff?]: "\<lbrakk> \<forall>x \<in> set xs. s x = s' x; s head = s' head \<rbrakk> \<Longrightarrow> circ_list s head xs = circ_list s' head xs"
  apply (force iff: circ_list_ign_ext')
  done

lemma circ_list_tail_unique: "\<lbrakk> circ_list_tail s head p xs h; circ_list_tail s head p' ys h \<rbrakk> \<Longrightarrow> xs = ys"
  apply (induct xs arbitrary: ys p p' h)
   apply clarsimp
  apply (case_tac ys, auto)
  done

lemma circ_list_unique: "\<lbrakk> circ_list s h xs; circ_list s h ys \<rbrakk> \<Longrightarrow> xs = ys"
  apply (clarsimp simp: circ_list_def)
  apply (erule (1) circ_list_tail_unique)
  done

lemma circ_list_tail_append_Ex:
  "circ_list_tail s head p (xs@ys) h \<Longrightarrow> (\<exists>q. circ_list_tail s head (last (p#xs)) ys q)"
  apply (induct xs arbitrary: ys p h)
   apply force
  apply force
  done

lemma circ_list_tail_head_not_in_list: "\<lbrakk> circ_list_tail s head p xs (list_next a); s h = Some a \<rbrakk> \<Longrightarrow> h \<notin> set xs"
  apply (rule ccontr)
  apply clarsimp
  apply (frule split_list)
  apply clarsimp
  apply (frule circ_list_tail_append_Ex)
  apply clarsimp
  apply (drule (1) circ_list_tail_unique)
  apply clarsimp
  done

lemma circ_list_head_not_in_list: "\<lbrakk> circ_list s head xs \<rbrakk> \<Longrightarrow> head \<notin> set xs"
  apply (clarsimp simp: circ_list_def)
  apply (drule (1) circ_list_tail_head_not_in_list)
  apply simp
  done

lemma circ_list_tail_distinct: "circ_list_tail s head p xs x \<Longrightarrow> distinct xs"
  apply (induct xs arbitrary: x p)
   apply clarsimp
  apply clarsimp
  apply (drule (1) circ_list_tail_head_not_in_list)
  apply clarsimp
  done

lemma circ_list_distinct: "circ_list s head xs \<Longrightarrow> distinct xs"
  by (metis circ_list_def circ_list_tail_distinct)

lemma circ_list_tail_prev':
  "\<lbrakk> circ_list_tail s h p a x; n \<in> set a; s n = Some m; list_prev m \<noteq> p \<rbrakk> \<Longrightarrow> list_prev m \<in> set a"
  apply (induct a arbitrary: p x)
   apply clarsimp
  apply force
  done

lemma circ_list_tail_prev:
  "\<lbrakk> circ_list_tail s h p a x; n \<in> set a; s n = Some m; list_prev m \<notin> set a \<rbrakk> \<Longrightarrow> list_prev m = p"
  apply (induct a arbitrary: p x)
   apply clarsimp
  apply force
  done

lemma circ_list_tail_h_not_in_list:
  "\<lbrakk> circ_list_tail s h p a x \<rbrakk> \<Longrightarrow> h \<notin> set a"
  by (induct a arbitrary: p x, auto)

lemma circ_list_tail_cong:
  "\<lbrakk> \<And>i. \<lbrakk> i \<in> set a; i \<noteq> h \<rbrakk> \<Longrightarrow> s i = s' i; h = h'; p = p'; a = a'; x = x' \<rbrakk>
     \<Longrightarrow> circ_list_tail s h p a x = circ_list_tail s' h' p' a' x'"
  apply clarsimp
  apply (case_tac "h' \<in> set a'")
   apply (metis circ_list_tail_h_not_in_list)
  apply (rule circ_list_tail_ign_ext')
  apply clarsimp
  apply metis
  done

end

end


(*  Title:      HOL/ex/Hex_Bin_Examples.thy
    Author:     Gerwin Klein, NICTA
*)

section \<open>Examples for hexadecimal and binary numerals\<close>

theory Hex_Bin_Examples imports MainRLT
begin

text "Hex and bin numerals can be used like normal decimal numerals in input"
lemma "0xFF = 255" by (rule refl)
lemma "0xF = 0b1111" by (rule refl)

text \<open>
  Just like decimal numeral they are polymorphic, for arithmetic
  they need to be constrained
\<close>
lemma "0x0A + 0x10 = (0x1A :: nat)" by simp

text "The number of leading zeros is irrelevant"
lemma "0b00010000 = 0x10" by (rule refl)

text "Unary minus works as for decimal numerals"
lemma "- 0x0A = - 10" by (rule refl)

text \<open>
  Hex and bin numerals are printed as decimal: \<^term>\<open>0b10\<close>
\<close>
term "0b10"
term "0x0A"

text \<open>
  The numerals 0 and 1 are syntactically different from the
  constants 0 and 1. For the usual numeric types, their values
  are the same, though.
\<close>
lemma "0x01 = 1" oops
lemma "0x00 = 0" oops

lemma "0x01 = (1::nat)" by simp
lemma "0b0000 = (0::int)" by simp

end


(*  Title:      ZF/ex/Ramsey.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1992  University of Cambridge

Ramsey's Theorem (finite exponent 2 version)

Based upon the article
    D Basin and M Kaufmann,
    The Boyer-Moore Prover and Nuprl: An Experimental Comparison.
    In G Huet and G Plotkin, editors, Logical Frameworks.
    (CUP, 1991), pages 89-119

See also
    M Kaufmann,
    An example in NQTHM: Ramsey's Theorem
    Internal Note, Computational Logic, Inc., Austin, Texas 78703
    Available from the author: kaufmann@cli.com

This function compute Ramsey numbers according to the proof given below
(which, does not constrain the base case values at all.

fun ram 0 j = 1
  | ram i 0 = 1
  | ram i j = ram (i-1) j + ram i (j-1)
*)

theory Ramsey imports Main begin

definition
  Symmetric :: "i=>o" where
    "Symmetric(E) == (\<forall>x y. <x,y>:E \<longrightarrow> <y,x>:E)"

definition
  Atleast :: "[i,i]=>o" where \<comment> "not really necessary: ZF defines cardinality"
    "Atleast(n,S) == (\<exists>f. f \<in> inj(n,S))"

definition
  Clique  :: "[i,i,i]=>o" where
    "Clique(C,V,E) == (C \<subseteq> V) & (\<forall>x \<in> C. \<forall>y \<in> C. x\<noteq>y \<longrightarrow> <x,y> \<in> E)"

definition
  Indept  :: "[i,i,i]=>o" where
    "Indept(I,V,E) == (I \<subseteq> V) & (\<forall>x \<in> I. \<forall>y \<in> I. x\<noteq>y \<longrightarrow> <x,y> \<notin> E)"

definition
  Ramsey  :: "[i,i,i]=>o" where
    "Ramsey(n,i,j) == \<forall>V E. Symmetric(E) & Atleast(n,V) \<longrightarrow>
         (\<exists>C. Clique(C,V,E) & Atleast(i,C)) |
         (\<exists>I. Indept(I,V,E) & Atleast(j,I))"

(*** Cliques and Independent sets ***)

lemma Clique0 [intro]: "Clique(0,V,E)"
by (unfold Clique_def, blast)

lemma Clique_superset: "[| Clique(C,V',E);  V'<=V |] ==> Clique(C,V,E)"
by (unfold Clique_def, blast)

lemma Indept0 [intro]: "Indept(0,V,E)"
by (unfold Indept_def, blast)

lemma Indept_superset: "[| Indept(I,V',E);  V'<=V |] ==> Indept(I,V,E)"
by (unfold Indept_def, blast)

(*** Atleast ***)

lemma Atleast0 [intro]: "Atleast(0,A)"
by (unfold Atleast_def inj_def Pi_def function_def, blast)

lemma Atleast_succD:
    "Atleast(succ(m),A) ==> \<exists>x \<in> A. Atleast(m, A-{x})"
apply (unfold Atleast_def)
apply (blast dest: inj_is_fun [THEN apply_type] inj_succ_restrict)
done

lemma Atleast_superset:
    "[| Atleast(n,A);  A \<subseteq> B |] ==> Atleast(n,B)"
by (unfold Atleast_def, blast intro: inj_weaken_type)

lemma Atleast_succI:
    "[| Atleast(m,B);  b\<notin> B |] ==> Atleast(succ(m), cons(b,B))"
apply (unfold Atleast_def succ_def)
apply (blast intro: inj_extend elim: mem_irrefl)
done

lemma Atleast_Diff_succI:
     "[| Atleast(m, B-{x});  x \<in> B |] ==> Atleast(succ(m), B)"
by (blast intro: Atleast_succI [THEN Atleast_superset])

(*** Main Cardinality Lemma ***)

(*The #-succ(0) strengthens the original theorem statement, but precisely
  the same proof could be used!!*)
lemma pigeon2 [rule_format]:
     "m \<in> nat ==>
          \<forall>n \<in> nat. \<forall>A B. Atleast((m#+n) #- succ(0), A \<union> B) \<longrightarrow>
                           Atleast(m,A) | Atleast(n,B)"
apply (induct_tac "m")
apply (blast intro!: Atleast0, simp)
apply (rule ballI)
apply (rename_tac m' n) (*simplifier does NOT preserve bound names!*)
apply (induct_tac "n", auto)
apply (erule Atleast_succD [THEN bexE])
apply (rename_tac n' A B z)
apply (erule UnE)
(**case z \<in> B.  Instantiate the '\<forall>A B' induction hypothesis. **)
apply (drule_tac [2] x1 = A and x = "B-{z}" in spec [THEN spec])
apply (erule_tac [2] mp [THEN disjE])
(*cases Atleast(succ(m1),A) and Atleast(succ(k),B)*)
apply (erule_tac [3] asm_rl notE Atleast_Diff_succI)+
(*proving the condition*)
prefer 2 apply (blast intro: Atleast_superset)
(**case z \<in> A.  Instantiate the '\<forall>n \<in> nat. \<forall>A B' induction hypothesis. **)
apply (drule_tac x2="succ(n')" and x1="A-{z}" and x=B
       in bspec [THEN spec, THEN spec])
apply (erule nat_succI)
apply (erule mp [THEN disjE])
(*cases Atleast(succ(m1),A) and Atleast(succ(k),B)*)
apply (erule_tac [2] asm_rl Atleast_Diff_succI notE)+
(*proving the condition*)
apply simp
apply (blast intro: Atleast_superset)
done

(**** Ramsey's Theorem ****)

(** Base cases of induction; they now admit ANY Ramsey number **)

lemma Ramsey0j: "Ramsey(n,0,j)"
by (unfold Ramsey_def, blast)

lemma Ramseyi0: "Ramsey(n,i,0)"
by (unfold Ramsey_def, blast)

(** Lemmas for induction step **)

(*The use of succ(m) here, rather than #-succ(0), simplifies the proof of
  Ramsey_step_lemma.*)
lemma Atleast_partition: "[| Atleast(m #+ n, A);  m \<in> nat;  n \<in> nat |]
      ==> Atleast(succ(m), {x \<in> A. ~P(x)}) | Atleast(n, {x \<in> A. P(x)})"
apply (rule nat_succI [THEN pigeon2], assumption+)
apply (rule Atleast_superset, auto)
done

(*For the Atleast part, proves ~(a \<in> I) from the second premise!*)
lemma Indept_succ:
    "[| Indept(I, {z \<in> V-{a}. <a,z> \<notin> E}, E);  Symmetric(E);  a \<in> V;
        Atleast(j,I) |] ==>
     Indept(cons(a,I), V, E) & Atleast(succ(j), cons(a,I))"
apply (unfold Symmetric_def Indept_def)
apply (blast intro!: Atleast_succI)
done

lemma Clique_succ:
    "[| Clique(C, {z \<in> V-{a}. <a,z>:E}, E);  Symmetric(E);  a \<in> V;
        Atleast(j,C) |] ==>
     Clique(cons(a,C), V, E) & Atleast(succ(j), cons(a,C))"
apply (unfold Symmetric_def Clique_def)
apply (blast intro!: Atleast_succI)
done

(** Induction step **)

(*Published proofs gloss over the need for Ramsey numbers to be POSITIVE.*)
lemma Ramsey_step_lemma:
   "[| Ramsey(succ(m), succ(i), j);  Ramsey(n, i, succ(j));
       m \<in> nat;  n \<in> nat |] ==> Ramsey(succ(m#+n), succ(i), succ(j))"
apply (unfold Ramsey_def, clarify)
apply (erule Atleast_succD [THEN bexE])
apply (erule_tac P1 = "%z.<x,z>:E" in Atleast_partition [THEN disjE],
       assumption+)
(*case m*)
apply (fast dest!: Indept_succ elim: Clique_superset)
(*case n*)
apply (fast dest!: Clique_succ elim: Indept_superset)
done

(** The actual proof **)

(*Again, the induction requires Ramsey numbers to be positive.*)
lemma ramsey_lemma: "i \<in> nat ==> \<forall>j \<in> nat. \<exists>n \<in> nat. Ramsey(succ(n), i, j)"
apply (induct_tac "i")
apply (blast intro!: Ramsey0j)
apply (rule ballI)
apply (induct_tac "j")
apply (blast intro!: Ramseyi0)
apply (blast intro!: add_type Ramsey_step_lemma)
done

(*Final statement in a tidy form, without succ(...) *)

end


theory EtaExpansionSafe
imports EtaExpansion Sestoft
begin

theorem eta_expansion_safe:
  assumes "set T \<subseteq> range Arg"
  shows "(\<Gamma>, eta_expand (length T) e, T@S) \<Rightarrow>\<^sup>* (\<Gamma>, e, T@S)"
using assms
proof(induction T arbitrary: e)
  case Nil show ?case by simp
next
  case (Cons se T)
  from Cons(2) obtain x where "se = Arg x" by auto

  from Cons have prem: "set T \<subseteq> range Arg" by simp

  have "(\<Gamma>, eta_expand (Suc (length T)) e, Arg x # T @ S) = (\<Gamma>, Lam [fresh_var e]. eta_expand (length T) (App e (fresh_var e)), Arg x # T @ S)" by simp
  also have "\<dots> \<Rightarrow> (\<Gamma>, (eta_expand (length T) (App e (fresh_var e)))[fresh_var e ::= x], T @ S)" by (rule app\<^sub>2)
  also have "\<dots> = (\<Gamma>, (eta_expand (length T) (App e x)), T @ S)" unfolding subst_eta_expand by simp
  also have "\<dots> \<Rightarrow>\<^sup>* (\<Gamma>, App e x, T @ S)" by (rule Cons.IH[OF prem])
  also have "\<dots> \<Rightarrow> (\<Gamma>, e, Arg x # T @ S)"  by (rule app\<^sub>1)
  finally show ?case using `se = _` by simp
qed

fun arg_prefix :: "stack \<Rightarrow> nat" where
  "arg_prefix [] = 0"
| "arg_prefix (Arg x # S) = Suc (arg_prefix S)"
| "arg_prefix (Alts e1 e2 # S) = 0"
| "arg_prefix (Upd x # S) = 0"
| "arg_prefix (Dummy x # S) = 0"

theorem eta_expansion_safe':
  assumes "n \<le> arg_prefix S"
  shows "(\<Gamma>, eta_expand n e, S) \<Rightarrow>\<^sup>* (\<Gamma>, e, S)"
proof-
  from assms
  have "set (take n S) \<subseteq> range Arg" and "length (take n S) = n"
    apply (induction S arbitrary: n rule: arg_prefix.induct)
    apply auto
    apply (case_tac n, auto)+
    done
  hence "S = take n S @ drop n S" by (metis append_take_drop_id)
  with eta_expansion_safe[OF `_ \<subseteq> _`] `length _ = _`
  show ?thesis by metis
qed

end