(*:maxLineLen=78:*)

section \<open>Digression: List Utility Theorems\<close>

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>

theory List_Utilities
  imports
    "HOL-Library.Permutation"
begin

sledgehammer_params [smt_proofs = false]

subsection \<open> Multiset Coercion \<close>

lemma length_sub_mset:
  assumes "mset \<Psi> \<subseteq># mset \<Gamma>"
      and "length \<Psi> >= length \<Gamma>"
    shows "mset \<Psi> = mset \<Gamma>"
  using assms
proof -
  have "\<forall> \<Psi>. mset \<Psi> \<subseteq># mset \<Gamma>
              \<longrightarrow> length \<Psi> >= length \<Gamma>
              \<longrightarrow> mset \<Psi> = mset \<Gamma>"
  proof (induct \<Gamma>)
    case Nil
    then show ?case by simp
  next
    case (Cons \<gamma> \<Gamma>)
    {
      fix \<Psi>
      assume "mset \<Psi> \<subseteq># mset (\<gamma> # \<Gamma>)" "length \<Psi> >= length (\<gamma> # \<Gamma>)"
      have "\<gamma> \<in> set \<Psi>"
      proof (rule ccontr)
        assume "\<gamma> \<notin> set \<Psi>"
        hence \<diamondsuit>: "remove1 \<gamma> \<Psi> = \<Psi>"
          by (simp add: remove1_idem)
        have "mset \<Psi> \<subseteq># mset (\<gamma> # \<Gamma>)"
          using \<open>mset \<Psi> \<subseteq># mset (\<gamma> # \<Gamma>)\<close> by auto
        hence "mset \<Psi> \<subseteq># mset (remove1 \<gamma> (\<gamma> # \<Gamma>))"
          by (metis \<diamondsuit> mset_le_perm_append perm_remove_perm remove1_append)
        hence "mset \<Psi> \<subseteq># mset \<Gamma>"
          by simp
        hence "mset \<Psi> = mset \<Gamma>"
          using \<open>length (\<gamma> # \<Gamma>) \<le> length \<Psi>\<close> size_mset_mono by fastforce
        hence "length \<Psi> = length \<Gamma>"
          by (metis size_mset)
        hence "length \<Gamma> \<ge> length (\<gamma> # \<Gamma>)"
          using \<open>length (\<gamma> # \<Gamma>) \<le> length \<Psi>\<close> by auto
        thus "False" by simp
      qed
      hence \<heartsuit>: "mset \<Psi> = mset (\<gamma> # (remove1 \<gamma> \<Psi>))"
        by simp
      hence "length (remove1 \<gamma> \<Psi>) >= length \<Gamma>"
        by (metis
              \<open>length (\<gamma> # \<Gamma>) \<le> length \<Psi>\<close>
              drop_Suc_Cons
              drop_eq_Nil
              length_Cons
              mset_eq_length)
      moreover have "mset (remove1 \<gamma> \<Psi>) \<subseteq># mset \<Gamma>"
        by (simp,
            metis
              \<heartsuit>
              \<open>mset \<Psi> \<subseteq># mset (\<gamma> # \<Gamma>)\<close>
              mset.simps(2)
              mset_remove1
              mset_subset_eq_add_mset_cancel)
      ultimately have "mset (remove1 \<gamma> \<Psi>) = mset \<Gamma>" using Cons by blast
      with \<heartsuit> have "mset \<Psi> = mset (\<gamma> # \<Gamma>)" by simp
    }
    thus ?case by blast
  qed
  thus ?thesis using assms by blast
qed

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

subsection \<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_perm:
  assumes "A \<rightleftharpoons> B"
  shows "map f A \<rightleftharpoons> map f B"
  by (metis assms mset_eq_perm mset_map)

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)
              mset_eq_perm
              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_eq_perm
              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 (meson
              B'(2)
              b(1)
              cons_perm_eq
              perm.trans
              perm_remove
              perm_sym)
      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 (simp add: perm_remove perm_sym)
        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_eq_perm
                 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 force
        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> mset_eq_perm)
        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
                diff_subset_eq_self
                mset_remove1
                remove_hd
                subset_mset.order.trans)
      qed
    }
    thus ?case using Cons by blast
  qed
  thus ?thesis using assms by blast
qed

subsection \<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

subsection \<open> Permutations \<close>

lemma perm_count_list:
  assumes "\<Phi> \<rightleftharpoons> \<Psi>"
  shows "count_list \<Phi> \<phi> = count_list \<Psi> \<phi>"
proof -
  have "\<forall>\<Psi>. \<Phi> \<rightleftharpoons> \<Psi> \<longrightarrow> count_list \<Phi> \<phi> = count_list \<Psi> \<phi>"
  proof (induct \<Phi>)
    case Nil
    then show ?case
      by simp
  next
    case (Cons \<chi> \<Phi>)
    {
      fix \<Psi>
      assume "\<chi> # \<Phi> \<rightleftharpoons> \<Psi>"
      hence "\<chi> \<in> set \<Psi>"
        using perm_set_eq by fastforce
      hence "\<Psi> \<rightleftharpoons> \<chi> # (remove1 \<chi> \<Psi>)"
        by (simp add: perm_remove)
      hence "\<Phi> \<rightleftharpoons> (remove1 \<chi> \<Psi>)"
        using \<open>\<chi> # \<Phi> \<rightleftharpoons> \<Psi>\<close> perm.trans by auto
      hence \<diamondsuit>: "count_list \<Phi> \<phi> = count_list (remove1 \<chi> \<Psi>) \<phi>"
        using Cons.hyps by blast
      have "count_list (\<chi> # \<Phi>) \<phi> = count_list \<Psi> \<phi>"
      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 "count_list (remove1 \<chi> \<Psi>) \<phi> + 1 = count_list \<Psi> \<phi>"
          using \<open>\<chi> = \<phi>\<close> \<open>\<chi> \<in> set \<Psi>\<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
    }
    then show ?case
      by blast
  qed
  with assms show ?thesis by blast
qed

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

lemma append_set_containment:
  assumes "a \<in> set A"
      and "A \<rightleftharpoons> B @ C"
    shows "a \<in> set B \<or> a \<in> set C"
  using assms
  by (simp add: perm_set_eq)

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 append.assoc
              perm.trans
              perm_append1
              perm_append_swap)

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,
        meson concat_remove1 mset_le_perm_append perm.trans perm_sym)

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>')"
proof -
  have "\<forall> \<Phi>. \<Psi> \<rightleftharpoons> \<Phi> \<longrightarrow> (\<Sum>\<psi>'\<leftarrow>\<Psi>. f \<psi>') = (\<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: "\<psi> # \<Psi> \<rightleftharpoons> \<Phi>"
      hence "\<Psi> \<rightleftharpoons> (remove1 \<psi> \<Phi>)"
        by (metis perm_remove_perm remove_hd)
      hence "(\<Sum>\<psi>' \<leftarrow> \<Psi>. f \<psi>') = (\<Sum>\<phi>' \<leftarrow> (remove1 \<psi> \<Phi>). f \<phi>')"
        using Cons.hyps by blast
      moreover have "\<psi> \<in> set \<Phi>"
        using hypothesis perm_set_eq by fastforce
      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 simp
      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 have "(\<Sum>\<psi>'\<leftarrow>(\<psi> # \<Psi>). f \<psi>') = (\<Sum>\<phi>'\<leftarrow>\<Phi>. f \<phi>')"
        by simp
    }
    then show ?case by blast
  qed
  with assms show ?thesis by blast
qed

subsection \<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

subsection \<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, metis perm_remove_perm remove1_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 -
  have "\<forall> \<Phi>. count_list \<Phi> \<phi> \<ge> count_list \<Lambda> \<phi>
               \<longrightarrow> \<phi> # (\<Phi> \<ominus> \<Lambda>) \<rightleftharpoons> (\<phi> # \<Phi>) \<ominus> \<Lambda>"
  proof (induct \<Lambda>)
    case Nil
    thus ?case using list_subtract_cons by fastforce
  next
    case (Cons \<psi> \<Lambda>)
    assume inductive_hypothesis:
           " \<forall>\<Phi>. count_list \<Lambda> \<phi> \<le> count_list \<Phi> \<phi>
                   \<longrightarrow> \<phi> # \<Phi> \<ominus> \<Lambda> \<rightleftharpoons> (\<phi> # \<Phi>) \<ominus> \<Lambda>"
    {
      fix \<Phi> :: "'a list"
      assume "count_list (\<psi> # \<Lambda>) \<phi> \<le> count_list \<Phi> \<phi>"
      have "count_list \<Lambda> \<phi> \<le> count_list (remove1 \<psi> \<Phi>) \<phi>"
      proof (cases "\<phi> = \<psi>")
        case True
        hence "1 + count_list \<Lambda> \<phi> \<le> count_list \<Phi> \<phi>"
          using \<open>count_list (\<psi> # \<Lambda>) \<phi> \<le> count_list \<Phi> \<phi>\<close>
          by auto
        moreover from this have "\<phi> \<in> set \<Phi>"
          using not_one_le_zero by fastforce
        hence "\<Phi> \<rightleftharpoons> \<phi> # (remove1 \<psi> \<Phi>)"
          using True
          by (simp add: True perm_remove)
        ultimately show ?thesis by (simp add: perm_count_list)
      next
        case False
        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 "\<phi>' = \<phi>")
            case True
            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
            case False
            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 auto
      qed
      hence "\<phi> # ((remove1 \<psi> \<Phi>) \<ominus> \<Lambda>) \<rightleftharpoons> (\<phi> # (remove1 \<psi> \<Phi>)) \<ominus> \<Lambda>"
          using inductive_hypothesis by blast
      moreover have "\<phi> # ((remove1 \<psi> \<Phi>) \<ominus> \<Lambda>) \<rightleftharpoons> \<phi> # (\<Phi> \<ominus> (\<psi> # \<Lambda>))"
        by (induct \<Lambda>, simp, simp add: perm_remove_perm remove1_commute)
      ultimately have \<star>: "\<phi> # (\<Phi> \<ominus> (\<psi> # \<Lambda>)) \<rightleftharpoons> (\<phi> # (remove1 \<psi> \<Phi>)) \<ominus> \<Lambda>"
        by (meson perm.trans perm_sym)
      have "\<phi> # (\<Phi> \<ominus> (\<psi> # \<Lambda>)) \<rightleftharpoons> (\<phi> # \<Phi>) \<ominus> (\<psi> # \<Lambda>)"
      proof cases
        assume "\<phi> = \<psi>"
        hence "(\<phi> # \<Phi>) \<ominus> (\<psi> # \<Lambda>) \<rightleftharpoons> \<Phi> \<ominus> \<Lambda>"
          using list_subtract_remove1_cons_perm by fastforce
        moreover have "\<phi> \<in> set \<Phi>"
          using
            \<open>\<phi> = \<psi>\<close>
            \<open>count_list (\<psi> # \<Lambda>) \<phi> \<le> count_list \<Phi> \<phi>\<close>
            leD
          by force
        hence "\<Phi> \<ominus> \<Lambda> \<rightleftharpoons> (\<phi> # (remove1 \<phi> \<Phi>)) \<ominus> \<Lambda>"
          by (induct \<Lambda>, simp add: perm_remove, simp add: perm_remove_perm)
        ultimately show ?thesis
          using \<star>
          by (metis \<open>\<phi> = \<psi>\<close> mset_eq_perm)
      next
        assume "\<phi> \<noteq> \<psi>"
        hence "(\<phi> # (remove1 \<psi> \<Phi>)) \<ominus> \<Lambda> \<rightleftharpoons> (\<phi> # \<Phi>) \<ominus> (\<psi> # \<Lambda>)"
          by (induct \<Lambda>, simp, simp add: perm_remove_perm remove1_commute)
        then show ?thesis using \<star> by blast
      qed
    }
    then show ?case by blast
  qed
  with assms show ?thesis by blast
qed

lemma list_subtract_remove1_perm:
  assumes "\<phi> \<in> set \<Lambda>"
  shows  "\<Phi> \<ominus> \<Lambda> \<rightleftharpoons> (remove1 \<phi> \<Phi>) \<ominus> (remove1 \<phi> \<Lambda>)"
proof -
  from \<open>\<phi> \<in> set \<Lambda>\<close>
  have "mset (\<Phi> \<ominus> \<Lambda>) = mset ((remove1 \<phi> \<Phi>) \<ominus> (remove1 \<phi> \<Lambda>))"
    by simp
  thus ?thesis
    using mset_eq_perm by blast
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 list_subtract_remove1_perm by fastforce

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>)"
proof -
  have "\<forall> \<Lambda>. count_list \<Phi> \<phi> \<le> count_list \<Lambda> \<phi>
               \<longrightarrow> \<Phi> \<ominus> \<Lambda> \<rightleftharpoons> (removeAll \<phi> \<Phi>) \<ominus> (removeAll \<phi> \<Lambda>)"
  proof (induct \<Phi>)
    case Nil
    thus ?case by auto
  next
    case (Cons \<xi> \<Phi>)
    {
      fix \<Lambda>
      assume "count_list (\<xi> # \<Phi>) \<phi> \<le> count_list \<Lambda> \<phi>"
      hence "\<Phi> \<ominus> \<Lambda> \<rightleftharpoons> (removeAll \<phi> \<Phi>) \<ominus> (removeAll \<phi> \<Lambda>)"
        by (metis
              Cons.hyps
              count_list.simps(2)
              dual_order.trans
              le_add_same_cancel1
              zero_le_one)
      have "(\<xi> # \<Phi>) \<ominus> \<Lambda> \<rightleftharpoons> (removeAll \<phi> (\<xi> # \<Phi>)) \<ominus> (removeAll \<phi> \<Lambda>)"
      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 (meson list_subtract_remove1_perm)
        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 (simp add: list_subtract_cons_remove1_perm)
          moreover have "count_list \<Lambda> \<phi> = count_list (remove1 \<xi> \<Lambda>) \<phi>"
            using \<open>\<xi> \<noteq> \<phi>\<close> \<open>\<xi> \<in> set \<Lambda>\<close> perm_count_list perm_remove
            by force
          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,
                  simp add: filter_remove1 removeAll_filter_not_eq)
          hence "(removeAll \<phi> \<Phi>) \<ominus> (removeAll \<phi> (remove1 \<xi> \<Lambda>)) \<rightleftharpoons>
                   (removeAll \<phi> (\<xi> # \<Phi>)) \<ominus> (removeAll \<phi> \<Lambda>)"
            by (simp add: \<open>\<xi> \<in> set \<Lambda>\<close>
                          filter_remove1
                          list_subtract_cons_remove1_perm
                          perm_sym
                          removeAll_filter_not_eq)
          ultimately show ?thesis by blast
        next
          assume "\<xi> \<notin> set \<Lambda>"
          hence "(\<xi> # \<Phi>) \<ominus> \<Lambda> \<rightleftharpoons> \<xi> # (\<Phi> \<ominus> \<Lambda>)"
            by (simp add: list_subtract_cons_absorb perm_sym)
          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 blast
          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
    }
    then show ?case by auto
  qed
  with assms show ?thesis by blast
qed

lemma list_subtract_permute:
  assumes "\<Phi> \<rightleftharpoons> \<Psi>"
  shows "\<Phi> \<ominus> \<Lambda> \<rightleftharpoons> \<Psi> \<ominus> \<Lambda>"
proof -
  from \<open>\<Phi> \<rightleftharpoons> \<Psi>\<close> have "mset \<Phi> = mset \<Psi>"
    by (simp add: mset_eq_perm)
  hence "mset (\<Phi> \<ominus> \<Lambda>) = mset (\<Psi> \<ominus> \<Lambda>)"
    by simp
  thus ?thesis
    using mset_eq_perm by blast
qed

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 = mset (B @ C)"
    using mset_eq_perm by blast
  hence "mset (A \<ominus> C) = mset B"
    by simp
  thus ?thesis using mset_eq_perm 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,
       meson
         append_perm_list_subtract_intro
         concat_remove1
         perm.trans
         perm_append_swap
         perm_sym)

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 (simp add: perm_remove perm_sym)
      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

subsection \<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

subsection \<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 (simp add: multiset_inter_def)

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


section {*sets*}
theory
  sets

imports
  basic

begin

lemma ex1_set: "
  \<exists>!x. x \<in> A
  \<Longrightarrow> x \<in> A
  \<Longrightarrow> A = {x}"
  apply(auto)
  done

lemma in_set_eq_imp: "
  x \<in> A
  \<Longrightarrow> A = B
  \<Longrightarrow> (x \<in> B \<Longrightarrow> P)
  \<Longrightarrow> P"
  apply(auto)
  done

lemma from_in_set: "
  x \<in> A
  \<Longrightarrow> A = {f w|w. P w}
  \<Longrightarrow> \<exists>w. x = f w \<and> P w"
  apply(rule_tac
      x = "x"
      and A = "A"
      and B = "{f w|w. P w}"
      in in_set_eq_imp)
    apply(force)
   apply(force)
  apply(force)
  done

lemma propForElem: "
  {a} = A
  \<Longrightarrow> A = (Collect P)
  \<Longrightarrow> P a"
  apply(auto)
  done

lemma inMap_rev: "
  x  \<in> f ` A
  \<Longrightarrow> \<exists>y \<in> A. f y = x"
  apply(auto)
  done

lemma mapToApply: "
  A = {a}
  \<Longrightarrow> B = {b}
  \<Longrightarrow> f ` A = f ` B
  \<Longrightarrow> f a = f b"
  apply(auto)
  done

lemma inMap2: "
  f y = x
  \<Longrightarrow> y \<in> A
  \<Longrightarrow> x \<in> (f`A)"
  apply(auto)
  done

lemma inMap: "
  \<exists>y \<in> A. f y = x
  \<Longrightarrow> x \<in> f`A"
  apply(auto)
  done

lemma InBigUnion: "
  \<exists>y \<in> A. x \<in> f y
  \<Longrightarrow> x \<in> \<Union>{f y |y. y \<in> A}"
  apply(auto)
  done

lemma InBigUnion2: "
  x \<in> \<Union>{f y |y. y \<in> A}
  \<Longrightarrow> \<exists>y \<in> A. x \<in> f y"
  apply(auto)
  done

lemma distinct_by_set_membership: "
  a \<in> A
  \<Longrightarrow> b \<notin> A
  \<Longrightarrow> a \<noteq> b"
  apply(force)
  done

lemma elementChoice: "
  y \<in> (A\<union>B)
  \<Longrightarrow> y \<notin> B
  \<Longrightarrow> y \<in> A"
  apply(force)
  done

lemma eqSubset: "
  Collect P = Collect Q
  \<Longrightarrow> Q x
  \<Longrightarrow> P x"
  apply(auto)
  done

lemma theI_prime2: "
  \<exists>!x. f x  \<in> A
  \<Longrightarrow> (THE x. f x  \<in> A) = y
  \<Longrightarrow> f y  \<in> A"
  apply(rule_tac
      t = "y"
      and s = "THE x. f x  \<in> A"
      in ssubst)
   apply(force)
  apply(rule theI')
  apply(force)
  done

lemma isID: "
  R^^0 = Id"
  apply(auto)
  done

lemma setElemE: "
  x \<in> {(f y)| y. P (f y)}
  \<Longrightarrow> (\<And>y. P (f y) \<Longrightarrow> Q (f y))
  \<Longrightarrow> Q x"
  apply(auto)
  done

lemma mapToApply2: "
  A = {a}
  \<Longrightarrow> B = {b}
  \<Longrightarrow> \<exists>x \<in> A. \<exists>y \<in> B. f1(f2(f1 x)) = f1 y
  \<Longrightarrow> f1 ` (f2 ` (f1 ` A)) = f1 ` B"
  apply(auto)
  done

lemma unequal1: "
  \<exists>x \<in> A. x \<notin> B
  \<Longrightarrow> A \<noteq> B"
  apply(force)
  done

lemma hasElem_prefix_closureise: "
  A - B = {c}
  \<Longrightarrow> \<exists>I. I \<in> A"
  apply(force)
  done

lemma notin_union: "
  a \<notin> A
  \<Longrightarrow> a \<notin> B
  \<Longrightarrow> a \<notin> (A\<union>B)"
  apply(force)
  done

lemma rev_subset: "
  F1 \<subset> F0
  \<Longrightarrow> F0 \<subseteq> A
  \<Longrightarrow> A - F0 \<subset> A - F1"
  apply(auto)
  done

lemma getInner: "
  (\<And>X. f X \<subseteq> X)
  \<Longrightarrow> (\<And>X. g X \<subseteq> X)
  \<Longrightarrow> A = f (g A)
  \<Longrightarrow> A = g A"
  apply(auto)
  apply(rename_tac x)(*strict*)
  apply(rule_tac
      A = "f (g A)"
      in set_mp)
   apply(rename_tac x)(*strict*)
   apply(blast+)
  done

lemma subsetI_basic: "
  \<forall>x. x \<in> A \<longrightarrow> x \<in> B
  \<Longrightarrow> A\<subseteq>B"
  apply(force)
  done

lemma subsetE: "
  A \<subseteq> B
  \<Longrightarrow> \<forall>x. x  \<in> A \<longrightarrow> x  \<in> B"
  apply(blast)
  done

lemma nInterI: "
  x \<notin> A \<or> x \<notin> B
  \<Longrightarrow> x \<notin> A \<inter> B"
  apply(simp)
  done

lemma nInterE: "
  x \<notin> A \<inter> B
  \<Longrightarrow> x \<notin> A \<or> x \<notin> B"
  apply(simp)
  done

lemma complementA: "
  x  \<in> A
  \<Longrightarrow> x \<notin> A - B
  \<Longrightarrow> x  \<in> B"
  apply(simp)
  done

lemma elemSubsetTrans: "
  x  \<in> A
  \<Longrightarrow> A \<subseteq> Collect P
  \<Longrightarrow> (P x \<Longrightarrow> Q)
  \<Longrightarrow> Q"
  apply(blast)
  done

lemma SetContraPosSubset: "
  A \<subseteq> B
  \<Longrightarrow> B \<subseteq> C
  \<Longrightarrow> C - B \<subseteq> C - A"
  apply(blast)
  done

lemma interSimp: "
  A = B \<inter> C
  \<Longrightarrow> A \<subseteq> C"
  apply(auto)
  done

lemma interSimp2: "
  A \<subseteq> B
  \<Longrightarrow> C \<subseteq> B
  \<Longrightarrow> A \<inter> C \<subseteq> B"
  apply(auto)
  done

lemma emptySetE: "
  A \<noteq> {}
  \<Longrightarrow> \<exists> x . x  \<in> A"
  apply(auto)
  done

lemma emptySetI: "
  \<exists> x . x  \<in> A
  \<Longrightarrow> A \<noteq> {}"
  apply(auto)
  done

lemma trivConjBySubset: "
  A\<subseteq> D
  \<Longrightarrow> A\<subseteq>B
  \<Longrightarrow> C\<subseteq>A
  \<Longrightarrow> P
  \<Longrightarrow> (A\<subseteq>B\<and>(P\<and>C\<subseteq>D))"
  apply(auto)
  done

lemma imageNotEmpty: "
  A \<noteq> {}
  \<Longrightarrow> f`A \<noteq> {}"
  apply(auto)
  done

lemma TransSubSetNorm: "
  \<forall>n. R^^n\<subseteq>S
  \<Longrightarrow> R\<^sup>* \<subseteq> S"
  apply(rule subsetI)
  apply(rename_tac x)(*strict*)
  apply(subgoal_tac "(\<exists>n. x  \<in> R ^^ n)")
   apply(rename_tac x)(*strict*)
   prefer 2
   apply (metis rtrancl_power)
  apply(rename_tac x)(*strict*)
  apply(erule exE)
  apply(rename_tac x n)(*strict*)
  apply(rule_tac
      A = "R^^n"
      in set_mp)
   apply(rename_tac x n)(*strict*)
   apply(blast) +
  done

lemma useForMGEQZ: "
  (\<And>y. (z, y)  \<in> {e  \<in> less_than. fst e  \<in> A \<and> snd e  \<in> A}\<inverse> \<Longrightarrow> y \<notin> A)
  \<Longrightarrow> m  \<in> A
  \<Longrightarrow> z \<in> A
  \<Longrightarrow> z \<le> m"
  apply(case_tac "m < z")
   prefer 2
   apply(rule Orderings.linorder_class.leI)
   apply(blast)
  apply(subgoal_tac "(z,m) \<in> {e  \<in> less_than. fst e  \<in> A \<and> snd e  \<in> A}\<inverse>")
   apply(blast)
  apply(rule Relation.converseI)
  apply(simp)
  done

lemma supProveSubset: "
  B = \<Union>Collect P
  \<Longrightarrow> P C
  \<Longrightarrow> C \<subseteq> B"
  apply(auto)
  done

lemma supProveEq: "
  P B
  \<Longrightarrow> \<forall>C. P C \<longrightarrow> C \<subseteq> B
  \<Longrightarrow> B = \<Union>Collect P"
  apply(auto)
  done

lemma gfpSupCorrespond: "
  (\<And>x. f x \<subseteq> x)
  \<Longrightarrow> gfp (\<lambda>x. f x \<inter> y) = \<Union>{x. x = f x \<and> x\<subseteq>y }"
  apply(simp add: gfp_def)
  apply(subgoal_tac "{u. u \<subseteq> f u \<and> u \<subseteq> y} = {x. x = f x \<and> x \<subseteq> y}")
   apply(force)
  apply(force)
  done

lemma exSetEQI: "
  A = B
  \<Longrightarrow> {X. X = A} = {X. X = B}"
  apply(simp)
  done

lemma doubleMonoEQ: "
  (\<And>X. f X \<subseteq> X)
  \<Longrightarrow> (\<And>X. g X \<subseteq> X)
  \<Longrightarrow> X = f (g X)
  \<Longrightarrow> X = f X \<and> X = g X"
  apply(subgoal_tac "X = g X")
   apply(clarsimp)
  apply(subgoal_tac "X\<subseteq>f (g X)")
   apply(rule equalityI)
    apply(rule_tac
      B = "f (g X)"
      in subset_trans)
     apply(blast) +
  done

lemma EQremoveInter: "
  A = B\<inter>C
  \<Longrightarrow> B\<subseteq>C
  \<Longrightarrow> A = B"
  apply(auto)
  done

lemma setExEQI2: "
  (\<And>X. P X = Q X)
  \<Longrightarrow> {X. X\<subseteq>P X} = {X. X\<subseteq>Q X}"
  apply(auto)
  done

lemma subsetExtension: "
  A\<subseteq>B
  \<Longrightarrow> A\<subseteq>C
  \<Longrightarrow> A\<inter>C\<subseteq>B\<inter>C"
  apply(auto)
  done

lemma antiAbsorb: "
  A\<inter>B = A
  \<Longrightarrow> A\<subseteq>B"
  apply(auto)
  done

lemma nset_mp: "
  A \<subseteq> B
  \<Longrightarrow> x \<notin> B
  \<Longrightarrow> x \<notin> A"
  apply(auto)
  done

lemma set_eq_from_double_subseteq: "
  A \<subseteq> B
  \<Longrightarrow> B \<subseteq> A
  \<Longrightarrow> A = B"
  apply(auto)
  done

lemma add_element_to_enumeration: "
  y < x
  \<Longrightarrow> insert y (S \<union> {Suc y..x - Suc 0}) = S \<union> {y..x - Suc 0}"
  apply(rule order_antisym)
   apply(auto)
  done

lemma rev_subseteq: "
  F1 \<subseteq> F0
  \<Longrightarrow> A - F0 \<subseteq> A - F1"
  apply(auto)
  done

lemma useForMLEQZ: "
  (\<And>y. (y, z)  \<in> {e  \<in> less_than. fst e  \<in> A \<and> snd e  \<in> A}\<inverse> \<Longrightarrow> y \<notin> A)
  \<Longrightarrow> m  \<in> A
  \<Longrightarrow> z \<in> A
  \<Longrightarrow> m \<le> z"
  apply(case_tac "z < m")
   prefer 2
   apply(rule Orderings.linorder_class.leI)
   apply(blast)
  apply(subgoal_tac "(m,z) \<in> {e  \<in> less_than. fst e  \<in> A \<and> snd e  \<in> A}\<inverse>")
   apply(blast)
  apply(rule Relation.converseI)
  apply(simp)
  done

lemma set_mp_prime: "
  A \<subseteq> B
  \<Longrightarrow> x  \<in> A
  \<Longrightarrow> (x  \<in> B \<Longrightarrow> P)
  \<Longrightarrow> P"
  apply(auto)
  done

lemma restrict_subseteq: "
  A \<subseteq> B
  \<Longrightarrow> A \<subseteq> {x. P x}
  \<Longrightarrow> A \<subseteq> {x  \<in> B. P x}"
  apply(auto)
  done

lemma finite_ex_min: "
  finite (M::nat set)
  \<Longrightarrow> M \<noteq> {}
  \<Longrightarrow> \<exists>i. i \<in> M \<and> (\<forall>j < i. j\<notin>M)"
  apply(case_tac "0 \<in> M")
   apply(force)
  apply(subgoal_tac "\<exists>x. x \<in> M")
   prefer 2
   apply(force)
  apply(clarsimp)
  apply(rename_tac x)(*strict*)
  apply(subgoal_tac "\<exists>k \<le> x. (\<forall>i < k. \<not>(\<lambda>x. x \<in> M) i) & (\<lambda>x. x \<in> M)k")
   apply(rename_tac x)(*strict*)
   prefer 2
   apply(rule ex_least_nat_le)
    apply(rename_tac x)(*strict*)
    apply(force)
   apply(rename_tac x)(*strict*)
   apply(force)
  apply(rename_tac x)(*strict*)
  apply(force)
  done

lemma InvLessThanFinite: "
  finite A
  \<Longrightarrow> A \<noteq> {}
  \<Longrightarrow> wf ({e. e \<in> less_than \<and> (fst e) \<in> A \<and>(snd e) \<in> A}\<inverse>)"
  apply(rule Wellfounded.finite_acyclic_wf_converse)
   apply(rule_tac
      B = "A\<times>A"
      in Finite_Set.finite_subset)
    apply(clarsimp)
   apply(rule Finite_Set.finite_cartesian_product)
    apply(simp) +
  apply(rule_tac
      s = "less_than"
      in Transitive_Closure.acyclic_subset)
   apply(rule Wellfounded.wf_acyclic)
   apply(rule Wellfounded.wf_less_than)
  apply(blast)
  done

lemma LessThanFinite: "
  finite A
  \<Longrightarrow> A \<noteq> {}
  \<Longrightarrow> wf ({e. e \<in> less_than \<and> (fst e) \<in> A \<and>(snd e) \<in> A})"
  apply(rule_tac
      r = "less_than"
      in Wellfounded.wf_subset)
   apply(rule Wellfounded.wf_less_than)
  apply(blast)
  done

lemma card_diff_null_implies_subseteq: "
  finite A
  \<Longrightarrow> card (A - B) = 0
  \<Longrightarrow> A \<subseteq> B"
  apply(subgoal_tac "A - B = {}")
   apply(auto)
  done

lemma strictly_smaller_set_map_has_strictly_fewer_image_elements: "
  \<forall>x. finite (f' x)
  \<Longrightarrow> \<forall>x. f x \<subseteq> f' x
  \<Longrightarrow> \<exists>x  \<in> A. f x \<subset> f' x
  \<Longrightarrow> finite A
  \<Longrightarrow> (\<Sum>x  \<in> A. card (f x)) < (\<Sum>x  \<in> A. card (f' x))"
  apply(erule_tac bexE)
  apply(rename_tac x)(*strict*)
  apply(rule_tac
      t = "sum (\<lambda>x. card (f x)) A"
      and s = "(card(f x)) + (sum (\<lambda>x. card (f x)) (A - {x}))"
      in ssubst)
   apply(rename_tac x)(*strict*)
   apply(rule Groups_Big.comm_monoid_add_class.sum.remove)
    apply(rename_tac x)(*strict*)
    apply(blast)
   apply(rename_tac x)(*strict*)
   apply(blast)
  apply(rename_tac x)(*strict*)
  apply(rule_tac
      t = "sum (\<lambda>x. card (f' x)) A"
      and s = "(card(f' x)) + (sum (\<lambda>x. card (f' x)) (A - {x}))"
      in ssubst)
   apply(rename_tac x)(*strict*)
   apply(rule Groups_Big.comm_monoid_add_class.sum.remove)
    apply(rename_tac x)(*strict*)
    apply(blast)
   apply(rename_tac x)(*strict*)
   apply(blast)
  apply(rename_tac x)(*strict*)
  apply(rule Groups.ordered_cancel_ab_semigroup_add_class.add_less_le_mono)
   apply(rename_tac x)(*strict*)
   apply(rule Finite_Set.psubset_card_mono)
    apply(rename_tac x)(*strict*)
    apply(blast)
   apply(rename_tac x)(*strict*)
   apply(blast)
  apply(rename_tac x)(*strict*)
  apply(rule_tac
      i = "\<lambda>x. x"
      in Groups_Big.sum_le_included)
     apply(rename_tac x)(*strict*)
     apply(blast)
    apply(rename_tac x)(*strict*)
    apply(blast)
   apply(rename_tac x)(*strict*)
   apply(blast)
  apply(rename_tac x)(*strict*)
  apply(rule_tac ballI)
  apply(rename_tac x xa)(*strict*)
  apply(erule_tac
      x = "xa"
      and P = "\<lambda>xa. f xa \<subseteq> f' xa"
      in allE)
  apply(rule_tac
      x = "xa"
      in bexI)
   apply(rename_tac x xa)(*strict*)
   defer
   apply(blast)
  apply(rename_tac x xa)(*strict*)
  apply(rule conjI)
   apply(rename_tac x xa)(*strict*)
   apply(clarsimp)
  apply(rename_tac x xa)(*strict*)
  apply(rule Finite_Set.card_mono)
   apply(rename_tac x xa)(*strict*)
   apply(blast)
  apply(rename_tac x xa)(*strict*)
  apply(blast)
  done

lemma finite_map_split: "
  finite A
  \<Longrightarrow> \<forall>x  \<in> A. finite (f x)
  \<Longrightarrow> finite {(x, y). x  \<in> A \<and> y = f x}"
  apply(rule_tac
      B = "(A \<times> {x. \<exists>y  \<in> A. x = f y})"
      in Finite_Set.finite_subset)
   apply(auto)
  done

lemma finite_big_union: "
  finite A
  \<Longrightarrow> \<forall>x  \<in> A. finite (f x)
  \<Longrightarrow> finite (\<Union>{f x |x. x  \<in> A})"
  apply(subgoal_tac "(\<forall>x  \<in> A. finite (f x)) \<longrightarrow> finite (\<Union>{f x |x. x  \<in> A})")
   apply(blast)
  apply(rule_tac
      x = "A"
      in Finite_Set.finite.induct)
    apply(blast)
   apply(clarsimp)
  apply(rename_tac Aa a)(*strict*)
  apply(clarsimp)
  apply(rule_tac
      s = "(f a)\<union>(\<Union>{y. \<exists>x. y = f x \<and> x  \<in> Aa})"
      and t = "\<Union>{y. \<exists>x. y = f x \<and> (x = a \<or> x  \<in> Aa)}"
      in ssubst)
   apply(rename_tac Aa a)(*strict*)
   apply(blast)
  apply(rename_tac Aa a)(*strict*)
  apply(auto)
  done

lemma positive_weight_function_with_sum_null_is_null_everywhere: "
  finite A
  \<Longrightarrow> sum f A = (0::nat)
  \<Longrightarrow> x  \<in> A
  \<Longrightarrow> \<forall>x  \<in> A. 0 \<le> f x
  \<Longrightarrow> f x = 0"
  apply(subgoal_tac "\<forall>x  \<in> A. f x = 0")
   apply(blast)
  apply(rule_tac
      s = "sum f A = 0"
      and t = "\<forall>x  \<in> A. f x = 0"
      in ssubst)
   apply(rule sym)
   apply(rule sum_eq_0_iff)
   apply(blast)
  apply(blast)
  done

lemma exInsert: "
  card A>0
  \<Longrightarrow> \<exists>a B. A = insert a B \<and> a \<notin> B"
  apply(case_tac "A = {}")
   apply(clarsimp)
  apply(auto)
  apply(rename_tac x)(*strict*)
  apply(erule_tac
      x = "x"
      in allE)
  apply(erule_tac
      x = "A - {x}"
      in allE)
  apply(clarsimp)
  apply(auto)
  done

lemma injToInfiniteSet: "
  \<not> finite B
  \<Longrightarrow> finite Q
  \<Longrightarrow> \<exists>f. inj_on f Q \<and> f`Q\<subseteq>B"
  apply(subgoal_tac "\<forall>n. \<forall>Q. card Q = n \<and> finite Q \<longrightarrow> (\<exists>f. inj_on f Q \<and> f`Q\<subseteq>B)")
   apply(erule_tac
      x = "card Q"
      in allE)
   apply(erule_tac
      x = "Q"
      in allE)
   apply(clarsimp)
  apply(rule allI)
  apply(rename_tac n)(*strict*)
  apply(induct_tac n)
   apply(rename_tac n)(*strict*)
   apply(clarsimp)
  apply(rename_tac n na)(*strict*)
  apply(clarsimp)
  apply(rename_tac na Qa)(*strict*)
  apply(subgoal_tac "\<exists>a Q'. Qa = insert a Q' \<and> a \<notin> Q'")
   apply(rename_tac na Qa)(*strict*)
   defer
   apply(rule exInsert)
   apply(clarsimp)
  apply(rename_tac na Qa)(*strict*)
  apply(clarsimp)
  apply(rename_tac a Q')(*strict*)
  apply(erule_tac
      x = "Q'"
      in allE)
  apply(erule impE)
   apply(rename_tac a Q')(*strict*)
   apply(clarsimp)
  apply(rename_tac a Q')(*strict*)
  apply(erule exE)
  apply(rename_tac a Q' f)(*strict*)
  apply(auto)
  apply(subgoal_tac "B - (f`Q') \<noteq> {}")
   apply(rename_tac a Q' f)(*strict*)
   defer
   apply(clarsimp)
  apply(rename_tac a Q' f)(*strict*)
  apply(subgoal_tac "\<exists>x. x \<in> (B - (f`Q'))")
   apply(rename_tac a Q' f)(*strict*)
   defer
   apply(blast)
  apply(rename_tac a Q' f)(*strict*)
  apply(erule exE)
  apply(rename_tac a Q' f x)(*strict*)
  apply(rule_tac
      x = "\<lambda>n. (if n = a then x else f n)"
      in exI)
  apply(rule conjI)
   apply(rename_tac a Q' f x)(*strict*)
   apply(simp add: inj_on_def)
  apply(rename_tac a Q' f x)(*strict*)
  apply(rule conjI)
   apply(rename_tac a Q' f x)(*strict*)
   apply(clarsimp)
  apply(rename_tac a Q' f x)(*strict*)
  apply(rule conjI)
   apply(rename_tac a Q' f x)(*strict*)
   apply(clarsimp)
  apply(rename_tac a Q' f x)(*strict*)
  apply(rule subsetI)
  apply(rename_tac a Q' f x xa)(*strict*)
  apply(rule set_mp)
   apply(rename_tac a Q' f x xa)(*strict*)
   apply(blast)
  apply(rename_tac a Q' f x xa)(*strict*)
  apply(clarsimp)
  done

lemma notFinite_subset: "
  \<not>(finite A)
  \<Longrightarrow> A\<subseteq>B
  \<Longrightarrow> \<not> finite B"
  apply(auto)
  apply(subgoal_tac "finite A")
   apply(blast)
  apply(rule Finite_Set.finite_subset)
   apply(auto)
  done

lemma finite_has_max: "
  finite A
  \<Longrightarrow> \<exists>(n::nat). \<forall>x \<in> A. f x \<le> n"
  apply(rule_tac
      x = "sum f A"
      in exI)
  apply(rule ballI)
  apply(rename_tac x)(*strict*)
  apply(rule_tac
      t = "sum f A"
      and s = "f x + sum f (A - {x})"
      in ssubst)
   apply(rename_tac x)(*strict*)
   apply(rule Groups_Big.sum.remove)
    apply(rename_tac x)(*strict*)
    apply(force)
   apply(rename_tac x)(*strict*)
   apply(force)
  apply(rename_tac x)(*strict*)
  apply(force)
  done

lemma finite_imageI_2sets: "
  finite A
  \<Longrightarrow> finite B
  \<Longrightarrow> finite {f a b| a b. a  \<in> A \<and> b  \<in> B }"
  apply(rule_tac
      t = "{f a b| a b. a  \<in> A \<and> b  \<in> B }"
      and s = "(\<lambda>(a,b). f a b) ` (A\<times>B)"
      in ssubst)
   apply(force)
  apply(rule finite_imageI)
  apply(force)
  done

lemma finite_imageI_1set: "
  finite A
  \<Longrightarrow> finite {f a| a. a  \<in> A }"
  apply(rule_tac
      t = "{f a| a. a  \<in> A }"
      and s = "(\<lambda>a. f a) ` A"
      in ssubst)
   apply(force)
  apply(rule finite_imageI)
  apply(force)
  done

lemma UN_eq: "
  (\<Union>x \<in> A. B x) = \<Union>{Y. \<exists>x \<in> A. Y = B x}"
  apply(blast)
  done

lemma finite_transfer_card_eq: "
  card A = card B
  \<Longrightarrow> finite A
  \<Longrightarrow> A \<noteq> {}
  \<Longrightarrow> finite B"
  apply (metis card_eq_0_iff)
  done

lemma finite_two_set: "
  finite A
  \<Longrightarrow> finite B
  \<Longrightarrow> A \<noteq> {}
  \<Longrightarrow> B \<noteq> {}
  \<Longrightarrow> inj_on (\<lambda> (x, y) . two x y) (A \<times> B)
  \<Longrightarrow> finite {two a b| a b. a  \<in> A \<and> b  \<in> B}"
  apply(rule_tac
      A="A\<times>B"
      in finite_transfer_card_eq)
    apply(rule_tac
      f="\<lambda>(a,b). two a b"
      in bij_betw_same_card)
    apply(simp add: bij_betw_def)
    apply(rule order_antisym)
     apply(clarsimp)
     apply(rename_tac a b)(*strict*)
     apply(force)
    apply(force)
   apply(force)
  apply(force)
  done

lemma finite_three_set: "
  finite A
  \<Longrightarrow> finite B
  \<Longrightarrow> A \<noteq> {}
  \<Longrightarrow> B \<noteq> {}
  \<Longrightarrow> inj_on (\<lambda>(a, x, y). three a x y) (A \<times> B \<times> A)
  \<Longrightarrow> finite {three a b c| a b c. a  \<in> A \<and> c  \<in> A \<and> b  \<in> B}"
  apply(rule_tac
      A="A\<times>B\<times>A"
      in finite_transfer_card_eq)
    apply(rule_tac
      f="\<lambda>(a,b,c). three a b c"
      in bij_betw_same_card)
    apply(simp add: bij_betw_def)
    apply(rule order_antisym)
     apply(clarsimp)
     apply(rename_tac a aa b)(*strict*)
     apply(force)
    apply(force)
   apply(force)
  apply(force)
  done

lemma Min_is_Suc_n: "
  n \<notin> A
  \<Longrightarrow> finite A
  \<Longrightarrow> (\<And>k. k  \<in> A \<Longrightarrow> n \<le> k)
  \<Longrightarrow> Suc n  \<in> A
  \<Longrightarrow> Min A = Suc n"
  apply (metis Min_eqI eq_iff not_less_eq_eq)
  done

lemma apply_min: "
  x  \<in> A
  \<Longrightarrow> x  \<in> A
  \<Longrightarrow> x = Min A
  \<Longrightarrow> P x
  \<Longrightarrow> P (Min A)"
  apply(force)
  done

lemma inter_eq_intro: "
  A \<subseteq> B
  \<Longrightarrow> A \<subseteq> C
  \<Longrightarrow> B \<inter> C \<subseteq> A
  \<Longrightarrow> A = B \<inter> C"
  apply(force)
  done

lemma card_diff: "
  C \<subseteq> B
  \<Longrightarrow> C \<noteq> B
  \<Longrightarrow> finite A
  \<Longrightarrow> B \<subseteq> A
  \<Longrightarrow> card (A - B) < card (A - C)"
  apply (metis finite_Diff psubset_card_mono psubset_eq rev_subset)
  done

lemma finite_big_union2: "
  finite A
  \<Longrightarrow> \<forall>x  \<in> A. finite (f x)
  \<Longrightarrow> finite (\<Union> (f ` A))"
  apply(rule finite_Union)
   apply(force)
  apply(rename_tac M)(*strict*)
  apply(force)
  done

lemma showDisj: "
  (\<And>x. x \<in> A \<Longrightarrow> x \<notin> B)
  \<Longrightarrow> (\<And>x. x \<in> B \<Longrightarrow> x \<notin> A)
  \<Longrightarrow> A\<inter>B = {}"
  apply(auto)
  done

lemma showInImage: "
  \<exists>y \<in> A. f y = x
  \<Longrightarrow> x \<in> (f ` A)"
  apply(clarsimp)
  done

lemma inv_into_f_eq2: "
  inj_on f A
  \<Longrightarrow> a  \<in> A
  \<Longrightarrow> ((inv_into A f) \<circ> f) a = a"
  apply (metis inv_into_f_eq o_apply)
  done

lemma inj_on_from_infinite_set: "
  finite A
  \<Longrightarrow> \<not> finite (B::'b set)
  \<Longrightarrow> \<exists>f::'a \<Rightarrow> 'b. inj_on f A"
  apply (metis injToInfiniteSet)
  done

lemma Max_exists: "
  N \<noteq> {}
  \<Longrightarrow> finite N
  \<Longrightarrow> \<exists>x \<in> N. x = Max N"
  apply(rule_tac
      x="Max N"
      in bexI)
   apply(force)
  apply(rule Max_in)
   apply(force)
  apply(force)
  done

lemma ballE_prime: "
  \<forall>x \<in> A. P x
  \<Longrightarrow> (P x \<Longrightarrow> \<forall>x \<in> A. P x  \<Longrightarrow> Q)
  \<Longrightarrow> (x \<notin> A \<Longrightarrow> Q )
  \<Longrightarrow> Q"
  apply(force)
  done

end


\<comment> \<open>Substitutionless First-Order Logic: A Formal Soundness Proof\<close>

theory Lesser imports Main begin

type_synonym proxy = \<open>unit list\<close>

type_synonym arity = proxy

type_synonym var = proxy

datatype form = Pre proxy arity | Eq var var | Neg form | Imp form form | Uni var form

primrec eval :: \<open>(var \<Rightarrow> 'a) \<Rightarrow> arity \<Rightarrow> 'a list\<close> where
  \<open>eval _ [] = []\<close> |
  \<open>eval e (_ # n) = e n # eval e n\<close>

primrec semantics :: \<open>(var \<Rightarrow> 'a) \<Rightarrow> (proxy \<Rightarrow> 'a list \<Rightarrow> bool) \<Rightarrow> form \<Rightarrow> bool\<close> where
  \<open>semantics e g (Pre i n) = g i (eval e n)\<close> |
  \<open>semantics e g (Eq x y) = (e x = e y)\<close> |
  \<open>semantics e g (Neg p) = (\<not> semantics e g p)\<close> |
  \<open>semantics e g (Imp p q) = (semantics e g p \<longrightarrow> semantics e g q)\<close> |
  \<open>semantics e g (Uni x p) = (\<forall>t. semantics (e(x := t)) g p)\<close>

primrec no_occur_in :: \<open>var \<Rightarrow> form \<Rightarrow> bool\<close> where
  \<open>no_occur_in z (Pre _ n) = (length z \<ge> length n)\<close> |
  \<open>no_occur_in z (Eq x y) = (z \<noteq> x \<and> z \<noteq> y)\<close> |
  \<open>no_occur_in z (Neg p) = no_occur_in z p\<close> |
  \<open>no_occur_in z (Imp p q) = (no_occur_in z p \<and> no_occur_in z q)\<close> |
  \<open>no_occur_in z (Uni _ p) = no_occur_in z p\<close>

abbreviation \<open>fail \<equiv> Uni [] (Eq [] [])\<close>

inductive OK :: \<open>form \<Rightarrow> bool\<close> ("\<turnstile> _" 0) where
  \<open>\<turnstile> pq \<Longrightarrow> \<turnstile> p \<Longrightarrow> \<turnstile> case pq of Imp p' q \<Rightarrow> if p' = p then q else fail | _ \<Rightarrow> fail\<close> |
  \<open>\<turnstile> p \<Longrightarrow> \<turnstile> Uni x p\<close> |
  \<open>\<turnstile> Imp (Imp p q) (Imp (Imp q r) (Imp p r))\<close> |
  \<open>\<turnstile> Imp (Imp (Neg p) p) p\<close> |
  \<open>\<turnstile> Imp p (Imp (Neg p) q)\<close> |
  \<open>\<turnstile> Imp (Uni x (Imp p q)) (Imp (Uni x p) (Uni x q))\<close> |
  \<open>\<turnstile> if no_occur_in x p then Imp p (Uni x p) else fail\<close> |
  \<open>\<turnstile> Imp (Neg (Uni x p)) (Uni x (Neg (Uni x p)))\<close> |
  \<open>\<turnstile> Imp (Uni x (Uni y p)) (Uni y (Uni x p))\<close> |
  \<open>\<turnstile> Neg (Uni x (Neg (Eq x y)))\<close> |
  \<open>\<turnstile> Imp (Eq x y) (Imp (Eq x z) (Eq y z))\<close> |
  \<open>\<turnstile> if x \<noteq> y then Imp (Eq x y) (Imp p (Uni x (Imp (Eq x y) p))) else fail\<close>

theorem soundness: \<open>\<turnstile> p \<Longrightarrow> semantics e g p\<close>
proof (induct arbitrary: e rule: OK.induct)
  case 7
  have \<open>semantics (e(x := t)) g p = semantics e g p\<close> if \<open>no_occur_in x p\<close> for e x g p and t :: 'a
  proof -
    have \<open>eval (e(x := t)) n = eval e n\<close> if \<open>length x \<ge> length n\<close> for e x n and t :: 'a
      using that Suc_n_not_le_n by (induct n, simp_all, fast)
    with that show ?thesis
      by (induct arbitrary: e, simp_all, fast, metis fun_upd_twist fun_upd_upd)
  qed
  then show ?case
    by simp
qed (auto simp: fun_upd_idem split: form.split, metis fun_upd_twist)

end

\<comment> \<open>Andreas Halkjær From, John Bruntse Larsen, Anders Schlichtkrull & Jørgen Villadsen\<close>


theory SubcategoryFactorization
  imports Main
         "Category3.Subcategory"
         "Category3.NaturalTransformation"
begin

locale factorization =
  A: category A +
  B: category B +
  S: subcategory B S +
  F: "functor" A B F
  for A :: "'a comp"
  and B :: "'b comp"
  and F :: "'a \<Rightarrow> 'b"
  and S :: "'b \<Rightarrow> bool" +
assumes lands_in_subcat: "\<And>a. A.arr a \<Longrightarrow> S (F a)"
begin

lemma is_functor : "functor A S.comp F"
  unfolding functor_def apply auto
    apply (simp add: A.category_axioms)
   apply (simp add: subcategory.is_category S.subcategory_axioms)
  unfolding functor_axioms_def apply auto
proof-
  show "\<And>f. \<not> A.arr f \<Longrightarrow> F f = B.null"
    using F.is_extensional by blast
  show arr_f : "\<And>f. A.arr f \<Longrightarrow> S.arr (F f)"
    using S.subcategory_axioms apply (simp add: subcategory.arr_char)
    by (simp add: lands_in_subcat)
  show "\<And>f. A.arr f \<Longrightarrow> S.dom (F f) = F (A.dom f)"
    using S.subcategory_axioms apply (simp add: subcategory.dom_char)
    using lands_in_subcat by auto
  show "\<And>f. A.arr f \<Longrightarrow> S.cod (F f) = F (A.cod f)"
    using S.subcategory_axioms apply (simp add: subcategory.cod_char)
    using lands_in_subcat by auto
  show "\<And>g f. A.seq g f \<Longrightarrow> B (F g) (F f) = S.comp (F g) (F f)"
    using S.subcategory_axioms apply (simp add: subcategory.comp_char)
    using lands_in_subcat by auto
qed

lemma fully_faithful : "fully_faithful_functor A B F \<Longrightarrow>
                        fully_faithful_functor A S.comp F"
  unfolding fully_faithful_functor_def
            faithful_functor_def
            full_functor_def
  apply auto
  apply (simp add: is_functor)
  unfolding full_functor_axioms_def
  apply auto
proof-
  fix a b g
  assume "\<forall>a. A.ide a \<longrightarrow>
           (\<forall>b. A.ide b \<longrightarrow>
                 (\<forall>g. \<guillemotleft>g : F b \<rightarrow>\<^sub>B F a\<guillemotright> \<longrightarrow> (\<exists>f. \<guillemotleft>f : b \<rightarrow>\<^sub>A a\<guillemotright> \<and> F f = g)))"
  then have full: "\<And>a. A.ide a \<Longrightarrow> (\<And>b. A.ide b \<Longrightarrow>
             (\<And>g. \<guillemotleft>g : F b \<rightarrow>\<^sub>B F a\<guillemotright> \<Longrightarrow>  (\<exists>f. \<guillemotleft>f : b \<rightarrow>\<^sub>A a\<guillemotright> \<and> F f = g)))"
    by auto
  assume "A.ide a" "A.ide b"
  assume g_in_Shom: "S.in_hom g (F b) (F a)"
  then have "\<guillemotleft>g : F b \<rightarrow>\<^sub>B F a\<guillemotright>"
    using subcategory.in_hom_char [OF S.subcategory_axioms] by blast
  show "(\<exists>f. \<guillemotleft>f : b \<rightarrow>\<^sub>A a\<guillemotright> \<and> F f = g)"
    apply (rule_tac full)
    using \<open>A.ide a\<close> \<open>A.ide b\<close> \<open>\<guillemotleft>g : F b \<rightarrow>\<^sub>B F a\<guillemotright>\<close> by simp_all
qed

lemma comp_factorization :
  assumes "functor D A G"
  shows "factorization D B (F \<circ> G) S"
  unfolding factorization_def
  apply safe
  using \<open>functor D A G\<close>
      apply (simp add: functor_def)
     apply (rule_tac B.category_axioms)
    apply (rule_tac S.subcategory_axioms)
   apply (rule_tac functor_comp)
    apply (rule_tac \<open>functor D A G\<close>)
   apply (rule_tac F.functor_axioms)
  unfolding factorization_axioms_def
  apply safe
proof-
  fix a
  assume "partial_magma.arr D a"
  then have "A.arr (G a)"
    using functor.preserves_arr [OF \<open>functor D A G\<close>]
    by simp
  then show "S ((F \<circ> G) a)"
    apply simp
    using lands_in_subcat.
qed

end

locale nat_trafo_factorization =
  A: category A +
  B: category B +
  S: subcategory B S +
  F: "functor" A B F +
  F_factors : factorization A B F S +
  G_factors : factorization A B G S +
  G: "functor" A B G +
  \<tau>: natural_transformation A B F G \<tau>
  for A :: "'a comp"
  and B :: "'b comp"
  and F :: "'a \<Rightarrow> 'b"
  and G :: "'a \<Rightarrow> 'b"
  and \<tau> :: "'a \<Rightarrow> 'b"
  and S :: "'b \<Rightarrow> bool" +
assumes lands_in_subcat: "\<And>a. A.arr a \<Longrightarrow> S (\<tau> a)"
begin

lemma is_natural_transformation : "natural_transformation A S.comp F G \<tau>"
  unfolding natural_transformation_def
  apply (simp add: A.category_axioms
                   subcategory.is_category [OF S.subcategory_axioms]
                   F_factors.is_functor
                   G_factors.is_functor)
  unfolding natural_transformation_axioms_def
  apply safe
proof-
  fix f
  show "\<not> A.arr f \<Longrightarrow> \<tau> f = S.null"
    unfolding subcategory.null_char [OF S.subcategory_axioms]
    using \<tau>.is_extensional by blast
  assume "A.arr f"
  show "S.dom (\<tau> f) = F (A.dom f)"
    unfolding subcategory.dom_char [OF S.subcategory_axioms]
    using lands_in_subcat [OF \<open>A.arr f\<close>]
    unfolding subcategory.arr_char [OF S.subcategory_axioms] apply simp
    using \<open>A.arr f\<close> by blast
  show "S.cod (\<tau> f) = G (A.cod f)"
    unfolding subcategory.cod_char [OF S.subcategory_axioms]
    using lands_in_subcat [OF \<open>A.arr f\<close>]
    unfolding subcategory.arr_char [OF S.subcategory_axioms] apply simp
    using \<open>A.arr f\<close> by blast
  have "S.arr (\<tau> (A.dom f)) \<and> S.arr (G f) \<and> B.seq (G f) (\<tau> (A.dom f))"
    unfolding subcategory.arr_char [OF S.subcategory_axioms]
    apply safe
      apply (rule_tac lands_in_subcat [OF A.arr_dom [OF \<open>A.arr f\<close>]])
     apply (rule_tac G_factors.lands_in_subcat [OF \<open>A.arr f\<close>])
    by (simp add: \<open>A.arr f\<close>)
  then show "S.comp (G f) (\<tau> (A.dom f)) = \<tau> f"
    apply (subst subcategory.comp_char [OF S.subcategory_axioms])
    apply simp
    by blast
  have "S.arr (F f) \<and> S.arr (\<tau> (A.cod f)) \<and> B.seq (\<tau> (A.cod f)) (F f)"
    unfolding subcategory.arr_char [OF S.subcategory_axioms]
    apply safe
      apply (rule_tac F_factors.lands_in_subcat [OF \<open>A.arr f\<close>])
     apply (rule_tac lands_in_subcat [OF A.arr_cod [OF \<open>A.arr f\<close>]])
    by (simp add: \<open>A.arr f\<close>)
  then show "S.comp (\<tau> (A.cod f)) (F f) = \<tau> f"
    apply (subst subcategory.comp_char [OF S.subcategory_axioms])
    apply simp
    by blast
qed

end

end