(******************************************************************************)
(* Project: Isabelle/UTP Toolkit                                              *)
(* File: Finite_Fun.thy                                                       *)
(* Authors: Simon Foster and Frank Zeyda                                      *)
(* Emails: simon.foster@york.ac.uk and frank.zeyda@york.ac.uk                 *)
(******************************************************************************)

section \<open> Finite Functions \<close>

theory Finite_Fun
imports Map_Extra Partial_Fun FSet_Extra
begin

subsection \<open> Finite function type and operations \<close>

typedef ('a, 'b) ffun = "{f :: ('a, 'b) pfun. finite(pdom(f))}"
  morphisms pfun_of Abs_pfun
  by (rule_tac x="{}\<^sub>p" in exI, auto)

setup_lifting type_definition_ffun

lift_definition ffun_app :: "('a, 'b) ffun \<Rightarrow> 'a \<Rightarrow> 'b" ("_'(_')\<^sub>f" [999,0] 999) is "pfun_app" .

lift_definition ffun_upd :: "('a, 'b) ffun \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b) ffun" is "pfun_upd" by simp

lift_definition fdom :: "('a, 'b) ffun \<Rightarrow> 'a set" is pdom .

lift_definition fran :: "('a, 'b) ffun \<Rightarrow> 'b set" is pran .

lift_definition ffun_comp :: "('b, 'c) ffun \<Rightarrow> ('a, 'b) ffun \<Rightarrow> ('a, 'c) ffun" (infixl "\<circ>\<^sub>f" 55) is pfun_comp by auto

lift_definition ffun_member :: "'a \<times> 'b \<Rightarrow> ('a, 'b) ffun \<Rightarrow> bool" (infix "\<in>\<^sub>f" 50) is "(\<in>\<^sub>p)" .

lift_definition fdom_res :: "'a set \<Rightarrow> ('a, 'b) ffun \<Rightarrow> ('a, 'b) ffun" (infixl "\<lhd>\<^sub>f" 85)
is "pdom_res" by simp

lift_definition fran_res :: "('a, 'b) ffun \<Rightarrow> 'b set \<Rightarrow> ('a, 'b) ffun" (infixl "\<rhd>\<^sub>f" 85)
is pran_res by simp

lift_definition ffun_graph :: "('a, 'b) ffun \<Rightarrow> ('a \<times> 'b) set" is pfun_graph .

lift_definition graph_ffun :: "('a \<times> 'b) set \<Rightarrow> ('a, 'b) ffun" is
  "\<lambda> R. if (finite (Domain R)) then graph_pfun R else pempty"
  by (simp add: finite_Domain)

instantiation ffun :: (type, type) zero
begin
lift_definition zero_ffun :: "('a, 'b) ffun" is "0" by simp
instance ..
end

abbreviation fempty :: "('a, 'b) ffun" ("{}\<^sub>f")
where "fempty \<equiv> 0"

instantiation ffun :: (type, type) plus
begin
lift_definition plus_ffun :: "('a, 'b) ffun \<Rightarrow> ('a, 'b) ffun \<Rightarrow> ('a, 'b) ffun" is "(+)" by simp
instance ..
end

instantiation ffun :: (type, type) minus
begin
lift_definition minus_ffun :: "('a, 'b) ffun \<Rightarrow> ('a, 'b) ffun \<Rightarrow> ('a, 'b) ffun" is "(-)"
  by (metis finite_Diff finite_Domain pdom_graph_pfun pdom_pfun_graph_finite pfun_graph_inv pfun_graph_minus)
instance ..
end

instance ffun :: (type, type) monoid_add
  by (intro_classes, (transfer, simp add: add.assoc)+)

instantiation ffun :: (type, type) inf
begin
lift_definition inf_ffun :: "('a, 'b) ffun \<Rightarrow> ('a, 'b) ffun \<Rightarrow> ('a, 'b) ffun" is inf
  by (meson finite_Int infinite_super pdom_inter)
instance ..
end

abbreviation ffun_inter :: "('a, 'b) ffun \<Rightarrow> ('a, 'b) ffun \<Rightarrow> ('a, 'b) ffun" (infixl "\<inter>\<^sub>f" 80)
where "ffun_inter \<equiv> inf"

instantiation ffun :: (type, type) order
begin
  lift_definition less_eq_ffun :: "('a, 'b) ffun \<Rightarrow> ('a, 'b) ffun \<Rightarrow> bool" is
  "\<lambda> f g. f \<subseteq>\<^sub>p g" .
  lift_definition less_ffun :: "('a, 'b) ffun \<Rightarrow> ('a, 'b) ffun \<Rightarrow> bool" is
  "\<lambda> f g. f < g" .
instance
  by (intro_classes, (transfer, auto)+)
end

abbreviation ffun_subset :: "('a, 'b) ffun \<Rightarrow> ('a, 'b) ffun \<Rightarrow> bool" (infix "\<subset>\<^sub>f" 50)
where "ffun_subset \<equiv> less"

abbreviation ffun_subset_eq :: "('a, 'b) ffun \<Rightarrow> ('a, 'b) ffun \<Rightarrow> bool" (infix "\<subseteq>\<^sub>f" 50)
where "ffun_subset_eq \<equiv> less_eq"

instance ffun :: (type, type) semilattice_inf
  by (intro_classes, (transfer, auto)+)

lemma ffun_subset_eq_least [simp]:
  "{}\<^sub>f \<subseteq>\<^sub>f f"
  by (transfer, auto)

syntax
  "_FfunUpd"  :: "[('a, 'b) ffun, maplets] => ('a, 'b) ffun" ("_'(_')\<^sub>f" [900,0]900)
  "_Ffun"     :: "maplets => ('a, 'b) ffun"            ("(1{_}\<^sub>f)")

translations
  "_FfunUpd m (_Maplets xy ms)"  == "_FfunUpd (_FfunUpd m xy) ms"
  "_FfunUpd m (_maplet  x y)"    == "CONST ffun_upd m x y"
  "_Ffun ms"                     => "_FfunUpd (CONST fempty) ms"
  "_Ffun (_Maplets ms1 ms2)"     <= "_FfunUpd (_Ffun ms1) ms2"
  "_Ffun ms"                     <= "_FfunUpd (CONST fempty) ms"

subsection \<open> Algebraic laws \<close>

lemma ffun_comp_assoc: "f \<circ>\<^sub>f (g \<circ>\<^sub>f h) = (f \<circ>\<^sub>f g) \<circ>\<^sub>f h"
  by (transfer, simp add: pfun_comp_assoc)

lemma pfun_override_dist_comp:
  "(f + g) \<circ>\<^sub>f h = (f \<circ>\<^sub>f h) + (g \<circ>\<^sub>f h)"
  by (transfer, simp add: pfun_override_dist_comp)

lemma ffun_minus_unit [simp]:
  fixes f :: "('a, 'b) ffun"
  shows "f - 0 = f"
  by (transfer, simp)

lemma ffun_minus_zero [simp]:
  fixes f :: "('a, 'b) ffun"
  shows "0 - f = 0"
  by (transfer, simp)

lemma ffun_minus_self [simp]:
  fixes f :: "('a, 'b) ffun"
  shows "f - f = 0"
  by (transfer, simp)

lemma ffun_plus_commute:
  "fdom(f) \<inter> fdom(g) = {} \<Longrightarrow> f + g = g + f"
  by (transfer, metis pfun_plus_commute)

lemma ffun_minus_plus_commute:
  "fdom(g) \<inter> fdom(h) = {} \<Longrightarrow> (f - g) + h = (f + h) - g"
  by (transfer, simp add: pfun_minus_plus_commute)

lemma ffun_plus_minus:
  "f \<subseteq>\<^sub>f g \<Longrightarrow> (g - f) + f = g"
  by (transfer, simp add: pfun_plus_minus)

lemma ffun_minus_common_subset:
  "\<lbrakk> h \<subseteq>\<^sub>f f; h \<subseteq>\<^sub>f g \<rbrakk> \<Longrightarrow> (f - h = g - h) = (f = g)"
  by (transfer, simp add: pfun_minus_common_subset)

lemma ffun_minus_plus:
  "fdom(f) \<inter> fdom(g) = {} \<Longrightarrow> (f + g) - g = f"
  by (transfer, simp add: pfun_minus_plus)

lemma ffun_plus_pos: "x + y = {}\<^sub>f \<Longrightarrow> x = {}\<^sub>f"
  by (transfer, simp add: pfun_plus_pos)

lemma ffun_le_plus: "fdom x \<inter> fdom y = {} \<Longrightarrow> x \<le> x + y"
  by (transfer, simp add: pfun_le_plus)

subsection \<open> Membership, application, and update \<close>

lemma ffun_ext: "\<lbrakk> \<And> x y. (x, y) \<in>\<^sub>f f \<longleftrightarrow> (x, y) \<in>\<^sub>f g \<rbrakk> \<Longrightarrow> f = g"
  by (transfer, simp add: pfun_ext)

lemma ffun_member_alt_def:
  "(x, y) \<in>\<^sub>f f \<longleftrightarrow> (x \<in> fdom f \<and> f(x)\<^sub>f = y)"
  by (transfer, simp add: pfun_member_alt_def)

lemma ffun_member_plus:
  "(x, y) \<in>\<^sub>f f + g \<longleftrightarrow> ((x \<notin> fdom(g) \<and> (x, y) \<in>\<^sub>f f) \<or> (x, y) \<in>\<^sub>f g)"
  by (transfer, simp add: pfun_member_plus)

lemma ffun_member_minus:
  "(x, y) \<in>\<^sub>f f - g \<longleftrightarrow> (x, y) \<in>\<^sub>f f \<and> (\<not> (x, y) \<in>\<^sub>f g)"
  by (transfer, simp add: pfun_member_minus)

lemma ffun_app_upd_1 [simp]: "x = y \<Longrightarrow> (f(x \<mapsto> v)\<^sub>f)(y)\<^sub>f = v"
  by (transfer, simp)

lemma ffun_app_upd_2 [simp]: "x \<noteq> y \<Longrightarrow> (f(x \<mapsto> v)\<^sub>f)(y)\<^sub>f = f(y)\<^sub>f"
  by (transfer, simp)

lemma ffun_upd_ext [simp]: "x \<in> fdom(f) \<Longrightarrow> f(x \<mapsto> f(x)\<^sub>f)\<^sub>f = f"
  by (transfer, simp)

lemma ffun_app_add [simp]: "x \<in> fdom(g) \<Longrightarrow> (f + g)(x)\<^sub>f = g(x)\<^sub>f"
  by (transfer, simp)

lemma ffun_upd_add [simp]: "f + g(x \<mapsto> v)\<^sub>f = (f + g)(x \<mapsto> v)\<^sub>f"
  by (transfer, simp)

lemma ffun_upd_twice [simp]: "f(x \<mapsto> u, x \<mapsto> v)\<^sub>f = f(x \<mapsto> v)\<^sub>f"
  by (transfer, simp)

lemma ffun_upd_comm:
  assumes "x \<noteq> y"
  shows "f(y \<mapsto> u, x \<mapsto> v)\<^sub>f = f(x \<mapsto> v, y \<mapsto> u)\<^sub>f"
  using assms by (transfer, simp add: pfun_upd_comm)

lemma ffun_upd_comm_linorder [simp]:
  fixes x y :: "'a :: linorder"
  assumes "x < y"
  shows "f(y \<mapsto> u, x \<mapsto> v)\<^sub>f = f(x \<mapsto> v, y \<mapsto> u)\<^sub>f"
  using assms by (transfer, auto)

lemma ffun_app_minus [simp]: "x \<notin> fdom g \<Longrightarrow> (f - g)(x)\<^sub>f = f(x)\<^sub>f"
  by (transfer, auto)

lemma ffun_upd_minus [simp]:
  "x \<notin> fdom g \<Longrightarrow> (f - g)(x \<mapsto> v)\<^sub>f = (f(x \<mapsto> v)\<^sub>f - g)"
  by (transfer, auto)

lemma fdom_member_minus_iff [simp]:
  "x \<notin> fdom g \<Longrightarrow> x \<in> fdom(f - g) \<longleftrightarrow> x \<in> fdom(f)"
  by (transfer, simp)

lemma fsubseteq_ffun_upd1 [intro]:
  "\<lbrakk> f \<subseteq>\<^sub>f g; x \<notin> fdom(g) \<rbrakk> \<Longrightarrow> f \<subseteq>\<^sub>f g(x \<mapsto> v)\<^sub>f"
  by (transfer, auto)

lemma fsubseteq_ffun_upd2 [intro]:
  "\<lbrakk> f \<subseteq>\<^sub>f g; x \<notin> fdom(f) \<rbrakk> \<Longrightarrow> f \<subseteq>\<^sub>f g(x \<mapsto> v)\<^sub>f"
  by (transfer, auto)

lemma psubseteq_pfun_upd3 [intro]:
  "\<lbrakk> f \<subseteq>\<^sub>f g; g(x)\<^sub>f = v \<rbrakk> \<Longrightarrow> f \<subseteq>\<^sub>f g(x \<mapsto> v)\<^sub>f"
  by (transfer, auto)

lemma fsubseteq_dom_subset:
  "f \<subseteq>\<^sub>f g \<Longrightarrow> fdom(f) \<subseteq> fdom(g)"
  by (transfer, auto simp add: psubseteq_dom_subset)

lemma fsubseteq_ran_subset:
  "f \<subseteq>\<^sub>f g \<Longrightarrow> fran(f) \<subseteq> fran(g)"
  by (transfer, simp add: psubseteq_ran_subset)

subsection \<open> Domain laws \<close>

lemma fdom_finite [simp]: "finite(fdom(f))"
  by (transfer, simp)

lemma fdom_zero [simp]: "fdom 0 = {}"
  by (transfer, simp)

lemma fdom_plus [simp]: "fdom (f + g) = fdom f \<union> fdom g"
  by (transfer, auto)

lemma fdom_inter: "fdom (f \<inter>\<^sub>f g) \<subseteq> fdom f \<inter> fdom g"
  by (transfer, meson pdom_inter)

lemma fdom_comp [simp]: "fdom (g \<circ>\<^sub>f f) = fdom (f \<rhd>\<^sub>f fdom g)"
  by (transfer, auto)

lemma fdom_upd [simp]: "fdom (f(k \<mapsto> v)\<^sub>f) = insert k (fdom f)"
  by (transfer, simp)

lemma fdom_fdom_res [simp]: "fdom (A \<lhd>\<^sub>f f) = A \<inter> fdom(f)"
  by (transfer, auto)

lemma fdom_graph_ffun [simp]:
  "finite (Domain R) \<Longrightarrow> fdom (graph_ffun R) = Domain R"
  by (transfer, simp add: Domain_fst graph_map_dom)

subsection \<open> Range laws \<close>

lemma fran_zero [simp]: "fran 0 = {}"
  by (transfer, simp)

lemma fran_upd [simp]: "fran (f(k \<mapsto> v)\<^sub>f) = insert v (fran ((- {k}) \<lhd>\<^sub>f f))"
  by (transfer, auto)

lemma fran_fran_res [simp]: "fran (f \<rhd>\<^sub>f A) = fran(f) \<inter> A"
  by (transfer, auto)

lemma fran_comp [simp]: "fran (g \<circ>\<^sub>f f) = fran (fran f \<lhd>\<^sub>f g)"
  by (transfer, auto)

subsection \<open> Domain restriction laws \<close>

lemma fdom_res_zero [simp]: "A \<lhd>\<^sub>f {}\<^sub>f = {}\<^sub>f"
  by (transfer, auto)

lemma fdom_res_empty [simp]:
  "({} \<lhd>\<^sub>f f) = {}\<^sub>f"
  by (transfer, auto)

lemma fdom_res_fdom [simp]:
  "fdom(f) \<lhd>\<^sub>f f = f"
  by (transfer, auto)

lemma pdom_res_upd_in [simp]:
  "k \<in> A \<Longrightarrow> A \<lhd>\<^sub>f f(k \<mapsto> v)\<^sub>f = (A \<lhd>\<^sub>f f)(k \<mapsto> v)\<^sub>f"
  by (transfer, auto)

lemma pdom_res_upd_out [simp]:
  "k \<notin> A \<Longrightarrow> A \<lhd>\<^sub>f f(k \<mapsto> v)\<^sub>f = A \<lhd>\<^sub>f f"
  by (transfer, auto)

lemma fdom_res_override [simp]: "A \<lhd>\<^sub>f (f + g) = (A \<lhd>\<^sub>f f) + (A \<lhd>\<^sub>f g)"
  by (metis fdom_res.rep_eq pdom_res_override pfun_of_inject plus_ffun.rep_eq)

lemma fdom_res_minus [simp]: "A \<lhd>\<^sub>f (f - g) = (A \<lhd>\<^sub>f f) - g"
  by (transfer, auto)

lemma fdom_res_swap: "(A \<lhd>\<^sub>f f) \<rhd>\<^sub>f B = A \<lhd>\<^sub>f (f \<rhd>\<^sub>f B)"
  by (transfer, simp add: pdom_res_swap)

lemma fdom_res_twice [simp]: "A \<lhd>\<^sub>f (B \<lhd>\<^sub>f f) = (A \<inter> B) \<lhd>\<^sub>f f"
  by (transfer, auto)

lemma fdom_res_comp [simp]: "A \<lhd>\<^sub>f (g \<circ>\<^sub>f f) =  g \<circ>\<^sub>f (A \<lhd>\<^sub>f f)"
  by (transfer, simp)

subsection \<open> Range restriction laws \<close>

lemma fran_res_zero [simp]: "{}\<^sub>f \<rhd>\<^sub>f A = {}\<^sub>f"
  by (transfer, auto)

lemma fran_res_upd_1 [simp]: "v \<in> A \<Longrightarrow> f(x \<mapsto> v)\<^sub>f \<rhd>\<^sub>f A = (f \<rhd>\<^sub>f A)(x \<mapsto> v)\<^sub>f"
  by (transfer, auto)

lemma fran_res_upd_2 [simp]: "v \<notin> A \<Longrightarrow> f(x \<mapsto> v)\<^sub>f \<rhd>\<^sub>f A = ((- {x}) \<lhd>\<^sub>f f) \<rhd>\<^sub>f A"
  by (transfer, auto)

lemma fran_res_override: "(f + g) \<rhd>\<^sub>f A \<subseteq>\<^sub>f (f \<rhd>\<^sub>f A) + (g \<rhd>\<^sub>f A)"
  by (transfer, simp add: pran_res_override)

subsection \<open> Graph laws \<close>

lemma ffun_graph_inv: "graph_ffun (ffun_graph f) = f"
  by (transfer, auto simp add: pfun_graph_inv finite_Domain)

lemma ffun_graph_zero: "ffun_graph 0 = {}"
  by (transfer, simp add: pfun_graph_zero)

lemma ffun_graph_minus: "ffun_graph (f - g) = ffun_graph f - ffun_graph g"
  by (transfer, simp add: pfun_graph_minus)

lemma ffun_graph_inter: "ffun_graph (f \<inter>\<^sub>f g) = ffun_graph f \<inter> ffun_graph g"
  by (transfer, simp add: pfun_graph_inter)

subsection \<open> Partial Function Lens \<close>

definition ffun_lens :: "'a \<Rightarrow> ('b \<Longrightarrow> ('a, 'b) ffun)" where
[lens_defs]: "ffun_lens i = \<lparr> lens_get = \<lambda> s. s(i)\<^sub>f, lens_put = \<lambda> s v. s(i \<mapsto> v)\<^sub>f \<rparr>"

lemma ffun_lens_mwb [simp]: "mwb_lens (ffun_lens i)"
  by (unfold_locales, simp_all add: ffun_lens_def)

lemma ffun_lens_src: "\<S>\<^bsub>ffun_lens i\<^esub> = {f. i \<in> fdom(f)}"
  by (auto simp add: lens_defs lens_source_def, metis ffun_upd_ext)

text \<open> Hide implementation details for finite functions \<close>

lifting_update ffun.lifting
lifting_forget ffun.lifting

end


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

section \<open>Main Observations on Operations and Permutations\<close>

theory Twelvefold_Way_Core
imports Preliminaries
begin

subsection \<open>Range Multiset\<close>

subsubsection \<open>Existence of a Suitable Finite Function\<close>

lemma obtain_function:
  assumes "finite A"
  assumes "size M = card A"
  shows "\<exists>f. image_mset f (mset_set A) = M"
using assms
proof (induct arbitrary: M rule: finite_induct)
  case empty
  from this show ?case by simp
next
  case (insert x A)
  from insert(1,2,4) have "size M > 0"
    by (simp add: card_gt_0_iff)
  from this obtain y where "y \<in># M"
    using gr0_implies_Suc size_eq_Suc_imp_elem by blast
  from insert(1,2,4) this have "size (M - {#y#}) = card A"
    by (simp add: Diff_insert_absorb card_Diff_singleton_if insertI1 size_Diff_submset)
  from insert.hyps this obtain f' where "image_mset f' (mset_set A) = M - {#y#}" by blast
  from this have "image_mset (f'(x := y)) (mset_set (insert x A)) = M"
    using \<open>finite A\<close> \<open>x \<notin> A\<close> \<open>y \<in># M\<close> by (simp add: image_mset_fun_upd)
  from this show ?case by blast
qed

lemma obtain_function_on_ext_funcset:
  assumes "finite A"
  assumes "size M = card A"
  shows "\<exists>f \<in> A \<rightarrow>\<^sub>E set_mset M. image_mset f (mset_set A) = M"
proof -
  obtain f where range_eq_M: "image_mset f (mset_set A) = M"
    using obtain_function \<open>finite A\<close> \<open>size M = card A\<close> by blast
  let ?f = "\<lambda>x. if x \<in> A then f x else undefined"
  have "?f \<in> A \<rightarrow>\<^sub>E set_mset M"
    using range_eq_M \<open>finite A\<close> by auto
  moreover have "image_mset ?f (mset_set A) = M"
    using range_eq_M \<open>finite A\<close> by (auto intro: multiset.map_cong0)
  ultimately show ?thesis by auto
qed

subsubsection \<open>Existence of Permutation\<close>

lemma image_mset_eq_implies_bij_betw:
  fixes f :: "'a1 \<Rightarrow> 'b" and f' :: "'a2 \<Rightarrow> 'b"
  assumes "finite A" "finite A'"
  assumes mset_eq: "image_mset f (mset_set A) = image_mset f' (mset_set A')"
  obtains bij where "bij_betw bij A A'" and "\<forall>x\<in>A. f x = f' (bij x)"
proof -
  from \<open>finite A\<close> have [simp]: "finite {a \<in> A. f a = (b::'b)}" for b by auto
  from \<open>finite A'\<close> have [simp]: "finite {a \<in> A'. f' a = (b::'b)}" for b by auto
  have "f ` A = f' ` A'"
  proof -
    have "f ` A = f ` (set_mset (mset_set A))" using \<open>finite A\<close> by simp
    also have "\<dots> = f' ` (set_mset (mset_set A'))"
      by (metis mset_eq multiset.set_map)
    also have "\<dots> = f' ` A'" using \<open>finite A'\<close> by simp
    finally show ?thesis .
  qed
  have "\<forall>b\<in>(f ` A). \<exists>bij. bij_betw bij {a \<in> A. f a = b} {a \<in> A'. f' a = b}"
  proof
    fix b
    from mset_eq have
      "count (image_mset f (mset_set A)) b = count (image_mset f' (mset_set A')) b" by simp
    from this have "card {a \<in> A. f a = b} = card {a \<in> A'. f' a = b}"
      using \<open>finite A\<close> \<open>finite A'\<close>
      by (simp add: count_image_mset_eq_card_vimage)
    from this show "\<exists>bij. bij_betw bij {a \<in> A. f a = b} {a \<in> A'. f' a = b}"
      by (intro finite_same_card_bij) simp_all
  qed
  hence "\<exists>bij. \<forall>b\<in>f ` A. bij_betw (bij b) {a \<in> A. f a = b} {a \<in> A'. f' a = b}"
    by (rule bchoice)
  then guess bij .. note bij = this
  define bij' where "bij' = (\<lambda>a. bij (f a) a)"
  have "bij_betw bij' A A'"
  proof -
    have "disjoint_family_on (\<lambda>i. {a \<in> A'. f' a = i}) (f ` A)"
      unfolding disjoint_family_on_def by auto
    moreover have "bij_betw (\<lambda>a. bij (f a) a) {a \<in> A. f a = b} {a \<in> A'. f' a = b}" if b: "b \<in> f ` A" for b
      using bij b by (subst bij_betw_cong[where g="bij b"]) auto
    ultimately have "bij_betw (\<lambda>a. bij (f a) a) (\<Union>b\<in>f ` A. {a \<in> A. f a = b}) (\<Union>b\<in>f ` A. {a \<in> A'. f' a = b})"
      by (rule bij_betw_UNION_disjoint)
    moreover have "(\<Union>b\<in>f ` A. {a \<in> A. f a = b}) = A" by auto
    moreover have "(\<Union>b\<in>f ` A. {a \<in> A'. f' a = b}) = A'" using \<open>f ` A = f' ` A'\<close> by auto
    ultimately show "bij_betw bij' A A'"
      unfolding bij'_def by (subst bij_betw_cong[where g="(\<lambda>a. bij (f a) a)"]) auto
  qed
  moreover from bij have "\<forall>x\<in>A. f x = f' (bij' x)"
    unfolding bij'_def using bij_betwE by fastforce
  ultimately show ?thesis by (rule that)
qed

lemma image_mset_eq_implies_permutes:
  fixes f :: "'a \<Rightarrow> 'b"
  assumes "finite A"
  assumes mset_eq: "image_mset f (mset_set A) = image_mset f' (mset_set A)"
  obtains p where "p permutes A" and "\<forall>x\<in>A. f x = f' (p x)"
proof -
  from assms obtain b where "bij_betw b A A" and "\<forall>x\<in>A. f x = f' (b x)"
    using image_mset_eq_implies_bij_betw by blast
  define p where "p = (\<lambda>a. if a \<in> A then b a else a)"
  have "p permutes A"
  proof (rule bij_imp_permutes)
    show "bij_betw p A A"
      unfolding p_def by (simp add: \<open>bij_betw b A A\<close> bij_betw_cong)
  next
    fix x
    assume "x \<notin> A"
    from this show "p x = x"
      unfolding p_def by simp
  qed
  moreover from \<open>\<forall>x\<in>A. f x = f' (b x)\<close> have "\<forall>x\<in>A. f x = f' (p x)"
    unfolding p_def by simp
  ultimately show ?thesis by (rule that)
qed

subsection \<open>Domain Partition\<close>

subsubsection \<open>Existence of a Suitable Finite Function\<close>

lemma obtain_function_with_partition:
  assumes "finite A" "finite B"
  assumes "partition_on A P"
  assumes "card P \<le> card B"
  shows "\<exists>f \<in> A \<rightarrow>\<^sub>E B. (\<lambda>b. {x \<in> A. f x = b}) ` B - {{}} = P"
proof -
  obtain g' where "bij_betw g' P (g' ` P)" and "g' ` P \<subseteq> B"
    by (meson assms card_le_inj finite_elements inj_on_imp_bij_betw)
  define f where "\<And>a. f a = (if a \<in> A then g' (THE X. a \<in> X \<and> X \<in> P) else undefined)"
  have "f \<in> A \<rightarrow>\<^sub>E B"
  unfolding f_def
  using \<open>g' ` P \<subseteq> B\<close> assms(3) partition_on_the_part_mem by fastforce
  moreover have "(\<lambda>b. {x \<in> A. f x = b}) ` B - {{}} = P"
  proof
    show "(\<lambda>b. {x \<in> A. f x = b}) ` B - {{}} \<subseteq> P"
    proof
      fix X
      assume X:"X \<in> (\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}"
      from this obtain b where "b \<in> B" and "X = {x' \<in> A. f x' = b}" by auto
      from this X obtain a where "a \<in> A" and "a \<in> X" and "f a = b" by blast
      have "(THE X. a \<in> X \<and> X \<in> P) \<in> P"
        using \<open>a \<in> A\<close> \<open>partition_on A P\<close> by (simp add: partition_on_the_part_mem)
      from \<open>X = {x' \<in> A. f x' = b}\<close> have X_eq1: "X = {x' \<in> A. g' (THE X. x' \<in> X \<and> X \<in> P) = b}"
        unfolding f_def by auto
      also have "\<dots> = {x' \<in> A. (THE X. x' \<in> X \<and> X \<in> P) = inv_into P g' b}"
      proof -
        {
          fix x'
          assume "x' \<in> A"
          have "(THE X. x' \<in> X \<and> X \<in> P) \<in> P"
            using \<open>partition_on A P\<close> \<open>x' \<in> A\<close> by (simp add: partition_on_the_part_mem)
          from X_eq1 \<open>a \<in> X\<close> have "g' (THE X. a \<in> X \<and> X \<in> P) = b"
            unfolding f_def by auto
          from this \<open>(THE X. a \<in> X \<and> X \<in> P) \<in> P\<close> have "b \<in> g' ` P" by auto
          have "(g' (THE X. x' \<in> X \<and> X \<in> P) = b) \<longleftrightarrow> ((THE X. x' \<in> X \<and> X \<in> P) = inv_into P g' b)"
          proof -
            from \<open>(THE X. x' \<in> X \<and> X \<in> P) \<in> P\<close>
            have "(g' (THE X. x' \<in> X \<and> X \<in> P) = b) \<longleftrightarrow> (inv_into P g' (g' (THE X. x' \<in> X \<and> X \<in> P)) = inv_into P g' b)"
              using \<open>b \<in> g' ` P\<close> by (auto intro: inv_into_injective)
            moreover have "inv_into P g' (g' (THE X. x' \<in> X \<and> X \<in> P)) = (THE X. x' \<in> X \<and> X \<in> P)"
              using \<open>bij_betw g' P (g' ` P)\<close> \<open>(THE X. x' \<in> X \<and> X \<in> P) \<in> P\<close>
              by (simp add: bij_betw_inv_into_left)
            ultimately show ?thesis by simp
          qed
        }
        from this show ?thesis by auto
      qed
      finally have X_eq: "X = {x' \<in> A. (THE X. x' \<in> X \<and> X \<in> P) = inv_into P g' b}" .
      moreover have "inv_into P g' b \<in> P"
      proof -
        from X_eq have eq: "inv_into P g' b = (THE X. a \<in> X \<and> X \<in> P)"
          using \<open>a \<in> X\<close> \<open>a \<in> A\<close> by auto
        from this show ?thesis
          using \<open>(THE X. a \<in> X \<and> X \<in> P) \<in> P\<close> by simp
      qed
      ultimately have "X = inv_into P g' b"
        using partition_on_all_in_part_eq_part[OF \<open>partition_on A P\<close>] by blast
      from this \<open>inv_into P g' b \<in> P\<close> show "X \<in> P" by blast
    qed
  next
    show "P \<subseteq> (\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}"
    proof
      fix X
      assume "X \<in> P"
      from assms(3) this have "X \<noteq> {}"
        by (auto elim: partition_onE)
      moreover have "X \<in> (\<lambda>b. {x \<in> A. f x = b}) ` B"
      proof
        show "g' X \<in> B"
          using \<open>X \<in> P\<close> \<open>g' ` P \<subseteq> B\<close> by blast
        show "X = {x \<in> A. f x = g' X}"
        proof
          show "X \<subseteq> {x \<in> A. f x = g' X}"
          proof
            fix x
            assume "x \<in> X"
            from this have "x \<in> A"
              using \<open>X \<in> P\<close> assms(3) by (fastforce elim: partition_onE)
            have "(THE X. x \<in> X \<and> X \<in> P) = X"
              using \<open>X \<in> P\<close> \<open>x \<in> X\<close> assms(3) partition_on_the_part_eq by fastforce
            from this \<open>x \<in> A\<close> have "f x = g' X"
              unfolding f_def by auto
            from this \<open>x \<in> A\<close> show "x \<in> {x \<in> A. f x = g' X}" by auto
          qed
        next
          show "{x \<in> A. f x = g' X} \<subseteq> X"
          proof
            fix x
            assume "x \<in> {x \<in> A. f x = g' X}"
            from this have "x \<in> A" and g_eq: "g' (THE X. x \<in> X \<and> X \<in> P) = g' X"
              unfolding f_def by auto
            from \<open>x \<in> A\<close> have "(THE X. x \<in> X \<and> X \<in> P) \<in> P"
              using assms(3) by (simp add: partition_on_the_part_mem)
            from this g_eq have "(THE X. x \<in> X \<and> X \<in> P) = X"
              using \<open>X \<in> P\<close> \<open>bij_betw g' P (g' ` P)\<close>
              by (metis bij_betw_inv_into_left)
            from this \<open>x \<in> A\<close> assms(3) show "x \<in> X"
              using partition_on_in_the_unique_part by fastforce
          qed
        qed
      qed
      ultimately show "X \<in> (\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}"
        by auto
    qed
  qed
  ultimately show ?thesis by blast
qed

subsubsection \<open>Equality under Permutation Application\<close>

subsubsection \<open>Existence of Permutation\<close>

lemma the_elem:
  assumes "f \<in> A \<rightarrow>\<^sub>E B" "f' \<in> A \<rightarrow>\<^sub>E B"
  assumes partitions_eq: "(\<lambda>b. {x \<in> A. f x = b}) ` B - {{}} = (\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}}"
  assumes "x \<in> A"
  shows "the_elem (f ` {xa \<in> A. f' xa = f' x}) = f x"
proof -
  from \<open>x \<in> A\<close> have x: "x \<in> {x' \<in> A. f' x' = f' x}" by blast
  have "f' x \<in> B"
    using \<open>x \<in> A\<close> \<open>f' \<in> A \<rightarrow>\<^sub>E B\<close> by blast
  from this have "{x' \<in> A. f' x' = f' x} \<in> (\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}}"
    using \<open>x \<in> A\<close> by blast
  from this have "{x' \<in> A. f' x' = f' x} \<in> (\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}"
    using partitions_eq by blast
  from this obtain b where eq: "{x' \<in> A. f' x' = f' x} = {x' \<in> A. f x' = b}" by blast
  also from x this show "the_elem (f ` {x' \<in> A. f' x' = f' x}) = f x"
    by (metis (mono_tags, lifting) empty_iff mem_Collect_eq the_elem_image_unique)
qed

lemma the_elem_eq:
  assumes "f \<in> A \<rightarrow>\<^sub>E B"
  assumes "b \<in> f ` A"
  shows "the_elem (f ` {x' \<in> A. f x' = b}) = b"
proof -
  from \<open>b \<in> f ` A\<close> obtain a where "a \<in> A" and "b = f a" by blast
  from this show "the_elem (f ` {x' \<in> A. f x' = b}) = b"
    using the_elem[OF \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> \<open>f \<in> A \<rightarrow>\<^sub>E B\<close>] by simp
qed

lemma partitions_eq_implies:
  assumes "f \<in> A \<rightarrow>\<^sub>E B" "f' \<in> A \<rightarrow>\<^sub>E B"
  assumes partitions_eq: "(\<lambda>b. {x \<in> A. f x = b}) ` B - {{}} = (\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}}"
  assumes "x \<in> A" "x' \<in> A"
  assumes "f x = f x'"
  shows "f' x = f' x'"
proof -
  have "f x \<in> B" and "x \<in> {a \<in> A. f a = f x}" and "x' \<in> {a \<in> A. f a = f x}"
    using \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> \<open>x \<in> A\<close> \<open>x' \<in> A\<close> \<open>f x = f x'\<close> by auto
  moreover have "{a \<in> A. f a = f x} \<in> (\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}"
    using \<open>f x \<in> B\<close> \<open>x \<in> {a \<in> A. f a = f x}\<close> by auto
  ultimately obtain b where "x \<in> {a \<in> A. f' a = b}" and "x' \<in> {a \<in> A. f' a = b}"
    using partitions_eq by (metis (no_types, lifting) Diff_iff imageE)
  from this show "f' x = f' x'" by auto
qed

lemma card_domain_partitions:
  assumes "f \<in> A \<rightarrow>\<^sub>E B"
  assumes "finite B"
  shows "card ((\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}) = card (f ` A)"
proof -
  note [simp] = the_elem_eq[OF \<open>f \<in> A \<rightarrow>\<^sub>E B\<close>]
  have "bij_betw (\<lambda>X. the_elem (f ` X)) ((\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}) (f ` A)"
  proof (rule bij_betw_imageI)
    show "inj_on (\<lambda>X. the_elem (f ` X)) ((\<lambda>b. {x \<in> A. f x = b}) ` B - {{}})"
    proof (rule inj_onI)
      fix X X'
      assume X: "X \<in> (\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}"
      assume X': "X' \<in> (\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}"
      assume eq: "the_elem (f ` X) = the_elem (f ` X')"
      from X obtain b where "b \<in> B" and X_eq: "X = {x \<in> A. f x = b}" by blast
      from X this have "b \<in> f ` A"
        using Collect_empty_eq Diff_iff image_iff insertCI by auto
      from X' obtain b' where "b' \<in> B" and X'_eq: "X' = {x \<in> A. f x = b'}" by blast
      from X' this have "b' \<in> f ` A"
        using Collect_empty_eq Diff_iff image_iff insertCI by auto
      from X_eq X'_eq eq \<open>\<And>b. b \<in> f ` A \<Longrightarrow> the_elem (f ` {x' \<in> A. f x' = b}) = b\<close> \<open>b \<in> f ` A\<close> \<open>b' \<in> f ` A\<close>
        have "b = b'" by auto
      from this show "X = X'"
        using X_eq X'_eq by simp
    qed
    show "(\<lambda>X. the_elem (f ` X)) ` ((\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}) = f ` A"
    proof
      show "(\<lambda>X. the_elem (f ` X)) ` ((\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}) \<subseteq> f ` A"
        using \<open>\<And>b. b \<in> f ` A \<Longrightarrow> the_elem (f ` {x' \<in> A. f x' = b}) = b\<close> by auto
    next
      show "f ` A \<subseteq> (\<lambda>X. the_elem (f ` X)) ` ((\<lambda>b. {x \<in> A. f x = b}) ` B - {{}})"
      proof
        fix b
        assume "b \<in> f ` A"
        from this have "b = the_elem (f ` {x \<in> A. f x = b})"
          using \<open>\<And>b. b \<in> f ` A \<Longrightarrow> the_elem (f ` {x' \<in> A. f x' = b}) = b\<close> by auto
        moreover from \<open>b \<in> f ` A\<close> have " {x \<in> A. f x = b} \<in> (\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}"
          using \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> by auto
        ultimately show "b \<in> (\<lambda>X. the_elem (f ` X)) ` ((\<lambda>b. {x \<in> A. f x = b}) ` B - {{}})" ..
      qed
    qed
  qed
  from this show ?thesis by (rule bij_betw_same_card)
qed

lemma partitions_eq_implies_permutes:
  assumes "f \<in> A \<rightarrow>\<^sub>E B" "f' \<in> A \<rightarrow>\<^sub>E B"
  assumes "finite B"
  assumes partitions_eq: "(\<lambda>b. {x \<in> A. f x = b}) ` B - {{}} = (\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}}"
  shows "\<exists>p. p permutes B \<and> (\<forall>x\<in>A. f x = p (f' x))"
proof -
  have card_eq: "card (f' ` A) = card (f ` A)"
    using card_domain_partitions[OF \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> \<open>finite B\<close>]
    using card_domain_partitions[OF \<open>f' \<in> A \<rightarrow>\<^sub>E B\<close> \<open>finite B\<close>]
    using partitions_eq by simp
  have "f' ` A \<subseteq> B" "f ` A \<subseteq> B"
    using \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> \<open>f' \<in> A \<rightarrow>\<^sub>E B\<close> by auto
  from this card_eq have "card (B - f' ` A) = card (B - f ` A)"
    using \<open>finite B\<close> by (auto simp add: card_Diff_subset finite_subset)
  from this obtain p' where "bij_betw p' (B - f' ` A) (B - f ` A)"
    using \<open>finite B\<close> by (metis finite_same_card_bij finite_Diff)
  from this have "p' ` (B - f' ` A) = (B - f ` A)"
    by (simp add: bij_betw_imp_surj_on)
  define p where "\<And>b. p b = (if b \<in> B then
    (if b \<in> f' ` A then the_elem (f ` {x \<in> A. f' x = b}) else p' b) else b)"
  have "\<forall>x\<in>A. f x = p (f' x)"
  proof
    fix x
    assume "x \<in> A"
    from this partitions_eq have "the_elem (f ` {xa \<in> A. f' xa = f' x}) = f x"
      using the_elem[OF \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> \<open>f' \<in> A \<rightarrow>\<^sub>E B\<close>] by auto
    from this show "f x = p (f' x)"
      using \<open>x \<in> A\<close> p_def \<open>f' \<in> A \<rightarrow>\<^sub>E B\<close> by auto
  qed
  moreover have "p permutes B"
  proof (rule bij_imp_permutes)
    let ?invp = "\<lambda>b. if b \<in> f ` A then the_elem (f' ` {x \<in> A. f x = b}) else b"
    note [simp] = the_elem[OF \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> \<open>f' \<in> A \<rightarrow>\<^sub>E B\<close> partitions_eq]
    show "bij_betw p B B"
    proof (rule bij_betw_imageI)
      show "p ` B = B"
      proof
        have "(\<lambda>b. the_elem (f ` {x \<in> A. f' x = b})) ` (f' ` A) \<subseteq> B"
          using \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> by auto
        from \<open>p' ` (B - f' ` A) = (B - f ` A)\<close> this show "p ` B \<subseteq> B"
          unfolding p_def \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> by force
      next
        show "B \<subseteq> p ` B"
        proof
          fix b
          assume "b \<in> B"
          show "b \<in> p ` B"
          proof (cases "b \<in> f ` A")
            assume "b \<notin> f ` A"
            note \<open>p' ` (B - f' ` A) = (B - f ` A)\<close>
            from this \<open>b \<in> B\<close> \<open>b \<notin> f ` A\<close> show ?thesis
              unfolding p_def by auto
          next
            assume "b \<in> f ` A"
            from this \<open>\<forall>x\<in>A. f x = p (f' x)\<close> \<open>b \<in> B\<close> show ?thesis
              using \<open>f' \<in> A \<rightarrow>\<^sub>E B\<close> by auto
          qed
        qed
      qed
    next
      show "inj_on p B"
      proof (rule inj_onI)
        fix b b'
        assume "b \<in> B" "b' \<in> B" "p b = p b'"
        have "b \<in> f' ` A \<longleftrightarrow> b' \<in> f' ` A"
        proof -
          have "b \<in> f' ` A \<longleftrightarrow> p b \<in> f ` A"
            unfolding p_def using \<open>b \<in> B\<close> \<open>p' ` (B - f' ` A) = B - f ` A\<close> by auto
          also have "p b \<in> f ` A \<longleftrightarrow> p b' \<in> f ` A"
            using \<open>p b = p b'\<close> by simp
          also have "p b' \<in> f ` A \<longleftrightarrow> b' \<in> f' ` A"
            unfolding p_def using \<open>b' \<in> B\<close> \<open>p' ` (B - f' ` A) = B - f ` A\<close> by auto
          finally show ?thesis .
        qed
        from this have "(b \<in> f' ` A \<and> b' \<in> f' ` A) \<or> (b \<notin> f' ` A \<and> b' \<notin> f' ` A)" by blast
        from this show "b = b'"
        proof
          assume "b \<in> f' ` A \<and> b' \<in> f' ` A"
          from this obtain a a' where "a \<in> A" "b = f' a" and "a' \<in> A" "b' = f' a'" by auto
          from this \<open>b \<in> B\<close> \<open>b' \<in> B\<close> have "p b = f a" "p b' = f a'"
            unfolding p_def by auto
          from this \<open>p b = p b'\<close> have "f a = f a'" by simp
          from this have "f' a = f' a'"
            using partitions_eq_implies[OF \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> \<open>f' \<in> A \<rightarrow>\<^sub>E B\<close> partitions_eq]
            using \<open>a \<in> A\<close> \<open>a' \<in> A\<close> by blast
          from this show "b = b'"
            using \<open>b' = f' a'\<close> \<open>b = f' a\<close> by simp
        next
          assume "b \<notin> f' ` A \<and> b' \<notin> f' ` A"
          from this \<open>b \<in> B\<close> \<open>b' \<in> B\<close> have "p b' = p' b'" "p b = p' b"
            unfolding p_def by auto
          from this \<open>p b = p b'\<close> have "p' b = p' b'" by simp
          moreover have "b \<in> B - f' ` A" "b' \<in> B - f' ` A"
            using \<open>b \<in> B\<close> \<open>b' \<in> B\<close> \<open>b \<notin> f' ` A \<and> b' \<notin> f' ` A\<close> by auto
          ultimately show "b = b'"
            using \<open>bij_betw p' _ _\<close> by (metis bij_betw_inv_into_left)
        qed
      qed
    qed
  next
    fix x
    assume "x \<notin> B"
    from this show "p x = x"
      using \<open>f' \<in> A \<rightarrow>\<^sub>E B\<close> p_def by auto
  qed
  ultimately show ?thesis by blast
qed

subsection \<open>Number Partition of Range\<close>

subsubsection \<open>Existence of a Suitable Finite Function\<close>

lemma obtain_partition:
  assumes "finite A"
  assumes "number_partition (card A) N"
  shows "\<exists>P. partition_on A P \<and> image_mset card (mset_set P) = N"
using assms
proof (induct N arbitrary: A)
  case empty
  from this have "A = {}"
    unfolding number_partition_def by auto
  from this have "partition_on A {}" by (simp add: partition_on_empty)
  moreover have "image_mset card (mset_set {}) = {#}" by simp
  ultimately show ?case by blast
next
  case (add x N)
  from add.prems(2) have "0 \<notin># add_mset x N" and "sum_mset (add_mset x N) = card A"
    unfolding number_partition_def by auto
  from this have "x \<le> card A" by auto
  from this obtain X where "X \<subseteq> A" and "card X = x"
    using subset_with_given_card_exists by auto
  from this have "X \<noteq> {}"
    using \<open>0 \<notin># add_mset x N\<close> \<open>finite A\<close> by auto
  have "sum_mset N = card (A - X)"
    using \<open>sum_mset (add_mset x N) = card A\<close> \<open>card X = x\<close> \<open>X \<subseteq> A\<close>
    by (metis add.commute add.prems(1) add_diff_cancel_right' card_Diff_subset infinite_super sum_mset.add_mset)
  from this \<open>0 \<notin># add_mset x N\<close> have "number_partition (card (A - X)) N"
    unfolding number_partition_def by auto
  from this obtain P where "partition_on (A - X) P" and eq_N: "image_mset card (mset_set P) = N"
    using add.hyps \<open>finite A\<close> by auto
  from \<open>partition_on (A - X) P\<close> have "finite P"
    using \<open>finite A\<close> finite_elements by blast
  from \<open>partition_on (A - X) P\<close> have "X \<notin> P"
    using \<open>X \<noteq> {}\<close> partition_onD1 by fastforce
  have "partition_on A (insert X P)"
    using \<open>partition_on (A - X) P\<close> \<open>X \<subseteq> A\<close> \<open>X \<noteq> {}\<close>
    by (rule partition_on_insert')
  moreover have "image_mset card (mset_set (insert X P)) = add_mset x N"
    using eq_N \<open>card X = x\<close> \<open>finite P\<close> \<open>X \<notin> P\<close> by simp
  ultimately show ?case by blast
qed

lemma obtain_extensional_function_from_number_partition:
  assumes "finite A" "finite B"
  assumes "number_partition (card A) N"
  assumes "size N \<le> card B"
  shows "\<exists>f\<in>A \<rightarrow>\<^sub>E B. image_mset (\<lambda>X. card X) (mset_set (((\<lambda>b. {x \<in> A. f x = b})) ` B - {{}})) = N"
proof -
  obtain P where "partition_on A P" and eq_N: "image_mset card (mset_set P) = N"
    using assms obtain_partition by blast
  from eq_N[symmetric] \<open>size N \<le> card B\<close> have "card P \<le> card B" by simp
  from \<open>partition_on A P\<close> this obtain f where "f \<in> A \<rightarrow>\<^sub>E B"
    and eq_P: "(\<lambda>b. {x \<in> A. f x = b}) ` B - {{}} = P"
    using obtain_function_with_partition[OF \<open>finite A\<close> \<open>finite B\<close>] by blast
  have "image_mset (\<lambda>X. card X) (mset_set (((\<lambda>b. {x \<in> A. f x = b})) ` B - {{}})) = N"
    using eq_P eq_N by simp
  from this \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> show ?thesis by auto
qed

subsubsection \<open>Equality under Permutation Application\<close>

lemma permutes_implies_multiset_of_partition_cards_eq:
  assumes "p\<^sub>A permutes A" "p\<^sub>B permutes B"
  shows "image_mset card (mset_set ((\<lambda>b. {x \<in> A. p\<^sub>B (f' (p\<^sub>A x)) = b}) ` B - {{}})) = image_mset card (mset_set ((\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}}))"
proof -
  have "inj_on ((`) (inv p\<^sub>A)) ((\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}})"
    by (meson \<open>p\<^sub>A permutes A\<close> inj_image_eq_iff inj_onI permutes_surj surj_imp_inj_inv)
  have "image_mset card (mset_set ((\<lambda>b. {x \<in> A. p\<^sub>B (f' (p\<^sub>A x)) = b}) ` B - {{}})) =
    image_mset card (mset_set ((\<lambda>X. inv p\<^sub>A ` X) ` ((\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}})))"
  proof -
    have "(\<lambda>b. {x \<in> A. p\<^sub>B (f' (p\<^sub>A x)) = b}) ` B - {{}} = (\<lambda>b. {x \<in> A. f' (p\<^sub>A x) = b}) ` B - {{}}"
      using permutes_implies_inv_image_on_eq[OF \<open>p\<^sub>B permutes B\<close>] by metis
    also have "\<dots> = (\<lambda>b. inv p\<^sub>A ` {x \<in> A. f' x = b}) ` B - {{}}"
    proof -
      have "{x \<in> A. f' (p\<^sub>A x) = b} = inv p\<^sub>A ` {x \<in> A. f' x = b}" for b
      proof
        show "{x \<in> A. f' (p\<^sub>A x) = b} \<subseteq> inv p\<^sub>A ` {x \<in> A. f' x = b}"
        proof
          fix x
          assume "x \<in> {x \<in> A. f' (p\<^sub>A x) = b}"
          from this have "x \<in> A" "f' (p\<^sub>A x) = b" by auto
          moreover from this \<open>p\<^sub>A permutes A\<close> have "p\<^sub>A x \<in> A" by (simp add: permutes_in_image)
          moreover from \<open>p\<^sub>A permutes A\<close> have "x = inv p\<^sub>A (p\<^sub>A x)"
            using permutes_inverses(2) by fastforce
          ultimately show "x \<in> inv p\<^sub>A ` {x \<in> A. f' x = b}" by auto
        qed
      next
        show "inv p\<^sub>A ` {x \<in> A. f' x = b} \<subseteq> {x \<in> A. f' (p\<^sub>A x) = b}"
        proof
          fix x
          assume "x \<in> inv p\<^sub>A ` {x \<in> A. f' x = b}"
          from this obtain x' where x: "x = inv p\<^sub>A x'" "x' \<in> A" "f' x' = b" by auto
          from this \<open>p\<^sub>A permutes A\<close> have "x \<in> A" by (simp add: permutes_in_image permutes_inv)
          from \<open>x = inv p\<^sub>A x'\<close> \<open>f' x' = b\<close> have "f' (p\<^sub>A x) = b"
            using \<open>p\<^sub>A permutes A\<close> permutes_inverses(1) by fastforce
          from this \<open>x \<in> A\<close> show "x \<in> {x \<in> A. f' (p\<^sub>A x) = b}" by auto
        qed
      qed
      from this show ?thesis by blast
    qed
    also have "\<dots> = (\<lambda>X. inv p\<^sub>A ` X) ` ((\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}})" by auto
    finally show ?thesis by simp
  qed
  also have "\<dots> = image_mset (\<lambda>X. card (inv p\<^sub>A ` X)) (mset_set ((\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}}))"
    using \<open>inj_on ((`) (inv p\<^sub>A)) ((\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}})\<close>
    by (simp only: image_mset_mset_set[symmetric] image_mset.compositionality) (meson comp_apply)
  also have "\<dots> = image_mset card (mset_set ((\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}}))"
    using \<open>p\<^sub>A permutes A\<close> by (simp add: card_image inj_on_inv_into permutes_surj)
  finally show ?thesis .
qed

subsubsection \<open>Existence of Permutation\<close>

lemma partition_implies_permutes:
  assumes "finite A"
  assumes "partition_on A P" "partition_on A P'"
  assumes "image_mset card (mset_set P') = image_mset card (mset_set P)"
  obtains p where "p permutes A" "P' = (\<lambda>X. p ` X) ` P"
proof -
  from \<open>partition_on A P\<close> \<open>partition_on A P'\<close> have "finite P" "finite P'"
    using \<open>finite A\<close> finite_elements by blast+
  from this \<open>image_mset card (mset_set P') = image_mset card (mset_set P)\<close>
  obtain bij where "bij_betw bij P P'" and "\<forall>X\<in>P. card X = card (bij X)"
    using image_mset_eq_implies_bij_betw by metis
  have "\<forall>X\<in>P. \<exists>p'. bij_betw p' X (bij X)"
  proof
    fix X
    assume "X \<in> P"
    from this have "X \<subseteq> A"
      using \<open>partition_on A P\<close> partition_onD1 by fastforce
    from this have "finite X"
      using \<open>finite A\<close> rev_finite_subset by blast
    from \<open>X \<in> P\<close> have "bij X \<in> P'"
      using \<open>bij_betw bij P P'\<close> bij_betwE by blast
    from this have "bij X \<subseteq> A"
      using \<open>partition_on A P'\<close> partition_onD1 by fastforce
    from this have "finite (bij X)"
      using \<open>finite A\<close> rev_finite_subset by blast
    from \<open>X \<in> P\<close> have "card X = card (bij X)"
      using \<open>\<forall>X\<in>P. card X = card (bij X)\<close> by blast
    from this show "\<exists>p'. bij_betw p' X (bij X)"
      using \<open>finite (bij X)\<close> \<open>finite X\<close> finite_same_card_bij by blast
  qed
  from this have "\<exists>p'. \<forall>X\<in>P. bij_betw (p' X) X (bij X)" by metis
  from this obtain p' where p': "\<forall>X\<in>P. bij_betw (p' X) X (bij X)" ..
  define p where "\<And>a. p a = (if a \<in> A then p' (THE X. a \<in> X \<and> X \<in> P) a else a)"
  have "p permutes A"
  proof -
    have "bij_betw p A A"
    proof -
      have "disjoint_family_on bij P"
      proof
        fix X X'
        assume XX': "X \<in> P" "X' \<in> P" "X \<noteq> X'"
        from this have "bij X \<in> P'" "bij X' \<in> P'"
          using \<open>bij_betw bij P P'\<close> bij_betwE by blast+
        moreover from XX' have "bij X \<noteq> bij X'"
          using \<open>bij_betw bij P P'\<close> by (metis bij_betw_inv_into_left)
        ultimately show "bij X \<inter> bij X' = {}"
          using \<open>partition_on A P'\<close> by (meson partition_onE)
      qed
      moreover have "bij_betw (\<lambda>a. p' (THE X. a \<in> X \<and> X \<in> P) a) X (bij X)" if "X \<in> P" for X
      proof -
        from \<open>X \<in> P\<close> have "bij_betw (p' X) X (bij X)"
          using \<open>\<forall>X\<in>P. bij_betw (p' X) X (bij X)\<close> by blast
        moreover from \<open>X \<in> P\<close> have "\<forall>a\<in>X. (THE X. a \<in> X \<and> X \<in> P) = X"
          using \<open>partition_on A P\<close> partition_on_the_part_eq by fastforce
        ultimately show ?thesis by (auto intro: bij_betw_congI)
      qed
      ultimately have "bij_betw (\<lambda>a. p' (THE X. a \<in> X \<and> X \<in> P) a) (\<Union>X\<in>P. X) (\<Union>X\<in>P. bij X)"
        by (rule bij_betw_UNION_disjoint)
      moreover have "(\<Union>X\<in>P. X) = A" "(\<Union>X\<in>P'. X) = A"
        using \<open>partition_on A P\<close> \<open>partition_on A P'\<close> partition_onD1 by auto
      moreover have "(\<Union>X\<in>P. bij X) = (\<Union>X\<in>P'. X)"
        using \<open>bij_betw bij P P'\<close> bij_betw_imp_surj_on by force
      ultimately have "bij_betw (\<lambda>a. p' (THE X. a \<in> X \<and> X \<in> P) a) A A" by simp
      moreover have "\<forall>a \<in> A. p' (THE X. a \<in> X \<and> X \<in> P) a = p a"
        unfolding p_def by auto
      ultimately show ?thesis by (rule bij_betw_congI)
    qed
    moreover have "p x = x" if "x \<notin> A" for x
      using \<open>x \<notin> A\<close> p_def by auto
    ultimately show ?thesis by (rule bij_imp_permutes)
  qed
  moreover have "P' = (\<lambda>X. p ` X) ` P"
  proof
    show "P' \<subseteq> (\<lambda>X. p ` X) ` P"
    proof
      fix X
      assume "X \<in> P'"
      have in_P: "the_inv_into P bij X \<in> P"
        using \<open>X \<in> P'\<close> \<open>bij_betw bij P P'\<close> bij_betwE bij_betw_the_inv_into by blast
      have eq_X: "bij (the_inv_into P bij X) = X"
        using \<open>X \<in> P'\<close> \<open>bij_betw bij P P'\<close>
        by (meson f_the_inv_into_f_bij_betw)
      have "X = p ` (the_inv_into P bij X)"
      proof
        from in_P have "the_inv_into P bij X \<subseteq> A"
          using \<open>partition_on A P\<close> partition_onD1 by fastforce
        have "(\<lambda>a. p' (THE X. a \<in> X \<and> X \<in> P) a) ` the_inv_into P bij X = X"
        proof
          show "(\<lambda>a. p' (THE X. a \<in> X \<and> X \<in> P) a) ` the_inv_into P bij X \<subseteq> X"
          proof
            fix x
            assume "x \<in> (\<lambda>a. p' (THE X. a \<in> X \<and> X \<in> P) a) ` the_inv_into P bij X"
            from this obtain a where a_in: "a \<in> the_inv_into P bij X"
              and x_eq: "x = p' (THE X. a \<in> X \<and> X \<in> P) a" by blast
            have "(THE X. a \<in> X \<and> X \<in> P) = the_inv_into P bij X"
              using a_in in_P \<open>partition_on A P\<close> partition_on_the_part_eq
              by fastforce
            from this x_eq have x_eq: "x = p' (the_inv_into P bij X) a"
              by auto
            from this have "x \<in> bij (the_inv_into P bij X)"
              using a_in in_P bij_betwE p' by blast
            from this eq_X show "x \<in> X" by blast
          qed
        next
          show "X \<subseteq> (\<lambda>a. p' (THE X. a \<in> X \<and> X \<in> P) a) ` the_inv_into P bij X"
          proof
            fix x
            assume "x \<in> X"
            let ?X' = "the_inv_into P bij X"
            define x' where "x' = the_inv_into ?X' (p' ?X') x"
            from in_P p' eq_X have bij_betw: "bij_betw (p' ?X') ?X' X" by auto
            from bij_betw \<open>x \<in> X\<close> have "x' \<in> ?X'"
              unfolding x'_def
              using bij_betwE bij_betw_the_inv_into by blast
            from this in_P have "(THE X. x' \<in> X \<and> X \<in> P) = ?X'"
              using \<open>partition_on A P\<close> partition_on_the_part_eq by fastforce
            from this \<open>x \<in> X\<close> have "x = p' (THE X. x' \<in> X \<and> X \<in> P) x'"
              unfolding x'_def
              using bij_betw f_the_inv_into_f_bij_betw by fastforce
            from this \<open>x' \<in> ?X'\<close> show "x \<in> (\<lambda>a. p' (THE X. a \<in> X \<and> X \<in> P) a) ` the_inv_into P bij X" ..
          qed
        qed
        from this \<open>the_inv_into P bij X \<subseteq> A\<close> show "X \<subseteq> p ` the_inv_into P bij X"
          unfolding p_def by auto
      next
        show "p ` the_inv_into P bij X \<subseteq> X"
        proof
          fix x
          assume "x \<in> p ` the_inv_into P bij X"
          from this obtain x' where "x = p x'" and "x' \<in> the_inv_into P bij X"
            by auto
          have "x' \<in> A"
            using \<open>x' \<in> the_inv_into P bij X\<close> assms(2) in_P partition_onD1 by fastforce
          have eq: "(THE X. x' \<in> X \<and> X \<in> P) = the_inv_into P bij X"
            using \<open>x' \<in> the_inv_into P bij X\<close> assms(2) in_P partition_on_the_part_eq by fastforce
          have p': "p' (the_inv_into P bij X) x' \<in> X"
            using \<open>x' \<in> the_inv_into P bij X\<close> bij_betwE eq_X in_P p' by blast
          from \<open>x = p x'\<close> \<open>x' \<in> A\<close> eq p' show "x \<in> X"
            unfolding p_def by auto
        qed
      qed
      moreover from \<open>X \<in> P'\<close> \<open>bij_betw bij P P'\<close> have "the_inv_into P bij X \<in> P"
        using bij_betwE bij_betw_the_inv_into by blast
      ultimately show "X \<in> (\<lambda>X. p ` X) ` P" ..
    qed
  next
    show "(\<lambda>X. p ` X) ` P \<subseteq> P'"
    proof
      fix X'
      assume "X' \<in> (\<lambda>X. p ` X) ` P"
      from this obtain X where X'_eq: "X' = p ` X" and "X \<in> P" ..
      from \<open>X \<in> P\<close> have "X \<subseteq> A"
        using assms(2) partition_onD1 by force
      from \<open>X \<in> P\<close> p' have bij: "bij_betw (p' X) X (bij X)" by auto
      have "p ` X \<in> P'"
      proof -
        from \<open>X \<in> P\<close> \<open>bij_betw bij P P'\<close> have "bij X \<in> P'"
          using bij_betwE by blast
        moreover have "(\<lambda>a. p' (THE X. a \<in> X \<and> X \<in> P) a) ` X = bij X"
        proof
          show "(\<lambda>a. p' (THE X. a \<in> X \<and> X \<in> P) a) ` X \<subseteq> bij X"
          proof
            fix x'
            assume "x' \<in> (\<lambda>a. p' (THE X. a \<in> X \<and> X \<in> P) a) ` X"
            from this obtain x where "x \<in> X" and x'_eq: "x' = p' (THE X. x \<in> X \<and> X \<in> P) x" ..
            from \<open>X \<in> P\<close> \<open>x \<in> X\<close> have eq_X: "(THE X. x \<in> X \<and> X \<in> P) = X"
              using assms(2) partition_on_the_part_eq by fastforce
            from bij \<open>x \<in> X\<close> x'_eq eq_X show "x' \<in> bij X"
              using bij_betwE by blast
          qed
        next
          show "bij X \<subseteq> (\<lambda>a. p' (THE X. a \<in> X \<and> X \<in> P) a) ` X"
          proof
            fix x'
            assume "x' \<in> bij X"
            let ?x = "inv_into X (p' X) x'"
            from \<open>x' \<in> bij X\<close> bij have "?x \<in> X"
              by (metis  bij_betw_imp_surj_on inv_into_into)
            from this \<open>X \<in> P\<close> have "(THE X. ?x \<in> X \<and> X \<in> P) = X"
              using assms(2) partition_on_the_part_eq by fastforce
            from this \<open>x' \<in> bij X\<close> bij have "x' = p' (THE X. ?x \<in> X \<and> X \<in> P) ?x"
              using bij_betw_inv_into_right by fastforce
            moreover from \<open>x' \<in> bij X\<close> bij have "?x \<in> X"
              by (metis bij_betw_imp_surj_on inv_into_into)
            ultimately show "x' \<in> (\<lambda>a. p' (THE X. a \<in> X \<and> X \<in> P) a) ` X" ..
          qed
        qed
        ultimately have "(\<lambda>a. p' (THE X. a \<in> X \<and> X \<in> P) a) ` X \<in> P'" by simp
        have "(\<lambda>a. p' (THE X. a \<in> X \<and> X \<in> P) a) ` X = (\<lambda>a. if a \<in> A then p' (THE X. a \<in> X \<and> X \<in> P) a else a) ` X "
          using \<open>X \<subseteq> A\<close> by (auto intro: image_cong)
        from this show ?thesis
         using \<open>(\<lambda>a. p' (THE X. a \<in> X \<and> X \<in> P) a) ` X \<in> P'\<close> unfolding p_def by auto
      qed
      from this X'_eq show "X' \<in> P'" by simp
    qed
  qed
  ultimately show thesis using that by blast
qed

lemma permutes_domain_partition_eq:
  assumes "f \<in> A \<rightarrow> B"
  assumes "p\<^sub>A permutes A"
  assumes "b \<in> B"
  shows "p\<^sub>A ` {x \<in> A. f x = b} = {x \<in> A. f (inv p\<^sub>A x) = b}"
proof
  show "p\<^sub>A ` {x \<in> A. f x = b} \<subseteq> {x \<in> A. f (inv p\<^sub>A x) = b}"
    using \<open>p\<^sub>A permutes A\<close> permutes_in_image permutes_inverses(2) by fastforce
next
  show "{x \<in> A. f (inv p\<^sub>A x) = b} \<subseteq> p\<^sub>A ` {x \<in> A. f x = b}"
  proof
    fix x
    assume "x \<in> {x \<in> A. f (inv p\<^sub>A x) = b}"
    from this have "x \<in> A" "f (inv p\<^sub>A x) = b" by auto
    from \<open>x \<in> A\<close> have "x = p\<^sub>A (inv p\<^sub>A x)"
      using \<open>p\<^sub>A permutes A\<close> permutes_inverses(1) by fastforce
    moreover from \<open>f (inv p\<^sub>A x) = b\<close> \<open>x \<in> A\<close> have "inv p\<^sub>A x \<in> {x \<in> A. f x = b}"
      by (simp add: \<open>p\<^sub>A permutes A\<close> permutes_in_image permutes_inv)
    ultimately show "x \<in> p\<^sub>A ` {x \<in> A. f x = b}" ..
  qed
qed

lemma image_domain_partition_eq:
  assumes "f \<in> A \<rightarrow>\<^sub>E B"
  assumes "p\<^sub>A permutes A"
  shows "(\<lambda>X. p\<^sub>A ` X) ` ((\<lambda>b. {x \<in> A. f x = b}) ` B) = (\<lambda>b. {x \<in> A. f (inv p\<^sub>A x) = b}) ` B"
proof
  from \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> have "f \<in> A \<rightarrow> B" by auto
  note eq = permutes_domain_partition_eq[OF \<open>f \<in> A \<rightarrow> B\<close> \<open>p\<^sub>A permutes A\<close>]
  show "(\<lambda>X. p\<^sub>A ` X) ` (\<lambda>b. {x \<in> A. f x = b}) ` B \<subseteq> (\<lambda>b. {x \<in> A. f (inv p\<^sub>A x) = b}) ` B"
  proof
    fix X
    assume "X \<in> (\<lambda>X. p\<^sub>A ` X) ` (\<lambda>b. {x \<in> A. f x = b}) ` B"
    from this obtain b where "b \<in> B" and X_eq: "X = p\<^sub>A ` {x \<in> A. f x = b}" by auto
    from this eq have "X = {x \<in> A. f (inv p\<^sub>A x) = b}" by simp
    from this \<open>b \<in> B\<close> show "X \<in> (\<lambda>b. {x \<in> A. f (inv p\<^sub>A x) = b}) ` B" ..
  qed
next
  from \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> have "f \<in> A \<rightarrow> B" by auto
  note eq = permutes_domain_partition_eq[OF \<open>f \<in> A \<rightarrow> B\<close> \<open>p\<^sub>A permutes A\<close>, symmetric]
  show "(\<lambda>b. {x \<in> A. f (inv p\<^sub>A x) = b}) ` B \<subseteq> (\<lambda>X. p\<^sub>A ` X) ` (\<lambda>b. {x \<in> A. f x = b}) ` B"
  proof
    fix X
    assume "X \<in> (\<lambda>b. {x \<in> A. f (inv p\<^sub>A x) = b}) ` B"
    from this obtain b where "b \<in> B" and X_eq: "X = {x \<in> A. f (inv p\<^sub>A x) = b}" by auto
    from this eq have "X = p\<^sub>A ` {x \<in> A. f x = b}" by simp
    from this \<open>b \<in> B\<close> show "X \<in> (\<lambda>X. p\<^sub>A ` X) ` (\<lambda>b. {x \<in> A. f x = b}) ` B" by auto
  qed
qed

lemma multiset_of_partition_cards_eq_implies_permutes:
  assumes "finite A" "finite B" "f \<in> A \<rightarrow>\<^sub>E B" "f' \<in> A \<rightarrow>\<^sub>E B"
  assumes eq: "image_mset card (mset_set ((\<lambda>b. {x \<in> A. f x = b}) ` B - {{}})) = image_mset card (mset_set ((\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}}))"
  obtains p\<^sub>A p\<^sub>B where "p\<^sub>A permutes A" "p\<^sub>B permutes B" "\<forall>x\<in>A. f x = p\<^sub>B (f' (p\<^sub>A x))"
proof -
  have "partition_on A ((\<lambda>b. {x \<in> A. f x = b}) ` B - {{}})"
    using \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> by (auto intro!: partition_onI)
  moreover have "partition_on A ((\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}})"
    using \<open>f' \<in> A \<rightarrow>\<^sub>E B\<close> by (auto intro!: partition_onI)
  moreover note partition_implies_permutes[OF \<open>finite A\<close> _ _ eq]
  ultimately obtain p\<^sub>A where "p\<^sub>A permutes A" and
    inv_image_eq: "(\<lambda>b. {x \<in> A. f x = b}) ` B - {{}} =
      (`) p\<^sub>A ` ((\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}})" by blast
  from \<open>p\<^sub>A permutes A\<close> have "inj ((`) p\<^sub>A)"
    by (meson injI inj_image_eq_iff permutes_inj)
  have inv_image_eq': "(\<lambda>b. {x \<in> A. f x = b}) ` B - {{}} = (\<lambda>b. {x \<in> A. f' (inv p\<^sub>A x) = b}) ` B - {{}}"
  proof -
    note inv_image_eq
    also have "(\<lambda>X. p\<^sub>A ` X) ` ((\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}}) = (\<lambda>b. {x \<in> A. f' (inv p\<^sub>A x) = b}) ` B - {{}}"
      using image_domain_partition_eq[OF \<open>f' \<in> A \<rightarrow>\<^sub>E B\<close> \<open>p\<^sub>A permutes A\<close>]
      by (simp add: image_set_diff[OF \<open>inj ((`) p\<^sub>A)\<close>])
    finally show ?thesis .
  qed
  from \<open>p\<^sub>A permutes A\<close> have "inv p\<^sub>A permutes A"
    using permutes_inv by blast
  have "(\<lambda>x. f' (inv p\<^sub>A x)) \<in> A \<rightarrow>\<^sub>E B"
    using \<open>f' \<in> A \<rightarrow>\<^sub>E B\<close> \<open>inv p\<^sub>A permutes A\<close> permutes_in_image by fastforce
  from \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> this \<open>finite B\<close> obtain p\<^sub>B
    where "p\<^sub>B permutes B" and eq'': "\<forall>x\<in>A. f x = p\<^sub>B (f' (inv p\<^sub>A x))"
    using partitions_eq_implies_permutes[OF _ _ _ inv_image_eq'] by blast
  from \<open>inv p\<^sub>A permutes A\<close> \<open>p\<^sub>B permutes B\<close> eq'' that show thesis by blast
qed

subsection \<open>Bijections on Same Domain and Range\<close>

subsubsection \<open>Existence of Domain Permutation\<close>

lemma obtain_domain_permutation_for_two_bijections:
  assumes "bij_betw f A B" "bij_betw f' A B"
  obtains p where "p permutes A" and "\<forall>a\<in>A. f a = f' (p a)"
proof -
  let ?p = "\<lambda>a. if a \<in> A then the_inv_into A f' (f a) else a"
  have "?p permutes A"
  proof (rule bij_imp_permutes)
    show "bij_betw ?p A A"
    proof (rule bij_betw_imageI)
      show "inj_on ?p A"
      proof (rule inj_onI)
        fix a a'
        assume "a \<in> A" "a' \<in> A" "?p a = ?p a'"
        from this have "the_inv_into A f' (f a) = the_inv_into A f' (f a')"
          using \<open>a \<in> A\<close> \<open>a' \<in> A\<close> by simp
        from this have "f a = f a'"
          using \<open>a \<in> A\<close> \<open>a' \<in> A\<close> assms
          by (metis bij_betwE f_the_inv_into_f_bij_betw)
        from this show "a = a'"
          using \<open>a \<in> A\<close> \<open>a' \<in> A\<close> assms
          by (metis bij_betw_inv_into_left)
      qed
    next
      show "?p ` A = A"
      proof
        show "?p ` A \<subseteq> A"
        proof
          fix a
          assume "a \<in> ?p ` A"
          from this obtain a' where "a' \<in> A" and "a = the_inv_into A f' (f a')" by auto
          from this assms show "a \<in> A"
            by (metis bij_betwE bij_betw_imp_inj_on bij_betw_imp_surj_on subset_iff the_inv_into_into)
        qed
      next
        show "A \<subseteq> ?p ` A"
        proof
          fix a
          assume "a \<in> A"
          from this assms have "the_inv_into A f (f' a) \<in> A"
            by (meson bij_betwE bij_betw_the_inv_into)
          moreover from  \<open>a \<in> A\<close> assms have "a = the_inv_into A f' (f (the_inv_into A f (f' a)))"
            by (metis bij_betwE bij_betw_imp_inj_on f_the_inv_into_f_bij_betw the_inv_into_f_eq)
          ultimately show "a \<in> ?p ` A" by auto
        qed
      qed
    qed
  next
    fix a
    assume "a \<notin> A"
    from this show "?p a = a" by auto
  qed
  moreover have "\<forall>a\<in>A. f a = f' (?p a)"
    using \<open>bij_betw f A B\<close> \<open>bij_betw f' A B\<close>
    using bij_betwE f_the_inv_into_f_bij_betw by fastforce
  moreover note that
  ultimately show thesis by auto
qed

subsubsection \<open>Existence of Range Permutation\<close>

lemma obtain_range_permutation_for_two_bijections:
  assumes "bij_betw f A B" "bij_betw f' A B"
  obtains p where "p permutes B" and "\<forall>a\<in>A. f a = p (f' a)"
proof -
  let ?p = "\<lambda>b. if b \<in> B then f (inv_into A f' b) else b"
  have "?p permutes B"
  proof (rule bij_imp_permutes)
    show "bij_betw ?p B B"
    proof (rule bij_betw_imageI)
      show "inj_on ?p B"
      proof (rule inj_onI)
        fix b b'
        assume "b \<in> B" "b' \<in> B" "?p b = ?p b'"
        from this have "f (inv_into A f' b) = f (inv_into A f' b')"
          using \<open>b \<in> B\<close> \<open>b' \<in> B\<close> by simp
        from this have "inv_into A f' b = inv_into A f' b'"
          using \<open>b \<in> B\<close> \<open>b' \<in> B\<close> assms
          by (metis bij_betw_imp_surj_on bij_betw_inv_into_left inv_into_into)
        from this show "b = b'"
          using \<open>b \<in> B\<close> \<open>b' \<in> B\<close> assms(2)
          by (metis bij_betw_inv_into_right)
      qed
    next
      show "?p ` B = B"
      proof
        from assms show "?p ` B \<subseteq> B"
          by (auto simp add: bij_betwE bij_betw_def inv_into_into)
      next
        show "B \<subseteq> ?p ` B"
        proof
          fix b
          assume "b \<in> B"
          from this assms have "f' (inv_into A f b) \<in> B"
            by (metis bij_betwE bij_betw_imp_surj_on inv_into_into)
          moreover have "b = ?p (f' (inv_into A f b))"
            using assms \<open>f' (inv_into A f b) \<in> B\<close> \<open>b \<in> B\<close>
            by (auto simp add: bij_betw_imp_surj_on bij_betw_inv_into_left bij_betw_inv_into_right inv_into_into)
          ultimately show "b \<in> ?p ` B" by auto
        qed
      qed
    qed
  next
    fix b
    assume "b \<notin> B"
    from this show "?p b = b" by auto
  qed
  moreover have "\<forall>a\<in>A. f a = ?p (f' a)"
    using \<open>bij_betw f' A B\<close> bij_betw_inv_into_left bij_betwE by fastforce
  moreover note that
  ultimately show thesis by auto
qed

end


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

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

fun x :: "'a list => 'a list => 'a list" where
"x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun rev :: "'a list => 'a list" where
"rev (nil2) = nil2"
| "rev (cons2 z xs) = x (rev xs) (cons2 z (nil2))"

fun filter :: "('a => bool) => 'a list => 'a list" where
"filter y (nil2) = nil2"
| "filter y (cons2 z2 xs) =
     (if y z2 then cons2 z2 (filter y xs) else filter y xs)"

theorem property0 :
  "((rev (filter p xs)) = (filter p (rev xs)))"
  apply(induct xs arbitrary: p)(*arbitrary: p is optional*)
   apply auto[1]
  apply(subst filter.simps)
  apply(subst rev.simps)
  apply(case_tac "p x1")
   apply simp
   apply(subgoal_tac "\<And>x1 xs revxs.
      TIP_prop_73.rev (TIP_prop_73.filter p xs) = TIP_prop_73.filter p revxs \<Longrightarrow>
      p x1 \<Longrightarrow>
      x (TIP_prop_73.filter p revxs) (cons2 x1 nil2) =
      TIP_prop_73.filter p (x revxs (cons2 x1 nil2))")
    apply fastforce
   apply(induct_tac rule:x.induct)
  oops

end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_prop_44
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

fun y :: "Nat => Nat => bool" where
  "y (Z) (Z) = True"
| "y (Z) (S z2) = False"
| "y (S x2) (Z) = False"
| "y (S x2) (S y22) = y x2 y22"

fun x :: "bool => bool => bool" where
  "x True y2 = True"
| "x False y2 = y2"

fun elem :: "Nat => Nat list => bool" where
  "elem z (nil2) = False"
| "elem z (cons2 z2 xs) = x (y z z2) (elem z xs)"

fun intersect :: "Nat list => Nat list => Nat list" where
  "intersect (nil2) y2 = nil2"
| "intersect (cons2 z2 xs) y2 =
     (if elem z2 y2 then cons2 z2 (intersect xs y2) else
        intersect xs y2)"

theorem property0 :
  "((elem z y2) ==> ((elem z z2) ==> (elem z (intersect y2 z2))))"
  oops

end


(*  Title:       Nested Multisets
    Author:      Dmitriy Traytel <traytel at inf.ethz.ch>, 2016
    Author:      Jasmin Blanchette <jasmin.blanchette at inria.fr>, 2016
    Maintainer:  Dmitriy Traytel <traytel at inf.ethz.ch>
*)

section \<open>Nested Multisets\<close>

theory Nested_Multiset
imports "HOL-Library.Multiset_Order"
begin

declare multiset.map_comp [simp]
declare multiset.map_cong [cong]

subsection \<open>Type Definition\<close>

datatype 'a nmultiset =
  Elem 'a
| MSet "'a nmultiset multiset"

inductive no_elem :: "'a nmultiset \<Rightarrow> bool" where
  "(\<And>X. X \<in># M \<Longrightarrow> no_elem X) \<Longrightarrow> no_elem (MSet M)"

inductive_set sub_nmset :: "('a nmultiset \<times> 'a nmultiset) set" where
  "X \<in># M \<Longrightarrow> (X, MSet M) \<in> sub_nmset"

lemma wf_sub_nmset[simp]: "wf sub_nmset"
proof (rule wfUNIVI)
  fix P :: "'a nmultiset \<Rightarrow> bool" and M :: "'a nmultiset"
  assume IH: "\<forall>M. (\<forall>N. (N, M) \<in> sub_nmset \<longrightarrow> P N) \<longrightarrow> P M"
  show "P M"
    by (induct M; rule IH[rule_format]) (auto simp: sub_nmset.simps)
qed

primrec depth_nmset :: "'a nmultiset \<Rightarrow> nat" ("|_|") where
  "|Elem a| = 0"
| "|MSet M| = (let X = set_mset (image_mset depth_nmset M) in if X = {} then 0 else Suc (Max X))"

lemma depth_nmset_MSet: "x \<in># M \<Longrightarrow> |x| < |MSet M|"
  by (auto simp: less_Suc_eq_le)

declare depth_nmset.simps(2)[simp del]

subsection \<open>Dershowitz and Manna's Nested Multiset Order\<close>

text \<open>The Dershowitz--Manna extension:\<close>

definition less_multiset_ext\<^sub>D\<^sub>M :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset \<Rightarrow> bool" where
  "less_multiset_ext\<^sub>D\<^sub>M R M N \<longleftrightarrow>
   (\<exists>X Y. X \<noteq> {#} \<and> X \<subseteq># N \<and> M = (N - X) + Y \<and> (\<forall>k. k \<in># Y \<longrightarrow> (\<exists>a. a \<in># X \<and> R k a)))"

lemma less_multiset_ext\<^sub>D\<^sub>M_imp_mult:
  assumes
    N_A: "set_mset N \<subseteq> A" and M_A: "set_mset M \<subseteq> A" and less: "less_multiset_ext\<^sub>D\<^sub>M R M N"
  shows "(M, N) \<in> mult {(x, y). x \<in> A \<and> y \<in> A \<and> R x y}"
proof -
  from less obtain X Y where
    "X \<noteq> {#}" and "X \<subseteq># N" and "M = N - X + Y" and "\<forall>k. k \<in># Y \<longrightarrow> (\<exists>a. a \<in># X \<and> R k a)"
    unfolding less_multiset_ext\<^sub>D\<^sub>M_def by blast
  with N_A M_A have "(N - X + Y, N - X + X) \<in> mult {(x, y). x \<in> A \<and> y \<in> A \<and> R x y}"
    by (intro one_step_implies_mult, blast,
      metis (mono_tags, lifting) case_prodI mem_Collect_eq mset_subset_eqD mset_subset_eq_add_right
        subsetCE)
  with \<open>M = N - X + Y\<close> \<open>X \<subseteq># N\<close> show "(M, N) \<in> mult {(x, y). x \<in> A \<and> y \<in> A \<and> R x y}"
    by (simp add: subset_mset.diff_add)
qed

lemma mult_imp_less_multiset_ext\<^sub>D\<^sub>M:
  assumes
    N_A: "set_mset N \<subseteq> A" and M_A: "set_mset M \<subseteq> A" and
    trans: "\<forall>x \<in> A. \<forall>y \<in> A. \<forall>z \<in> A. R x y \<longrightarrow> R y z \<longrightarrow> R x z" and
    in_mult: "(M, N) \<in> mult {(x, y). x \<in> A \<and> y \<in> A \<and> R x y}"
  shows "less_multiset_ext\<^sub>D\<^sub>M R M N"
  using in_mult N_A M_A unfolding mult_def less_multiset_ext\<^sub>D\<^sub>M_def
proof induct
  case (base N)
  then obtain y M0 X where "N = add_mset y M0" and "M = M0 + X" and "\<forall>a. a \<in># X \<longrightarrow> R a y"
    unfolding mult1_def by auto
  thus ?case
    by (auto intro: exI[of _ "{#y#}"])
next
  case (step N N')
  note N_N'_in_mult1 = this(2) and ih = this(3) and N'_A = this(4) and M_A = this(5)

  have N_A: "set_mset N \<subseteq> A"
    using N_N'_in_mult1 N'_A unfolding mult1_def by auto

  obtain Y X where y_nemp: "Y \<noteq> {#}" and y_sub_N: "Y \<subseteq># N" and M_eq: "M = N - Y + X" and
    ex_y: "\<forall>x. x \<in># X \<longrightarrow> (\<exists>y. y \<in># Y \<and> R x y)"
    using ih[OF N_A M_A] by blast

  obtain z M0 Ya where N'_eq: "N' = M0 + {#z#}" and N_eq: "N = M0 + Ya" and
    z_gt: "\<forall>y. y \<in># Ya \<longrightarrow> y \<in> A \<and> z \<in> A \<and> R y z"
    using N_N'_in_mult1[unfolded mult1_def] by auto

  let ?Za = "Y - Ya + {#z#}"
  let ?Xa = "X + Ya + (Y - Ya) - Y"

  have xa_sub_x_ya: "set_mset ?Xa \<subseteq> set_mset (X + Ya)"
    by (metis diff_subset_eq_self in_diffD subsetI subset_mset.diff_diff_right)

  have x_A: "set_mset X \<subseteq> A"
    using M_A M_eq by auto
  have ya_A: "set_mset Ya \<subseteq> A"
    by (simp add: subsetI z_gt)

  have ex_y': "\<exists>y. y \<in># Y - Ya + {#z#} \<and> R x y" if x_in: "x \<in># X + Ya" for x
  proof (cases "x \<in># X")
    case True
    then obtain y where y_in: "y \<in># Y" and y_gt_x: "R x y"
      using ex_y by blast
    show ?thesis
    proof (cases "y \<in># Ya")
      case False
      hence "y \<in># Y - Ya + {#z#}"
        using y_in count_greater_zero_iff in_diff_count by fastforce
      thus ?thesis
        using y_gt_x by blast
    next
      case True
      hence "y \<in> A" and "z \<in> A" and "R y z"
        using z_gt by blast+
      hence "R x z"
        using trans y_gt_x x_A ya_A x_in by (meson subsetCE union_iff)
      thus ?thesis
        by auto
    qed
  next
    case False
    hence "x \<in># Ya"
      using x_in by auto
    hence "x \<in> A" and "z \<in> A" and "R x z"
      using z_gt by blast+
    thus ?thesis
      by auto
  qed

  show ?case
  proof (rule exI[of _ ?Za], rule exI[of _ ?Xa], intro conjI)
    show "Y - Ya + {#z#} \<subseteq># N'"
      using mset_subset_eq_mono_add subset_eq_diff_conv y_sub_N N_eq N'_eq
      by (simp add: subset_eq_diff_conv)
  next
    show "M = N' - (Y - Ya + {#z#}) + (X + Ya + (Y - Ya) - Y)"
      unfolding M_eq N_eq N'_eq by (auto simp: multiset_eq_iff)
  next
    show "\<forall>x. x \<in># X + Ya + (Y - Ya) - Y \<longrightarrow> (\<exists>y. y \<in># Y - Ya + {#z#} \<and> R x y)"
      using ex_y' xa_sub_x_ya by blast
  qed auto
qed

lemma less_multiset_ext\<^sub>D\<^sub>M_iff_mult:
  assumes
    N_A: "set_mset N \<subseteq> A" and M_A: "set_mset M \<subseteq> A" and
    trans: "\<forall>x \<in> A. \<forall>y \<in> A. \<forall>z \<in> A. R x y \<longrightarrow> R y z \<longrightarrow> R x z"
  shows "less_multiset_ext\<^sub>D\<^sub>M R M N \<longleftrightarrow> (M, N) \<in> mult {(x, y). x \<in> A \<and> y \<in> A \<and> R x y}"
  using mult_imp_less_multiset_ext\<^sub>D\<^sub>M[OF assms] less_multiset_ext\<^sub>D\<^sub>M_imp_mult[OF N_A M_A] by blast

instantiation nmultiset :: (preorder) preorder
begin

lemma less_multiset_ext\<^sub>D\<^sub>M_cong[fundef_cong]:
  "(\<And>X Y k a. X \<noteq> {#} \<Longrightarrow> X \<subseteq># N \<Longrightarrow> M = (N - X) + Y \<Longrightarrow> k \<in># Y \<Longrightarrow> R k a = S k a) \<Longrightarrow>
  less_multiset_ext\<^sub>D\<^sub>M R M N = less_multiset_ext\<^sub>D\<^sub>M S M N"
  unfolding less_multiset_ext\<^sub>D\<^sub>M_def by metis

function less_nmultiset :: "'a nmultiset \<Rightarrow> 'a nmultiset \<Rightarrow> bool" where
  "less_nmultiset (Elem a) (Elem b) \<longleftrightarrow> a < b"
| "less_nmultiset (Elem a) (MSet M) \<longleftrightarrow> True"
| "less_nmultiset (MSet M) (Elem a) \<longleftrightarrow> False"
| "less_nmultiset (MSet M) (MSet N) \<longleftrightarrow> less_multiset_ext\<^sub>D\<^sub>M less_nmultiset M N"
  by pat_completeness auto
termination
  by (relation "sub_nmset <*lex*> sub_nmset", fastforce,
    metis sub_nmset.simps in_lex_prod mset_subset_eqD mset_subset_eq_add_right)

lemmas less_nmultiset_induct =
  less_nmultiset.induct[case_names Elem_Elem Elem_MSet MSet_Elem MSet_MSet]

lemmas less_nmultiset_cases =
  less_nmultiset.cases[case_names Elem_Elem Elem_MSet MSet_Elem MSet_MSet]

lemma trans_less_nmultiset: "X < Y \<Longrightarrow> Y < Z \<Longrightarrow> X < Z" for X Y Z :: "'a nmultiset"
proof (induct "Max {|X|, |Y|, |Z|}" arbitrary: X Y Z
    rule: less_induct)
  case less
  from less(2,3) show ?case
  proof (cases X; cases Y; cases Z)
    fix M N N' :: "'a nmultiset multiset"
    define A where "A = set_mset M \<union> set_mset N \<union> set_mset N'"
    assume XYZ: "X = MSet M" "Y = MSet N" "Z = MSet N'"
    then have trans: "\<forall>x \<in> A. \<forall>y \<in> A. \<forall>z \<in> A. x < y \<longrightarrow> y < z \<longrightarrow> x < z"
      by (auto elim!: less(1)[rotated -1] dest!: depth_nmset_MSet simp add: A_def)
    have "set_mset M \<subseteq> A" "set_mset N \<subseteq> A" "set_mset N' \<subseteq> A"
      unfolding A_def by auto
    with less(2,3) XYZ show "X < Z"
      by (auto simp: less_multiset_ext\<^sub>D\<^sub>M_iff_mult[OF _ _ trans] mult_def)
  qed (auto elim: less_trans)
qed

lemma irrefl_less_nmultiset:
  fixes X :: "'a nmultiset"
  shows "X < X \<Longrightarrow> False"
proof (induct X)
  case (MSet M)
  from MSet(2) show ?case
  unfolding less_nmultiset.simps less_multiset_ext\<^sub>D\<^sub>M_def
  proof safe
    fix X Y :: "'a nmultiset multiset"
    define XY where "XY = {(x, y). x \<in># X \<and> y \<in># Y \<and> y < x}"
    then have fin: "finite XY" and trans: "trans XY"
      by (auto simp: trans_def intro: trans_less_nmultiset
        finite_subset[OF _ finite_cartesian_product])
    assume "X \<noteq> {#}" "X \<subseteq># M" "M = M - X + Y"
    then have "X = Y"
      by (auto simp: mset_subset_eq_exists_conv)
    with MSet(1) \<open>X \<subseteq># M\<close> have "irrefl XY"
      unfolding XY_def by (force dest: mset_subset_eqD simp: irrefl_def)
    with trans have "acyclic XY"
      by (simp add: acyclic_irrefl)
    moreover
    assume "\<forall>k. k \<in># Y \<longrightarrow> (\<exists>a. a \<in># X \<and> k < a)"
    with \<open>X = Y\<close> \<open>X \<noteq> {#}\<close> have "\<not> acyclic XY"
      by (intro notI, elim finite_acyclic_wf[OF fin, elim_format])
        (auto dest!: spec[of _ "set_mset Y"] simp: wf_eq_minimal XY_def)
    ultimately show False by blast
  qed
qed simp

lemma antisym_less_nmultiset:
  fixes X Y :: "'a nmultiset"
  shows "X < Y \<Longrightarrow> Y < X \<Longrightarrow> False"
  using trans_less_nmultiset irrefl_less_nmultiset by blast

definition less_eq_nmultiset :: "'a nmultiset \<Rightarrow> 'a nmultiset \<Rightarrow> bool" where
  "less_eq_nmultiset X Y = (X < Y \<or> X = Y)"

instance
proof (intro_classes, goal_cases less_def refl trans)
  case (less_def x y)
  then show ?case
    unfolding less_eq_nmultiset_def by (metis irrefl_less_nmultiset antisym_less_nmultiset)
next
  case (refl x)
  then show ?case
    unfolding less_eq_nmultiset_def by blast
next
  case (trans x y z)
  then show ?case
    unfolding less_eq_nmultiset_def by (metis trans_less_nmultiset)
qed

lemma less_multiset_ext\<^sub>D\<^sub>M_less: "less_multiset_ext\<^sub>D\<^sub>M (<) = (<)"
  unfolding fun_eq_iff less_multiset_ext\<^sub>D\<^sub>M_def less_multiset\<^sub>D\<^sub>M by blast

end

instantiation nmultiset :: (order) order
begin

instance
proof (intro_classes, goal_cases antisym)
  case (antisym x y)
  then show ?case
    unfolding less_eq_nmultiset_def by (metis trans_less_nmultiset irrefl_less_nmultiset)
qed

end

instantiation nmultiset :: (linorder) linorder
begin

lemma total_less_nmultiset:
  fixes X Y :: "'a nmultiset"
  shows "\<not> X < Y \<Longrightarrow> Y \<noteq> X \<Longrightarrow> Y < X"
proof (induct X Y rule: less_nmultiset_induct)
  case (MSet_MSet M N)
  then show ?case
    unfolding nmultiset.inject less_nmultiset.simps less_multiset_ext\<^sub>D\<^sub>M_less less_multiset\<^sub>H\<^sub>O
    by (metis add_diff_cancel_left' count_inI diff_add_zero in_diff_count less_imp_not_less
      mset_subset_eq_multiset_union_diff_commute subset_mset.order.refl)
qed auto

instance
proof (intro_classes, goal_cases total)
  case (total x y)
  then show ?case
    unfolding less_eq_nmultiset_def by (metis total_less_nmultiset)
qed

end

lemma less_depth_nmset_imp_less_nmultiset: "|X| < |Y| \<Longrightarrow> X < Y"
proof (induct X Y rule: less_nmultiset_induct)
  case (MSet_MSet M N)
  then show ?case
  proof (cases "M = {#}")
    case False
    with MSet_MSet show ?thesis
      by (auto 0 4 simp: depth_nmset.simps(2) less_multiset_ext\<^sub>D\<^sub>M_def not_le Max_gr_iff
        intro: exI[of _ N] split: if_splits)
  qed (auto simp: depth_nmset.simps(2) less_multiset_ext\<^sub>D\<^sub>M_less split: if_splits)
qed simp_all

lemma less_nmultiset_imp_le_depth_nmset: "X < Y \<Longrightarrow> |X| \<le> |Y|"
proof (induct X Y rule: less_nmultiset_induct)
  case (MSet_MSet M N)
  then have "M < N" by (simp add: less_multiset_ext\<^sub>D\<^sub>M_less)
  then show ?case
  proof (cases "M = {#}" "N = {#}" rule: bool.exhaust[case_product bool.exhaust])
    case [simp]: False_False
    show ?thesis
    unfolding depth_nmset.simps(2) Let_def False_False Suc_le_mono set_image_mset image_is_empty
      set_mset_eq_empty_iff if_False
    proof (intro iffD2[OF Max_le_iff] ballI iffD2[OF Max_ge_iff]; (elim imageE)?; simp)
      fix X
      assume [simp]: "X \<in># M"
      with MSet_MSet(1)[of N M X, simplified] \<open>M < N\<close> show "\<exists>Y\<in>#N. |X| \<le> |Y|"
        by (meson ex_gt_imp_less_multiset less_asym' less_depth_nmset_imp_less_nmultiset
          not_le_imp_less)
    qed
  qed (auto simp: depth_nmset.simps(2))
qed simp_all

lemma eq_mlex_I:
  fixes f :: "'a \<Rightarrow> nat" and R :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  assumes "\<And>X Y. f X < f Y \<Longrightarrow> R X Y" and "antisymp R"
  shows "{(X, Y). R X Y} = f <*mlex*> {(X, Y). f X = f Y \<and> R X Y}"
proof safe
  fix X Y
  assume "R X Y"
  show "(X, Y) \<in> f <*mlex*> {(X, Y). f X = f Y \<and> R X Y}"
  proof (cases "f X" "f Y" rule: linorder_cases)
    case less
    with \<open>R X Y\<close> show ?thesis
      by (elim mlex_less)
  next
    case equal
    with \<open>R X Y\<close> show ?thesis
      by (intro mlex_leq) auto
  next
    case greater
    from \<open>R X Y\<close> assms(1)[OF greater] \<open>antisymp R\<close> greater show ?thesis
      unfolding antisymp_def by auto
  qed
next
  fix X Y
  assume "(X, Y) \<in> f <*mlex*> {(X, Y). f X = f Y \<and> R X Y}"
  then show "R X Y"
    unfolding mlex_prod_def by (auto simp: assms(1))
qed

instantiation nmultiset :: (wellorder) wellorder
begin

lemma depth_nmset_eq_0[simp]: "|X| = 0 \<longleftrightarrow> (X = MSet {#} \<or> (\<exists>x. X = Elem x))"
  by (cases X; simp add: depth_nmset.simps(2))

lemma depth_nmset_eq_Suc[simp]: "|X| = Suc n \<longleftrightarrow>
  (\<exists>N. X = MSet N \<and> (\<exists>Y \<in># N. |Y| = n) \<and> (\<forall>Y \<in># N. |Y| \<le> n))"
  by (cases X; auto simp add: depth_nmset.simps(2) intro!: Max_eqI)
    (metis (no_types, lifting) Max_in finite_imageI finite_set_mset imageE image_is_empty
      set_mset_eq_empty_iff)

lemma wf_less_nmultiset_depth:
  "wf {(X :: 'a nmultiset, Y). |X| = i \<and> |Y| = i \<and> X < Y}"
proof (induct i rule: less_induct)
  case (less i)
  define A :: "'a nmultiset set" where "A = {X. |X| < i}"
  from less have "wf ((depth_nmset :: 'a nmultiset \<Rightarrow> nat) <*mlex*>
      (\<Union>j < i. {(X, Y). |X| = j \<and> |Y| = j \<and> X < Y}))"
    by (intro wf_UN wf_mlex) auto
  then have *: "wf (mult {(X :: 'a nmultiset, Y). X \<in> A \<and> Y \<in> A \<and> X < Y})"
    by (intro wf_mult, elim wf_subset) (force simp: A_def mlex_prod_def not_less_iff_gr_or_eq
      dest!: less_depth_nmset_imp_less_nmultiset)
  show ?case
  proof (cases i)
    case 0
    then show ?thesis
      by (auto simp: inj_on_def intro!: wf_subset[OF
        wf_Un[OF wf_map_prod_image[OF wf, of Elem] wf_UN[of "Elem ` UNIV" "\<lambda>x. {(x, MSet {#})}"]]])
  next
    case (Suc n)
    then show ?thesis
      by (intro wf_subset[OF wf_map_prod_image[OF *, of MSet]])
        (auto 0 4 simp: map_prod_def image_iff inj_on_def A_def
          dest!: less_multiset_ext\<^sub>D\<^sub>M_imp_mult[of _ A, rotated -1] split: prod.splits)
  qed
qed

lemma wf_less_nmultiset: "wf {(X :: 'a nmultiset, Y :: 'a nmultiset). X < Y}" (is "wf ?R")
proof -
  have "?R = depth_nmset <*mlex*> {(X, Y). |X| = |Y| \<and> X < Y}"
    by (rule eq_mlex_I) (auto simp: antisymp_def less_depth_nmset_imp_less_nmultiset)
  also have "{(X, Y). |X| = |Y| \<and> X < Y} = (\<Union>i. {(X, Y). |X| = i \<and> |Y| = i \<and> X < Y})"
    by auto
  finally show ?thesis
    by (fastforce intro: wf_mlex wf_Union wf_less_nmultiset_depth)
qed

instance using wf_less_nmultiset unfolding wf_def mem_Collect_eq prod.case by intro_classes metis

end

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_nat_alt_mul_assoc
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
"plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun altmul :: "Nat => Nat => Nat" where
"altmul (Z) y = Z"
| "altmul (S z) (Z) = Z"
| "altmul (S z) (S x2) =
     plus (plus (plus (S Z) (altmul z x2)) z) x2"

theorem property0 :
  "((altmul x (altmul y z)) = (altmul (altmul x y) z))"
  oops

end


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

section\<open>Equivalence Relations\<close>

theory EquivClass imports Trancl Perm begin

definition
  quotient   :: "[i,i]=>i"    (infixl \<open>'/'/\<close> 90)  (*set of equiv classes*)  where
      "A//r == {r``{x} . x \<in> A}"

definition
  congruent  :: "[i,i=>i]=>o"  where
      "congruent(r,b) == \<forall>y z. <y,z>:r \<longrightarrow> b(y)=b(z)"

definition
  congruent2 :: "[i,i,[i,i]=>i]=>o"  where
      "congruent2(r1,r2,b) == \<forall>y1 z1 y2 z2.
           <y1,z1>:r1 \<longrightarrow> <y2,z2>:r2 \<longrightarrow> b(y1,y2) = b(z1,z2)"

abbreviation
  RESPECTS ::"[i=>i, i] => o"  (infixr \<open>respects\<close> 80) where
  "f respects r == congruent(r,f)"

abbreviation
  RESPECTS2 ::"[i=>i=>i, i] => o"  (infixr \<open>respects2 \<close> 80) where
  "f respects2 r == congruent2(r,r,f)"
    \<comment> \<open>Abbreviation for the common case where the relations are identical\<close>

subsection\<open>Suppes, Theorem 70:
    \<^term>\<open>r\<close> is an equiv relation iff \<^term>\<open>converse(r) O r = r\<close>\<close>

(** first half: equiv(A,r) ==> converse(r) O r = r **)

lemma sym_trans_comp_subset:
    "[| sym(r); trans(r) |] ==> converse(r) O r \<subseteq> r"
by (unfold trans_def sym_def, blast)

lemma refl_comp_subset:
    "[| refl(A,r); r \<subseteq> A*A |] ==> r \<subseteq> converse(r) O r"
by (unfold refl_def, blast)

lemma equiv_comp_eq:
    "equiv(A,r) ==> converse(r) O r = r"
apply (unfold equiv_def)
apply (blast del: subsetI intro!: sym_trans_comp_subset refl_comp_subset)
done

(*second half*)
lemma comp_equivI:
    "[| converse(r) O r = r;  domain(r) = A |] ==> equiv(A,r)"
apply (unfold equiv_def refl_def sym_def trans_def)
apply (erule equalityE)
apply (subgoal_tac "\<forall>x y. <x,y> \<in> r \<longrightarrow> <y,x> \<in> r", blast+)
done

(** Equivalence classes **)

(*Lemma for the next result*)
lemma equiv_class_subset:
    "[| sym(r);  trans(r);  <a,b>: r |] ==> r``{a} \<subseteq> r``{b}"
by (unfold trans_def sym_def, blast)

lemma equiv_class_eq:
    "[| equiv(A,r);  <a,b>: r |] ==> r``{a} = r``{b}"
apply (unfold equiv_def)
apply (safe del: subsetI intro!: equalityI equiv_class_subset)
apply (unfold sym_def, blast)
done

lemma equiv_class_self:
    "[| equiv(A,r);  a \<in> A |] ==> a \<in> r``{a}"
by (unfold equiv_def refl_def, blast)

(*Lemma for the next result*)
lemma subset_equiv_class:
    "[| equiv(A,r);  r``{b} \<subseteq> r``{a};  b \<in> A |] ==> <a,b>: r"
by (unfold equiv_def refl_def, blast)

lemma eq_equiv_class: "[| r``{a} = r``{b};  equiv(A,r);  b \<in> A |] ==> <a,b>: r"
by (assumption | rule equalityD2 subset_equiv_class)+

(*thus r``{a} = r``{b} as well*)
lemma equiv_class_nondisjoint:
    "[| equiv(A,r);  x: (r``{a} \<inter> r``{b}) |] ==> <a,b>: r"
by (unfold equiv_def trans_def sym_def, blast)

lemma equiv_type: "equiv(A,r) ==> r \<subseteq> A*A"
by (unfold equiv_def, blast)

lemma equiv_class_eq_iff:
     "equiv(A,r) ==> <x,y>: r \<longleftrightarrow> r``{x} = r``{y} & x \<in> A & y \<in> A"
by (blast intro: eq_equiv_class equiv_class_eq dest: equiv_type)

lemma eq_equiv_class_iff:
     "[| equiv(A,r);  x \<in> A;  y \<in> A |] ==> r``{x} = r``{y} \<longleftrightarrow> <x,y>: r"
by (blast intro: eq_equiv_class equiv_class_eq dest: equiv_type)

(*** Quotients ***)

(** Introduction/elimination rules -- needed? **)

lemma quotientI [TC]: "x \<in> A ==> r``{x}: A//r"
apply (unfold quotient_def)
apply (erule RepFunI)
done

lemma quotientE:
    "[| X \<in> A//r;  !!x. [| X = r``{x};  x \<in> A |] ==> P |] ==> P"
by (unfold quotient_def, blast)

lemma Union_quotient:
    "equiv(A,r) ==> \<Union>(A//r) = A"
by (unfold equiv_def refl_def quotient_def, blast)

lemma quotient_disj:
    "[| equiv(A,r);  X \<in> A//r;  Y \<in> A//r |] ==> X=Y | (X \<inter> Y \<subseteq> 0)"
apply (unfold quotient_def)
apply (safe intro!: equiv_class_eq, assumption)
apply (unfold equiv_def trans_def sym_def, blast)
done

subsection\<open>Defining Unary Operations upon Equivalence Classes\<close>

(** Could have a locale with the premises equiv(A,r)  and  congruent(r,b)
**)

(*Conversion rule*)
lemma UN_equiv_class:
    "[| equiv(A,r);  b respects r;  a \<in> A |] ==> (\<Union>x\<in>r``{a}. b(x)) = b(a)"
apply (subgoal_tac "\<forall>x \<in> r``{a}. b(x) = b(a)")
 apply simp
 apply (blast intro: equiv_class_self)
apply (unfold equiv_def sym_def congruent_def, blast)
done

(*type checking of  @{term"\<Union>x\<in>r``{a}. b(x)"} *)
lemma UN_equiv_class_type:
    "[| equiv(A,r);  b respects r;  X \<in> A//r;  !!x.  x \<in> A ==> b(x) \<in> B |]
     ==> (\<Union>x\<in>X. b(x)) \<in> B"
apply (unfold quotient_def, safe)
apply (simp (no_asm_simp) add: UN_equiv_class)
done

(*Sufficient conditions for injectiveness.  Could weaken premises!
  major premise could be an inclusion; bcong could be !!y. y \<in> A ==> b(y):B
*)
lemma UN_equiv_class_inject:
    "[| equiv(A,r);   b respects r;
        (\<Union>x\<in>X. b(x))=(\<Union>y\<in>Y. b(y));  X \<in> A//r;  Y \<in> A//r;
        !!x y. [| x \<in> A; y \<in> A; b(x)=b(y) |] ==> <x,y>:r |]
     ==> X=Y"
apply (unfold quotient_def, safe)
apply (rule equiv_class_eq, assumption)
apply (simp add: UN_equiv_class [of A r b])
done

subsection\<open>Defining Binary Operations upon Equivalence Classes\<close>

lemma congruent2_implies_congruent:
    "[| equiv(A,r1);  congruent2(r1,r2,b);  a \<in> A |] ==> congruent(r2,b(a))"
by (unfold congruent_def congruent2_def equiv_def refl_def, blast)

lemma congruent2_implies_congruent_UN:
    "[| equiv(A1,r1);  equiv(A2,r2);  congruent2(r1,r2,b);  a \<in> A2 |] ==>
     congruent(r1, %x1. \<Union>x2 \<in> r2``{a}. b(x1,x2))"
apply (unfold congruent_def, safe)
apply (frule equiv_type [THEN subsetD], assumption)
apply clarify
apply (simp add: UN_equiv_class congruent2_implies_congruent)
apply (unfold congruent2_def equiv_def refl_def, blast)
done

lemma UN_equiv_class2:
    "[| equiv(A1,r1);  equiv(A2,r2);  congruent2(r1,r2,b);  a1: A1;  a2: A2 |]
     ==> (\<Union>x1 \<in> r1``{a1}. \<Union>x2 \<in> r2``{a2}. b(x1,x2)) = b(a1,a2)"
by (simp add: UN_equiv_class congruent2_implies_congruent
              congruent2_implies_congruent_UN)

(*type checking*)
lemma UN_equiv_class_type2:
    "[| equiv(A,r);  b respects2 r;
        X1: A//r;  X2: A//r;
        !!x1 x2.  [| x1: A; x2: A |] ==> b(x1,x2) \<in> B
     |] ==> (\<Union>x1\<in>X1. \<Union>x2\<in>X2. b(x1,x2)) \<in> B"
apply (unfold quotient_def, safe)
apply (blast intro: UN_equiv_class_type congruent2_implies_congruent_UN
                    congruent2_implies_congruent quotientI)
done

(*Suggested by John Harrison -- the two subproofs may be MUCH simpler
  than the direct proof*)
lemma congruent2I:
    "[|  equiv(A1,r1);  equiv(A2,r2);
        !! y z w. [| w \<in> A2;  <y,z> \<in> r1 |] ==> b(y,w) = b(z,w);
        !! y z w. [| w \<in> A1;  <y,z> \<in> r2 |] ==> b(w,y) = b(w,z)
     |] ==> congruent2(r1,r2,b)"
apply (unfold congruent2_def equiv_def refl_def, safe)
apply (blast intro: trans)
done

lemma congruent2_commuteI:
 assumes equivA: "equiv(A,r)"
     and commute: "!! y z. [| y \<in> A;  z \<in> A |] ==> b(y,z) = b(z,y)"
     and congt:   "!! y z w. [| w \<in> A;  <y,z>: r |] ==> b(w,y) = b(w,z)"
 shows "b respects2 r"
apply (insert equivA [THEN equiv_type, THEN subsetD])
apply (rule congruent2I [OF equivA equivA])
apply (rule commute [THEN trans])
apply (rule_tac [3] commute [THEN trans, symmetric])
apply (rule_tac [5] sym)
apply (blast intro: congt)+
done

(*Obsolete?*)
lemma congruent_commuteI:
    "[| equiv(A,r);  Z \<in> A//r;
        !!w. [| w \<in> A |] ==> congruent(r, %z. b(w,z));
        !!x y. [| x \<in> A;  y \<in> A |] ==> b(y,x) = b(x,y)
     |] ==> congruent(r, %w. \<Union>z\<in>Z. b(w,z))"
apply (simp (no_asm) add: congruent_def)
apply (safe elim!: quotientE)
apply (frule equiv_type [THEN subsetD], assumption)
apply (simp add: UN_equiv_class [of A r])
apply (simp add: congruent_def)
done

end