chapter \<open> List Utility Theorems \<close>

theory List_Utilities
  imports
    "HOL-Combinatorics.List_Permutation"
begin

text \<open> Throughout our work it will be necessary to reuse common lemmas
       regarding lists and multisets. These results are proved in the
       following section and reused by subsequent lemmas and theorems. \<close>

section \<open> Multisets \<close>

lemma length_sub_mset:
  assumes "mset \<Psi> \<subseteq># mset \<Gamma>"
      and "length \<Psi> >= length \<Gamma>"
    shows "mset \<Psi> = mset \<Gamma>"
  using assms
  by (metis
        append_Nil2
        append_eq_append_conv
        leD
        linorder_neqE_nat
        mset_le_perm_append
        perm_length
        size_mset
        size_mset_mono)

lemma set_exclusion_mset_simplify:
  assumes "\<not> (\<exists> \<psi> \<in> set \<Psi>. \<psi> \<in> set \<Sigma>)"
      and "mset \<Psi> \<subseteq># mset (\<Sigma> @ \<Gamma>)"
    shows "mset \<Psi> \<subseteq># mset \<Gamma>"
using assms
proof (induct \<Sigma>)
  case Nil
  then show ?case by simp
next
  case (Cons \<sigma> \<Sigma>)
  then show ?case
    by (cases "\<sigma> \<in> set \<Psi>",
        fastforce,
        metis
          add.commute
          add_mset_add_single
          diff_single_trivial
          in_multiset_in_set
          mset.simps(2)
          notin_set_remove1
          remove_hd
          subset_eq_diff_conv
          union_code
          append_Cons)
qed

lemma image_mset_cons_homomorphism:
  "image_mset mset (image_mset ((#) \<phi>) \<Phi>) = image_mset ((+) {# \<phi> #}) (image_mset mset \<Phi>)"
  by (induct \<Phi>, simp+)

lemma image_mset_append_homomorphism:
  "image_mset mset (image_mset ((@) \<Delta>) \<Phi>) = image_mset ((+) (mset \<Delta>)) (image_mset mset \<Phi>)"
  by (induct \<Phi>, simp+)

lemma image_mset_add_collapse:
  fixes A B :: "'a multiset"
  shows "image_mset ((+) A) (image_mset ((+) B) X) = image_mset ((+) (A + B)) X"
  by (induct X, simp, simp)

lemma remove1_remdups_removeAll: "remove1 x (remdups A) = remdups (removeAll x A)"
proof (induct A)
  case Nil
  then show ?case by simp
next
  case (Cons a A)
  then show ?case
    by (cases "a = x", (simp add: Cons)+)
qed

lemma mset_remdups:
  assumes "mset A = mset B"
  shows "mset (remdups A) = mset (remdups B)"
proof -
  have "\<forall> B. mset A = mset B \<longrightarrow> mset (remdups A) = mset (remdups B)"
  proof (induct A)
    case Nil
    then show ?case by simp
  next
    case (Cons a A)
    {
      fix B
      assume "mset (a # A) = mset B"
      hence "mset A = mset (remove1 a B)"
        by (metis add_mset_add_mset_same_iff
                  list.set_intros(1)
                  mset.simps(2)
                  mset_eq_setD
                  perm_remove)
      hence "mset (remdups A) = mset (remdups (remove1 a B))"
        using Cons.hyps by blast
      hence "mset (remdups (a # (remdups A))) = mset (remdups (a # (remdups (remove1 a B))))"
        by (metis mset_eq_setD set_eq_iff_mset_remdups_eq list.simps(15))
      hence "  mset (remdups (a # (removeAll a (remdups A))))
             = mset (remdups (a # (removeAll a (remdups (remove1 a B)))))"
        by (metis insert_Diff_single list.set(2) set_eq_iff_mset_remdups_eq set_removeAll)
      hence "  mset (remdups (a # (remdups (removeAll a A))))
             = mset (remdups (a # (remdups (removeAll a (remove1 a B)))))"
        by (metis distinct_remdups distinct_remove1_removeAll remove1_remdups_removeAll)
      hence "mset (remdups (remdups (a # A))) = mset (remdups (remdups (a # (remove1 a B))))"
        by (metis \<open>mset A = mset (remove1 a B)\<close>
                  list.set(2)
                  mset_eq_setD
                  set_eq_iff_mset_remdups_eq)
      hence "mset (remdups (a # A)) = mset (remdups (a # (remove1 a B)))"
        by (metis remdups_remdups)
      hence "mset (remdups (a # A)) = mset (remdups B)"
        using \<open>mset (a # A) = mset B\<close> mset_eq_setD set_eq_iff_mset_remdups_eq by blast
    }
    then show ?case by simp
  qed
  thus ?thesis using assms by blast
qed

lemma mset_mset_map_snd_remdups:
  assumes "mset (map mset A) = mset (map mset B)"
  shows "mset (map (mset \<circ> (map snd) \<circ> remdups) A) = mset (map (mset \<circ> (map snd) \<circ> remdups) B)"
proof -
  {
    fix B :: "('a \<times> 'b) list list"
    fix b :: "('a \<times> 'b) list"
    assume "b \<in> set B"
    hence "  mset (map (mset \<circ> (map snd) \<circ> remdups) (b # (remove1 b B)))
         = mset (map (mset \<circ> (map snd) \<circ> remdups) B)"
    proof (induct B)
      case Nil
      then show ?case by simp
    next
      case (Cons b' B)
      then show ?case
      by (cases "b = b'", simp+)
    qed
  }
  note \<diamondsuit> = this
  have
    "\<forall> B :: ('a \<times> 'b) list list.
     mset (map mset A) = mset (map mset B)
       \<longrightarrow> mset (map (mset \<circ> (map snd) \<circ> remdups) A) = mset (map (mset \<circ> (map snd) \<circ> remdups) B)"
  proof (induct A)
    case Nil
    then show ?case by simp
  next
    case (Cons a A)
    {
      fix B
      assume \<spadesuit>: "mset (map mset (a # A)) = mset (map mset B)"
      hence "mset a \<in># mset (map mset B)"
        by (simp,
            metis \<spadesuit>
                  image_set
                  list.set_intros(1)
                  list.simps(9)
                  mset_eq_setD)
      from this obtain b where \<dagger>:
        "b \<in> set B"
        "mset a = mset b"
        by auto
      with \<spadesuit> have "mset (map mset A) = mset (remove1 (mset b) (map mset B))"
        by (simp add: union_single_eq_diff)
      moreover have "mset B = mset (b # remove1 b B)" using \<dagger> by simp
      hence "mset (map mset B) = mset (map mset (b # (remove1 b B)))"
        by (simp,
            metis image_mset_add_mset
                  mset.simps(2)
                  mset_remove1)
      ultimately have "mset (map mset A) = mset (map mset (remove1 b B))"
        by simp
      hence "  mset (map (mset \<circ> (map snd) \<circ> remdups) A)
             = mset (map (mset \<circ> (map snd) \<circ> remdups) (remove1 b B))"
        using Cons.hyps by blast
      moreover have "(mset \<circ> (map snd) \<circ> remdups) a = (mset \<circ> (map snd) \<circ> remdups) b"
        using \<dagger>(2) mset_remdups by fastforce
      ultimately have
        "  mset (map (mset \<circ> (map snd) \<circ> remdups) (a # A))
         = mset (map (mset \<circ> (map snd) \<circ> remdups) (b # (remove1 b B)))"
        by simp
      moreover have
        "  mset (map (mset \<circ> (map snd) \<circ> remdups) (b # (remove1 b B)))
         = mset (map (mset \<circ> (map snd) \<circ> remdups) B)"
        using \<dagger>(1) \<diamondsuit> by blast
      ultimately have
        "  mset (map (mset \<circ> (map snd) \<circ> remdups) (a # A))
         = mset (map (mset \<circ> (map snd) \<circ> remdups) B)"
        by simp
    }
    then show ?case by blast
  qed
  thus ?thesis using assms by blast
qed

lemma mset_remdups_append_msub:
  "mset (remdups A) \<subseteq># mset (remdups (B @ A))"
proof -
  have "\<forall> B. mset (remdups A) \<subseteq># mset (remdups (B @ A))"
  proof (induct A)
    case Nil
    then show ?case by simp
  next
    case (Cons a A)
    {
      fix B
      have \<dagger>: "mset (remdups (B @ (a # A))) = mset (remdups (a # (B @ A)))"
        by (induct B, simp+)
      have "mset (remdups (a # A)) \<subseteq># mset (remdups (B @ (a # A)))"
      proof (cases "a \<in> set B \<and> a \<notin> set A")
        case True
        hence \<dagger>: "mset (remove1 a (remdups (B @ A))) = mset (remdups ((removeAll a B) @ A))"
          by (simp add: remove1_remdups_removeAll)
        hence "   (add_mset a (mset (remdups A)) \<subseteq># mset (remdups (B @ A)))
               = (mset (remdups A) \<subseteq># mset (remdups ((removeAll a B) @ A)))"
          using True
          by (simp add: insert_subset_eq_iff)
        then show ?thesis
          by (metis \<dagger> Cons True
                    Un_insert_right
                    list.set(2)
                    mset.simps(2)
                    mset_subset_eq_insertD
                    remdups.simps(2)
                    set_append
                    set_eq_iff_mset_remdups_eq
                    set_mset_mset set_remdups)
      next
        case False
        then show ?thesis using \<dagger> Cons by simp
      qed
    }
    thus ?case by blast
  qed
  thus ?thesis by blast
qed

section \<open> List Mapping \<close>

text \<open> The following notation for permutations is slightly nicer when
       formatted in \LaTeX. \<close>

notation perm (infix "\<rightleftharpoons>" 50)

lemma map_monotonic:
  assumes "mset A \<subseteq># mset B"
  shows "mset (map f A) \<subseteq># mset (map f B)"
  by (simp add: assms image_mset_subseteq_mono)

lemma perm_map_perm_list_exists:
  assumes "A \<rightleftharpoons> map f B"
  shows "\<exists> B'. A = map f B' \<and> B' \<rightleftharpoons> B"
proof -
  have "\<forall>B. A \<rightleftharpoons> map f B \<longrightarrow> (\<exists> B'. A = map f B' \<and> B' \<rightleftharpoons> B)"
  proof (induct A)
    case Nil
    then show ?case by simp
  next
    case (Cons a A)
    {
      fix B
      assume "a # A \<rightleftharpoons> map f B"
      from this obtain b where b:
        "b \<in> set B"
        "f b = a"
        by (metis
              (full_types)
              imageE
              list.set_intros(1)
              set_map
              set_mset_mset)
      hence "A \<rightleftharpoons> (remove1 (f b) (map f B))"
            "B \<rightleftharpoons> b # remove1 b B"
        by (metis
              \<open>a # A \<rightleftharpoons> map f B\<close>
              perm_remove_perm
              remove_hd,
            meson b(1) perm_remove)
      hence "A \<rightleftharpoons> (map f (remove1 b B))"
        by (metis (no_types)
              list.simps(9)
              mset_map
              mset_remove1
              remove_hd)
      from this obtain B' where B':
        "A = map f B'"
        "B' \<rightleftharpoons> (remove1 b B)"
        using Cons.hyps by blast
      with b have "a # A = map f (b # B')"
        by simp
      moreover have "B \<rightleftharpoons> b # B'"
        by (metis B'(2) \<open>mset B = mset (b # remove1 b B)\<close> mset.simps(2))
      ultimately have "\<exists>B'. a # A = map f B' \<and> B' \<rightleftharpoons> B"
        by (meson perm_sym)
    }
    thus ?case by blast
  qed
  with assms show ?thesis by blast
qed

lemma mset_sub_map_list_exists:
  assumes "mset \<Phi> \<subseteq># mset (map f \<Gamma>)"
  shows "\<exists> \<Phi>'. mset \<Phi>' \<subseteq># mset \<Gamma> \<and> \<Phi> = (map f \<Phi>')"
proof -
  have "\<forall> \<Phi>. mset \<Phi> \<subseteq># mset (map f \<Gamma>)
              \<longrightarrow> (\<exists> \<Phi>'. mset \<Phi>' \<subseteq># mset \<Gamma> \<and> \<Phi> = (map f \<Phi>'))"
  proof (induct \<Gamma>)
    case Nil
    then show ?case by simp
  next
    case (Cons \<gamma> \<Gamma>)
    {
      fix \<Phi>
      assume "mset \<Phi> \<subseteq># mset (map f (\<gamma> # \<Gamma>))"
      have "\<exists>\<Phi>'. mset \<Phi>' \<subseteq># mset (\<gamma> # \<Gamma>) \<and> \<Phi> = map f \<Phi>'"
      proof cases
        assume "f \<gamma> \<in> set \<Phi>"
        hence "f \<gamma> # (remove1 (f \<gamma>) \<Phi>) \<rightleftharpoons> \<Phi>"
          by force
        with \<open>mset \<Phi> \<subseteq># mset (map f (\<gamma> # \<Gamma>))\<close>
        have "mset (remove1 (f \<gamma>) \<Phi>) \<subseteq># mset (map f \<Gamma>)"
          by (metis
                 insert_subset_eq_iff
                 list.simps(9)
                 mset.simps(2)
                 mset_remove1
                 remove_hd)
        from this Cons obtain \<Phi>' where \<Phi>':
          "mset \<Phi>' \<subseteq># mset \<Gamma>"
          "remove1 (f \<gamma>) \<Phi> = map f \<Phi>'"
          by blast
        hence "mset (\<gamma> # \<Phi>') \<subseteq># mset (\<gamma> # \<Gamma>)"
          and "f \<gamma> # (remove1 (f \<gamma>) \<Phi>) = map f (\<gamma> # \<Phi>')"
          by simp+
        hence "\<Phi> \<rightleftharpoons> map f (\<gamma> # \<Phi>')"
          using \<open>f \<gamma> \<in> set \<Phi>\<close> perm_remove
          by metis
        from this obtain \<Phi>'' where \<Phi>'':
          "\<Phi> = map f \<Phi>''"
          "\<Phi>'' \<rightleftharpoons> \<gamma> # \<Phi>'"
          using perm_map_perm_list_exists
          by blast
        hence "mset \<Phi>'' \<subseteq># mset (\<gamma> # \<Gamma>)"
          by (metis \<open>mset (\<gamma> # \<Phi>') \<subseteq># mset (\<gamma> # \<Gamma>)\<close>)
        thus ?thesis using \<Phi>'' by blast
      next
        assume "f \<gamma> \<notin> set \<Phi>"
        have "mset \<Phi> - {#f \<gamma>#} = mset \<Phi>"
          by (metis (no_types)
                \<open>f \<gamma> \<notin> set \<Phi>\<close>
                diff_single_trivial
                set_mset_mset)
        moreover
        have "mset (map f (\<gamma> # \<Gamma>))
                = add_mset (f \<gamma>) (image_mset f (mset \<Gamma>))"
          by simp
        ultimately have "mset \<Phi> \<subseteq># mset (map f \<Gamma>)"
          by (metis (no_types)
                Diff_eq_empty_iff_mset
                \<open>mset \<Phi> \<subseteq># mset (map f (\<gamma> # \<Gamma>))\<close>
                add_mset_add_single
                cancel_ab_semigroup_add_class.diff_right_commute
                diff_diff_add mset_map)
        with Cons show ?thesis
          by (metis
                mset_le_perm_append
                perm_append_single
                subset_mset.order_trans)
      qed
    }
    thus ?case using Cons by blast
  qed
  thus ?thesis using assms by blast
qed

section \<open> Laws for Searching a List \<close>

lemma find_Some_predicate:
  assumes "find P \<Psi> = Some \<psi>"
  shows "P \<psi>"
  using assms
proof (induct \<Psi>)
  case Nil
  then show ?case by simp
next
  case (Cons \<omega> \<Psi>)
  then show ?case by (cases "P \<omega>", fastforce+)
qed

lemma find_Some_set_membership:
  assumes "find P \<Psi> = Some \<psi>"
  shows "\<psi> \<in> set \<Psi>"
  using assms
proof (induct \<Psi>)
  case Nil
  then show ?case by simp
next
  case (Cons \<omega> \<Psi>)
  then show ?case by (cases "P \<omega>", fastforce+)
qed

section \<open> Permutations \<close>

lemma perm_count_list:
  assumes "\<Phi> \<rightleftharpoons> \<Psi>"
  shows "count_list \<Phi> \<phi> = count_list \<Psi> \<phi>"
  using assms
proof (induct \<Phi> arbitrary: \<Psi>)
  case Nil
  then show ?case
    by blast
next
  case (Cons \<chi> \<Phi> \<Psi>)
  hence \<diamondsuit>: "count_list \<Phi> \<phi> = count_list (remove1 \<chi> \<Psi>) \<phi>"
    by (metis mset_remove1 remove_hd)
  show ?case
  proof cases
    assume "\<chi> = \<phi>"
    hence "count_list (\<chi> # \<Phi>) \<phi> = count_list \<Phi> \<phi> + 1" by simp
    with \<diamondsuit> have "count_list (\<chi> # \<Phi>) \<phi> = count_list (remove1 \<chi> \<Psi>) \<phi> + 1"
      by simp
    moreover
    have "\<chi> \<in> set \<Psi>"
      by (metis Cons.prems list.set_intros(1) set_mset_mset)
    hence "count_list (remove1 \<chi> \<Psi>) \<phi> + 1 = count_list \<Psi> \<phi>"
      using \<open>\<chi> = \<phi>\<close>
      by (induct \<Psi>, simp, auto)
    ultimately show ?thesis by simp
  next
    assume "\<chi> \<noteq> \<phi>"
    with \<diamondsuit> have "count_list (\<chi> # \<Phi>) \<phi> = count_list (remove1 \<chi> \<Psi>) \<phi>"
      by simp
    moreover have "count_list (remove1 \<chi> \<Psi>) \<phi> = count_list \<Psi> \<phi>"
      using \<open>\<chi> \<noteq> \<phi>\<close>
      by (induct \<Psi>, simp+)
    ultimately show ?thesis by simp
  qed
qed

lemma count_list_append:
  "count_list (A @ B) a = count_list A a + count_list B a"
  by (induct A, simp, simp)

lemma concat_remove1:
  assumes "\<Psi> \<in> set \<L>"
  shows "concat \<L> \<rightleftharpoons> \<Psi> @ concat (remove1 \<Psi> \<L>)"
    using assms
    by (induct \<L>, simp, simp, metis)

lemma concat_set_membership_mset_containment:
  assumes "concat \<Gamma> \<rightleftharpoons> \<Lambda>"
  and     "\<Phi> \<in> set \<Gamma>"
  shows   "mset \<Phi> \<subseteq># mset \<Lambda>"
  using assms
  by (induct \<Gamma>, simp, simp, metis concat_remove1 mset_le_perm_append)

lemma (in comm_monoid_add) perm_list_summation:
  assumes "\<Psi> \<rightleftharpoons> \<Phi>"
  shows "(\<Sum>\<psi>'\<leftarrow>\<Psi>. f \<psi>') = (\<Sum>\<phi>'\<leftarrow>\<Phi>. f \<phi>')"
  using assms
proof (induct \<Psi> arbitrary: \<Phi>)
  case Nil
  then show ?case by auto
next
  case (Cons \<psi> \<Psi> \<Phi>)
  hence "(\<Sum>\<psi>' \<leftarrow> \<Psi>. f \<psi>') = (\<Sum>\<phi>' \<leftarrow> (remove1 \<psi> \<Phi>). f \<phi>')"
    by (metis mset_remove1 remove_hd)
  moreover have "\<psi> \<in> set \<Phi>"
    by (metis Cons.prems list.set_intros(1) set_mset_mset)
  hence "(\<Sum>\<phi>' \<leftarrow> (\<psi> # (remove1 \<psi> \<Phi>)). f \<phi>') = (\<Sum>\<phi>'\<leftarrow>\<Phi>. f \<phi>')"
  proof (induct \<Phi>)
    case Nil
    then show ?case by auto
  next
    case (Cons \<phi> \<Phi>)
    show ?case
    proof cases
      assume "\<phi> = \<psi>"
      then show ?thesis by simp
    next
      assume "\<phi> \<noteq> \<psi>"
      hence "\<psi> \<in> set \<Phi>"
        using Cons.prems by auto
      hence "(\<Sum>\<phi>' \<leftarrow> (\<psi> # (remove1 \<psi> \<Phi>)). f \<phi>') = (\<Sum>\<phi>'\<leftarrow>\<Phi>. f \<phi>')"
        using Cons.hyps by blast
      hence "(\<Sum>\<phi>'\<leftarrow>(\<phi> # \<Phi>). f \<phi>')
                = (\<Sum>\<phi>' \<leftarrow> (\<psi> # \<phi> # (remove1 \<psi> \<Phi>)). f \<phi>')"
        by (simp add: add.left_commute)
      moreover
      have "(\<psi> # (\<phi> # (remove1 \<psi> \<Phi>))) = (\<psi> # (remove1 \<psi> (\<phi> # \<Phi>)))"
        using \<open>\<phi> \<noteq> \<psi>\<close> by simp
      ultimately show ?thesis
        by simp
    qed
  qed
  ultimately show ?case
    by simp
qed

section \<open> List Duplicates \<close>

primrec duplicates :: "'a list \<Rightarrow> 'a set"
  where
    "duplicates [] = {}"
  | "duplicates (x # xs) =
       (if (x \<in> set xs)
        then insert x (duplicates xs)
        else duplicates xs)"

lemma duplicates_subset:
  "duplicates \<Phi> \<subseteq> set \<Phi>"
  by (induct \<Phi>, simp, auto)

lemma duplicates_alt_def:
  "duplicates xs = {x. count_list xs x \<ge> 2}"
proof (induct xs)
  case Nil
  then show ?case by simp
next
  case (Cons x xs)
  assume inductive_hypothesis: "duplicates xs = {x. 2 \<le> count_list xs x}"
  then show ?case
  proof cases
    assume "x \<in> set xs"
    hence "count_list (x # xs) x \<ge> 2"
      by (simp, induct xs, simp, simp, blast)
    hence "{y. 2 \<le> count_list (x # xs) y}
              = insert x {y. 2 \<le> count_list xs y}"
      by (simp,  blast)
    thus ?thesis using inductive_hypothesis \<open>x \<in> set xs\<close>
      by simp
  next
    assume "x \<notin> set xs"
    hence "{y. 2 \<le> count_list (x # xs) y} = {y. 2 \<le> count_list xs y}"
      by (simp, auto)
    thus ?thesis using inductive_hypothesis \<open>x \<notin> set xs\<close>
      by simp
  qed
qed

section \<open> List Subtraction \<close>

primrec list_subtract :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" (infixl "\<ominus>" 70)
  where
      "xs \<ominus> [] = xs"
    | "xs \<ominus> (y # ys) = (remove1 y (xs \<ominus> ys))"

lemma list_subtract_mset_homomorphism [simp]:
  "mset (A \<ominus> B) = mset A - mset B"
  by (induct B, simp, simp)

lemma list_subtract_empty [simp]:
  "[] \<ominus> \<Phi> = []"
  by (induct \<Phi>, simp, simp)

lemma list_subtract_remove1_cons_perm:
  "\<Phi> \<ominus> (\<phi> # \<Lambda>) \<rightleftharpoons> (remove1 \<phi> \<Phi>) \<ominus> \<Lambda>"
  by (induct \<Lambda>, simp, simp add: add_mset_commute)

lemma list_subtract_cons:
  assumes "\<phi> \<notin> set \<Lambda>"
  shows "(\<phi> # \<Phi>) \<ominus> \<Lambda> = \<phi> # (\<Phi> \<ominus> \<Lambda>)"
  using assms
  by (induct \<Lambda>, simp, simp, blast)

lemma list_subtract_cons_absorb:
  assumes "count_list \<Phi> \<phi> \<ge> count_list \<Lambda> \<phi>"
  shows "\<phi> # (\<Phi> \<ominus> \<Lambda>) \<rightleftharpoons> (\<phi> # \<Phi>) \<ominus> \<Lambda>"
  using assms
proof (induct \<Lambda> arbitrary: \<Phi>)
  case Nil
  then show ?case using list_subtract_cons by fastforce
next
  case (Cons \<psi> \<Lambda> \<Phi>)
  then show ?case
  proof cases
    assume "\<phi> = \<psi>"
    hence "\<phi> \<in> set \<Phi>"
      using Cons.prems count_notin by force
    hence "\<Phi> \<rightleftharpoons> \<phi> # (remove1 \<psi> \<Phi>)"
      unfolding \<open>\<phi> = \<psi>\<close>
      by force
    thus ?thesis using perm_count_list
      by (metis
            (no_types, lifting)
            Cons.hyps
            Cons.prems
            \<open>\<phi> = \<psi>\<close>
            add_le_cancel_right
            add_mset_diff_bothsides
            count_list.simps(2)
            list_subtract_mset_homomorphism
            mset.simps(2))
  next
    assume "\<phi> \<noteq> \<psi>"
    hence "count_list (\<psi> # \<Lambda>) \<phi> = count_list \<Lambda> \<phi>"
       by simp
    moreover have "count_list \<Phi> \<phi> = count_list (remove1 \<psi> \<Phi>) \<phi>"
    proof (induct \<Phi>)
      case Nil
      then show ?case by simp
    next
      case (Cons \<phi>' \<Phi>)
      show ?case
      proof cases
        assume "\<phi>' = \<phi>"
        with \<open>\<phi> \<noteq> \<psi>\<close>
        have "count_list (\<phi>' # \<Phi>) \<phi> = 1 + count_list \<Phi> \<phi>"
             "count_list (remove1 \<psi> (\<phi>' # \<Phi>)) \<phi>
                = 1 + count_list (remove1 \<psi> \<Phi>) \<phi>"
          by simp+
        with Cons show ?thesis by linarith
      next
        assume "\<phi>' \<noteq> \<phi>"
        with Cons show ?thesis by (cases "\<phi>' = \<psi>", simp+)
      qed
    qed
    ultimately show ?thesis
      using \<open>count_list (\<psi> # \<Lambda>) \<phi> \<le> count_list \<Phi> \<phi>\<close>
      by (metis
            Cons.hyps
            \<open>\<phi> \<noteq> \<psi>\<close>
            list_subtract_remove1_cons_perm
            mset.simps(2)
            remove1.simps(2))
  qed
qed

lemma list_subtract_cons_remove1_perm:
  assumes "\<phi> \<in> set \<Lambda>"
  shows "(\<phi> # \<Phi>) \<ominus> \<Lambda> \<rightleftharpoons> \<Phi> \<ominus> (remove1 \<phi> \<Lambda>)"
  using assms
  by (metis
        list_subtract_mset_homomorphism
        list_subtract_remove1_cons_perm
        perm_remove
        remove_hd)

lemma list_subtract_removeAll_perm:
  assumes "count_list \<Phi> \<phi> \<le> count_list \<Lambda> \<phi>"
  shows "\<Phi> \<ominus> \<Lambda> \<rightleftharpoons> (removeAll \<phi> \<Phi>) \<ominus> (removeAll \<phi> \<Lambda>)"
  using assms
proof (induct \<Phi> arbitrary: \<Lambda>)
  case Nil
  then show ?case by auto
next
  case (Cons \<xi> \<Phi> \<Lambda>)
  hence "\<Phi> \<ominus> \<Lambda> \<rightleftharpoons> (removeAll \<phi> \<Phi>) \<ominus> (removeAll \<phi> \<Lambda>)"
    by (metis add_leE count_list.simps(2))
  show ?case
  proof cases
    assume "\<xi> = \<phi>"
    hence "count_list \<Phi> \<phi> < count_list \<Lambda> \<phi>"
      using \<open>count_list (\<xi> # \<Phi>) \<phi> \<le> count_list \<Lambda> \<phi>\<close>
      by auto
    hence "count_list \<Phi> \<phi> \<le> count_list (remove1 \<phi> \<Lambda>) \<phi>"
      by (induct \<Lambda>, simp, auto)
    hence "\<Phi> \<ominus> (remove1 \<phi> \<Lambda>)
             \<rightleftharpoons> removeAll \<phi> \<Phi> \<ominus> removeAll \<phi> (remove1 \<phi> \<Lambda>)"
      using Cons.hyps by blast
    hence "\<Phi> \<ominus> (remove1 \<phi> \<Lambda>) \<rightleftharpoons> removeAll \<phi> \<Phi> \<ominus> removeAll \<phi> \<Lambda>"
      by (simp add: filter_remove1 removeAll_filter_not_eq)
    moreover have "\<phi> \<in> set \<Lambda>" and "\<phi> \<in> set (\<phi> # \<Phi>)"
      using \<open>\<xi> = \<phi>\<close>
            \<open>count_list (\<xi> # \<Phi>) \<phi> \<le> count_list \<Lambda> \<phi>\<close>
            gr_implies_not0
      by fastforce+
    hence "(\<phi> # \<Phi>) \<ominus> \<Lambda> \<rightleftharpoons> (remove1 \<phi> (\<phi> # \<Phi>)) \<ominus> (remove1 \<phi> \<Lambda>)"
      by (metis list_subtract_cons_remove1_perm remove_hd)

    hence "(\<phi> # \<Phi>) \<ominus> \<Lambda> \<rightleftharpoons> \<Phi> \<ominus> (remove1 \<phi> \<Lambda>)" by simp
    ultimately show ?thesis using \<open>\<xi> = \<phi>\<close> by auto
  next
    assume "\<xi> \<noteq> \<phi>"
    show ?thesis
    proof cases
      assume "\<xi> \<in> set \<Lambda>"
      hence "(\<xi> # \<Phi>) \<ominus> \<Lambda> \<rightleftharpoons> \<Phi> \<ominus> remove1 \<xi> \<Lambda>"
        by (meson list_subtract_cons_remove1_perm)
      moreover have "count_list \<Lambda> \<phi> = count_list (remove1 \<xi> \<Lambda>) \<phi>"
        by (metis
              count_list.simps(2)
              \<open>\<xi> \<noteq> \<phi>\<close>
              \<open>\<xi> \<in> set \<Lambda>\<close>
              perm_count_list
              perm_remove)
      hence "count_list \<Phi> \<phi> \<le> count_list (remove1 \<xi> \<Lambda>) \<phi>"
        using \<open>\<xi> \<noteq> \<phi>\<close> \<open>count_list (\<xi> # \<Phi>) \<phi> \<le> count_list \<Lambda> \<phi>\<close> by auto
      hence "\<Phi> \<ominus> remove1 \<xi> \<Lambda>
               \<rightleftharpoons> (removeAll \<phi> \<Phi>) \<ominus> (removeAll \<phi> (remove1 \<xi> \<Lambda>))"
        using Cons.hyps by blast
      moreover
      have "(removeAll \<phi> \<Phi>) \<ominus> (removeAll \<phi> (remove1 \<xi> \<Lambda>)) \<rightleftharpoons>
              (removeAll \<phi> \<Phi>) \<ominus> (remove1 \<xi> (removeAll \<phi> \<Lambda>))"
        by (induct \<Lambda>,
              simp,
              metis
                \<open>\<xi> \<noteq> \<phi>\<close>
                list_subtract.simps(2)
                mset_remove1
                remove1.simps(2)
                removeAll.simps(2))
      hence "(removeAll \<phi> \<Phi>) \<ominus> (removeAll \<phi> (remove1 \<xi> \<Lambda>)) \<rightleftharpoons>
               (removeAll \<phi> (\<xi> # \<Phi>)) \<ominus> (removeAll \<phi> \<Lambda>)"
        by (metis
              \<open>\<xi> \<in> set \<Lambda>\<close>
              \<open>\<xi> \<noteq> \<phi>\<close>
              list_subtract_cons_remove1_perm
              member_remove removeAll.simps(2)
              remove_code(1))
      ultimately show ?thesis
        by presburger
    next
      assume "\<xi> \<notin> set \<Lambda>"
      hence "(\<xi> # \<Phi>) \<ominus> \<Lambda> \<rightleftharpoons> \<xi> # (\<Phi> \<ominus> \<Lambda>)"
        by fastforce
      hence "(\<xi> # \<Phi>) \<ominus> \<Lambda> \<rightleftharpoons> \<xi> # ((removeAll \<phi> \<Phi>) \<ominus> (removeAll \<phi> \<Lambda>))"
        using \<open>\<Phi> \<ominus> \<Lambda> \<rightleftharpoons> removeAll \<phi> \<Phi> \<ominus> removeAll \<phi> \<Lambda>\<close>
        by simp
      hence "(\<xi> # \<Phi>) \<ominus> \<Lambda> \<rightleftharpoons> (\<xi> # (removeAll \<phi> \<Phi>)) \<ominus> (removeAll \<phi> \<Lambda>)"
        by (simp add: \<open>\<xi> \<notin> set \<Lambda>\<close> list_subtract_cons)
      thus ?thesis using \<open>\<xi> \<noteq> \<phi>\<close> by auto
    qed
  qed
qed

lemma list_subtract_permute:
  assumes "\<Phi> \<rightleftharpoons> \<Psi>"
  shows "\<Phi> \<ominus> \<Lambda> \<rightleftharpoons> \<Psi> \<ominus> \<Lambda>"
  using assms
  by simp

lemma append_perm_list_subtract_intro:
  assumes "A \<rightleftharpoons> B @ C"
  shows "A \<ominus> C \<rightleftharpoons> B"
proof -
  from \<open>A \<rightleftharpoons> B @ C\<close> have "mset (A \<ominus> C) = mset B"
    by simp
  thus ?thesis by blast
qed

lemma list_subtract_concat:
  assumes "\<Psi> \<in> set \<L>"
  shows "concat (\<L> \<ominus> [\<Psi>]) \<rightleftharpoons> (concat \<L>) \<ominus> \<Psi>"
  using assms
  by (simp add: concat_remove1)

lemma (in comm_monoid_add) listSubstract_multisubset_list_summation:
  assumes "mset \<Psi> \<subseteq># mset \<Phi>"
  shows "(\<Sum>\<psi>\<leftarrow>\<Psi>. f \<psi>) + (\<Sum>\<phi>'\<leftarrow>(\<Phi> \<ominus> \<Psi>). f \<phi>') = (\<Sum>\<phi>'\<leftarrow>\<Phi>. f \<phi>')"
proof -
  have "\<forall> \<Phi>. mset \<Psi> \<subseteq># mset \<Phi>
          \<longrightarrow> (\<Sum>\<psi>'\<leftarrow>\<Psi>. f \<psi>') + (\<Sum>\<phi>'\<leftarrow>(\<Phi> \<ominus> \<Psi>). f \<phi>') = (\<Sum>\<phi>'\<leftarrow>\<Phi>. f \<phi>')"
  proof(induct \<Psi>)
    case Nil
    then show ?case
      by simp
  next
    case (Cons \<psi> \<Psi>)
    {
      fix \<Phi>
      assume hypothesis: "mset (\<psi> # \<Psi>) \<subseteq># mset \<Phi>"
      hence "mset \<Psi> \<subseteq># mset (remove1 \<psi> \<Phi>)"
        by (metis append_Cons mset_le_perm_append perm_remove_perm remove_hd)
      hence
        "(\<Sum>\<psi>' \<leftarrow> \<Psi>. f \<psi>') + (\<Sum>\<phi>'\<leftarrow>((remove1 \<psi> \<Phi>) \<ominus> \<Psi>). f \<phi>')
               = (\<Sum>\<phi>'\<leftarrow> (remove1 \<psi> \<Phi>). f \<phi>')"
        using Cons.hyps by blast
      moreover have "(remove1 \<psi> \<Phi>) \<ominus> \<Psi> \<rightleftharpoons> \<Phi> \<ominus> (\<psi> # \<Psi>)"
        by (meson list_subtract_remove1_cons_perm perm_sym)
      hence "(\<Sum>\<phi>'\<leftarrow>((remove1 \<psi> \<Phi>) \<ominus> \<Psi>). f \<phi>') = (\<Sum>\<phi>'\<leftarrow>(\<Phi> \<ominus> (\<psi> # \<Psi>)). f \<phi>')"
        using perm_list_summation by blast
      ultimately have
        "(\<Sum>\<psi>' \<leftarrow> \<Psi>. f \<psi>') + (\<Sum>\<phi>'\<leftarrow>(\<Phi> \<ominus> (\<psi> # \<Psi>)). f \<phi>')
               = (\<Sum>\<phi>'\<leftarrow> (remove1 \<psi> \<Phi>). f \<phi>')"
        by simp
      hence
        "(\<Sum>\<psi>' \<leftarrow> (\<psi> # \<Psi>). f \<psi>') + (\<Sum>\<phi>'\<leftarrow>(\<Phi> \<ominus> (\<psi> # \<Psi>)). f \<phi>')
               = (\<Sum>\<phi>'\<leftarrow> (\<psi> # (remove1 \<psi> \<Phi>)). f \<phi>')"
        by (simp add: add.assoc)
      moreover have "\<psi> \<in> set \<Phi>"
        by (metis
              append_Cons
              hypothesis
              list.set_intros(1)
              mset_le_perm_append
              perm_set_eq)
      hence "(\<psi> # (remove1 \<psi> \<Phi>)) \<rightleftharpoons> \<Phi>"
        by auto
      hence "(\<Sum>\<phi>' \<leftarrow> (\<psi> # (remove1 \<psi> \<Phi>)). f \<phi>') = (\<Sum>\<phi>'\<leftarrow>\<Phi>. f \<phi>')"
        using perm_list_summation by blast
      ultimately have
        "(\<Sum>\<psi>' \<leftarrow> (\<psi> # \<Psi>). f \<psi>') + (\<Sum>\<phi>'\<leftarrow>(\<Phi> \<ominus> (\<psi> # \<Psi>)). f \<phi>')
               = (\<Sum>\<phi>'\<leftarrow>\<Phi>. f \<phi>')"
        by simp
    }
    then show ?case
      by blast
  qed
  with assms show ?thesis by blast
qed

lemma list_subtract_set_difference_lower_bound:
  "set \<Gamma> - set \<Phi> \<subseteq> set (\<Gamma> \<ominus> \<Phi>)"
  using subset_Diff_insert
  by (induct \<Phi>, simp, fastforce)

lemma list_subtract_set_trivial_upper_bound:
  "set (\<Gamma> \<ominus> \<Phi>) \<subseteq> set \<Gamma>"
      by (induct \<Phi>,
          simp,
          simp,
          meson
            dual_order.trans
            set_remove1_subset)

lemma list_subtract_msub_eq:
  assumes "mset \<Phi> \<subseteq># mset \<Gamma>"
      and "length (\<Gamma> \<ominus> \<Phi>) = m"
    shows "length \<Gamma> = m + length \<Phi>"
  using assms
proof -
  have "\<forall> \<Gamma>. mset \<Phi> \<subseteq># mset \<Gamma>
           \<longrightarrow> length (\<Gamma> \<ominus> \<Phi>) = m --> length \<Gamma> = m + length \<Phi>"
  proof (induct \<Phi>)
    case Nil
    then show ?case by simp
  next
    case (Cons \<phi> \<Phi>)
    {
      fix \<Gamma> :: "'a list"
      assume "mset (\<phi> # \<Phi>) \<subseteq># mset \<Gamma>"
             "length (\<Gamma> \<ominus> (\<phi> # \<Phi>)) = m"
      moreover from this have
        "mset \<Phi> \<subseteq># mset (remove1 \<phi> \<Gamma>)"
        "mset (\<Gamma> \<ominus> (\<phi> # \<Phi>)) = mset ((remove1 \<phi> \<Gamma>) \<ominus> \<Phi>)"
        by (metis
              append_Cons
              mset_le_perm_append
              perm_remove_perm
              remove_hd,
            simp)
      ultimately have "length (remove1 \<phi> \<Gamma>) = m + length \<Phi>"
        using Cons.hyps
        by (metis mset_eq_length)
      hence "length (\<phi> # (remove1 \<phi> \<Gamma>)) = m + length (\<phi> # \<Phi>)"
        by simp
      moreover have "\<phi> \<in> set \<Gamma>"
        by (metis
              \<open>mset (\<Gamma> \<ominus> (\<phi> # \<Phi>)) = mset (remove1 \<phi> \<Gamma> \<ominus> \<Phi>)\<close>
              \<open>mset (\<phi> # \<Phi>) \<subseteq># mset \<Gamma>\<close>
              \<open>mset \<Phi> \<subseteq># mset (remove1 \<phi> \<Gamma>)\<close>
              add_diff_cancel_left'
              add_right_cancel
              eq_iff
              impossible_Cons
              list_subtract_mset_homomorphism
              mset_subset_eq_exists_conv
              remove1_idem size_mset)
      hence "length (\<phi> # (remove1 \<phi> \<Gamma>)) = length \<Gamma>"
        by (metis
              One_nat_def
              Suc_pred
              length_Cons
              length_pos_if_in_set
              length_remove1)
      ultimately have "length \<Gamma> = m + length (\<phi> # \<Phi>)" by simp
    }
    thus ?case by blast
  qed
  thus ?thesis using assms by blast
qed

lemma list_subtract_not_member:
  assumes "b \<notin> set A"
  shows "A \<ominus> B = A \<ominus> (remove1 b B)"
  using assms
  by (induct B,
      simp,
      simp,
      metis
        add_mset_add_single
        diff_subset_eq_self
        insert_DiffM2
        insert_subset_eq_iff
        list_subtract_mset_homomorphism
        remove1_idem
        set_mset_mset)

lemma list_subtract_monotonic:
  assumes "mset A \<subseteq># mset B"
  shows "mset (A \<ominus> C) \<subseteq># mset (B \<ominus> C)"
  by (simp,
      meson
        assms
        subset_eq_diff_conv
        subset_mset.dual_order.refl
        subset_mset.order_trans)

lemma map_list_subtract_mset_containment:
  "mset ((map f A) \<ominus> (map f B)) \<subseteq># mset (map f (A \<ominus> B))"
  by (induct B, simp, simp,
      metis
        diff_subset_eq_self
        diff_zero
        image_mset_add_mset
        image_mset_subseteq_mono
        image_mset_union
        subset_eq_diff_conv
        subset_eq_diff_conv)

lemma map_list_subtract_mset_equivalence:
  assumes "mset B \<subseteq># mset A"
  shows "mset ((map f A) \<ominus> (map f B)) = mset (map f (A \<ominus> B))"
  using assms
  by (induct B, simp, simp add: image_mset_Diff)

lemma msub_list_subtract_elem_cons_msub:
  assumes "mset \<Xi> \<subseteq># mset \<Gamma>"
      and "\<psi> \<in> set (\<Gamma> \<ominus> \<Xi>)"
    shows "mset (\<psi> # \<Xi>) \<subseteq># mset \<Gamma>"
proof -
  have "\<forall> \<Gamma>. mset \<Xi> \<subseteq># mset \<Gamma>
             \<longrightarrow> \<psi> \<in> set (\<Gamma> \<ominus> \<Xi>) --> mset (\<psi> # \<Xi>) \<subseteq># mset \<Gamma>"
  proof(induct \<Xi>)
    case Nil
    then show ?case by simp
  next
    case (Cons \<xi> \<Xi>)
    {
      fix \<Gamma>
      assume
        "mset (\<xi> # \<Xi>) \<subseteq># mset \<Gamma>"
        "\<psi> \<in> set (\<Gamma> \<ominus> (\<xi> # \<Xi>))"
      hence
         "\<xi> \<in> set \<Gamma>"
         "mset \<Xi> \<subseteq># mset (remove1 \<xi> \<Gamma>)"
         "\<psi> \<in> set ((remove1 \<xi> \<Gamma>) \<ominus> \<Xi>)"
        by (simp,
            metis
              ex_mset
              list.set_intros(1)
              mset.simps(2)
              mset_eq_setD
              subset_mset.le_iff_add
              union_mset_add_mset_left,
            metis
              list_subtract.simps(1)
              list_subtract.simps(2)
              list_subtract_monotonic
              remove_hd,
            simp,
            metis
              list_subtract_remove1_cons_perm
              perm_set_eq)
      with Cons.hyps have
        "mset \<Gamma> = mset (\<xi> # (remove1 \<xi> \<Gamma>))"
        "mset (\<psi> # \<Xi>) \<subseteq># mset (remove1 \<xi> \<Gamma>)"
        by (simp, blast)
      hence "mset (\<psi> # \<xi> # \<Xi>) \<subseteq># mset \<Gamma>"
        by (simp,
            metis
              add_mset_commute
              mset_subset_eq_add_mset_cancel)
    }
    then show ?case by auto
  qed
  thus ?thesis using assms by blast
qed

section \<open> Tuple Lists \<close>

lemma remove1_pairs_list_projections_fst:
  assumes "(\<gamma>,\<sigma>) \<in># mset \<Phi>"
  shows "mset (map fst (remove1 (\<gamma>, \<sigma>) \<Phi>)) = mset (map fst \<Phi>) - {# \<gamma> #}"
using assms
proof (induct \<Phi>)
  case Nil
  then show ?case by simp
next
  case (Cons \<phi> \<Phi>)
  assume "(\<gamma>, \<sigma>) \<in># mset (\<phi> # \<Phi>)"
  show ?case
  proof (cases "\<phi> = (\<gamma>, \<sigma>)")
    assume "\<phi> = (\<gamma>, \<sigma>)"
    then show ?thesis by simp
  next
    assume "\<phi> \<noteq> (\<gamma>, \<sigma>)"
    then have "add_mset \<phi> (mset \<Phi> - {#(\<gamma>, \<sigma>)#})
             = add_mset \<phi> (mset \<Phi>) - {#(\<gamma>, \<sigma>)#}"
        by force
    then have "add_mset (fst \<phi>) (image_mset fst (mset \<Phi> - {#(\<gamma>, \<sigma>)#}))
                = add_mset (fst \<phi>) (image_mset fst (mset \<Phi>)) - {#\<gamma>#}"
      by (metis (no_types) Cons.prems
                           add_mset_remove_trivial
                           fst_conv
                           image_mset_add_mset
                           insert_DiffM mset.simps(2))
    with \<open>\<phi> \<noteq> (\<gamma>, \<sigma>)\<close> show ?thesis
      by simp
  qed
qed

lemma remove1_pairs_list_projections_snd:
  assumes "(\<gamma>,\<sigma>) \<in># mset \<Phi>"
  shows "mset (map snd (remove1 (\<gamma>, \<sigma>) \<Phi>)) = mset (map snd \<Phi>) - {# \<sigma> #}"
using assms
proof (induct \<Phi>)
  case Nil
  then show ?case by simp
next
  case (Cons \<phi> \<Phi>)
  assume "(\<gamma>, \<sigma>) \<in># mset (\<phi> # \<Phi>)"
  show ?case
  proof (cases "\<phi> = (\<gamma>, \<sigma>)")
    assume "\<phi> = (\<gamma>, \<sigma>)"
    then show ?thesis by simp
  next
    assume "\<phi> \<noteq> (\<gamma>, \<sigma>)"
    then have "add_mset (snd \<phi>) (image_mset snd (mset \<Phi> - {#(\<gamma>, \<sigma>)#}))
             = image_mset snd (mset (\<phi> # \<Phi>) - {#(\<gamma>, \<sigma>)#})"
      by auto
    moreover have "add_mset (snd \<phi>) (image_mset snd (mset \<Phi>))
                 = add_mset \<sigma> (image_mset snd (mset (\<phi> # \<Phi>) - {#(\<gamma>, \<sigma>)#}))"
      by (metis (no_types)
             Cons.prems
             image_mset_add_mset
             insert_DiffM
             mset.simps(2)
             snd_conv)
    ultimately
    have "add_mset (snd \<phi>) (image_mset snd (mset \<Phi> - {#(\<gamma>, \<sigma>)#}))
                = add_mset (snd \<phi>) (image_mset snd (mset \<Phi>)) - {#\<sigma>#}"
      by simp
    with \<open>\<phi> \<noteq> (\<gamma>, \<sigma>)\<close> show ?thesis
      by simp
  qed
qed

lemma triple_list_exists:
  assumes "mset (map snd \<Psi>) \<subseteq># mset \<Sigma>"
      and "mset \<Sigma> \<subseteq># mset (map snd \<Delta>)"
    shows "\<exists> \<Omega>. map (\<lambda> (\<psi>, \<sigma>, _). (\<psi>, \<sigma>)) \<Omega> = \<Psi> \<and>
                mset (map (\<lambda> (_, \<sigma>, \<gamma>). (\<gamma>, \<sigma>)) \<Omega>) \<subseteq># mset \<Delta>"
  using assms(1)
proof (induct \<Psi>)
  case Nil
  then show ?case by fastforce
next
  case (Cons \<psi> \<Psi>)
  from Cons obtain \<Omega> where \<Omega>:
    "map (\<lambda> (\<psi>, \<sigma>, _). (\<psi>, \<sigma>)) \<Omega> = \<Psi>"
    "mset (map (\<lambda> (_, \<sigma>, \<gamma>). (\<gamma>, \<sigma>)) \<Omega>) \<subseteq># mset \<Delta>"
    by (metis
          (no_types, lifting)
          diff_subset_eq_self
          list.set_intros(1)
          remove1_pairs_list_projections_snd
          remove_hd
          set_mset_mset
          subset_mset.dual_order.trans
          surjective_pairing)
  let ?\<Delta>\<^sub>\<Omega> = "map (\<lambda> (_, \<sigma>, \<gamma>). (\<gamma>, \<sigma>)) \<Omega>"
  let ?\<psi> = "fst \<psi>"
  let ?\<sigma> = "snd \<psi>"
  from Cons.prems have "add_mset ?\<sigma> (image_mset snd (mset \<Psi>)) \<subseteq># mset \<Sigma>"
    by simp
  then have "mset \<Sigma> - {#?\<sigma>#} - image_mset snd (mset \<Psi>)
                \<noteq> mset \<Sigma> - image_mset snd (mset \<Psi>)"
    by (metis
          (no_types)
          insert_subset_eq_iff
          mset_subset_eq_insertD
          multi_drop_mem_not_eq
          subset_mset.diff_add
          subset_mset_def)
  hence "?\<sigma> \<in># mset \<Sigma> - mset (map snd \<Psi>)"
    using diff_single_trivial by fastforce
  have "mset (map snd (\<psi> # \<Psi>)) \<subseteq># mset (map snd \<Delta>)"
    by (meson
          Cons.prems
          \<open>mset \<Sigma> \<subseteq># mset (map snd \<Delta>)\<close>
          subset_mset.dual_order.trans)
  then have
    "mset (map snd \<Delta>) - mset (map snd (\<psi> # \<Psi>)) + ({#} + {#snd \<psi>#})
       = mset (map snd \<Delta>) + ({#} + {#snd \<psi>#})
           - add_mset (snd \<psi>) (mset (map snd \<Psi>))"
    by (metis
          (no_types)
          list.simps(9)
          mset.simps(2)
          mset_subset_eq_multiset_union_diff_commute)
  then have
    "mset (map snd \<Delta>) - mset (map snd (\<psi> # \<Psi>)) + ({#} + {#snd \<psi>#})
       = mset (map snd \<Delta>) - mset (map snd \<Psi>)"
    by auto
  hence "?\<sigma> \<in># mset (map snd \<Delta>) - mset (map snd \<Psi>)"
    using add_mset_remove_trivial_eq by fastforce
  moreover have "snd \<circ> (\<lambda> (\<psi>, \<sigma>, _). (\<psi>, \<sigma>)) = snd \<circ> (\<lambda> (_, \<sigma>, \<gamma>). (\<gamma>, \<sigma>))"
    by auto
  hence "map snd (?\<Delta>\<^sub>\<Omega>) = map snd (map (\<lambda> (\<psi>, \<sigma>, _). (\<psi>, \<sigma>)) \<Omega>)"
    by fastforce
  hence "map snd (?\<Delta>\<^sub>\<Omega>) = map snd \<Psi>"
    using \<Omega>(1) by simp
  ultimately have "?\<sigma> \<in># mset (map snd \<Delta>) - mset (map snd ?\<Delta>\<^sub>\<Omega>)"
    by simp
  hence "?\<sigma> \<in># image_mset snd (mset \<Delta> - mset ?\<Delta>\<^sub>\<Omega>)"
    using \<Omega>(2) by (metis image_mset_Diff mset_map)
  hence "?\<sigma> \<in> snd ` set_mset (mset \<Delta> - mset ?\<Delta>\<^sub>\<Omega>)"
    by (metis in_image_mset)
  from this obtain \<rho> where \<rho>:
    "snd \<rho> = ?\<sigma>" "\<rho> \<in># mset \<Delta> - mset ?\<Delta>\<^sub>\<Omega>"
    using imageE by auto
  from this obtain \<gamma> where
    "(\<gamma>, ?\<sigma>) = \<rho>"
    by (metis prod.collapse)
  with \<rho>(2) have \<gamma>: "(\<gamma>, ?\<sigma>) \<in># mset \<Delta> - mset ?\<Delta>\<^sub>\<Omega>" by auto
  let ?\<Omega> = "(?\<psi>, ?\<sigma>, \<gamma>) # \<Omega>"
  have "map (\<lambda> (\<psi>, \<sigma>, _). (\<psi>, \<sigma>)) ?\<Omega> = \<psi> # \<Psi>"
    using \<Omega>(1) by simp
  moreover
  have A: "(\<gamma>, snd \<psi>) = (case (snd \<psi>, \<gamma>) of (a, c) \<Rightarrow> (c, a))"
    by auto
  have B: "mset (map (\<lambda>(b, a, c). (c, a)) \<Omega>)
             + {# case (snd \<psi>, \<gamma>) of (a, c) \<Rightarrow> (c, a) #}
           = mset (map (\<lambda>(b, a, c). (c, a)) ((fst \<psi>, snd \<psi>, \<gamma>) # \<Omega>))"
    by simp
  obtain mm
     :: "('c \<times> 'a) multiset
     \<Rightarrow> ('c \<times> 'a) multiset
     \<Rightarrow> ('c \<times> 'a) multiset"
    where "\<forall>x0 x1. (\<exists>v2. x0 = x1 + v2) = (x0 = x1 + mm x0 x1)"
    by moura
  then have "mset \<Delta> = mset (map (\<lambda>(b, a, c). (c, a)) \<Omega>)
                        + mm (mset \<Delta>) (mset (map (\<lambda>(b, a, c). (c, a)) \<Omega>))"
    by (metis \<Omega>(2) subset_mset.le_iff_add)
  then have "mset (map (\<lambda> (_, \<sigma>, \<gamma>). (\<gamma>, \<sigma>)) ?\<Omega>) \<subseteq># mset \<Delta>"
    using A B by
      (metis
         \<gamma>
         add_diff_cancel_left'
         single_subset_iff
         subset_mset.add_le_cancel_left)
  ultimately show ?case by meson
qed

section \<open> List Intersection \<close>

primrec list_intersect :: "'a list => 'a list => 'a list"  (infixl "\<^bold>\<inter>" 60)
  where
    "_ \<^bold>\<inter> [] = []"
  | "xs \<^bold>\<inter> (y # ys) =
        (if (y \<in> set xs)
         then (y # (remove1 y xs \<^bold>\<inter> ys))
         else (xs \<^bold>\<inter> ys))"

lemma list_intersect_mset_homomorphism [simp]:
  "mset (\<Phi> \<^bold>\<inter> \<Psi>) = mset \<Phi> \<inter># mset \<Psi>"
proof -
  have "\<forall> \<Phi>. mset (\<Phi> \<^bold>\<inter> \<Psi>) = mset \<Phi> \<inter># mset \<Psi>"
  proof (induct \<Psi>)
    case Nil
    then show ?case by simp
  next
    case (Cons \<psi> \<Psi>)
    {
      fix \<Phi>
      have "mset (\<Phi> \<^bold>\<inter> \<psi> # \<Psi>) = mset \<Phi> \<inter># mset (\<psi> # \<Psi>)"
        using Cons.hyps
        by (cases "\<psi> \<in> set \<Phi>",
            simp add: inter_add_right2,
            simp add: inter_add_right1)
    }
    then show ?case by blast
  qed
  thus ?thesis by simp
qed

lemma list_intersect_left_empty [simp]: "[] \<^bold>\<inter> \<Phi> = []" by (induct \<Phi>, simp+)

lemma list_diff_intersect_comp:
  "mset \<Phi> = mset (\<Phi> \<ominus> \<Psi>) + mset (\<Phi> \<^bold>\<inter> \<Psi>)"
  by (metis
        diff_intersect_left_idem
        list_intersect_mset_homomorphism
        list_subtract_mset_homomorphism
        subset_mset.inf_le1
        subset_mset.le_imp_diff_is_add)

lemma list_intersect_left_project: "mset (\<Phi> \<^bold>\<inter> \<Psi>) \<subseteq># mset \<Phi>"
  by simp

lemma list_intersect_right_project: "mset (\<Phi> \<^bold>\<inter> \<Psi>) \<subseteq># mset \<Psi>"
  by simp

end


(*  Title:      ZF/Induct/Primrec.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section \<open>Primitive Recursive Functions: the inductive definition\<close>

theory Primrec imports Main begin

text \<open>
  Proof adopted from @{cite szasz93}.

  See also @{cite \<open>page 250, exercise 11\<close> mendelson}.
\<close>

subsection \<open>Basic definitions\<close>

definition
  SC :: "i"  where
  "SC == \<lambda>l \<in> list(nat). list_case(0, \<lambda>x xs. succ(x), l)"

definition
  CONSTANT :: "i=>i"  where
  "CONSTANT(k) == \<lambda>l \<in> list(nat). k"

definition
  PROJ :: "i=>i"  where
  "PROJ(i) == \<lambda>l \<in> list(nat). list_case(0, \<lambda>x xs. x, drop(i,l))"

definition
  COMP :: "[i,i]=>i"  where
  "COMP(g,fs) == \<lambda>l \<in> list(nat). g ` map(\<lambda>f. f`l, fs)"

definition
  PREC :: "[i,i]=>i"  where
  "PREC(f,g) ==
     \<lambda>l \<in> list(nat). list_case(0,
                      \<lambda>x xs. rec(x, f`xs, \<lambda>y r. g ` Cons(r, Cons(y, xs))), l)"
  \<comment> \<open>Note that \<open>g\<close> is applied first to @{term "PREC(f,g)`y"} and then to \<open>y\<close>!\<close>

consts
  ACK :: "i=>i"
primrec
  "ACK(0) = SC"
  "ACK(succ(i)) = PREC (CONSTANT (ACK(i) ` [1]), COMP(ACK(i), [PROJ(0)]))"

abbreviation
  ack :: "[i,i]=>i" where
  "ack(x,y) == ACK(x) ` [y]"

text \<open>
  \medskip Useful special cases of evaluation.
\<close>

lemma SC: "[| x \<in> nat;  l \<in> list(nat) |] ==> SC ` (Cons(x,l)) = succ(x)"
  by (simp add: SC_def)

lemma CONSTANT: "l \<in> list(nat) ==> CONSTANT(k) ` l = k"
  by (simp add: CONSTANT_def)

lemma PROJ_0: "[| x \<in> nat;  l \<in> list(nat) |] ==> PROJ(0) ` (Cons(x,l)) = x"
  by (simp add: PROJ_def)

lemma COMP_1: "l \<in> list(nat) ==> COMP(g,[f]) ` l = g` [f`l]"
  by (simp add: COMP_def)

lemma PREC_0: "l \<in> list(nat) ==> PREC(f,g) ` (Cons(0,l)) = f`l"
  by (simp add: PREC_def)

lemma PREC_succ:
  "[| x \<in> nat;  l \<in> list(nat) |]
    ==> PREC(f,g) ` (Cons(succ(x),l)) =
      g ` Cons(PREC(f,g)`(Cons(x,l)), Cons(x,l))"
  by (simp add: PREC_def)

subsection \<open>Inductive definition of the PR functions\<close>

consts
  prim_rec :: i

inductive
  domains prim_rec \<subseteq> "list(nat)->nat"
  intros
    "SC \<in> prim_rec"
    "k \<in> nat ==> CONSTANT(k) \<in> prim_rec"
    "i \<in> nat ==> PROJ(i) \<in> prim_rec"
    "[| g \<in> prim_rec; fs\<in>list(prim_rec) |] ==> COMP(g,fs) \<in> prim_rec"
    "[| f \<in> prim_rec; g \<in> prim_rec |] ==> PREC(f,g) \<in> prim_rec"
  monos list_mono
  con_defs SC_def CONSTANT_def PROJ_def COMP_def PREC_def
  type_intros nat_typechecks list.intros
    lam_type list_case_type drop_type map_type
    apply_type rec_type

lemma prim_rec_into_fun [TC]: "c \<in> prim_rec ==> c \<in> list(nat) -> nat"
  by (erule subsetD [OF prim_rec.dom_subset])

lemmas [TC] = apply_type [OF prim_rec_into_fun]

declare prim_rec.intros [TC]
declare nat_into_Ord [TC]
declare rec_type [TC]

lemma ACK_in_prim_rec [TC]: "i \<in> nat ==> ACK(i) \<in> prim_rec"
  by (induct set: nat) simp_all

lemma ack_type [TC]: "[| i \<in> nat;  j \<in> nat |] ==>  ack(i,j) \<in> nat"
  by auto

subsection \<open>Ackermann's function cases\<close>

lemma ack_0: "j \<in> nat ==> ack(0,j) = succ(j)"
  \<comment> \<open>PROPERTY A 1\<close>
  by (simp add: SC)

lemma ack_succ_0: "ack(succ(i), 0) = ack(i,1)"
  \<comment> \<open>PROPERTY A 2\<close>
  by (simp add: CONSTANT PREC_0)

lemma ack_succ_succ:
  "[| i\<in>nat;  j\<in>nat |] ==> ack(succ(i), succ(j)) = ack(i, ack(succ(i), j))"
  \<comment> \<open>PROPERTY A 3\<close>
  by (simp add: CONSTANT PREC_succ COMP_1 PROJ_0)

lemmas [simp] = ack_0 ack_succ_0 ack_succ_succ ack_type
  and [simp del] = ACK.simps

lemma lt_ack2: "i \<in> nat ==> j \<in> nat ==> j < ack(i,j)"
  \<comment> \<open>PROPERTY A 4\<close>
  apply (induct i arbitrary: j set: nat)
   apply simp
  apply (induct_tac j)
   apply (erule_tac [2] succ_leI [THEN lt_trans1])
   apply (rule nat_0I [THEN nat_0_le, THEN lt_trans])
   apply auto
  done

lemma ack_lt_ack_succ2: "[|i\<in>nat; j\<in>nat|] ==> ack(i,j) < ack(i, succ(j))"
  \<comment> \<open>PROPERTY A 5-, the single-step lemma\<close>
  by (induct set: nat) (simp_all add: lt_ack2)

lemma ack_lt_mono2: "[| j<k; i \<in> nat; k \<in> nat |] ==> ack(i,j) < ack(i,k)"
  \<comment> \<open>PROPERTY A 5, monotonicity for \<open><\<close>\<close>
  apply (frule lt_nat_in_nat, assumption)
  apply (erule succ_lt_induct)
    apply assumption
   apply (rule_tac [2] lt_trans)
    apply (auto intro: ack_lt_ack_succ2)
  done

lemma ack_le_mono2: "[|j\<le>k;  i\<in>nat;  k\<in>nat|] ==> ack(i,j) \<le> ack(i,k)"
  \<comment> \<open>PROPERTY A 5', monotonicity for \<open>\<le>\<close>\<close>
  apply (rule_tac f = "\<lambda>j. ack (i,j) " in Ord_lt_mono_imp_le_mono)
     apply (assumption | rule ack_lt_mono2 ack_type [THEN nat_into_Ord])+
  done

lemma ack2_le_ack1:
  "[| i\<in>nat;  j\<in>nat |] ==> ack(i, succ(j)) \<le> ack(succ(i), j)"
  \<comment> \<open>PROPERTY A 6\<close>
  apply (induct_tac j)
   apply simp_all
  apply (rule ack_le_mono2)
    apply (rule lt_ack2 [THEN succ_leI, THEN le_trans])
      apply auto
  done

lemma ack_lt_ack_succ1: "[| i \<in> nat; j \<in> nat |] ==> ack(i,j) < ack(succ(i),j)"
  \<comment> \<open>PROPERTY A 7-, the single-step lemma\<close>
  apply (rule ack_lt_mono2 [THEN lt_trans2])
     apply (rule_tac [4] ack2_le_ack1)
      apply auto
  done

lemma ack_lt_mono1: "[| i<j; j \<in> nat; k \<in> nat |] ==> ack(i,k) < ack(j,k)"
  \<comment> \<open>PROPERTY A 7, monotonicity for \<open><\<close>\<close>
  apply (frule lt_nat_in_nat, assumption)
  apply (erule succ_lt_induct)
    apply assumption
   apply (rule_tac [2] lt_trans)
    apply (auto intro: ack_lt_ack_succ1)
  done

lemma ack_le_mono1: "[| i\<le>j; j \<in> nat; k \<in> nat |] ==> ack(i,k) \<le> ack(j,k)"
  \<comment> \<open>PROPERTY A 7', monotonicity for \<open>\<le>\<close>\<close>
  apply (rule_tac f = "\<lambda>j. ack (j,k) " in Ord_lt_mono_imp_le_mono)
     apply (assumption | rule ack_lt_mono1 ack_type [THEN nat_into_Ord])+
  done

lemma ack_1: "j \<in> nat ==> ack(1,j) = succ(succ(j))"
  \<comment> \<open>PROPERTY A 8\<close>
  by (induct set: nat) simp_all

lemma ack_2: "j \<in> nat ==> ack(succ(1),j) = succ(succ(succ(j#+j)))"
  \<comment> \<open>PROPERTY A 9\<close>
  by (induct set: nat) (simp_all add: ack_1)

lemma ack_nest_bound:
  "[| i1 \<in> nat; i2 \<in> nat; j \<in> nat |]
    ==> ack(i1, ack(i2,j)) < ack(succ(succ(i1#+i2)), j)"
  \<comment> \<open>PROPERTY A 10\<close>
  apply (rule lt_trans2 [OF _ ack2_le_ack1])
    apply simp
    apply (rule add_le_self [THEN ack_le_mono1, THEN lt_trans1])
       apply auto
  apply (force intro: add_le_self2 [THEN ack_lt_mono1, THEN ack_lt_mono2])
  done

lemma ack_add_bound:
  "[| i1 \<in> nat; i2 \<in> nat; j \<in> nat |]
    ==> ack(i1,j) #+ ack(i2,j) < ack(succ(succ(succ(succ(i1#+i2)))), j)"
  \<comment> \<open>PROPERTY A 11\<close>
  apply (rule_tac j = "ack (succ (1), ack (i1 #+ i2, j))" in lt_trans)
   apply (simp add: ack_2)
   apply (rule_tac [2] ack_nest_bound [THEN lt_trans2])
      apply (rule add_le_mono [THEN leI, THEN leI])
         apply (auto intro: add_le_self add_le_self2 ack_le_mono1)
  done

lemma ack_add_bound2:
     "[| i < ack(k,j);  j \<in> nat;  k \<in> nat |]
      ==> i#+j < ack(succ(succ(succ(succ(k)))), j)"
  \<comment> \<open>PROPERTY A 12.\<close>
  \<comment> \<open>Article uses existential quantifier but the ALF proof used @{term "k#+#4"}.\<close>
  \<comment> \<open>Quantified version must be nested \<open>\<exists>k'. \<forall>i,j \<dots>\<close>.\<close>
  apply (rule_tac j = "ack (k,j) #+ ack (0,j) " in lt_trans)
   apply (rule_tac [2] ack_add_bound [THEN lt_trans2])
      apply (rule add_lt_mono)
         apply auto
  done

subsection \<open>Main result\<close>

declare list_add_type [simp]

lemma SC_case: "l \<in> list(nat) ==> SC ` l < ack(1, list_add(l))"
  apply (unfold SC_def)
  apply (erule list.cases)
   apply (simp add: succ_iff)
  apply (simp add: ack_1 add_le_self)
  done

lemma lt_ack1: "[| i \<in> nat; j \<in> nat |] ==> i < ack(i,j)"
  \<comment> \<open>PROPERTY A 4'? Extra lemma needed for \<open>CONSTANT\<close> case, constant functions.\<close>
  apply (induct_tac i)
   apply (simp add: nat_0_le)
  apply (erule lt_trans1 [OF succ_leI ack_lt_ack_succ1])
   apply auto
  done

lemma CONSTANT_case:
    "[| l \<in> list(nat);  k \<in> nat |] ==> CONSTANT(k) ` l < ack(k, list_add(l))"
  by (simp add: CONSTANT_def lt_ack1)

lemma PROJ_case [rule_format]:
    "l \<in> list(nat) ==> \<forall>i \<in> nat. PROJ(i) ` l < ack(0, list_add(l))"
  apply (unfold PROJ_def)
  apply simp
  apply (erule list.induct)
   apply (simp add: nat_0_le)
  apply simp
  apply (rule ballI)
  apply (erule_tac n = i in natE)
   apply (simp add: add_le_self)
  apply simp
  apply (erule bspec [THEN lt_trans2])
   apply (rule_tac [2] add_le_self2 [THEN succ_leI])
   apply auto
  done

text \<open>
  \medskip \<open>COMP\<close> case.
\<close>

lemma COMP_map_lemma:
  "fs \<in> list({f \<in> prim_rec. \<exists>kf \<in> nat. \<forall>l \<in> list(nat). f`l < ack(kf, list_add(l))})
    ==> \<exists>k \<in> nat. \<forall>l \<in> list(nat).
      list_add(map(\<lambda>f. f ` l, fs)) < ack(k, list_add(l))"
  apply (induct set: list)
   apply (rule_tac x = 0 in bexI)
    apply (simp_all add: lt_ack1 nat_0_le)
  apply clarify
  apply (rule ballI [THEN bexI])
  apply (rule add_lt_mono [THEN lt_trans])
       apply (rule_tac [5] ack_add_bound)
         apply blast
        apply auto
  done

lemma COMP_case:
 "[| kg\<in>nat;
     \<forall>l \<in> list(nat). g`l < ack(kg, list_add(l));
     fs \<in> list({f \<in> prim_rec .
                 \<exists>kf \<in> nat. \<forall>l \<in> list(nat).
                        f`l < ack(kf, list_add(l))}) |]
   ==> \<exists>k \<in> nat. \<forall>l \<in> list(nat). COMP(g,fs)`l < ack(k, list_add(l))"
  apply (simp add: COMP_def)
  apply (frule list_CollectD)
  apply (erule COMP_map_lemma [THEN bexE])
  apply (rule ballI [THEN bexI])
   apply (erule bspec [THEN lt_trans])
    apply (rule_tac [2] lt_trans)
     apply (rule_tac [3] ack_nest_bound)
       apply (erule_tac [2] bspec [THEN ack_lt_mono2])
         apply auto
  done

text \<open>
  \medskip \<open>PREC\<close> case.
\<close>

lemma PREC_case_lemma:
 "[| \<forall>l \<in> list(nat). f`l #+ list_add(l) < ack(kf, list_add(l));
     \<forall>l \<in> list(nat). g`l #+ list_add(l) < ack(kg, list_add(l));
     f \<in> prim_rec;  kf\<in>nat;
     g \<in> prim_rec;  kg\<in>nat;
     l \<in> list(nat) |]
  ==> PREC(f,g)`l #+ list_add(l) < ack(succ(kf#+kg), list_add(l))"
  apply (unfold PREC_def)
  apply (erule list.cases)
   apply (simp add: lt_trans [OF nat_le_refl lt_ack2])
  apply simp
  apply (erule ssubst)  \<comment> \<open>get rid of the needless assumption\<close>
  apply (induct_tac a)
   apply simp_all
   txt \<open>base case\<close>
   apply (rule lt_trans, erule bspec, assumption)
   apply (simp add: add_le_self [THEN ack_lt_mono1])
  txt \<open>ind step\<close>
  apply (rule succ_leI [THEN lt_trans1])
   apply (rule_tac j = "g ` ll #+ mm" for ll mm in lt_trans1)
    apply (erule_tac [2] bspec)
    apply (rule nat_le_refl [THEN add_le_mono])
       apply typecheck
   apply (simp add: add_le_self2)
   txt \<open>final part of the simplification\<close>
  apply simp
  apply (rule add_le_self2 [THEN ack_le_mono1, THEN lt_trans1])
     apply (erule_tac [4] ack_lt_mono2)
      apply auto
  done

lemma PREC_case:
   "[| f \<in> prim_rec;  kf\<in>nat;
       g \<in> prim_rec;  kg\<in>nat;
       \<forall>l \<in> list(nat). f`l < ack(kf, list_add(l));
       \<forall>l \<in> list(nat). g`l < ack(kg, list_add(l)) |]
    ==> \<exists>k \<in> nat. \<forall>l \<in> list(nat). PREC(f,g)`l< ack(k, list_add(l))"
  apply (rule ballI [THEN bexI])
   apply (rule lt_trans1 [OF add_le_self PREC_case_lemma])
          apply typecheck
     apply (blast intro: ack_add_bound2 list_add_type)+
  done

lemma ack_bounds_prim_rec:
    "f \<in> prim_rec ==> \<exists>k \<in> nat. \<forall>l \<in> list(nat). f`l < ack(k, list_add(l))"
  apply (induct set: prim_rec)
  apply (auto intro: SC_case CONSTANT_case PROJ_case COMP_case PREC_case)
  done

theorem ack_not_prim_rec:
    "(\<lambda>l \<in> list(nat). list_case(0, \<lambda>x xs. ack(x,x), l)) \<notin> prim_rec"
  apply (rule notI)
  apply (drule ack_bounds_prim_rec)
  apply force
  done

end


section "Ramsey's Theorem"

theory Ramsey
imports Main "HOL-Library.Infinite_Set"
begin

declare [[simp_depth_limit = 5]]

subsection "Library lemmas"

lemma infinite_inj_infinite_image: "infinite Z \<Longrightarrow> inj_on f Z \<Longrightarrow> infinite (f ` Z)"
  apply(rule ccontr)
  apply(simp)
  apply(force dest: finite_imageD)
  done

lemma infinite_dom_finite_rng: "[| infinite A; finite (f ` A) |] ==> \<exists>b \<in> f ` A. infinite {a : A. f a = b}"
  apply(rule ccontr) apply(simp)
  apply(subgoal_tac "\<Union>((\<lambda>b. {a : A. f a = f b}) ` A) = A") prefer 2 apply(blast)
  apply(subgoal_tac "(UN c : f ` A. {a : A. f a = c})= (UN b:A. {a : A. f a = f b})") prefer 2 apply(blast)
  apply(subgoal_tac "finite (UN c:f ` A. {a : A. f a = c})") apply(force)
  apply(rule finite_UN_I)
  apply(auto)
  done

lemma infinite_mem: "infinite X \<Longrightarrow> \<exists>x. x \<in> X"
  apply(rule ccontr)
  apply(force)
  done

subsection "Dependent Choice Variant"

  \<comment> \<open>%%cut choice\<close>
primrec choice :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a" where
  "choice P R 0 = (SOME x. P x)"
| "choice P R (Suc n) = (let x = choice P R n in SOME y. P y \<and> R x y)"
  \<comment> \<open>%%tuc\<close>

lemma dc: "
  (\<forall>x y z. R x y \<and> R y z \<longrightarrow> R x z)
  \<and> (\<exists>x0. P x0)
  \<and> (\<forall>x. P x \<longrightarrow> (\<exists>y. P y \<and> R x y))
  \<longrightarrow> (\<exists>f::nat\<Rightarrow>'b. (\<forall>n. P (f n)) \<and> (\<forall>n m. R (f n) (f (n+m+1))))
 "
  apply(intro allI impI, elim exE conjE)
  apply(rule_tac x="choice P R" in exI)
  apply(subgoal_tac "(\<forall>n. P (choice P R n))") prefer 2
  apply(rule, induct_tac n)
  apply(simp add: Let_def) apply(rule someI_ex) apply(blast)
  apply(simp add: Let_def) apply(subgoal_tac "P (SOME y. P y \<and> R (choice P R na) y) \<and> R (choice P R na) (SOME y. P y \<and> R (choice P R na) y)") apply(blast) apply(rule someI_ex) apply(blast)
  apply(rule) apply(assumption)

  apply(subgoal_tac "\<forall>n. R (choice P R n) (choice P R (Suc n))") prefer 2
  apply(rule)
  apply(simp add: Let_def)
  apply(subgoal_tac "P (SOME y. P y \<and> R (choice P R n) y) \<and>  R (choice P R n) (SOME y. P y \<and> R (choice P R n) y)") apply(blast)
  apply(rule someI_ex) apply(force)

  apply(rule) apply(rule)
  apply(induct_tac m)
  apply(force)
  apply(drule_tac x="n+na+1" in spec) back
  apply(force simp del: choice.simps)
  done

subsection "Partitions"

(* expect Y infinite *)
definition
  part :: "nat \<Rightarrow> nat \<Rightarrow> 'a set \<Rightarrow> ('a set \<Rightarrow> nat) \<Rightarrow> bool" where
  "part r s Y f = (\<forall>X. X \<subseteq> Y \<and> finite X \<and> card X = r \<longrightarrow> f X < s)"

lemma part: "[| infinite YY; part (Suc n) s YY f; yy : YY |] ==> part n s (YY - {yy}) (\<lambda>u. f (insert yy u))"
  apply(simp add: part_def)
  apply(intro allI impI, elim exE conjE)
  apply(drule_tac x="insert yy X" in spec)
  apply(force simp:card_Diff_singleton_if)
  done

lemma part_subset: "part (Suc n) s YY f \<Longrightarrow> Y \<subseteq> YY \<Longrightarrow> part (Suc n) s Y f"
  apply(simp add: part_def)
  apply(blast)
  done

subsection "Ramsey's theorem"

(* state theorem so it doesn't require part definition *)

  apply(intro allI impI)
  apply(rule_tac x="YY" in exI)
  apply(rule_tac x="f {}" in exI)
  apply(force simp: part_def)

  apply(intro allI impI) apply(elim exE conjE)

  (* now get the infinite g *)
  apply(subgoal_tac "
    \<exists>g.
    (\<forall>m::nat. let (y,Y,t) = (g m) in
    y \<in> YY \<and> y \<notin> Y
    \<and> Y \<subseteq> YY \<and> infinite Y
    \<and> t < s
    \<and> (\<forall>X. X \<subseteq> Y \<and> finite X \<and> card X = nat \<longrightarrow> (f \<circ> insert y) X = t))
    \<and> (\<forall>m m'.
    let (y,Y,t) = (g m) in
    let (y',Y',t') =(g (m+m'+1)) in
    y' : Y
    \<and> Y' \<subseteq> Y
    )
    ")
   prefer 2
   apply(cut_tac

     P = "\<lambda>gn.
     let (y,Y,t) = (gn) in
     y \<in> YY \<and> y \<notin> Y
     \<and> Y \<subseteq> YY \<and> infinite Y
     \<and> t < s
     \<and> (\<forall>X. X \<subseteq> Y \<and> finite X \<and> card X = nat \<longrightarrow> (f \<circ> insert y) X = t)
     "

     and R = "\<lambda>gn gn'.
     let (y,Y,t) = (gn) in
     let (y',Y',t') =(gn') in
     y' : Y
     \<and> Y' \<subseteq> Y
     "

     in dc)
   apply(erule impE)
   (* 3 *)
    apply(intro conjI)
      apply(intro allI impI, elim conjE) apply(simp add: Let_def split_beta) apply(blast)
     apply(subgoal_tac "\<exists>yy. yy \<in> YY") prefer 2 apply(rule infinite_mem) apply(assumption)
     apply(elim exE conjE)
     apply(drule_tac x="YY - {yy}" in spec) apply(drule_tac x="f \<circ> insert yy" in spec)
     apply(erule impE) apply(simp) apply(rule part) apply(assumption+)
     apply(elim exE conjE)
     apply(rule_tac x="(yy,Y',t')" in exI) apply(simp) apply(blast)
    apply(intro allI impI)
    apply(case_tac x) apply(rename_tac yx b Yx tx)
    apply(subgoal_tac "\<exists>yx'. yx' \<in> Yx") prefer 2 apply(rule infinite_mem) apply(force)
    apply(elim exE conjE)
    apply(drule_tac x="Yx - {yx'}" in spec)
    apply(drule_tac x="f \<circ> insert yx'" in spec)
    apply(erule impE) apply(simp) apply(elim exE conjE) apply(rule part) apply(assumption+)
    apply(rule part_subset) apply(assumption) apply(assumption) apply(assumption)
    apply(elim exE conjE)
    apply(rule_tac x="(yx',Y',t')" in exI) apply(simp) apply(blast)
   apply(assumption)

  apply(elim exE conjE)

  apply(subgoal_tac "\<exists>s'. s' < s \<and> infinite {n. (\<lambda>n. let (y,Y,t) = g n in t) n = s'}") prefer 2

  apply(subgoal_tac "\<exists>s' \<in> ((\<lambda>n. let (Y, y, t) = g n in t) ` UNIV). infinite {n : UNIV. (let (Y, y, t) = g n in t) = s'}") prefer 2
  apply(rule infinite_dom_finite_rng) apply(simp)
  apply(simp (no_asm) add: finite_nat_iff_bounded)
  apply(rule_tac x=s in exI)
  apply(rule)
  apply(simp add: image_iff) apply(elim exE conjE)
  apply(drule_tac x=xa in spec) apply(force simp add: Let_def split_beta)
  apply(elim bexE conjE) apply(rule_tac x=s' in exI) apply(simp)
  apply(simp add: image_iff) apply(elim exE conjE) apply(drule_tac x=x in spec) apply(force simp: Let_def split_beta)

  apply(elim exE conjE)
  apply(rule_tac x="(\<lambda>n. let (y,Y,t) = g n in y) ` {n. (\<lambda>n. let (y,Y,t) = g n in t) n = s'}" in exI)
  apply(rule_tac x=s' in exI)
  (* lift this because it is needed in later subgoals *)
  apply(subgoal_tac "inj (\<lambda>n. let (y, Y, t) = g n in y)") prefer 2
  apply(simp add: inj_on_def)
  (* minor optimisation *)
  apply(subgoal_tac "\<forall>x y. x < y \<and> (let (y, Y, t) = g x in y) = (let (y, Y, t) = g y in y) \<longrightarrow> x = y")
  apply(intro allI impI)
  apply(subgoal_tac "x < y | x = y | y < x") prefer 2 apply(arith)
  apply(elim disjE)
  apply(drule_tac x=x in spec) back back apply(drule_tac x=y in spec) back back apply(force simp: Let_def)
  apply(assumption)
  apply(drule_tac x=y in spec) back back apply(drule_tac x=x in spec) back back apply(force simp: Let_def)
  apply(intro allI impI)
  apply(drule_tac x=x in spec) apply(drule_tac x=x in spec) apply(drule_tac x="y-(Suc x)" in spec) apply(force simp: Let_def)

  apply(intro allI conjI)

  apply(drule_tac x=xa in spec)
  apply(force simp add: Let_def split_beta)

  apply(rule infinite_inj_infinite_image) apply(assumption)
  apply(simp add: inj_on_def)

  apply(simp)

  (* difficult goal- need that the other members of X all occur in Ya *)
  apply(intro allI impI, elim exE conjE)
  apply(simp add: subset_image_iff) apply(elim exE conjE)
  apply(subgoal_tac "\<exists>a. a \<in> AA \<and> (\<forall>a'. a' \<in> AA \<longrightarrow> a \<le> a')") prefer 2 apply(rule not_empty_least) apply(force)
  apply(elim exE conjE)
  apply(case_tac "g a" rule: prod.exhaust)
  apply(rename_tac b) apply(case_tac b rule: prod.exhaust) apply(rename_tac ya b Ya ta)
  apply(subgoal_tac "ya : X") prefer 2 apply(force intro!: rev_image_eqI simp: Let_def)
  apply(drule_tac s=X in sym)
  apply(subgoal_tac "f X = (f \<circ> insert ya) (X - {ya})") apply(simp)
  apply(drule_tac x=a in spec)
  apply(simp add: Let_def) apply(elim exE conjE)
  apply(drule_tac x="X-{ya}" in spec) back apply(erule impE)
  apply(simp)
  apply(rule)
  apply(rule)
  apply(drule_tac t=X in sym) apply(simp)
  apply(simp add: image_iff) apply(elim bexE exE conjE) apply(rename_tac a')
  apply(subgoal_tac "a' \<noteq> a") prefer 2 apply(force)
  apply(drule_tac x=a in spec)
  apply(drule_tac x="a'-Suc a" in spec) back
  apply(simp add: Let_def split_beta) apply(case_tac "g a'" rule: prod.exhaust) apply(case_tac ba rule: prod.exhaust) apply(rename_tac ya' ba Ya' ta') apply(simp add: Let_def split_beta)
  apply(drule_tac x=a' in spec) apply(erule impE) apply(force)
  apply(force)
  apply(force simp add: card_Diff_singleton_if)
  apply(subgoal_tac "ta = s'") apply(simp) apply(force)
  apply(simp) apply(rule_tac f=f in arg_cong) apply(force)
  done

end


theory CommAnd
  imports Main

begin

text\<open> Apply style \<close>
lemma lem_k_1 : "(p \<and> q) \<longrightarrow> (q \<and> p)"
  apply (rule impI)
  apply (rule conjI)
  apply (erule conjE)
   apply assumption
  apply (erule conjE)
  apply assumption
  done

text\<open> Isar style, the proof illustrates the use of intermediate facts,
   once more with keywords 'from ... have ...' \<close>
lemma lem_l_1 : "(p \<and> q) \<longrightarrow> (q \<and> p)"
proof
  assume a : "p \<and> q"
  from a have b : "p" by (rule conjE)     (* INTERMEDIATE fact *)
  from a have c : "q" by (rule conjE)     (* INTERMEDIATE fact *)
  from c b show "q \<and> p" by (rule conjI)   (* we must write 'from c b' not 'from b c' *)
qed

text\<open> Isar style, lem_l_1 again, with more abbreviations \<close>
lemma lem_l_2 : "(p \<and> q) \<longrightarrow> (q \<and> p)"
proof
  assume a : "p \<and> q"
  from a have b : "p" ..
  from a have c : "q" ..
  from c b show "(q \<and> p)" ..
qed

text\<open> Isar style, lem_l_1 again, with nested proofs \<close>
lemma lem_l_3 : "(p \<and> q) \<longrightarrow> (q \<and> p)"
proof
  assume a : "p \<and> q"
  from a show "q \<and> p"
  proof
    assume b : "p"
    assume c : "q"
    from c b show "q \<and> p" by (rule conjI)
  qed
qed
end


(***********************************************************************
* HiVe theory files
*
* Copyright (C) 2015 Commonwealth of Australia as represented by Defence Science and Technology
* Group (DST Group)
*
* All rights reserved.
*
* The HiVe theory files are free software: released for redistribution and use, and/or modification,
* under the BSD License, details of which can be found in the LICENSE file included in the
* distribution.
************************************************************************)

header {* Extensions to the \isa{type{\isacharunderscore}definition} locale *}

theory
  xHOL_TypeDef

imports
  xHOL_Lemmas_Chap

begin

text {*

The @{text Typedef} theory gives some useful rules for reasoning
about type definitions and organises them into a locale framework.
In this section we introduce an theorem attribute for instantiating these
rules and extend the locale with some more useful results.

*}

subsection {* Instantiating @{text "type_definition"} theorems *}

ML {*

local

  fun tdi_apply get Tnm =
  let
    fun mk_thm x thm =
    let
      val tydef_T = get x (("type_definition_"^Tnm));
    in
      tydef_T RS thm
    end;
  in
    Thm.rule_attribute mk_thm
  end;

in

val TDINST_setup =
  Attrib.setup (Binding.name "TDINST")
    (Scan.lift Args.name >> tdi_apply (fn ctxt => (Global_Theory.get_thm (Context.theory_of ctxt))))
    "positional instantiation of theorem";
end;

*}

setup {* TDINST_setup *}

subsection {* Some derived @{text "type_definition"} lemmas *}

context type_definition

begin

lemma Rep_image:
  "{ x | x \<in> X \<bullet> Rep x } \<subseteq> A"
  by (auto simp add: Rep)

lemma Rep_image':
  "{ x \<bullet> Rep x } \<subseteq> A"
  by (auto simp add: Rep)

lemma Rep_eqI:
  assumes a1: "Rep x = Rep y"
  shows "x = y"
  using a1
  by (simp add: Rep_inject)

lemma Rep_eqI':
  assumes a1: "x = y"
  shows "Rep x = Rep y"
  using a1
  by (simp)

lemma Abs_eq_onI:
  assumes
    a1: "x \<in> A" "y \<in> A" "Abs x = Abs y"
  shows
    "x = y"
  using a1
  by (simp add: Abs_inject)

lemma Abs_eq_onI':
  assumes
    a1: "x = y"
  shows
    "Abs x = Abs y"
  using a1
  by (simp)

lemma Rep_connect_on:
  assumes
    a1: "y \<in> A"
  shows
    "(Rep x = y) \<Leftrightarrow> (x = Abs y)"
proof -
  from type_definition_axioms a1 have
    "Rep x = y
    \<Leftrightarrow> Abs (Rep x) = Abs y"
    by (simp add: Abs_inject Rep)
  also from type_definition_axioms have "\<dots>
    \<Leftrightarrow> x = Abs y"
    by (simp add: Rep_inverse)
  finally show ?thesis
    by (this)
qed

lemma Abs_connect_on:
  assumes
    a1: "x \<in> A"
  shows
    "(Abs x = y) \<Leftrightarrow> (x = Rep y)"
proof -
  from type_definition_axioms have
  "Abs x = y
  \<Leftrightarrow> Rep (Abs x) = Rep y"
    by (simp add: Rep_inject Rep)
  also from type_definition_axioms a1 have "\<dots>
  \<Leftrightarrow> x = Rep y"
    by (simp add: Abs_inverse)
  finally show ?thesis
    by (this)
qed

lemma Rep_inj:
  "inj Rep"
  by (auto intro!: inj_onI simp add: Rep_inject)

lemma Abs_inj_on:
  "inj_on Abs A"
  by (auto intro!: inj_onI simp add: Abs_inject)

lemma Rep_onto_on:
  assumes
    a1: "y \<in> A"
  shows
    "\<exists> x \<bullet> y = Rep x"
proof -
  from a1 have a2: "y = Rep (Abs y)" by (simp add: Abs_inverse)
  from a2 show ?thesis by (auto)
qed

lemma Abs_onto_on:
  "\<exists> y \<bullet> y \<in> A \<and> x = Abs y"
proof -
  have a1: "Rep x \<in> A" by (rule Rep)
  have a2: "Abs (Rep x) = x" by (simp add: Rep_inverse)
  from a1 a2 show ?thesis by (auto)
qed

lemma Rep_char:
  "(y \<in> A) = (\<exists> x \<bullet> y = Rep x)"
by (auto intro: Rep_onto_on Rep)

lemma Rep_nonempty:
  "A \<noteq> \<emptyset>"
proof -
  obtain x::'b where True by (auto)
  have "Rep x \<in> A" by (rule Rep)
  then show ?thesis by (auto)
qed

lemma Rep_inverse_raw:
  "Abs \<circ> Rep = id"
  by (auto intro!: ext simp add: Rep_inverse)

lemma (in type_definition) Rep_inverse_image:
  "Abs\<lparr>Rep\<lparr>X\<rparr>\<rparr> = X"
  by (auto simp add: image_def Rep_inverse)

lemma Abs_inverse_image_on:
  assumes
    a1: "X \<subseteq> A"
  shows
    "Rep\<lparr>Abs\<lparr>X\<rparr>\<rparr> = X"
  using a1
  by (auto simp add: image_def Abs_inverse subset_eq)

lemma Rep_image_eq_iff:
  "Rep\<lparr>X\<rparr> = Rep\<lparr>Y\<rparr> \<Leftrightarrow> X = Y"
  by (rule inj_image_eq_iff [OF Rep_inj])

lemma Abs_image_eq_iff_on:
  assumes
    a1: "X \<subseteq> A" and
    a2: "Y \<subseteq> A"
  shows
    "Abs\<lparr>X\<rparr> = Abs\<lparr>Y\<rparr> \<Leftrightarrow> X = Y"
  apply (rule inj_on_Un_image_eq_iff)
  apply (rule subset_inj_on)
  apply (rule Abs_inj_on)
  using a1 a2
  apply (auto)
  done

lemma Abs_image_connect_on:
  assumes
    a1: "X \<subseteq> A"
  shows
    "Abs\<lparr>X\<rparr> \<subseteq> Y \<Leftrightarrow> X \<subseteq> Rep\<lparr>Y\<rparr>"
  apply (auto simp add: image_def subset_eq Rep_inverse)
  apply (rule bexI)
  apply (rule Abs_inverse [symmetric])
  using a1
  apply (auto)
  done

lemma Abs_image_connect_eq_on:
  assumes
    a1: "X \<subseteq> A"
  shows
    "Abs\<lparr>X\<rparr> = Y \<Leftrightarrow> X = Rep\<lparr>Y\<rparr>"
  apply (subst (2) Abs_inverse_image_on [symmetric, OF a1])
  apply (simp add: Rep_image_eq_iff)
  done

lemma Rep_image_connect_on:
  assumes
    a1: "X \<subseteq> A"
  shows
    "Rep\<lparr>Y\<rparr> \<subseteq> X \<Leftrightarrow> Y \<subseteq> Abs\<lparr>X\<rparr>"
  apply (auto simp add: image_def subset_eq)
  apply (rule bexI)
  apply (rule Rep_inverse [symmetric])
  using a1
  apply (auto elim!: ballE simp add: Abs_inverse)
  done

lemma Rep_image_connect_eq_on:
  assumes
    a1: "X \<subseteq> A"
  shows
    "Rep\<lparr>Y\<rparr> = X \<Leftrightarrow> Y = Abs\<lparr>X\<rparr>"
  apply (subst Abs_inverse_image_on [symmetric, OF a1])
  apply (simp add: Rep_image_eq_iff)
  done

lemma Rep_image_Int:
  "Rep\<lparr>X \<inter> Y\<rparr> = Rep\<lparr>X\<rparr> \<inter> Rep\<lparr>Y\<rparr>"
  by (rule image_Int [OF Rep_inj])

lemma Abs_image_Int_on:
  assumes
    a1: "X \<subseteq> A" and
    a2: "Y \<subseteq> A"
  shows
    "Abs\<lparr>X \<inter> Y\<rparr> = Abs\<lparr>X\<rparr> \<inter> Abs\<lparr>Y\<rparr>"
  by (rule inj_on_image_Int [OF Abs_inj_on a1 a2])

lemma all_Abs_iff:
  "(\<forall> x \<bullet> P x) \<Leftrightarrow> (\<forall> y \<bullet> P (Abs y))"
  apply (auto)
  apply (subst Rep_inverse [symmetric])
  apply (auto)
  done

lemma ex_Abs_iff:
  "(\<exists> x \<bullet> P x) \<Leftrightarrow> (\<exists> y \<bullet> P (Abs y))"
  apply (auto)
  apply (subst (asm) Rep_inverse [symmetric])
  apply (auto)
  done

end

locale epi_type_definition =
  fixes Rep and Abs
  assumes
    Rep_surj: "range Rep = \<univ>" and
    Rep_inverse: "Abs (Rep x) = x"

sublocale epi_type_definition \<subseteq> TD: type_definition "Rep" "Abs" "\<univ>"
proof (rule type_definition.intro)
  fix
    x :: "'b"
  from Rep_surj show
    "Rep x \<in> \<univ>"
    by (auto)
  from Rep_inverse show
    "Abs (Rep x) = x"
    by (auto)
next
  fix
    y :: "'a"
  from Rep_surj obtain x where
    "y = Rep x"
    by (auto)
  then show
    "Rep (Abs y) = y"
    by (simp add: Rep_inverse)
qed

lemma (in type_definition) epiI:
  assumes
    a1: "A = \<univ>"
  shows
    "epi_type_definition Rep Abs"
  apply (rule epi_type_definition.intro)
  using a1 Rep_range Rep_inverse
  apply (auto)
  done

context epi_type_definition

begin

lemma Abs_inverse:
  "Rep (Abs r) = r"
  by (simp add: TD.Abs_inverse)

lemma Abs_inject:
  "(Abs x = Abs y) \<Leftrightarrow> (x = y)"
  by (simp add: TD.Abs_inject)

lemma Rep_cases [cases set]:
  assumes
    hyp: "!!x. y = Rep x ==> P"
  shows
    "P"
  apply (rule TD.Rep_cases)
  apply (auto intro: hyp)
  done

lemma Abs_cases [cases type]:
  assumes
    r: "\<And> y \<bullet> x = Abs y \<turnstile> P"
  shows
    "P"
  apply (rule TD.Abs_cases)
  apply (auto intro: r)
  done

lemma Rep_induct [induct set]:
  assumes
    hyp: "!!x. P (Rep x)"
  shows
    "P y"
  apply (rule TD.Rep_induct)
  apply (auto intro: hyp)
  done

lemma Abs_induct [induct type]:
  assumes
    r: "\<And> y \<bullet> P (Abs y)"
  shows
   "P x"
  apply (rule TD.Abs_induct)
  apply (auto intro: r)
  done

lemmas Abs_surj = TD.Abs_image

lemma Abs_inverse_raw:
  "Rep \<circ> Abs = id"
  by (auto intro!: ext simp add: TD.Abs_inverse)

lemma Abs_inj:
  "inj Abs"
  using TD.Abs_inj_on
  by (simp)

lemma Abs_eqI:
  assumes
    a1: "Abs x = Abs y"
  shows
    "x = y"
  apply (rule TD.Abs_eq_onI)
  apply (auto simp add: a1)
  done

lemma Rep_connect:
  "(Rep x = y) \<Leftrightarrow> (x = Abs y)"
  apply (rule TD.Rep_connect_on)
  apply (simp)
  done

lemma Abs_connect:
  "(Abs x = y) \<Leftrightarrow> (x = Rep y)"
  apply (rule TD.Abs_connect_on)
  apply (simp)
  done

lemma Rep_onto:
  "\<exists> x \<bullet> y = Rep x"
  apply (rule TD.Rep_onto_on)
  apply (simp)
  done

lemma Abs_onto:
  "\<exists> y \<bullet> x = Abs y"
  using TD.Abs_onto_on [of "x"]
  apply (auto)
  done

lemma Abs_inverse_image:
  "Rep\<lparr>Abs\<lparr>X\<rparr>\<rparr> = X"
  apply (rule TD.Abs_inverse_image_on)
  apply (simp)
  done

lemma Abs_image_eq_iff:
  "Abs\<lparr>X\<rparr> = Abs\<lparr>Y\<rparr> \<Leftrightarrow> X = Y"
  apply (rule TD.Abs_image_eq_iff_on)
  apply (auto)
  done

lemma Abs_image_connect:
  "Abs\<lparr>X\<rparr> \<subseteq> Y \<Leftrightarrow> X \<subseteq> Rep\<lparr>Y\<rparr>"
  apply (rule TD.Abs_image_connect_on)
  apply (auto)
  done

lemma Abs_image_connect_eq:
  "Abs\<lparr>X\<rparr> = Y \<Leftrightarrow> X = Rep\<lparr>Y\<rparr>"
  apply (rule TD.Abs_image_connect_eq_on)
  apply (auto)
  done

lemma Rep_image_connect:
  "Rep\<lparr>Y\<rparr> \<subseteq> X \<Leftrightarrow> Y \<subseteq> Abs\<lparr>X\<rparr>"
  apply (rule TD.Rep_image_connect_on)
  apply (auto)
  done

lemma Rep_image_connect_eq:
  "Rep\<lparr>Y\<rparr> = X \<Leftrightarrow> Y = Abs\<lparr>X\<rparr>"
  apply (rule TD.Rep_image_connect_eq_on)
  apply (auto)
  done

lemma Abs_image_Int:
  "Abs\<lparr>X \<inter> Y\<rparr> = Abs\<lparr>X\<rparr> \<inter> Abs\<lparr>Y\<rparr>"
  apply (rule TD.Abs_image_Int_on)
  apply (auto)
  done

lemma all_Rep_iff:
  "(\<forall> x \<bullet> P (Rep x)) \<Leftrightarrow> (\<forall> y \<bullet> P y)"
  apply (auto)
  apply (subst Abs_inverse [symmetric])
  apply (auto)
  done

lemma ex_Rep_iff:
  "(\<exists> x \<bullet> P (Rep x)) \<Leftrightarrow> (\<exists> y \<bullet> P y)"
  apply (auto)
  apply (subst (asm) Abs_inverse [symmetric])
  apply (auto)
  done

end

end


theory General_Utils
  imports "HOL-Analysis.Analysis"
begin

lemma lambda_skolem_gen: "(\<forall>i. \<exists>f'::('a ^ 'n) \<Rightarrow> 'a. P i f') \<longleftrightarrow>
   (\<exists>f'::('a ^ 'n) \<Rightarrow> ('a ^ 'n). \<forall>i. P i ((\<lambda>x. (f' x) $ i)))" (is "?lhs \<longleftrightarrow> ?rhs")
  (*using choice_iff lambda_skolem*)
proof -
  { assume H: "?rhs"
    then have ?lhs by auto }
  moreover
  { assume H: "?lhs"
    then obtain f'' where f'':"\<forall>i. P i (f'' i)" unfolding choice_iff
      by metis
    let ?x = "(\<lambda>x. (\<chi> i. (f''  i) x))"
    { fix i
      from f'' have "P i (f'' i)" by metis
      then have "P i (\<lambda>x.(?x x) $ i)" by auto
    }
    hence "\<forall>i. P i (\<lambda>x.(?x x) $ i)" by metis
    hence ?rhs by metis}
  ultimately show ?thesis by metis
qed

lemma lambda_skolem_euclidean: "(\<forall>i\<in>Basis. \<exists>f'::('a::{euclidean_space}\<Rightarrow>real). P i f') \<longleftrightarrow>
   (\<exists>f'::('a::euclidean_space\<Rightarrow>'b::euclidean_space). \<forall>i\<in>Basis. P i ((\<lambda>x. (f' x) \<bullet> i)))" (is "?lhs \<longleftrightarrow> ?rhs")
  (*using choice_iff lambda_skolem*)
proof -
  { assume H: "?rhs"
    then have ?lhs by auto }
  moreover
  { assume H: "?lhs"
    then obtain f'' where f'':"\<forall>i::('b::euclidean_space)\<in>Basis. P i (f'' i)" unfolding choice_iff
      by metis
    let ?x = "(\<lambda>x. (\<Sum>i\<in>Basis. ((f''  i) x) *\<^sub>R i))"
    { fix i::"'b::euclidean_space"
      assume ass: "i\<in>Basis"
      then have "P i (f'' i)"
        using f''
        by metis
      then have "P i (\<lambda>x.(?x x) \<bullet> i)" using ass by auto
    }
    hence *: "\<forall>i\<in>Basis. P i (\<lambda>x.(?x x) \<bullet> i)" by auto
    then have ?rhs
      apply auto
    proof
      let ?f'6 = ?x
      show " \<forall>i\<in>Basis. P i (\<lambda>x. ?f'6 x \<bullet> i)" using * by auto
    qed}
  ultimately show ?thesis by metis
qed

lemma lambda_skolem_euclidean_explicit: "(\<forall>i\<in>Basis. \<exists>f'::('a::{euclidean_space}\<Rightarrow>real). P i f') \<longleftrightarrow>
   (\<exists>f'::('a::{euclidean_space}\<Rightarrow>'a). \<forall>i\<in>Basis. P i ((\<lambda>x. (f' x) \<bullet> i)))" (is "?lhs \<longleftrightarrow> ?rhs")
  (*using choice_iff lambda_skolem*)
proof -
  { assume H: "?rhs"
    then have ?lhs by auto }
  moreover
  { assume H: "?lhs"
    then obtain f'' where f'':"\<forall>i::('a::euclidean_space)\<in>Basis. P i (f'' i)" unfolding choice_iff
      by metis
    let ?x = "(\<lambda>x. (\<Sum>i\<in>Basis. ((f''  i) x) *\<^sub>R i))"
    { fix i::"'a::euclidean_space"
      assume ass: "i\<in>Basis"
      then have "P i (f'' i)"
        using f''
        by metis
      then have "P i (\<lambda>x.(?x x) \<bullet> i)" using ass by auto
    }
    hence *: "\<forall>i\<in>Basis. P i (\<lambda>x.(?x x) \<bullet> i)" by auto
    then have ?rhs
      apply auto
    proof
      let ?f'6 = ?x
      show " \<forall>i\<in>Basis. P i (\<lambda>x. ?f'6 x \<bullet> i)" using * by auto
    qed}
  ultimately show ?thesis by metis
qed

lemma indic_ident:
  "\<And> (f::'a \<Rightarrow> real) s. (\<lambda>x. (f x) * indicator s x) = (\<lambda>x. if x \<in> s then f x else 0)"
proof
  fix f::"'a \<Rightarrow> real"
  fix s::"'a set"
  fix x:: 'a
  show " f x * indicator s x = (if x \<in> s then f x else 0)"
    by (simp add: indicator_def)
qed

lemma real_pair_basis: "Basis = {(1::real,0::real), (0::real,1::real)}"
  by (simp add: Basis_prod_def insert_commute)

(*AE_measure_singleton*)

lemma real_singleton_in_borel:
  shows "{a::real} \<in> sets borel"
  using Borel_Space.cbox_borel[of "a" "a"]
  apply auto
  done

lemma real_singleton_in_lborel:
  shows "{a::real} \<in> sets lborel"
  using real_singleton_in_borel
  apply auto
  done

lemma cbox_diff:
  shows "{0::real..1} - {0,1} = box 0 1"
  by (auto simp add: cbox_def)

lemma sum_bij:
  assumes "bij F"
    "\<forall>x\<in>s. f x = g (F x)"
  shows "\<And>t. F ` s =  t \<Longrightarrow> sum f s = sum g t"
  by (metis assms bij_betw_def bij_betw_subset subset_UNIV sum.reindex_cong)

abbreviation surj_on where
  "surj_on s f \<equiv> s \<subseteq> range f"

lemma surj_on_image_vimage_eq: "surj_on s f \<Longrightarrow> f ` (f -` s) = s"
  by fastforce

end


section \<open>Auxiliary Lemmas for Coinductive Lists\<close>

text \<open>Some lemmas to allow better reasoning with coinductive lists.\<close>

theory MoreCoinductiveList
imports
  Main
  Coinductive.Coinductive_List
begin

subsection \<open>@{term "lset"}\<close>

lemma lset_lnth: "x \<in> lset xs \<Longrightarrow> \<exists>n. lnth xs n = x"
  by (induct rule: llist.set_induct, meson lnth_0, meson lnth_Suc_LCons)

lemma lset_lnth_member: "\<lbrakk> lset xs \<subseteq> A; enat n < llength xs \<rbrakk> \<Longrightarrow> lnth xs n \<in> A"
  using contra_subsetD[of "lset xs" A] in_lset_conv_lnth[of _ xs] by blast

lemma lset_nth_member_inf: "\<lbrakk> \<not>lfinite xs; lset xs \<subseteq> A \<rbrakk> \<Longrightarrow> lnth xs n \<in> A"
  by (metis contra_subsetD inf_llist_lnth lset_inf_llist rangeI)

lemma lset_intersect_lnth: "lset xs \<inter> A \<noteq> {} \<Longrightarrow> \<exists>n. enat n < llength xs \<and> lnth xs n \<in> A"
  by (metis disjoint_iff_not_equal in_lset_conv_lnth)

lemma lset_ltake_Suc:
  assumes "\<not>lnull xs" "lnth xs 0 = x" "lset (ltake (enat n) (ltl xs)) \<subseteq> A"
  shows "lset (ltake (enat (Suc n)) xs) \<subseteq> insert x A"
proof-
  have "lset (ltake (eSuc (enat n)) (LCons x (ltl xs))) \<subseteq> insert x A"
    using assms(3) by auto
  moreover from assms(1,2) have "LCons x (ltl xs) = xs"
    by (metis lnth_0 ltl_simps(2) not_lnull_conv)
  ultimately show ?thesis by (simp add: eSuc_enat)
qed

lemma lfinite_lset: "lfinite xs \<Longrightarrow> \<not>lnull xs \<Longrightarrow> llast xs \<in> lset xs"
proof (induct rule: lfinite_induct)
  case (LCons xs)
  show ?case proof (cases)
    assume *: "\<not>lnull (ltl xs)"
    hence "llast (ltl xs) \<in> lset (ltl xs)" using LCons.hyps(3) by blast
    hence "llast (ltl xs) \<in> lset xs" by (simp add: in_lset_ltlD)
    thus ?thesis by (metis * LCons.prems lhd_LCons_ltl llast_LCons2)
  qed (metis LCons.prems lhd_LCons_ltl llast_LCons llist.set_sel(1))
qed simp

lemma lset_subset: "\<not>(lset xs \<subseteq> A) \<Longrightarrow> \<exists>n. enat n < llength xs \<and> lnth xs n \<notin> A"
  by (metis in_lset_conv_lnth subsetI)

subsection \<open>@{term "llength"}\<close>

lemma enat_Suc_ltl:
  assumes "enat (Suc n) < llength xs"
  shows "enat n < llength (ltl xs)"
proof-
  from assms have "eSuc (enat n) < llength xs" by (simp add: eSuc_enat)
  hence "enat n < epred (llength xs)" using eSuc_le_iff ileI1 by fastforce
  thus ?thesis by (simp add: epred_llength)
qed

lemma enat_ltl_Suc: "enat n < llength (ltl xs) \<Longrightarrow> enat (Suc n) < llength xs"
  by (metis eSuc_enat ldrop_ltl leD leI lnull_ldrop)

lemma infinite_small_llength [intro]: "\<not>lfinite xs \<Longrightarrow> enat n < llength xs"
  using enat_iless lfinite_conv_llength_enat neq_iff by blast

lemma lnull_0_llength: "\<not>lnull xs \<Longrightarrow> enat 0 < llength xs"
  using zero_enat_def by auto

lemma Suc_llength: "enat (Suc n) < llength xs \<Longrightarrow> enat n < llength xs"
  using dual_order.strict_trans enat_ord_simps(2) by blast

subsection \<open>@{term "ltake"}\<close>

lemma ltake_lnth: "ltake n xs = ltake n ys \<Longrightarrow> enat m < n \<Longrightarrow> lnth xs m = lnth ys m"
  by (metis lnth_ltake)

lemma lset_ltake_prefix [simp]: "n \<le> m \<Longrightarrow> lset (ltake n xs) \<subseteq> lset (ltake m xs)"
  by (simp add: lprefix_lsetD)

lemma lset_ltake: "(\<And>m. m < n \<Longrightarrow> lnth xs m \<in> A) \<Longrightarrow> lset (ltake (enat n) xs) \<subseteq> A"
proof (induct n arbitrary: xs)
  case 0
  have "ltake (enat 0) xs = LNil" by (simp add: zero_enat_def)
  thus ?case by simp
next
  case (Suc n)
  show ?case proof (cases)
    assume "xs \<noteq> LNil"
    then obtain x xs' where xs: "xs = LCons x xs'" by (meson neq_LNil_conv)
    { fix m assume "m < n"
      hence "Suc m < Suc n" by simp
      hence "lnth xs (Suc m) \<in> A" using Suc.prems by presburger
      hence "lnth xs' m \<in> A" using xs by simp
    }
    hence "lset (ltake (enat n) xs') \<subseteq> A" using Suc.hyps by blast
    moreover have "ltake (enat (Suc n)) xs = LCons x (ltake (enat n) xs')"
      using xs ltake_eSuc_LCons[of _ x xs'] by (metis (no_types) eSuc_enat)
    moreover have "x \<in> A" using Suc.prems xs by force
    ultimately show ?thesis by simp
  qed simp
qed

lemma llength_ltake': "enat n < llength xs \<Longrightarrow> llength (ltake (enat n) xs) = enat n"
  by (metis llength_ltake min.strict_order_iff)

lemma llast_ltake:
  assumes "enat (Suc n) < llength xs"
  shows "llast (ltake (enat (Suc n)) xs) = lnth xs n" (is "llast ?A = _")
  unfolding llast_def using llength_ltake'[OF assms] by (auto simp add: lnth_ltake)

lemma lset_ltake_ltl: "lset (ltake (enat n) (ltl xs)) \<subseteq> lset (ltake (enat (Suc n)) xs)"
proof (cases)
  assume "\<not>lnull xs"
  then obtain v0 where "xs = LCons v0 (ltl xs)" by (metis lhd_LCons_ltl)
  hence "ltake (eSuc (enat n)) xs = LCons v0 (ltake (enat n) (ltl xs))"
    by (metis ltake_eSuc_LCons)
  hence "lset (ltake (enat (Suc n)) xs) = lset (LCons v0 (ltake (enat n) (ltl xs)))"
    by (simp add: eSuc_enat)
  thus ?thesis using lset_LCons[of v0 "ltake (enat n) (ltl xs)"] by blast
qed (simp add: lnull_def)

subsection \<open>@{term "ldropn"}\<close>

lemma ltl_ldrop: "\<lbrakk> \<And>xs. P xs \<Longrightarrow> P (ltl xs); P xs \<rbrakk> \<Longrightarrow> P (ldropn n xs)"
  unfolding ldropn_def by (induct n) simp_all

subsection \<open>@{term "lfinite"}\<close>

lemma lfinite_drop_set: "lfinite xs \<Longrightarrow> \<exists>n. v \<notin> lset (ldrop n xs)"
  by (metis ldrop_inf lmember_code(1) lset_lmember)

lemma index_infinite_set:
  "\<lbrakk> \<not>lfinite x; lnth x m = y; \<And>i. lnth x i = y \<Longrightarrow> (\<exists>m > i. lnth x m = y) \<rbrakk> \<Longrightarrow> y \<in> lset (ldropn n x)"
proof (induct n arbitrary: x m)
  case 0 thus ?case using lset_nth_member_inf by auto
next
  case (Suc n)
  obtain a xs where x: "x = LCons a xs" by (meson Suc.prems(1) lnull_imp_lfinite not_lnull_conv)
  obtain j where j: "j > m" "lnth x j = y" using Suc.prems(2,3) by blast
  have "lnth xs (j - 1) = y" by (metis lnth_LCons' j(1,2) not_less0 x)
  moreover {
    fix i assume "lnth xs i = y"
    hence "lnth x (Suc i) = y" by (simp add: x)
    hence "\<exists>j>i. lnth xs j = y" by (metis Suc.prems(3) Suc_lessE lnth_Suc_LCons x)
  }
  ultimately show ?case using Suc.hyps Suc.prems(1) x by auto
qed

subsection \<open>@{term "lmap"}\<close>

lemma lnth_lmap_ldropn:
  "enat n < llength xs \<Longrightarrow> lnth (lmap f (ldropn n xs)) 0 = lnth (lmap f xs) n"
  by (simp add: lhd_ldropn lnth_0_conv_lhd)

lemma lnth_lmap_ldropn_Suc:
  "enat (Suc n) < llength xs \<Longrightarrow> lnth (lmap f (ldropn n xs)) (Suc 0) = lnth (lmap f xs) (Suc n)"
  by (metis (no_types, lifting) Suc_llength ldropn_ltl leD llist.map_disc_iff lnth_lmap_ldropn
                                lnth_ltl lnull_ldropn ltl_ldropn ltl_lmap)

subsection \<open>Notation\<close>

text \<open>We introduce the notation \$ to denote @{term "lnth"}.\<close>

notation lnth (infix "$" 61)

end


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

datatype ('a, 'b) pair = pair2 "'a" "'b"

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun zip :: "'a list => 'b list => (('a, 'b) pair) list" where
  "zip (nil2) y = nil2"
| "zip (cons2 z x2) (nil2) = nil2"
| "zip (cons2 z x2) (cons2 x3 x4) = cons2 (pair2 z x3) (zip x2 x4)"

fun zipConcat :: "'a => 'a list => 'b list =>
                  (('a, 'b) pair) list" where
  "zipConcat x y (nil2) = nil2"
| "zipConcat x y (cons2 y2 ys) = cons2 (pair2 x y2) (zip y ys)"

theorem property0 :
  "((zip (cons2 x xs) ys) = (zipConcat x xs ys))"
  find_proof DInd
  apply (induct ys arbitrary: x)(*"ys" is optional*)
    (*Why "induct ys"?
    Because "zipConcat" is recursively defined on the third argument, which is "ys" in this case.
    Because "zip" is recursively defined on the first argument, which is a composite term
    "cons2 x xs", which has a constructor "cons2" at the top in this case.*)
   apply auto
  done

end