section \<open>The Nash-Williams Theorem\<close>

text \<open>Following S. Todor\v{c}evi{\'c}, \emph{Introduction to Ramsey Spaces},
Princeton University Press (2010), 11--12.\<close>

theory Nash_Williams
  imports Nash_Extras
begin

lemma finite_nat_Int_greaterThan_iff:
  fixes N :: "nat set"
  shows "finite (N \<inter> {n<..}) \<longleftrightarrow> finite N"
  apply (simp add: finite_nat_iff_bounded subset_iff)
  by (metis dual_order.strict_trans2 nat_less_le not_less_eq)

subsection \<open>Initial segments\<close>

definition init_segment :: "nat set \<Rightarrow> nat set \<Rightarrow> bool"
  where "init_segment S T \<equiv> \<exists>S'. T = S \<union> S' \<and> S \<lless> S'"

lemma init_segment_subset: "init_segment S T \<Longrightarrow> S \<subseteq> T"
  by (auto simp: init_segment_def)

lemma init_segment_refl: "init_segment S S"
  by (metis empty_iff init_segment_def less_sets_def sup_bot.right_neutral)

lemma init_segment_antisym: "\<lbrakk>init_segment S T; init_segment T S\<rbrakk> \<Longrightarrow> S=T"
  by (auto simp: init_segment_def)

lemma init_segment_trans: "\<lbrakk>init_segment S T; init_segment T U\<rbrakk> \<Longrightarrow> init_segment S U"
  unfolding init_segment_def
  by (meson UnE Un_assoc Un_upper1 less_sets_def less_sets_weaken1)

lemma init_segment_empty2 [iff]: "init_segment S {} \<longleftrightarrow> S={}"
  by (auto simp: init_segment_def less_sets_def)

lemma init_segment_Un: "S \<lless> S' \<Longrightarrow> init_segment S (S \<union> S')"
  by (auto simp: init_segment_def less_sets_def)

lemma init_segment_iff:
  shows "init_segment S T \<longleftrightarrow> S=T \<or> (\<exists>m \<in> T. S = {n \<in> T. n < m})" (is "?lhs=?rhs")
proof
  assume ?lhs
  then obtain S' where S': "T = S \<union> S'" "S \<lless> S'"
    by (meson init_segment_def)
  then have "S \<subseteq> T"
    by auto
  then have eq: "S' = T-S"
    using S' by (auto simp: less_sets_def)
  show ?rhs
  proof (cases "T \<subseteq> S")
    case True
    with \<open>S \<subseteq> T\<close> show ?rhs by blast
  next
    case False
    then have "Inf S' \<in> T"
      by (metis Diff_eq_empty_iff Diff_iff Inf_nat_def1 eq)
    moreover have "\<And>x. x \<in> S \<Longrightarrow> x < Inf S'"
      using S' False by (metis Diff_eq_empty_iff Inf_nat_def1 eq less_sets_def)
    moreover have "{n \<in> T. n < Inf S'} \<subseteq> S"
      using Inf_nat_def eq not_less_Least by fastforce
    ultimately show ?rhs
      using \<open>S \<subseteq> T\<close> by blast
  qed
next
  assume ?rhs
  then show ?lhs
  proof (elim disjE bexE)
    fix m
    assume m: "m \<in> T" "S = {n \<in> T. n < m}"
    then have "T = S \<union> {n \<in> T. m \<le> n}"
      by auto
    moreover have "S \<lless> {n \<in> T. m \<le> n}"
      using m by (auto simp: less_sets_def)
    ultimately show "init_segment S T"
      using init_segment_Un by force
  qed (use init_segment_refl in blast)
qed

lemma init_segment_empty [iff]: "init_segment {} S"
  by (auto simp: init_segment_def less_sets_def)

lemma init_segment_insert_iff:
  assumes Sn: "S \<lless> {n}" and TS: "\<And>x. x \<in> T-S \<Longrightarrow> n\<le>x"
  shows "init_segment (insert n S) T \<longleftrightarrow> init_segment S T \<and> n \<in> T" (is "?lhs=?rhs")
proof
  assume ?lhs then show ?rhs
    by (metis Sn Un_commute init_segment_Un init_segment_subset init_segment_trans insertI1 insert_is_Un subsetD)
next
  assume rhs: ?rhs
  then obtain R where R: "T = S \<union> R" "S \<lless> R"
    by (auto simp: init_segment_def less_sets_def)
  then have "S\<union>R = insert n (S \<union> (R-{n})) \<and> insert n S \<lless> R-{n}"
    unfolding less_sets_def using rhs TS nat_less_le by auto
  then show ?lhs
    using R init_segment_Un by force
qed

lemma init_segment_insert:
  assumes "init_segment S T" and T: "T \<lless> {n}"
  shows "init_segment S (insert n T)"
proof (cases "T={}")
  case False
  obtain S' where S': "T = S \<union> S'" "S \<lless> S'"
    by (meson assms init_segment_def)
  then have "insert n T = S \<union> (insert n S')" "S \<lless> (insert n S')"
    using T False by (auto simp: less_sets_def)
  then show ?thesis
    using init_segment_Un by presburger
qed (use assms in auto)

subsection \<open>Definitions and basic properties\<close>

definition Ramsey :: "[nat set set, nat] \<Rightarrow> bool"
  where "Ramsey \<F> r \<equiv> \<forall>f \<in> \<F> \<rightarrow> {..<r}.
                       \<forall>M. infinite M \<longrightarrow>
                           (\<exists>N i. N \<subseteq> M \<and> infinite N \<and> i<r \<and>
                                  (\<forall>j<r. j\<noteq>i \<longrightarrow> f -` {j} \<inter> \<F> \<inter> Pow N = {}))"

text \<open>Alternative, simpler definition suggested by a referee.\<close>
lemma Ramsey_eq:
  "Ramsey \<F> r \<longleftrightarrow> (\<forall>f \<in> \<F> \<rightarrow> {..<r}.
                       \<forall>M. infinite M \<longrightarrow>
                           (\<exists>N i. N \<subseteq> M \<and> infinite N \<and> i<r \<and> \<F> \<inter> Pow N \<subseteq> f -` {i}))"
  unfolding Ramsey_def
  by (intro ball_cong all_cong ex_cong1 conj_cong refl) blast

definition thin_set :: "nat set set \<Rightarrow> bool"
  where "thin_set \<F> \<equiv> \<F> \<subseteq> Collect finite \<and> (\<forall>S\<in>\<F>. \<forall>T\<in>\<F>. init_segment S T \<longrightarrow> S=T)"

definition comparables :: "nat set \<Rightarrow> nat set \<Rightarrow> nat set set"
  where "comparables S M \<equiv> {T. finite T \<and> (init_segment T S \<or> init_segment S T \<and> T-S \<subseteq> M)}"

lemma comparables_iff: "T \<in> comparables S M \<longleftrightarrow> finite T \<and> (init_segment T S \<or> init_segment S T \<and> T \<subseteq> S \<union> M)"
  by (auto simp: comparables_def init_segment_def)

lemma comparables_subset: "\<Union>(comparables S M) \<subseteq> S \<union> M"
  by (auto simp: comparables_def init_segment_def)

lemma comparables_empty [simp]: "comparables {} M = Fpow M"
  by (auto simp: comparables_def Fpow_def)

lemma comparables_mono: "N \<subseteq> M \<Longrightarrow> comparables S N \<subseteq> comparables S M"
  by (auto simp: comparables_def)

definition "rejects \<F> S M \<equiv> comparables S M \<inter> \<F> = {}"

abbreviation accepts
  where "accepts \<F> S M \<equiv> \<not> rejects \<F> S M"

definition strongly_accepts
  where "strongly_accepts \<F> S M \<equiv> (\<forall>N\<subseteq>M. rejects \<F> S N \<longrightarrow> finite N)"

definition decides
  where "decides \<F> S M \<equiv> rejects \<F> S M \<or> strongly_accepts \<F> S M"

definition decides_subsets
  where "decides_subsets \<F> M \<equiv> \<forall>T. T \<subseteq> M \<longrightarrow> finite T \<longrightarrow> decides \<F> T M"

lemma strongly_accepts_imp_accepts:
  "\<lbrakk>strongly_accepts \<F> S M; infinite M\<rbrakk> \<Longrightarrow> accepts \<F> S M"
  unfolding strongly_accepts_def by blast

lemma rejects_trivial: "\<lbrakk>rejects \<F> S M; thin_set \<F>; init_segment F S; F \<in> \<F>\<rbrakk> \<Longrightarrow> False"
  unfolding rejects_def thin_set_def
  using comparables_iff by blast

lemma rejects_subset: "\<lbrakk>rejects \<F> S M; N \<subseteq> M\<rbrakk> \<Longrightarrow> rejects \<F> S N"
  by (fastforce simp add: rejects_def comparables_def)

lemma strongly_accepts_subset: "\<lbrakk>strongly_accepts \<F> S M; N \<subseteq> M\<rbrakk> \<Longrightarrow> strongly_accepts \<F> S N"
  by (auto simp: strongly_accepts_def)

lemma decides_subsets_subset: "\<lbrakk>decides_subsets \<F> M; N \<subseteq> M\<rbrakk> \<Longrightarrow> decides_subsets \<F> N"
  by (meson decides_subset decides_subsets_def subset_trans)

lemma rejects_empty [simp]: "rejects \<F> {} M \<longleftrightarrow> Fpow M \<inter> \<F> = {}"
  by (auto simp: rejects_def comparables_def Fpow_def)

lemma strongly_accepts_empty [simp]: "strongly_accepts \<F> {} M \<longleftrightarrow> (\<forall>N\<subseteq>M. Fpow N \<inter> \<F> = {} \<longrightarrow> finite N)"
  by (simp add: strongly_accepts_def Fpow_def disjoint_iff)

lemma ex_infinite_decides_1:
  assumes "infinite M"
  obtains N where "N \<subseteq> M" "infinite N" "decides \<F> S N"
  by (meson assms decides_def order_refl strongly_accepts_def)

proposition ex_infinite_decides_finite:
  assumes "infinite M" "finite S"
  obtains N where "N \<subseteq> M" "infinite N" "\<And>T. T \<subseteq> S \<Longrightarrow> decides \<F> T N"
proof -
  have "finite (Pow S)"
    by (simp add: \<open>finite S\<close>)
  then obtain f :: "nat \<Rightarrow> nat set" where f: "f ` {..< card (Pow S)} = Pow S"
    by (metis bij_betw_imp_surj_on [OF bij_betw_from_nat_into_finite])
  obtain M0 where M0: "infinite M0" "M0 \<subseteq> M" "decides \<F> (f 0) M0"
    by (meson \<open>infinite M\<close> ex_infinite_decides_1)
  define F where "F \<equiv> rec_nat M0 (\<lambda>n N. @N'. N' \<subseteq> N \<and> infinite N' \<and> decides \<F> (f (Suc n)) N')"
  define \<Phi> where "\<Phi> \<equiv> \<lambda>n N'. N' \<subseteq> F n \<and> infinite N' \<and> decides \<F> (f (Suc n)) N'"
  have P_Suc: "F (Suc n) = (@N'. \<Phi> n N')" for n
    by (auto simp: F_def \<Phi>_def)
  have *: "infinite (F n) \<and> decides \<F> (f n) (F n) \<and> F n \<subseteq> M" for n
  proof (induction n)
    case (Suc n) then show ?case
      by (metis P_Suc \<Phi>_def ex_infinite_decides_1 someI_ex subset_trans)
  qed (auto simp: F_def M0)
  then have telescope: "F (Suc n) \<subseteq> F n" for n
    by (metis P_Suc \<Phi>_def ex_infinite_decides_1 someI_ex)
  let ?N = "\<Inter>n<card (Pow S). F n"
  show thesis
  proof
    show "?N \<subseteq> M"
      by (metis "*" INF_lower2 Pow_iff f imageE order_refl)
  next
    have eq: "(\<Inter>n\<le>m. F n) = F m" for m
      by (induction m) (use telescope in \<open>auto simp: atMost_Suc\<close>)
    then show "infinite ?N"
      by (metis "*" Suc_le_D Suc_le_eq finite_subset le_INF_iff lessThan_Suc_atMost lessThan_iff)
  next
    fix T
    assume "T \<subseteq> S"
    then obtain m where "f m = T" "m < card (Pow S)"
      using f by (blast elim: equalityE)
    then show "decides \<F> T ?N"
      by (metis "*" INT_lower decides_subset lessThan_iff)
  qed
qed

lemma sorted_wrt_subset: "\<lbrakk>X \<in> list.set l; sorted_wrt (\<le>) l\<rbrakk> \<Longrightarrow> hd l \<subseteq> X"
  by (induction l) auto

text \<open>Todor\v{c}evi{\'c}'s Lemma 1.18\<close>
proposition ex_infinite_decides_subsets:
  assumes "thin_set \<F>" "infinite M"
  obtains N where "N \<subseteq> M" "infinite N" "decides_subsets \<F> N"
proof -
  obtain M0 where M0: "infinite M0" "M0 \<subseteq> M" "decides \<F> {} M0"
    by (meson \<open>infinite M\<close> ex_infinite_decides_1)
  define decides_all where "decides_all \<equiv> \<lambda>S N. \<forall>T \<subseteq> S. decides \<F> T N"
  define \<Phi> where "\<Phi> \<equiv> \<lambda>NL N. N \<subseteq> hd NL \<and> Inf N > Inf (hd NL) \<and> infinite N \<and> decides_all (List.set (map Inf NL)) N"
  have "\<exists>N. \<Phi> NL N" if "infinite (hd NL)" for NL
  proof -
    obtain N where N: "N \<subseteq> hd NL \<and> infinite N \<and> decides_all (List.set (map Inf NL)) N"
      unfolding \<Phi>_def decides_all_def
      by (metis List.finite_set ex_infinite_decides_finite \<open>infinite (hd NL)\<close>)
    then have "Inf (N \<inter> {Inf (hd NL)<..}) > Inf (hd NL)"
      by (metis Inf_nat_def1 Int_iff finite.emptyI finite_nat_Int_greaterThan_iff greaterThan_iff)
    then show ?thesis
      unfolding \<Phi>_def
      by (meson Int_lower1 N decides_all_def decides_subset finite_nat_Int_greaterThan_iff subset_trans)
  qed
  then have \<Phi>_Eps: "\<Phi> NL (Eps (\<Phi> NL))" if "infinite (hd NL)" for NL
    by (simp add: someI_ex that)
  define F where "F \<equiv> rec_nat [M0] (\<lambda>n NL. (Eps (\<Phi> NL)) # NL)"
  have F_simps [simp]: "F 0 = [M0]" "F (Suc n) = Eps (\<Phi> (F n)) # F n" for n
    by (auto simp: F_def)
  have F: "F n \<noteq> [] \<and> sorted_wrt (\<le>) (F n) \<and> list.set (F n) \<subseteq> Collect infinite \<and> list.set (F n) \<subseteq> Pow M" for n
  proof (induction n)
    case 0
    then show ?case
      by (simp add: M0)
  next
    case (Suc n)
    then have *: "\<Phi> (F n) (Eps (\<Phi> (F n)))"
      using \<Phi>_Eps hd_in_set by blast
    show ?case
    proof (intro conjI)
      show "sorted_wrt (\<subseteq>) (F (Suc n))"
        using subset_trans [OF _ sorted_wrt_subset] Suc.IH \<Phi>_def "*" by auto
      show "list.set (F (Suc n)) \<subseteq> {S. infinite S}"
        using "*" \<Phi>_def Suc.IH by force
      show "list.set (F (Suc n)) \<subseteq> Pow M"
        using "*" Suc.IH \<Phi>_def hd_in_set by force
    qed auto
  qed
  have \<Phi>F: "\<Phi> (F n) (Eps (\<Phi> (F n)))" for n
    using F \<Phi>_Eps hd_in_set by blast
  then have decides: "decides_all (List.set (map Inf (F n))) (Eps (\<Phi> (F n)))" for n
    using \<Phi>_def by blast
  have Eps_subset_hd: "Eps (\<Phi> (F n)) \<subseteq> hd (F n) " for n
    using \<Phi>F \<Phi>_def by blast
  have "List.set (map Inf (F n)) \<subseteq> List.set (map Inf (F (Suc n)))" for n
    by auto
  then have map_Inf_subset: "m \<le> n \<Longrightarrow> List.set (map Inf (F m)) \<subseteq> List.set (map Inf (F n))" for m n
    by (rule order_class.lift_Suc_mono_le) auto
  define mmap where "mmap \<equiv> \<lambda>n. Inf (hd (F (Suc n)))"
  have "mmap n < mmap (Suc n)" for n
    by (metis F_simps(2) \<Phi>F \<Phi>_def list.sel(1) mmap_def)
  then have "strict_mono mmap"
    by (simp add: lift_Suc_mono_less strict_mono_def)
  then have "inj mmap"
    by (simp add: strict_mono_imp_inj_on)
  have finite_F_bound: "\<exists>n. S \<subseteq> List.set (map Inf (F n))"
    if S: "S \<subseteq> range mmap" "finite S" for S
  proof -
    obtain K where "finite K" "S \<subseteq> mmap ` K"
      by (metis S finite_subset_image order_refl)
    show ?thesis
    proof
      have "mmap ` K \<subseteq> list.set (map Inf (F (Suc (Max K))))"
        unfolding mmap_def image_subset_iff
        by (metis F Max_ge Suc_le_mono \<open>finite K\<close> hd_in_set imageI map_Inf_subset set_map subsetD)
      with S show "S \<subseteq> list.set (map Inf (F (Suc (Max K))))"
        using \<open>S \<subseteq> mmap ` K\<close> by auto
    qed
  qed
  have "Eps (\<Phi> (F (Suc n))) \<subseteq> Eps (\<Phi> (F n))" for n
    by (metis F_simps(2) \<Phi>F \<Phi>_def list.sel(1))
  then have Eps_\<Phi>_decreasing: "m \<le> n \<Longrightarrow> Eps (\<Phi> (F n)) \<subseteq> Eps (\<Phi> (F m))" for m n
    by (rule order_class.lift_Suc_antimono_le)
  have hd_Suc_eq_Eps: "hd (F (Suc n)) = Eps (\<Phi> (F n))" for n
    by simp
  have "Inf (hd (F n)) \<in> hd (F n)" for n
    by (metis Inf_nat_def1 \<Phi>F \<Phi>_def finite.emptyI rev_finite_subset)
  then have Inf_hd_in_Eps: "Inf (hd (F m)) \<in> Eps (\<Phi> (F n))" if "m>n" for m n
    by (metis Eps_\<Phi>_decreasing Nat.lessE hd_Suc_eq_Eps less_imp_le_nat subsetD that)
  then have image_mmap_subset_hd_F: "mmap ` {n..} \<subseteq> hd (F (Suc n))" for n
    by (metis hd_Suc_eq_Eps atLeast_iff image_subsetI le_imp_less_Suc mmap_def)
  have "list.set (F k) \<subseteq> list.set (F n)" if "k \<le> n" for k n
    by (rule order_class.lift_Suc_mono_le) (use that in auto)
  then have hd_F_in_F: "hd (F k) \<in> list.set (F n)" if "k \<le> n" for k n
    by (meson F hd_in_set subsetD that)
  show thesis
  proof
    show infinite_mm: "infinite (range mmap)"
      using \<open>inj mmap\<close> range_inj_infinite by blast
    show "range mmap \<subseteq> M"
      using Eps_subset_hd \<open>M0 \<subseteq> M\<close> image_mmap_subset_hd_F by fastforce
    show "decides_subsets \<F> (range mmap)"
      unfolding decides_subsets_def
    proof (intro strip)
      fix S
      assume "S \<subseteq> range mmap" "finite S"
      define n where "n \<equiv> LEAST n. S \<subseteq> List.set (map Inf (F n))"
      have "\<exists>m. S \<subseteq> List.set (map Inf (F m))"
        using \<open>S \<subseteq> range mmap\<close> \<open>finite S\<close> finite_F_bound by blast
      then have S: "S \<subseteq> List.set (map Inf (F n))" and minS: "\<And>m. m<n \<Longrightarrow> \<not> S \<subseteq> List.set (map Inf (F m))"
        unfolding n_def by (meson LeastI_ex not_less_Least)+
      have decides_Fn: "decides \<F> S (Eps (\<Phi> (F n)))"
        using S decides decides_all_def by blast
      show "decides \<F> S (range mmap)"
      proof (cases "n=0")
        case True
        then show ?thesis
          by (metis image_mmap_subset_hd_F decides_Fn decides_subset hd_Suc_eq_Eps atLeast_0)
      next
        case False
        have notin_map_Inf: "x \<notin> List.set (map Inf (F n))" if "S \<lless> {x}" for x
        proof clarsimp
          fix T
          assume "x = Inf T" and "T \<in> list.set (F n)"
          with that have ls: "S \<lless> {Inf T}"
            by auto
          have "S \<subseteq> List.set (map Inf (F j))" if T: "T \<in> list.set (F (Suc j))" for j
          proof clarsimp
            fix x
            assume "x \<in> S"
            then have "x < Inf T"
              using less_setsD ls by blast
            then have "x \<notin> T"
              using Inf_nat_def not_less_Least by auto
            obtain k where k: "x = mmap k"
              using \<open>S \<subseteq> range mmap\<close> \<open>x \<in> S\<close> by blast
            with T \<open>x < Inf T\<close> have "k < j"
              by (metis F Inf_hd_in_Eps \<open>x \<notin> T\<close> hd_Suc_eq_Eps mmap_def not_less_eq sorted_wrt_subset subsetD)
            then have "Eps (\<Phi> (F k)) \<in> list.set (F j)"
              by (metis Suc_leI hd_Suc_eq_Eps hd_F_in_F)
            then show "x \<in> Inf ` list.set (F j)"
              by (auto simp: k image_iff mmap_def)
          qed
          then obtain m where "m<n" "S \<subseteq> List.set (map Inf (F m))"
            using \<open>n \<noteq> 0\<close> by (metis \<open>T \<in> list.set (F n)\<close> lessI less_Suc_eq_0_disj)
          then show False
            using minS by blast
        qed
        have Inf_hd_F: "Inf (hd (F m)) \<in> Eps (\<Phi> (F n))" if "S \<lless> {Inf (hd (F m))}" for m
          by (metis Inf_hd_in_Eps hd_F_in_F notin_map_Inf imageI leI set_map that)
        have less_S: "S \<lless> {Inf (hd (F m))}"
          if "init_segment S T" "Inf (hd (F m)) \<in> T" "Inf (hd (F m)) \<notin> S" for T m
          using \<open>finite S\<close> that by (auto simp: init_segment_iff less_sets_def)
        consider "rejects \<F> S (Eps (\<Phi> (F n)))" | "strongly_accepts \<F> S (Eps (\<Phi> (F n)))"
          using decides_Fn by (auto simp: decides_def)
        then show ?thesis
        proof cases
          case 1
          then have "rejects \<F> S (range mmap)"
            apply (simp add: rejects_def disjoint_iff mmap_def comparables_def image_iff subset_iff)
            by (metis less_S Inf_hd_F hd_Suc_eq_Eps)
          then show ?thesis
            by (auto simp: decides_def)
        next
          case 2
          have False
            if "N \<subseteq> range mmap" and "rejects \<F> S N" and "infinite N" for N
          proof -
            have "N = mmap ` {n..} \<inter> N \<union> mmap ` {..<n} \<inter> N"
              using in_mono that(1) by fastforce
            then have "infinite (mmap ` {n..} \<inter> N)"
              by (metis finite_Int finite_Un finite_imageI finite_lessThan that(3))
            moreover have "rejects \<F> S (mmap ` {n..} \<inter> N)"
              using rejects_subset \<open>rejects \<F> S N\<close> by fastforce
            moreover have "mmap ` {n..} \<inter> N \<subseteq>Eps (\<Phi> (F n))"
              using image_mmap_subset_hd_F by fastforce
            ultimately show ?thesis
              using 2 by (auto simp: strongly_accepts_def)
          qed
          with 2 show ?thesis
            by (auto simp: decides_def strongly_accepts_def)
        qed
      qed
    qed
  qed
qed

text \<open>Todor\v{c}evi{\'c}'s Lemma 1.19\<close>
proposition strongly_accepts_1_19:
  assumes acc: "strongly_accepts \<F> S M"
    and "thin_set \<F>" "infinite M" "S \<subseteq> M" "finite S"
    and dsM: "decides_subsets \<F> M"
  shows "finite {n \<in> M. \<not> strongly_accepts \<F> (insert n S) M}"
proof (rule ccontr)
  define N where "N \<equiv> {n \<in> M. rejects \<F> (insert n S) M} \<inter> {Sup S<..}"
  have "N \<subseteq> M" and N: "\<And>n. n \<in> N \<longleftrightarrow> n \<in> M \<and> rejects \<F> (insert n S) M \<and> n > Sup S"
    by (auto simp: N_def)
  assume "\<not> ?thesis"
  moreover have "{n \<in> M. \<not> strongly_accepts \<F> (insert n S) M} = {n \<in> M. rejects \<F> (insert n S) M}"
    using dsM \<open>finite S\<close> \<open>infinite M\<close> \<open>S \<subseteq> M\<close> unfolding decides_subsets_def
    by (meson decides_def finite.insertI insert_subset strongly_accepts_imp_accepts)
  ultimately have "infinite N"
    by (simp add: N_def finite_nat_Int_greaterThan_iff)
  then have "accepts \<F> S N"
    using acc strongly_accepts_def \<open>N \<subseteq> M\<close> by blast
  then obtain T where T: "T \<in> comparables S N" "T \<in> \<F>" and TSN: "T \<subseteq> S \<union> N"
    unfolding rejects_def using comparables_iff init_segment_subset by fastforce
  then consider "init_segment T S" | "init_segment S T" "S\<noteq>T" "\<not> init_segment T S"
    by (auto simp: comparables_def)
  then show False
  proof cases
    case 1
    then have "init_segment T (insert n S)" if "n \<in> N" for n
      by (meson Sup_nat_less_sets_singleton N \<open>finite S\<close> init_segment_insert that)
    with \<open>infinite N\<close> \<open>thin_set \<F>\<close> \<open>T \<in> \<F>\<close> show False
      by (meson N infinite_nat_iff_unbounded rejects_trivial)
  next
    let ?n = "Min (T-S)"
    case 2
    then obtain TS: "?n \<in> T-S" "finite (T-S)"
      using T unfolding comparables_iff
      by (meson Diff_eq_empty_iff Min_in finite_Diff init_segment_subset subset_antisym)
    then have "?n \<in> N"
      by (meson Diff_subset_conv TSN in_mono)
    then have "rejects \<F> (insert ?n S) N"
      using rejects_subset \<open>N \<subseteq> M\<close> by (auto simp: N_def)
    then have \<section>: "\<not> init_segment T (insert ?n S) \<and> (init_segment (insert ?n S) T \<longrightarrow> insert ?n S = T)"
      using T Diff_partition TSN \<open>?n \<in> N\<close> \<open>finite S\<close>
      by (auto simp: rejects_def comparables_iff disjoint_iff)
    moreover have "S \<lless> {?n}"
      using Sup_nat_less_sets_singleton N \<open>?n \<in> N\<close> \<open>finite S\<close> by blast
    ultimately show ?thesis
      using 2 TS Min_in init_segment_insert_iff by fastforce
  qed
qed

text \<open>Much work is needed for this slight strengthening of the previous result!\<close>
proposition strongly_accepts_1_19_plus:
  assumes "thin_set \<F>" "infinite M"
    and dsM: "decides_subsets \<F> M"
  obtains N where "N \<subseteq> M" "infinite N"
       "\<And>S n. \<lbrakk>S \<subseteq> N; finite S; strongly_accepts \<F> S N; n \<in> N; S \<lless> {n}\<rbrakk>
              \<Longrightarrow> strongly_accepts \<F> (insert n S) N"
proof -
  define insert_closed where
    "insert_closed \<equiv> \<lambda>NL N. \<forall>T \<subseteq> Inf ` set NL. \<forall>n \<in> N.
                      strongly_accepts \<F> T ((Inf ` set NL) \<union> hd NL) \<longrightarrow>
                      T \<lless> {n} \<longrightarrow> strongly_accepts \<F> (insert n T) ((Inf ` set NL) \<union> hd NL)"
  define \<Phi> where "\<Phi> \<equiv> \<lambda>NL N. N \<subseteq> hd NL \<and> Inf N > Inf (hd NL) \<and> infinite N \<and> insert_closed NL N"
  have "\<exists>N. \<Phi> NL N" if NL: "infinite (hd NL)" "Inf ` set NL \<union> hd NL \<subseteq> M" for NL
  proof -
    let ?m = "Inf ` set NL"
    let ?M = "?m \<union> hd NL"
    define P where "P \<equiv> \<lambda>S. {n \<in> ?M. \<not> strongly_accepts \<F> (insert n S) ?M}"
    have "\<exists>k. P S \<subseteq> {..k}"
      if "S \<subseteq> Inf ` set NL" "strongly_accepts \<F> S ?M" for S
    proof -
      have "decides_subsets \<F> ?M"
        using NL(2) decides_subsets_subset dsM by blast
      with that NL assms finite_surj have "finite (P S)"
        unfolding P_def by (blast intro!: strongly_accepts_1_19)
      then show ?thesis
        by (simp add: finite_nat_iff_bounded_le)
    qed
    then obtain f where f: "\<And>S. \<lbrakk>S \<subseteq> Inf ` set NL; strongly_accepts \<F> S ?M\<rbrakk> \<Longrightarrow> P S \<subseteq> {..f S}"
      by metis
    define m where "m \<equiv> Max (insert (Inf (hd NL)) (f ` Pow (Inf ` set NL)))"
    have \<section>: "strongly_accepts \<F> (insert n S) ?M"
      if S: "S \<subseteq> Inf ` set NL" "strongly_accepts \<F> S ?M" and n: "n \<in> hd NL \<inter> {m<..}" for S n
    proof -
      have "f S \<le> m"
        unfolding m_def using that(1) by auto
      then show ?thesis
        using f [OF S] n unfolding P_def by auto
    qed
    have "\<Phi> NL (hd NL \<inter> {m<..})"
      unfolding \<Phi>_def
    proof (intro conjI)
      show "infinite (hd NL \<inter> {m<..})"
        by (simp add: finite_nat_Int_greaterThan_iff that(1))
      moreover have "Inf (hd NL) \<le> m"
        by (simp add: m_def)
      ultimately show "Inf (hd NL) < Inf (hd NL \<inter> {m<..})"
        using Inf_nat_def1 [of "(hd NL \<inter> {m<..})"] by force
      show "insert_closed NL (hd NL \<inter> {m<..})"
        by (auto intro: \<section> simp: insert_closed_def)
    qed auto
    then show ?thesis ..
  qed
  then have \<Phi>_Eps: "\<Phi> NL (Eps (\<Phi> NL))" if "infinite (hd NL)" "(Inf ` set NL) \<union> hd NL \<subseteq> M" for NL
    by (meson someI_ex that)
  define F where "F \<equiv> rec_nat [M] (\<lambda>n NL. (Eps (\<Phi> NL)) # NL)"
  have F_simps [simp]: "F 0 = [M]" "F (Suc n) = Eps (\<Phi> (F n)) # F n" for n
    by (auto simp: F_def)
  have InfM: "Inf M \<in> M"
    by (metis Inf_nat_def1 assms(2) finite.emptyI)
  have F: "F n \<noteq> [] \<and> sorted_wrt (\<le>) (F n) \<and> list.set (F n) \<subseteq> Collect infinite \<and> set (F n) \<subseteq> Pow M \<and> Inf ` set (F n) \<subseteq> M" for n
  proof (induction n)
    case (Suc n)
    have "hd (F n) \<subseteq> M"
      by (meson Pow_iff Suc.IH hd_in_set subsetD)
    then obtain \<Phi>: "Ball (list.set (F n)) ((\<subseteq>) (Eps (\<Phi> (F n))))" "infinite (Eps (\<Phi> (F n)))"
      using order_trans [OF _ sorted_wrt_subset]
      by (metis Suc.IH Un_subset_iff \<Phi>_Eps \<Phi>_def hd_in_set mem_Collect_eq subsetD)
    then have M: "Eps (\<Phi> (F n)) \<subseteq> M"
      by (meson Pow_iff Suc.IH hd_in_set subset_iff)
    with \<Phi> have "Inf (Eps (\<Phi> (F n))) \<in> M"
      by (metis Inf_nat_def1 finite.simps in_mono)
    with \<Phi> M show ?case
      using Suc by simp
  qed (auto simp: InfM \<open>infinite M\<close>)
  have \<Phi>F: "\<Phi> (F n) (Eps (\<Phi> (F n)))" for n
    by (metis Ball_Collect F Pow_iff Un_subset_iff \<Phi>_Eps hd_in_set subsetD)
  then have insert_closed: "insert_closed (F n) (Eps (\<Phi> (F n)))" for n
    using \<Phi>_def by blast
  have Eps_subset_hd: "Eps (\<Phi> (F n)) \<subseteq> hd (F n)" for n
    using \<Phi>F \<Phi>_def by blast
  define mmap where "mmap \<equiv> \<lambda>n. Inf (hd (F (Suc n)))"
  have "mmap n < mmap (Suc n)" for n
    by (metis F_simps(2) \<Phi>F \<Phi>_def list.sel(1) mmap_def)
  then have "strict_mono mmap"
    by (simp add: lift_Suc_mono_less strict_mono_def)
  then have "inj mmap"
    by (simp add: strict_mono_imp_inj_on)
  have "Eps (\<Phi> (F (Suc n))) \<subseteq> Eps (\<Phi> (F n))" for n
    by (metis F_simps(2) \<Phi>F \<Phi>_def list.sel(1))
  then have Eps_\<Phi>_decreasing: "m \<le> n \<Longrightarrow> Eps (\<Phi> (F n)) \<subseteq> Eps (\<Phi> (F m))" for m n
    by (rule order_class.lift_Suc_antimono_le)
  have hd_Suc_eq_Eps: "hd (F (Suc n)) = Eps (\<Phi> (F n))" for n
    by simp
  have "Inf (hd (F n)) \<in> hd (F n)" for n
    by (metis Inf_nat_def1 \<Phi>F \<Phi>_def finite.emptyI finite_subset)
  then have Inf_hd_in_Eps: "Inf (hd (F m)) \<in> Eps (\<Phi> (F n))" if "m>n" for m n
    by (metis Eps_\<Phi>_decreasing Nat.lessE hd_Suc_eq_Eps nat_less_le subsetD that)
  then have image_mmap_subset_hd_F: "mmap ` {n..} \<subseteq> hd (F (Suc n))" for n
    by (metis hd_Suc_eq_Eps atLeast_iff image_subsetI le_imp_less_Suc mmap_def)
  have "list.set (F k) \<subseteq> list.set (F n)" if "k \<le> n" for k n
    by (rule order_class.lift_Suc_mono_le) (use that in auto)
  then have hd_F_in_F: "hd (F k) \<in> list.set (F n)" if "k \<le> n" for k n
    by (meson F hd_in_set subsetD that)
  show ?thesis
  proof
    show infinite_mm: "infinite (range mmap)"
      using \<open>inj mmap\<close> range_inj_infinite by blast
    show "range mmap \<subseteq> M"
      using Eps_subset_hd image_mmap_subset_hd_F by fastforce
  next
    fix S a
    assume S: "S \<subseteq> range mmap" "finite S" and acc: "strongly_accepts \<F> S (range mmap)"
       and a: "a \<in> range mmap" and Sn: "S \<lless> {a}"
    then obtain n where n: "a = mmap n"
      by auto
    define N where "N \<equiv> LEAST n. S \<subseteq> mmap ` {..<n}"
    have "\<exists>n. S \<subseteq> mmap ` {..<n}"
      by (metis S finite_nat_iff_bounded finite_subset_image image_mono)
    then have S: "S \<subseteq> mmap ` {..<N}" and minS: "\<And>m. m<N \<Longrightarrow> \<not> S \<subseteq> mmap ` {..<m}"
      unfolding N_def by (meson LeastI_ex not_less_Least)+
    have range_mmap_subset: "range mmap \<subseteq> Inf ` list.set (F n) \<union> hd (F n)" for n
    proof (induction n)
      case 0
      then show ?case
        using Eps_subset_hd image_mmap_subset_hd_F by fastforce
    next
      case (Suc n)
      then show ?case
        by clarsimp (metis Inf_hd_in_Eps hd_F_in_F image_iff leI mmap_def)
    qed
    have subM: "(Inf ` list.set (F N) \<union> hd (F N)) \<subseteq> M"
      by (meson F PowD hd_in_set subsetD sup.boundedI)
    have "strongly_accepts \<F> (insert a S) (Inf ` list.set (F N) \<union> hd (F N))"
    proof (rule insert_closed [unfolded insert_closed_def, rule_format])
      have "mmap ` {..<N} \<subseteq> Inf ` list.set (F N)"
        using Suc_leI hd_F_in_F by (fastforce simp: mmap_def le_eq_less_or_eq)
      with S show Ssub: "S \<subseteq> Inf ` list.set (F N)"
        by auto
      have "S \<subseteq> mmap ` {..<n}"
        using Sn S \<open>strict_mono mmap\<close> strict_mono_less
        by (fastforce simp: less_sets_def n image_iff subset_iff Bex_def)
      with leI minS have "n\<ge>N" by blast
      then show "a \<in> Eps (\<Phi> (F N))"
        using image_mmap_subset_hd_F n by fastforce
      show "strongly_accepts \<F> S (Inf ` list.set (F N) \<union> hd (F N))"
      proof (rule ccontr)
        assume "\<not> strongly_accepts \<F> S (Inf ` list.set (F N) \<union> hd (F N))"
        then have "rejects \<F> S (Inf ` list.set (F N) \<union> hd (F N))"
          using dsM subM unfolding decides_subsets_def
          by (meson F Ssub \<open>finite S\<close> decides_def decides_subset subset_trans)
        moreover have "accepts \<F> S (range mmap)"
          using \<open>inj mmap\<close> acc range_inj_infinite strongly_accepts_imp_accepts by blast
        ultimately show False
          by (meson range_mmap_subset rejects_subset)
      qed
    qed (auto simp: Sn)
    then show "strongly_accepts \<F> (insert a S) (range mmap)"
      using range_mmap_subset strongly_accepts_subset by auto
  qed
qed

subsection \<open>Main Theorem\<close>

lemma Nash_Williams_1: "Ramsey \<F> 1"
  by (auto simp: Ramsey_eq)

theorem Nash_Williams_2:
  assumes "thin_set \<F>" shows "Ramsey \<F> 2"
  unfolding Ramsey_eq
proof clarify
  fix f :: "nat set \<Rightarrow> nat" and M :: "nat set"
  assume "infinite M" and f2: "f \<in> \<F> \<rightarrow> {..<2}"
  let ?\<F> = "\<lambda>i. f -` {i} \<inter> \<F>"  \<comment>\<open>needed with @{thm[source] Ramsey_eq}, not with  @{thm[source] Ramsey_def}\<close>
  have \<F>: "?\<F> 0 \<union> ?\<F> 1 = \<F>"
    using f2 less_2_cases by (auto simp: PiE)
  have fin\<F>: "\<And>X. X \<in> \<F> \<Longrightarrow> finite X" and thin: "\<And>i. thin_set (?\<F> i)"
    using assms thin_set_def by auto
  then obtain N where "N \<subseteq> M" "infinite N" and N: "decides_subsets (?\<F> 0) N"
    using \<open>infinite M\<close> ex_infinite_decides_subsets by blast
  then consider "rejects (?\<F> 0) {} N" | "strongly_accepts (?\<F> 0) {} N"
    unfolding decides_def decides_subsets_def by blast
  then show "\<exists>N i. N \<subseteq> M \<and> infinite N \<and> i<2 \<and> \<F> \<inter> Pow N \<subseteq> f -` {i}"
  proof cases
    case 1
    then have "(?\<F> 0 \<union> ?\<F> 1) \<inter> Pow N \<subseteq> f -` {1}"
      using f2 fin\<F>
      by (force simp add: Fpow_def rejects_def disjoint_iff comparables_iff Pi_iff less_2_cases_iff simp flip: neq0_conv)
    then show ?thesis
      by (metis \<F> Suc_1 \<open>N \<subseteq> M\<close> \<open>infinite N\<close> lessI)
  next
    case 2
    then have \<section>: "\<And>P. \<lbrakk>P\<subseteq>N; \<And>S. \<lbrakk>S \<subseteq> P; finite S\<rbrakk> \<Longrightarrow> S \<notin> ?\<F> 0\<rbrakk> \<Longrightarrow> finite P"
      by (auto simp: Fpow_def disjoint_iff)
    obtain P where "P \<subseteq> N" "infinite P" and P:
      "\<And>S n. \<lbrakk>S \<subseteq> P; finite S; strongly_accepts (?\<F> 0) S P; n \<in> P; S \<lless> {n}\<rbrakk>
              \<Longrightarrow> strongly_accepts (?\<F> 0) (insert n S) P"
      using strongly_accepts_1_19_plus [OF thin \<open>infinite N\<close> N] by blast
    have "\<F> \<inter> Pow P \<subseteq> f -` {0}"
    proof (clarsimp simp: subset_vimage_iff)
      fix T
      assume T: "T \<in> \<F>" and "T \<subseteq> P"
      then have "finite T"
        using fin\<F> by blast
      moreover have "strongly_accepts (?\<F> 0) S P" if "finite S" "S \<subseteq> P" for S
        using that
      proof (induction "card S" arbitrary: S)
        case (Suc n)
        then have Seq: "S = insert (Sup S) (S - {Sup S})"
          using Sup_nat_def Max_eq_iff by fastforce
        then have sacc: "strongly_accepts (?\<F> 0) (S - {Sup S}) P"
          by (metis Suc card_Diff_singleton diff_Suc_1 finite_Diff insertCI insert_subset)
        have "S - {Sup S} \<lless> {Sup S}"
          using Suc by (simp add: Sup_nat_def dual_order.strict_iff_order less_sets_def)
        then have "strongly_accepts (?\<F> 0) (insert (Sup S) (S - {Sup S})) P"
          by (metis P Seq Suc.prems finite_Diff insert_subset sacc)
        then show ?case
          using Seq by auto
      qed (use 2 \<open>P \<subseteq> N\<close> in auto)
      ultimately have "\<exists>x\<in>comparables T P. f x = 0 \<and> x \<in> \<F>"
        using \<open>T \<subseteq> P\<close> \<open>infinite P\<close> rejects_def strongly_accepts_def by fastforce
      then show "f T = 0"
        using T assms thin_set_def comparables_def by force
    qed
    then show ?thesis
      by (meson \<open>N \<subseteq> M\<close> \<open>P \<subseteq> N\<close> \<open>infinite P\<close> less_2_cases_iff subset_trans)
  qed
qed

theorem Nash_Williams:
  assumes \<F>: "thin_set \<F>" "r > 0" shows "Ramsey \<F> r"
  using \<open>r > 0\<close>
proof (induction r)
  case (Suc r)
  show ?case
  proof (cases "r<2")
    case True
    with less_2_cases Nash_Williams_1 Nash_Williams_2 assms show ?thesis
      by (auto simp: numeral_2_eq_2)
  next
    case False
    with Suc.IH have Ram: "Ramsey \<F> r" "r \<ge> 2"
      by auto
    show ?thesis
      unfolding Ramsey_eq
    proof clarify
      fix f and M :: "nat set"
      assume fim: "f \<in> \<F> \<rightarrow> {..<Suc r}"
        and "infinite M"
      let ?within = "\<lambda>g i N. \<F> \<inter> Pow N \<subseteq> g -` {i}"
      define g where "g \<equiv> \<lambda>x. if f x = r then r-1 else f x"
      have gim: "g \<in> \<F> \<rightarrow> {..<r}"
        using fim False by (force simp: g_def)
      then obtain N i where "N \<subseteq> M" "infinite N" "i<r" and i: "?within g i N"
        using Ram \<open>infinite M\<close> by (metis Ramsey_eq)
      show "\<exists>N j. N \<subseteq> M \<and> infinite N \<and> j < Suc r \<and> ?within f j N"
      proof (cases "i<r-1")
        case True
        then have "?within f i N"
          using \<open>N \<subseteq> M\<close> \<open>infinite N\<close> \<open>i<r\<close> i by (fastforce simp add: g_def)
        then show ?thesis
          by (meson \<open>N \<subseteq> M\<close> \<open>i < r\<close> \<open>infinite N\<close> less_Suc_eq)
      next
        case False
        then have "i = r-1"
          using \<open>i<r\<close> by linarith
        then have null: "\<F> \<inter> Pow N \<subseteq> f -` {i,r}"
          using i \<open>i < r\<close>
          by (auto simp: g_def split: if_split_asm)
        define h where "h \<equiv> \<lambda>x. if f x = r then 0 else f x"
        have him: "h \<in> \<F> \<rightarrow> {..<r}"
          using fim i False \<open>i<r\<close> by (force simp: h_def)
        then obtain P j where "P \<subseteq> N" "infinite P" "j<r" and j: "?within h j P"
          using Ram \<open>i < r\<close> \<open>infinite N\<close> unfolding Ramsey_eq by metis
        have "\<exists>i < Suc r. ?within f i P"
        proof (cases "j=0")
          case True
          then have "\<F> \<inter> Pow P \<subseteq> f -` {r}"
            using Ram(2) \<open>P \<subseteq> N\<close> \<open>i = r - 1\<close>  i j
            unfolding subset_vimage_iff g_def h_def
            by (metis Int_iff Pow_iff Suc_1 diff_is_0_eq insert_iff not_less_eq_eq subset_trans)
          then show ?thesis
            by blast
        next
          case False
          then show ?thesis
            using j \<open>j < r\<close> by (fastforce simp add: h_def less_Suc_eq)
        qed
        then show ?thesis
          by (meson \<open>N \<subseteq> M\<close> \<open>P \<subseteq> N\<close> \<open>infinite P\<close> subset_trans)
      qed
    qed
  qed
qed auto

end


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

chapter "Cartesian Closed Category"

theory CartesianClosedCategory
imports CartesianCategory
begin

  text\<open>
    A \emph{cartesian closed category} is a cartesian category such that,
    for every object \<open>b\<close>, the functor \<open>prod \<hyphen> b\<close> is a left adjoint functor.
    A right adjoint to this functor takes each object \<open>c\<close> to the \emph{exponential}
    \<open>exp b c\<close>.  The adjunction yields a natural bijection between \<open>hom (prod a b) c\<close>
    and \<open>hom a (exp b c)\<close>.
  \<close>

  locale cartesian_closed_category =
    cartesian_category C
  for C :: "'a comp" +
  assumes left_adjoint_prod: "\<And>b. ide b \<Longrightarrow> left_adjoint_functor C C (\<lambda>x. prod x b)"

  locale elementary_cartesian_closed_category =
    elementary_cartesian_category C pr0 pr1 one trm
  for C :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"  (infixr \<open>\<cdot>\<close> 55)
  and pr0 :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"  (\<open>\<pp>\<^sub>0[_, _]\<close>)
  and pr1 :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"  (\<open>\<pp>\<^sub>1[_, _]\<close>)
  and one :: "'a"              (\<open>\<one>\<close>)
  and trm :: "'a \<Rightarrow> 'a"        (\<open>\<t>[_]\<close>)
  and exp :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  and eval :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  and \<Lambda> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" +
  assumes eval_in_hom: "\<lbrakk> ide b; ide c \<rbrakk> \<Longrightarrow> \<guillemotleft>eval b c : prod (exp b c) b \<rightarrow> c\<guillemotright>"
  and ide_exp: "\<lbrakk> ide b; ide c \<rbrakk> \<Longrightarrow> ide (exp b c)"
  and lam_in_hom: "\<lbrakk> ide a; ide b; ide c; \<guillemotleft>g : prod a b \<rightarrow> c\<guillemotright> \<rbrakk> \<Longrightarrow> \<guillemotleft>\<Lambda> a b c g : a \<rightarrow> exp b c\<guillemotright>"
  and eval_prod_lam: "\<lbrakk> ide a; ide b; ide c; \<guillemotleft>g : prod a b \<rightarrow> c\<guillemotright> \<rbrakk>
                          \<Longrightarrow> C (eval b c) (prod (\<Lambda> a b c g) b) = g"
  and lam_eval_prod: "\<lbrakk> ide a; ide b; ide c; \<guillemotleft>h : a \<rightarrow> exp b c\<guillemotright> \<rbrakk>
                          \<Longrightarrow> \<Lambda> a b c (C (eval b c) (prod h b)) = h"

  context cartesian_closed_category
  begin

    lemma has_exponentials:
    assumes "ide b" and "ide c"
    shows "\<exists>x e. ide x \<and> \<guillemotleft>e : prod x b \<rightarrow> c\<guillemotright> \<and>
                 (\<forall>a g. ide a \<and> \<guillemotleft>g : prod a b \<rightarrow> c\<guillemotright> \<longrightarrow> (\<exists>!f. \<guillemotleft>f : a \<rightarrow> x\<guillemotright> \<and> g = C e (prod f b)))"
    proof -
      interpret F: left_adjoint_functor C C \<open>\<lambda>x. prod x b\<close>
        using assms(1) left_adjoint_prod by simp
      obtain x e where e: "terminal_arrow_from_functor C C (\<lambda>x. prod x b) x c e"
        using assms F.ex_terminal_arrow [of c] by auto
      interpret e: terminal_arrow_from_functor C C \<open>\<lambda>x. prod x b\<close> x c e
        using e by simp
      have "\<And>a g. \<lbrakk> ide a; \<guillemotleft>g : prod a b \<rightarrow> c\<guillemotright> \<rbrakk> \<Longrightarrow> \<exists>!f. \<guillemotleft>f : a \<rightarrow> x\<guillemotright> \<and> g = C e (prod f b)"
        using e.is_terminal category_axioms F.functor_axioms
        unfolding e.is_coext_def arrow_from_functor_def arrow_from_functor_axioms_def
        by simp
      thus ?thesis
        using e.arrow by metis
    qed

    definition exp
    where "exp b c \<equiv> SOME x. ide x \<and>
                              (\<exists>e. \<guillemotleft>e : prod x b \<rightarrow> c\<guillemotright> \<and>
                                   (\<forall>a g. ide a \<and> \<guillemotleft>g : prod a b \<rightarrow> c\<guillemotright>
                                           \<longrightarrow> (\<exists>!f. \<guillemotleft>f : a \<rightarrow> x\<guillemotright> \<and> g = C e (prod f b))))"

    definition eval
    where "eval b c \<equiv> SOME e. \<guillemotleft>e : prod (exp b c) b \<rightarrow> c\<guillemotright> \<and>
                              (\<forall>a g. ide a \<and> \<guillemotleft>g : prod a b \<rightarrow> c\<guillemotright>
                                       \<longrightarrow> (\<exists>!f. \<guillemotleft>f : a \<rightarrow> exp b c\<guillemotright> \<and> g = C e (prod f b)))"

    definition \<Lambda>
    where "\<Lambda> a b c g \<equiv> THE f. \<guillemotleft>f : a \<rightarrow> exp b c\<guillemotright> \<and> g = C (eval b c) (prod f b)"

    lemma ex_un_lam:
    assumes "ide b" and "ide c"
    shows "ide (exp b c)" and "\<guillemotleft>eval b c : prod (exp b c) b \<rightarrow> c\<guillemotright>"
    and "\<lbrakk> ide a; \<guillemotleft>g : prod a b \<rightarrow> c\<guillemotright> \<rbrakk> \<Longrightarrow> \<exists>!f. \<guillemotleft>f : a \<rightarrow> exp b c\<guillemotright> \<and> g = C (eval b c) (prod f b)"
      using assms exp_def eval_def has_exponentials
            someI_ex [of "\<lambda>x. ide x \<and> (\<exists>e. \<guillemotleft>e : prod x b \<rightarrow> c\<guillemotright> \<and>
                                           (\<forall>a g. ide a \<and> \<guillemotleft>g : prod a b \<rightarrow> c\<guillemotright>
                                              \<longrightarrow> (\<exists>!f. \<guillemotleft>f : a \<rightarrow> x\<guillemotright> \<and> g = C e (prod f b))))"]
            someI_ex [of "\<lambda>e. \<guillemotleft>e : prod (exp b c) b \<rightarrow> c\<guillemotright> \<and>
                              (\<forall>a g. ide a \<and> \<guillemotleft>g : prod a b \<rightarrow> c\<guillemotright>
                                           \<longrightarrow> (\<exists>!f. \<guillemotleft>f : a \<rightarrow> exp b c\<guillemotright> \<and> g = C e (prod f b)))"]
      by auto

    lemma eval_in_hom [intro]:
    assumes "ide b" and "ide c"
    shows "\<guillemotleft>eval b c : prod (exp b c) b \<rightarrow> c\<guillemotright>"
      using assms ex_un_lam by simp

    lemma eval_prod_lam:
    assumes "ide a" and "ide b" and "ide c" and "\<guillemotleft>g : prod a b \<rightarrow> c\<guillemotright>"
    shows "\<guillemotleft>\<Lambda> a b c g : a \<rightarrow> exp b c\<guillemotright> \<and> g = C (eval b c) (prod (\<Lambda> a b c g) b)"
      using assms \<Lambda>_def ex_un_lam
            theI' [of "\<lambda>f. \<guillemotleft>f : a \<rightarrow> exp b c\<guillemotright> \<and> g = C (eval b c) (prod f b)"]
      by simp

    lemma lam_eval_prod:
    assumes "ide a" and "ide b" and "ide c" and "\<guillemotleft>h : a \<rightarrow> exp b c\<guillemotright>"
    shows "\<Lambda> a b c (C (eval b c) (prod h b)) = h"
    proof -
      have "\<exists>!f. \<guillemotleft>f : a \<rightarrow> exp b c\<guillemotright> \<and> C (eval b c) (prod h b) = C (eval b c) (prod f b)"
      proof -
        have "ide a \<and> \<guillemotleft>C (eval b c) (prod h b) : prod a b \<rightarrow> c\<guillemotright>"
        proof (intro conjI)
          show "ide a" by fact
          show "\<guillemotleft>C (eval b c) (prod h b) : prod a b \<rightarrow> c\<guillemotright>"
            using assms by (intro comp_in_homI) auto
        qed
        thus ?thesis
          using assms ex_un_lam by simp
      qed
      moreover have "\<guillemotleft>h : a \<rightarrow> exp b c\<guillemotright> \<and> C (eval b c) (prod h b) = C (eval b c) (prod h b)"
        using assms by simp
      ultimately show ?thesis
        using assms \<Lambda>_def ex_un_lam eval_prod_lam
              the1_equality [of "\<lambda>f. \<guillemotleft>f : a \<rightarrow> exp b c\<guillemotright> \<and>
                                     C (eval b c) (prod h b) = C (eval b c) (prod f b)"]
        by simp
    qed

    interpretation elementary_cartesian_closed_category C pr0 pr1 \<one> trm exp eval \<Lambda>
      using eval_in_hom ex_un_lam eval_prod_lam lam_eval_prod
      apply unfold_locales by auto

    lemma induces_elementary_cartesian_closed_category:
    shows "elementary_cartesian_closed_category C pr0 pr1 \<one> trm exp eval \<Lambda>"
      ..

  end

  context elementary_cartesian_closed_category
  begin

    lemma left_adjoint_prod:
    assumes "ide b"
    shows "left_adjoint_functor C C (\<lambda>x. x \<otimes> b)"
    proof -
      interpret "functor" C C \<open>\<lambda>x. x \<otimes> b\<close>
      proof
        show "\<And>f. \<not> arr f \<Longrightarrow> f \<otimes> b = null"
          using tuple_ext prod_def by auto
        fix f
        show "arr f \<Longrightarrow> dom (f \<otimes> b) = dom f \<otimes> b"
          using assms by simp
        show "arr f \<Longrightarrow> arr (f \<otimes> b)"
          using assms by simp
        show "arr f \<Longrightarrow> cod (f \<otimes> b) = cod f \<otimes> b"
          using assms by simp
        fix g
        show "seq g f \<Longrightarrow> g \<cdot> f \<otimes> b = (g \<otimes> b) \<cdot> (f \<otimes> b)"
          using assms interchange by simp
      qed
      interpret left_adjoint_functor C C \<open>\<lambda>x. x \<otimes> b\<close>
      proof
        show "\<And>c. ide c \<Longrightarrow> \<exists>x e. terminal_arrow_from_functor C C (\<lambda>x. x \<otimes> b) x c e"
        proof -
          fix c
          assume c: "ide c"
          show "\<exists>x e. terminal_arrow_from_functor C C (\<lambda>x. x \<otimes> b) x c e"
          proof (intro exI)
            interpret arrow_from_functor C C \<open>\<lambda>x. x \<otimes> b\<close> \<open>exp b c\<close> c \<open>eval b c\<close>
            proof
              show "ide (exp b c) \<and> \<guillemotleft>eval b c : exp b c \<otimes> b \<rightarrow> c\<guillemotright>"
              proof (intro conjI)
                show "\<guillemotleft>eval b c : exp b c \<otimes> b \<rightarrow> c\<guillemotright>"
                  using assms c eval_in_hom by simp
                show "ide (exp b c)"
                  using assms c ide_exp by simp
              qed
            qed
            interpret terminal_arrow_from_functor C C \<open>\<lambda>x. x \<otimes> b\<close> \<open>exp b c\<close> c \<open>eval b c\<close>
            proof
              show "\<And>a f. arrow_from_functor C C (\<lambda>x. x \<otimes> b) a c f \<Longrightarrow>
                            \<exists>!g. arrow_from_functor.is_coext C C
                                   (\<lambda>x. x \<otimes> b) (exp b c) (eval b c) a f g"
              proof -
                fix a f
                assume f: "arrow_from_functor C C (\<lambda>x. x \<otimes> b) a c f"
                interpret f: arrow_from_functor C C \<open>\<lambda>x. x \<otimes> b\<close> a c f
                  using f by simp
                show "\<exists>!g. is_coext a f g"
                proof
                  have a: "ide a"
                    using f.arrow by simp
                  show "is_coext a f (\<Lambda> a b c f)"
                    unfolding is_coext_def
                    using assms a c lam_in_hom [of a b c f] eval_prod_lam [of a b c f]
                          f.arrow
                    by simp
                  show "\<And>g. is_coext a f g \<Longrightarrow> g = \<Lambda> a b c f"
                    unfolding is_coext_def
                    using assms a c lam_eval_prod [of a b c] f.arrow by simp
                qed
              qed
            qed
            show "terminal_arrow_from_functor C C (\<lambda>x. x \<otimes> b) (exp b c) c (eval b c)" ..
          qed
        qed
      qed
      show ?thesis ..
    qed

    interpretation CCC: cartesian_category C
      using is_cartesian_category by simp

    interpretation CCC: cartesian_closed_category C
    proof
      fix b
      assume b: "ide b"
      interpret left_adjoint_functor C C \<open>\<lambda>x. CCC.prod x b\<close>
      proof -
        (*
         * We know that (\<lambda>x. x \<otimes> b) is a left adjoint functor, where \<otimes> is the
         * product ultimately defined in terms of the projections that are parameters
         * to the elementary_category_with_binary_products locale that is the present context.
         * This is not necessarily the same as (\<lambda>x. CCC.prod x b), which is defined in terms
         * of projections chosen arbitrarily in category_with_binary_products.
         * However, since they are both categorical products, they are naturally isomorphic,
         * so one is a left adjoint functor if and only if the other is.
         *)
        have "naturally_isomorphic C C (\<lambda>x. x \<otimes> b) (\<lambda>x. CCC.prod x b)"
        proof -
          interpret CC: product_category C C ..
          interpret X: binary_functor C C C \<open>\<lambda>fg. fst fg \<otimes> snd fg\<close>
            using binary_functor_Prod(1) by auto
          interpret Xb: "functor" C C \<open>\<lambda>x. x \<otimes> b\<close>
            using b X.fixing_ide_gives_functor_2 by simp
          interpret prod: binary_functor C C C \<open>\<lambda>fg. CCC.prod (fst fg) (snd fg)\<close>
            using CCC.binary_functor_Prod(1) by simp
          interpret prod_b: "functor" C C \<open>\<lambda>x. CCC.prod x b\<close>
             using b prod.fixing_ide_gives_functor_2 by simp
          interpret \<phi>: transformation_by_components C C \<open>\<lambda>x. x \<otimes> b\<close> \<open>\<lambda>x. CCC.prod x b\<close>
                         \<open>\<lambda>a. CCC.tuple (pr1 a b) (pr0 a b)\<close>
            using b CCC.prod_tuple by unfold_locales auto
          interpret \<phi>: natural_isomorphism C C \<open>\<lambda>x. x \<otimes> b\<close> \<open>\<lambda>x. CCC.prod x b\<close> \<phi>.map
          proof
            fix a
            assume a: "ide a"
            show "iso (\<phi>.map a)"
            proof
              show "inverse_arrows (\<phi>.map a) \<langle>CCC.pr1 a b, CCC.pr0 a b\<rangle>"
                using a b by auto
            qed
          qed
          show ?thesis
            using naturally_isomorphic_def \<phi>.natural_isomorphism_axioms by blast
        qed
        moreover have "left_adjoint_functor C C (\<lambda>x. x \<otimes> b)"
          using b left_adjoint_prod [of b] by simp
        ultimately show "left_adjoint_functor C C (\<lambda>x. CCC.prod x b)"
          using left_adjoint_functor_respects_naturally_isomorphic by auto
      qed
      show "\<And>f. \<not> arr f \<Longrightarrow> CCC.prod f b = null"
        using is_extensional by blast
      show "\<And>f. arr f \<Longrightarrow> dom (CCC.prod f b) = CCC.prod (dom f) b"
        by simp
      show "\<And>f. arr f \<Longrightarrow> cod (CCC.prod f b) = CCC.prod (cod f) b"
        by simp
      show "\<And>f. arr f \<Longrightarrow> arr (CCC.prod f b)"
        by simp
      show "\<And>g f. seq g f \<Longrightarrow> CCC.prod (g \<cdot> f) b = CCC.prod g b \<cdot> CCC.prod f b"
        by simp
      show "\<And>y. ide y \<Longrightarrow> \<exists>x e. terminal_arrow_from_functor (\<cdot>) (\<cdot>) (\<lambda>x. CCC.prod x b) x y e"
        using ex_terminal_arrow by simp
    qed

    lemma is_cartesian_closed_category:
    shows "cartesian_closed_category C"
      ..

  end

end


theory FA_N2D_EQUI
  imports DFA NFA

begin

definition
nfa2dfa :: "('q, 'a)nfa \<Rightarrow> ('q set, 'a)dfa" where
"nfa2dfa A = (
  \<lambda>S. \<lambda>a. \<Union>{tri_f A s a | s. s\<in>S},
  {tri_s A},
  \<lambda>S. (\<exists>s. s\<in>S \<and> tri_t A s)
)"

lemma run_inclusion[simp]:
"\<forall>s. NFA.run A s w = (DFA.run (nfa2dfa A) {s} w)"
  apply (induct w)
   apply (auto simp add: nfa2dfa_def)
  sorry

lemma equi:
"NFA.accept A w = DFA.accept (nfa2dfa A) w"
  apply (simp add: DFA.accept_def NFA.accept_def run_inclusion)
  apply (simp add: nfa2dfa_def)
  apply blast
  done

end


(*  Title:      HOL/Decision_Procs/ex/Commutative_Ring_Ex.thy
    Author:     Bernhard Haeupler, Stefan Berghofer
*)

section \<open>Some examples demonstrating the ring and field methods\<close>

theory Commutative_Ring_Ex
  imports "../Reflective_Field"
begin

lemma "4 * (x::int) ^ 5 * y ^ 3 * x ^ 2 * 3 + x * z + 3 ^ 5 = 12 * x ^ 7 * y ^ 3 + z * x + 243"
  by ring

lemma (in cring)
  assumes "x \<in> carrier R" "y \<in> carrier R" "z \<in> carrier R"
  shows "\<guillemotleft>4\<guillemotright> \<otimes> x [^] (5::nat) \<otimes> y [^] (3::nat) \<otimes> x [^] (2::nat) \<otimes> \<guillemotleft>3\<guillemotright> \<oplus> x \<otimes> z \<oplus> \<guillemotleft>3\<guillemotright> [^] (5::nat) =
    \<guillemotleft>12\<guillemotright> \<otimes> x [^] (7::nat) \<otimes> y [^] (3::nat) \<oplus> z \<otimes> x \<oplus> \<guillemotleft>243\<guillemotright>"
  by ring

lemma "((x::int) + y) ^ 2  = x ^ 2 + y ^ 2 + 2 * x * y"
  by ring

lemma (in cring)
  assumes "x \<in> carrier R" "y \<in> carrier R"
  shows "(x \<oplus> y) [^] (2::nat)  = x [^] (2::nat) \<oplus> y [^] (2::nat) \<oplus> \<guillemotleft>2\<guillemotright> \<otimes> x \<otimes> y"
  by ring

lemma "((x::int) + y) ^ 3 = x ^ 3 + y ^ 3 + 3 * x ^ 2 * y + 3 * y ^ 2 * x"
  by ring

lemma (in cring)
  assumes "x \<in> carrier R" "y \<in> carrier R"
  shows "(x \<oplus> y) [^] (3::nat) =
    x [^] (3::nat) \<oplus> y [^] (3::nat) \<oplus> \<guillemotleft>3\<guillemotright> \<otimes> x [^] (2::nat) \<otimes> y \<oplus> \<guillemotleft>3\<guillemotright> \<otimes> y [^] (2::nat) \<otimes> x"
  by ring

lemma "((x::int) - y) ^ 3 = x ^ 3 + 3 * x * y ^ 2 + (- 3) * y * x ^ 2 - y ^ 3"
  by ring

lemma (in cring)
  assumes "x \<in> carrier R" "y \<in> carrier R"
  shows "(x \<ominus> y) [^] (3::nat) =
    x [^] (3::nat) \<oplus> \<guillemotleft>3\<guillemotright> \<otimes> x \<otimes> y [^] (2::nat) \<oplus> (\<ominus> \<guillemotleft>3\<guillemotright>) \<otimes> y \<otimes> x [^] (2::nat) \<ominus> y [^] (3::nat)"
  by ring

lemma "((x::int) - y) ^ 2 = x ^ 2 + y ^ 2 - 2 * x * y"
  by ring

lemma (in cring)
  assumes "x \<in> carrier R" "y \<in> carrier R"
  shows "(x \<ominus> y) [^] (2::nat) = x [^] (2::nat) \<oplus> y [^] (2::nat) \<ominus> \<guillemotleft>2\<guillemotright> \<otimes> x \<otimes> y"
  by ring

lemma " ((a::int) + b + c) ^ 2 = a ^ 2 + b ^ 2 + c ^ 2 + 2 * a * b + 2 * b * c + 2 * a * c"
  by ring

lemma (in cring)
  assumes "a \<in> carrier R" "b \<in> carrier R" "c \<in> carrier R"
  shows " (a \<oplus> b \<oplus> c) [^] (2::nat) =
    a [^] (2::nat) \<oplus> b [^] (2::nat) \<oplus> c [^] (2::nat) \<oplus> \<guillemotleft>2\<guillemotright> \<otimes> a \<otimes> b \<oplus> \<guillemotleft>2\<guillemotright> \<otimes> b \<otimes> c \<oplus> \<guillemotleft>2\<guillemotright> \<otimes> a \<otimes> c"
  by ring

lemma "((a::int) - b - c) ^ 2 = a ^ 2 + b ^ 2 + c ^ 2 - 2 * a * b + 2 * b * c - 2 * a * c"
  by ring

lemma (in cring)
  assumes "a \<in> carrier R" "b \<in> carrier R" "c \<in> carrier R"
  shows "(a \<ominus> b \<ominus> c) [^] (2::nat) =
    a [^] (2::nat) \<oplus> b [^] (2::nat) \<oplus> c [^] (2::nat) \<ominus> \<guillemotleft>2\<guillemotright> \<otimes> a \<otimes> b \<oplus> \<guillemotleft>2\<guillemotright> \<otimes> b \<otimes> c \<ominus> \<guillemotleft>2\<guillemotright> \<otimes> a \<otimes> c"
  by ring

lemma "(a::int) * b + a * c = a * (b + c)"
  by ring

lemma (in cring)
  assumes "a \<in> carrier R" "b \<in> carrier R" "c \<in> carrier R"
  shows "a \<otimes> b \<oplus> a \<otimes> c = a \<otimes> (b \<oplus> c)"
  by ring

lemma "(a::int) ^ 2 - b ^ 2 = (a - b) * (a + b)"
  by ring

lemma (in cring)
  assumes "a \<in> carrier R" "b \<in> carrier R"
  shows "a [^] (2::nat) \<ominus> b [^] (2::nat) = (a \<ominus> b) \<otimes> (a \<oplus> b)"
  by ring

lemma "(a::int) ^ 3 - b ^ 3 = (a - b) * (a ^ 2 + a * b + b ^ 2)"
  by ring

lemma (in cring)
  assumes "a \<in> carrier R" "b \<in> carrier R"
  shows "a [^] (3::nat) \<ominus> b [^] (3::nat) = (a \<ominus> b) \<otimes> (a [^] (2::nat) \<oplus> a \<otimes> b \<oplus> b [^] (2::nat))"
  by ring

lemma "(a::int) ^ 3 + b ^ 3 = (a + b) * (a ^ 2 - a * b + b ^ 2)"
  by ring

lemma (in cring)
  assumes "a \<in> carrier R" "b \<in> carrier R"
  shows "a [^] (3::nat) \<oplus> b [^] (3::nat) = (a \<oplus> b) \<otimes> (a [^] (2::nat) \<ominus> a \<otimes> b \<oplus> b [^] (2::nat))"
  by ring

lemma "(a::int) ^ 4 - b ^ 4 = (a - b) * (a + b) * (a ^ 2 + b ^ 2)"
  by ring

lemma (in cring)
  assumes "a \<in> carrier R" "b \<in> carrier R"
  shows "a [^] (4::nat) \<ominus> b [^] (4::nat) = (a \<ominus> b) \<otimes> (a \<oplus> b) \<otimes> (a [^] (2::nat) \<oplus> b [^] (2::nat))"
  by ring

lemma "(a::int) ^ 10 - b ^ 10 =
  (a - b) * (a ^ 9 + a ^ 8 * b + a ^ 7 * b ^ 2 + a ^ 6 * b ^ 3 + a ^ 5 * b ^ 4 +
    a ^ 4 * b ^ 5 + a ^ 3 * b ^ 6 + a ^ 2 * b ^ 7 + a * b ^ 8 + b ^ 9)"
  by ring

lemma (in cring)
  assumes "a \<in> carrier R" "b \<in> carrier R"
  shows "a [^] (10::nat) \<ominus> b [^] (10::nat) =
  (a \<ominus> b) \<otimes> (a [^] (9::nat) \<oplus> a [^] (8::nat) \<otimes> b \<oplus> a [^] (7::nat) \<otimes> b [^] (2::nat) \<oplus>
    a [^] (6::nat) \<otimes> b [^] (3::nat) \<oplus> a [^] (5::nat) \<otimes> b [^] (4::nat) \<oplus>
    a [^] (4::nat) \<otimes> b [^] (5::nat) \<oplus> a [^] (3::nat) \<otimes> b [^] (6::nat) \<oplus>
    a [^] (2::nat) \<otimes> b [^] (7::nat) \<oplus> a \<otimes> b [^] (8::nat) \<oplus> b [^] (9::nat))"
  by ring

lemma "(x::'a::field) \<noteq> 0 \<Longrightarrow> (1 - 1 / x) * x - x + 1 = 0"
  by field

lemma (in field)
  assumes "x \<in> carrier R"
  shows "x \<noteq> \<zero> \<Longrightarrow> (\<one> \<ominus> \<one> \<oslash> x) \<otimes> x \<ominus> x \<oplus> \<one> = \<zero>"
  by field

end


(*  Title:      ZF/UNITY/GenPrefix.thy
    Author:     Sidi O Ehmety, Cambridge University Computer Laboratory
    Copyright   2001  University of Cambridge

\<langle>xs,ys\<rangle>:gen_prefix(r)
  if ys = xs' @ zs where length(xs) = length(xs')
  and corresponding elements of xs, xs' are pairwise related by r

Based on Lex/Prefix
*)

section\<open>Charpentier's Generalized Prefix Relation\<close>

theory GenPrefix
imports ZF
begin

definition (*really belongs in ZF/Trancl*)
  part_order :: "[i, i] \<Rightarrow> o"  where
  "part_order(A, r) \<equiv> refl(A,r) \<and> trans[A](r) \<and> antisym(r)"

consts
  gen_prefix :: "[i, i] \<Rightarrow> i"

inductive
  (* Parameter A is the domain of zs's elements *)

  domains "gen_prefix(A, r)" \<subseteq> "list(A)*list(A)"

  intros
    Nil:     "<[],[]>:gen_prefix(A, r)"

    prepend: "\<lbrakk>\<langle>xs,ys\<rangle>:gen_prefix(A, r);  \<langle>x,y\<rangle>:r; x \<in> A; y \<in> A\<rbrakk>
              \<Longrightarrow> <Cons(x,xs), Cons(y,ys)>: gen_prefix(A, r)"

    append:  "\<lbrakk>\<langle>xs,ys\<rangle>:gen_prefix(A, r); zs:list(A)\<rbrakk>
              \<Longrightarrow> <xs, ys@zs>:gen_prefix(A, r)"
    type_intros app_type list.Nil list.Cons

definition
  prefix :: "i\<Rightarrow>i"  where
  "prefix(A) \<equiv> gen_prefix(A, id(A))"

definition
  strict_prefix :: "i\<Rightarrow>i"  where
  "strict_prefix(A) \<equiv> prefix(A) - id(list(A))"

(* less or equal and greater or equal over prefixes *)

abbreviation
  pfixLe :: "[i, i] \<Rightarrow> o"  (infixl \<open>pfixLe\<close> 50)  where
  "xs pfixLe ys \<equiv> \<langle>xs, ys\<rangle>:gen_prefix(nat, Le)"

abbreviation
  pfixGe :: "[i, i] \<Rightarrow> o"  (infixl \<open>pfixGe\<close> 50)  where
  "xs pfixGe ys \<equiv> \<langle>xs, ys\<rangle>:gen_prefix(nat, Ge)"

lemma reflD:
 "\<lbrakk>refl(A, r); x \<in> A\<rbrakk> \<Longrightarrow> \<langle>x,x\<rangle>:r"
apply (unfold refl_def, auto)
done

(*** preliminary lemmas ***)

lemma Nil_gen_prefix: "xs \<in> list(A) \<Longrightarrow> <[], xs> \<in> gen_prefix(A, r)"
by (drule gen_prefix.append [OF gen_prefix.Nil], simp)
declare Nil_gen_prefix [simp]

lemma gen_prefix_length_le: "\<langle>xs,ys\<rangle> \<in> gen_prefix(A, r) \<Longrightarrow> length(xs) \<le> length(ys)"
apply (erule gen_prefix.induct)
apply (subgoal_tac [3] "ys \<in> list (A) ")
apply (auto dest: gen_prefix.dom_subset [THEN subsetD]
            intro: le_trans simp add: length_app)
done

lemma Cons_gen_prefix_aux:
  "\<lbrakk><xs', ys'> \<in> gen_prefix(A, r)\<rbrakk>
   \<Longrightarrow> (\<forall>x xs. x \<in> A \<longrightarrow> xs'= Cons(x,xs) \<longrightarrow>
       (\<exists>y ys. y \<in> A \<and> ys' = Cons(y,ys) \<and>
       \<langle>x,y\<rangle>:r \<and> \<langle>xs, ys\<rangle> \<in> gen_prefix(A, r)))"
apply (erule gen_prefix.induct)
prefer 3 apply (force intro: gen_prefix.append, auto)
done

lemma Cons_gen_prefixE:
  "\<lbrakk><Cons(x,xs), zs> \<in> gen_prefix(A, r);
    \<And>y ys. \<lbrakk>zs = Cons(y, ys); y \<in> A; x \<in> A; \<langle>x,y\<rangle>:r;
      \<langle>xs,ys\<rangle> \<in> gen_prefix(A, r)\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
apply (frule gen_prefix.dom_subset [THEN subsetD], auto)
apply (blast dest: Cons_gen_prefix_aux)
done
declare Cons_gen_prefixE [elim!]

lemma Cons_gen_prefix_Cons:
"(<Cons(x,xs),Cons(y,ys)> \<in> gen_prefix(A, r))
  \<longleftrightarrow> (x \<in> A \<and> y \<in> A \<and> \<langle>x,y\<rangle>:r \<and> \<langle>xs,ys\<rangle> \<in> gen_prefix(A, r))"
apply (auto intro: gen_prefix.prepend)
done
declare Cons_gen_prefix_Cons [iff]

(** Monotonicity of gen_prefix **)

lemma gen_prefix_mono2: "r<=s \<Longrightarrow> gen_prefix(A, r) \<subseteq> gen_prefix(A, s)"
apply clarify
apply (frule gen_prefix.dom_subset [THEN subsetD], clarify)
apply (erule rev_mp)
apply (erule gen_prefix.induct)
apply (auto intro: gen_prefix.append)
done

lemma gen_prefix_mono1: "A<=B \<Longrightarrow>gen_prefix(A, r) \<subseteq> gen_prefix(B, r)"
apply clarify
apply (frule gen_prefix.dom_subset [THEN subsetD], clarify)
apply (erule rev_mp)
apply (erule_tac P = "y \<in> list (A) " in rev_mp)
apply (erule_tac P = "xa \<in> list (A) " in rev_mp)
apply (erule gen_prefix.induct)
apply (simp (no_asm_simp))
apply clarify
apply (erule ConsE)+
apply (auto dest: gen_prefix.dom_subset [THEN subsetD]
            intro: gen_prefix.append list_mono [THEN subsetD])
done

lemma gen_prefix_mono: "\<lbrakk>A \<subseteq> B; r \<subseteq> s\<rbrakk> \<Longrightarrow> gen_prefix(A, r) \<subseteq> gen_prefix(B, s)"
apply (rule subset_trans)
apply (rule gen_prefix_mono1)
apply (rule_tac [2] gen_prefix_mono2, auto)
done

(*** gen_prefix order ***)

(* reflexivity *)
lemma refl_gen_prefix: "refl(A, r) \<Longrightarrow> refl(list(A), gen_prefix(A, r))"
apply (unfold refl_def, auto)
apply (induct_tac "x", auto)
done
declare refl_gen_prefix [THEN reflD, simp]

(* Transitivity *)
(* A lemma for proving gen_prefix_trans_comp *)

lemma append_gen_prefix [rule_format (no_asm)]: "xs \<in> list(A) \<Longrightarrow>
   \<forall>zs. <xs @ ys, zs> \<in> gen_prefix(A, r) \<longrightarrow> \<langle>xs, zs\<rangle>: gen_prefix(A, r)"
apply (erule list.induct)
apply (auto dest: gen_prefix.dom_subset [THEN subsetD])
done

(* Lemma proving transitivity and more*)

lemma gen_prefix_trans_comp [rule_format (no_asm)]:
     "\<langle>x, y\<rangle>: gen_prefix(A, r) \<Longrightarrow>
   (\<forall>z \<in> list(A). \<langle>y,z\<rangle> \<in> gen_prefix(A, s)\<longrightarrow>\<langle>x, z\<rangle> \<in> gen_prefix(A, s O r))"
apply (erule gen_prefix.induct)
apply (auto elim: ConsE simp add: Nil_gen_prefix)
apply (subgoal_tac "ys \<in> list (A) ")
prefer 2 apply (blast dest: gen_prefix.dom_subset [THEN subsetD])
apply (drule_tac xs = ys and r = s in append_gen_prefix, auto)
done

lemma trans_comp_subset: "trans(r) \<Longrightarrow> r O r \<subseteq> r"
by (auto dest: transD)

lemma trans_gen_prefix: "trans(r) \<Longrightarrow> trans(gen_prefix(A,r))"
apply (simp (no_asm) add: trans_def)
apply clarify
apply (rule trans_comp_subset [THEN gen_prefix_mono2, THEN subsetD], assumption)
apply (rule gen_prefix_trans_comp)
apply (auto dest: gen_prefix.dom_subset [THEN subsetD])
done

lemma trans_on_gen_prefix:
 "trans(r) \<Longrightarrow> trans[list(A)](gen_prefix(A, r))"
apply (drule_tac A = A in trans_gen_prefix)
apply (unfold trans_def trans_on_def, blast)
done

lemma prefix_gen_prefix_trans:
    "\<lbrakk>\<langle>x,y\<rangle> \<in> prefix(A); \<langle>y, z\<rangle> \<in> gen_prefix(A, r); r<=A*A\<rbrakk>
      \<Longrightarrow>  \<langle>x, z\<rangle> \<in> gen_prefix(A, r)"
  unfolding prefix_def
apply (rule_tac P = "\<lambda>r. \<langle>x,z\<rangle> \<in> gen_prefix (A, r) " in right_comp_id [THEN subst])
apply (blast dest: gen_prefix_trans_comp gen_prefix.dom_subset [THEN subsetD])+
done

lemma gen_prefix_prefix_trans:
"\<lbrakk>\<langle>x,y\<rangle> \<in> gen_prefix(A,r); \<langle>y, z\<rangle> \<in> prefix(A); r<=A*A\<rbrakk>
  \<Longrightarrow>  \<langle>x, z\<rangle> \<in> gen_prefix(A, r)"
  unfolding prefix_def
apply (rule_tac P = "\<lambda>r. \<langle>x,z\<rangle> \<in> gen_prefix (A, r) " in left_comp_id [THEN subst])
apply (blast dest: gen_prefix_trans_comp gen_prefix.dom_subset [THEN subsetD])+
done

(** Antisymmetry **)

lemma nat_le_lemma [rule_format]: "n \<in> nat \<Longrightarrow> \<forall>b \<in> nat. n #+ b \<le> n \<longrightarrow> b = 0"
by (induct_tac "n", auto)

lemma antisym_gen_prefix: "antisym(r) \<Longrightarrow> antisym(gen_prefix(A, r))"
apply (simp (no_asm) add: antisym_def)
apply (rule impI [THEN allI, THEN allI])
apply (erule gen_prefix.induct, blast)
apply (simp add: antisym_def, blast)
txt\<open>append case is hardest\<close>
apply clarify
apply (subgoal_tac "length (zs) = 0")
apply (subgoal_tac "ys \<in> list (A) ")
prefer 2 apply (blast dest: gen_prefix.dom_subset [THEN subsetD])
apply (drule_tac psi = "<ys @ zs, xs> \<in> gen_prefix (A,r) " in asm_rl)
apply simp
apply (subgoal_tac "length (ys @ zs) = length (ys) #+ length (zs) \<and>ys \<in> list (A) \<and>xs \<in> list (A) ")
prefer 2 apply (blast intro: length_app dest: gen_prefix.dom_subset [THEN subsetD])
apply (drule gen_prefix_length_le)+
apply clarify
apply simp
apply (drule_tac j = "length (xs) " in le_trans)
apply blast
apply (auto intro: nat_le_lemma)
done

(*** recursion equations ***)

lemma gen_prefix_Nil: "xs \<in> list(A) \<Longrightarrow> <xs, []> \<in> gen_prefix(A,r) \<longleftrightarrow> (xs = [])"
by (induct_tac "xs", auto)
declare gen_prefix_Nil [simp]

lemma same_gen_prefix_gen_prefix:
 "\<lbrakk>refl(A, r);  xs \<in> list(A)\<rbrakk> \<Longrightarrow>
    <xs@ys, xs@zs>: gen_prefix(A, r) \<longleftrightarrow> \<langle>ys,zs\<rangle> \<in> gen_prefix(A, r)"
  unfolding refl_def
apply (induct_tac "xs")
apply (simp_all (no_asm_simp))
done
declare same_gen_prefix_gen_prefix [simp]

lemma gen_prefix_Cons: "\<lbrakk>xs \<in> list(A); ys \<in> list(A); y \<in> A\<rbrakk> \<Longrightarrow>
    <xs, Cons(y,ys)> \<in> gen_prefix(A,r)  \<longleftrightarrow>
      (xs=[] | (\<exists>z zs. xs=Cons(z,zs) \<and> z \<in> A \<and> \<langle>z,y\<rangle>:r \<and> \<langle>zs,ys\<rangle> \<in> gen_prefix(A,r)))"
apply (induct_tac "xs", auto)
done

lemma gen_prefix_take_append: "\<lbrakk>refl(A,r);  \<langle>xs,ys\<rangle> \<in> gen_prefix(A, r); zs \<in> list(A)\<rbrakk>
      \<Longrightarrow>  <xs@zs, take(length(xs), ys) @ zs> \<in> gen_prefix(A, r)"
apply (erule gen_prefix.induct)
apply (simp (no_asm_simp))
apply (frule_tac [!] gen_prefix.dom_subset [THEN subsetD], auto)
apply (frule gen_prefix_length_le)
apply (subgoal_tac "take (length (xs), ys) \<in> list (A) ")
apply (simp_all (no_asm_simp) add: diff_is_0_iff [THEN iffD2] take_type)
done

lemma gen_prefix_append_both: "\<lbrakk>refl(A, r);  \<langle>xs,ys\<rangle> \<in> gen_prefix(A,r);
         length(xs) = length(ys); zs \<in> list(A)\<rbrakk>
      \<Longrightarrow>  <xs@zs, ys @ zs> \<in> gen_prefix(A, r)"
apply (drule_tac zs = zs in gen_prefix_take_append, assumption+)
apply (subgoal_tac "take (length (xs), ys) =ys")
apply (auto intro!: take_all dest: gen_prefix.dom_subset [THEN subsetD])
done

(*NOT suitable for rewriting since [y] has the form y#ys*)
lemma append_cons_conv: "xs \<in> list(A) \<Longrightarrow> xs @ Cons(y, ys) = (xs @ [y]) @ ys"
by (auto simp add: app_assoc)

lemma append_one_gen_prefix_lemma [rule_format]:
     "\<lbrakk>\<langle>xs,ys\<rangle> \<in> gen_prefix(A, r);  refl(A, r)\<rbrakk>
      \<Longrightarrow> length(xs) < length(ys) \<longrightarrow>
          <xs @ [nth(length(xs), ys)], ys> \<in> gen_prefix(A, r)"
apply (erule gen_prefix.induct, blast)
apply (frule gen_prefix.dom_subset [THEN subsetD], clarify)
apply (simp_all add: length_type)
(* Append case is hardest *)
apply (frule gen_prefix_length_le [THEN le_iff [THEN iffD1]])
apply (frule gen_prefix.dom_subset [THEN subsetD], clarify)
apply (subgoal_tac "length (xs) :nat\<and>length (ys) :nat \<and>length (zs) :nat")
prefer 2 apply (blast intro: length_type, clarify)
apply (simp_all add: nth_append length_type length_app)
apply (rule conjI)
apply (blast intro: gen_prefix.append)
apply (erule_tac V = "length (xs) < length (ys) \<longrightarrow>u" for u in thin_rl)
apply (erule_tac a = zs in list.cases, auto)
apply (rule_tac P1 = "\<lambda>x. <u(x), v>:w" for u v w in nat_diff_split [THEN iffD2])
apply auto
apply (simplesubst append_cons_conv)
apply (rule_tac [2] gen_prefix.append)
apply (auto elim: ConsE simp add: gen_prefix_append_both)
done

lemma append_one_gen_prefix: "\<lbrakk>\<langle>xs,ys\<rangle>: gen_prefix(A, r);  length(xs) < length(ys);  refl(A, r)\<rbrakk>
      \<Longrightarrow> <xs @ [nth(length(xs), ys)], ys> \<in> gen_prefix(A, r)"
apply (blast intro: append_one_gen_prefix_lemma)
done

(** Proving the equivalence with Charpentier's definition **)

lemma gen_prefix_imp_nth_lemma [rule_format]: "xs \<in> list(A) \<Longrightarrow>
  \<forall>ys \<in> list(A). \<forall>i \<in> nat. i < length(xs)
          \<longrightarrow> \<langle>xs, ys\<rangle>: gen_prefix(A, r) \<longrightarrow> <nth(i, xs), nth(i, ys)>:r"
apply (induct_tac "xs", simp, clarify)
apply simp
apply (erule natE, auto)
done

lemma gen_prefix_imp_nth: "\<lbrakk>\<langle>xs,ys\<rangle> \<in> gen_prefix(A,r); i < length(xs)\<rbrakk>
      \<Longrightarrow> <nth(i, xs), nth(i, ys)>:r"
apply (cut_tac A = A in gen_prefix.dom_subset)
apply (rule gen_prefix_imp_nth_lemma)
apply (auto simp add: lt_nat_in_nat)
done

lemma nth_imp_gen_prefix [rule_format]: "xs \<in> list(A) \<Longrightarrow>
  \<forall>ys \<in> list(A). length(xs) \<le> length(ys)
      \<longrightarrow> (\<forall>i. i < length(xs) \<longrightarrow> <nth(i, xs), nth(i,ys)>:r)
      \<longrightarrow> \<langle>xs, ys\<rangle> \<in> gen_prefix(A, r)"
apply (induct_tac "xs")
apply (simp_all (no_asm_simp))
apply clarify
apply (erule_tac a = ys in list.cases, simp)
apply (force intro!: nat_0_le simp add: lt_nat_in_nat)
done

lemma gen_prefix_iff_nth: "(\<langle>xs,ys\<rangle> \<in> gen_prefix(A,r)) \<longleftrightarrow>
      (xs \<in> list(A) \<and> ys \<in> list(A) \<and> length(xs) \<le> length(ys) \<and>
      (\<forall>i. i < length(xs) \<longrightarrow> <nth(i,xs), nth(i, ys)>: r))"
apply (rule iffI)
apply (frule gen_prefix.dom_subset [THEN subsetD])
apply (frule gen_prefix_length_le, auto)
apply (rule_tac [2] nth_imp_gen_prefix)
apply (drule gen_prefix_imp_nth)
apply (auto simp add: lt_nat_in_nat)
done

(** prefix is a partial order: **)

lemma refl_prefix: "refl(list(A), prefix(A))"
  unfolding prefix_def
apply (rule refl_gen_prefix)
apply (auto simp add: refl_def)
done
declare refl_prefix [THEN reflD, simp]

lemma trans_prefix: "trans(prefix(A))"
  unfolding prefix_def
apply (rule trans_gen_prefix)
apply (auto simp add: trans_def)
done

lemmas prefix_trans = trans_prefix [THEN transD]

lemma trans_on_prefix: "trans[list(A)](prefix(A))"
  unfolding prefix_def
apply (rule trans_on_gen_prefix)
apply (auto simp add: trans_def)
done

lemmas prefix_trans_on = trans_on_prefix [THEN trans_onD]

(* Monotonicity of "set" operator WRT prefix *)

lemma set_of_list_prefix_mono:
"\<langle>xs,ys\<rangle> \<in> prefix(A) \<Longrightarrow> set_of_list(xs) \<subseteq> set_of_list(ys)"

  unfolding prefix_def
apply (erule gen_prefix.induct)
apply (subgoal_tac [3] "xs \<in> list (A) \<and>ys \<in> list (A) ")
prefer 4 apply (blast dest: gen_prefix.dom_subset [THEN subsetD])
apply (auto simp add: set_of_list_append)
done

(** recursion equations **)

lemma Nil_prefix: "xs \<in> list(A) \<Longrightarrow> <[],xs> \<in> prefix(A)"

  unfolding prefix_def
apply (simp (no_asm_simp) add: Nil_gen_prefix)
done
declare Nil_prefix [simp]

lemma prefix_Nil: "<xs, []> \<in> prefix(A) \<longleftrightarrow> (xs = [])"

apply (unfold prefix_def, auto)
apply (frule gen_prefix.dom_subset [THEN subsetD])
apply (drule_tac psi = "<xs, []> \<in> gen_prefix (A, id (A))" in asm_rl)
apply (simp add: gen_prefix_Nil)
done
declare prefix_Nil [iff]

lemma Cons_prefix_Cons:
"<Cons(x,xs), Cons(y,ys)> \<in> prefix(A) \<longleftrightarrow> (x=y \<and> \<langle>xs,ys\<rangle> \<in> prefix(A) \<and> y \<in> A)"
apply (unfold prefix_def, auto)
done
declare Cons_prefix_Cons [iff]

lemma same_prefix_prefix:
"xs \<in> list(A)\<Longrightarrow> <xs@ys,xs@zs> \<in> prefix(A) \<longleftrightarrow> (\<langle>ys,zs\<rangle> \<in> prefix(A))"
  unfolding prefix_def
apply (subgoal_tac "refl (A,id (A))")
apply (simp (no_asm_simp))
apply (auto simp add: refl_def)
done
declare same_prefix_prefix [simp]

lemma same_prefix_prefix_Nil: "xs \<in> list(A) \<Longrightarrow> <xs@ys,xs> \<in> prefix(A) \<longleftrightarrow> (<ys,[]> \<in> prefix(A))"
apply (rule_tac P = "\<lambda>x. \<langle>u, x\<rangle>:v \<longleftrightarrow> w(x)" for u v w in app_right_Nil [THEN subst])
apply (rule_tac [2] same_prefix_prefix, auto)
done
declare same_prefix_prefix_Nil [simp]

lemma prefix_appendI:
"\<lbrakk>\<langle>xs,ys\<rangle> \<in> prefix(A); zs \<in> list(A)\<rbrakk> \<Longrightarrow> <xs,ys@zs> \<in> prefix(A)"
  unfolding prefix_def
apply (erule gen_prefix.append, assumption)
done
declare prefix_appendI [simp]

lemma prefix_Cons:
"\<lbrakk>xs \<in> list(A); ys \<in> list(A); y \<in> A\<rbrakk> \<Longrightarrow>
  <xs,Cons(y,ys)> \<in> prefix(A) \<longleftrightarrow>
  (xs=[] | (\<exists>zs. xs=Cons(y,zs) \<and> \<langle>zs,ys\<rangle> \<in> prefix(A)))"
  unfolding prefix_def
apply (auto simp add: gen_prefix_Cons)
done

lemma append_one_prefix:
  "\<lbrakk>\<langle>xs,ys\<rangle> \<in> prefix(A); length(xs) < length(ys)\<rbrakk>
  \<Longrightarrow> <xs @ [nth(length(xs),ys)], ys> \<in> prefix(A)"
  unfolding prefix_def
apply (subgoal_tac "refl (A, id (A))")
apply (simp (no_asm_simp) add: append_one_gen_prefix)
apply (auto simp add: refl_def)
done

lemma prefix_length_le:
"\<langle>xs,ys\<rangle> \<in> prefix(A) \<Longrightarrow> length(xs) \<le> length(ys)"
  unfolding prefix_def
apply (blast dest: gen_prefix_length_le)
done

lemma prefix_type: "prefix(A)<=list(A)*list(A)"
  unfolding prefix_def
apply (blast intro!: gen_prefix.dom_subset)
done

lemma strict_prefix_type:
"strict_prefix(A) \<subseteq> list(A)*list(A)"
  unfolding strict_prefix_def
apply (blast intro!: prefix_type [THEN subsetD])
done

lemma strict_prefix_length_lt_aux:
     "\<langle>xs,ys\<rangle> \<in> prefix(A) \<Longrightarrow> xs\<noteq>ys \<longrightarrow> length(xs) < length(ys)"
  unfolding prefix_def
apply (erule gen_prefix.induct, clarify)
apply (subgoal_tac [!] "ys \<in> list(A) \<and> xs \<in> list(A)")
apply (auto dest: gen_prefix.dom_subset [THEN subsetD]
            simp add: length_type)
apply (subgoal_tac "length (zs) =0")
apply (drule_tac [2] not_lt_imp_le)
apply (rule_tac [5] j = "length (ys) " in lt_trans2)
apply auto
done

lemma strict_prefix_length_lt:
     "\<langle>xs,ys\<rangle>:strict_prefix(A) \<Longrightarrow> length(xs) < length(ys)"
  unfolding strict_prefix_def
apply (rule strict_prefix_length_lt_aux [THEN mp])
apply (auto dest: prefix_type [THEN subsetD])
done

(*Equivalence to the definition used in Lex/Prefix.thy*)
lemma prefix_iff:
    "\<langle>xs,zs\<rangle> \<in> prefix(A) \<longleftrightarrow> (\<exists>ys \<in> list(A). zs = xs@ys) \<and> xs \<in> list(A)"
  unfolding prefix_def
apply (auto simp add: gen_prefix_iff_nth lt_nat_in_nat nth_append nth_type app_type length_app)
apply (subgoal_tac "drop (length (xs), zs) \<in> list (A) ")
apply (rule_tac x = "drop (length (xs), zs) " in bexI)
apply safe
 prefer 2 apply (simp add: length_type drop_type)
apply (rule nth_equalityI)
apply (simp_all (no_asm_simp) add: nth_append app_type drop_type length_app length_drop)
apply (rule nat_diff_split [THEN iffD2], simp_all, clarify)
apply (drule_tac i = "length (zs) " in leI)
apply (force simp add: le_subset_iff, safe)
apply (subgoal_tac "length (xs) #+ (i #- length (xs)) = i")
apply (subst nth_drop)
apply (simp_all (no_asm_simp) add: leI split: nat_diff_split)
done

lemma prefix_snoc:
"\<lbrakk>xs \<in> list(A); ys \<in> list(A); y \<in> A\<rbrakk> \<Longrightarrow>
   <xs, ys@[y]> \<in> prefix(A) \<longleftrightarrow> (xs = ys@[y] | \<langle>xs,ys\<rangle> \<in> prefix(A))"
apply (simp (no_asm) add: prefix_iff)
apply (rule iffI, clarify)
apply (erule_tac xs = ysa in rev_list_elim, simp)
apply (simp add: app_type app_assoc [symmetric])
apply (auto simp add: app_assoc app_type)
done
declare prefix_snoc [simp]

lemma prefix_append_iff [rule_format]: "zs \<in> list(A) \<Longrightarrow> \<forall>xs \<in> list(A). \<forall>ys \<in> list(A).
   (<xs, ys@zs> \<in> prefix(A)) \<longleftrightarrow>
  (\<langle>xs,ys\<rangle> \<in> prefix(A) | (\<exists>us. xs = ys@us \<and> \<langle>us,zs\<rangle> \<in> prefix(A)))"
apply (erule list_append_induct, force, clarify)
apply (rule iffI)
apply (simp add: add: app_assoc [symmetric])
apply (erule disjE)
apply (rule disjI2)
apply (rule_tac x = "y @ [x]" in exI)
apply (simp add: add: app_assoc [symmetric], force+)
done

(*Although the prefix ordering is not linear, the prefixes of a list
  are linearly ordered.*)
lemma common_prefix_linear_lemma [rule_format]: "\<lbrakk>zs \<in> list(A); xs \<in> list(A); ys \<in> list(A)\<rbrakk>
   \<Longrightarrow> \<langle>xs, zs\<rangle> \<in> prefix(A) \<longrightarrow> \<langle>ys,zs\<rangle> \<in> prefix(A)
  \<longrightarrow>\<langle>xs,ys\<rangle> \<in> prefix(A) | \<langle>ys,xs\<rangle> \<in> prefix(A)"
apply (erule list_append_induct, auto)
done

lemma common_prefix_linear: "\<lbrakk>\<langle>xs, zs\<rangle> \<in> prefix(A); \<langle>ys,zs\<rangle> \<in> prefix(A)\<rbrakk>
      \<Longrightarrow> \<langle>xs,ys\<rangle> \<in> prefix(A) | \<langle>ys,xs\<rangle> \<in> prefix(A)"
apply (cut_tac prefix_type)
apply (blast del: disjCI intro: common_prefix_linear_lemma)
done

(*** pfixLe, pfixGe \<in> properties inherited from the translations ***)

(** pfixLe **)

lemma refl_Le: "refl(nat,Le)"

apply (unfold refl_def, auto)
done
declare refl_Le [simp]

lemma antisym_Le: "antisym(Le)"
  unfolding antisym_def
apply (auto intro: le_anti_sym)
done
declare antisym_Le [simp]

lemma trans_on_Le: "trans[nat](Le)"
apply (unfold trans_on_def, auto)
apply (blast intro: le_trans)
done
declare trans_on_Le [simp]

lemma trans_Le: "trans(Le)"
apply (unfold trans_def, auto)
apply (blast intro: le_trans)
done
declare trans_Le [simp]

lemma part_order_Le: "part_order(nat,Le)"
by (unfold part_order_def, auto)
declare part_order_Le [simp]

lemma pfixLe_refl: "x \<in> list(nat) \<Longrightarrow> x pfixLe x"
by (blast intro: refl_gen_prefix [THEN reflD] refl_Le)
declare pfixLe_refl [simp]

lemma pfixLe_trans: "\<lbrakk>x pfixLe y; y pfixLe z\<rbrakk> \<Longrightarrow> x pfixLe z"
by (blast intro: trans_gen_prefix [THEN transD] trans_Le)

lemma pfixLe_antisym: "\<lbrakk>x pfixLe y; y pfixLe x\<rbrakk> \<Longrightarrow> x = y"
by (blast intro: antisym_gen_prefix [THEN antisymE] antisym_Le)

lemma prefix_imp_pfixLe:
"\<langle>xs,ys\<rangle>:prefix(nat)\<Longrightarrow> xs pfixLe ys"

  unfolding prefix_def
apply (rule gen_prefix_mono [THEN subsetD], auto)
done

lemma refl_Ge: "refl(nat, Ge)"
by (unfold refl_def Ge_def, auto)
declare refl_Ge [iff]

lemma antisym_Ge: "antisym(Ge)"
  unfolding antisym_def Ge_def
apply (auto intro: le_anti_sym)
done
declare antisym_Ge [iff]

lemma trans_Ge: "trans(Ge)"
  unfolding trans_def Ge_def
apply (auto intro: le_trans)
done
declare trans_Ge [iff]

lemma pfixGe_refl: "x \<in> list(nat) \<Longrightarrow> x pfixGe x"
by (blast intro: refl_gen_prefix [THEN reflD])
declare pfixGe_refl [simp]

lemma pfixGe_trans: "\<lbrakk>x pfixGe y; y pfixGe z\<rbrakk> \<Longrightarrow> x pfixGe z"
by (blast intro: trans_gen_prefix [THEN transD])

lemma pfixGe_antisym: "\<lbrakk>x pfixGe y; y pfixGe x\<rbrakk> \<Longrightarrow> x = y"
by (blast intro: antisym_gen_prefix [THEN antisymE])

lemma prefix_imp_pfixGe:
  "\<langle>xs,ys\<rangle>:prefix(nat) \<Longrightarrow> xs pfixGe ys"
  unfolding prefix_def Ge_def
apply (rule gen_prefix_mono [THEN subsetD], auto)
done
(* Added by Sidi \<in> prefix and take *)

lemma prefix_imp_take:
"\<langle>xs, ys\<rangle> \<in> prefix(A) \<Longrightarrow> xs = take(length(xs), ys)"

  unfolding prefix_def
apply (erule gen_prefix.induct)
apply (subgoal_tac [3] "length (xs) :nat")
apply (auto dest: gen_prefix.dom_subset [THEN subsetD] simp add: length_type)
apply (frule gen_prefix.dom_subset [THEN subsetD])
apply (frule gen_prefix_length_le)
apply (auto simp add: take_append)
apply (subgoal_tac "length (xs) #- length (ys) =0")
apply (simp_all (no_asm_simp) add: diff_is_0_iff)
done

lemma prefix_length_equal: "\<lbrakk>\<langle>xs,ys\<rangle> \<in> prefix(A); length(xs)=length(ys)\<rbrakk> \<Longrightarrow> xs = ys"
apply (cut_tac A = A in prefix_type)
apply (drule subsetD, auto)
apply (drule prefix_imp_take)
apply (erule trans, simp)
done

lemma prefix_length_le_equal: "\<lbrakk>\<langle>xs,ys\<rangle> \<in> prefix(A); length(ys) \<le> length(xs)\<rbrakk> \<Longrightarrow> xs = ys"
by (blast intro: prefix_length_equal le_anti_sym prefix_length_le)

lemma take_prefix [rule_format]: "xs \<in> list(A) \<Longrightarrow> \<forall>n \<in> nat. <take(n, xs), xs> \<in> prefix(A)"
  unfolding prefix_def
apply (erule list.induct, simp, clarify)
apply (erule natE, auto)
done

lemma prefix_take_iff: "\<langle>xs,ys\<rangle> \<in> prefix(A) \<longleftrightarrow> (xs=take(length(xs), ys) \<and> xs \<in> list(A) \<and> ys \<in> list(A))"
apply (rule iffI)
apply (frule prefix_type [THEN subsetD])
apply (blast intro: prefix_imp_take, clarify)
apply (erule ssubst)
apply (blast intro: take_prefix length_type)
done

lemma prefix_imp_nth: "\<lbrakk>\<langle>xs,ys\<rangle> \<in> prefix(A); i < length(xs)\<rbrakk> \<Longrightarrow> nth(i,xs) = nth(i,ys)"
by (auto dest!: gen_prefix_imp_nth simp add: prefix_def)

lemma nth_imp_prefix:
     "\<lbrakk>xs \<in> list(A); ys \<in> list(A); length(xs) \<le> length(ys);
        \<And>i. i < length(xs) \<Longrightarrow> nth(i, xs) = nth(i,ys)\<rbrakk>
      \<Longrightarrow> \<langle>xs,ys\<rangle> \<in> prefix(A)"
apply (auto simp add: prefix_def nth_imp_gen_prefix)
apply (auto intro!: nth_imp_gen_prefix simp add: prefix_def)
apply (blast intro: nth_type lt_trans2)
done

lemma length_le_prefix_imp_prefix: "\<lbrakk>length(xs) \<le> length(ys);
        \<langle>xs,zs\<rangle> \<in> prefix(A); \<langle>ys,zs\<rangle> \<in> prefix(A)\<rbrakk> \<Longrightarrow> \<langle>xs,ys\<rangle> \<in> prefix(A)"
apply (cut_tac A = A in prefix_type)
apply (rule nth_imp_prefix, blast, blast)
 apply assumption
apply (rule_tac b = "nth (i,zs)" in trans)
 apply (blast intro: prefix_imp_nth)
apply (blast intro: sym prefix_imp_nth prefix_length_le lt_trans2)
done

end


(* Author: Xingyuan Zhang, Chunhan Wu, Christian Urban *)

theory Myhill
  imports Myhill_2 "Regular-Sets.Derivatives"
begin

section \<open>The theorem\<close>

theorem Myhill_Nerode:
  fixes A::"('a::finite) lang"
  shows "(\<exists>r. A = lang r) \<longleftrightarrow> finite (UNIV // \<approx>A)"
using Myhill_Nerode1 Myhill_Nerode2 by auto

subsection \<open>Second direction proved using partial derivatives\<close>

text \<open>
  An alternaive proof using the notion of partial derivatives for regular
  expressions due to Antimirov \<^cite>\<open>"Antimirov95"\<close>.
\<close>

lemma MN_Rel_Derivs:
  shows "x \<approx>A y \<longleftrightarrow> Derivs x A = Derivs y A"
unfolding Derivs_def str_eq_def
by auto

lemma Myhill_Nerode3:
  fixes r::"'a rexp"
  shows "finite (UNIV // \<approx>(lang r))"
proof -
  have "finite (UNIV // =(\<lambda>x. pderivs x r)=)"
  proof -
    have "range (\<lambda>x. pderivs x r) \<subseteq> Pow (pderivs_lang UNIV r)"
      unfolding pderivs_lang_def by auto
    moreover
    have "finite (Pow (pderivs_lang UNIV r))" by (simp add: finite_pderivs_lang)
    ultimately
    have "finite (range (\<lambda>x. pderivs x r))"
      by (simp add: finite_subset)
    then show "finite (UNIV // =(\<lambda>x. pderivs x r)=)"
      by (rule finite_eq_tag_rel)
  qed
  moreover
  have "=(\<lambda>x. pderivs x r)= \<subseteq> \<approx>(lang r)"
    unfolding tag_eq_def
    by (auto simp add: MN_Rel_Derivs Derivs_pderivs)
  moreover
  have "equiv UNIV =(\<lambda>x. pderivs x r)="
  and  "equiv UNIV (\<approx>(lang r))"
    unfolding equiv_def refl_on_def sym_def trans_def
    unfolding tag_eq_def str_eq_def
    by auto
  ultimately show "finite (UNIV // \<approx>(lang r))"
    by (rule refined_partition_finite)
qed

end