(*  Title:       Yoneda
    Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
    Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
*)

chapter Yoneda

theory Yoneda
imports DualCategory SetCat FunctorCategory
begin

  text\<open>
    This theory defines the notion of a ``hom-functor'' and gives a proof of the Yoneda Lemma.
    In traditional developments of category theory based on set theories such as ZFC,
    hom-functors are normally defined to be functors into the large category \textbf{Set}
    whose objects are of \emph{all} sets and whose arrows are functions between sets.
    However, in HOL there does not exist a single ``type of all sets'', so the notion of
    the category of \emph{all} sets and functions does not make sense.  To work around this,
    we consider a more general setting consisting of a category @{term C} together with
    a set category @{term S} and a function @{term "\<phi> :: 'c * 'c \<Rightarrow> 'c \<Rightarrow> 's"} such that
    whenever @{term b} and @{term a} are objects of C then @{term "\<phi> (b, a)"} maps
    \<open>C.hom b a\<close> injectively to \<open>S.Univ\<close>.  We show that these data induce
    a binary functor \<open>Hom\<close> from \<open>Cop\<times>C\<close> to @{term S} in such a way that @{term \<phi>}
    is rendered natural in @{term "(b, a)"}.  The Yoneda lemma is then proved for the
    Yoneda functor determined by \<open>Hom\<close>.
\<close>

  section "Hom-Functors"

  text\<open>
    A hom-functor for a category @{term C} allows us to regard the hom-sets of @{term C}
    as objects of a category @{term S} of sets and functions.  Any description of a
    hom-functor for @{term C} must therefore specify the category @{term S} and provide
    some sort of correspondence between arrows of @{term C} and elements of objects of @{term S}.
    If we are to think of each hom-set \<open>C.hom b a\<close> of \<open>C\<close> as corresponding
    to an object \<open>Hom (b, a)\<close> of @{term S} then at a minimum it ought to be the
    case that the correspondence between arrows and elements is bijective between
    \<open>C.hom b a\<close> and \<open>Hom (b, a)\<close>.  The \<open>hom_functor\<close> locale defined
    below captures this idea by assuming a set category @{term S} and a function @{term \<phi>}
    taking arrows of @{term C} to elements of \<open>S.Univ\<close>, such that @{term \<phi>} is injective
    on each set \<open>C.hom b a\<close>.  We show that these data induce a functor \<open>Hom\<close>
    from \<open>Cop\<times>C\<close> to \<open>S\<close> in such a way that @{term \<phi>} becomes a natural
    bijection between \<open>C.hom b a\<close> and \<open>Hom (b, a)\<close>.
\<close>

  locale hom_functor =
    C: category C +
    Cop: dual_category C +
    CopxC: product_category Cop.comp C +
    S: set_category S
  for C :: "'c comp"      (infixr "\<cdot>" 55)
  and S :: "'s comp"      (infixr "\<cdot>\<^sub>S" 55)
  and \<phi> :: "'c * 'c \<Rightarrow> 'c \<Rightarrow> 's" +
  assumes maps_arr_to_Univ: "C.arr f \<Longrightarrow> \<phi> (C.dom f, C.cod f) f \<in> S.Univ"
  and local_inj: "\<lbrakk> C.ide b; C.ide a \<rbrakk> \<Longrightarrow> inj_on (\<phi> (b, a)) (C.hom b a)"
  begin

    notation S.in_hom     ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>S _\<guillemotright>")
    notation CopxC.comp   (infixr "\<odot>" 55)
    notation CopxC.in_hom ("\<guillemotleft>_ : _ \<rightleftharpoons> _\<guillemotright>")

    definition set
    where "set ba \<equiv> \<phi> (fst ba, snd ba) ` C.hom (fst ba) (snd ba)"

    lemma set_subset_Univ:
    assumes "C.ide b" and "C.ide a"
    shows "set (b, a) \<subseteq> S.Univ"
      using assms set_def maps_arr_to_Univ CopxC.ide_char by auto

    definition \<psi> :: "'c * 'c \<Rightarrow> 's \<Rightarrow> 'c"
    where "\<psi> ba = inv_into (C.hom (fst ba) (snd ba)) (\<phi> ba)"

    lemma \<phi>_mapsto:
    assumes "C.ide b" and "C.ide a"
    shows "\<phi> (b, a) \<in> C.hom b a \<rightarrow> set (b, a)"
      using assms set_def maps_arr_to_Univ by auto

    lemma \<psi>_mapsto:
    assumes "C.ide b" and "C.ide a"
    shows "\<psi> (b, a) \<in> set (b, a) \<rightarrow> C.hom b a"
      using assms set_def \<psi>_def local_inj by auto

    lemma \<psi>_\<phi> [simp]:
    assumes "\<guillemotleft>f : b \<rightarrow> a\<guillemotright>"
    shows "\<psi> (b, a) (\<phi> (b, a) f) = f"
      using assms local_inj [of b a] \<psi>_def by fastforce

    lemma \<phi>_\<psi> [simp]:
    assumes "C.ide b" and "C.ide a"
    and "x \<in> set (b, a)"
    shows "\<phi> (b, a) (\<psi> (b, a) x) = x"
      using assms set_def local_inj \<psi>_def by auto

    lemma \<psi>_img_set:
    assumes "C.ide b" and "C.ide a"
    shows "\<psi> (b, a) ` set (b, a) = C.hom b a"
      using assms \<psi>_def set_def local_inj by auto

    text\<open>
      A hom-functor maps each arrow @{term "(g, f)"} of @{term "CopxC"}
      to the arrow of the set category @{term[source=true] S} corresponding to the function
      that takes an arrow @{term h} of @{term C} to the arrow @{term "C f (C h g)"} of @{term C}
      obtained by precomposing with @{term g} and postcomposing with @{term f}.
\<close>

    definition map
    where "map gf =
             (if CopxC.arr gf then
                S.mkArr (set (CopxC.dom gf)) (set (CopxC.cod gf))
                        (\<phi> (CopxC.cod gf) o (\<lambda>h. snd gf \<cdot> h \<cdot> fst gf) o \<psi> (CopxC.dom gf))
              else S.null)"

    lemma arr_map:
    assumes "CopxC.arr gf"
    shows "S.arr (map gf)"
    proof -
      have "\<phi> (CopxC.cod gf) o (\<lambda>h. snd gf \<cdot> h \<cdot> fst gf) o \<psi> (CopxC.dom gf)
              \<in> set (CopxC.dom gf) \<rightarrow> set (CopxC.cod gf)"
        using assms \<phi>_mapsto [of "fst (CopxC.cod gf)" "snd (CopxC.cod gf)"]
              \<psi>_mapsto [of "fst (CopxC.dom gf)" "snd (CopxC.dom gf)"]
        by fastforce
      thus ?thesis
        using assms map_def set_subset_Univ by auto
    qed

    lemma map_ide [simp]:
    assumes "C.ide b" and "C.ide a"
    shows "map (b, a) = S.mkIde (set (b, a))"
    proof -
      have "map (b, a) = S.mkArr (set (b, a)) (set (b, a))
                                 (\<phi> (b, a) o (\<lambda>h. a \<cdot> h \<cdot> b) o \<psi> (b, a))"
        using assms map_def by auto
      also have "... = S.mkArr (set (b, a)) (set (b, a)) (\<lambda>h. h)"
      proof -
        have "S.mkArr (set (b, a)) (set (b, a)) (\<lambda>h. h) = ..."
          using assms S.arr_mkArr set_subset_Univ set_def C.comp_arr_dom C.comp_cod_arr
          by (intro S.mkArr_eqI', simp, fastforce)
        thus ?thesis by auto
      qed
      also have "... = S.mkIde (set (b, a))"
        using assms S.mkIde_as_mkArr set_subset_Univ by simp
      finally show ?thesis by auto
    qed

    lemma set_map:
    assumes "C.ide a" and "C.ide b"
    shows "S.set (map (b, a)) = set (b, a)"
      using assms map_ide S.set_mkIde set_subset_Univ by simp

    text\<open>
      The definition does in fact yield a functor.
\<close>

    interpretation "functor" CopxC.comp S map
    proof
      fix gf
      assume "\<not>CopxC.arr gf"
      thus "map gf = S.null" using map_def by auto
      next
      fix gf
      assume gf: "CopxC.arr gf"
      thus arr: "S.arr (map gf)" using gf arr_map by blast
      show "S.dom (map gf) = map (CopxC.dom gf)"
      proof -
        have "S.dom (map gf) = S.mkArr (set (CopxC.dom gf)) (set (CopxC.dom gf)) (\<lambda>x. x)"
          using gf arr_map map_def by simp
        also have "... = S.mkArr (set (CopxC.dom gf)) (set (CopxC.dom gf))
                                 (\<phi> (CopxC.dom gf) o
                                  (\<lambda>h. snd (CopxC.dom gf) \<cdot> h \<cdot> fst (CopxC.dom gf)) o
                                  \<psi> (CopxC.dom gf))"
          using gf set_subset_Univ \<psi>_mapsto map_def set_def
          apply (intro S.mkArr_eqI', auto)
          by (metis C.comp_arr_dom C.comp_cod_arr C.in_homE)
        also have "... = map (CopxC.dom gf)"
          using gf map_def C.arr_dom_iff_arr C.arr_cod_iff_arr by simp
        finally show ?thesis by auto
      qed
      show "S.cod (map gf) = map (CopxC.cod gf)"
      proof -
        have "S.cod (map gf) = S.mkArr (set (CopxC.cod gf)) (set (CopxC.cod gf)) (\<lambda>x. x)"
          using gf map_def arr_map by simp
        also have "... = S.mkArr (set (CopxC.cod gf)) (set (CopxC.cod gf))
                                 (\<phi> (CopxC.cod gf) o
                                  (\<lambda>h. snd (CopxC.cod gf) \<cdot> h \<cdot> fst (CopxC.cod gf)) o
                                  \<psi> (CopxC.cod gf))"
          using gf set_subset_Univ \<psi>_mapsto map_def set_def
          apply (intro S.mkArr_eqI', auto)
          by (metis C.comp_arr_dom C.comp_cod_arr C.in_homE)
        also have "... = map (CopxC.cod gf)" using gf map_def by simp
        finally show ?thesis by auto
      qed
      next
      fix gf gf'
      assume gf': "CopxC.seq gf' gf"
      hence seq: "C.arr (fst gf) \<and> C.arr (snd gf) \<and> C.dom (snd gf') = C.cod (snd gf) \<and>
                  C.arr (fst gf') \<and> C.arr (snd gf') \<and> C.dom (fst gf) = C.cod (fst gf')"
        by (elim CopxC.seqE C.seqE, auto)
      have 0: "S.arr (map (CopxC.comp gf' gf))"
        using gf' arr_map by blast
      have 1: "map (gf' \<odot> gf) =
                    S.mkArr (set (CopxC.dom gf)) (set (CopxC.cod gf'))
                            (\<phi> (CopxC.cod gf') o (\<lambda>h. snd (gf' \<odot> gf) \<cdot> h \<cdot> fst (gf' \<odot> gf))
                                               o \<psi> (CopxC.dom gf))"
        using gf' map_def using CopxC.cod_comp CopxC.dom_comp by auto
      also have "... = S.mkArr (set (CopxC.dom gf)) (set (CopxC.cod gf'))
                               (\<phi> (CopxC.cod gf') \<circ> (\<lambda>h. snd gf' \<cdot> h \<cdot> fst gf') \<circ> \<psi> (CopxC.dom gf')
                                \<circ>
                               (\<phi> (CopxC.cod gf) \<circ> (\<lambda>h. snd gf \<cdot> h \<cdot> fst gf) \<circ> \<psi> (CopxC.dom gf)))"
      proof (intro S.mkArr_eqI')
        show "S.arr (S.mkArr (set (CopxC.dom gf)) (set (CopxC.cod gf'))
                             (\<phi> (CopxC.cod gf') \<circ> (\<lambda>h. snd (gf' \<odot> gf) \<cdot> h \<cdot> fst (gf' \<odot> gf))
                                                \<circ> \<psi> (CopxC.dom gf)))"
          using 0 1 by simp
        show "\<And>x. x \<in> set (CopxC.dom gf) \<Longrightarrow>
                     (\<phi> (CopxC.cod gf') \<circ> (\<lambda>h. snd (gf' \<odot> gf) \<cdot> h \<cdot> fst (gf' \<odot> gf)) \<circ>
                      \<psi> (CopxC.dom gf)) x =
                     (\<phi> (CopxC.cod gf') \<circ> (\<lambda>h. snd gf' \<cdot> h \<cdot> fst gf') \<circ> \<psi> (CopxC.dom gf') \<circ>
                      (\<phi> (CopxC.cod gf) \<circ> (\<lambda>h. snd gf \<cdot> h \<cdot> fst gf) \<circ> \<psi> (CopxC.dom gf))) x"
        proof -
          fix x
          assume "x \<in> set (CopxC.dom gf)"
          hence x: "x \<in> set (C.cod (fst gf), C.dom (snd gf))"
            using gf' CopxC.seqE by (elim CopxC.seqE, fastforce)
          show "(\<phi> (CopxC.cod gf') \<circ> (\<lambda>h. snd (gf' \<odot> gf) \<cdot> h \<cdot> fst (gf' \<odot> gf)) \<circ>
                 \<psi> (CopxC.dom gf)) x =
                (\<phi> (CopxC.cod gf') \<circ> (\<lambda>h. snd gf' \<cdot> h \<cdot> fst gf') \<circ> \<psi> (CopxC.dom gf') \<circ>
                 (\<phi> (CopxC.cod gf) \<circ> (\<lambda>h. snd gf \<cdot> h \<cdot> fst gf) \<circ> \<psi> (CopxC.dom gf))) x"
          proof -
            have "(\<phi> (CopxC.cod gf') o (\<lambda>h. snd (gf' \<odot> gf) \<cdot> h \<cdot> fst (gf' \<odot> gf))
                                     o \<psi> (CopxC.dom gf)) x =
                  \<phi> (CopxC.cod gf') (snd (gf' \<odot> gf) \<cdot> \<psi> (CopxC.dom gf) x \<cdot> fst (gf' \<odot> gf))"
              by simp
            also have "... = \<phi> (CopxC.cod gf')
                               (((\<lambda>h. snd gf' \<cdot> h \<cdot> fst gf') \<circ> \<psi> (CopxC.dom gf') \<circ>
                                 (\<phi> (CopxC.dom gf') \<circ> (\<lambda>h. snd gf \<cdot> h \<cdot> fst gf)))
                                (\<psi> (CopxC.dom gf) x))"
            proof -
              have "C.ide (C.cod (fst gf)) \<and> C.ide (C.dom (snd gf))"
                using gf' by (elim CopxC.seqE, auto)
              hence "\<guillemotleft>\<psi> (C.cod (fst gf), C.dom (snd gf)) x : C.cod (fst gf) \<rightarrow> C.dom (snd gf)\<guillemotright>"
                using x \<psi>_mapsto by auto
              hence "\<guillemotleft>snd gf \<cdot> \<psi> (C.cod (fst gf), C.dom (snd gf)) x \<cdot> fst gf :
                        C.cod (fst gf') \<rightarrow> C.dom (snd gf')\<guillemotright>"
                using x seq by auto
              thus ?thesis
                using seq \<psi>_\<phi> C.comp_assoc by auto
            qed
            also have "... = (\<phi> (CopxC.cod gf') \<circ> (\<lambda>h. snd gf' \<cdot> h \<cdot> fst gf') \<circ> \<psi> (CopxC.dom gf') \<circ>
                              (\<phi> (CopxC.dom gf') \<circ> (\<lambda>h. snd gf \<cdot> h \<cdot> fst gf) \<circ> \<psi> (CopxC.dom gf)))
                              x"
              by auto
            finally show ?thesis using seq by simp
          qed
        qed
      qed
      also have "... = map gf' \<cdot>\<^sub>S map gf"
        using seq gf' map_def arr_map [of gf] arr_map [of gf'] S.comp_mkArr by auto
      finally show "map (gf' \<odot> gf) = map gf' \<cdot>\<^sub>S map gf"
        using seq gf' by auto
    qed

    interpretation binary_functor Cop.comp C S map ..

    lemma is_binary_functor:
    shows "binary_functor Cop.comp C S map" ..

  end

  sublocale hom_functor \<subseteq> binary_functor Cop.comp C S map
    using is_binary_functor by auto

  context hom_functor
  begin

    text\<open>
      The map @{term \<phi>} determines a bijection between @{term "C.hom b a"} and
      @{term "set (b, a)"} which is natural in @{term "(b, a)"}.
\<close>

    lemma \<phi>_local_bij:
    assumes "C.ide b" and "C.ide a"
    shows "bij_betw (\<phi> (b, a)) (C.hom b a) (set (b, a))"
      using assms local_inj inj_on_imp_bij_betw set_def by auto

    lemma \<phi>_natural:
    assumes "C.arr g" and "C.arr f" and "h \<in> C.hom (C.cod g) (C.dom f)"
    shows "\<phi> (C.dom g, C.cod f) (f \<cdot> h \<cdot> g) = S.Fun (map (g, f)) (\<phi> (C.cod g, C.dom f) h)"
    proof -
      let ?\<phi>h = "\<phi> (C.cod g, C.dom f) h"
      have \<phi>h: "?\<phi>h \<in> set (C.cod g, C.dom f)"
        using assms \<phi>_mapsto set_def by simp
      have gf: "CopxC.arr (g, f)" using assms by simp
      have "map (g, f) =
               S.mkArr (set (C.cod g, C.dom f)) (set (C.dom g, C.cod f))
                       (\<phi> (C.dom g, C.cod f) \<circ> (\<lambda>h. f \<cdot> h \<cdot> g) \<circ> \<psi> (C.cod g, C.dom f))"
        using assms map_def by simp
      moreover have "S.arr (map (g, f))" using gf by simp
      ultimately have
          "S.Fun (map (g, f)) =
               restrict (\<phi> (C.dom g, C.cod f) \<circ> (\<lambda>h. f \<cdot> h \<cdot> g) \<circ> \<psi> (C.cod g, C.dom f))
                        (set (C.cod g, C.dom f))"
        using S.Fun_mkArr by simp
      hence "S.Fun (map (g, f)) ?\<phi>h =
                (\<phi> (C.dom g, C.cod f) \<circ> (\<lambda>h. f \<cdot> h \<cdot> g) \<circ> \<psi> (C.cod g, C.dom f)) ?\<phi>h"
        using \<phi>h by simp
      also have "... = \<phi> (C.dom g, C.cod f) (f \<cdot> h \<cdot> g)"
        using assms(3) by simp
      finally show ?thesis by auto
    qed

    lemma Dom_map:
    assumes "C.arr g" and "C.arr f"
    shows "S.Dom (map (g, f)) = set (C.cod g, C.dom f)"
      using assms map_def preserves_arr by auto

    lemma Fun_map:
    assumes "C.arr g" and "C.arr f"
    shows "S.Fun (map (g, f)) =
             restrict (\<phi> (C.dom g, C.cod f) o (\<lambda>h. f \<cdot> h \<cdot> g) o \<psi> (C.cod g, C.dom f))
                      (set (C.cod g, C.dom f))"
      using assms map_def preserves_arr by force

    lemma map_simp_1:
    assumes "C.arr g" and "C.ide a"
    shows "map (g, a) = S.mkArr (set (C.cod g, a)) (set (C.dom g, a))
                                (\<phi> (C.dom g, a) o Cop.comp g o \<psi> (C.cod g, a))"
    proof -
      have 1: "map (g, a) = S.mkArr (set (C.cod g, a)) (set (C.dom g, a))
                                    (\<phi> (C.dom g, a) o (\<lambda>h. a \<cdot> h \<cdot> g) o \<psi> (C.cod g, a))"
        using assms map_def by force
      also have "... = S.mkArr (set (C.cod g, a)) (set (C.dom g, a))
                               (\<phi> (C.dom g, a) o Cop.comp g o \<psi> (C.cod g, a))"
        using assms 1 preserves_arr [of "(g, a)"] set_def C.in_homI C.comp_cod_arr
        by (intro S.mkArr_eqI, auto)
     finally show ?thesis by auto
    qed

    lemma map_simp_2:
    assumes "C.ide b" and "C.arr f"
    shows "map (b, f) = S.mkArr (set (b, C.dom f)) (set (b, C.cod f))
                                (\<phi> (b, C.cod f) o C f o \<psi> (b, C.dom f))"
    proof -
      have 1: "map (b, f) = S.mkArr (set (b, C.dom f)) (set (b, C.cod f))
                                    (\<phi> (b, C.cod f) o (\<lambda>h. f \<cdot> h \<cdot> b) o \<psi> (b, C.dom f))"
        using assms map_def by force
      also have "... = S.mkArr (set (b, C.dom f)) (set (b, C.cod f))
                               (\<phi> (b, C.cod f) o C f o \<psi> (b, C.dom f))"
        using assms 1 preserves_arr [of "(b, f)"] set_def C.in_homI C.comp_arr_dom
        by (intro S.mkArr_eqI, auto)
      finally show ?thesis by auto
    qed

  end

  text\<open>
    Every category @{term C} has a hom-functor: take @{term S} to be the set category
    \<open>SetCat\<close> generated by the set of arrows of @{term C} and take @{term "\<phi> (b, a)"}
    to be the map \<open>UP :: 'c \<Rightarrow> 'c SetCat.arr\<close>.
\<close>

  context category
  begin

    interpretation Cop: dual_category C ..
    interpretation CopxC: product_category Cop.comp C ..
    interpretation S: set_category \<open>SetCat.comp :: 'a setcat.arr comp\<close>
      using is_set_category by auto
    interpretation Hom: hom_functor C \<open>SetCat.comp :: 'a setcat.arr comp\<close> \<open>\<lambda>_. SetCat.UP\<close>
      apply unfold_locales
      using UP_mapsto apply auto[1]
      using inj_UP injD inj_onI by metis

    lemma has_hom_functor:
    shows "hom_functor C (SetCat.comp :: 'a setcat.arr comp) (\<lambda>_. UP)" ..

  end

  text\<open>
    The locales \<open>set_valued_functor\<close> and \<open>set_valued_transformation\<close> provide some
    abbreviations that are convenient when working with functors and natural transformations
    into a set category.
\<close>

  locale set_valued_functor =
    C: category C +
    S: set_category S +
    "functor" C S F
    for C :: "'c comp"
    and S :: "'s comp"
    and F :: "'c \<Rightarrow> 's"
  begin

    abbreviation SET :: "'c \<Rightarrow> 's set"
    where "SET a \<equiv> S.set (F a)"

    abbreviation DOM :: "'c \<Rightarrow> 's set"
    where "DOM f \<equiv> S.Dom (F f)"

    abbreviation COD :: "'c \<Rightarrow> 's set"
    where "COD f \<equiv> S.Cod (F f)"

    abbreviation FUN :: "'c \<Rightarrow> 's \<Rightarrow> 's"
    where "FUN f \<equiv> S.Fun (F f)"

  end

  locale set_valued_transformation =
    C: category C +
    S: set_category S +
    F: set_valued_functor C S F +
    G: set_valued_functor C S G +
    natural_transformation C S F G \<tau>
  for C :: "'c comp"
  and S :: "'s comp"
  and F :: "'c \<Rightarrow> 's"
  and G :: "'c \<Rightarrow> 's"
  and \<tau> :: "'c \<Rightarrow> 's"
  begin

    abbreviation DOM :: "'c \<Rightarrow> 's set"
    where "DOM f \<equiv> S.Dom (\<tau> f)"

    abbreviation COD :: "'c \<Rightarrow> 's set"
    where "COD f \<equiv> S.Cod (\<tau> f)"

    abbreviation FUN :: "'c \<Rightarrow> 's \<Rightarrow> 's"
    where "FUN f \<equiv> S.Fun (\<tau> f)"

  end

  section "Yoneda Functors"

  text\<open>
    A Yoneda functor is the functor from @{term C} to \<open>[Cop, S]\<close> obtained by ``currying''
    a hom-functor in its first argument.
\<close>

  locale yoneda_functor =
    C: category C +
    Cop: dual_category C +
    CopxC: product_category Cop.comp C +
    S: set_category S +
    Hom: hom_functor C S \<phi> +
    Cop_S: functor_category Cop.comp S +
    curried_functor' Cop.comp C S Hom.map
  for C :: "'c comp"      (infixr "\<cdot>" 55)
  and S :: "'s comp"      (infixr "\<cdot>\<^sub>S" 55)
  and \<phi> :: "'c * 'c \<Rightarrow> 'c \<Rightarrow> 's"
  begin

    notation Cop_S.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>[\<^sub>C\<^sub>o\<^sub>p\<^sub>,\<^sub>S\<^sub>] _\<guillemotright>")

    abbreviation \<psi>
    where "\<psi> \<equiv> Hom.\<psi>"

    text\<open>
      An arrow of the functor category \<open>[Cop, S]\<close> consists of a natural transformation
      bundled together with its domain and codomain functors.  However, when considering
      a Yoneda functor from @{term[source=true] C} to \<open>[Cop, S]\<close> we generally are only
      interested in the mapping @{term Y} that takes each arrow @{term f} of @{term[source=true] C}
      to the corresponding natural transformation @{term "Y f"}.  The domain and codomain functors
      are then the identity transformations @{term "Y (C.dom f)"} and @{term "Y (C.cod f)"}.
\<close>

    definition Y
    where "Y f \<equiv> Cop_S.Map (map f)"

    lemma Y_simp [simp]:
    assumes "C.arr f"
    shows "Y f = (\<lambda>g. Hom.map (g, f))"
      using assms preserves_arr Y_def by simp

    lemma Y_ide_is_functor:
    assumes "C.ide a"
    shows "functor Cop.comp S (Y a)"
      using assms Y_def Hom.fixing_ide_gives_functor_2 by force

    lemma Y_arr_is_transformation:
    assumes "C.arr f"
    shows "natural_transformation Cop.comp S (Y (C.dom f)) (Y (C.cod f)) (Y f)"
      using assms Y_def [of f] map_def Hom.fixing_arr_gives_natural_transformation_2
            preserves_dom preserves_cod by fastforce

    lemma Y_ide_arr [simp]:
    assumes a: "C.ide a" and "\<guillemotleft>g : b' \<rightarrow> b\<guillemotright>"
    shows "\<guillemotleft>Y a g : Hom.map (b, a) \<rightarrow>\<^sub>S Hom.map (b', a)\<guillemotright>"
    and "Y a g =
         S.mkArr (Hom.set (b, a)) (Hom.set (b', a)) (\<phi> (b', a) o Cop.comp g o \<psi> (b, a))"
      using assms Hom.map_simp_1 by (fastforce, auto)

    lemma Y_arr_ide [simp]:
    assumes "C.ide b" and "\<guillemotleft>f : a \<rightarrow> a'\<guillemotright>"
    shows "\<guillemotleft>Y f b : Hom.map (b, a) \<rightarrow>\<^sub>S Hom.map (b, a')\<guillemotright>"
    and "Y f b = S.mkArr (Hom.set (b, a)) (Hom.set (b, a')) (\<phi> (b, a') o C f o \<psi> (b, a))"
      using assms apply fastforce
      using assms Hom.map_simp_2 by auto

  end

  locale yoneda_functor_fixed_object =
    yoneda_functor C S \<phi>
  for C :: "'c comp" (infixr "\<cdot>" 55)
  and S :: "'s comp" (infixr "\<cdot>\<^sub>S" 55)
  and \<phi> :: "'c * 'c \<Rightarrow> 'c \<Rightarrow> 's"
  and a :: 'c +
  assumes ide_a: "C.ide a"

  sublocale yoneda_functor_fixed_object \<subseteq> "functor" Cop.comp S "(Y a)"
    using ide_a Y_ide_is_functor by auto
  sublocale yoneda_functor_fixed_object \<subseteq> set_valued_functor Cop.comp S "(Y a)" ..

  text\<open>
    The Yoneda lemma states that, given a category @{term C} and a functor @{term F}
    from @{term Cop} to a set category @{term S}, for each object @{term a} of @{term C},
    the set of natural transformations from the contravariant functor @{term "Y a"}
    to @{term F} is in bijective correspondence with the set \<open>F.SET a\<close>
    of elements of @{term "F a"}.

    Explicitly, if @{term e} is an arbitrary element of the set \<open>F.SET a\<close>,
    then the functions \<open>\<lambda>x. F.FUN (\<psi> (b, a) x) e\<close> are the components of a
    natural transformation from @{term "Y a"} to @{term F}.
    Conversely, if @{term \<tau>} is a natural transformation from @{term "Y a"} to @{term F},
    then the component @{term "\<tau> b"} of @{term \<tau>} at an arbitrary object @{term b}
    is completely determined by the single arrow \<open>\<tau>.FUN a (\<phi> (a, a) a)))\<close>,
    which is the the element of \<open>F.SET a\<close> that corresponds to the image of the
    identity @{term a} under the function \<open>\<tau>.FUN a\<close>.
    Then @{term "\<tau> b"} is the arrow from @{term "Y a b"} to @{term "F b"} corresponding
    to the function \<open>\<lambda>x. (F.FUN (\<psi> (b, a) x) (\<tau>.FUN a (\<phi> (a, a) a)))\<close>
    from \<open>S.set (Y a b)\<close> to \<open>F.SET b\<close>.

    The above expressions look somewhat more complicated than the usual versions due to the
    need to account for the coercions @{term \<phi>} and @{term \<psi>}.
\<close>

  locale yoneda_lemma =
    C: category C +
    Cop: dual_category C +
    S: set_category S +
    F: set_valued_functor Cop.comp S F +
    yoneda_functor_fixed_object C S \<phi> a
  for C :: "'c comp" (infixr "\<cdot>" 55)
  and S :: "'s comp" (infixr "\<cdot>\<^sub>S" 55)
  and \<phi> :: "'c * 'c \<Rightarrow> 'c \<Rightarrow> 's"
  and F :: "'c \<Rightarrow> 's"
  and a :: 'c
  begin

    text\<open>
      The mapping that evaluates the component @{term "\<tau> a"} at @{term a} of a
      natural transformation @{term \<tau>} from @{term Y} to @{term F} on the element
      @{term "\<phi> (a, a) a"} of @{term "SET a"}, yielding an element of @{term "F.SET a"}.
\<close>

    definition \<E> :: "('c \<Rightarrow> 's) \<Rightarrow> 's"
    where "\<E> \<tau> = S.Fun (\<tau> a) (\<phi> (a, a) a)"

    text\<open>
      The mapping that takes an element @{term e} of @{term "F.SET a"} and produces
      a map on objects of @{term[source=true] C} whose value at @{term b} is the arrow of
      @{term[source=true] S} corresponding to the function
      @{term "(\<lambda>x. F.FUN (\<psi> (b, a) x) e) \<in> Hom.set (b, a) \<rightarrow> F.SET b"}.
\<close>

    definition \<T>o :: "'s \<Rightarrow> 'c \<Rightarrow> 's"
    where "\<T>o e b = S.mkArr (Hom.set (b, a)) (F.SET b) (\<lambda>x. F.FUN (\<psi> (b, a) x) e)"

    lemma \<T>o_e_ide:
    assumes e: "e \<in> S.set (F a)" and b: "C.ide b"
    shows "\<guillemotleft>\<T>o e b : Y a b \<rightarrow>\<^sub>S F b\<guillemotright>"
    and "\<T>o e b = S.mkArr (Hom.set (b, a)) (F.SET b) (\<lambda>x. F.FUN (\<psi> (b, a) x) e)"
    proof -
      show "\<T>o e b = S.mkArr (Hom.set (b, a)) (F.SET b) (\<lambda>x. F.FUN (\<psi> (b, a) x) e)"
        using \<T>o_def by auto
      moreover have "(\<lambda>x. F.FUN (\<psi> (b, a) x) e) \<in> Hom.set (b, a) \<rightarrow> F.SET b"
      proof
        fix x
        assume x: "x \<in> Hom.set (b, a)"
        hence "\<guillemotleft>\<psi> (b, a) x : b \<rightarrow> a\<guillemotright>" using assms ide_a Hom.\<psi>_mapsto by auto
        hence "F.FUN (\<psi> (b, a) x) \<in> F.SET a \<rightarrow> F.SET b"
          using S.Fun_mapsto [of "F (\<psi> (b, a) x)"] by fastforce
        thus "F.FUN (\<psi> (b, a) x) e \<in> F.SET b" using e by auto
      qed
      ultimately show "\<guillemotleft>\<T>o e b : Y a b \<rightarrow>\<^sub>S F b\<guillemotright>"
        using ide_a b S.mkArr_in_hom [of "Hom.set (b, a)" "F.SET b"] Hom.set_subset_Univ
        by auto
    qed

    text\<open>
      For each @{term "e \<in> F.SET a"}, the mapping @{term "\<T>o e"} gives the components
      of a natural transformation @{term \<T>} from @{term "Y a"} to @{term F}.
\<close>

    lemma \<T>o_e_induces_transformation:
    assumes e: "e \<in> S.set (F a)"
    shows "transformation_by_components Cop.comp S (Y a) F (\<T>o e)"
    proof
      fix b :: 'c
      assume b: "Cop.ide b"
      show "\<guillemotleft>\<T>o e b : Y a b \<rightarrow>\<^sub>S F b\<guillemotright>"
        using ide_a b e \<T>o_e_ide by simp
      next
      fix g :: 'c
      assume g: "Cop.arr g"
      let ?b = "Cop.dom g"
      let ?b' = "Cop.cod g"
      show "\<T>o e (Cop.cod g) \<cdot>\<^sub>S Y a g = F g \<cdot>\<^sub>S \<T>o e (Cop.dom g)"
      proof -
        have 1: "\<T>o e (Cop.cod g) \<cdot>\<^sub>S Y a g
                   = S.mkArr (Hom.set (?b, a)) (F.SET ?b')
                             ((\<lambda>x. F.FUN (\<psi> (?b', a) x) e)
                                o (\<phi> (?b', a) o Cop.comp g o \<psi> (?b, a)))"
        proof -
          have "S.arr (S.mkArr (Hom.set (Cop.cod g, a)) (F.SET (Cop.cod g))
                      (\<lambda>s. F.FUN (\<psi> (Cop.cod g, a) s) e)) \<and>
                S.dom (S.mkArr (Hom.set (Cop.cod g, a)) (F.SET (Cop.cod g))
                      (\<lambda>s. F.FUN (\<psi> (Cop.cod g, a) s) e)) = Y a (Cop.cod g) \<and>
                S.cod (S.mkArr (Hom.set (Cop.cod g, a)) (F.SET (Cop.cod g))
                      (\<lambda>s. F.FUN (\<psi> (Cop.cod g, a) s) e)) = F (Cop.cod g)"
            using Cop.cod_char \<T>o_e_ide [of e ?b'] \<T>o_e_ide [of e ?b'] e g by force
          moreover have "Y a g = S.mkArr (Hom.set (Cop.dom g, a)) (Hom.set (Cop.cod g, a))
                                         (\<phi> (Cop.cod g, a) \<circ> Cop.comp g \<circ> \<psi> (Cop.dom g, a))"
            using Y_ide_arr [of a g ?b' ?b] ide_a g by auto
          ultimately show ?thesis
            using ide_a e g Y_ide_arr Cop.cod_char \<T>o_e_ide
                  S.comp_mkArr [of "Hom.set (?b, a)" "Hom.set (?b', a)"
                                   "\<phi> (?b', a) o Cop.comp g o \<psi> (?b, a)"
                                   "F.SET ?b'" "\<lambda>x. F.FUN (\<psi> (?b', a) x) e"]
            by (metis C.ide_dom Cop.arr_char preserves_arr)
        qed
        also have "... = S.mkArr (Hom.set (?b, a)) (F.SET ?b')
                                 (F.FUN g o (\<lambda>x. F.FUN (\<psi> (?b, a) x) e))"
        proof (intro S.mkArr_eqI')
          have "(\<lambda>x. F.FUN (\<psi> (?b', a) x) e)
                   o (\<phi> (?b', a) o Cop.comp g o \<psi> (?b, a)) \<in> Hom.set (?b, a) \<rightarrow> F.SET ?b'"
          proof -
            have "S.arr (S (\<T>o e ?b') (Y a g))"
              using ide_a e g \<T>o_e_ide [of e ?b'] Y_ide_arr(1) [of a "C.dom g" "C.cod g" g]
              by auto
            thus ?thesis using 1 by simp
          qed
          thus "S.arr (S.mkArr (Hom.set (?b, a)) (F.SET ?b')
                               ((\<lambda>x. F.FUN (\<psi> (?b', a) x) e)
                                  o (\<phi> (?b', a) o Cop.comp g o \<psi> (?b, a))))"
            using ide_a e g Hom.set_subset_Univ by simp
          show "\<And>x. x \<in> Hom.set (?b, a) \<Longrightarrow>
                        ((\<lambda>x. F.FUN (\<psi> (?b', a) x) e) o (\<phi> (?b', a) o Cop.comp g o \<psi> (?b, a))) x
                        = (F.FUN g o (\<lambda>x. F.FUN (\<psi> (?b, a) x) e)) x"
          proof -
            fix x
            assume x: "x \<in> Hom.set (?b, a)"
            have "((\<lambda>x. (F.FUN o \<psi> (?b', a)) x e)
                       o (\<phi> (?b', a) o Cop.comp g o \<psi> (?b, a))) x
                    = F.FUN (\<psi> (?b', a) (\<phi> (?b', a) (C (\<psi> (?b, a) x) g))) e"
              by simp
            also have "... = (F.FUN g o (F.FUN o \<psi> (?b, a)) x) e"
            proof -
              have 1: "\<guillemotleft>\<psi> (Cop.dom g, a) x : Cop.dom g \<rightarrow> a\<guillemotright>"
                using ide_a x g Hom.\<psi>_mapsto [of ?b a] by auto
              moreover have "S.seq (F g) (F (\<psi> (C.cod g, a) x))"
                using 1 g by (intro S.seqI', auto)
              moreover have "\<psi> (C.dom g, a) (\<phi> (C.dom g, a) (C (\<psi> (C.cod g, a) x) g)) =
                             C (\<psi> (C.cod g, a) x) g"
                using g 1 Hom.\<psi>_\<phi> [of "C (\<psi> (?b, a) x) g" ?b' a] by fastforce
              ultimately show ?thesis
                using assms F.preserves_comp by fastforce
            qed
            also have "... = (F.FUN g o (\<lambda>x. F.FUN (\<psi> (?b, a) x) e)) x" by fastforce
            finally show "((\<lambda>x. F.FUN (\<psi> (?b', a) x) e)
                             o (\<phi> (?b', a) o Cop.comp g o \<psi> (?b, a))) x
                            = (F.FUN g o (\<lambda>x. F.FUN (\<psi> (?b, a) x) e)) x"
              by simp
          qed
        qed
        also have "... = F g \<cdot>\<^sub>S \<T>o e (Cop.dom g)"
        proof -
          have "S.arr (F g) \<and> F g = S.mkArr (F.SET ?b) (F.SET ?b') (F.FUN g)"
            using g S.mkArr_Fun [of "F g"] by simp
          moreover have
              "S.arr (\<T>o e ?b) \<and>
               \<T>o e ?b = S.mkArr (Hom.set (?b, a)) (F.SET ?b) (\<lambda>x. F.FUN (\<psi> (?b, a) x) e)"
            using e g \<T>o_e_ide
            by (metis C.ide_cod Cop.arr_char Cop.dom_char S.in_homE)
          ultimately show ?thesis
            using S.comp_mkArr [of "Hom.set (?b, a)" "F.SET ?b" "\<lambda>x. F.FUN (\<psi> (?b, a) x) e"
                                   "F.SET ?b'" "F.FUN g"]
            by metis
        qed
        finally show ?thesis by blast
      qed
    qed

    abbreviation \<T> :: "'s \<Rightarrow> 'c \<Rightarrow> 's"
    where "\<T> e \<equiv> transformation_by_components.map Cop.comp S (Y a) (\<T>o e)"

  end

  locale yoneda_lemma_fixed_e =
    yoneda_lemma C S \<phi> F a
  for C :: "'c comp" (infixr "\<cdot>" 55)
  and S :: "'s comp" (infixr "\<cdot>\<^sub>S" 55)
  and \<phi> :: "'c * 'c \<Rightarrow> 'c \<Rightarrow> 's"
  and F :: "'c \<Rightarrow> 's"
  and a :: 'c
  and e :: 's +
  assumes E: "e \<in> F.SET a"
  begin

    interpretation \<T>e: transformation_by_components Cop.comp S \<open>Y a\<close> F \<open>\<T>o e\<close>
      using E \<T>o_e_induces_transformation by auto

    lemma natural_transformation_\<T>e:
    shows "natural_transformation Cop.comp S (Y a) F (\<T> e)" ..

    lemma \<T>e_ide:
    assumes "Cop.ide b"
    shows "S.arr (\<T> e b)"
    and "\<T> e b = S.mkArr (Hom.set (b, a)) (F.SET b) (\<lambda>x. F.FUN (\<psi> (b, a) x) e)"
      using assms apply fastforce
      using assms \<T>o_def by auto

  end

  locale yoneda_lemma_fixed_\<tau> =
    yoneda_lemma C S \<phi> F a +
    \<tau>: set_valued_transformation Cop.comp S "Y a" F \<tau>
  for C :: "'c comp" (infixr "\<cdot>" 55)
  and S :: "'s comp" (infixr "\<cdot>\<^sub>S" 55)
  and \<phi> :: "'c * 'c \<Rightarrow> 'c \<Rightarrow> 's"
  and F :: "'c \<Rightarrow> 's"
  and a :: 'c
  and \<tau> :: "'c \<Rightarrow> 's"
  begin

    text\<open>
      The key lemma: The component @{term "\<tau> b"} of @{term \<tau>} at an arbitrary object @{term b}
      is completely determined by the single element @{term "\<tau>.FUN a (\<phi> (a, a) a) \<in> F.SET a"}.
\<close>

    text\<open>
      Consequently, if @{term \<tau>'} is any natural transformation from @{term "Y a"} to @{term F}
      that agrees with @{term \<tau>} at @{term a}, then @{term "\<tau>' = \<tau>"}.
\<close>

    lemma eqI:
    assumes "natural_transformation Cop.comp S (Y a) F \<tau>'" and "\<tau>' a = \<tau> a"
    shows "\<tau>' = \<tau>"
    proof (intro NaturalTransformation.eqI)
      interpret \<tau>': natural_transformation Cop.comp S \<open>Y a\<close> F \<tau>' using assms by auto
      interpret T': yoneda_lemma_fixed_\<tau> C S \<phi> F a \<tau>' ..
      show "natural_transformation Cop.comp S (Y a) F \<tau>" ..
      show "natural_transformation Cop.comp S (Y a) F \<tau>'" ..
      show "\<And>b. Cop.ide b \<Longrightarrow> \<tau>' b = \<tau> b"
        using assms(2) \<tau>_ide T'.\<tau>_ide by simp
    qed

  end

  context yoneda_lemma
  begin

    text\<open>
      One half of the Yoneda lemma:
      The mapping @{term \<T>} is an injection, with left inverse @{term \<E>},
      from the set @{term "F.SET a"} to the set of natural transformations from
      @{term "Y a"} to @{term F}.
\<close>

    lemma \<T>_is_injection:
    assumes "e \<in> F.SET a"
    shows "natural_transformation Cop.comp S (Y a) F (\<T> e)" and "\<E> (\<T> e) = e"
    proof -
      interpret yoneda_lemma_fixed_e C S \<phi> F a e
        using assms by (unfold_locales, auto)
      interpret \<T>e: natural_transformation Cop.comp S \<open>Y a\<close> F \<open>\<T> e\<close>
        using natural_transformation_\<T>e by auto
      show "natural_transformation Cop.comp S (Y a) F (\<T> e)" ..
      show "\<E> (\<T> e) = e"
        unfolding \<E>_def
        using assms \<T>e_ide S.Fun_mkArr Hom.\<phi>_mapsto Hom.\<psi>_\<phi> ide_a
              F.preserves_ide S.Fun_ide restrict_apply C.ide_in_hom
        by (auto simp add: Pi_iff)
    qed

    lemma \<E>\<tau>_in_Fa:
    assumes "natural_transformation Cop.comp S (Y a) F \<tau>"
    shows "\<E> \<tau> \<in> F.SET a"
    proof -
      interpret \<tau>: natural_transformation Cop.comp S \<open>Y a\<close> F \<tau> using assms by auto
      interpret yoneda_lemma_fixed_\<tau> C S \<phi> F a \<tau> ..
      show ?thesis
      proof (unfold \<E>_def)
        have "S.arr (\<tau> a) \<and> S.Dom (\<tau> a) = Hom.set (a, a) \<and> S.Cod (\<tau> a) = F.SET a"
          using ide_a Hom.set_map by auto
        hence "\<tau>.FUN a \<in> Hom.set (a, a) \<rightarrow> F.SET a"
          using S.Fun_mapsto by blast
        thus "\<tau>.FUN a (\<phi> (a, a) a) \<in> F.SET a"
          using ide_a Hom.\<phi>_mapsto by fastforce
      qed
    qed

    text\<open>
      The other half of the Yoneda lemma:
      The mapping @{term \<T>} is a surjection, with right inverse @{term \<E>},
      taking natural transformations from @{term "Y a"} to @{term F}
      to elements of @{term "F.SET a"}.
\<close>

    lemma \<T>_is_surjection:
    assumes "natural_transformation Cop.comp S (Y a) F \<tau>"
    shows "\<E> \<tau> \<in> F.SET a" and "\<T> (\<E> \<tau>) = \<tau>"
    proof -
      interpret natural_transformation Cop.comp S \<open>Y a\<close> F \<tau> using assms by auto
      interpret yoneda_lemma_fixed_\<tau> C S \<phi> F a \<tau> ..
      show 1: "\<E> \<tau> \<in> F.SET a" using assms \<E>\<tau>_in_Fa by auto
      interpret yoneda_lemma_fixed_e C S \<phi> F a \<open>\<E> \<tau>\<close>
        using 1 by (unfold_locales, auto)
      interpret \<T>e: natural_transformation Cop.comp S \<open>Y a\<close> F \<open>\<T> (\<E> \<tau>)\<close>
        using natural_transformation_\<T>e by auto
      show "\<T> (\<E> \<tau>) = \<tau>"
      proof (intro eqI)
        show "natural_transformation Cop.comp S (Y a) F (\<T> (\<E> \<tau>))" ..
        show "\<T> (\<E> \<tau>) a = \<tau> a"
          using ide_a \<tau>_ide [of a] \<T>e_ide \<E>_def by simp
      qed
    qed

    text\<open>
      The main result.
\<close>

    theorem yoneda_lemma:
    shows "bij_betw \<T> (F.SET a) {\<tau>. natural_transformation Cop.comp S (Y a) F \<tau>}"
      using \<T>_is_injection \<T>_is_surjection by (intro bij_betwI, auto)

  end

  text\<open>
    We now consider the special case in which @{term F} is the contravariant
    functor @{term "Y a'"}.  Then for any @{term e} in \<open>Hom.set (a, a')\<close>
    we have @{term "\<T> e = Y (\<psi> (a, a') e)"}, and @{term \<T>} is a bijection from
    \<open>Hom.set (a, a')\<close> to the set of natural transformations from @{term "Y a"}
    to @{term "Y a'"}.  It then follows that that the Yoneda functor @{term Y}
    is a fully faithful functor from @{term C} to the functor category \<open>[Cop, S]\<close>.
\<close>

  locale yoneda_lemma_for_hom =
    C: category C +
    Cop: dual_category C +
    S: set_category S +
    yoneda_functor_fixed_object C S \<phi> a +
    Ya': yoneda_functor_fixed_object C S \<phi> a' +
    yoneda_lemma C S \<phi> "Y a'" a
  for C :: "'c comp" (infixr "\<cdot>" 55)
  and S :: "'s comp" (infixr "\<cdot>\<^sub>S" 55)
  and \<phi> :: "'c * 'c \<Rightarrow> 'c \<Rightarrow> 's"
  and F :: "'c \<Rightarrow> 's"
  and a :: 'c
  and a' :: 'c +
  assumes ide_a': "C.ide a'"
  begin

    text\<open>
      In case @{term F} is the functor @{term "Y a'"}, for any @{term "e \<in> Hom.set (a, a')"}
      the induced natural transformation @{term "\<T> e"} from @{term "Y a"} to @{term "Y a'"}
      is just @{term "Y (\<psi> (a, a') e)"}.
\<close>

    lemma \<T>_equals_Yo\<psi>:
    assumes e: "e \<in> Hom.set (a, a')"
    shows "\<T> e = Y (\<psi> (a, a') e)"
    proof -
      let ?\<psi>e = "\<psi> (a, a') e"
      have \<psi>e: "\<guillemotleft>?\<psi>e : a \<rightarrow> a'\<guillemotright>" using ide_a ide_a' e Hom.\<psi>_mapsto [of a a'] by auto
      interpret Ye: natural_transformation Cop.comp S \<open>Y a\<close> \<open>Y a'\<close> \<open>Y ?\<psi>e\<close>
        using Y_arr_is_transformation [of ?\<psi>e] \<psi>e by (elim C.in_homE, auto)
      interpret yoneda_lemma_fixed_e C S \<phi> \<open>Y a'\<close> a e
        using ide_a ide_a' e S.set_mkIde Hom.set_map
        by (unfold_locales, simp_all)
      interpret \<T>e: natural_transformation Cop.comp S \<open>Y a\<close> \<open>Y a'\<close> \<open>\<T> e\<close>
        using natural_transformation_\<T>e by auto
      interpret yoneda_lemma_fixed_\<tau> C S \<phi> \<open>Y a'\<close> a \<open>\<T> e\<close> ..
      have "natural_transformation Cop.comp S (Y a) (Y a') (Y ?\<psi>e)" ..
      moreover have "natural_transformation Cop.comp S (Y a) (Y a') (\<T> e)" ..
      moreover have "\<T> e a = Y ?\<psi>e a"
      proof -
        have 1: "S.arr (\<T> e a)"
          using ide_a e \<T>e.preserves_reflects_arr by simp
        have 2: "\<T> e a = S.mkArr (Hom.set (a, a)) (Ya'.SET a) (\<lambda>x. Ya'.FUN (\<psi> (a, a) x) e)"
          using ide_a \<T>o_def \<T>e_ide by simp
        also have
            "... = S.mkArr (Hom.set (a, a)) (Hom.set (a, a')) (\<phi> (a, a') o C ?\<psi>e o \<psi> (a, a))"
        proof (intro S.mkArr_eqI)
          show "S.arr (S.mkArr (Hom.set (a, a)) (Ya'.SET a) (\<lambda>x. Ya'.FUN (\<psi> (a, a) x) e))"
            using ide_a e 1 2 by simp
          show "Hom.set (a, a) = Hom.set (a, a)" ..
          show 3: "Ya'.SET a = Hom.set (a, a')"
            using ide_a ide_a' Y_simp Hom.set_map by simp
          show "\<And>x. x \<in> Hom.set (a, a) \<Longrightarrow>
                      Ya'.FUN (\<psi> (a, a) x) e = (\<phi> (a, a') o C ?\<psi>e o \<psi> (a, a)) x"
          proof -
            fix x
            assume x: "x \<in> Hom.set (a, a)"
            have \<psi>x: "\<guillemotleft>\<psi> (a, a) x : a \<rightarrow> a\<guillemotright>" using ide_a x Hom.\<psi>_mapsto [of a a] by auto
            have "S.arr (Y a' (\<psi> (a, a) x)) \<and>
                  Y a' (\<psi> (a, a) x) = S.mkArr (Hom.set (a, a')) (Hom.set (a, a'))
                                              (\<phi> (a, a') \<circ> Cop.comp (\<psi> (a, a) x) \<circ> \<psi> (a, a'))"
              using Y_ide_arr ide_a ide_a' \<psi>x by blast
            hence "Ya'.FUN (\<psi> (a, a) x) e = (\<phi> (a, a') \<circ> Cop.comp (\<psi> (a, a) x) \<circ> \<psi> (a, a')) e"
              using e 3 S.Fun_mkArr Ya'.preserves_reflects_arr [of "\<psi> (a, a) x"] by simp
            also have "... = (\<phi> (a, a') o C ?\<psi>e o \<psi> (a, a)) x" by simp
            finally show "Ya'.FUN (\<psi> (a, a) x) e = (\<phi> (a, a') o C ?\<psi>e o \<psi> (a, a)) x" by auto
          qed
        qed
        also have "... = Y ?\<psi>e a"
          using ide_a ide_a' Y_arr_ide \<psi>e by simp
        finally show "\<T> e a = Y ?\<psi>e a" by auto
      qed
      ultimately show ?thesis using eqI by auto
    qed

    lemma Y_injective_on_homs:
    assumes "\<guillemotleft>f : a \<rightarrow> a'\<guillemotright>" and "\<guillemotleft>f' : a \<rightarrow> a'\<guillemotright>" and "map f = map f'"
    shows "f = f'"
    proof -
      have "f = \<psi> (a, a') (\<phi> (a, a') f)"
        using assms ide_a Hom.\<psi>_\<phi> by simp
      also have "... = \<psi> (a, a') (\<E> (\<T> (\<phi> (a, a') f)))"
        using ide_a ide_a' assms(1) \<T>_is_injection Hom.\<phi>_mapsto Hom.set_map
        by (elim C.in_homE, simp add: Pi_iff)
      also have "... = \<psi> (a, a') (\<E> (Y (\<psi> (a, a') (\<phi> (a, a') f))))"
        using assms Hom.\<phi>_mapsto [of a a'] \<T>_equals_Yo\<psi> [of "\<phi> (a, a') f"] by force
      also have "... = \<psi> (a, a') (\<E> (\<T> (\<phi> (a, a') f')))"
        using assms Hom.\<phi>_mapsto [of a a'] ide_a Hom.\<psi>_\<phi> Y_def
              \<T>_equals_Yo\<psi> [of "\<phi> (a, a') f'"]
        by fastforce
      also have "... = \<psi> (a, a') (\<phi> (a, a') f')"
        using ide_a ide_a' assms(2) \<T>_is_injection Hom.\<phi>_mapsto Hom.set_map
        by (elim C.in_homE, simp add: Pi_iff)
      also have "... = f'"
        using assms ide_a Hom.\<psi>_\<phi> by simp
      finally show "f = f'" by auto
    qed

    lemma Y_surjective_on_homs:
    assumes \<tau>: "natural_transformation Cop.comp S (Y a) (Y a') \<tau>"
    shows "Y (\<psi> (a, a') (\<E> \<tau>)) = \<tau>"
      using ide_a ide_a' \<tau> \<T>_is_surjection \<T>_equals_Yo\<psi> \<E>\<tau>_in_Fa Hom.set_map by simp

  end

  context yoneda_functor
  begin

    lemma is_faithful_functor:
    shows "faithful_functor C Cop_S.comp map"
    proof
      fix f :: 'c and f' :: 'c
      assume par: "C.par f f'" and ff': "map f = map f'"
      show "f = f'"
      proof -
        interpret Ya': yoneda_functor_fixed_object C S \<phi> \<open>C.cod f\<close>
          using par by (unfold_locales, auto)
        interpret yoneda_lemma_for_hom C S \<phi> \<open>Y (C.cod f)\<close> \<open>C.dom f\<close> \<open>C.cod f\<close>
          using par by (unfold_locales, auto)
        show "f = f'" using par ff' Y_injective_on_homs [of f f'] by fastforce
      qed
    qed

    lemma is_full_functor:
    shows "full_functor C Cop_S.comp map"
    proof
      fix a :: 'c and a' :: 'c and t
      assume a: "C.ide a" and a': "C.ide a'"
      assume t: "\<guillemotleft>t : map a \<rightarrow>\<^sub>[\<^sub>C\<^sub>o\<^sub>p\<^sub>,\<^sub>S\<^sub>] map a'\<guillemotright>"
      show "\<exists>e. \<guillemotleft>e : a \<rightarrow> a'\<guillemotright> \<and> map e = t"
      proof
        interpret Ya': yoneda_functor_fixed_object C S \<phi> a'
          using a' by (unfold_locales, auto)
        interpret yoneda_lemma_for_hom C S \<phi> \<open>Y a'\<close> a a'
          using a a' by (unfold_locales, auto)
        have NT: "natural_transformation Cop.comp S (Y a) (Y a') (Cop_S.Map t)"
          using t a' Y_def Cop_S.Map_dom Cop_S.Map_cod Cop_S.dom_char Cop_S.cod_char
                Cop_S.in_homE Cop_S.arrE
          by metis
        hence 1: "\<E> (Cop_S.Map t) \<in> Hom.set (a, a')"
          using \<E>\<tau>_in_Fa ide_a ide_a' Hom.set_map by simp
        moreover have "map (\<psi> (a, a') (\<E> (Cop_S.Map t))) = t"
        proof (intro Cop_S.arr_eqI)
          have 2: "\<guillemotleft>map (\<psi> (a, a') (\<E> (Cop_S.Map t))) : map a \<rightarrow>\<^sub>[\<^sub>C\<^sub>o\<^sub>p\<^sub>,\<^sub>S\<^sub>] map a'\<guillemotright>"
            using 1 ide_a ide_a' Hom.\<psi>_mapsto [of a a'] by blast
          show "Cop_S.arr t" using t by blast
          show "Cop_S.arr (map (\<psi> (a, a') (\<E> (Cop_S.Map t))))" using 2 by blast
          show 3: "Cop_S.Map (map (\<psi> (a, a') (\<E> (Cop_S.Map t)))) = Cop_S.Map t"
            using NT Y_surjective_on_homs Y_def by simp
          show 4: "Cop_S.Dom (map (\<psi> (a, a') (\<E> (Cop_S.Map t)))) = Cop_S.Dom t"
            using t 2 natural_transformation_axioms Cop_S.Map_dom by (metis Cop_S.in_homE)
          show "Cop_S.Cod (map (\<psi> (a, a') (\<E> (Cop_S.Map t)))) = Cop_S.Cod t"
            using 2 3 4 t Cop_S.Map_cod by (metis Cop_S.in_homE)
        qed
        ultimately show "\<guillemotleft>\<psi> (a, a') (\<E> (Cop_S.Map t)) : a \<rightarrow> a'\<guillemotright> \<and>
                         map (\<psi> (a, a') (\<E> (Cop_S.Map t))) = t"
          using ide_a ide_a' Hom.\<psi>_mapsto by auto
      qed
    qed

  end

  sublocale yoneda_functor \<subseteq> faithful_functor C Cop_S.comp map
    using is_faithful_functor by auto
  sublocale yoneda_functor \<subseteq> full_functor C Cop_S.comp map using is_full_functor by auto
  sublocale yoneda_functor \<subseteq> fully_faithful_functor C Cop_S.comp map ..

end


(* Author: Christian Urban, Xingyuan Zhang, Chunhan Wu *)
theory Closures
imports Myhill "HOL-Library.Infinite_Set"
begin

section \<open>Closure properties of regular languages\<close>

abbreviation
  regular :: "'a lang \<Rightarrow> bool"
where
  "regular A \<equiv> \<exists>r. A = lang r"

subsection \<open>Closure under \<open>\<union>\<close>, \<open>\<cdot>\<close> and \<open>\<star>\<close>\<close>

lemma closure_union [intro]:
  assumes "regular A" "regular B"
  shows "regular (A \<union> B)"
proof -
  from assms obtain r1 r2::"'a rexp" where "lang r1 = A" "lang r2 = B" by auto
  then have "A \<union> B = lang (Plus r1 r2)" by simp
  then show "regular (A \<union> B)" by blast
qed

lemma closure_seq [intro]:
  assumes "regular A" "regular B"
  shows "regular (A \<cdot> B)"
proof -
  from assms obtain r1 r2::"'a rexp" where "lang r1 = A" "lang r2 = B" by auto
  then have "A \<cdot> B = lang (Times r1 r2)" by simp
  then show "regular (A \<cdot> B)" by blast
qed

lemma closure_star [intro]:
  assumes "regular A"
  shows "regular (A\<star>)"
proof -
  from assms obtain r::"'a rexp" where "lang r = A" by auto
  then have "A\<star> = lang (Star r)" by simp
  then show "regular (A\<star>)" by blast
qed

subsection \<open>Closure under complementation\<close>

text \<open>Closure under complementation is proved via the
  Myhill-Nerode theorem\<close>

lemma closure_complement [intro]:
  fixes A::"('a::finite) lang"
  assumes "regular A"
  shows "regular (- A)"
proof -
  from assms have "finite (UNIV // \<approx>A)" by (simp add: Myhill_Nerode)
  then have "finite (UNIV // \<approx>(-A))" by (simp add: str_eq_def)
  then show "regular (- A)" by (simp add: Myhill_Nerode)
qed

subsection \<open>Closure under \<open>-\<close> and \<open>\<inter>\<close>\<close>

lemma closure_difference [intro]:
  fixes A::"('a::finite) lang"
  assumes "regular A" "regular B"
  shows "regular (A - B)"
proof -
  have "A - B = - (- A \<union> B)" by blast
  moreover
  have "regular (- (- A \<union> B))"
    using assms by blast
  ultimately show "regular (A - B)" by simp
qed

lemma closure_intersection [intro]:
  fixes A::"('a::finite) lang"
  assumes "regular A" "regular B"
  shows "regular (A \<inter> B)"
proof -
  have "A \<inter> B = - (- A \<union> - B)" by blast
  moreover
  have "regular (- (- A \<union> - B))"
    using assms by blast
  ultimately show "regular (A \<inter> B)" by simp
qed

subsection \<open>Closure under string reversal\<close>

fun
  Rev :: "'a rexp \<Rightarrow> 'a rexp"
where
  "Rev Zero = Zero"
| "Rev One = One"
| "Rev (Atom c) = Atom c"
| "Rev (Plus r1 r2) = Plus (Rev r1) (Rev r2)"
| "Rev (Times r1 r2) = Times (Rev r2) (Rev r1)"
| "Rev (Star r) = Star (Rev r)"

lemma rev_seq[simp]:
  shows "rev ` (B \<cdot> A) = (rev ` A) \<cdot> (rev ` B)"
unfolding conc_def image_def
by (auto) (metis rev_append)+

lemma rev_star1:
  assumes a: "s \<in> (rev ` A)\<star>"
  shows "s \<in> rev ` (A\<star>)"
using a
proof(induct rule: star_induct)
  case (append s1 s2)
  have inj: "inj (rev::'a list \<Rightarrow> 'a list)" unfolding inj_on_def by auto
  have "s1 \<in> rev ` A" "s2 \<in> rev ` (A\<star>)" by fact+
  then obtain x1 x2 where "x1 \<in> A" "x2 \<in> A\<star>" and eqs: "s1 = rev x1" "s2 = rev x2" by auto
  then have "x1 \<in> A\<star>" "x2 \<in> A\<star>" by (auto)
  then have "x2 @ x1 \<in> A\<star>" by (auto)
  then have "rev (x2 @ x1) \<in> rev ` A\<star>" using inj by (simp only: inj_image_mem_iff)
  then show "s1 @ s2 \<in>  rev ` A\<star>" using eqs by simp
qed (auto)

lemma rev_star2:
  assumes a: "s \<in> A\<star>"
  shows "rev s \<in> (rev ` A)\<star>"
using a
proof(induct rule: star_induct)
  case (append s1 s2)
  have inj: "inj (rev::'a list \<Rightarrow> 'a list)" unfolding inj_on_def by auto
  have "s1 \<in> A"by fact
  then have "rev s1 \<in> rev ` A" using inj by (simp only: inj_image_mem_iff)
  then have "rev s1 \<in> (rev ` A)\<star>" by (auto)
  moreover
  have "rev s2 \<in> (rev ` A)\<star>" by fact
  ultimately show "rev (s1 @ s2) \<in>  (rev ` A)\<star>" by (auto)
qed (auto)

lemma rev_star [simp]:
  shows " rev ` (A\<star>) = (rev ` A)\<star>"
using rev_star1 rev_star2 by auto

lemma rev_lang:
  shows "rev ` (lang r) = lang (Rev r)"
by (induct r) (simp_all add: image_Un)

lemma closure_reversal [intro]:
  assumes "regular A"
  shows "regular (rev ` A)"
proof -
  from assms obtain r::"'a rexp" where "A = lang r" by auto
  then have "lang (Rev r) = rev ` A" by (simp add: rev_lang)
  then show "regular (rev` A)" by blast
qed

subsection \<open>Closure under left-quotients\<close>

abbreviation
  "Deriv_lang A B \<equiv> \<Union>x \<in> A. Derivs x B"

lemma closure_left_quotient:
  assumes "regular A"
  shows "regular (Deriv_lang B A)"
proof -
  from assms obtain r::"'a rexp" where eq: "lang r = A" by auto
  have fin: "finite (pderivs_lang B r)" by (rule finite_pderivs_lang)

  have "Deriv_lang B (lang r) = (\<Union> (lang ` pderivs_lang B r))"
    by (simp add: Derivs_pderivs pderivs_lang_def)
  also have "\<dots> = lang (\<Uplus>(pderivs_lang B r))" using fin by simp
  finally have "Deriv_lang B A = lang (\<Uplus>(pderivs_lang B r))" using eq
    by simp
  then show "regular (Deriv_lang B A)" by auto
qed

subsection \<open>Finite and co-finite sets are regular\<close>

lemma singleton_regular:
  shows "regular {s}"
proof (induct s)
  case Nil
  have "{[]} = lang (One)" by simp
  then show "regular {[]}" by blast
next
  case (Cons c s)
  have "regular {s}" by fact
  then obtain r where "{s} = lang r" by blast
  then have "{c # s} = lang (Times (Atom c) r)"
    by (auto simp add: conc_def)
  then show "regular {c # s}" by blast
qed

lemma finite_regular:
  assumes "finite A"
  shows "regular A"
using assms
proof (induct)
  case empty
  have "{} = lang (Zero)" by simp
  then show "regular {}" by blast
next
  case (insert s A)
  have "regular {s}" by (simp add: singleton_regular)
  moreover
  have "regular A" by fact
  ultimately have "regular ({s} \<union> A)" by (rule closure_union)
  then show "regular (insert s A)" by simp
qed

lemma cofinite_regular:
  fixes A::"'a::finite lang"
  assumes "finite (- A)"
  shows "regular A"
proof -
  from assms have "regular (- A)" by (simp add: finite_regular)
  then have "regular (-(- A))" by (rule closure_complement)
  then show "regular A" by simp
qed

subsection \<open>Continuation lemma for showing non-regularity of languages\<close>

lemma continuation_lemma:
  fixes A B::"'a::finite lang"
  assumes reg: "regular A"
  and     inf: "infinite B"
  shows "\<exists>x \<in> B. \<exists>y \<in> B. x \<noteq> y \<and> x \<approx>A y"
proof -
  define eqfun where "eqfun = (\<lambda>A x::('a::finite list). (\<approx>A) `` {x})"
  have "finite (UNIV // \<approx>A)" using reg by (simp add: Myhill_Nerode)
  moreover
  have "(eqfun A) ` B \<subseteq> UNIV // (\<approx>A)"
    unfolding eqfun_def quotient_def by auto
  ultimately have "finite ((eqfun A) ` B)" by (rule rev_finite_subset)
  with inf have "\<exists>a \<in> B. infinite {b \<in> B. eqfun A b = eqfun A a}"
    by (rule pigeonhole_infinite)
  then obtain a where in_a: "a \<in> B" and "infinite {b \<in> B. eqfun A b = eqfun A a}"
    by blast
  moreover
  have "{b \<in> B. eqfun A b = eqfun A a} = {b \<in> B. b \<approx>A a}"
    unfolding eqfun_def Image_def str_eq_def by auto
  ultimately have "infinite {b \<in> B. b \<approx>A a}" by simp
  then have "infinite ({b \<in> B. b \<approx>A a} - {a})" by simp
  moreover
  have "{b \<in> B. b \<approx>A a} - {a} = {b \<in> B. b \<approx>A a \<and> b \<noteq> a}" by auto
  ultimately have "infinite {b \<in> B. b \<approx>A a \<and> b \<noteq> a}" by simp
  then have "{b \<in> B. b \<approx>A a \<and> b \<noteq> a} \<noteq> {}"
    by (metis finite.emptyI)
  then obtain b where "b \<in> B" "b \<noteq> a" "b \<approx>A a" by blast
  with in_a show "\<exists>x \<in> B. \<exists>y \<in> B. x \<noteq> y \<and> x \<approx>A y"
    by blast
qed

subsection \<open>The language \<open>a\<^sup>n b\<^sup>n\<close> is not regular\<close>

abbreviation
  replicate_rev ("_ ^^^ _" [100, 100] 100)
where
  "a ^^^ n \<equiv> replicate n a"

lemma an_bn_not_regular:
  shows "\<not> regular (\<Union>n. {CHR ''a'' ^^^ n @ CHR ''b'' ^^^ n})"
proof
  define A where "A = (\<Union>n. {CHR ''a'' ^^^ n @ CHR ''b'' ^^^ n})"
  assume as: "regular A"
  define B where "B = (\<Union>n. {CHR ''a'' ^^^ n})"

  have sameness: "\<And>i j. CHR ''a'' ^^^ i @ CHR ''b'' ^^^ j \<in> A \<longleftrightarrow> i = j"
    unfolding A_def
    apply auto
    apply(drule_tac f="\<lambda>s. length (filter ((=) (CHR ''a'')) s) = length (filter ((=) (CHR ''b'')) s)"
      in arg_cong)
    apply(simp)
    done

  have b: "infinite B"
    unfolding infinite_iff_countable_subset
    unfolding inj_on_def B_def
    by (rule_tac x="\<lambda>n. CHR ''a'' ^^^ n" in exI) (auto)
  moreover
  have "\<forall>x \<in> B. \<forall>y \<in> B. x \<noteq> y \<longrightarrow> \<not> (x \<approx>A y)"
    apply(auto)
    unfolding B_def
    apply(auto)
    apply(simp add: str_eq_def)
    apply(drule_tac x="CHR ''b'' ^^^ xa" in spec)
    apply(simp add: sameness)
    done
  ultimately
  show "False" using continuation_lemma[OF as] by blast
qed

end


section {* Lists: extra functions and properties *}

theory List_extra
imports
  Main
  "~~/src/HOL/Library/Sublist"
  "~~/src/HOL/Library/Monad_Syntax"
begin

subsection {* Extra list functions *}

text {*
The following variant of the standard @{text nth} function returns
@{text "\<bottom>"} if the index is out of range.
*}

primrec
  nth_el :: "'a list \<Rightarrow> nat \<Rightarrow> 'a option" ("_\<langle>_\<rangle>\<^sub>l" [90, 0] 91)
where
  "[]\<langle>i\<rangle>\<^sub>l = None"
| "(x # xs)\<langle>i\<rangle>\<^sub>l = (case i of 0 \<Rightarrow> Some x | Suc j \<Rightarrow> xs \<langle>j\<rangle>\<^sub>l)"

fun sequence :: "'a option list \<Rightarrow> 'a list option" where
"sequence [] = Some []" |
"sequence (f # fs) = do { x \<leftarrow> f; xs \<leftarrow> sequence fs; Some (x # xs) }"

abbreviation "mapM f \<equiv> sequence \<circ> map f"

subsection {* List lemmas *}

lemma map_nth_Cons_atLeastLessThan:
  "map (nth (x # xs)) [Suc m..<n] = map (nth xs) [m..<n - 1]"
proof -
  have "nth xs = nth (x # xs) \<circ> Suc"
    by auto
  hence "map (nth xs) [m..<n - 1] = map (nth (x # xs) \<circ> Suc) [m..<n - 1]"
    by simp
  also have "... = map (nth (x # xs)) (map Suc [m..<n - 1])"
    by simp
  also have "... = map (nth (x # xs)) [Suc m..<n]"
    by (metis Suc_diff_1 le_0_eq length_upt list.simps(8) list.size(3) map_Suc_upt not_less upt_0)
  finally show ?thesis ..
qed

lemma nth_el_appendl[simp]: "i < length xs \<Longrightarrow> (xs @ ys)\<langle>i\<rangle>\<^sub>l = xs\<langle>i\<rangle>\<^sub>l"
  apply (induct xs arbitrary: i)
  apply simp
  apply (case_tac i)
  apply simp_all
done

lemma nth_el_appendr[simp]: "length xs \<le> i \<Longrightarrow> (xs @ ys)\<langle>i\<rangle>\<^sub>l = ys\<langle>i - length xs\<rangle>\<^sub>l"
  apply (induct xs arbitrary: i)
  apply simp
  apply (case_tac i)
  apply simp_all
done

lemma sorted_last [simp]: "\<lbrakk> x \<in> set xs; sorted xs \<rbrakk> \<Longrightarrow> x \<le> last xs"
  apply (induct xs)
  apply (auto)
  apply (metis last_in_set sorted_Cons)+
done

lemma sorted_map: "\<lbrakk> sorted xs; mono f \<rbrakk> \<Longrightarrow> sorted (map f xs)"
  by (simp add: monoD sorted_equals_nth_mono)

lemma prefix_length_eq:
  "\<lbrakk> length xs = length ys; prefixeq xs ys \<rbrakk> \<Longrightarrow> xs = ys"
  using not_equal_is_parallel by auto

lemma prefix_Cons_elim [elim]:
  assumes "prefixeq (x # xs) ys"
  obtains ys' where "ys = x # ys'" "prefixeq xs ys'"
  using assms by (auto elim!: prefixeqE)

lemma prefix_map_inj:
  "\<lbrakk> inj_on f (set xs \<union> set ys); prefixeq (map f xs) (map f ys) \<rbrakk> \<Longrightarrow>
   prefixeq xs ys"
  apply (induct xs arbitrary:ys)
  apply (simp_all)
  apply (erule prefix_Cons_elim)
  apply (auto)
  apply (metis image_insert insertI1 insert_Diff_if singletonE)
done

lemma prefix_map_inj_eq [simp]:
  "inj_on f (set xs \<union> set ys) \<Longrightarrow>
   prefixeq (map f xs) (map f ys) \<longleftrightarrow> prefixeq xs ys"
  by (metis map_prefixeqI prefix_map_inj)

lemma strict_prefix_Cons_elim:
  assumes "prefixeq (x # xs) ys"
  obtains ys' where "ys = x # ys'" "prefixeq xs ys'"
  using assms by auto

lemma strict_prefix_map_inj:
  "\<lbrakk> inj_on f (set xs \<union> set ys); prefixeq (map f xs) (map f ys) \<rbrakk> \<Longrightarrow>
   prefixeq xs ys" by auto

lemma strict_prefix_map_inj_eq:
  "inj_on f (set xs \<union> set ys) \<Longrightarrow>
   prefixeq (map f xs) (map f ys) \<longleftrightarrow> prefixeq xs ys"
   by auto

lemma prefix_drop:
  "\<lbrakk> drop (length xs) ys = zs; prefixeq xs ys \<rbrakk>
   \<Longrightarrow> ys = xs @ zs"
  by (metis append_eq_conv_conj prefixeq_def)

subsection {* Minus on lists *}

instantiation list :: (type) minus
begin

text {* We define list minus so that if the second list is not a prefix of the first, then an arbitrary
        list longer than the combined length is produced. Thus we can always determined from the output
        whether the minus is defined or not. *}

definition "xs - ys = (if (prefixeq ys xs) then drop (length ys) xs else [])"

instance ..
end

lemma minus_cancel [simp]: "xs - xs = []"
  by (simp add: minus_list_def)

lemma append_minus [simp]: "(xs @ ys) - xs = ys"
  by (simp add: minus_list_def)

lemma minus_right_nil [simp]: "xs - [] = xs"
  by (simp add: minus_list_def)

lemma list_concat_minus_list_concat: "(s @ t) - (s @ z) = t - z"
  by (simp add: minus_list_def)

lemma length_gt_zero_butlast_concat:
  assumes "length ys > 0"
  shows "butlast (xs @ ys) = xs @ (butlast ys)"
  using assms by (metis butlast_append length_greater_0_conv)

lemma length_eq_zero_butlast_concat:
  assumes "length ys = 0"
  shows "butlast (xs @ ys) = butlast xs"
  using assms by (metis append_Nil2 length_0_conv)

lemma butlast_single_element:
  shows "butlast [e] = []"
  by (metis butlast.simps(2))

lemma last_single_element:
  shows "last [e] = e"
  by (metis last.simps)

lemma length_zero_last_concat:
  assumes "length t = 0"
  shows "last (s @ t) = last s"
  by (metis append_Nil2 assms length_0_conv)

lemma length_gt_zero_last_concat:
  assumes "length t > 0"
  shows "last (s @ t) = last t"
  by (metis assms last_append length_greater_0_conv)

subsection {* Interleaving operations *}

fun interleave :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list set" where
"interleave [] ys = {ys}" |
"interleave (x # xs) (y # ys) = (Cons x) ` (interleave xs (y # ys))
                              \<union> (Cons y) ` (interleave (x # xs) ys)" |
"interleave xs [] = {xs}"

lemma interleave_finite [simp]:
  "finite (interleave xs ys)"
  apply (induct xs arbitrary: ys)
  apply (simp)
  apply (induct_tac ys)
  apply (auto)
done

lemma interleave_right_nil [simp]:
  "interleave xs [] = {xs}"
  by (induct xs, auto)

lemma interleave_headE [elim!]:
  "\<lbrakk> z # zs \<in> interleave xs ys
   ; \<And> xs'. xs = z # xs' \<Longrightarrow> P
   ; \<And> ys'. ys = z # ys' \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  apply (induct xs)
  apply (auto)
  apply (induct ys)
  apply (auto)
done

lemma interleave_member:
  "\<lbrakk> zs \<in> interleave xs ys; z \<in> set zs \<rbrakk> \<Longrightarrow> z \<in> set xs \<or> z \<in> set ys"
  apply (induct xs arbitrary: zs)
  apply (auto)
  apply (induct ys)
  apply (auto)
oops

(* FIXME: What happens if no progress can be made? *)
fun intersync :: "'a set \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list set" where
"intersync s (x # xs) (y # ys)
  = (case (x = y , x \<in> s , y \<in> s) of
          (True  , True   , _      ) \<Rightarrow> Cons x ` intersync s xs ys |
          (True  , False  , _      ) \<Rightarrow> ((Cons x ` intersync s xs (y # ys))
                                         \<union> (Cons y ` intersync s (x # xs) ys)) |
          (False , True   , True   ) \<Rightarrow> {[]} |
          (False , True   , False  ) \<Rightarrow> Cons y ` intersync s (x # xs) ys |
          (False , False  , True   ) \<Rightarrow> Cons x ` intersync s xs (y # ys) |
          (False , False  , False  ) \<Rightarrow> ((Cons x ` intersync s xs (y # ys))
                                         \<union> (Cons y ` intersync s (x # xs) ys)))" |
"intersync s [] (y # ys) =
   (if (y \<in> s) then {[]} else Cons y ` intersync s [] ys)" |
"intersync s (x # xs) [] =
   (if (x \<in> s) then {[]} else Cons x ` intersync s xs [])" |
"intersync s [] [] = {[]}"

(* FIXME: We should be able to prove this property... *)
lemma intersync_empty_interleave:
  "intersync {} xs ys = interleave xs ys"
oops

subsection {* Sorting of lists *}

definition is_sorted_list_of_set :: "('a::ord) set \<Rightarrow> 'a list \<Rightarrow> bool" where
"is_sorted_list_of_set A xs = ((\<forall> i<length(xs) - 1. xs!i < xs!(i + 1)) \<and> set(xs) = A)"

lemma sorted_distinct [intro]: "\<lbrakk> sorted (xs); distinct(xs) \<rbrakk> \<Longrightarrow> (\<forall> i<length xs - 1. xs!i < xs!(i + 1))"
  apply (induct xs)
  apply (auto)
  apply (metis Suc_mono distinct.simps(2) length_Cons lessI less_SucI less_le nth_Cons_Suc nth_eq_iff_index_eq sorted_equals_nth_mono)
done

lemma sorted_is_sorted_list_of_set:
  assumes "is_sorted_list_of_set A xs"
  shows "sorted(xs)" and "distinct(xs)"
using assms proof (induct xs arbitrary: A)
  show "sorted []"
    by auto
next
  show "distinct []"
    by auto
next
  fix A :: "'a set"
  case (Cons x xs) note hyps = this
  assume isl: "is_sorted_list_of_set A (x # xs)"
  hence srt: "(\<forall>i<length xs - Suc 0. xs ! i < xs ! Suc i)"
    using less_diff_conv by (auto simp add: is_sorted_list_of_set_def)
  with hyps(1) have srtd: "sorted xs"
    by (simp add: is_sorted_list_of_set_def)
  with isl show "sorted (x # xs)"
    apply (auto simp add: is_sorted_list_of_set_def)
    apply (metis length_pos_if_in_set less_imp_le nth_Cons_0 sorted.simps sorted_many sorted_single)
  done
  from srt hyps(2) have "distinct xs"
    by (simp add: is_sorted_list_of_set_def)
  with isl show "distinct (x # xs)"
  proof -
    have "(\<forall>n. \<not> n < length (x # xs) - 1 \<or> (x # xs) ! n < (x # xs) ! (n + 1)) \<and> set (x # xs) = A"
      by (meson \<open>is_sorted_list_of_set A (x # xs)\<close> is_sorted_list_of_set_def)
  then show ?thesis
      by (metis Nat.add_0_right One_nat_def \<open>distinct xs\<close> \<open>sorted (x # xs)\<close> add_Suc_right diff_Suc_Suc diff_zero distinct.simps(2) insert_iff length_pos_if_in_set linorder_not_less list.set(2) list.simps(1) list.simps(3) list.size(3) list.size(4) not_less_iff_gr_or_eq nth_Cons_0 nth_Cons_Suc sorted.cases)
  qed
qed

lemma is_sorted_list_of_set_alt_def:
  "is_sorted_list_of_set A xs \<longleftrightarrow> sorted (xs) \<and> distinct (xs) \<and> set(xs) = A"
  apply (auto intro: sorted_is_sorted_list_of_set)
  apply (auto simp add: is_sorted_list_of_set_def)
  apply (metis Nat.add_0_right One_nat_def add_Suc_right sorted_distinct)
done

(*
lemma sorted_alt_def:
  "(\<forall> i<(length xs) - 1. xs!i < xs!(i + 1)) \<longleftrightarrow> sorted (xs) \<and> distinct (xs)"
  apply (auto)
  sledgehammer
oops
*)

definition sorted_list_of_set_alt :: "('a::ord) set \<Rightarrow> 'a list" where
"sorted_list_of_set_alt A =
  (if (A = {}) then [] else (THE xs. is_sorted_list_of_set A xs))"

lemma is_sorted_list_of_set:
  "finite A \<Longrightarrow> is_sorted_list_of_set A (sorted_list_of_set A)"
  apply (simp add: is_sorted_list_of_set_def)
  apply (metis One_nat_def add.right_neutral add_Suc_right sorted_distinct sorted_list_of_set)
done

lemma sorted_list_of_set_other_def:
  "finite A \<Longrightarrow> sorted_list_of_set(A) = (THE xs. sorted(xs) \<and> distinct(xs) \<and> set xs = A)"
  apply (rule sym)
  apply (rule the_equality)
  apply (auto)
  apply (simp add: sorted_distinct_set_unique)
done

lemma sorted_list_of_set_alt [simp]:
  "finite A \<Longrightarrow> sorted_list_of_set_alt(A) = sorted_list_of_set(A)"
  apply (rule sym)
  apply (auto simp add: sorted_list_of_set_alt_def is_sorted_list_of_set_alt_def sorted_list_of_set_other_def)
done

text {* Greatest common prefix *}

fun gcp :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"gcp [] ys = []" |
"gcp (x # xs) (y # ys) = (if (x = y) then x # gcp xs ys else [])" |
"gcp _ _ = []"

lemma gcp_right [simp]: "gcp xs [] = []"
  by (induct xs, auto)

lemma gcp_append [simp]: "gcp (xs @ ys) (xs @ zs) = xs @ gcp ys zs"
  by (induct xs, auto)

lemma gcp_lb1: "prefixeq (gcp xs ys) xs"
  apply (induct xs arbitrary: ys, auto)
  apply (case_tac ys, auto)
done

lemma gcp_lb2: "prefixeq (gcp xs ys) ys"
  apply (induct ys arbitrary: xs, auto)
  apply (case_tac xs, auto)
done

interpretation prefix_semilattice: semilattice_inf gcp prefixeq prefix
proof (unfold_locales)
  fix xs ys :: "'a list"
  show "prefixeq (gcp xs ys) xs"
    by (induct xs arbitrary: ys, auto, case_tac ys, auto)
  show "prefixeq (gcp xs ys) ys"
    by (induct ys arbitrary: xs, auto, case_tac xs, auto)
next
  fix xs ys zs :: "'a list"
  assume "prefixeq xs ys" "prefixeq xs zs"
  thus "prefixeq xs (gcp ys zs)"
    by (simp add: prefixeq_def, auto)
qed

text {* Extra laws to do with prefix and order *}

lemma lexord_append:
  assumes "(xs\<^sub>1 @ ys\<^sub>1, xs\<^sub>2 @ ys\<^sub>2) \<in> lexord R" "length(xs\<^sub>1) = length(xs\<^sub>2)"
  shows "(xs\<^sub>1, xs\<^sub>2) \<in> lexord R \<or> (xs\<^sub>1 = xs\<^sub>2 \<and> (ys\<^sub>1, ys\<^sub>2) \<in> lexord R)"
using assms
proof (induct xs\<^sub>2 arbitrary: xs\<^sub>1)
  case (Cons x\<^sub>2 xs\<^sub>2') note hyps = this
  from hyps(3) obtain x\<^sub>1 xs\<^sub>1' where xs\<^sub>1: "xs\<^sub>1 = x\<^sub>1 # xs\<^sub>1'" "length(xs\<^sub>1') = length(xs\<^sub>2')"
    by (auto, metis Suc_length_conv)
  with hyps(2) have xcases: "(x\<^sub>1, x\<^sub>2) \<in> R \<or> (xs\<^sub>1' @ ys\<^sub>1, xs\<^sub>2' @ ys\<^sub>2) \<in> lexord R"
    by (auto)
  show ?case
  proof (cases "(x\<^sub>1, x\<^sub>2) \<in> R")
    case True with xs\<^sub>1 show ?thesis
      by (auto)
  next
    case False
    with xcases have "(xs\<^sub>1' @ ys\<^sub>1, xs\<^sub>2' @ ys\<^sub>2) \<in> lexord R"
      by (auto)
    with hyps(1) xs\<^sub>1 have dichot: "(xs\<^sub>1', xs\<^sub>2') \<in> lexord R \<or> (xs\<^sub>1' = xs\<^sub>2' \<and> (ys\<^sub>1, ys\<^sub>2) \<in> lexord R)"
      by (auto)
    have "x\<^sub>1 = x\<^sub>2"
      using False hyps(2) xs\<^sub>1(1) by auto
    with dichot xs\<^sub>1 show ?thesis
      by (simp)
  qed
next
  case Nil thus ?case
    by auto
qed

lemma strict_prefix_lexord_rel:
  "prefix xs ys \<Longrightarrow> (xs, ys) \<in> lexord R"
  by (metis lexord_append_rightI prefixE')

lemma strict_prefix_lexord_left:
  assumes "trans R" "(xs, ys) \<in> lexord R" "prefix xs' xs"
  shows "(xs', ys) \<in> lexord R"
  using assms lexord_trans strict_prefix_lexord_rel by blast

lemma prefix_lexord_right:
  assumes "trans R" "(xs, ys) \<in> lexord R" "prefix ys ys'"
  shows "(xs, ys') \<in> lexord R"
  by (metis assms lexord_trans strict_prefix_lexord_rel)

lemma lexord_eq_length:
  assumes "(xs, ys) \<in> lexord R" "length xs = length ys"
  shows "\<exists> i. (xs!i, ys!i) \<in> R \<and> i < length xs \<and> (\<forall> j<i. xs!j = ys!j)"
using assms proof (induct xs arbitrary: ys)
  case (Cons x xs) note hyps = this
  then obtain y ys' where ys: "ys = y # ys'" "length ys' = length xs"
    by (metis Suc_length_conv)
  show ?case
  proof (cases "(x, y) \<in> R")
    case True with ys show ?thesis
      by (rule_tac x="0" in exI, simp)
  next
    case False
    with ys hyps(2) have xy: "x = y" "(xs, ys') \<in> lexord R"
      by auto
    with hyps(1,3) ys obtain i where "(xs!i, ys'!i) \<in> R" "i < length xs" "(\<forall> j<i. xs!j = ys'!j)"
      by force
    with xy ys show ?thesis
      apply (rule_tac x="Suc i" in exI)
      apply (auto simp add: less_Suc_eq_0_disj)
    done
  qed
next
  case Nil thus ?case by (auto)
qed

lemma lexord_intro_elems:
  assumes "length xs > i" "length ys > i" "(xs!i, ys!i) \<in> R" "\<forall> j<i. xs!j = ys!j"
  shows "(xs, ys) \<in> lexord R"
using assms proof (induct i arbitrary: xs ys)
  case 0 thus ?case
    by (auto, metis lexord_cons_cons list.exhaust nth_Cons_0)
next
  case (Suc i) note hyps = this
  then obtain x' y' xs' ys' where "xs = x' # xs'" "ys = y' # ys'"
    by (metis Suc_length_conv Suc_lessE)
  moreover with hyps(5) have "\<forall>j<i. xs' ! j = ys' ! j"
    by (auto)
  ultimately show ?case using hyps
    by (auto)
qed

text {* Extra lemmas about @{term prefix} and @{term strict_prefix} *}

lemma prefix_concat_minus:
  assumes "prefixeq xs ys"
  shows "xs @ (ys - xs) = ys"
  using assms by (metis minus_list_def prefix_drop)

lemma prefix_minus_concat:
  assumes "prefixeq s t"
  shows "(t - s) @ z = (t @ z) - s"
  using assms by (simp add: minus_list_def prefixeq_length_le)

lemma strict_prefix_minus_not_empty:
  assumes "prefix xs ys"
  shows "ys - xs \<noteq> []"
  using assms  by (metis append_Nil2 prefixE prefix_concat_minus)

lemma strict_prefix_diff_minus:
  assumes "prefix xs ys" and "xs \<noteq> ys"
  shows "(ys - xs) \<noteq> []"
  using assms by (simp add: strict_prefix_minus_not_empty)

lemma prefix_not_empty:
  assumes "prefix xs ys" and "xs \<noteq> []"
  shows "ys \<noteq> []"
  using assms prefix_simps(1) by blast

lemma prefix_not_empty_length_gt_zero:
  assumes "prefix xs ys" and "xs \<noteq> []"
  shows "length ys > 0"
  using assms prefix_not_empty by auto

lemma butlast_prefix_suffix_not_empty:
  assumes "prefix (butlast xs) ys"
  shows "ys \<noteq> []"
  using assms prefix_not_empty_length_gt_zero by fastforce

lemma length_tl_list_minus_butlast_gt_zero:
  assumes "length s < length t" and "prefix (butlast s) t" and "length s > 0"
  shows "length (tl (t - (butlast s))) > 0"
  using assms
  by (metis Nitpick.size_list_simp(2) butlast_snoc hd_Cons_tl length_butlast length_greater_0_conv length_tl less_trans nat_neq_iff strict_prefix_minus_not_empty prefix_order.dual_order.strict_implies_order prefix_concat_minus)

lemma prefix_and_concat_prefix_is_concat_prefix:
  assumes "prefixeq s t" "prefixeq (e @ t) u"
  shows "prefixeq (e @ s) u"
  using assms prefix_order.dual_order.trans same_prefixeq_prefixeq by blast

lemma list_minus_butlast_eq_butlast_list:
  assumes "length t = length s" and "prefix (butlast s) t"
  shows "t - (butlast s) = [last t]"
  using assms
  by (metis append_butlast_last_id append_eq_append_conv butlast.simps(1) length_butlast less_numeral_extra(3) list.size(3) prefix_order.dual_order.strict_implies_order prefix_concat_minus prefixeq_length_less)

lemma strict_prefix_eq_exists:
  "prefix s t \<longleftrightarrow> (\<exists>xs . s @ xs = t \<and> (length xs) > 0)"
  by (metis append_minus length_greater_0_conv minus_list_def prefixE' prefix_def self_append_conv)

lemma butlast_strict_prefix_eq_butlast:
  assumes "length s = length t" and "prefix (butlast s) t"
  shows "prefix (butlast s) t \<longleftrightarrow> (butlast s) = (butlast t)"
  by (metis append_butlast_last_id append_eq_append_conv assms(1) assms(2) length_0_conv length_butlast strict_prefix_eq_exists)

lemma butlast_eq_if_eq_length_and_prefix:
  assumes "length s > 0" "length z > 0"
          "length s = length z" "prefix (butlast s) t" "prefix (butlast z) t"
  shows   "(butlast s) = (butlast z)"
  using assms by (auto simp add:strict_prefix_eq_exists)

lemma prefix_imp_length_lteq:
  assumes "prefixeq s t"
  shows "length s \<le> length t"
  using assms by (simp add:prefixeq_length_le)

lemma prefix_imp_length_not_gt:
  assumes "prefixeq s t"
  shows "\<not> length t < length s"
  using assms by (simp add: leD prefixeq_length_le)

lemma prefix_and_eq_length_imp_eq_list:
  assumes "prefixeq s t" and "length t = length s"
  shows "s=t"
  using assms by (simp add: prefix_length_eq)

lemma butlast_strict_prefix_length_lt_imp_last_tl_minus_butlast_eq_last:
  assumes "length s > 0" "prefix (butlast s) t" "length s < length t"
  shows "last (tl (t - (butlast s))) = (last t)"
  using assms by (metis last_append last_tl length_tl_list_minus_butlast_gt_zero less_numeral_extra(3) list.size(3) append_minus strict_prefix_eq_exists)

lemma tl_list_minus_butlast_not_empty:
  assumes "prefixeq (butlast s) t" and "length s > 0" and "length t > length s"
  shows "tl (t - (butlast s)) \<noteq> []"
  using assms length_tl_list_minus_butlast_gt_zero
proof -
  have "butlast s \<noteq> t"
    by (metis (full_types) assms(3) diff_le_self leD length_butlast)
  then have "prefix (butlast s) t"
    by (metis assms(1) prefix_order.le_imp_less_or_eq)
  then show ?thesis
    by (metis (full_types) assms(2) assms(3) length_tl_list_minus_butlast_gt_zero less_numeral_extra(3) list.size(3))
qed

lemma tl_list_minus_butlast_empty:
  assumes "prefix (butlast s) t" and "length s > 0" and "length t = length s"
  shows "tl (t - (butlast s)) = []"
  using assms by (simp add: list_minus_butlast_eq_butlast_list)

lemma concat_minus_list_concat_butlast_eq_list_minus_butlast:
  assumes "prefixeq (butlast u) s"
  shows "(t @ s) - (t @ (butlast u)) = s - (butlast u)"
  using List_extra.list_concat_minus_list_concat by auto

lemma tl_list_minus_butlast_eq_empty:
  assumes "prefix (butlast s) t" and "length s = length t"
  shows "tl (t - (butlast s)) = []"
  using assms by (metis list.sel(3) list_minus_butlast_eq_butlast_list)

(* this can be shown using length_tl, but care is needed when list is empty? *)
lemma prefix_length_tl_minus:
  assumes "prefix s t"
  shows "length (tl (t-s)) = (length (t-s)) - 1"
  by auto

lemma length_list_minus:
  assumes "prefix s t"
  shows "length(t - s) = length(t) - length(s)"
  using assms by (simp add: minus_list_def prefix_order.dual_order.strict_implies_order)

lemma butlast_prefix_imp_length_not_gt:
  assumes "length s > 0" "prefix (butlast s) t"
  shows "\<not> (length t < length s)"
  using assms prefixeq_length_less by fastforce

lemma length_not_gt_iff_eq_length:
  assumes "length s > 0" and "prefix (butlast s) t"
  shows "(\<not> (length s < length t)) = (length s = length t)"
proof -
  have "(\<not> (length s < length t)) = ((length t < length s) \<or> (length s = length t))"
      by (metis not_less_iff_gr_or_eq)
  also have "... = (length s = length t)"
      using assms
      by (simp add:butlast_prefix_imp_length_not_gt)
  finally show ?thesis .
qed

lemma dropWhile_sorted_le_above:
  "\<lbrakk> sorted xs; x \<in> set (dropWhile (\<lambda> x. x \<le> n) xs) \<rbrakk> \<Longrightarrow> x > n"
  apply (induct xs)
  apply (auto)
  apply (rename_tac a xs)
  apply (case_tac "a \<le> n")
  apply (simp_all)
  using sorted_Cons apply blast
  apply (meson dual_order.trans not_less sorted_Cons)
done

lemma set_dropWhile_le:
  "sorted xs \<Longrightarrow> set (dropWhile (\<lambda> x. x \<le> n) xs) = {x\<in>set xs. x > n}"
  apply (induct xs)
  apply (simp)
  apply (rename_tac x xs)
  apply (subgoal_tac "sorted xs")
  apply (simp)
  apply (safe)
  apply (simp_all)
  apply (meson not_less order_trans sorted_Cons)
  using sorted_Cons apply auto
done

lemma set_takeWhile_less_sorted:
  "\<lbrakk> sorted I; x \<in> set I; x < n \<rbrakk> \<Longrightarrow> x \<in> set (takeWhile (\<lambda>x. x < n) I)"
proof (induct I arbitrary: x)
  case Nil thus ?case
    by (simp)
next
  case (Cons a I) thus ?case
    by (auto, (meson le_less_trans sorted_Cons)+)
qed

lemma nth_le_takeWhile_ord: "\<lbrakk> sorted xs; i \<ge> length (takeWhile (\<lambda> x. x \<le> n) xs); i < length xs \<rbrakk> \<Longrightarrow> n \<le> xs ! i"
  apply (induct xs arbitrary: i, auto)
  apply (rename_tac x xs i)
  apply (case_tac "x \<le> n")
  apply (auto simp add: sorted_Cons)
  apply (metis One_nat_def Suc_eq_plus1 le_less_linear le_less_trans less_imp_le list.size(4) nth_mem set_ConsD)
done

lemma length_takeWhile_less:
  "\<lbrakk> a \<in> set xs; \<not> P a \<rbrakk> \<Longrightarrow> length (takeWhile P xs) < length xs"
  by (metis in_set_conv_nth length_takeWhile_le nat_neq_iff not_less set_takeWhileD takeWhile_nth)

lemma nth_length_takeWhile_less:
  "\<lbrakk> sorted xs; distinct xs; (\<exists> a \<in> set xs. a \<ge> n) \<rbrakk> \<Longrightarrow> xs ! length (takeWhile (\<lambda>x. x < n) xs) \<ge> n"
  apply (induct xs, auto)
  using sorted_Cons by blast

text {* Sorting lists according to a relation *}

definition is_sorted_list_of_set_by :: "'a rel \<Rightarrow> 'a set \<Rightarrow> 'a list \<Rightarrow> bool" where
"is_sorted_list_of_set_by R A xs = ((\<forall> i<length(xs) - 1. (xs!i, xs!(i + 1)) \<in> R) \<and> set(xs) = A)"

definition sorted_list_of_set_by :: "'a rel \<Rightarrow> 'a set \<Rightarrow> 'a list" where
"sorted_list_of_set_by R A = (THE xs. is_sorted_list_of_set_by R A xs)"

definition fin_set_lexord :: "'a rel \<Rightarrow> 'a set rel" where
"fin_set_lexord R = {(A, B). finite A \<and> finite B \<and>
                             (\<exists> xs ys. is_sorted_list_of_set_by R A xs \<and> is_sorted_list_of_set_by R B ys
                              \<and> (xs, ys) \<in> lexord R)}"

lemma is_sorted_list_of_set_by_mono:
  "\<lbrakk> R \<subseteq> S; is_sorted_list_of_set_by R A xs \<rbrakk> \<Longrightarrow> is_sorted_list_of_set_by S A xs"
  by (auto simp add: is_sorted_list_of_set_by_def)

lemma lexord_mono':
  "\<lbrakk> (\<And> x y. f x y \<longrightarrow> g x y); (xs, ys) \<in> lexord {(x, y). f x y} \<rbrakk> \<Longrightarrow> (xs, ys) \<in> lexord {(x, y). g x y}"
  by (metis case_prodD case_prodI lexord_take_index_conv mem_Collect_eq)

lemma fin_set_lexord_mono [mono]:
  "(\<And> x y. f x y \<longrightarrow> g x y) \<Longrightarrow> (xs, ys) \<in> fin_set_lexord {(x, y). f x y} \<longrightarrow> (xs, ys) \<in> fin_set_lexord {(x, y). g x y}"
proof
  assume
    fin: "(xs, ys) \<in> fin_set_lexord {(x, y). f x y}" and
    hyp: "(\<And> x y. f x y \<longrightarrow> g x y)"

  from fin have "finite xs" "finite ys"
    using fin_set_lexord_def by fastforce+

  with fin hyp show "(xs, ys) \<in> fin_set_lexord {(x, y). g x y}"
    apply (auto simp add: fin_set_lexord_def)
    apply (rule_tac x="xsa" in exI)
    apply (auto)
    apply (metis case_prodD case_prodI is_sorted_list_of_set_by_def mem_Collect_eq)
    apply (metis case_prodD case_prodI is_sorted_list_of_set_by_def lexord_mono' mem_Collect_eq)
  done
qed

definition distincts :: "'a set \<Rightarrow> 'a list set" where
"distincts A = {xs \<in> lists A. distinct(xs)}"

lemma tl_element:
  "\<lbrakk> x \<in> set xs; x \<noteq> hd(xs) \<rbrakk> \<Longrightarrow> x \<in> set(tl(xs))"
  by (metis in_set_insert insert_Nil list.collapse list.distinct(2) set_ConsD)

subsection {* Z mathematical tool kit for sequences *}

abbreviation seq_dom :: "'a list \<Rightarrow> nat set" ("dom\<^sub>l") where
"seq_dom xs \<equiv> {0..<length xs}"

abbreviation seq_ran :: "'a list \<Rightarrow> 'a set" ("ran\<^sub>l") where
"seq_ran xs \<equiv> set xs"

definition seq_extract :: "nat set \<Rightarrow> 'a list \<Rightarrow> 'a list" (infix "\<upharpoonleft>\<^sub>l" 80) where
"seq_extract A xs = sublist xs A"

lemma seq_extract_Nil [simp]: "A \<upharpoonleft>\<^sub>l [] = []"
  by (simp add: seq_extract_def)

lemma seq_extract_Cons:
  "A \<upharpoonleft>\<^sub>l (x # xs) = (if 0 \<in> A then [x] else []) @ {j. Suc j \<in> A} \<upharpoonleft>\<^sub>l xs"
  by (simp add: seq_extract_def sublist_Cons)

lemma seq_extract_empty [simp]: "{} \<upharpoonleft>\<^sub>l xs = []"
  by (simp add: seq_extract_def)

lemma seq_extract_ident [simp]: "{0..<length xs} \<upharpoonleft>\<^sub>l xs = xs"
  unfolding list_eq_iff_nth_eq
  by (auto simp add: seq_extract_def length_sublist atLeast0LessThan)

lemma seq_extract_split:
  assumes "i \<le> length xs"
  shows "{0..<i} \<upharpoonleft>\<^sub>l xs @ {i..<length xs} \<upharpoonleft>\<^sub>l xs = xs"
using assms
proof (induct xs arbitrary: i)
  case Nil thus ?case by (simp add: seq_extract_def)
next
  case (Cons x xs) note hyp = this
  have "{j. Suc j < i} = {0..<i - 1}"
    by (auto)
  moreover have "{j. i \<le> Suc j \<and> j < length xs} = {i - 1..<length xs}"
    by (auto)
  ultimately show ?case
    using hyp by (force simp add: seq_extract_def sublist_Cons)
qed

lemma seq_extract_append:
  "A \<upharpoonleft>\<^sub>l (xs @ ys) = (A \<upharpoonleft>\<^sub>l xs) @ ({j. j + length xs \<in> A} \<upharpoonleft>\<^sub>l ys)"
  by (simp add: seq_extract_def sublist_append)

lemma seq_extract_range: "A \<upharpoonleft>\<^sub>l xs = (A \<inter> dom\<^sub>l(xs)) \<upharpoonleft>\<^sub>l xs"
  apply (auto simp add: seq_extract_def sublist_def)
  apply (metis (no_types, lifting) atLeastLessThan_iff filter_cong in_set_zip nth_mem set_upt)
done

lemma seq_extract_out_of_range:
  "A \<inter> dom\<^sub>l(xs) = {} \<Longrightarrow> A \<upharpoonleft>\<^sub>l xs = []"
  by (metis seq_extract_def seq_extract_range sublist_empty)

lemma seq_extract_length [simp]:
  "length (A \<upharpoonleft>\<^sub>l xs) = card (A \<inter> dom\<^sub>l(xs))"
proof -
  have "{i. i < length(xs) \<and> i \<in> A} = (A \<inter> {0..<length(xs)})"
    by (auto)
  thus ?thesis
    by (simp add: seq_extract_def length_sublist)
qed

lemma seq_extract_Cons_atLeastLessThan:
  assumes "m < n"
  shows "{m..<n} \<upharpoonleft>\<^sub>l (x # xs) = (if (m = 0) then x # ({0..<n-1} \<upharpoonleft>\<^sub>l xs) else {m-1..<n-1} \<upharpoonleft>\<^sub>l xs)"
proof -
  have "{j. Suc j < n} = {0..<n - Suc 0}"
    by (auto)
  moreover have "{j. m \<le> Suc j \<and> Suc j < n} = {m - Suc 0..<n - Suc 0}"
    by (auto)

  ultimately show ?thesis using assms
    by (auto simp add: seq_extract_Cons)
qed

lemma seq_extract_singleton:
  assumes "i < length xs"
  shows "{i} \<upharpoonleft>\<^sub>l xs = [xs ! i]"
  using assms
  apply (induct xs arbitrary: i)
  apply (auto simp add: seq_extract_Cons)
  apply (rename_tac xs i)
  apply (subgoal_tac "{j. Suc j = i} = {i - 1}")
  apply (auto)
done

lemma seq_extract_as_map:
  assumes "m < n" "n \<le> length xs"
  shows "{m..<n} \<upharpoonleft>\<^sub>l xs = map (nth xs) [m..<n]"
using assms proof (induct xs arbitrary: m n)
  case Nil thus ?case by simp
next
  case (Cons x xs)
  have "[m..<n] = m # [m+1..<n]"
    using Cons.prems(1) upt_eq_Cons_conv by blast
  moreover have "map (nth (x # xs)) [Suc m..<n] = map (nth xs) [m..<n-1]"
    by (simp add: map_nth_Cons_atLeastLessThan)
  ultimately show ?case
    using Cons upt_rec
    by (auto simp add: seq_extract_Cons_atLeastLessThan)
qed

lemma seq_append_as_extract:
  "xs = ys @ zs \<longleftrightarrow> (\<exists> i\<le>length(xs). ys = {0..<i} \<upharpoonleft>\<^sub>l xs \<and> zs = {i..<length(xs)} \<upharpoonleft>\<^sub>l xs)"
proof
  assume xs: "xs = ys @ zs"
  moreover have "ys = {0..<length ys} \<upharpoonleft>\<^sub>l (ys @ zs)"
    by (simp add: seq_extract_append)
  moreover have "zs = {length ys..<length ys + length zs} \<upharpoonleft>\<^sub>l (ys @ zs)"
  proof -
    have "{length ys..<length ys + length zs} \<inter> {0..<length ys} = {}"
      by auto
    moreover have s1: "{j. j < length zs} = {0..<length zs}"
      by auto
    ultimately show ?thesis
      by (simp add: seq_extract_append seq_extract_out_of_range)
  qed
  ultimately show "(\<exists> i\<le>length(xs). ys = {0..<i} \<upharpoonleft>\<^sub>l xs \<and> zs = {i..<length(xs)} \<upharpoonleft>\<^sub>l xs)"
    by (rule_tac x="length ys" in exI, auto)
next
  assume "\<exists>i\<le>length xs. ys = {0..<i} \<upharpoonleft>\<^sub>l xs \<and> zs = {i..<length xs} \<upharpoonleft>\<^sub>l xs"
  thus "xs = ys @ zs"
    by (auto simp add: seq_extract_split)
qed

definition seq_filter :: "'a list \<Rightarrow> 'a set \<Rightarrow> 'a list" (infix "\<restriction>\<^sub>l" 80) where
"seq_filter xs A = filter (\<lambda> x. x \<in> A) xs"

lemma seq_filter_Nil [simp]: "[] \<restriction>\<^sub>l A = []"
  by (simp add: seq_filter_def)

lemma seq_filter_empty [simp]: "xs \<restriction>\<^sub>l {} = []"
  by (simp add: seq_filter_def)

lemma seq_filter_append: "(xs @ ys) \<restriction>\<^sub>l A = (xs \<restriction>\<^sub>l A) @ (ys \<restriction>\<^sub>l A)"
  by (simp add: seq_filter_def)

subsection {* Distributed Concatenation *}

definition uncurry :: "('a \<Rightarrow> 'b \<Rightarrow>  'c) \<Rightarrow> ('a \<times> 'b \<Rightarrow> 'c)" where
[simp]: "uncurry f = (\<lambda>(x, y). f x y)"

definition dist_concat ::
  "'a list set \<Rightarrow> 'a list set \<Rightarrow> 'a list set" (infixr "\<^sup>\<frown>" 100) where
"dist_concat ls1 ls2 = (uncurry (op @) ` (ls1 \<times> ls2))"

lemma dist_concat_left_empty [simp]:
  "{} \<^sup>\<frown> ys = {}"
  by (simp add: dist_concat_def)

lemma dist_concat_right_empty [simp]:
  "xs \<^sup>\<frown> {} = {}"
  by (simp add: dist_concat_def)

lemma dist_concat_insert [simp]:
"insert l ls1 \<^sup>\<frown> ls2 = ((op @ l) ` ( ls2)) \<union> (ls1 \<^sup>\<frown> ls2)"
  by (auto simp add: dist_concat_def)
end