(*  Title:       More about Multisets
    Author:      Mathias Fleury <mathias.fleury at mpi-inf.mpg.de>, 2015
    Author:      Jasmin Blanchette <blanchette at in.tum.de>, 2014, 2015
    Author:      Anders Schlichtkrull <andschl at dtu.dk>, 2017
    Author:      Dmitriy Traytel <traytel at in.tum.de>, 2014
    Maintainer:  Mathias Fleury <mathias.fleury at mpi-inf.mpg.de>
*)

section \<open>More about Multisets\<close>

theory Multiset_More
  imports
    "HOL-Library.Multiset_Order"
    "HOL-Library.Sublist"
begin

text \<open>
Isabelle's theory of finite multisets is not as developed as other areas, such as lists and sets.
The present theory introduces some missing concepts and lemmas. Some of it is expected to move to
Isabelle's library.
\<close>

subsection \<open>Basic Setup\<close>

declare
  diff_single_trivial [simp]
  in_image_mset [iff]
  image_mset.compositionality [simp]

  (*To have the same rules as the set counter-part*)
  mset_subset_eqD[dest, intro?] (*@{thm subsetD}*)

  Multiset.in_multiset_in_set[simp]
  inter_add_left1[simp]
  inter_add_left2[simp]
  inter_add_right1[simp]
  inter_add_right2[simp]

  sum_mset_sum_list[simp]

subsection \<open>Lemmas about Intersection, Union and Pointwise Inclusion\<close>

lemma subset_mset_imp_subset_add_mset: "A \<subseteq># B \<Longrightarrow> A \<subseteq># add_mset x B"
  by (auto simp add: subseteq_mset_def le_SucI)

lemma subset_add_mset_notin_subset_mset: \<open>A \<subseteq># add_mset b B \<Longrightarrow> b \<notin># A \<Longrightarrow> A \<subseteq># B\<close>
  by (simp add: subset_mset.le_iff_sup)

lemma subset_msetE: "\<lbrakk>A \<subset># B; \<lbrakk>A \<subseteq># B; \<not> B \<subseteq># A\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  by (simp add: subset_mset.less_le_not_le)

lemma Diff_triv_mset: "M \<inter># N = {#} \<Longrightarrow> M - N = M"
  by (metis diff_intersect_left_idem diff_zero)

lemma diff_intersect_sym_diff: "(A - B) \<inter># (B - A) = {#}"
  by (rule multiset_eqI) simp

declare subset_msetE [elim!]

lemma subseq_mset_subseteq_mset: "subseq xs ys \<Longrightarrow> mset xs \<subseteq># mset ys"
proof (induct xs arbitrary: ys)
  case (Cons x xs)
  note Outer_Cons = this
  then show ?case
  proof (induct ys)
    case (Cons y ys)
    have "subseq xs ys"
      by (metis Cons.prems(2) subseq_Cons' subseq_Cons2_iff)
    then show ?case
      using Cons by (metis mset.simps(2) mset_subset_eq_add_mset_cancel subseq_Cons2_iff
          subset_mset_imp_subset_add_mset)
  qed simp
qed simp

lemma finite_mset_set_inter:
  \<open>finite A \<Longrightarrow> finite B \<Longrightarrow> mset_set (A \<inter> B) = mset_set A \<inter># mset_set B\<close>
  apply (induction A rule: finite_induct)
  subgoal by auto
  subgoal for a A
    by (cases \<open>a \<in> B\<close>; cases \<open>a \<in># mset_set B\<close>)
      (use multi_member_split[of a \<open>mset_set B\<close>] in
        \<open>auto simp: mset_set.insert_remove\<close>)
  done

subsection \<open>Lemmas about Filter and Image\<close>

lemma count_image_mset_ge_count: "count (image_mset f A) (f b) \<ge> count A b"
  by (induction A) auto

lemma count_image_mset_inj:
  assumes \<open>inj f\<close>
  shows \<open>count (image_mset f M) (f x) = count M x\<close>
  by (induct M) (use assms in \<open>auto simp: inj_on_def\<close>)

lemma count_image_mset_le_count_inj_on:
  "inj_on f (set_mset M) \<Longrightarrow> count (image_mset f M) y \<le> count M (inv_into (set_mset M) f y)"
proof (induct M)
  case (add x M)
  note ih = this(1) and inj_xM = this(2)

  have inj_M: "inj_on f (set_mset M)"
    using inj_xM by simp

  show ?case
  proof (cases "x \<in># M")
    case x_in_M: True
    show ?thesis
    proof (cases "y = f x")
      case y_eq_fx: True
      show ?thesis
        using x_in_M ih[OF inj_M] unfolding y_eq_fx by (simp add: inj_M insert_absorb)
    next
      case y_ne_fx: False
      show ?thesis
        using x_in_M ih[OF inj_M] y_ne_fx insert_absorb by fastforce
    qed
  next
    case x_ni_M: False
    show ?thesis
    proof (cases "y = f x")
      case y_eq_fx: True
      have "f x \<notin># image_mset f M"
        using x_ni_M inj_xM by force
      thus ?thesis
        unfolding y_eq_fx
        by (metis (no_types) inj_xM count_add_mset count_greater_eq_Suc_zero_iff count_inI
          image_mset_add_mset inv_into_f_f union_single_eq_member)
    next
      case y_ne_fx: False
      show ?thesis
      proof (rule ccontr)
        assume neg_conj: "\<not> count (image_mset f (add_mset x M)) y
          \<le> count (add_mset x M) (inv_into (set_mset (add_mset x M)) f y)"

        have cnt_y: "count (add_mset (f x) (image_mset f M)) y = count (image_mset f M) y"
          using y_ne_fx by simp

        have "inv_into (set_mset M) f y \<in># add_mset x M \<Longrightarrow>
          inv_into (set_mset (add_mset x M)) f (f (inv_into (set_mset M) f y)) =
          inv_into (set_mset M) f y"
          by (meson inj_xM inv_into_f_f)
        hence "0 < count (image_mset f (add_mset x M)) y \<Longrightarrow>
          count M (inv_into (set_mset M) f y) = 0 \<or> x = inv_into (set_mset M) f y"
          using neg_conj cnt_y ih[OF inj_M]
          by (metis (no_types) count_add_mset count_greater_zero_iff count_inI f_inv_into_f
            image_mset_add_mset set_image_mset)
        thus False
          using neg_conj cnt_y x_ni_M ih[OF inj_M]
          by (metis (no_types) count_greater_zero_iff count_inI eq_iff image_mset_add_mset
            less_imp_le)
      qed
    qed
  qed
qed simp

lemma mset_filter_compl: "mset (filter p xs) + mset (filter (Not \<circ> p) xs) = mset xs"
  by (induction xs) (auto simp: ac_simps)

text \<open>Near duplicate of @{thm [source] filter_eq_replicate_mset}: @{thm filter_eq_replicate_mset}.\<close>

lemma filter_mset_eq: "filter_mset ((=) L) A = replicate_mset (count A L) L"
  by (auto simp: multiset_eq_iff)

lemma filter_mset_cong[fundef_cong]:
  assumes "M = M'" "\<And>a. a \<in># M \<Longrightarrow> P a = Q a"
  shows "filter_mset P M = filter_mset Q M"
proof -
  have "M - filter_mset Q M = filter_mset (\<lambda>a. \<not>Q a) M"
    by (metis multiset_partition add_diff_cancel_left')
  then show ?thesis
    by (auto simp: filter_mset_eq_conv assms)
qed

lemma image_mset_filter_swap: "image_mset f {# x \<in># M. P (f x)#} = {# x \<in># image_mset f M. P x#}"
  by (induction M) auto

lemma image_mset_cong2:
  "(\<And>x. x \<in># M \<Longrightarrow> f x = g x) \<Longrightarrow> M = N \<Longrightarrow> image_mset f M = image_mset g N"
  by (hypsubst, rule image_mset_cong)

lemma filter_mset_empty_conv: \<open>(filter_mset P M = {#}) = (\<forall>L\<in>#M. \<not> P L)\<close>
  by (induction M) auto

lemma multiset_filter_mono2: \<open>filter_mset P A \<subseteq># filter_mset Q A \<longleftrightarrow> (\<forall>a\<in>#A. P a \<longrightarrow> Q a)\<close>
  by (induction A) (auto intro: subset_mset.trans)

lemma image_filter_cong:
  assumes \<open>\<And>C. C \<in># M \<Longrightarrow> P C \<Longrightarrow> f C = g C\<close>
  shows \<open>{#f C. C \<in># {#C \<in># M. P C#}#} = {#g C | C\<in># M. P C#}\<close>
  using assms by (induction M) auto

lemma image_mset_filter_swap2: \<open>{#C \<in># {#P x. x \<in># D#}. Q C #} = {#P x. x \<in># {#C| C \<in># D. Q (P C)#}#}\<close>
  by (simp add: image_mset_filter_swap)

declare image_mset_cong2 [cong]

lemma filter_mset_empty_if_finite_and_filter_set_empty:
  assumes
    "{x \<in> X. P x} = {}" and
    "finite X"
  shows "{#x \<in># mset_set X. P x#} = {#}"
proof -
  have empty_empty: "\<And>Y. set_mset Y = {} \<Longrightarrow> Y = {#}"
    by auto
  from assms have "set_mset {#x \<in># mset_set X. P x#} = {}"
    by auto
  then show ?thesis
    by (rule empty_empty)
qed

subsection \<open>Lemmas about Sum\<close>

lemma sum_image_mset_sum_map[simp]: "sum_mset (image_mset f (mset xs)) = sum_list (map f xs)"
  by (metis mset_map sum_mset_sum_list)

lemma sum_image_mset_mono:
  fixes f :: "'a \<Rightarrow> 'b::canonically_ordered_monoid_add"
  assumes sub: "A \<subseteq># B"
  shows "(\<Sum>m \<in># A. f m) \<le> (\<Sum>m \<in># B. f m)"
  by (metis image_mset_union le_iff_add sub subset_mset.add_diff_inverse sum_mset.union)

lemma sum_image_mset_mono_mem:
  "n \<in># M \<Longrightarrow> f n \<le> (\<Sum>m \<in># M. f m)" for f :: "'a \<Rightarrow> 'b::canonically_ordered_monoid_add"
  using le_iff_add multi_member_split by fastforce

lemma count_sum_mset_if_1_0: \<open>count M a = (\<Sum>x\<in>#M. if x = a then 1 else 0)\<close>
  by (induction M) auto

lemma sum_mset_dvd:
  fixes k :: "'a::comm_semiring_1_cancel"
  assumes "\<forall>m \<in># M. k dvd f m"
  shows "k dvd (\<Sum>m \<in># M. f m)"
  using assms by (induct M) auto

subsection \<open>Lemmas about Remove\<close>

lemma set_mset_minus_replicate_mset[simp]:
  "n \<ge> count A a \<Longrightarrow> set_mset (A - replicate_mset n a) = set_mset A - {a}"
  "n < count A a \<Longrightarrow> set_mset (A - replicate_mset n a) = set_mset A"
  unfolding set_mset_def by (auto split: if_split simp: not_in_iff)

abbreviation removeAll_mset :: "'a \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset" where
  "removeAll_mset C M \<equiv> M - replicate_mset (count M C) C"

lemma mset_removeAll[simp, code]: "removeAll_mset C (mset L) = mset (removeAll C L)"
  by (induction L) (auto simp: ac_simps multiset_eq_iff split: if_split_asm)

lemma removeAll_mset_filter_mset: "removeAll_mset C M = filter_mset ((\<noteq>) C) M"
  by (induction M) (auto simp: ac_simps multiset_eq_iff)

abbreviation remove1_mset :: "'a \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset" where
  "remove1_mset C M \<equiv> M - {#C#}"

lemma removeAll_subseteq_remove1_mset: "removeAll_mset x M \<subseteq># remove1_mset x M"
  by (auto simp: subseteq_mset_def)

lemma in_remove1_mset_neq:
  assumes ab: "a \<noteq> b"
  shows "a \<in># remove1_mset b C \<longleftrightarrow> a \<in># C"
  by (metis assms diff_single_trivial in_diffD insert_DiffM insert_noteq_member)

lemma size_mset_removeAll_mset_le_iff: "size (removeAll_mset x M) < size M \<longleftrightarrow> x \<in># M"
  by (auto intro: count_inI mset_subset_size simp: subset_mset_def multiset_eq_iff)

lemma size_remove1_mset_If: \<open>size (remove1_mset x M) = size M - (if x \<in># M then 1 else 0)\<close>
  by (auto simp: size_Diff_subset_Int)

lemma size_mset_remove1_mset_le_iff: "size (remove1_mset x M) < size M \<longleftrightarrow> x \<in># M"
  using less_irrefl
  by (fastforce intro!: mset_subset_size elim: in_countE simp: subset_mset_def multiset_eq_iff)

lemma remove_1_mset_id_iff_notin: "remove1_mset a M = M \<longleftrightarrow> a \<notin># M"
  by (meson diff_single_trivial multi_drop_mem_not_eq)

lemma id_remove_1_mset_iff_notin: "M = remove1_mset a M \<longleftrightarrow> a \<notin># M"
  using remove_1_mset_id_iff_notin by metis

lemma remove1_mset_eqE:
  "remove1_mset L x1 = M \<Longrightarrow>
    (L \<in># x1 \<Longrightarrow> x1 = M + {#L#} \<Longrightarrow> P) \<Longrightarrow>
    (L \<notin># x1 \<Longrightarrow> x1 = M \<Longrightarrow> P) \<Longrightarrow>
  P"
  by (cases "L \<in># x1") auto

lemma image_filter_ne_mset[simp]:
  "image_mset f {#x \<in># M. f x \<noteq> y#} = removeAll_mset y (image_mset f M)"
  by (induction M) simp_all

lemma image_mset_remove1_mset_if:
  "image_mset f (remove1_mset a M) =
   (if a \<in># M then remove1_mset (f a) (image_mset f M) else image_mset f M)"
  by (auto simp: image_mset_Diff)

lemma filter_mset_neq: "{#x \<in># M. x \<noteq> y#} = removeAll_mset y M"
  by (metis add_diff_cancel_left' filter_eq_replicate_mset multiset_partition)

lemma filter_mset_neq_cond: "{#x \<in># M. P x \<and> x \<noteq> y#} = removeAll_mset y {# x\<in>#M. P x#}"
  by (metis filter_filter_mset filter_mset_neq)

lemma remove1_mset_add_mset_If:
  "remove1_mset L (add_mset L' C) = (if L = L' then C else remove1_mset L C + {#L'#})"
  by (auto simp: multiset_eq_iff)

lemma minus_remove1_mset_if:
  "A - remove1_mset b B = (if b \<in># B \<and> b \<in># A \<and> count A b \<ge> count B b then {#b#} + (A - B) else A - B)"
  by (auto simp: multiset_eq_iff count_greater_zero_iff[symmetric]
    simp del: count_greater_zero_iff)

lemma add_mset_eq_add_mset_ne:
  "a \<noteq> b \<Longrightarrow> add_mset a A = add_mset b B \<longleftrightarrow> a \<in># B \<and> b \<in># A \<and> A = add_mset b (B - {#a#})"
  by (metis (no_types, lifting) diff_single_eq_union diff_union_swap multi_self_add_other_not_self
    remove_1_mset_id_iff_notin union_single_eq_diff)

lemma add_mset_eq_add_mset: \<open>add_mset a M = add_mset b M' \<longleftrightarrow>
  (a = b \<and> M = M') \<or> (a \<noteq> b \<and> b \<in># M \<and> add_mset a (M - {#b#}) = M')\<close>
  by (metis add_mset_eq_add_mset_ne add_mset_remove_trivial union_single_eq_member)

(* TODO move to Multiset: could replace add_mset_remove_trivial_eq? *)
lemma add_mset_remove_trivial_iff: \<open>N = add_mset a (N - {#b#}) \<longleftrightarrow> a \<in># N \<and> a = b\<close>
  by (metis add_left_cancel add_mset_remove_trivial insert_DiffM2 single_eq_single
      size_mset_remove1_mset_le_iff union_single_eq_member)

lemma trivial_add_mset_remove_iff: \<open>add_mset a (N - {#b#}) = N \<longleftrightarrow> a \<in># N \<and> a = b\<close>
  by (subst eq_commute) (fact add_mset_remove_trivial_iff)

lemma remove1_single_empty_iff[simp]: \<open>remove1_mset L {#L'#} = {#} \<longleftrightarrow> L = L'\<close>
  using add_mset_remove_trivial_iff by fastforce

lemma add_mset_less_imp_less_remove1_mset:
  assumes xM_lt_N: "add_mset x M < N"
  shows "M < remove1_mset x N"
proof -
  have "M < N"
    using assms le_multiset_right_total mset_le_trans by blast
  then show ?thesis
    by (metis add_less_cancel_right add_mset_add_single diff_single_trivial insert_DiffM2 xM_lt_N)
qed

lemma remove_diff_multiset[simp]: \<open>x13 \<notin># A \<Longrightarrow> A - add_mset x13 B = A - B\<close>
  by (metis diff_intersect_left_idem inter_add_right1)

lemma removeAll_notin: \<open>a \<notin># A \<Longrightarrow> removeAll_mset a A = A\<close>
  using count_inI by force

lemma mset_drop_upto: \<open>mset (drop a N) = {#N!i. i \<in># mset_set {a..<length N}#}\<close>
proof (induction N arbitrary: a)
  case Nil
  then show ?case by simp
next
  case (Cons c N)
  have upt: \<open>{0..<Suc (length N)} = insert 0 {1..<Suc (length N)}\<close>
    by auto
  then have H: \<open>mset_set {0..<Suc (length N)} = add_mset 0 (mset_set {1..<Suc (length N)})\<close>
    unfolding upt by auto
  have mset_case_Suc: \<open>{#case x of 0 \<Rightarrow> c | Suc x \<Rightarrow> N ! x . x \<in># mset_set {Suc a..<Suc b}#} =
    {#N ! (x-1) . x \<in># mset_set {Suc a..<Suc b}#}\<close> for a b
    by (rule image_mset_cong) (auto split: nat.splits)
  have Suc_Suc: \<open>{Suc a..<Suc b} = Suc ` {a..<b}\<close> for a b
    by auto
  then have mset_set_Suc_Suc: \<open>mset_set {Suc a..<Suc b} = {#Suc n. n \<in># mset_set {a..<b}#}\<close> for a b
    unfolding Suc_Suc by (subst image_mset_mset_set[symmetric]) auto
  have *: \<open>{#N ! (x-Suc 0) . x \<in># mset_set {Suc a..<Suc b}#} = {#N ! x . x \<in># mset_set {a..<b}#}\<close>
    for a b
    by (auto simp add: mset_set_Suc_Suc)
  show ?case
    apply (cases a)
    using Cons[of 0] Cons by (auto simp: nth_Cons drop_Cons H mset_case_Suc *)
qed

subsection \<open>Lemmas about Replicate\<close>

lemma replicate_mset_minus_replicate_mset_same[simp]:
  "replicate_mset m x - replicate_mset n x = replicate_mset (m - n) x"
  by (induct m arbitrary: n, simp, metis left_diff_repeat_mset_distrib' repeat_mset_replicate_mset)

lemma replicate_mset_subset_iff_lt[simp]: "replicate_mset m x \<subset># replicate_mset n x \<longleftrightarrow> m < n"
  by (induct n m rule: diff_induct) (auto intro: subset_mset.gr_zeroI)

lemma replicate_mset_subseteq_iff_le[simp]: "replicate_mset m x \<subseteq># replicate_mset n x \<longleftrightarrow> m \<le> n"
  by (induct n m rule: diff_induct) auto

lemma replicate_mset_lt_iff_lt[simp]: "replicate_mset m x < replicate_mset n x \<longleftrightarrow> m < n"
  by (induct n m rule: diff_induct) (auto intro: subset_mset.gr_zeroI gr_zeroI)

lemma replicate_mset_le_iff_le[simp]: "replicate_mset m x \<le> replicate_mset n x \<longleftrightarrow> m \<le> n"
  by (induct n m rule: diff_induct) auto

lemma replicate_mset_eq_iff[simp]:
  "replicate_mset m x = replicate_mset n y \<longleftrightarrow> m = n \<and> (m \<noteq> 0 \<longrightarrow> x = y)"
  by (cases m; cases n; simp)
    (metis in_replicate_mset insert_noteq_member size_replicate_mset union_single_eq_diff)

lemma replicate_mset_plus: "replicate_mset (a + b) C = replicate_mset a C + replicate_mset b C"
  by (induct a) (auto simp: ac_simps)

lemma mset_replicate_replicate_mset: "mset (replicate n L) = replicate_mset n L"
  by (induction n) auto

lemma set_mset_single_iff_replicate_mset: "set_mset U = {a} \<longleftrightarrow> (\<exists>n > 0. U = replicate_mset n a)"
  by (rule, metis count_greater_zero_iff count_replicate_mset insertI1 multi_count_eq singletonD
    zero_less_iff_neq_zero, force)

lemma ex_replicate_mset_if_all_elems_eq:
  assumes "\<forall>x \<in># M. x = y"
  shows "\<exists>n. M = replicate_mset n y"
  using assms by (metis count_replicate_mset mem_Collect_eq multiset_eqI neq0_conv set_mset_def)

subsection \<open>Multiset and Set Conversions\<close>

lemma count_mset_set_if: "count (mset_set A) a = (if a \<in> A \<and> finite A then 1 else 0)"
  by auto

lemma mset_set_set_mset_empty_mempty[iff]: "mset_set (set_mset D) = {#} \<longleftrightarrow> D = {#}"
  by (simp add: mset_set_empty_iff)

lemma count_mset_set_le_one: "count (mset_set A) x \<le> 1"
  by (simp add: count_mset_set_if)

lemma mset_set_set_mset_subseteq[simp]: "mset_set (set_mset A) \<subseteq># A"
  by (simp add: mset_set_set_mset_msubset)

lemma mset_sorted_list_of_set[simp]: "mset (sorted_list_of_set A) = mset_set A"
  by (metis mset_sorted_list_of_multiset sorted_list_of_mset_set)

lemma mset_take_subseteq: "mset (take n xs) \<subseteq># mset xs"
  apply (induct xs arbitrary: n)
   apply simp
  by (case_tac n) simp_all

lemma sorted_list_of_multiset_eq_Nil[simp]: "sorted_list_of_multiset M = [] \<longleftrightarrow> M = {#}"
  by (metis mset_sorted_list_of_multiset sorted_list_of_multiset_empty)

subsection \<open>Duplicate Removal\<close>

(* TODO: use abbreviation? *)
definition remdups_mset :: "'v multiset \<Rightarrow> 'v multiset" where
  "remdups_mset S = mset_set (set_mset S)"

lemma set_mset_remdups_mset[simp]: \<open>set_mset (remdups_mset A) = set_mset A\<close>
  unfolding remdups_mset_def by auto

lemma count_remdups_mset_eq_1: "a \<in># remdups_mset A \<longleftrightarrow> count (remdups_mset A) a = 1"
  unfolding remdups_mset_def by (auto simp: count_eq_zero_iff intro: count_inI)

lemma remdups_mset_empty[simp]: "remdups_mset {#} = {#}"
  unfolding remdups_mset_def by auto

lemma remdups_mset_singleton[simp]: "remdups_mset {#a#} = {#a#}"
  unfolding remdups_mset_def by auto

lemma remdups_mset_eq_empty[iff]: "remdups_mset D = {#} \<longleftrightarrow> D = {#}"
  unfolding remdups_mset_def by blast

lemma remdups_mset_singleton_sum[simp]:
  "remdups_mset (add_mset a A) = (if a \<in># A then remdups_mset A else add_mset a (remdups_mset A))"
  unfolding remdups_mset_def by (simp_all add: insert_absorb)

lemma mset_remdups_remdups_mset[simp]: "mset (remdups D) = remdups_mset (mset D)"
  by (induction D) (auto simp add: ac_simps)

declare mset_remdups_remdups_mset[symmetric, code]

lemma count_remdups_mset_If: \<open>count (remdups_mset A) a = (if a \<in># A then 1 else 0)\<close>
  unfolding remdups_mset_def by auto

lemma notin_add_mset_remdups_mset:
  \<open>a \<notin># A \<Longrightarrow> add_mset a (remdups_mset A) = remdups_mset (add_mset a A)\<close>
  by auto

subsection \<open>Repeat Operation\<close>

lemma repeat_mset_compower: "repeat_mset n A = (((+) A) ^^ n) {#}"
  by (induction n) auto

lemma repeat_mset_prod: "repeat_mset (m * n) A = (((+) (repeat_mset n A)) ^^ m) {#}"
  by (induction m) (auto simp: repeat_mset_distrib)

subsection \<open>Cartesian Product\<close>

text \<open>Definition of the cartesian products over multisets. The construction mimics of the cartesian
  product on sets and use the same theorem names (adding only the suffix \<open>_mset\<close> to Sigma
  and Times). See file @{file \<open>~~/src/HOL/Product_Type.thy\<close>}\<close>

definition Sigma_mset :: "'a multiset \<Rightarrow> ('a \<Rightarrow> 'b multiset) \<Rightarrow> ('a \<times> 'b) multiset" where
  "Sigma_mset A B \<equiv> \<Sum>\<^sub># {#{#(a, b). b \<in># B a#}. a \<in># A #}"

abbreviation Times_mset :: "'a multiset \<Rightarrow> 'b multiset \<Rightarrow> ('a \<times> 'b) multiset" (infixr "\<times>#" 80) where
  "Times_mset A B \<equiv> Sigma_mset A (\<lambda>_. B)"

hide_const (open) Times_mset

text \<open>Contrary to the set version @{term \<open>SIGMA x:A. B\<close>}, we use the non-ASCII symbol \<open>\<in>#\<close>.\<close>

syntax
  "_Sigma_mset" :: "[pttrn, 'a multiset, 'b multiset] => ('a * 'b) multiset"
  ("(3SIGMAMSET _\<in>#_./ _)" [0, 0, 10] 10)
translations
  "SIGMAMSET x\<in>#A. B" == "CONST Sigma_mset A (\<lambda>x. B)"

text \<open>Link between the multiset and the set cartesian product:\<close>

lemma Times_mset_Times: "set_mset (A \<times># B) = set_mset A \<times> set_mset B"
  unfolding Sigma_mset_def by auto

lemma Sigma_msetI [intro!]: "\<lbrakk>a \<in># A; b \<in># B a\<rbrakk> \<Longrightarrow> (a, b) \<in># Sigma_mset A B"
  by (unfold Sigma_mset_def) auto

lemma Sigma_msetE[elim!]: "\<lbrakk>c \<in># Sigma_mset A B; \<And>x y. \<lbrakk>x \<in># A; y \<in># B x; c = (x, y)\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (unfold Sigma_mset_def) auto

text \<open>Elimination of @{term "(a, b) \<in># A \<times># B"} -- introduces no eigenvariables.\<close>

lemma Sigma_msetD1: "(a, b) \<in># Sigma_mset A B \<Longrightarrow> a \<in># A"
  by blast

lemma Sigma_msetD2: "(a, b) \<in># Sigma_mset A B \<Longrightarrow> b \<in># B a"
  by blast

lemma Sigma_msetE2: "\<lbrakk>(a, b) \<in># Sigma_mset A B; \<lbrakk>a \<in># A; b \<in># B a\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by blast

lemma Sigma_mset_cong:
  "\<lbrakk>A = B; \<And>x. x \<in># B \<Longrightarrow> C x = D x\<rbrakk> \<Longrightarrow> (SIGMAMSET x \<in># A. C x) = (SIGMAMSET x \<in># B. D x)"
  by (metis (mono_tags, lifting) Sigma_mset_def image_mset_cong)

lemma count_sum_mset: "count (\<Sum>\<^sub># M) b = (\<Sum>P \<in># M. count P b)"
  by (induction M) auto

lemma Sigma_mset_plus_distrib1[simp]: "Sigma_mset (A + B) C = Sigma_mset A C + Sigma_mset B C"
  unfolding Sigma_mset_def by auto

lemma Sigma_mset_plus_distrib2[simp]:
  "Sigma_mset A (\<lambda>i. B i + C i) = Sigma_mset A B + Sigma_mset A C"
  unfolding Sigma_mset_def by (induction A) (auto simp: multiset_eq_iff)

lemma Times_mset_single_left: "{#a#} \<times># B = image_mset (Pair a) B"
  unfolding Sigma_mset_def by auto

lemma Times_mset_single_right: "A \<times># {#b#} = image_mset (\<lambda>a. Pair a b) A"
  unfolding Sigma_mset_def by (induction A) auto

lemma Times_mset_single_single[simp]: "{#a#} \<times># {#b#} = {#(a, b)#}"
  unfolding Sigma_mset_def by simp

lemma count_image_mset_Pair:
  "count (image_mset (Pair a) B) (x, b) = (if x = a then count B b else 0)"
  by (induction B) auto

lemma count_Sigma_mset: "count (Sigma_mset A B) (a, b) = count A a * count (B a) b"
  by (induction A) (auto simp: Sigma_mset_def count_image_mset_Pair)

lemma Sigma_mset_empty1[simp]: "Sigma_mset {#} B = {#}"
  unfolding Sigma_mset_def by auto

lemma Sigma_mset_empty2[simp]: "A \<times># {#} = {#}"
  by (auto simp: multiset_eq_iff count_Sigma_mset)

lemma Sigma_mset_mono:
  assumes "A \<subseteq># C" and "\<And>x. x \<in># A \<Longrightarrow> B x \<subseteq># D x"
  shows "Sigma_mset A B \<subseteq># Sigma_mset C D"
proof -
  have "count A a * count (B a) b \<le> count C a * count (D a) b" for a b
    using assms unfolding subseteq_mset_def by (metis count_inI eq_iff mult_eq_0_iff mult_le_mono)
  then show ?thesis
    by (auto simp: subseteq_mset_def count_Sigma_mset)
qed

lemma mem_Sigma_mset_iff[iff]: "((a,b) \<in># Sigma_mset A B) = (a \<in># A \<and> b \<in># B a)"
  by blast

lemma Sigma_mset_empty_iff: "(SIGMAMSET i\<in>#I. X i) = {#} \<longleftrightarrow> (\<forall>i\<in>#I. X i = {#})"
  by (auto simp: Sigma_mset_def)

lemma Times_mset_subset_mset_cancel1: "x \<in># A \<Longrightarrow> (A \<times># B \<subseteq># A \<times># C) = (B \<subseteq># C)"
  by (auto simp: subseteq_mset_def count_Sigma_mset)

lemma Times_mset_subset_mset_cancel2: "x \<in># C \<Longrightarrow> (A \<times># C \<subseteq># B \<times># C) = (A \<subseteq># B)"
  by (auto simp: subseteq_mset_def count_Sigma_mset)

lemma Times_mset_eq_cancel2: "x \<in># C \<Longrightarrow> (A \<times># C = B \<times># C) = (A = B)"
  by (auto simp: multiset_eq_iff count_Sigma_mset dest!: in_countE)

lemma split_paired_Ball_mset_Sigma_mset[simp]:
  "(\<forall>z\<in>#Sigma_mset A B. P z) \<longleftrightarrow> (\<forall>x\<in>#A. \<forall>y\<in>#B x. P (x, y))"
  by blast

lemma split_paired_Bex_mset_Sigma_mset[simp]:
  "(\<exists>z\<in>#Sigma_mset A B. P z) \<longleftrightarrow> (\<exists>x\<in>#A. \<exists>y\<in>#B x. P (x, y))"
  by blast

lemma sum_mset_if_eq_constant:
  "(\<Sum>x\<in>#M. if a = x then (f x) else 0) = (((+) (f a)) ^^ (count M a)) 0"
  by (induction M) (auto simp: ac_simps)

lemma iterate_op_plus: "(((+) k) ^^ m) 0 = k * m"
  by (induction m) auto

lemma untion_image_mset_Pair_distribute:
  "\<Sum>\<^sub>#{#image_mset (Pair x) (C x). x \<in># J - I#} =
   \<Sum>\<^sub># {#image_mset (Pair x) (C x). x \<in># J#} - \<Sum>\<^sub>#{#image_mset (Pair x) (C x). x \<in># I#}"
  by (auto simp: multiset_eq_iff count_sum_mset count_image_mset_Pair sum_mset_if_eq_constant
    iterate_op_plus diff_mult_distrib2)

lemma Sigma_mset_Un_distrib1: "Sigma_mset (I \<union># J) C = Sigma_mset I C \<union># Sigma_mset J C"
  by (auto simp add: Sigma_mset_def union_mset_def untion_image_mset_Pair_distribute)

lemma Sigma_mset_Un_distrib2: "(SIGMAMSET i\<in>#I. A i \<union># B i) = Sigma_mset I A \<union># Sigma_mset I B"
  by (auto simp: multiset_eq_iff count_sum_mset count_image_mset_Pair sum_mset_if_eq_constant
    Sigma_mset_def diff_mult_distrib2 iterate_op_plus max_def not_in_iff)

lemma Sigma_mset_Int_distrib1: "Sigma_mset (I \<inter># J) C = Sigma_mset I C \<inter># Sigma_mset J C"
  by (auto simp: multiset_eq_iff count_sum_mset count_image_mset_Pair sum_mset_if_eq_constant
    Sigma_mset_def iterate_op_plus min_def not_in_iff)

lemma Sigma_mset_Int_distrib2: "(SIGMAMSET i\<in>#I. A i \<inter># B i) = Sigma_mset I A \<inter># Sigma_mset I B"
  by (auto simp: multiset_eq_iff count_sum_mset count_image_mset_Pair sum_mset_if_eq_constant
    Sigma_mset_def iterate_op_plus min_def not_in_iff)

lemma Sigma_mset_Diff_distrib1: "Sigma_mset (I - J) C = Sigma_mset I C - Sigma_mset J C"
  by (auto simp: multiset_eq_iff count_sum_mset count_image_mset_Pair sum_mset_if_eq_constant
    Sigma_mset_def iterate_op_plus min_def not_in_iff diff_mult_distrib2)

lemma Sigma_mset_Diff_distrib2: "(SIGMAMSET i\<in>#I. A i - B i) = Sigma_mset I A - Sigma_mset I B"
  by (auto simp: multiset_eq_iff count_sum_mset count_image_mset_Pair sum_mset_if_eq_constant
    Sigma_mset_def iterate_op_plus min_def not_in_iff diff_mult_distrib)

lemma Sigma_mset_Union: "Sigma_mset (\<Sum>\<^sub>#X) B = (\<Sum>\<^sub># (image_mset (\<lambda>A. Sigma_mset A B) X))"
  by (auto simp: multiset_eq_iff count_sum_mset count_image_mset_Pair sum_mset_if_eq_constant
    Sigma_mset_def iterate_op_plus min_def not_in_iff sum_mset_distrib_left)

lemma Times_mset_Un_distrib1: "(A \<union># B) \<times># C = A \<times># C \<union># B \<times># C"
  by (fact Sigma_mset_Un_distrib1)

lemma Times_mset_Int_distrib1: "(A \<inter># B) \<times># C = A \<times># C \<inter># B \<times># C"
  by (fact Sigma_mset_Int_distrib1)

lemma Times_mset_Diff_distrib1: "(A - B) \<times># C = A \<times># C - B \<times># C"
  by (fact Sigma_mset_Diff_distrib1)

lemma Times_mset_empty[simp]: "A \<times># B = {#} \<longleftrightarrow> A = {#} \<or> B = {#}"
  by (auto simp: Sigma_mset_empty_iff)

lemma Times_insert_left: "A \<times># add_mset x B = A \<times># B + image_mset (\<lambda>a. Pair a x) A"
  unfolding add_mset_add_single[of x B] Sigma_mset_plus_distrib2
  by (simp add: Times_mset_single_right)

lemma Times_insert_right: "add_mset a A \<times># B = A \<times># B + image_mset (Pair a) B"
  unfolding add_mset_add_single[of a A] Sigma_mset_plus_distrib1
  by (simp add: Times_mset_single_left)

lemma fst_image_mset_times_mset [simp]:
  "image_mset fst (A \<times># B) = (if B = {#} then {#} else repeat_mset (size B) A)"
  by (induct B) (auto simp: Times_mset_single_right ac_simps Times_insert_left)

lemma snd_image_mset_times_mset [simp]:
  "image_mset snd (A \<times># B) = (if A = {#} then {#} else repeat_mset (size A) B)"
  by (induct B) (auto simp add: Times_mset_single_right Times_insert_left image_mset_const_eq)

lemma product_swap_mset: "image_mset prod.swap (A \<times># B) = B \<times># A"
  by (induction A) (auto simp add: Times_mset_single_left Times_mset_single_right
      Times_insert_right Times_insert_left)

context
begin

qualified definition product_mset :: "'a multiset \<Rightarrow> 'b multiset \<Rightarrow> ('a \<times> 'b) multiset" where
  [code_abbrev]: "product_mset A B = A \<times># B"

lemma member_product_mset: "x \<in># product_mset A B \<longleftrightarrow> x \<in># A \<times># B"
  by (simp add: Multiset_More.product_mset_def)

end

lemma count_Sigma_mset_abs_def: "count (Sigma_mset A B) = (\<lambda>(a, b) \<Rightarrow> count A a * count (B a) b)"
  by (auto simp: fun_eq_iff count_Sigma_mset)

lemma Times_mset_image_mset1: "image_mset f A \<times># B = image_mset (\<lambda>(a, b). (f a, b)) (A \<times># B)"
  by (induct B) (auto simp: Times_insert_left)

lemma Times_mset_image_mset2: "A \<times># image_mset f B = image_mset (\<lambda>(a, b). (a, f b)) (A \<times># B)"
  by (induct A) (auto simp: Times_insert_right)

lemma sum_le_singleton: "A \<subseteq> {x} \<Longrightarrow> sum f A = (if x \<in> A then f x else 0)"
  by (auto simp: subset_singleton_iff elim: finite_subset)

lemma Times_mset_assoc: "(A \<times># B) \<times># C = image_mset (\<lambda>(a, b, c). ((a, b), c)) (A \<times># B \<times># C)"
  by (auto simp: multiset_eq_iff count_Sigma_mset count_image_mset vimage_def Times_mset_Times
      Int_commute count_eq_zero_iff intro!: trans[OF _ sym[OF sum_le_singleton[of _ "(_, _, _)"]]]
      cong: sum.cong if_cong)

subsection \<open>Transfer Rules\<close>

lemma plus_multiset_transfer[transfer_rule]:
  "(rel_fun (rel_mset R) (rel_fun (rel_mset R) (rel_mset R))) (+) (+)"
  by (unfold rel_fun_def rel_mset_def)
    (force dest: list_all2_appendI intro: exI[of _ "_ @ _"] conjI[rotated])

lemma minus_multiset_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique R"
  shows "(rel_fun (rel_mset R) (rel_fun (rel_mset R) (rel_mset R))) (-) (-)"
proof (unfold rel_fun_def rel_mset_def, safe)
  fix xs ys xs' ys'
  assume [transfer_rule]: "list_all2 R xs ys" "list_all2 R xs' ys'"
  have "list_all2 R (fold remove1 xs' xs) (fold remove1 ys' ys)"
    by transfer_prover
  moreover have "mset (fold remove1 xs' xs) = mset xs - mset xs'"
    by (induct xs' arbitrary: xs) auto
  moreover have "mset (fold remove1 ys' ys) = mset ys - mset ys'"
    by (induct ys' arbitrary: ys) auto
  ultimately show "\<exists>xs'' ys''.
    mset xs'' = mset xs - mset xs' \<and> mset ys'' = mset ys - mset ys' \<and> list_all2 R xs'' ys''"
    by blast
qed

declare rel_mset_Zero[transfer_rule]

lemma count_transfer[transfer_rule]:
  assumes "bi_unique R"
  shows "(rel_fun (rel_mset R) (rel_fun R (=))) count count"
unfolding rel_fun_def rel_mset_def proof safe
  fix x y xs ys
  assume "list_all2 R xs ys" "R x y"
  then show "count (mset xs) x = count (mset ys) y"
  proof (induct xs ys rule: list.rel_induct)
    case (Cons x' xs y' ys)
    then show ?case
      using assms unfolding bi_unique_alt_def2 by (auto simp: rel_fun_def)
  qed simp
qed

lemma subseteq_multiset_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique R" "right_total R"
  shows "(rel_fun (rel_mset R) (rel_fun (rel_mset R) (=)))
    (\<lambda>M N. filter_mset (Domainp R) M \<subseteq># filter_mset (Domainp R) N) (\<subseteq>#)"
proof -
  have count_filter_mset_less:
    "(\<forall>a. count (filter_mset (Domainp R) M) a \<le> count (filter_mset (Domainp R) N) a) \<longleftrightarrow>
     (\<forall>a \<in> {x. Domainp R x}. count M a \<le> count N a)" for M and N by auto
  show ?thesis unfolding subseteq_mset_def count_filter_mset_less
    by transfer_prover
qed

lemma sum_mset_transfer[transfer_rule]:
  "R 0 0 \<Longrightarrow> rel_fun R (rel_fun R R) (+) (+) \<Longrightarrow> (rel_fun (rel_mset R) R) sum_mset sum_mset"
  using sum_list_transfer[of R] unfolding rel_fun_def rel_mset_def by auto

lemma Sigma_mset_transfer[transfer_rule]:
  "(rel_fun (rel_mset R) (rel_fun (rel_fun R (rel_mset S)) (rel_mset (rel_prod R S))))
     Sigma_mset Sigma_mset"
  by (unfold Sigma_mset_def) transfer_prover

subsection \<open>Even More about Multisets\<close>

subsubsection \<open>Multisets and Functions\<close>

lemma range_image_mset:
  assumes "set_mset Ds \<subseteq> range f"
  shows "Ds \<in> range (image_mset f)"
proof -
  have "\<forall>D. D \<in># Ds \<longrightarrow> (\<exists>C. f C = D)"
    using assms by blast
  then obtain f_i where
    f_p: "\<forall>D. D \<in># Ds \<longrightarrow> (f (f_i D) = D)"
    by metis
  define Cs where
    "Cs \<equiv> image_mset f_i Ds"
  from f_p Cs_def have "image_mset f Cs = Ds"
    by auto
  then show ?thesis
    by blast
qed

subsubsection \<open>Multisets and Lists\<close>

lemma length_sorted_list_of_multiset[simp]: "length (sorted_list_of_multiset A) = size A"
  by (metis mset_sorted_list_of_multiset size_mset)

definition list_of_mset :: "'a multiset \<Rightarrow> 'a list" where
  "list_of_mset m = (SOME l. m = mset l)"

lemma mset_list_of_mset[simp]: "mset (list_of_mset m) = m"
  by (metis (mono_tags, lifting) ex_mset list_of_mset_def someI_ex)

lemma length_list_of_mset[simp]: "length (list_of_mset A) = size A"
  unfolding list_of_mset_def by (metis (mono_tags) ex_mset size_mset someI_ex)

lemma range_mset_map:
  assumes "set_mset Ds \<subseteq> range f"
  shows "Ds \<in> range (\<lambda>Cl. mset (map f Cl))"
proof -
  have "Ds \<in> range (image_mset f)"
    by (simp add: assms range_image_mset)
  then obtain Cs where Cs_p: "image_mset f Cs = Ds"
    by auto
  define Cl where "Cl = list_of_mset Cs"
  then have "mset Cl = Cs"
    by auto
  then have "image_mset f (mset Cl) = Ds"
    using Cs_p by auto
  then have "mset (map f Cl) = Ds"
    by auto
  then show ?thesis
    by auto
qed

lemma list_of_mset_empty[iff]: "list_of_mset m = [] \<longleftrightarrow> m = {#}"
  by (metis (mono_tags, lifting) ex_mset list_of_mset_def mset_zero_iff_right someI_ex)

lemma in_mset_conv_nth: "(x \<in># mset xs) = (\<exists>i<length xs. xs ! i = x)"
  by (auto simp: in_set_conv_nth)

lemma in_mset_sum_list:
  assumes "L \<in># LL"
  assumes "LL \<in> set Ci"
  shows "L \<in># sum_list Ci"
  using assms by (induction Ci) auto

lemma in_mset_sum_list2:
  assumes "L \<in># sum_list Ci"
  obtains LL where
    "LL \<in> set Ci"
    "L \<in># LL"
  using assms by (induction Ci) auto

(* TODO: Make [simp]. *)
lemma in_mset_sum_list_iff: "a \<in># sum_list \<A> \<longleftrightarrow> (\<exists>A \<in> set \<A>. a \<in># A)"
  by (metis in_mset_sum_list in_mset_sum_list2)

lemma subseteq_list_Union_mset:
  assumes "length Ci = n"
  assumes "length CAi = n"
  assumes "\<forall>i<n.  Ci ! i \<subseteq># CAi ! i "
  shows "\<Sum>\<^sub># (mset Ci) \<subseteq># \<Sum>\<^sub># (mset CAi)"
  using assms proof (induction n arbitrary: Ci CAi)
  case 0
  then show ?case by auto
next
  case (Suc n)
  from Suc have "\<forall>i<n. tl Ci ! i \<subseteq># tl CAi ! i"
    by (simp add: nth_tl)
  hence "\<Sum>\<^sub>#(mset (tl Ci)) \<subseteq># \<Sum>\<^sub>#(mset (tl CAi))" using Suc by auto
  moreover
  have "hd Ci \<subseteq># hd CAi" using Suc
    by (metis hd_conv_nth length_greater_0_conv zero_less_Suc)
  ultimately
  show "\<Sum>\<^sub>#(mset Ci) \<subseteq># \<Sum>\<^sub>#(mset CAi)"
    using Suc by (cases Ci; cases CAi) (auto intro: subset_mset.add_mono)
qed

lemma same_mset_distinct_iff:
  \<open>mset M = mset M' \<Longrightarrow> distinct M \<longleftrightarrow> distinct M'\<close>
  by (fact mset_eq_imp_distinct_iff)

subsubsection \<open>More on Multisets and Functions\<close>

lemma subseteq_mset_size_eql: "X \<subseteq># Y \<Longrightarrow> size Y = size X \<Longrightarrow> X = Y"
  using mset_subset_size subset_mset_def by fastforce

lemma image_mset_of_subset_list:
  assumes "image_mset \<eta> C' = mset lC"
  shows "\<exists>qC'. map \<eta> qC' = lC \<and> mset qC' = C'"
  using assms apply (induction lC arbitrary: C')
  subgoal by simp
  subgoal by (fastforce dest!: msed_map_invR intro: exI[of _ \<open>_ # _\<close>])
  done

lemma image_mset_of_subset:
  assumes "A \<subseteq># image_mset \<eta> C'"
  shows "\<exists>A'. image_mset \<eta> A' = A \<and> A' \<subseteq># C'"
proof -
  define C where "C = image_mset \<eta> C'"

  define lA where "lA = list_of_mset A"
  define lD where "lD = list_of_mset (C-A)"
  define lC where "lC = lA @ lD"

  have "mset lC = C"
    using C_def assms unfolding lD_def lC_def lA_def by auto
  then have "\<exists>qC'. map \<eta> qC' = lC \<and> mset qC' = C'"
    using assms image_mset_of_subset_list unfolding C_def by metis
  then obtain qC' where qC'_p: "map \<eta> qC' = lC \<and> mset qC' = C'"
    by auto
  let ?lA' = "take (length lA) qC'"
  have m: "map \<eta> ?lA' = lA"
    using qC'_p lC_def
    by (metis append_eq_conv_conj take_map)
  let ?A' = "mset ?lA'"

  have "image_mset \<eta> ?A' = A"
    using m using lA_def
    by (metis (full_types) ex_mset list_of_mset_def mset_map someI_ex)
  moreover have "?A' \<subseteq># C'"
    using qC'_p unfolding lA_def
    using mset_take_subseteq by blast
  ultimately show ?thesis by blast
qed

lemma Melem_subseteq_Union_mset[simp]:
  assumes "x \<in># T"
  shows "x \<subseteq># \<Sum>\<^sub>#T"
  using assms sum_mset.remove by force

lemma Melem_subset_eq_sum_list[simp]:
  assumes "x \<in># mset T"
  shows "x \<subseteq># sum_list T"
  using assms by (metis mset_subset_eq_add_left sum_mset.remove sum_mset_sum_list)

lemma less_subset_eq_Union_mset[simp]:
  assumes "i < length CAi"
  shows "CAi ! i \<subseteq># \<Sum>\<^sub>#(mset CAi)"
proof -
  from assms have "CAi ! i \<in># mset CAi"
    by auto
  then show ?thesis
    by auto
qed

lemma less_subset_eq_sum_list[simp]:
  assumes "i < length CAi"
  shows "CAi ! i \<subseteq># sum_list CAi"
proof -
  from assms have "CAi ! i \<in># mset CAi"
    by auto
  then show ?thesis
    by auto
qed

subsubsection \<open>More on Multiset Order\<close>

lemma less_multiset_doubletons:
  assumes
    "y < t \<or> y < s"
    "x < t \<or> x < s"
  shows
    "{#y, x#} < {#t, s#}"
  unfolding less_multiset\<^sub>D\<^sub>M
proof (intro exI)
  let ?X = "{#t, s#}"
  let ?Y = "{#y, x#}"
  show "?X \<noteq> {#} \<and> ?X \<subseteq># {#t, s#} \<and> {#y, x#} = {#t, s#} - ?X + ?Y
    \<and> (\<forall>k. k \<in># ?Y \<longrightarrow> (\<exists>a. a \<in># ?X \<and> k < a))"
    using add_eq_conv_diff assms by auto
qed

end


(* Author: Tobias Nipkow *)

section \<open>Creating Balanced Trees\<close>

theory Balance
imports
  Complex_Main
  "~~/src/HOL/Library/Tree"
begin

(* mv *)

text \<open>The lemmas about \<open>floor\<close> and \<open>ceiling\<close> of \<open>log 2\<close> should be generalized
from 2 to \<open>n\<close> and should be made executable. In the end they should be moved
to theory \<open>Log_Nat\<close> and \<open>floorlog\<close> should be replaced.\<close>

lemma floor_log_nat_ivl: fixes b n k :: nat
assumes "b \<ge> 2" "b^n \<le> k" "k < b^(n+1)"
shows "floor (log b (real k)) = int(n)"
proof -
  have "k \<ge> 1"
    using assms(1,2) one_le_power[of b n] by linarith
  show ?thesis
  proof(rule floor_eq2)
    show "int n \<le> log b k"
      using assms(1,2) \<open>k \<ge> 1\<close>
      by(simp add: powr_realpow le_log_iff of_nat_power[symmetric] del: of_nat_power)
  next
    have "real k < b powr (real(n + 1))" using assms(1,3)
      by (simp only: powr_realpow) (metis of_nat_less_iff of_nat_power)
    thus "log b k < real_of_int (int n) + 1"
      using assms(1) \<open>k \<ge> 1\<close> by(simp add: log_less_iff add_ac)
  qed
qed

lemma ceil_log_nat_ivl: fixes b n k :: nat
assumes "b \<ge> 2" "b^n < k" "k \<le> b^(n+1)"
shows "ceiling (log b (real k)) = int(n)+1"
proof(rule ceiling_eq)
  show "int n < log b k"
    using assms(1,2)
    by(simp add: powr_realpow less_log_iff of_nat_power[symmetric] del: of_nat_power)
next
  have "real k \<le> b powr (real(n + 1))"
    using assms(1,3)
    by (simp only: powr_realpow) (metis of_nat_le_iff of_nat_power)
  thus "log b k \<le> real_of_int (int n) + 1"
    using assms(1,2) by(simp add: log_le_iff add_ac)
qed

lemma ceil_log2_div2: assumes "n \<ge> 2"
shows "ceiling(log 2 (real n)) = ceiling(log 2 ((n-1) div 2 + 1)) + 1"
proof cases
  assume "n=2"
  thus ?thesis by simp
next
  let ?m = "(n-1) div 2 + 1"
  assume "n\<noteq>2"
  hence "2 \<le> ?m"
    using assms by arith
  then obtain i where i: "2 ^ i < ?m" "?m \<le> 2 ^ (i + 1)"
    using ex_power_ivl2[of 2 ?m] by auto
  have "n \<le> 2*?m"
    by arith
  also have "2*?m \<le> 2 ^ ((i+1)+1)"
    using i(2) by simp
  finally have *: "n \<le> \<dots>" .
  have "2^(i+1) < n"
    using i(1) by (auto simp add: less_Suc_eq_0_disj)
  from ceil_log_nat_ivl[OF _ this *] ceil_log_nat_ivl[OF _ i]
  show ?thesis by simp
qed

lemma floor_log2_div2: fixes n :: nat assumes "n \<ge> 2"
shows "floor(log 2 n) = floor(log 2 (n div 2)) + 1"
proof cases
  assume "n=2"
  thus ?thesis by simp
next
  let ?m = "n div 2"
  assume "n\<noteq>2"
  hence "1 \<le> ?m"
    using assms by arith
  then obtain i where i: "2 ^ i \<le> ?m" "?m < 2 ^ (i + 1)"
    using ex_power_ivl1[of 2 ?m] by auto
  have "2^(i+1) \<le> 2*?m"
    using i(1) by simp
  also have "2*?m \<le> n"
    by arith
  finally have *: "2^(i+1) \<le> \<dots>" .
  have "n < 2^(i+1+1)"
    using i(2) by simp
  from floor_log_nat_ivl[OF _ * this] floor_log_nat_ivl[OF _ i]
  show ?thesis by simp
qed

(* end of mv *)

fun bal :: "'a list \<Rightarrow> nat \<Rightarrow> 'a tree * 'a list" where
"bal xs n = (if n=0 then (Leaf,xs) else
 (let m = n div 2;
      (l, ys) = bal xs m;
      (r, zs) = bal (tl ys) (n-1-m)
  in (Node l (hd ys) r, zs)))"

declare bal.simps[simp del]

definition balance_list :: "'a list \<Rightarrow> 'a tree" where
"balance_list xs = fst (bal xs (length xs))"

definition balance_tree :: "'a tree \<Rightarrow> 'a tree" where
"balance_tree = balance_list o inorder"

lemma bal_simps:
  "bal xs 0 = (Leaf, xs)"
  "n > 0 \<Longrightarrow>
   bal xs n =
  (let m = n div 2;
      (l, ys) = bal xs m;
      (r, zs) = bal (tl ys) (n-1-m)
  in (Node l (hd ys) r, zs))"
by(simp_all add: bal.simps)

text\<open>The following lemmas take advantage of the fact
that \<open>bal xs n\<close> yields a result even if \<open>n > length xs\<close>.\<close>

lemma size_bal: "bal xs n = (t,ys) \<Longrightarrow> size t = n"
proof(induction xs n arbitrary: t ys rule: bal.induct)
  case (1 xs n)
  thus ?case
    by(cases "n=0")
      (auto simp add: bal_simps Let_def split: prod.splits)
qed

lemma bal_inorder:
  "\<lbrakk> bal xs n = (t,ys); n \<le> length xs \<rbrakk>
  \<Longrightarrow> inorder t = take n xs \<and> ys = drop n xs"
proof(induction xs n arbitrary: t ys rule: bal.induct)
  case (1 xs n) show ?case
  proof cases
    assume "n = 0" thus ?thesis using 1 by (simp add: bal_simps)
  next
    assume [arith]: "n \<noteq> 0"
    let ?n1 = "n div 2" let ?n2 = "n - 1 - ?n1"
    from "1.prems" obtain l r xs' where
      b1: "bal xs ?n1 = (l,xs')" and
      b2: "bal (tl xs') ?n2 = (r,ys)" and
      t: "t = \<langle>l, hd xs', r\<rangle>"
      by(auto simp: Let_def bal_simps split: prod.splits)
    have IH1: "inorder l = take ?n1 xs \<and> xs' = drop ?n1 xs"
      using b1 "1.prems" by(intro "1.IH"(1)) auto
    have IH2: "inorder r = take ?n2 (tl xs') \<and> ys = drop ?n2 (tl xs')"
      using b1 b2 IH1 "1.prems" by(intro "1.IH"(2)) auto
    have "drop (n div 2) xs \<noteq> []" using "1.prems"(2) by simp
    hence "hd (drop ?n1 xs) # take ?n2 (tl (drop ?n1 xs)) = take (?n2 + 1) (drop ?n1 xs)"
      by (metis Suc_eq_plus1 take_Suc)
    hence *: "inorder t = take n xs" using t IH1 IH2
      using take_add[of ?n1 "?n2+1" xs] by(simp)
    have "n - n div 2 + n div 2 = n" by simp
    hence "ys = drop n xs" using IH1 IH2 by (simp add: drop_Suc[symmetric])
    thus ?thesis using * by blast
  qed
qed

corollary inorder_balance_list: "inorder(balance_list xs) = xs"
using bal_inorder[of xs "length xs"]
by (metis balance_list_def order_refl prod.collapse take_all)

corollary inorder_balance_tree[simp]: "inorder(balance_tree t) = inorder t"
by(simp add: balance_tree_def inorder_balance_list)

corollary size_balance_list[simp]: "size(balance_list xs) = length xs"
by (metis inorder_balance_list length_inorder)

corollary size_balance_tree[simp]: "size(balance_tree t) = size t"
by(simp add: balance_tree_def inorder_balance_list)

lemma min_height_bal:
  "bal xs n = (t,ys) \<Longrightarrow> min_height t = nat(floor(log 2 (n + 1)))"
proof(induction xs n arbitrary: t ys rule: bal.induct)
  case (1 xs n) show ?case
  proof cases
    assume "n = 0" thus ?thesis
      using "1.prems" by (simp add: bal_simps)
  next
    assume [arith]: "n \<noteq> 0"
    from "1.prems" obtain l r xs' where
      b1: "bal xs (n div 2) = (l,xs')" and
      b2: "bal (tl xs') (n - 1 - n div 2) = (r,ys)" and
      t: "t = \<langle>l, hd xs', r\<rangle>"
      by(auto simp: bal_simps Let_def split: prod.splits)
    let ?log1 = "nat (floor(log 2 (n div 2 + 1)))"
    let ?log2 = "nat (floor(log 2 (n - 1 - n div 2 + 1)))"
    have IH1: "min_height l = ?log1" using "1.IH"(1) b1 by simp
    have IH2: "min_height r = ?log2" using "1.IH"(2) b1 b2 by simp
    have "(n+1) div 2 \<ge> 1" by arith
    hence 0: "log 2 ((n+1) div 2) \<ge> 0" by simp
    have "n - 1 - n div 2 + 1 \<le> n div 2 + 1" by arith
    hence le: "?log2 \<le> ?log1"
      by(simp add: nat_mono floor_mono)
    have "min_height t = min ?log1 ?log2 + 1" by (simp add: t IH1 IH2)
    also have "\<dots> = ?log2 + 1" using le by (simp add: min_absorb2)
    also have "n - 1 - n div 2 + 1 = (n+1) div 2" by linarith
    also have "nat (floor(log 2 ((n+1) div 2))) + 1
       = nat (floor(log 2 ((n+1) div 2) + 1))"
      using 0 by linarith
    also have "\<dots> = nat (floor(log 2 (n + 1)))"
      using floor_log2_div2[of "n+1"] by (simp add: log_mult)
    finally show ?thesis .
  qed
qed

lemma height_bal:
  "bal xs n = (t,ys) \<Longrightarrow> height t = nat \<lceil>log 2 (n + 1)\<rceil>"
proof(induction xs n arbitrary: t ys rule: bal.induct)
  case (1 xs n) show ?case
  proof cases
    assume "n = 0" thus ?thesis
      using "1.prems" by (simp add: bal_simps)
  next
    assume [arith]: "n \<noteq> 0"
    from "1.prems" obtain l r xs' where
      b1: "bal xs (n div 2) = (l,xs')" and
      b2: "bal (tl xs') (n - 1 - n div 2) = (r,ys)" and
      t: "t = \<langle>l, hd xs', r\<rangle>"
      by(auto simp: bal_simps Let_def split: prod.splits)
    let ?log1 = "nat \<lceil>log 2 (n div 2 + 1)\<rceil>"
    let ?log2 = "nat \<lceil>log 2 (n - 1 - n div 2 + 1)\<rceil>"
    have IH1: "height l = ?log1" using "1.IH"(1) b1 by simp
    have IH2: "height r = ?log2" using "1.IH"(2) b1 b2 by simp
    have 0: "log 2 (n div 2 + 1) \<ge> 0" by auto
    have "n - 1 - n div 2 + 1 \<le> n div 2 + 1" by arith
    hence le: "?log2 \<le> ?log1"
      by(simp add: nat_mono ceiling_mono del: nat_ceiling_le_eq)
    have "height t = max ?log1 ?log2 + 1" by (simp add: t IH1 IH2)
    also have "\<dots> = ?log1 + 1" using le by (simp add: max_absorb1)
    also have "\<dots> = nat \<lceil>log 2 (n div 2 + 1) + 1\<rceil>" using 0 by linarith
    also have "\<dots> = nat \<lceil>log 2 (n + 1)\<rceil>"
      using ceil_log2_div2[of "n+1"] by (simp)
    finally show ?thesis .
  qed
qed

lemma balanced_bal:
  assumes "bal xs n = (t,ys)" shows "balanced t"
unfolding balanced_def
using height_bal[OF assms] min_height_bal[OF assms]
by linarith

lemma height_balance_list:
  "height (balance_list xs) = nat \<lceil>log 2 (length xs + 1)\<rceil>"
by (metis balance_list_def height_bal prod.collapse)

corollary height_balance_tree:
  "height (balance_tree t) = nat(ceiling(log 2 (size t + 1)))"
by(simp add: balance_tree_def height_balance_list)

corollary balanced_balance_list[simp]: "balanced (balance_list xs)"
by (metis balance_list_def balanced_bal prod.collapse)

corollary balanced_balance_tree[simp]: "balanced (balance_tree t)"
by (simp add: balance_tree_def)

lemma wbalanced_bal: "bal xs n = (t,ys) \<Longrightarrow> wbalanced t"
proof(induction xs n arbitrary: t ys rule: bal.induct)
  case (1 xs n)
  show ?case
  proof cases
    assume "n = 0"
    thus ?thesis
      using "1.prems" by(simp add: bal_simps)
  next
    assume "n \<noteq> 0"
    with "1.prems" obtain l ys r zs where
      rec1: "bal xs (n div 2) = (l, ys)" and
      rec2: "bal (tl ys) (n - 1 - n div 2) = (r, zs)" and
      t: "t = \<langle>l, hd ys, r\<rangle>"
      by(auto simp add: bal_simps Let_def split: prod.splits)
    have l: "wbalanced l" using "1.IH"(1)[OF \<open>n\<noteq>0\<close> refl rec1] .
    have "wbalanced r" using "1.IH"(2)[OF \<open>n\<noteq>0\<close> refl rec1[symmetric] refl rec2] .
    with l t size_bal[OF rec1] size_bal[OF rec2]
    show ?thesis by auto
  qed
qed

lemma wbalanced_balance_tree: "wbalanced (balance_tree t)"
by(simp add: balance_tree_def balance_list_def)
  (metis prod.collapse wbalanced_bal)

hide_const (open) bal

end


(*  Author: Lukas Bulwahn <lukas.bulwahn-at-gmail.com> *)

section \<open>Cardinality of Number Partitions\<close>

theory Card_Number_Partitions
imports Number_Partition
begin

subsection \<open>The Partition Function\<close>

fun Partition :: "nat \<Rightarrow> nat \<Rightarrow> nat"
where
  "Partition 0 0 = 1"
| "Partition 0 (Suc k) = 0"
| "Partition (Suc m) 0 = 0"
| "Partition (Suc m) (Suc k) = Partition m k + Partition (m - k) (Suc k)"

lemma Partition_less:
  assumes "m < k"
  shows "Partition m k = 0"
using assms by (induct m k rule: Partition.induct) auto

lemma Partition_sum_Partition_diff:
  assumes "k \<le> m"
  shows "Partition m k = (\<Sum>i\<le>k. Partition (m - k) i)"
using assms by (induct m k rule: Partition.induct) auto

lemma Partition_parts1:
  "Partition (Suc m) (Suc 0) = 1"
by (induct m) auto

lemma Partition_diag:
  "Partition (Suc m) (Suc m) = 1"
by (induct m) auto

lemma Partition_diag1:
  "Partition (Suc (Suc m)) (Suc m) = 1"
by (induct m) auto

lemma Partition_parts2:
  shows "Partition m 2 = m div 2"
proof (induct m rule: nat_less_induct)
  fix m
  assume hypothesis: "\<forall>n<m. Partition n 2 = n div 2"
  have "(m = 0 \<or> m = 1) \<or> m \<ge> 2" by auto
  from this show "Partition m 2 = m div 2"
  proof
    assume "m = 0 \<or> m = 1"
    from this show ?thesis by (auto simp add: numerals(2))
  next
    assume "2 \<le> m"
    from this obtain m' where m': "m = Suc (Suc m')" by (metis add_2_eq_Suc le_Suc_ex)
    from hypothesis this have "Partition m' 2 = m' div 2" by simp
    from this m' show ?thesis
      using Partition_parts1 Partition.simps(4)[of "Suc m'" "Suc 0"] div2_Suc_Suc
      by (simp add: numerals(2) del: Partition.simps)
  qed
qed

subsection \<open>Cardinality of Number Partitions\<close>

lemma set_rewrite1:
  "{p. p partitions Suc m \<and> sum p {..Suc m} = Suc k \<and> p 1 \<noteq> 0}
    = (\<lambda>p. p(1 := p 1 + 1)) ` {p. p partitions m \<and> sum p {..m} = k}" (is "?S = ?T")
proof
  {
    fix p
    assume assms: "p partitions Suc m" "sum p {..Suc m} = Suc k" "0 < p 1"
    have "p(1 := p 1 - 1) partitions m"
      using assms by (metis partitions_remove1 diff_Suc_1)
    moreover have "(\<Sum>i\<le>m. (p(1 := p 1 - 1)) i) = k"
      using assms by (metis count_remove1 diff_Suc_1)
    ultimately have "p(1 := p 1 - 1) \<in> {p. p partitions m \<and> sum p {..m} = k}" by simp
    moreover have "p = p(1 := p 1 - 1, 1 := (p(1 := p 1 - 1)) 1 + 1)"
      using \<open>0 < p 1\<close> by auto
    ultimately have "p \<in> (\<lambda>p. p(1 := p 1 + 1)) ` {p. p partitions m \<and> sum p {..m} = k}" by blast
  }
  from this show "?S \<subseteq> ?T" by blast
next
  {
    fix p
    assume assms: "p partitions m" "sum p {..m} = k"
    have "(p(1 := p 1 + 1)) partitions Suc m" (is ?g1)
      using assms by (metis partitions_insert1 Suc_eq_plus1 zero_less_one)
    moreover have "sum (p(1 := p 1 + 1)) {..Suc m} = Suc k" (is ?g2)
      using assms by (metis count_insert1 Suc_eq_plus1)
    moreover have "(p(1 := p 1 + 1)) 1 \<noteq> 0" (is ?g3) by auto
    ultimately have "?g1 \<and> ?g2 \<and> ?g3" by simp
  }
  from this show "?T \<subseteq> ?S" by auto
qed

lemma set_rewrite2:
  "{p. p partitions m \<and> sum p {..m} = k \<and> p 1 = 0}
    = (\<lambda>p. (\<lambda>i. p (i - 1))) ` {p. p partitions (m - k) \<and> sum p {..m - k} = k}"
  (is "?S = ?T")
proof
  {
    fix p
    assume assms: "p partitions m" "sum p {..m} = k" "p 1 = 0"
    have "(\<lambda>i. p (i + 1)) partitions m - k"
      using assms partitions_decrease1 by blast
    moreover from assms have "sum (\<lambda>i. p (i + 1)) {..m - k} = k"
      using assms count_decrease1 by blast
    ultimately have "(\<lambda>i. p (i + 1)) \<in> {p. p partitions m - k \<and> sum p {..m - k} = k}" by simp
    moreover have "p = (\<lambda>i. p ((i - 1) + 1))"
    proof (rule ext)
      fix i show "p i = p (i - 1 + 1)"
        using assms by (cases i) (auto elim!: partitionsE)
    qed
    ultimately have "p \<in> (\<lambda>p. (\<lambda>i. p (i - 1))) ` {p. p partitions m - k \<and> sum p {..m - k} = k}" by auto
  }
  from this show "?S \<subseteq> ?T" by auto
next
   {
     fix p
     assume assms: "p partitions m - k" "sum p {..m - k} = k"
     from assms have "(\<lambda>i. p (i - 1)) partitions m" (is ?g1)
       using partitions_increase1 by blast
     moreover from assms have "(\<Sum>i\<le>m. p (i - 1)) = k" (is ?g2)
       using count_increase1 by blast
     moreover from assms have "p 0 = 0" (is ?g3)
       by (auto elim!: partitionsE)
     ultimately have "?g1 \<and> ?g2 \<and> ?g3" by simp
   }
   from this show "?T \<subseteq> ?S" by auto
qed

theorem card_partitions_k_parts:
  "card {p. p partitions n \<and> (\<Sum>i\<le>n. p i) = k} = Partition n k"
proof (induct n k rule: Partition.induct)
  case 1
  have eq: "{p. p = (\<lambda>x. 0) \<and> p 0 = 0} = {(\<lambda>x. 0)}" by auto
  show "card {p. p partitions 0 \<and> sum p {..0} = 0} = Partition 0 0"
    by (simp add: partitions_zero eq)
next
  case (2 k)
  have eq: "{p. p = (\<lambda>x. 0) \<and> p 0 = Suc k} = {}" by auto
  show "card {p. p partitions 0 \<and> sum p {..0} = Suc k} = Partition 0 (Suc k)"
    by (simp add: partitions_zero eq)
next
  case (3 m)
  have eq: "{p. p partitions Suc m \<and> sum p {..Suc m} = 0} = {}"
    by (fastforce elim!: partitionsE simp add: le_Suc_eq)
  from this show "card {p. p partitions Suc m \<and> sum p {..Suc m} = 0} = Partition (Suc m) 0"
    by (simp only: Partition.simps card_empty)
next
  case (4 m k)
  let ?set1 = "{p. p partitions Suc m \<and> sum p {..Suc m} = Suc k \<and> p 1 \<noteq> 0}"
  let ?set2 = "{p. p partitions Suc m \<and> sum p {..Suc m} = Suc k \<and> p 1 = 0}"
  have "finite {p. p partitions Suc m}"
    by (simp add: finite_partitions)
  from this have finite_sets: "finite ?set1" "finite ?set2" by simp+
  have set_eq: "{p. p partitions Suc m \<and> sum p {..Suc m} = Suc k} = ?set1 \<union> ?set2" by auto
  have disjoint: "?set1 \<inter> ?set2 = {}" by auto
  have inj1: "inj_on (\<lambda>p. p(1 := p 1 + 1)) {p. p partitions m \<and> sum p {..m} = k}"
    by (auto intro!: inj_onI) (metis diff_Suc_1 fun_upd_idem_iff fun_upd_upd)
  have inj2: "inj_on (\<lambda>p i. p (i - 1)) {p. p partitions m - k \<and> sum p {..m - k} = Suc k}"
    by (auto intro!: inj_onI simp add: fun_eq_iff) (metis add_diff_cancel_right')
  have card1: "card ?set1 = Partition m k"
    using inj1 4(1) by (simp only: set_rewrite1 card_image)
  have card2: "card ?set2 = Partition (m - k) (Suc k)"
    using inj2 4(2) by (simp only: set_rewrite2 card_image diff_Suc_Suc)
  have "card {p. p partitions Suc m \<and> sum p {..Suc m} = Suc k} = Partition m k + Partition (m - k) (Suc k)"
    using finite_sets disjoint by (simp only: set_eq card_Un_disjoint card1 card2)
  from this show "card {p. p partitions Suc m \<and> sum p {..Suc m} = Suc k} = Partition (Suc m) (Suc k)"
    by auto
qed

theorem card_partitions:
  "card {p. p partitions n} = (\<Sum>k\<le>n. Partition n k)"
proof -
  have seteq: "{p. p partitions n} = \<Union>((\<lambda>k. {p. p partitions n \<and> (\<Sum>i\<le>n. p i) = k}) ` {..n})"
    by (auto intro: partitions_parts_bounded)
  have finite: "\<And>k. finite {p. p partitions n \<and> sum p {..n} = k}"
    by (simp add: finite_partitions)
  have "card {p. p partitions n} = card (\<Union>((\<lambda>k. {p. p partitions n \<and> (\<Sum>i\<le>n. p i) = k}) ` {..n}))"
    using finite by (simp add: seteq)
  also have "... = (\<Sum>x\<le>n. card {p. p partitions n \<and> sum p {..n} = x})"
    using finite by (subst card_UN_disjoint) auto
  also have "... = (\<Sum>k\<le>n. Partition n k)"
    by (simp add: card_partitions_k_parts)
  finally show ?thesis .
qed

lemma card_partitions_atmost_k_parts:
  "card {p. p partitions n \<and> sum p {..n} \<le> k} = Partition (n + k) k"
proof -
  have "card {p. p partitions n \<and> sum p {..n} \<le> k} =
    card (\<Union>((\<lambda>k'. {p. p partitions n \<and> sum p {..n} = k'}) ` {..k}))"
  proof -
    have "{p. p partitions n \<and> sum p {..n} \<le> k} =
      (\<Union>k'\<le>k. {p. p partitions n \<and> sum p {..n} = k'})" by auto
    from this show ?thesis by simp
  qed
  also have "card (\<Union>((\<lambda>k'. {p. p partitions n \<and> sum p {..n} = k'}) ` {..k})) =
    sum (\<lambda>k'. card {p. p partitions n \<and> sum p {..n} = k'}) {..k}"
    using finite_partitions_k_parts by (subst card_UN_disjoint) auto
  also have "\<dots> = sum (\<lambda>k'. Partition n k') {..k}"
    using card_partitions_k_parts by simp
  also have "\<dots> = Partition (n + k) k"
    using Partition_sum_Partition_diff by simp
  finally show ?thesis .
qed

subsection \<open>Cardinality of Number Partitions as Multisets of Natural Numbers\<close>

lemma bij_betw_multiset_number_partition_with_size:
  "bij_betw count {N. number_partition n N \<and> size N = k} {p. p partitions n \<and> sum p {..n} = k}"
proof (rule bij_betw_byWitness[where f'="Abs_multiset"])
  show "\<forall>N\<in>{N. number_partition n N \<and> size N = k}. Abs_multiset (count N) = N"
    using count_inverse by blast
  show "\<forall>p\<in>{p. p partitions n \<and> sum p {..n} = k}. count (Abs_multiset p) = p"
    by (auto simp add: multiset_def partitions_imp_finite_elements)
  show "count ` {N. number_partition n N \<and> size N = k} \<subseteq> {p. p partitions n \<and> sum p {..n} = k}"
    by (auto simp add: count_partitions_iff size_nat_multiset_eq)
  show "Abs_multiset ` {p. p partitions n \<and> sum p {..n} = k} \<subseteq> {N. number_partition n N \<and> size N = k}"
    using partitions_iff_Abs_multiset size_nat_multiset_eq partitions_imp_multiset by fastforce
qed

lemma bij_betw_multiset_number_partition_with_atmost_size:
  "bij_betw count {N. number_partition n N \<and> size N \<le> k} {p. p partitions n \<and> sum p {..n} \<le> k}"
proof (rule bij_betw_byWitness[where f'="Abs_multiset"])
  show "\<forall>N\<in>{N. number_partition n N \<and> size N \<le> k}. Abs_multiset (count N) = N"
    using count_inverse by blast
  show "\<forall>p\<in>{p. p partitions n \<and> sum p {..n} \<le> k}. count (Abs_multiset p) = p"
    by (auto simp add: multiset_def partitions_imp_finite_elements)
  show "count ` {N. number_partition n N \<and> size N \<le> k} \<subseteq> {p. p partitions n \<and> sum p {..n} \<le> k}"
    by (auto simp add: count_partitions_iff size_nat_multiset_eq)
  show "Abs_multiset ` {p. p partitions n \<and> sum p {..n} \<le> k} \<subseteq> {N. number_partition n N\<and> size N \<le> k}"
    using partitions_iff_Abs_multiset size_nat_multiset_eq partitions_imp_multiset by fastforce
qed

theorem card_number_partitions_with_atmost_k_parts:
  shows "card {N. number_partition n N \<and> size N \<le> x} = Partition (n + x) x"
proof -
  have "bij_betw count {N. number_partition n N \<and> size N \<le> x} {p. p partitions n \<and> sum p {..n} \<le> x}"
    by (rule bij_betw_multiset_number_partition_with_atmost_size)
  from this have "card {N. number_partition n N \<and> size N \<le> x} = card {p. p partitions n \<and> sum p {..n} \<le> x}"
    by (rule bij_betw_same_card)
  also have "card {p. p partitions n \<and> sum p {..n} \<le> x} = Partition (n + x) x"
    by (rule card_partitions_atmost_k_parts)
  finally show ?thesis .
qed

theorem card_partitions_with_k_parts:
  "card {N. number_partition n N \<and> size N = k} = Partition n k"
proof -
  have "bij_betw count {N. number_partition n N \<and> size N = k} {p. p partitions n \<and> sum p {..n} = k}"
    by (rule bij_betw_multiset_number_partition_with_size)
  from this have "card {N. number_partition n N \<and> size N = k} = card {p. p partitions n \<and> sum p {..n} = k}"
    by (rule bij_betw_same_card)
  also have "\<dots> = Partition n k" by (rule card_partitions_k_parts)
  finally show ?thesis .
qed

subsection \<open>Cardinality of Number Partitions with only 1-parts\<close>

lemma number_partition1_eq_replicate_mset:
  "{N. (\<forall>n. n\<in># N \<longrightarrow> n = 1) \<and> number_partition n N} = {replicate_mset n 1}"
proof
  show "{N. (\<forall>n. n \<in># N \<longrightarrow> n = 1) \<and> number_partition n N} \<subseteq> {replicate_mset n 1}"
  proof
    fix N
    assume N: "N \<in> {N. (\<forall>n. n \<in># N \<longrightarrow> n = 1) \<and> number_partition n N}"
    have "N = replicate_mset n 1"
    proof (rule multiset_eqI)
      fix i
      have "count N 1 = sum_mset N"
      proof cases
        assume "N = {#}"
        from this show ?thesis by auto
      next
        assume "N \<noteq> {#}"
        from this N have "1 \<in># N" by blast
        from this N show ?thesis
          by (auto simp add: sum_mset_sum_count sum.remove[where x="1"] simp del: One_nat_def)
      qed
      from N this show "count N i = count (replicate_mset n 1) i"
        unfolding number_partition_def by (auto intro: count_inI)
    qed
    from this show "N \<in> {replicate_mset n 1}" by simp
  qed
next
  show "{replicate_mset n 1} \<subseteq> {N. (\<forall>n. n \<in># N \<longrightarrow> n = 1) \<and> number_partition n N}"
    unfolding number_partition_def by auto
qed

lemma card_number_partitions_with_only_parts_1_eq_0:
  assumes "x < n"
  shows "card {N. (\<forall>n. n\<in># N \<longrightarrow> n = 1) \<and> number_partition n N \<and> size N \<le> x} = 0" (is "card ?N = _")
proof -
  have "\<forall>N \<in> {N. (\<forall>n. n \<in># N \<longrightarrow> n = 1) \<and> number_partition n N}. size N = n"
    unfolding number_partition1_eq_replicate_mset by simp
  from this number_partition1_eq_replicate_mset\<open>x < n\<close> have "?N = {}" by auto
  from this show ?thesis by (simp only: card_empty)
qed

end


section \<open>lr-Multisemigroups\<close>

theory LR_Multisemigroup
  imports Main

begin

text \<open>A multimagma is a set equipped with a multioperation. Multioperations are nothing but ternary relations.\<close>

class multimagma =
  fixes mcomp :: "'a \<Rightarrow> 'a \<Rightarrow> 'a set" (infixl "\<odot>" 70)

begin

text \<open>We define left and right units.\<close>

definition "munitl e = ((\<exists>x. x \<in> e \<odot> x) \<and> (\<forall>x y. y \<in> e \<odot> x \<longrightarrow> y = x))"

definition "munitr e = ((\<exists>x. x \<in> x \<odot> e) \<and> (\<forall>x y. y \<in> x \<odot> e \<longrightarrow> y = x))"

abbreviation "munit e \<equiv> (munitl e \<or> munitr e)"

text \<open>We lift the multioperation to powersets\<close>

definition conv :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a set" (infixl "\<odot>\<^sub>l" 70) where
  "X \<odot>\<^sub>l Y = \<Union>{x \<odot> y |x y. x \<in> X \<and> y \<in> Y}"

lemma conv_exp: "X \<odot>\<^sub>l Y = {z. \<exists>x y. z \<in> x \<odot> y \<and> x \<in> X \<and> y \<in> Y}"
  unfolding conv_def by fastforce

lemma conv_distl: "X \<odot>\<^sub>l \<Union>\<Y> = \<Union>{X \<odot>\<^sub>l Y |Y. Y \<in> \<Y>}"
  unfolding conv_def by blast

lemma conv_distr: "\<Union>\<X> \<odot>\<^sub>l Y  = \<Union>{X \<odot>\<^sub>l Y |X. X \<in> \<X>}"
  unfolding conv_def by blast

end

text \<open>A multimagma is unital if every element has a left and a right unit.\<close>

class unital_multimagma_var = multimagma +
  assumes munitl_ex: "\<forall>x.\<exists>e. munitl e \<and> e \<odot> x \<noteq> {}"
  assumes munitr_ex: "\<forall>x.\<exists>e. munitr e \<and> x \<odot> e \<noteq> {}"

begin

lemma munitl_ex_var: "\<forall>x.\<exists>e. munitl e \<and> x \<in> e \<odot> x"
  by (metis equals0I local.munitl_def local.munitl_ex)

lemma unitl: "\<Union>{e \<odot> x |e. munitl e} = {x}"
  apply safe
  apply (simp add: multimagma.munitl_def)
  apply simp
  by (metis munitl_ex_var)

lemma munitr_ex_var: "\<forall>x.\<exists>e. munitr e \<and> x \<in> x \<odot> e"
  by (metis equals0I local.munitr_def local.munitr_ex)

lemma unitr: "\<Union>{x \<odot> e |e. munitr e} = {x}"
  apply safe
  apply (simp add: multimagma.munitr_def)
  apply simp
  by (metis munitr_ex_var)

text \<open>In a unital multimagma, elements can have several left or right units.\<close>

lemma "\<forall>x.\<exists>!e. munit e \<and> e \<odot> x = {x}"
  nitpick
  oops

lemma "\<forall>x.\<exists>!e. munit e \<and> x \<odot> e = {x}"
  nitpick
  oops

end

text \<open>Here is an alternative definition.\<close>

class unital_multimagma = multimagma +
  fixes E :: "'a set"
  assumes El: "\<Union>{e \<odot> x |e. e \<in> E} = {x}"
  and Er: "\<Union>{x \<odot> e |e. e \<in> E} = {x}"

begin

lemma E1: "\<forall>e \<in> E. (\<forall>x y. y \<in> e \<odot> x \<longrightarrow> y = x)"
  using local.El by fastforce

lemma E2: "\<forall>e \<in> E. (\<forall>x y. y \<in> x \<odot> e \<longrightarrow> y = x)"
  using local.Er by fastforce

text \<open>Units are "orthogonal" idempotents.\<close>

lemma unit_id: "\<forall>e \<in> E. e \<in> e \<odot> e"
  using E1 local.Er by fastforce

lemma unit_id_eq: "\<forall>e \<in> E. e \<odot> e = {e}"
  by (simp add: E1 equalityI subsetI unit_id)

lemma unit_comp: "e\<^sub>1 \<in> E \<Longrightarrow> e\<^sub>2 \<in> E \<Longrightarrow>  e\<^sub>1 \<odot> e\<^sub>2 \<noteq> {} \<Longrightarrow> e\<^sub>1 = e\<^sub>2"
  using E1 E2 by blast

lemma unit_comp_iff: "e\<^sub>1 \<in> E \<Longrightarrow> e\<^sub>2 \<in> E \<Longrightarrow> ((e\<^sub>1 \<odot> e\<^sub>2 \<noteq> {}) = (e\<^sub>1 = e\<^sub>2))"
  using unit_comp unit_id by auto

lemma El11: "\<forall>x.\<exists>e \<in> E. x \<in> e \<odot> x"
  using local.El by auto

lemma El12: "\<forall>x.\<exists>e \<in> E. e \<odot> x = {x}"
  using E1 El11 by fastforce

lemma Er11: "\<forall>x.\<exists>e \<in> E. x \<in> x \<odot> e"
  using local.Er by auto

lemma Er12: "\<forall>x.\<exists>e \<in> E. x \<odot> e = {x}"
  using Er Er11 by fastforce

lemma "\<forall>e \<in> E.\<exists>x. x \<in> e \<odot> x"
  using unit_id by blast

lemma "\<forall>e \<in> E.\<exists>x. x \<in> x \<odot> e"
  using unit_id by blast

sublocale unital_multimagma_var
  apply unfold_locales
  unfolding munitl_def munitr_def
  using E1 El11 apply fastforce
  using E2 Er11 by fastforce

text \<open>Now we know that the two definitions are equivalent.\<close>

text \<open>The next two lemmas show that the set of units is a left and right unit of composition at powerset level.\<close>

lemma conv_unl: "E \<odot>\<^sub>l X = X"
  unfolding conv_def
  apply safe
  using E1 apply blast
  using El12 by fastforce

lemma conv_unr: "X \<odot>\<^sub>l E = X"
  unfolding conv_def
  apply safe
  using E2 apply blast
  using Er12 by fastforce

end

text \<open>A multisemigroup is an associative multimagma.\<close>

class multisemigroup = multimagma +
  assumes assoc: "\<Union>{x \<odot> v |v. v \<in> y \<odot> z} = \<Union>{v \<odot> z |v. v \<in> x \<odot> y}"

begin

lemma assoc_exp: "(\<exists>v. w \<in> x \<odot> v \<and> v \<in> y \<odot> z) = (\<exists>v. v \<in> x \<odot> y \<and> w \<in> v \<odot> z)"
proof-
  have "(\<exists>v. w \<in> x \<odot> v \<and> v \<in> y \<odot> z) = (w \<in> \<Union>{x \<odot> v |v. v \<in> y \<odot> z})"
    by blast
  also have "\<dots> = (w \<in> \<Union>{v \<odot> z |v. v \<in> x \<odot> y})"
    using local.assoc by auto
  finally show ?thesis
    by blast
qed

lemma assoc_var: "{x} \<odot>\<^sub>l (y \<odot> z) = (x \<odot> y) \<odot>\<^sub>l {z}"
  unfolding conv_def assoc_exp
  using local.assoc by force

text \<open>Associativity lifts to powersets.\<close>

lemma conv_assoc: "X \<odot>\<^sub>l (Y \<odot>\<^sub>l Z) = (X \<odot>\<^sub>l Y) \<odot>\<^sub>l Z"
  unfolding conv_exp
  apply clarsimp
  using assoc_exp by blast

end

text \<open>A multimonoid is a unital multisemigroup.\<close>

class multimonoid = multisemigroup + unital_multimagma

begin

text \<open>In a multimonoid, left and right units are unique for each element.\<close>

lemma munits_uniquel: "\<forall>x.\<exists>!e. munit e \<and> e \<odot> x = {x}"
  apply safe
  using local.E1 local.El12 local.munitr_ex_var apply blast
  apply (metis insertI1 local.Er11 local.assoc_exp local.unit_comp_iff multimagma.munitl_def)
  apply (metis insertI1 local.assoc_exp multimagma.munitl_def multimagma.munitr_def)
  apply (metis insertI1 local.assoc_exp multimagma.munitl_def multimagma.munitr_def)
  by (metis insertI1 local.El11 local.assoc_exp local.unit_comp multimagma.munitr_def)

lemma munits_uniquer: "\<forall>x.\<exists>!e. munit e \<and> x \<odot> e = {x}"
  apply safe
  using local.E1 local.Er12 local.munitr_ex_var apply blast
  apply (metis insertI1 local.assoc_exp local.munitr_ex_var multimagma.munitl_def multimagma.munitr_def)
  apply (metis insertI1 local.assoc_exp local.munitl_def multimagma.munitr_def)
  apply (metis insertI1 local.assoc_exp local.munitl_def multimagma.munitr_def)
  by (metis insertI1 local.El11 local.assoc_exp local.unit_comp_iff multimagma.munitr_def)

text \<open>In a monoid, there is of course one single unit, and our definition of many units reduces to this one.\<close>

lemma units_unique: "(\<forall>x y. x \<odot> y \<noteq> {}) \<Longrightarrow> \<exists>!e. munit e"
  apply safe
  using local.munitl_ex_var apply blast
  apply (metis local.Er11 local.unit_comp multimagma.munitl_def)
  apply (metis local.Er11 local.munitl_ex_var local.unit_comp multimagma.munitl_def multimagma.munitr_def)
  apply (metis local.Er11 local.munitl_ex_var local.unit_comp multimagma.munitl_def multimagma.munitr_def)
  by (metis local.El11 local.unit_comp multimagma.munitr_def)

lemma "x \<odot> x = {x} \<Longrightarrow> x \<in> E"
  nitpick
  oops

end

text \<open>Next we define lr-multisemigroups with source and target maps.\<close>

class lr_multimagma = multimagma +
fixes ll :: "'a \<Rightarrow> 'a"
  and rr :: "'a \<Rightarrow> 'a"
  assumes Dlr: "x \<odot> y \<noteq> {} \<Longrightarrow> rr x = ll y"
  and l_absorb [simp]: "ll x \<odot> x = {x}"
  and r_absorb [simp]: "x \<odot> rr x = {x}"

begin

lemma rl_compat [simp]: "rr (ll x) = ll x"
  by (simp add: local.Dlr)

lemma lr_compat [simp]: "ll (rr x) = rr x"
  by (metis insert_not_empty local.Dlr local.r_absorb)

lemma ll_retract [simp]: "ll (ll x) = ll x"
  by (metis lr_compat rl_compat)

lemma rr_retract [simp]: "rr (rr x) = rr x"
  by (metis lr_compat rl_compat)

lemma lr_fix: "(rr x = x) = (ll x = x)"
  by (metis lr_compat rl_compat)

definition lfix :: "'a set" where
  "lfix = {x. ll x = x}"

definition rfix :: "'a set" where
  "rfix = {x. rr x = x}"

lemma lr_fix_set: "{x. ll x = x} = {x. rr x = x}"
  using lr_fix by simp

lemma lrfix_set: "lfix = rfix"
  by (simp add: lfix_def rfix_def lr_fix_set)

lemma l_idem [simp]: "ll x \<odot> ll x = {ll x}"
  by (metis local.r_absorb rl_compat)

lemma r_idem [simp]:  "rr x \<odot> rr x = {rr x}"
  by (metis local.l_absorb lr_compat)

lemma lr_comm: "rr x \<odot> ll y = ll y \<odot> rr x"
  using local.Dlr by fastforce

lemma l_weak_twisted: "\<Union>{ll u \<odot> x |u. u \<in> x \<odot> y} \<subseteq> x \<odot> ll y"
  apply (clarsimp simp:  Sup_least)
  by (metis equals0D local.Dlr local.l_absorb local.r_absorb rl_compat)

lemma "\<Union>{ll u \<odot> x |u. u \<in> x \<odot> y} = x \<odot> ll y"
  nitpick
  oops

lemma r_weak_twisted: "\<Union>{x \<odot> rr u |u. u \<in> y \<odot> x} \<subseteq> rr y \<odot> x"
  apply (clarsimp simp: Sup_least)
  by (metis empty_iff local.Dlr local.l_absorb local.r_absorb lr_compat)

lemma "\<Union>{x \<odot> rr u |u. u \<in> y \<odot> x} = rr y \<odot> x"
  nitpick
  oops

lemma l_comm: "ll x \<odot> ll y = ll y \<odot> ll x"
  using local.Dlr by force

lemma r_comm: "rr x \<odot> rr y = rr y \<odot> rr x"
  using local.Dlr by fastforce

lemma l_export: "ll ` (ll x \<odot> y) = ll x \<odot> ll y"
  using local.Dlr by force

lemma r_export: "rr ` (x \<odot> rr y) = rr x \<odot> rr y"
  by (metis image_empty image_insert local.Dlr local.r_absorb lr_compat r_idem)

lemma lr_prop: "(rr x = ll y) = (rr x \<odot> ll y \<noteq> {})"
  by (metis empty_not_insert l_idem local.Dlr lr_compat rl_compat)

lemma weak_local_var: "rr x \<odot> ll y = {} \<Longrightarrow> x \<odot> y = {}"
  using local.Dlr lr_prop by blast

lemma "x \<odot> y = {} \<Longrightarrow> rr x \<odot> ll y = {}"
  nitpick
  oops

lemma "(ll x \<odot> ll y \<noteq> {}) = (ll x = ll y)"
  using local.Dlr by fastforce

lemma "(rr x \<odot> rr y \<noteq> {}) = (rr x = rr y)"
  using local.Dlr by fastforce

text \<open>The set of all sources (and targets) are units at powerset level.\<close>

lemma conv_unl: "lfix \<odot>\<^sub>l X = X"
  unfolding conv_def lfix_def
  apply safe
   apply (metis empty_iff insert_iff local.Dlr local.l_absorb)
  apply simp
  using ll_retract local.l_absorb by blast

lemma conv_unr: "X \<odot>\<^sub>l rfix = X"
  unfolding conv_exp rfix_def
  apply safe
   apply (metis empty_iff insert_iff local.Dlr local.r_absorb)
  apply simp
  using local.r_absorb by fastforce

text \<open>We lift source and target maps to the powerset level and prove laws of modal powerset quantales.\<close>

definition LL :: "'a set \<Rightarrow> 'a set" where
  "LL = image ll"

definition RR :: "'a set \<Rightarrow> 'a set" where
  "RR = image rr"

lemma LR_compat [simp]: "LL (RR X) = RR X"
  by (metis LL_def RR_def image_cong image_image lr_compat)

lemma RL_compat [simp]: "RR (LL X) = LL X"
  by (metis LL_def RR_def image_cong image_image rl_compat)

lemma LL_absorp: "LL X \<odot>\<^sub>l X = X"
  unfolding conv_exp LL_def
  apply safe
  using local.Dlr apply fastforce
  by (metis imageI insertI1 local.l_absorb)

lemma RR_absorp: "X \<odot>\<^sub>l RR X = X"
  unfolding conv_exp RR_def
  apply safe
  apply (metis empty_iff local.Dlr local.r_absorb lr_compat singletonD)
  by force

lemma LL_Sup_pres: "LL (\<Union>\<X>) = \<Union>{LL X |X. X \<in> \<X>}"
  unfolding LL_def by blast

lemma RR_Sup_pres: "RR (\<Union>\<X>) = \<Union>{RR X |X. X \<in> \<X>}"
  unfolding RR_def by blast

lemma LR_comm: "LL X \<odot>\<^sub>l RR Y = RR Y \<odot>\<^sub>l LL X"
  unfolding LL_def RR_def conv_exp
  by (metis (no_types, lifting) empty_iff imageE local.Dlr lr_compat rl_compat)

lemma LL_comm: "LL X \<odot>\<^sub>l LL Y = LL Y \<odot>\<^sub>l LL X"
  by (metis LR_comm RL_compat)

lemma LL_comm: "RR X \<odot>\<^sub>l RR Y = RR Y \<odot>\<^sub>l RR X"
  by (metis LR_comm LR_compat)

lemma RR_subid: "LL X \<subseteq> lfix"
  by (simp add: LL_def image_subsetI lfix_def)

lemma RR_subid: "RR X \<subseteq> rfix"
  by (simp add: RR_def image_subsetI rfix_def)

lemma LL_export: "LL (LL X \<odot>\<^sub>l Y) = LL X \<odot>\<^sub>l LL Y"
  unfolding conv_exp LL_def
  apply safe
  apply (metis empty_iff image_eqI local.Dlr local.l_absorb local.r_absorb singletonD singletonI)
  using l_export by fastforce

lemma RR_export: "RR (X \<odot>\<^sub>l RR Y) = RR X \<odot>\<^sub>l RR Y"
  unfolding conv_exp RR_def
  apply safe
  apply (metis empty_iff image_eqI local.Dlr local.r_absorb r_idem singletonD singletonI)
  using r_export by fastforce

end

class lr_multisemigroup = lr_multimagma + multisemigroup

begin

lemma l_comp_aux: "v \<in> x \<odot> y \<Longrightarrow> ll v = ll x"
proof-
  assume hyp: "v \<in> x \<odot> y"
  hence "v \<in> ll v \<odot> v \<and> v \<in> x \<odot> y"
    by simp
  hence "\<exists>w. w \<in> ll v \<odot> x \<and> v \<in> w \<odot> y"
    using local.assoc by blast
  hence "rr (ll v) = ll x"
    using local.Dlr by fastforce
  thus ?thesis
    by simp
qed

lemma l_comp: "LL (x \<odot> y) \<subseteq> {ll x}"
  by (simp add: LL_def image_subsetI l_comp_aux)

lemma l_comp_cond: "x \<odot> y \<noteq> {} \<Longrightarrow> LL (x \<odot> y) = {ll x}"
  by (metis empty_is_image l_comp local.LL_def subset_singleton_iff)

lemma r_comp_aux: "v \<in> x \<odot> y \<Longrightarrow> rr v = rr y"
proof-
  assume hyp: "v \<in> x \<odot> y"
  hence "v \<in> v \<odot> rr v \<and> v \<in> x \<odot> y"
    by simp
  hence "\<exists>w. w \<in> y \<odot> rr v \<and> v \<in> x \<odot> w"
    using local.assoc by blast
  hence "ll (rr v) = rr y"
    using local.Dlr by fastforce
  thus ?thesis
    by simp
qed

lemma r_comp: "RR (x \<odot> y) \<subseteq> {rr y}"
  by (simp add: RR_def image_subsetI r_comp_aux)

lemma r_comp_cond: "x \<odot> y \<noteq> {} \<Longrightarrow> RR (x \<odot> y) = {rr y}"
  by (metis empty_is_image local.RR_def r_comp subset_singleton_iff)

lemma l_weak_local:  "LL (x \<odot> y) \<subseteq> LL (x \<odot> ll y)"
  by (metis insert_not_empty l_comp l_comp_cond local.Dlr local.r_absorb order_class.order.eq_iff)

lemma l_local_cond:  "x \<odot> y \<noteq> {} \<Longrightarrow> LL (x \<odot> y) = LL (x \<odot> ll y)"
  by (metis insert_not_empty l_comp_cond local.Dlr local.r_absorb)

lemma r_weak_local:  "RR (x \<odot> y) \<subseteq> RR (rr x \<odot> y)"
  using RR_def local.Dlr r_comp_cond by fastforce

lemma r_local_cond:  "x \<odot> y \<noteq> {} \<Longrightarrow> RR (x \<odot> y) = RR (rr x \<odot> y)"
  using r_comp r_comp_cond r_weak_local by fastforce

lemma r_twisted_aux: "u \<in> x \<odot> y \<Longrightarrow> (rr x \<odot> y = y \<odot> rr u)"
  using local.Dlr r_comp_aux by fastforce

lemma r_twisted_cond: "x \<odot> y \<noteq> {} \<Longrightarrow> rr x \<odot> y = \<Union>{y \<odot> rr u |u. u \<in> x \<odot> y}"
  by (simp add: Setcompr_eq_image local.Dlr r_comp_aux)

lemma l_twisted_aux: "u \<in> x \<odot> y \<Longrightarrow> (x \<odot> ll y = ll u \<odot> x)"
  by (metis l_comp_aux local.Dlr local.l_absorb local.r_absorb)

lemma l_twisted_cond: "x \<odot> y \<noteq> {} \<Longrightarrow> x \<odot> ll y = \<Union>{ll u \<odot> x |u. u \<in> x \<odot> y}"
  apply standard
  using l_twisted_aux apply fastforce
  by (simp add: local.l_weak_twisted)

lemma "x \<in> y \<odot> z \<Longrightarrow> x' \<in> y \<odot> z \<Longrightarrow> ll x = ll x'"
  by (simp add: l_comp_aux)

lemma coherence_iff: "(\<forall>x y. (x \<odot> y \<noteq> {}) = (rr x = ll y)) = (\<forall>v x y z. v \<in> x \<odot> y \<longrightarrow> y \<odot> z \<noteq> {} \<longrightarrow> v \<odot> z \<noteq> {})"
  by (metis (full_types) insert_not_empty local.Dlr local.l_absorb local.r_absorb r_comp_aux singletonI)

lemma "LL (x \<odot> y) = LL (x \<odot> ll y)"
  nitpick
  oops

lemma r_local:  "RR (x \<odot> y) = RR (rr x \<odot> y)"
  nitpick
  oops

  text \<open>Again we can lift to properties of modal semirings.\<close>

lemma LL_weak_local: "LL (X \<odot>\<^sub>l Y) \<subseteq> LL (X \<odot>\<^sub>l LL Y)"
  unfolding conv_exp LL_def image_def
  using l_comp_aux local.Dlr local.r_absorb by blast

lemma RR_weak_local: "RR (X \<odot>\<^sub>l  Y) \<subseteq> RR (RR X \<odot>\<^sub>l Y)"
  unfolding conv_exp RR_def image_def
  using r_comp_aux r_twisted_aux by fastforce

end

class coherent_lr_multisemigroup = lr_multisemigroup +
  assumes coherence: "(x \<odot> y \<noteq> {}) = (rr x = ll y)"

begin

text \<open>Coherence implies locality.\<close>

lemma l_local:  "LL (x \<odot> y) = LL (x \<odot> ll y)"
  by (metis local.coherence local.l_local_cond local.ll_retract)

lemma r_local:  "RR (x \<odot> y) = RR (rr x \<odot> y)"
  by (metis local.coherence local.r_local_cond local.rr_retract)

lemma r_twisted: "rr x \<odot> y = \<Union>{y \<odot> rr u |u. u \<in> x \<odot> y}"
  by (metis Setcompr_eq_image Union_empty image_empty local.coherence local.r_twisted_cond local.rr_retract)

lemma l_twisted: "x \<odot> ll y = \<Union>{ll u \<odot> x |u. u \<in> x \<odot> y}"
  by (metis Setcompr_eq_image Union_empty image_empty local.coherence local.l_twisted_cond local.ll_retract)

lemma "LL (x \<odot> y) = {ll x}"
  nitpick
  oops

lemma "RR (x \<odot> y) = {rr x}"
  nitpick
  oops

lemma local_var: "x \<odot> y = {} \<Longrightarrow> rr x \<odot> ll y = {}"
  by (metis local.coherence local.ll_retract local.rr_retract)

lemma local_var_eq: "(x \<odot> y = {}) = (rr x \<odot> ll y = {})"
  by (meson local.weak_local_var local_var)

lemma LL_local: "LL (X \<odot>\<^sub>l Y) = LL (X \<odot>\<^sub>l LL Y)"
  apply (rule antisym)
  apply (simp add: local.LL_weak_local)
  unfolding conv_exp LL_def image_def
  using l_twisted local.l_comp_aux by fastforce

lemma RR_local: "RR (X \<odot>\<^sub>l Y) = RR (RR X \<odot>\<^sub>l Y)"
  apply (rule antisym)
  apply (simp add: local.RR_weak_local)
  unfolding conv_exp RR_def image_def
  apply clarsimp
  using local.r_comp_aux r_twisted by fastforce

end

text \<open>Next we define local lr-multimagmas\<close>

class local_lr_multimagma = lr_multimagma +
  assumes l_local: "LL (x \<odot> ll y) \<subseteq> LL (x \<odot> y)"
  and r_local: "LL (rr x \<odot> y) \<subseteq>  LL (x \<odot> y)"

begin

text \<open>Locality implies coherence, which is the composition pattern of categories.\<close>

lemma  coherence: "(x \<odot> y \<noteq> {}) = (rr x = ll y)"
  apply standard
  apply (simp add: local.Dlr)
  by (metis image_empty local.LL_def local.l_export local.l_idem local.lr_prop local.r_local singleton_insert_inj_eq subset_antisym)

end

text \<open>Finally, we try to derive the implication used in the definition of lr-multisemigroups, but can't.\<close>

class st_multimagma = multimagma +
  fixes \<sigma> :: "'a \<Rightarrow> 'a"
  and \<tau> :: "'a \<Rightarrow> 'a"
  assumes st_compat [simp]: "\<sigma> (\<tau> x) = \<tau> x"
  and ts_compat [simp]: "\<tau> (\<sigma> x) = \<sigma> x"
  and s_absorb [simp]: "\<sigma> x \<odot> x = {x}"
  and t_absorb [simp]: "x \<odot> \<tau> x = {x}"
  and st_comm: "\<sigma> x \<odot> \<tau> y = \<tau> y \<odot> \<sigma> x"
  and s_weak_local: "\<sigma> ` (x \<odot> y) \<subseteq> \<sigma> ` (x \<odot> \<sigma> y)"
  and t_weak_local: "\<tau> ` (x \<odot> y) \<subseteq> \<sigma> ` (\<tau> x \<odot> y)"
and l_export: "\<sigma> ` (\<sigma> x \<odot> y) = \<sigma> x \<odot> \<sigma> y"
and  r_export: "\<tau> ` (x \<odot> \<tau> y) = \<tau> x \<odot> \<tau> y"

begin

lemma "x \<odot> y \<noteq> {} \<Longrightarrow> \<tau> x \<odot> \<sigma> y \<noteq> {}"
  by (metis empty_is_image empty_subsetI local.s_weak_local local.t_weak_local subset_antisym)

lemma "x \<odot> y = {} \<Longrightarrow> \<tau> x \<odot> \<sigma> y = {}"
  nitpick
  oops

lemma "x \<odot> y \<noteq> {} \<Longrightarrow> \<tau> x = \<sigma> y"
  nitpick
  oops

lemma lr_prop: "(\<tau> x = \<sigma> y) \<Longrightarrow> (\<tau> x \<odot> \<sigma> y \<noteq> {})"
  by (metis empty_not_insert local.t_absorb local.ts_compat)

lemma lr_prop: "(\<tau> x = \<sigma> y) = (\<tau> x \<odot> \<sigma> y \<noteq> {})"
  nitpick
  oops

lemma s_retract [simp]: "\<sigma> (\<sigma> x) = \<sigma> x"
  by (metis local.st_compat local.ts_compat)

lemma t_retract [simp]: "\<tau> (\<tau> x) = \<tau> x"
  by (metis local.st_compat local.ts_compat)

lemma st_fix: "(\<tau> x = x) = (\<sigma> x = x)"
  by (metis local.st_compat local.ts_compat)

lemma s_idem [simp]: "\<sigma> x \<odot> \<sigma> x = {\<sigma> x}"
  by (metis local.s_absorb s_retract)

lemma t_idem [simp]:  "\<tau> x \<odot> \<tau> x = {\<tau> x}"
  by (metis local.t_absorb t_retract)

lemma s_weak_twisted: "\<Union>{\<sigma> u \<odot> x |u. u \<in> x \<odot> y} \<subseteq> x \<odot> \<sigma> y"
  apply (clarsimp simp:  Sup_least)
  nitpick
  oops

lemma t_weak_twisted: "\<Union>{x \<odot> \<tau> u |u. u \<in> y \<odot> x} \<subseteq> \<tau> y \<odot> x"
  apply (clarsimp simp: Sup_least)
  nitpick
  oops

lemma s_comm: "\<sigma> x \<odot> \<sigma> y = \<sigma> y \<odot> \<sigma> x"
  by (metis local.st_comm local.ts_compat)

lemma t_comm: "\<tau> x \<odot> \<tau> y = \<tau> y \<odot> \<tau> x"
  by (metis local.st_comm local.st_compat)

end

class st_multisemigroup = st_multimagma + multisemigroup

begin

lemma "x \<odot> y = {} \<Longrightarrow> \<tau> x \<odot> \<sigma> y = {}"
  nitpick
  oops

lemma "x \<odot> y \<noteq> {} \<Longrightarrow> \<tau> x = \<sigma> y"
  nitpick
  oops

lemma lr_prop: "(\<tau> x = \<sigma> y) \<Longrightarrow> (\<tau> x \<odot> \<sigma> y \<noteq> {})"
  by (metis empty_not_insert local.t_absorb local.ts_compat)

lemma lr_prop: "(\<tau> x = \<sigma> y) = (\<tau> x \<odot> \<sigma> y \<noteq> {})"
  nitpick
  oops

end

class local_st_multisemigroup = st_multisemigroup +
  assumes s_local: "\<sigma> ` (x \<odot> \<sigma> y) \<subseteq> \<sigma> ` (x \<odot> y)"
  and t_local: " \<sigma> ` (\<tau> x \<odot> y) \<subseteq> \<tau> ` (x \<odot> y)"

begin

lemma "x \<odot> y = {} \<Longrightarrow> \<tau> x \<odot> \<sigma> y = {}"
  by (metis image_empty local.l_export local.st_compat local.t_local subset_empty)

lemma "(x \<odot> y = {}) = (\<tau> x \<odot> \<sigma> y = {})"
  by (metis empty_is_image local.l_export local.st_compat local.t_local local.t_weak_local subset_antisym)

lemma "\<tau> x \<odot> \<sigma> y \<noteq> {} \<Longrightarrow> \<tau> x = \<sigma> y"
  nitpick
  oops

end

end