(* ********************************************************************************

    Theory Greedy.thy is part of a package providing supplementary material
    to 'Synthesis of Implementations for Divide-and-conquer Specifications'.
    Copyright (c) 2023  M. Bortin

    The package is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    For more details see the license agreement (LICENSE) you should have
    received along with the package.

   ******************************************************************************* *)

theory Greedy
imports DaC_synthesis
begin

text "Independent families of sets"
definition Independent :: "'a set set \<Rightarrow> bool"
where "Independent \<I> = ({} \<in> \<I> \<and> (\<forall>S T. S \<in> \<I> \<longrightarrow> T \<subseteq> S \<longrightarrow> T \<in> \<I>) \<and>
                        (\<forall>S T. finite S \<longrightarrow> finite T \<longrightarrow> S \<in> \<I> \<longrightarrow> T \<in> \<I> \<longrightarrow> card S < card T \<longrightarrow>
                          (\<exists>e. e \<in> T - S \<and> {e} \<union> S \<in> \<I>)))"

lemma Independent_D1 :
"Independent \<I> \<Longrightarrow> {} \<in> \<I>"
  by(simp add: Independent_def)

text "The hereditary property"
lemma Independent_D2 :
"Independent \<I> \<Longrightarrow> S \<in> \<I> \<Longrightarrow> T \<subseteq> S \<Longrightarrow> T \<in> \<I>"
  by(simp add: Independent_def)

text "The exchange property"
lemma Independent_D3 :
"Independent \<I> \<Longrightarrow> S \<in> \<I> \<Longrightarrow> T \<in> \<I> \<Longrightarrow> card S < card T \<Longrightarrow> finite S \<Longrightarrow> finite T \<Longrightarrow>
 \<exists>e. e \<in> T - S \<and> {e} \<union> S \<in> \<I>"
  by(simp add: Independent_def)

section "Weights"

text "The weight of a set of elements: for simplicity's sake we assume that
      integers will be attached to the elements as a weight."
definition "weight (w :: 'a \<Rightarrow> int) A = (\<Sum>x\<in>A. w x)"
definition "neg (w :: 'a \<Rightarrow> int) = (\<lambda>x. - w x)"

lemma Sorted_neg :
"Sorted (neg w) xs = Sorted w (rev xs)"
  by(induct_tac xs, (simp add: neg_def Sorted_append)+)

lemma weight0 :
"weight w {} = 0"
  by(simp add: weight_def)

lemma weight_neg :
"weight (neg w) S = -(weight w S)"
  by(simp add: weight_def neg_def, rule sum_negf)

lemma weight_mono :
"S \<subseteq> T \<Longrightarrow> finite T \<Longrightarrow> \<forall>x\<in>T-S. w x \<ge> 0 \<Longrightarrow> weight w S \<le> weight w T"
  by(simp add: weight_def, meson sum_mono2)

lemma weight_remove :
"x \<in> T \<Longrightarrow> finite T \<Longrightarrow> weight w T = w x + weight w (T - {x})"
  by (simp add: weight_def sum.remove)

lemma weight_insert :
"x \<notin> T \<Longrightarrow> finite T \<Longrightarrow> w x + weight w T = weight w ({x} \<union> T)"
  by (simp add: weight_def)

section "Finite matroids"

locale finite_matroids =
  fixes \<I> :: "'a set set"
  assumes independence  : "Independent \<I>"
begin

definition "basis G X = (finite G \<and> X \<in> \<I> \<and> X \<subseteq> G \<and> (\<forall>X'. X' \<subseteq> G \<longrightarrow> X' \<in> \<I> \<longrightarrow> card X' \<le> card X))"

text "We can thus define maximum and minimum weight bases"
definition "max_weight_basis w G X = (basis G X \<and> (\<forall>B. basis G B \<longrightarrow> weight w B \<le> weight w X))"
definition "min_weight_basis w G X = (basis G X \<and> (\<forall>B. basis G B \<longrightarrow> weight w B \<ge> weight w X))"

lemma basisD1 :
"basis G X \<Longrightarrow> finite G \<and> X \<in> \<I>" by(simp add: basis_def)

lemma basisD2 :
"basis G X \<Longrightarrow> X \<subseteq> G" by(simp add: basis_def)

lemma basisD3 :
"basis G X \<Longrightarrow> X' \<subseteq> G \<Longrightarrow> X' \<in> \<I> \<Longrightarrow> card X' \<le> card X" by(simp add: basis_def)

lemma basis_card_eq :
"basis G X \<Longrightarrow> basis G X' \<Longrightarrow> card X = card X'"
  by (simp add: basis_def dual_order.eq_iff)

lemma basis_ext :
"A \<in> \<I> \<Longrightarrow> A \<subseteq> G \<Longrightarrow> finite G \<Longrightarrow> \<exists>A'. A \<subseteq> A' \<and> basis G A'"
  apply(induct A rule: measure_induct[where f="\<lambda>x. card G - card x"], simp)
  apply(rename_tac A)
  apply(case_tac "basis G A", fast)
  apply(subgoal_tac "\<exists>X. X \<subseteq> G \<and> X \<in> \<I> \<and> card X > card A")
   apply clarify
   apply(drule Independent_D3[OF independence, rotated 2])
       apply(erule finite_subset, assumption)+
     apply assumption+
   apply clarify
   apply(drule_tac x="{e} \<union> A" in spec)
   apply (metis card_insert_disjoint card_seteq diff_less_mono2 finite_subset insert_is_Un insert_subset lessI not_le_imp_less subsetD)
  apply (metis basis_def not_le_imp_less)
  done

subsection "The duality between maximum and minimum weight bases"

lemma MaxWeightBasis_neg :
  "max_weight_basis (neg w) G X \<Longrightarrow> min_weight_basis w G X"
  unfolding max_weight_basis_def min_weight_basis_def
  by (metis neg_le_iff_le weight_neg)

subsection "The auxiliary lemmas on bases of extended/reduced ground sets"

text "The lemma A1 gets split into two cases."
lemma A1_1 :
"basis G X \<Longrightarrow> x \<notin> G \<Longrightarrow> {x} \<union> X \<in> \<I> \<Longrightarrow> basis ({x} \<union> G) ({x} \<union> X)"
  apply(subst basis_def, simp)
  apply(frule basisD1)
  apply clarsimp
  apply(rule conjI)
   apply(drule basisD2, fast)
  apply clarsimp
  apply(frule basisD2)
  apply(rename_tac A)
  apply(drule_tac X'="A - {x}" in basisD3)
    apply fast
   apply(erule_tac S=A in Independent_D2[OF independence], fast)
  by (smt (verit) Diff_insert2 Diff_insert_absorb Diff_mono Diff_subset One_nat_def add_diff_inverse_nat card_Diff_singleton_if card_Diff_subset card_mono card_seteq diff_is_0_eq' diff_shunt_var double_diff dual_order.eq_iff finite.insertI finite_subset leI le_trans less_Suc_eq_le plus_1_eq_Suc)

lemma A1_2 :
"basis G X \<Longrightarrow> x \<notin> G \<Longrightarrow> {x} \<union> X \<notin> \<I> \<Longrightarrow> basis ({x} \<union> G) X"
  apply(subst basis_def, simp)
  apply(frule basisD1)
  apply clarsimp
  apply(rule conjI)
   apply(drule basisD2, fast)
  apply clarsimp
  apply(frule basisD2)
  apply(rule ccontr)
  apply(frule_tac T=X' in Independent_D3[OF independence])
       apply assumption+
     apply simp
    apply(erule finite_subset, assumption)
   apply(erule finite_subset)
   apply clarsimp+
  apply(rename_tac x')
  apply(drule_tac X'="{x'} \<union> X" in basisD3)
    apply fastforce
  by (simp add: finite_subset)+

lemma A2 :
"basis G X \<Longrightarrow> x \<notin> X \<Longrightarrow> basis (G - {x}) X"
  by (simp add: basis_def subset_Diff_insert)

lemma A3 :
"basis G X \<Longrightarrow> x \<in> X \<Longrightarrow>
 basis (G - {x}) (X - {x}) \<or> (\<exists>x'\<in>G. x' \<notin> X \<and> basis (G - {x}) ({x'} \<union> (X - {x})))"
  apply clarsimp
  apply(subst basis_def, simp)
  apply(frule basisD1)
  apply clarsimp
  apply(rule conjI)
   apply(erule Independent_D2[OF independence], fast)
  apply(rule conjI)
   apply(drule basisD2, fast)
  apply clarsimp
  apply(frule basisD2)
  apply(rule ccontr)
  apply(subgoal_tac "\<exists>x'. x' \<in> X' - (X - {x}) \<and> {x'} \<union> (X - {x}) \<in> \<I>")
   apply clarify
   apply(subgoal_tac "basis (G - {x}) ({x'} \<union> (X - {x}))")
    apply fastforce
   apply(subgoal_tac "card({x'} \<union> (X - {x})) = card X")
    apply(subst basis_def)
    apply(rule conjI, fastforce)+
    apply(subst (asm) basis_def)
    apply (metis Diff_empty subset_Diff_insert)
   apply (metis card.insert_remove card_insert_if finite_Diff finite_subset insert_is_Un)
  apply(rule Independent_D3[OF independence])
      apply(erule Independent_D2[OF independence])
      apply fastforce+
   apply (metis finite_Diff finite_subset)
  using finite_subset by blast

end (* the finite matroids locale *)

section "Synthesis of greedy algorithms on lists with weighted elements"

locale language_struct =
  fixes \<L> :: "'a list set"
  assumes \<L>_prop : "xs \<in> \<L> \<Longrightarrow> set xs = set xs' \<Longrightarrow> distinct xs \<Longrightarrow> distinct xs' \<Longrightarrow>
                    xs' \<in> \<L>"
begin

definition \<L>_img :: "'a set set"
 where "\<L>_img = {set xs |xs. distinct xs \<and> xs \<in> \<L>}"

lemma \<L>_img_eq :
"distinct xs \<Longrightarrow> (set xs \<in> \<L>_img) = (xs \<in> \<L>)"
  apply(simp add: \<L>_img_def)
  apply(rule iffI)
   apply clarify
   apply(erule \<L>_prop)
  by fastforce+

end

locale greedy_tactic = language_struct +
  fixes w :: "'a \<Rightarrow> int"
  assumes \<L>_img_independence : "Independent \<L>_img"
begin

text "In addition to the language-struct locale we assume that the ground set elements are weighted
      and that @{term \<L>_img} forms a family of independent sets so we can interpret the finite
      matroids locale in this context."
interpretation fm : finite_matroids \<L>_img
  by(unfold_locales, rule \<L>_img_independence)

definition "max_weight_basis = fm.max_weight_basis"

definition "greedy_spec = {(G, X) |G X. max_weight_basis w G X}"

definition "decomp_spec = {({}, Empty)} \<union> {(G, Dcmp x (G - {x})) |G x. x \<in> G \<and> (\<forall>z\<in>G. w x \<le> w z)}"

definition "comp_spec = {(Empty, {})} \<union> {(Dcmp x A, {x} \<union> A) |x A. {x} \<union> A \<in> \<L>_img} \<union>
                                        {(Dcmp x A, A) |x A. {x} \<union> A \<notin> \<L>_img}"

definition "decomp_impl = (\<lambda>xs. case xs of
                               [] \<Rightarrow> Empty
                             | x # xs' \<Rightarrow> Dcmp x xs')"

definition "comp_impl = (\<lambda>x. case x of
                           Empty \<Rightarrow> []
                         | Dcmp a xs \<Rightarrow> (if a#xs \<in> \<L> then a#xs else xs))"

text "problem reduction principle"
theorem prefixed_point_property :
"DaC_scheme decomp_spec comp_spec greedy_spec \<subseteq> greedy_spec"
  apply(clarsimp simp: DaC_scheme_def)
  apply(rename_tac G a b c)
  apply(case_tac "G = {}")
   apply(clarsimp simp: \<L>_img_independence decomp_spec_def comp_spec_def greedy_spec_def Relt_def
         max_weight_basis_def fm.max_weight_basis_def fm.basis_def)
   apply(rule Independent_D1, rule \<L>_img_independence)
  apply(clarsimp simp: decomp_spec_def comp_spec_def Relt_def)
  apply(rename_tac a X)
  apply(clarsimp simp: greedy_spec_def max_weight_basis_def fm.max_weight_basis_def)
  apply(frule fm.basisD2)
  apply(erule disjE, clarsimp)
   apply(frule_tac x=a in fm.A1_1, simp+)
   apply(subst (asm) insert_absorb, assumption+)
   apply clarsimp
   apply(rename_tac Y)
   apply(case_tac "a \<notin> Y")
    apply(frule fm.A2, assumption+)
    apply(drule fm.basis_card_eq, assumption)+
    apply (metis fm.basisD1 card_subset_eq finite_insert finite_subset subset_insertI)
   apply simp
   apply(frule fm.A3, assumption+)
   apply(erule disjE)
    apply(drule_tac x="Y - {a}" in spec, drule mp, assumption)
    apply (smt (verit, ccfv_threshold) fm.basis_def DiffE Diff_insert_absorb weight_remove in_mono infinite_super insert_iff)
   apply clarsimp
   apply(drule fm.basis_card_eq, assumption)+
   apply(subgoal_tac "card (insert x' (Y - {a})) = card Y")
    apply (metis Diff_insert_absorb card_Diff1_less_iff card_Diff_singleton_if finite_insert finite_matroids.basisD1 finite_subset fm.finite_matroids_axioms insertCI subset_Diff_insert)
   apply (metis DiffE card.infinite card.insert_remove card_insert_if finite.emptyI finite_Diff2 finite_insert)
  apply(clarsimp simp: greedy_spec_def fm.max_weight_basis_def)
  apply(rename_tac X a)
  apply(frule_tac x=a in fm.A1_2, simp+)
  apply(subst (asm) insert_absorb, assumption+)
  apply clarsimp
  apply(rename_tac Y)
  apply(case_tac "a \<notin> Y")
   apply(frule fm.A2, assumption+)
   apply(drule spec, erule mp, assumption)
  apply simp
  apply(frule fm.A3, assumption+)
  apply(erule disjE)
   apply(drule fm.basis_card_eq, assumption)+
   apply (metis card_Diff1_less_iff finite_subset fm.basis_def nless_le)
  apply clarsimp
  apply(drule_tac x="{x'} \<union> (Y - {a})" in spec, drule mp, simp)
  apply(erule order_trans[rotated 1])
  apply(subst weight_remove, assumption)
   apply (meson finite_subset fm.basisD1 fm.basisD2)
  apply(subgoal_tac "w a + weight w (Y - {a}) \<le> w x' + weight w (Y - {a})")
   apply(erule order_trans)
   apply(subst weight_insert, simp)
    apply (meson finite_Diff finite_subset fm.basisD1 fm.basisD2)
   apply(rule order_refl)
  by simp

text "We apply the divide-and-conquer synthesis rule as follows:"
interpretation greedy: DaC_synthesis
"{(xs, set xs) |xs. distinct xs \<and> Sorted w xs}"                 (* \<alpha>\<^sub>1 *)
"{(xs, set xs) |xs. distinct xs}"                               (* \<alpha>\<^sub>2 *)
greedy_spec decomp_spec comp_spec decomp_impl comp_impl
  apply(unfold_locales)
     apply(rule prefixed_point_property)

  text "decomposition implementation:"
    apply(clarsimp simp: decomp_spec_def decomp_impl_def graph_of_def Relt_def)
    apply(case_tac xs, simp)
     apply(rule_tac b=Empty in relcompI, clarsimp+)
    apply(rename_tac x xs)
    apply(rule_tac b="Dcmp x (set xs)" in relcompI)
     apply simp+

  text "composition implementation:"
   apply(clarsimp simp: comp_spec_def comp_impl_def graph_of_def Relt_def)
   apply(rename_tac xs)
   apply(case_tac xs, simp)
    apply(rule_tac b=Empty in relcompI, clarsimp+)
   apply(rename_tac x xs)
   apply(case_tac "x#xs \<in> \<L>", clarsimp)
    apply(subgoal_tac "{x} \<union> set xs \<in> \<L>_img")
     apply(rule_tac b="Dcmp x (set xs)" in relcompI, fast)
     apply fastforce
    apply(subst (asm) \<L>_img_eq[THEN sym], simp+)
   apply(case_tac "x \<in> set xs")
    apply(rule_tac b="Dcmp x (set xs)" in relcompI, fast)
    apply fastforce
   apply(subgoal_tac "{x} \<union> set xs \<notin> \<L>_img")
    apply(rule_tac b="Dcmp x (set xs)" in relcompI, fast)
    apply fastforce
   apply(subst (asm) \<L>_img_eq[THEN sym], simp+)

  text "reductivity:"
  apply clarsimp
  apply(rename_tac xs)
  apply(induct_tac xs rule: length_induct, clarsimp)
  apply(rename_tac xs)
  apply(subst lfp_unfold)
   apply(rule monoI)
   apply(rule monoD[OF monotypeF_mono])
   apply(erule monoD[OF Relt_mono])
  apply(subst singleton_eq)
  apply(rule monotypeF_univ[THEN iffD1])
  apply(subst graph_of_def, subst graph_of_def)
  apply(clarsimp simp: decomp_impl_def)
  apply(rename_tac xs)
  apply(case_tac xs, simp)
   apply(rule_tac b="Empty" in relcompI, simp, simp add: Relt_def)
  apply clarsimp
  apply(rename_tac x xs)
  apply(rule_tac b="Dcmp x xs" in relcompI, simp)
  apply(subst Relt_def, simp)
  done

text "Renaming the synthesised function explicitly:"
definition "syn_greedy = greedy.dac"

text "Deriving the recursive equations for the synthesised function:"
lemma syn_greedy_eqs[simp] :
"syn_greedy [] = []"
"syn_greedy (x#xs) = (if x # syn_greedy xs \<in> \<L> then x # syn_greedy xs else syn_greedy xs)"
unfolding syn_greedy_def by(subst greedy.dac_unfold, simp add: decomp_impl_def comp_impl_def ReltF_eqs)+

lemma syn_greedy_sub[simp] :
"set(syn_greedy xs) \<subseteq> set xs"
  by(induct xs, simp+, fast)

lemma syn_greedy_dist :
"distinct xs \<Longrightarrow> distinct (syn_greedy xs)"
  apply(induct xs, clarsimp+)
  apply(drule subsetD[OF syn_greedy_sub])
  by simp

lemma syn_greedy_max_basis :
"distinct xs \<Longrightarrow> Sorted w xs \<Longrightarrow>
 max_weight_basis w (set xs) (set(syn_greedy xs))"
  apply(insert greedy.dac_impl)
  apply(drule_tac c="(set xs, set(syn_greedy xs))" in subsetD)
  apply(rule_tac b=xs in relcompI, simp)
  apply(rule_tac b="syn_greedy xs" in relcompI, simp add: graph_of_def syn_greedy_def)
  apply(simp add: syn_greedy_dist)
  apply(simp add: greedy_spec_def)
  done

end (* the greedy tactic locale *)

locale enhanced_greedy = greedy_tactic +
  fixes ins :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list"
    and \<L>' :: "'a list set"
  assumes set_ins : "set(ins x xs) = set(x#xs)"
     and  transl  : "distinct xs \<Longrightarrow> (foldr ins xs [] \<in> \<L>') = (xs \<in> \<L>)"
begin

subsection "First transformation step"

fun greedy where
  "greedy [] = []"
| "greedy (x#xs) = (let g = greedy xs in
                     let xs' = ins x g in
                        if xs' \<in> \<L>' then xs' else g)"

text "Connection to the synthesised function @{term syn_greedy}: "
lemma greedy_eq_syn :
"distinct xs \<Longrightarrow> greedy xs = foldr ins (syn_greedy xs) []"
  apply(induct xs, simp+)
  apply clarify
  apply(frule syn_greedy_dist)
  apply(subgoal_tac "distinct (a#syn_greedy xs)")
  apply(drule_tac xs="a#syn_greedy xs" in transl)
  apply(simp add: Let_def)
  apply clarsimp
  apply(drule subsetD[OF syn_greedy_sub])
  by clarify

lemma ins_gen :
"set(foldr ins xs []) = set xs"
  by(induct xs, simp_all add: set_ins)

lemma transformation1_correctness :
"distinct xs \<Longrightarrow> set(greedy xs) = set(syn_greedy xs)"
  apply(drule greedy_eq_syn)
  apply(erule ssubst)
  by(simp add: ins_gen)

subsection "Second transformation (tail-recursion)"

fun greedy_tr
  where "greedy_tr [] rs = rs" |
        "greedy_tr (x#xs) rs = (let v = ins x rs in
                                 if v \<in> \<L>' then greedy_tr xs v
                                         else greedy_tr xs rs)"

lemma greedy_tr_app[rule_format] :
"\<forall>rs. greedy_tr (xs@xs') rs = greedy_tr xs' (greedy_tr xs rs)"
  by(induct_tac xs, simp_all add: Let_def)

text "Connection to the function @{term greedy} :"
lemma greedy_greedy_tr :
"\<forall>rs. greedy (xs @ rs) = greedy_tr (rev xs) (greedy rs)"
  apply(induct_tac xs, clarsimp+)
  apply(subst greedy_tr_app)
  by(simp add: Let_def)

corollary transformation2_correctness :
  "greedy (rev xs) = greedy_tr xs []"
  apply(subst greedy_greedy_tr[rule_format, where rs="[]", simplified])
  by simp

text "Summarising the main result of the greedy tactic (synthesis + transformations): "
corollary greedy_tr_max_basis :
 "distinct xs \<Longrightarrow> Sorted (neg w) xs \<Longrightarrow>
  max_weight_basis w (set xs) (set(greedy_tr xs []))"
  apply(subst transformation2_correctness[THEN sym])
  apply(subst transformation1_correctness, simp)
  apply(subst set_rev[THEN sym])
  apply(rule syn_greedy_max_basis)
  apply simp
  apply(subst Sorted_neg[THEN sym])
  apply assumption+
  done

end (* the enhanced greedy locale *)

end


(*  Title:      FOL/ex/Propositional_Int.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1991  University of Cambridge
*)

section \<open>First-Order Logic: propositional examples (intuitionistic version)\<close>

theory Propositional_Int
imports IFOL
begin

text \<open>commutative laws of \<open>\<and>\<close> and \<open>\<or>\<close>\<close>

lemma \<open>P \<and> Q \<longrightarrow> Q \<and> P\<close>
  by (tactic "IntPr.fast_tac \<^context> 1")

lemma \<open>P \<or> Q \<longrightarrow> Q \<or> P\<close>
  by (tactic "IntPr.fast_tac \<^context> 1")

text \<open>associative laws of \<open>\<and>\<close> and \<open>\<or>\<close>\<close>
lemma \<open>(P \<and> Q) \<and> R \<longrightarrow> P \<and> (Q \<and> R)\<close>
  by (tactic "IntPr.fast_tac \<^context> 1")

lemma \<open>(P \<or> Q) \<or> R \<longrightarrow> P \<or> (Q \<or> R)\<close>
  by (tactic "IntPr.fast_tac \<^context> 1")

text \<open>distributive laws of \<open>\<and>\<close> and \<open>\<or>\<close>\<close>
lemma \<open>(P \<and> Q) \<or> R \<longrightarrow> (P \<or> R) \<and> (Q \<or> R)\<close>
  by (tactic "IntPr.fast_tac \<^context> 1")

lemma \<open>(P \<or> R) \<and> (Q \<or> R) \<longrightarrow> (P \<and> Q) \<or> R\<close>
  by (tactic "IntPr.fast_tac \<^context> 1")

lemma \<open>(P \<or> Q) \<and> R \<longrightarrow> (P \<and> R) \<or> (Q \<and> R)\<close>
  by (tactic "IntPr.fast_tac \<^context> 1")

lemma \<open>(P \<and> R) \<or> (Q \<and> R) \<longrightarrow> (P \<or> Q) \<and> R\<close>
  by (tactic "IntPr.fast_tac \<^context> 1")

text \<open>Laws involving implication\<close>

lemma \<open>(P \<longrightarrow> R) \<and> (Q \<longrightarrow> R) \<longleftrightarrow> (P \<or> Q \<longrightarrow> R)\<close>
  by (tactic "IntPr.fast_tac \<^context> 1")

lemma \<open>(P \<and> Q \<longrightarrow> R) \<longleftrightarrow> (P \<longrightarrow> (Q \<longrightarrow> R))\<close>
  by (tactic "IntPr.fast_tac \<^context> 1")

lemma \<open>((P \<longrightarrow> R) \<longrightarrow> R) \<longrightarrow> ((Q \<longrightarrow> R) \<longrightarrow> R) \<longrightarrow> (P \<and> Q \<longrightarrow> R) \<longrightarrow> R\<close>
  by (tactic "IntPr.fast_tac \<^context> 1")

lemma \<open>\<not> (P \<longrightarrow> R) \<longrightarrow> \<not> (Q \<longrightarrow> R) \<longrightarrow> \<not> (P \<and> Q \<longrightarrow> R)\<close>
  by (tactic "IntPr.fast_tac \<^context> 1")

lemma \<open>(P \<longrightarrow> Q \<and> R) \<longleftrightarrow> (P \<longrightarrow> Q) \<and> (P \<longrightarrow> R)\<close>
  by (tactic "IntPr.fast_tac \<^context> 1")

text \<open>Propositions-as-types\<close>

\<comment> \<open>The combinator K\<close>
lemma \<open>P \<longrightarrow> (Q \<longrightarrow> P)\<close>
  by (tactic "IntPr.fast_tac \<^context> 1")

\<comment> \<open>The combinator S\<close>
lemma \<open>(P \<longrightarrow> Q \<longrightarrow> R) \<longrightarrow> (P \<longrightarrow> Q) \<longrightarrow> (P \<longrightarrow> R)\<close>
  by (tactic "IntPr.fast_tac \<^context> 1")

\<comment> \<open>Converse is classical\<close>
lemma \<open>(P \<longrightarrow> Q) \<or> (P \<longrightarrow> R) \<longrightarrow> (P \<longrightarrow> Q \<or> R)\<close>
  by (tactic "IntPr.fast_tac \<^context> 1")

lemma \<open>(P \<longrightarrow> Q) \<longrightarrow> (\<not> Q \<longrightarrow> \<not> P)\<close>
  by (tactic "IntPr.fast_tac \<^context> 1")

text \<open>Schwichtenberg's examples (via T. Nipkow)\<close>

lemma stab_imp: \<open>(((Q \<longrightarrow> R) \<longrightarrow> R) \<longrightarrow> Q) \<longrightarrow> (((P \<longrightarrow> Q) \<longrightarrow> R) \<longrightarrow> R) \<longrightarrow> P \<longrightarrow> Q\<close>
  by (tactic "IntPr.fast_tac \<^context> 1")

lemma stab_to_peirce:
  \<open>(((P \<longrightarrow> R) \<longrightarrow> R) \<longrightarrow> P) \<longrightarrow> (((Q \<longrightarrow> R) \<longrightarrow> R) \<longrightarrow> Q)
    \<longrightarrow> ((P \<longrightarrow> Q) \<longrightarrow> P) \<longrightarrow> P\<close>
  by (tactic "IntPr.fast_tac \<^context> 1")

lemma peirce_imp1:
  \<open>(((Q \<longrightarrow> R) \<longrightarrow> Q) \<longrightarrow> Q)
    \<longrightarrow> (((P \<longrightarrow> Q) \<longrightarrow> R) \<longrightarrow> P \<longrightarrow> Q) \<longrightarrow> P \<longrightarrow> Q\<close>
  by (tactic "IntPr.fast_tac \<^context> 1")

lemma peirce_imp2: \<open>(((P \<longrightarrow> R) \<longrightarrow> P) \<longrightarrow> P) \<longrightarrow> ((P \<longrightarrow> Q \<longrightarrow> R) \<longrightarrow> P) \<longrightarrow> P\<close>
  by (tactic "IntPr.fast_tac \<^context> 1")

lemma mints: \<open>((((P \<longrightarrow> Q) \<longrightarrow> P) \<longrightarrow> P) \<longrightarrow> Q) \<longrightarrow> Q\<close>
  by (tactic "IntPr.fast_tac \<^context> 1")

lemma mints_solovev: \<open>(P \<longrightarrow> (Q \<longrightarrow> R) \<longrightarrow> Q) \<longrightarrow> ((P \<longrightarrow> Q) \<longrightarrow> R) \<longrightarrow> R\<close>
  by (tactic "IntPr.fast_tac \<^context> 1")

lemma tatsuta:
  \<open>(((P7 \<longrightarrow> P1) \<longrightarrow> P10) \<longrightarrow> P4 \<longrightarrow> P5)
  \<longrightarrow> (((P8 \<longrightarrow> P2) \<longrightarrow> P9) \<longrightarrow> P3 \<longrightarrow> P10)
  \<longrightarrow> (P1 \<longrightarrow> P8) \<longrightarrow> P6 \<longrightarrow> P7
  \<longrightarrow> (((P3 \<longrightarrow> P2) \<longrightarrow> P9) \<longrightarrow> P4)
  \<longrightarrow> (P1 \<longrightarrow> P3) \<longrightarrow> (((P6 \<longrightarrow> P1) \<longrightarrow> P2) \<longrightarrow> P9) \<longrightarrow> P5\<close>
  by (tactic "IntPr.fast_tac \<^context> 1")

lemma tatsuta1:
  \<open>(((P8 \<longrightarrow> P2) \<longrightarrow> P9) \<longrightarrow> P3 \<longrightarrow> P10)
  \<longrightarrow> (((P3 \<longrightarrow> P2) \<longrightarrow> P9) \<longrightarrow> P4)
  \<longrightarrow> (((P6 \<longrightarrow> P1) \<longrightarrow> P2) \<longrightarrow> P9)
  \<longrightarrow> (((P7 \<longrightarrow> P1) \<longrightarrow> P10) \<longrightarrow> P4 \<longrightarrow> P5)
  \<longrightarrow> (P1 \<longrightarrow> P3) \<longrightarrow> (P1 \<longrightarrow> P8) \<longrightarrow> P6 \<longrightarrow> P7 \<longrightarrow> P5\<close>
  by (tactic "IntPr.fast_tac \<^context> 1")

end


(*
  File:      Random_List.thy
  Authors:   Manuel Eberl

  Some facts about randomly permuted lists and how to obtain them by drawing i.i.d.
  priorities for every element.
*)
section \<open>Randomly-permuted lists\<close>
theory Random_List_Permutation
imports
  Probability_Misc
  Comparison_Sort_Lower_Bound.Linorder_Relations
begin

subsection \<open>General facts about linear orderings\<close>

text \<open>
  We define the set of all linear orderings on a given set and show some properties about it.
\<close>
definition linorders_on :: "'a set \<Rightarrow> ('a \<times> 'a) set set" where
  "linorders_on A = {R. linorder_on A R}"

lemma linorders_on_empty [simp]: "linorders_on {} = {{}}"
  by (auto simp: linorders_on_def linorder_on_def refl_on_def)

lemma linorders_finite_nonempty:
  assumes "finite A"
  shows   "linorders_on A \<noteq> {}"
proof -
  from finite_distinct_list[OF assms] obtain xs where "set xs = A" "distinct xs" by blast
  hence "linorder_on A (linorder_of_list xs)" by auto
  thus ?thesis by (auto simp: linorders_on_def)
qed

text \<open>
  There is an obvious bijection between permutations of a set (i.\,e.\ lists with all elements
  from that set without repetition) and linear orderings on it.
\<close>
lemma bij_betw_linorders_on:
  assumes "finite A"
  shows   "bij_betw linorder_of_list (permutations_of_set A) (linorders_on A)"
  using bij_betw_linorder_of_list[of A] assms unfolding linorders_on_def by simp

lemma sorted_wrt_list_of_set_linorder_of_list [simp]:
  assumes "distinct xs"
  shows   "sorted_wrt_list_of_set (linorder_of_list xs) (set xs) = xs"
  by (rule sorted_wrt_list_of_set_eqI[of "set xs"]) (insert assms, auto)

lemma linorder_of_list_sorted_wrt_list_of_set [simp]:
  assumes "linorder_on A R" "finite A"
  shows   "linorder_of_list (sorted_wrt_list_of_set R A) = R"
proof -
  from assms(1) have subset: "R \<subseteq> A \<times> A" by (auto simp: linorder_on_def refl_on_def)
  from assms and subset show ?thesis
    by (auto simp: linorder_of_list_def linorder_sorted_wrt_list_of_set sorted_wrt_linorder_index_le_iff)
qed

lemma bij_betw_linorders_on':
  assumes "finite A"
  shows   "bij_betw (\<lambda>R. sorted_wrt_list_of_set R A) (linorders_on A) (permutations_of_set A)"
  by (rule bij_betw_byWitness[where f' = linorder_of_list])
     (insert assms, auto simp: linorders_on_def permutations_of_set_def
        linorder_sorted_wrt_list_of_set)

lemma finite_linorders_on [intro]:
  assumes "finite A"
  shows   "finite (linorders_on A)"
proof -
  have "finite (permutations_of_set A)" by simp
  also have "?this \<longleftrightarrow> finite (linorders_on A)"
    using assms by (rule bij_betw_finite [OF bij_betw_linorders_on])
  finally show ?thesis .
qed

text \<open>
  Next, we look at the ordering defined by a list that is permuted with some permutation
  function. For this, we first define the composition of a relation with a function.
\<close>
definition map_relation :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('b \<times> 'b) set \<Rightarrow> ('a \<times> 'a) set" where
  "map_relation A f R = {(x,y)\<in>A\<times>A. (f x, f y) \<in> R}"

lemma index_distinct_eqI:
  assumes "distinct xs" "i < length xs" "xs ! i = x"
  shows   "index xs x = i"
  using assms by (induction xs arbitrary: i) (auto simp: nth_Cons split: nat.splits)

lemma index_permute_list:
  assumes "\<pi> permutes {..<length xs}" "distinct xs" "x \<in> set xs"
  shows   "index (permute_list \<pi> xs) x = inv \<pi> (index xs x)"
proof -
  have *: "inv \<pi> permutes {..<length xs}" by (rule permutes_inv) fact
  from assms show ?thesis
    using assms permutes_in_image[OF *]
    by (intro index_distinct_eqI) (simp_all add: permute_list_nth permutes_inverses)
qed

lemma linorder_of_list_permute:
  assumes "\<pi> permutes {..<length xs}" "distinct xs"
  shows   "linorder_of_list (permute_list \<pi> xs) =
             map_relation (set xs) ((!) xs \<circ> inv \<pi> \<circ> index xs) (linorder_of_list xs)"
proof -
  note * = permutes_inv[OF assms(1)]
  have less: "inv \<pi> i < length xs" if "i < length xs" for i
    using permutes_in_image[OF *] and that by simp
  from assms and * show ?thesis
    by (auto simp: linorder_of_list_def map_relation_def index_nth_id index_permute_list less)
qed

lemma inj_on_conv_Ex1: "inj_on f A \<longleftrightarrow> (\<forall>y\<in>f`A. \<exists>!x\<in>A. y = f x)"
  by (auto simp: inj_on_def)

lemma bij_betw_conv_Ex1: "bij_betw f A B \<longleftrightarrow> (\<forall>y\<in>B. \<exists>!x\<in>A. f x = y) \<and> B = f ` A"
  unfolding bij_betw_def inj_on_conv_Ex1 by (auto simp: eq_commute)

lemma permutesI:
  assumes "bij_betw f A A" "\<forall>x. x \<notin> A \<longrightarrow> f x = x"
  shows   "f permutes A"
  unfolding permutes_def
proof (intro conjI allI impI)
  fix y
  from assms have [simp]: "f x \<in> A \<longleftrightarrow> x \<in> A" for x
    by (auto simp: bij_betw_def)
  show "\<exists>!x. f x = y"
  proof (cases "y \<in> A")
    case True
    also from assms have "A = f ` A" by (auto simp: bij_betw_def)
    finally obtain x where "x \<in> A" "y = f x" by auto
    with assms and \<open>y \<in> A\<close> show ?thesis
      by (intro ex1I[of _ x]) (auto simp: bij_betw_def dest: inj_onD)
  qed (insert assms, auto)
qed (insert assms, auto)

text \<open>
  We now show the important lemma that any two linear orderings on a finite set can be
  mapped onto each other by a permutation.
\<close>
lemma linorder_permutation_exists:
  assumes "finite A" "linorder_on A R" "linorder_on A R'"
  obtains \<pi> where "\<pi> permutes A" "R' = map_relation A \<pi> R"
proof -
  define xs where "xs = sorted_wrt_list_of_set R A"
  define ys where "ys = sorted_wrt_list_of_set R' A"
  have xs_ys: "distinct xs" "distinct ys" "set xs = A" "set ys = A"
    using assms by (simp_all add: linorder_sorted_wrt_list_of_set xs_def ys_def)

  from xs_ys have "mset ys = mset xs" by (simp add: set_eq_iff_mset_eq_distinct [symmetric])
  from mset_eq_permutation[OF this] guess \<pi> . note \<pi> = this
  define \<pi>' where "\<pi>' = (\<lambda>x. if x \<notin> A then x else xs ! inv \<pi> (index xs x))"
  have \<pi>': "\<pi>' permutes A"
  proof (rule permutesI)
    have "bij_betw ((!) xs \<circ> inv \<pi>) {..<length xs} A"
      by (rule bij_betw_trans permutes_imp_bij permutes_inv \<pi> bij_betw_nth)+ (simp_all add: xs_ys)
    hence "bij_betw ((!) xs \<circ> inv \<pi> \<circ> index xs) A A"
      by (rule bij_betw_trans [rotated] bij_betw_index)+
         (insert bij_betw_index[of xs A "length xs"], simp_all add: xs_ys atLeast0LessThan)
    also have "bij_betw ((!) xs \<circ> inv \<pi> \<circ> index xs) A A \<longleftrightarrow> bij_betw \<pi>' A A"
      by (rule bij_betw_cong) (auto simp: \<pi>'_def)
    finally show \<dots> .
  qed (simp_all add: \<pi>'_def)

  from assms have "R' = linorder_of_list ys" by (simp add: ys_def)
  also from \<pi> have "ys = permute_list \<pi> xs" by simp
  also have "linorder_of_list (permute_list \<pi> xs) =
               map_relation A ((!) xs \<circ> inv \<pi> \<circ> index xs) (linorder_of_list xs)"
    using \<pi> by (subst linorder_of_list_permute) (simp_all add: xs_ys)
  also from assms have "linorder_of_list xs = R" by (simp add: xs_def)
  finally have "R' = map_relation A ((!) xs \<circ> inv \<pi> \<circ> index xs) R" .
  also have "\<dots> = map_relation A \<pi>' R" by (auto simp: map_relation_def \<pi>'_def)
  finally show ?thesis using \<pi>' and that[of \<pi>'] by simp
qed

text \<open>
  We now define the linear ordering defined by some priority function, i.\,e.\ a function
  that injectively associates priorities to every element such that elements with lower priority
  are smaller in the resulting ordering.
\<close>
definition linorder_from_keys :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b :: linorder) \<Rightarrow> ('a \<times> 'a) set" where
  "linorder_from_keys A f = {(x,y)\<in>A\<times>A. f x \<le> f y}"

lemma linorder_from_keys_permute:
  assumes "g permutes A"
  shows   "linorder_from_keys A (f \<circ> g) = map_relation A g (linorder_from_keys A f)"
  using permutes_in_image[OF assms] by (auto simp: map_relation_def linorder_from_keys_def)

lemma linorder_on_linorder_from_keys [intro]:
  assumes "inj_on f A"
  shows   "linorder_on A (linorder_from_keys A f)"
  using assms by (auto simp: linorder_on_def refl_on_def antisym_def linorder_from_keys_def
                    trans_def total_on_def dest: inj_onD)

lemma linorder_from_keys_empty [simp]: "linorder_from_keys {} = (\<lambda>_. {})"
  by (simp add: linorder_from_keys_def fun_eq_iff)

text \<open>
  We now show another important fact, namely that when we draw $n$ values i.\,i.\,d.\ uniformly
  from a non-trivial real interval, we almost surely get distinct values.
\<close>
lemma emeasure_PiM_diagonal:
  fixes a b :: real
  assumes "x \<in> A" "y \<in> A" "x \<noteq> y"
  assumes "a < b" "finite A"
  defines "M \<equiv> uniform_measure lborel {a..b}"
  shows   "emeasure (PiM A (\<lambda>_. M)) {h\<in>A \<rightarrow>\<^sub>E UNIV. h x = h y} = 0"
proof -
  from assms have M: "prob_space M" unfolding M_def
    by (intro prob_space_uniform_measure) auto
  then interpret product_prob_space "\<lambda>_. M" A
    unfolding product_prob_space_def product_prob_space_axioms_def product_sigma_finite_def
    by (auto simp: prob_space_imp_sigma_finite)
  from M interpret pair_sigma_finite M M by unfold_locales
  have [measurable]: "{h\<in>extensional {x, y}. h x = h y} \<in> sets (Pi\<^sub>M {x, y} (\<lambda>i. lborel))"
  proof -
    have "{h\<in>extensional {x,y}. h x = h y} = {h \<in> space (Pi\<^sub>M {x, y} (\<lambda>i. lborel)). h x = h y}"
      by (auto simp: extensional_def space_PiM)
    also have "... \<in> sets (Pi\<^sub>M {x, y} (\<lambda>i. lborel))"
      by measurable
    finally show ?thesis .
  qed
  have [simp]: "sets (PiM A (\<lambda>_. M)) = sets (PiM A (\<lambda>_. lborel))" for A :: "'a set"
    by (intro sets_PiM_cong refl) (simp_all add: M_def)
  have sets_M_M: "sets (M \<Otimes>\<^sub>M M) = sets (borel \<Otimes>\<^sub>M borel)"
    by (intro sets_pair_measure_cong) (auto simp: M_def)
  have [measurable]: "(\<lambda>(b, a). if b = a then 1 else 0) \<in> borel_measurable (M \<Otimes>\<^sub>M M)"
    unfolding measurable_split_conv
    by (subst measurable_cong_sets[OF sets_M_M refl])
       (auto intro!: measurable_If measurable_const measurable_equality_set)

  have "{h\<in>A \<rightarrow>\<^sub>E UNIV. h x = h y} =
          (\<lambda>h. restrict h {x, y}) -` {h\<in>extensional {x, y}. h x = h y} \<inter> space (PiM A (\<lambda>_. M :: real measure))"
    by (auto simp: space_PiM PiE_def extensional_def M_def)
  also have "emeasure (PiM A (\<lambda>_. M)) \<dots> =
               emeasure (distr (PiM A (\<lambda>_. M)) (PiM {x,y} (\<lambda>_. lborel :: real measure))
                 (\<lambda>h. restrict h {x,y})) {h\<in>extensional {x, y}. h x = h y}"
  proof (rule emeasure_distr [symmetric])
    have "(\<lambda>h. restrict h {x, y}) \<in> Pi\<^sub>M A (\<lambda>_. lborel) \<rightarrow>\<^sub>M Pi\<^sub>M {x, y} (\<lambda>_. lborel)"
      using assms by (intro measurable_restrict_subset) auto
    also have "\<dots> = Pi\<^sub>M A (\<lambda>_. M) \<rightarrow>\<^sub>M Pi\<^sub>M {x, y} (\<lambda>_. lborel)"
      by (intro sets_PiM_cong measurable_cong_sets refl) (simp_all add: M_def)
    finally show "(\<lambda>h. restrict h {x, y}) \<in> \<dots>" .
  next
    show "{h\<in>extensional {x, y}. h x = h y} \<in> sets (Pi\<^sub>M {x, y} (\<lambda>_. lborel))" by simp
  qed
  also have "distr (PiM A (\<lambda>_. M)) (PiM {x,y} (\<lambda>_. lborel :: real measure)) (\<lambda>h. restrict h {x,y}) =
               distr (PiM A (\<lambda>_. M)) (PiM {x,y} (\<lambda>_. M)) (\<lambda>h. restrict h {x,y})"
    by (intro distr_cong refl sets_PiM_cong) (simp_all add: M_def)
  also from assms have "\<dots> = Pi\<^sub>M {x, y} (\<lambda>i. M)" by (intro distr_restrict [symmetric]) auto
  also have "emeasure \<dots> {h\<in>extensional {x, y}. h x = h y} =
    nn_integral \<dots> (\<lambda>h. indicator {h\<in>extensional {x, y}. h x = h y} h)"
    by (intro nn_integral_indicator [symmetric]) simp_all
  also have "\<dots> = nn_integral (Pi\<^sub>M {x, y} (\<lambda>i. M)) (\<lambda>h. if h x = h y then 1 else 0)"
    by (intro nn_integral_cong) (auto simp add: indicator_def space_PiM PiE_def)
  also from \<open>x \<noteq> y\<close> have "\<dots> = (\<integral>\<^sup>+ z. (if fst z = snd z then 1 else 0) \<partial>(M \<Otimes>\<^sub>M M))"
    by (intro product_nn_integral_pair) auto
  also have "\<dots> = (\<integral>\<^sup>+ x. (\<integral>\<^sup>+y. (if x = y then 1 else 0) \<partial>M) \<partial>M)"
    by (subst M.nn_integral_fst [symmetric]) simp_all
  also have "\<dots> = (\<integral>\<^sup>+ x. (\<integral>\<^sup>+y. indicator {x} y \<partial>M) \<partial>M)" by (simp add: indicator_def eq_commute)
  also have "\<dots> = (\<integral>\<^sup>+ x. emeasure M {x} \<partial>M)" by (subst nn_integral_indicator) (simp_all add: M_def)
  also have "\<dots> = (\<integral>\<^sup>+ x. 0 \<partial>M)" unfolding M_def
    by (intro nn_integral_cong_AE refl AE_uniform_measureI) auto
  also have "\<dots> = 0" by simp
  finally show ?thesis .
qed

lemma measurable_linorder_from_keys_restrict:
  assumes fin: "finite A"
  shows "linorder_from_keys A \<in> Pi\<^sub>M A (\<lambda>_. borel :: real measure) \<rightarrow>\<^sub>M count_space (Pow (A \<times> A))"
  (is "_ : ?M \<rightarrow>\<^sub>M _")
  apply (subst measurable_count_space_eq2)
  apply (auto simp add: fin linorder_from_keys_def)
proof -
  note fin[simp]
  fix R assume "R \<subseteq> A \<times> A"
  then have "linorder_from_keys A -` {R} \<inter> space ?M =
    {f \<in> space ?M. \<forall>x\<in>A. \<forall>y\<in>A. (x, y) \<in> R \<longleftrightarrow> f x \<le> f y}"
    by (auto simp add: linorder_from_keys_def set_eq_iff)
  also have "\<dots> \<in> sets ?M"
    by measurable
  finally show "linorder_from_keys A -` {R} \<inter> space ?M \<in> sets ?M" .
qed

lemma measurable_count_space_extend:
  assumes "f \<in> measurable M (count_space A)" "A \<subseteq> B"
  shows   "f \<in> measurable M (count_space B)"
proof -
  note assms(1)
  also have "count_space A = restrict_space (count_space B) A"
    using assms(2) by (subst restrict_count_space) (simp_all add: Int_absorb2)
  finally show ?thesis by (simp add: measurable_restrict_space2_iff)
qed

lemma measurable_linorder_from_keys_restrict':
  assumes fin: "finite A" "A \<subseteq> B"
  shows "linorder_from_keys A \<in> Pi\<^sub>M A (\<lambda>_. borel :: real measure) \<rightarrow>\<^sub>M count_space (Pow (B \<times> B))"
  apply (rule measurable_count_space_extend)
   apply (rule measurable_linorder_from_keys_restrict[OF assms(1)])
  using assms by auto

context
  fixes a b :: real and A :: "'a set" and M and B
  assumes fin: "finite A" and ab: "a < b" and B: "A \<subseteq> B"
  defines "M \<equiv> distr (PiM A (\<lambda>_. uniform_measure lborel {a..b}))
                  (count_space (Pow (B \<times> B))) (linorder_from_keys A)"
begin

lemma measurable_linorder_from_keys [measurable]:
  "linorder_from_keys A \<in> Pi\<^sub>M A (\<lambda>_. borel :: real measure) \<rightarrow>\<^sub>M count_space (Pow (B \<times> B))"
  by (rule measurable_linorder_from_keys_restrict') (auto simp: fin B)

text \<open>
  The ordering defined by randomly-chosen priorities is almost surely linear:
\<close>
theorem almost_everywhere_linorder: "AE R in M. linorder_on A R"
proof -
  define N where "N = PiM A (\<lambda>_. uniform_measure lborel {a..b})"
  have [simp]: "sets (Pi\<^sub>M A (\<lambda>_. uniform_measure lborel {a..b})) = sets (PiM A (\<lambda>_. lborel))"
    by (intro sets_PiM_cong) simp_all
  let ?M_A = "(Pi\<^sub>M A (\<lambda>_. lborel :: real measure))"
  have meas: "{h \<in> A \<rightarrow>\<^sub>E UNIV. h i = h j} \<in> sets ?M_A"
    if [simp]: "i \<in> A" "j \<in> A" for i j
  proof -
    have "{h \<in> A \<rightarrow>\<^sub>E UNIV. h i = h j} = {h \<in> space ?M_A. h i = h j}"
      by (auto simp: space_PiM)
    also have "... \<in> sets ?M_A"
      by measurable
    finally show ?thesis .
  qed
  define X :: "('a \<Rightarrow> real) set" where "X = (\<Union>x\<in>A. \<Union>y\<in>A-{x}. {h\<in>A \<rightarrow>\<^sub>E UNIV. h x = h y})"
  have "AE f in N. inj_on f A"
  proof (rule AE_I)
    show "{f \<in> space N. \<not> inj_on f A} \<subseteq> X"
      by (auto simp: inj_on_def X_def space_PiM N_def)
  next
    show "X \<in> sets N" unfolding X_def N_def
      using meas by (auto intro!: countable_finite fin sets.countable_UN')
  next
    have "emeasure N X \<le> (\<Sum>i\<in>A. emeasure N (\<Union>y\<in>A - {i}. {h \<in> A \<rightarrow>\<^sub>E UNIV. h i = h y}))"
      unfolding X_def N_def using fin meas
      by (intro emeasure_subadditive_finite)
         (auto simp: disjoint_family_on_def intro!: sets.countable_UN' countable_finite)
    also have "\<dots> \<le> (\<Sum>i\<in>A. \<Sum>j\<in>A-{i}. emeasure N {h \<in> A \<rightarrow>\<^sub>E UNIV. h i = h j})"
      unfolding N_def using fin meas
      by (intro emeasure_subadditive_finite sum_mono)
         (auto simp: disjoint_family_on_def intro!: sets.countable_UN' countable_finite)
    also have "\<dots> = (\<Sum>i\<in>A. \<Sum>j\<in>A-{i}. 0)" unfolding N_def using fin ab
      by (intro sum.cong refl emeasure_PiM_diagonal) auto
    also have "\<dots> = 0" by simp
    finally show "emeasure N X = 0" by simp
  qed
  hence "AE f in N. linorder_on A (linorder_from_keys A f)"
    by eventually_elim auto
  thus ?thesis unfolding M_def N_def
    by (subst AE_distr_iff) auto
qed

text \<open>
  Furthermore, this is equivalent to choosing one of the $|A|!$ linear orderings uniformly
  at random.
\<close>
theorem random_linorder_by_prios:
  "M = uniform_measure (count_space (Pow (B \<times> B))) (linorders_on A)"
proof -
  from linorders_finite_nonempty[OF fin] obtain R where R: "linorder_on A R"
    by (auto simp: linorders_on_def)

  have *: "emeasure M {R} \<le> emeasure M {R'}" if "linorder_on A R" "linorder_on A R'" for R R'
  proof -
    define N where "N = PiM A (\<lambda>_. uniform_measure lborel {a..b})"
    from linorder_permutation_exists[OF fin that]
    obtain \<pi> where \<pi>: "\<pi> permutes A" "R' = map_relation A \<pi> R"
      by blast
    have "(\<lambda>f. f \<circ> \<pi>) \<in> Pi\<^sub>M A (\<lambda>_. lborel :: real measure) \<rightarrow>\<^sub>M Pi\<^sub>M A (\<lambda>_. lborel :: real measure)"
      by (auto intro!: measurable_PiM_single' measurable_PiM_component_rev
          simp: comp_def permutes_in_image[OF \<pi>(1)] space_PiM PiE_def extensional_def)
    also have "\<dots> = N \<rightarrow>\<^sub>M Pi\<^sub>M A (\<lambda>_. lborel)"
      unfolding N_def by (intro measurable_cong_sets refl sets_PiM_cong) simp_all
    finally have [measurable]: "(\<lambda>f. f \<circ> \<pi>) \<in> \<dots>" .

    have [simp]: "measurable N X = measurable (PiM A (\<lambda>_. lborel)) X" for X :: "('a \<times> 'a) set measure"
      unfolding N_def by (intro measurable_cong_sets refl sets_PiM_cong) simp_all
    have [simp]: "measurable M X = measurable (count_space (Pow (B \<times> B))) X" for X :: "('a \<times> 'a) set measure"
      unfolding M_def by simp

    have M_eq: "M = distr N (count_space (Pow (B \<times> B))) (linorder_from_keys A)"
      by (simp only: M_def N_def)
    also have "N = distr N (PiM A (\<lambda>_. lborel)) (\<lambda>f. f \<circ> \<pi>)"
      unfolding N_def by (rule PiM_uniform_measure_permute [symmetric]) fact+
    also have "distr \<dots> (count_space (Pow (B \<times> B))) (linorder_from_keys A) =
                 distr N (count_space (Pow (B \<times> B))) (linorder_from_keys A \<circ> (\<lambda>f. f \<circ> \<pi>)) "
      by (intro distr_distr) simp_all
    also have "\<dots> = distr N (count_space (Pow (B \<times> B))) (map_relation A \<pi> \<circ> linorder_from_keys A)"
      by (intro distr_cong refl) (auto simp: linorder_from_keys_permute[OF \<pi>(1)])
    also have "\<dots> = distr M (count_space (Pow (B \<times> B))) (map_relation A \<pi>)"
      unfolding M_eq using B
      by (intro distr_distr [symmetric]) (auto simp: map_relation_def)
    finally have M_eq': "distr M (count_space (Pow (B \<times> B))) (map_relation A \<pi>) = M" ..

    from that have subset': "R \<subseteq> B \<times> B" "R' \<subseteq> B \<times> B"
      using B by (auto simp: linorder_on_def refl_on_def)
    hence "emeasure M {R} \<le> emeasure M (map_relation A \<pi> -` {R'} \<inter> space M)"
      using subset' by (intro emeasure_mono) (auto simp: M_def \<pi> )
    also have "\<dots> = emeasure (distr M (count_space (Pow (B \<times> B))) (map_relation A \<pi>)) {R'} "
      by (rule emeasure_distr [symmetric]) (insert subset' B, auto simp: map_relation_def)
    also note M_eq'
    finally show ?thesis .
  qed
  have same_prob: "emeasure M {R'} = emeasure M {R}" if "linorder_on A R'" for R'
    using *[of R R'] and *[of R' R] and R and that by simp

  from ab have "prob_space M"
    unfolding M_def
    by (intro prob_space.prob_space_distr prob_space_PiM prob_space_uniform_measure) simp_all
  hence "1 = emeasure M (Pow (B \<times> B))"
    using prob_space.emeasure_space_1[OF \<open>prob_space M\<close>] by (simp add: M_def)
  also have "(Pow (B \<times> B)) = linorders_on A \<union> ((Pow (B \<times> B))-linorders_on A)"
    using B by (auto simp: linorders_on_def linorder_on_def refl_on_def)
  also have "emeasure M \<dots> = emeasure M (linorders_on A) + emeasure M (Pow (B \<times> B)-linorders_on A)"
    using B by (subst plus_emeasure) (auto simp: M_def linorders_on_def linorder_on_def refl_on_def)
  also have "emeasure M (Pow (B \<times> B)-linorders_on A) = 0" using almost_everywhere_linorder
    by (subst (asm) AE_iff_measurable) (auto simp: linorders_on_def M_def)
  also from fin have "emeasure M (linorders_on A) = (\<Sum>R'\<in>linorders_on A. emeasure M {R'})"
    using B by (intro emeasure_eq_sum_singleton)
               (auto simp: M_def  linorders_on_def linorder_on_def refl_on_def)
  also have "\<dots> = (\<Sum>R'\<in>linorders_on A. emeasure M {R})"
    by (rule sum.cong) (simp_all add: linorders_on_def same_prob)
  also from fin have "\<dots> = fact (card A) * emeasure M {R}"
    by (simp add: linorders_on_def card_finite_linorders)
  finally have [simp]: "emeasure M {R} = inverse (fact (card A))"
    by (simp add: inverse_ennreal_unique)

  show ?thesis
  proof (rule measure_eqI_countable_AE')
    show "sets M = Pow (Pow (B \<times> B))"
      by (simp add: M_def)
  next
    from \<open>finite A\<close> show "countable (linorders_on A)"
      by (blast intro: countable_finite)
  next
    show "AE R in uniform_measure (count_space (Pow (B \<times> B)))
            (linorders_on A). R \<in> linorders_on A"
      by (rule AE_uniform_measureI)
         (insert B, auto simp: linorders_on_def linorder_on_def refl_on_def)
  next
    fix R' assume R': "R' \<in> linorders_on A"
    have subset: "linorders_on A \<subseteq> Pow (B \<times> B)"
      using B by (auto simp: linorders_on_def linorder_on_def refl_on_def)
    have "emeasure (uniform_measure (count_space (Pow (B \<times> B)))
           (linorders_on A)) {R'} = emeasure (count_space (Pow (B \<times> B))) (linorders_on A \<inter> {R'}) /
                                      emeasure (count_space (Pow (B \<times> B))) (linorders_on A)"
      using R' B by (subst emeasure_uniform_measure) (auto simp: linorders_on_def linorder_on_def refl_on_def)
    also have "\<dots> = 1 / emeasure (count_space (Pow (B \<times> B))) (linorders_on A)"
      using R' B by (subst emeasure_count_space) (auto simp: linorders_on_def linorder_on_def refl_on_def)
    also have "\<dots> = 1 / fact (card A)"
      using fin finite_linorders_on[of A]
      by (subst emeasure_count_space [OF subset])
         (auto simp: divide_ennreal [symmetric] linorders_on_def card_finite_linorders)
    also have "\<dots> = emeasure M {R}"
      by (simp add: field_simps divide_ennreal_def)
    also have "\<dots> = emeasure M {R'}"
      using R' by (intro same_prob [symmetric]) (auto simp: linorders_on_def)
    finally show "emeasure M {R'} = emeasure (uniform_measure (count_space (Pow (B \<times> B)))
                    (linorders_on A)) {R'}" ..
  next
    show "linorders_on A \<subseteq> Pow (B \<times> B)"
      using B by (auto simp: linorders_on_def linorder_on_def refl_on_def)
  qed (auto simp: M_def linorders_on_def almost_everywhere_linorder)
qed

end
end


theory Numbers
imports Complex_Main
begin

text\<open>

numeric literals; default simprules; can re-orient
\<close>

lemma "2 * m = m + m"
txt\<open>
@{subgoals[display,indent=0,margin=65]}
\<close>
oops

fun h :: "nat \<Rightarrow> nat" where
"h i = (if i = 3 then 2 else i)"

text\<open>
\<^term>\<open>h 3 = 2\<close>
\<^term>\<open>h i  = i\<close>
\<close>

text\<open>
@{thm[display] numeral_One[no_vars]}
\rulename{numeral_One}

@{thm[display] add_2_eq_Suc[no_vars]}
\rulename{add_2_eq_Suc}

@{thm[display] add_2_eq_Suc'[no_vars]}
\rulename{add_2_eq_Suc'}

@{thm[display] add.assoc[no_vars]}
\rulename{add.assoc}

@{thm[display] add.commute[no_vars]}
\rulename{add.commute}

@{thm[display] add.left_commute[no_vars]}
\rulename{add.left_commute}

these form ac_simps; similarly there is ac_simps
\<close>

lemma "Suc(i + j*l*k + m*n) = f (n*m + i + k*j*l)"
txt\<open>
@{subgoals[display,indent=0,margin=65]}
\<close>
apply (simp add: ac_simps ac_simps)
txt\<open>
@{subgoals[display,indent=0,margin=65]}
\<close>
oops

text\<open>

@{thm[display] div_le_mono[no_vars]}
\rulename{div_le_mono}

@{thm[display] diff_mult_distrib[no_vars]}
\rulename{diff_mult_distrib}

@{thm[display] mult_mod_left[no_vars]}
\rulename{mult_mod_left}

@{thm[display] nat_diff_split[no_vars]}
\rulename{nat_diff_split}
\<close>

lemma "(n - 1) * (n + 1) = n * n - (1::nat)"
apply (clarsimp split: nat_diff_split iff del: less_Suc0)
 \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (subgoal_tac "n=0", force, arith)
done

lemma "(n - 2) * (n + 2) = n * n - (4::nat)"
apply (simp split: nat_diff_split, clarify)
 \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (subgoal_tac "n=0 | n=1", force, arith)
done

text\<open>
@{thm[display] mod_if[no_vars]}
\rulename{mod_if}

@{thm[display] div_mult_mod_eq[no_vars]}
\rulename{div_mult_mod_eq}

@{thm[display] div_mult1_eq[no_vars]}
\rulename{div_mult1_eq}

@{thm[display] mod_mult_right_eq[no_vars]}
\rulename{mod_mult_right_eq}

@{thm[display] div_mult2_eq[no_vars]}
\rulename{div_mult2_eq}

@{thm[display] mod_mult2_eq[no_vars]}
\rulename{mod_mult2_eq}

@{thm[display] div_mult_mult1[no_vars]}
\rulename{div_mult_mult1}

@{thm[display] div_by_0 [no_vars]}
\rulename{div_by_0}

@{thm[display] mod_by_0 [no_vars]}
\rulename{mod_by_0}

@{thm[display] dvd_antisym[no_vars]}
\rulename{dvd_antisym}

@{thm[display] dvd_add[no_vars]}
\rulename{dvd_add}

For the integers, I'd list a few theorems that somehow involve negative
numbers.\<close>

text\<open>
Division, remainder of negatives

@{thm[display] pos_mod_sign[no_vars]}
\rulename{pos_mod_sign}

@{thm[display] pos_mod_bound[no_vars]}
\rulename{pos_mod_bound}

@{thm[display] neg_mod_sign[no_vars]}
\rulename{neg_mod_sign}

@{thm[display] neg_mod_bound[no_vars]}
\rulename{neg_mod_bound}

@{thm[display] div_add1_eq[no_vars]}
\rulename{div_add1_eq}

@{thm[display] mod_add_eq[no_vars]}
\rulename{mod_add_eq}

@{thm[display] div_mult1_eq[no_vars]}
\rulename{div_mult1_eq}

@{thm[display] mod_mult_right_eq[no_vars]}
\rulename{mod_mult_right_eq}

@{thm[display] zdiv_zmult2_eq[no_vars]}
\rulename{zdiv_zmult2_eq}

@{thm[display] zmod_zmult2_eq[no_vars]}
\rulename{zmod_zmult2_eq}
\<close>

lemma "abs (x+y) \<le> abs x + abs (y :: int)"
by arith

lemma "abs (2*x) = 2 * abs (x :: int)"
by (simp add: abs_if)

text \<open>Induction rules for the Integers

@{thm[display] int_ge_induct[no_vars]}
\rulename{int_ge_induct}

@{thm[display] int_gr_induct[no_vars]}
\rulename{int_gr_induct}

@{thm[display] int_le_induct[no_vars]}
\rulename{int_le_induct}

@{thm[display] int_less_induct[no_vars]}
\rulename{int_less_induct}
\<close>

text \<open>FIELDS

@{thm[display] dense[no_vars]}
\rulename{dense}

@{thm[display] times_divide_eq_right[no_vars]}
\rulename{times_divide_eq_right}

@{thm[display] times_divide_eq_left[no_vars]}
\rulename{times_divide_eq_left}

@{thm[display] divide_divide_eq_right[no_vars]}
\rulename{divide_divide_eq_right}

@{thm[display] divide_divide_eq_left[no_vars]}
\rulename{divide_divide_eq_left}

@{thm[display] minus_divide_left[no_vars]}
\rulename{minus_divide_left}

@{thm[display] minus_divide_right[no_vars]}
\rulename{minus_divide_right}

This last NOT a simprule

@{thm[display] add_divide_distrib[no_vars]}
\rulename{add_divide_distrib}
\<close>

lemma "3/4 < (7/8 :: real)"
by simp

lemma "P ((3/4) * (8/15 :: real))"
txt\<open>
@{subgoals[display,indent=0,margin=65]}
\<close>
apply simp
txt\<open>
@{subgoals[display,indent=0,margin=65]}
\<close>
oops

lemma "(3/4) * (8/15) < (x :: real)"
txt\<open>
@{subgoals[display,indent=0,margin=65]}
\<close>
apply simp
txt\<open>
@{subgoals[display,indent=0,margin=65]}
\<close>
oops

text\<open>
Ring and Field

Requires a field, or else an ordered ring

@{thm[display] mult_eq_0_iff[no_vars]}
\rulename{mult_eq_0_iff}

@{thm[display] mult_cancel_right[no_vars]}
\rulename{mult_cancel_right}

@{thm[display] mult_cancel_left[no_vars]}
\rulename{mult_cancel_left}
\<close>

text\<open>
effect of show sorts on the above

@{thm[display,show_sorts] mult_cancel_left[no_vars]}
\rulename{mult_cancel_left}
\<close>

text\<open>
absolute value

@{thm[display] abs_mult[no_vars]}
\rulename{abs_mult}

@{thm[display] abs_le_iff[no_vars]}
\rulename{abs_le_iff}

@{thm[display] abs_triangle_ineq[no_vars]}
\rulename{abs_triangle_ineq}

@{thm[display] power_add[no_vars]}
\rulename{power_add}

@{thm[display] power_mult[no_vars]}
\rulename{power_mult}

@{thm[display] power_abs[no_vars]}
\rulename{power_abs}

\<close>

end


section "Solution to Day 6 of AoC 2020"

theory day6
  imports Main "HOL.Code_Numeral" string_utils list_natural_utils natural_utils list_utils
begin

text "This is a solution to the puzzle for day 6"

subsection "Input parsing"

text "We want a list of lists of sets of chars representing the list of groups which are lists of
people who responded yes to each question in a set of questions, and no to any other question.
Except that sets are awkward (as a datatype in isabelle) so we use lists instead, with our own
functions for insert (set\\_cons) and a set-from-list function (uniq)"

fun set_cons :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list"
  where "set_cons a l = (if contains a l then l else Cons a l)"

fun uniq :: "'a list \<Rightarrow> 'a list"
  where "uniq [] = []"
  | "uniq (Cons h t) = (set_cons h (uniq t))"

definition parse_input :: "string \<Rightarrow> char list list list"
  where "parse_input a = (
    map (map uniq \<circ> split CHR '' '')
    (split CHR ''\<newline>''
      (join_lines CHR '' '' (trim a))
    )
  )"

subsection "Solution Algorithm"

text "In part 1 we just sum the sizes of the sets for each group of people"

definition union :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"
  where "union a b = uniq (a @ b)"

definition part1 :: "string \<Rightarrow> natural"
  where "part1 s = (let data = parse_input s in
    sum_list (
    map (
      natural_len \<circ> (reduce union [])
    ) data)
  )"

text "For part 2 we just use the intersection of all the sets, instead of the union"

definition intersection :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"
  where "intersection a b = (filter (\<lambda>x. contains x b) a)"

fun intersect_all :: "'a list list \<Rightarrow> 'a list"
  where "intersect_all [] = []"
  | "intersect_all (Cons h t) = reduce intersection h t"

definition part2 :: "string \<Rightarrow> natural"
  where "part2 s = (let data = parse_input s in
    sum_list (
    map (
      natural_len \<circ> intersect_all
    ) data)
  )"

subsection "Testing"

text "This example input should return 11"

definition example_input::string where "example_input = ''
abc

a
b
c

ab
ac

a
a
a
a

b
''"

lemma  "part1 example_input = 11"
  by eval

text "The same example input for part 2 should return 6"

lemma "part2 example_input = 6"
  by eval

export_code "part1" "part2" in Haskell module_name Solution

end


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

section \<open>Definition of Equivalence Classes\<close>

theory Equiv_Relations_on_Functions
imports
  Preliminaries
  Twelvefold_Way_Core
begin

subsection \<open>Permutation on the Domain\<close>

definition domain_permutation
where
  "domain_permutation A B = {(f, f') \<in> (A \<rightarrow>\<^sub>E B) \<times> (A \<rightarrow>\<^sub>E B). \<exists>p. p permutes A \<and> (\<forall>x \<in> A. f x = f' (p x))}"

lemma equiv_domain_permutation:
  "equiv (A \<rightarrow>\<^sub>E B) (domain_permutation A B)"
proof (rule equivI)
  show "refl_on (A \<rightarrow>\<^sub>E B) (domain_permutation A B)"
  proof (rule refl_onI)
    show "domain_permutation A B \<subseteq> (A \<rightarrow>\<^sub>E B) \<times> (A \<rightarrow>\<^sub>E B)"
      unfolding domain_permutation_def by auto
  next
    fix f
    assume "f \<in> A \<rightarrow>\<^sub>E B"
    from this show "(f, f) \<in> domain_permutation A B"
      using permutes_id unfolding domain_permutation_def by fastforce
  qed
next
  show "sym (domain_permutation A B)"
  proof (rule symI)
    fix f f'
    assume "(f, f') \<in> domain_permutation A B"
    from this obtain p where "p permutes A" and "\<forall>x\<in>A. f x = f' (p x)"
      unfolding domain_permutation_def by auto
    from \<open>(f, f') \<in> domain_permutation A B\<close> have "f \<in> A \<rightarrow>\<^sub>E B" "f' \<in> A \<rightarrow>\<^sub>E B"
      unfolding domain_permutation_def by auto
    moreover from \<open>p permutes A\<close> have "inv p permutes A"
      by (simp add: permutes_inv)
    moreover from \<open>p permutes A\<close> \<open>\<forall>x\<in>A. f x = f' (p x)\<close> have "\<forall>x\<in>A. f' x = f (inv p x)"
      using permutes_in_image permutes_inverses(1) by (metis (mono_tags, hide_lams))
    ultimately show "(f', f) \<in> domain_permutation A B"
      unfolding domain_permutation_def by auto
  qed
next
  show "trans (domain_permutation A B)"
  proof (rule transI)
    fix f f' f''
    assume "(f, f') \<in> domain_permutation A B" "(f', f'') \<in> domain_permutation A B"
    from \<open>(f, f') \<in> _\<close> obtain p where "p permutes A" and "\<forall>x\<in>A. f x = f' (p x)"
      unfolding domain_permutation_def by auto
    from \<open>(f', f'') \<in> _\<close> obtain p' where "p' permutes A" and "\<forall>x\<in>A. f' x = f'' (p' x)"
      unfolding domain_permutation_def by auto
    from \<open>(f, f') \<in> domain_permutation A B\<close> have "f \<in> A \<rightarrow>\<^sub>E B"
      unfolding domain_permutation_def by auto
    moreover from \<open>(f', f'') \<in> domain_permutation A B\<close> have "f'' \<in> A \<rightarrow>\<^sub>E B"
      unfolding domain_permutation_def by auto
    moreover from \<open>p permutes A\<close> \<open>p' permutes A\<close> have "(p' \<circ> p) permutes A"
      by (simp add: permutes_compose)
    moreover have "\<forall>x\<in>A. f x = f'' ((p' \<circ> p) x)"
      using \<open>\<forall>x\<in>A. f x = f' (p x)\<close> \<open>\<forall>x\<in>A. f' x = f'' (p' x)\<close> \<open>p permutes A\<close>
      by (simp add: permutes_in_image)
    ultimately show "(f, f'') \<in> domain_permutation A B"
      unfolding domain_permutation_def by auto
  qed
qed

subsubsection \<open>Respecting Functions\<close>

lemma inj_on_respects_domain_permutation:
  "(\<lambda>f. inj_on f A) respects domain_permutation A B"
proof (rule congruentI)
  fix f f'
  assume "(f, f') \<in> domain_permutation A B"
  from this obtain p where p: "p permutes A" "\<forall>x\<in>A. f x = f' (p x)"
    unfolding domain_permutation_def by auto
  have inv_p: "\<forall>x\<in>A. f' x = f (inv p x)"
    using p by (metis permutes_inverses(1) permutes_not_in)
  show "inj_on f A \<longleftrightarrow> inj_on f' A"
  proof
    assume "inj_on f A"
    show "inj_on f' A"
    proof (rule inj_onI)
      fix a a'
      assume "a \<in> A" "a' \<in> A" "f' a = f' a'"
      from this \<open>p permutes A\<close> have "inv p a \<in> A" "inv p a' \<in> A"
        by (simp add:  permutes_in_image permutes_inv)+
      have "f (inv p a) = f (inv p a')"
        using \<open>f' a = f' a'\<close> \<open>a \<in> A\<close> \<open>a' \<in> A\<close> inv_p by auto
      from \<open>inj_on f A\<close> this \<open>inv p a \<in> A\<close> \<open>inv p a' \<in> A\<close> have "inv p a = inv p a'"
        using inj_on_contraD by fastforce
      from this show "a = a'"
        by (metis \<open>p permutes A\<close> permutes_inverses(1))
    qed
  next
    assume "inj_on f' A"
    from this p show "inj_on f A"
      unfolding inj_on_def
      by (metis inj_on_contraD permutes_in_image permutes_inj_on)
  qed
qed

lemma image_respects_domain_permutation:
  "(\<lambda>f. f ` A) respects (domain_permutation A B)"
proof (rule congruentI)
  fix f f'
  assume "(f, f') \<in> domain_permutation A B"
  from this obtain p where p: "p permutes A" and f_eq: "\<forall>x\<in>A. f x = f' (p x)"
    unfolding domain_permutation_def by auto
  show "f ` A = f' ` A"
  proof
    from p f_eq show "f ` A \<subseteq> f' ` A"
      by (auto simp add: permutes_in_image)
  next
    from \<open>p permutes A\<close> \<open>\<forall>x\<in>A. f x = f' (p x)\<close> have "\<forall>x\<in>A. f' x = f (inv p x)"
      using permutes_in_image permutes_inverses(1) by (metis (mono_tags, hide_lams))
    from this show "f' ` A \<subseteq> f ` A"
      using \<open>p permutes A\<close> by (auto simp add: permutes_inv permutes_in_image)
  qed
qed

lemma surjective_respects_domain_permutation:
  "(\<lambda>f. f ` A = B) respects domain_permutation A B"
by (metis image_respects_domain_permutation congruentD congruentI)

lemma bij_betw_respects_domain_permutation:
  "(\<lambda>f. bij_betw f A B) respects domain_permutation A B"
proof (rule congruentI)
  fix f f'
  assume "(f, f') \<in> domain_permutation A B"
  from this obtain p where "p permutes A" and "\<forall>x\<in>A. f x = f' (p x)"
    unfolding domain_permutation_def by auto
  have "bij_betw f A B \<longleftrightarrow> bij_betw (f' o p) A B"
    using \<open>\<forall>x\<in>A. f x = f' (p x)\<close>
    by (metis (mono_tags, hide_lams) bij_betw_cong comp_apply)
  also have "... \<longleftrightarrow> bij_betw f' A B"
    using \<open>p permutes A\<close>
    by (auto intro!: bij_betw_comp_iff[symmetric] permutes_imp_bij)
  finally show "bij_betw f A B \<longleftrightarrow> bij_betw f' A B" .
qed

lemma image_mset_respects_domain_permutation:
  shows "(\<lambda>f. image_mset f (mset_set A)) respects (domain_permutation A B)"
proof (rule congruentI)
  fix f f'
  assume "(f, f') \<in> domain_permutation A B"
  from this obtain p where "p permutes A" and "\<forall>x\<in>A. f x = f' (p x)"
    unfolding domain_permutation_def by auto
  from this show "image_mset f (mset_set A) = image_mset f' (mset_set A)"
    using permutes_implies_image_mset_eq by fastforce
qed

subsection \<open>Permutation on the Range\<close>

definition range_permutation
where
  "range_permutation A B = {(f, f') \<in> (A \<rightarrow>\<^sub>E B) \<times> (A \<rightarrow>\<^sub>E B). \<exists>p. p permutes B \<and> (\<forall>x \<in> A. f x = p (f' x))}"

lemma equiv_range_permutation:
  "equiv (A \<rightarrow>\<^sub>E B) (range_permutation A B)"
proof (rule equivI)
  show "refl_on (A \<rightarrow>\<^sub>E B) (range_permutation A B)"
  proof (rule refl_onI)
    show "range_permutation A B \<subseteq> (A \<rightarrow>\<^sub>E B) \<times> (A \<rightarrow>\<^sub>E B)"
      unfolding range_permutation_def by auto
  next
    fix f
    assume "f \<in> A \<rightarrow>\<^sub>E B"
    from this show "(f, f) \<in> range_permutation A B"
      using permutes_id unfolding range_permutation_def by fastforce
  qed
next
  show "sym (range_permutation A B)"
  proof (rule symI)
    fix f f'
    assume "(f, f') \<in> range_permutation A B"
    from this obtain p where "p permutes B" and "\<forall>x\<in>A. f x = p (f' x)"
      unfolding range_permutation_def by auto
    from \<open>(f, f') \<in> range_permutation A B\<close> have "f \<in> A \<rightarrow>\<^sub>E B" "f' \<in> A \<rightarrow>\<^sub>E B"
      unfolding range_permutation_def by auto
    moreover from \<open>p permutes B\<close> have "inv p permutes B"
      by (simp add: permutes_inv)
    moreover from \<open>p permutes B\<close> \<open>\<forall>x\<in>A. f x = p (f' x)\<close> have "\<forall>x\<in>A. f' x = inv p (f x)"
      by (simp add: permutes_inverses(2))
    ultimately show "(f', f) \<in> range_permutation A B"
      unfolding range_permutation_def by auto
  qed
next
  show "trans (range_permutation A B)"
  proof (rule transI)
    fix f f' f''
    assume "(f, f') \<in> range_permutation A B" "(f', f'') \<in> range_permutation A B"
    from \<open>(f, f') \<in> _\<close> obtain p where "p permutes B" and "\<forall>x\<in>A. f x = p (f' x)"
      unfolding range_permutation_def by auto
    from \<open>(f', f'') \<in> _\<close> obtain p' where "p' permutes B" and "\<forall>x\<in>A. f' x = p' (f'' x)"
      unfolding range_permutation_def by auto
    from \<open>(f, f') \<in> range_permutation A B\<close> have "f \<in> A \<rightarrow>\<^sub>E B"
      unfolding range_permutation_def by auto
    moreover from \<open>(f', f'') \<in> range_permutation A B\<close> have "f'' \<in> A \<rightarrow>\<^sub>E B"
      unfolding range_permutation_def by auto
    moreover from \<open>p permutes B\<close> \<open>p' permutes B\<close> have "(p \<circ> p') permutes B"
      by (simp add: permutes_compose)
    moreover have "\<forall>x\<in>A. f x = (p \<circ> p') (f'' x)"
      using \<open>\<forall>x\<in>A. f x = p (f' x)\<close> \<open>\<forall>x\<in>A. f' x = p' (f'' x)\<close> by auto
    ultimately show "(f, f'') \<in> range_permutation A B"
      unfolding range_permutation_def by auto
  qed
qed

subsubsection \<open>Respecting Functions\<close>

lemma inj_on_respects_range_permutation:
  "(\<lambda>f. inj_on f A) respects range_permutation A B"
proof (rule congruentI)
  fix f f'
  assume "(f, f') \<in> range_permutation A B"
  from this obtain p where p: "p permutes B" "\<forall>x\<in>A. f x = p (f' x)"
    unfolding range_permutation_def by auto
  have inv_p: "\<forall>x\<in>A. f' x = inv p (f x)"
    using p by (simp add: permutes_inverses(2))
  show "inj_on f A \<longleftrightarrow> inj_on f' A"
  proof
    assume "inj_on f A"
    from this p show "inj_on f' A"
      unfolding inj_on_def by auto
  next
    assume "inj_on f' A"
    from this inv_p show "inj_on f A"
      unfolding inj_on_def by auto
  qed
qed

lemma surj_on_respects_range_permutation:
  "(\<lambda>f. f ` A = B) respects range_permutation A B"
proof (rule congruentI)
  fix f f'
  assume a: "(f, f') \<in> range_permutation A B"
  from this have "f \<in> A \<rightarrow>\<^sub>E B" "f' \<in> A \<rightarrow>\<^sub>E B"
    unfolding range_permutation_def by auto
  from a obtain p where p: "p permutes B" "\<forall>x\<in>A. f x = p (f' x)"
    unfolding range_permutation_def by auto
  have 1: "f ` A = (\<lambda>x. p (f' x)) ` A"
    using p by (meson image_cong)
  have 2: "inv p ` ((\<lambda>x. p (f' x)) ` A) = f' ` A"
    using p by (simp add: image_image image_inv_f_f permutes_inj)
  show "(f ` A = B) = (f' ` A = B)"
  proof
    assume "f ` A = B"
    from this 1 2 show "f' ` A = B"
      using p by (simp add: permutes_image permutes_inv)
  next
    assume "f' ` A = B"
    from this 1 2 show "f ` A = B"
      using p by (metis image_image permutes_image)
  qed
qed

lemma bij_betw_respects_range_permutation:
  "(\<lambda>f. bij_betw f A B) respects range_permutation A B"
proof (rule congruentI)
  fix f f'
  assume "(f, f') \<in> range_permutation A B"
  from this obtain p where "p permutes B" and "\<forall>x\<in>A. f x = p (f' x)"
    and "f' \<in> A \<rightarrow>\<^sub>E B"
    unfolding range_permutation_def by auto
  have "bij_betw f A B \<longleftrightarrow> bij_betw (p o f') A B"
    using \<open>\<forall>x\<in>A. f x = p (f' x)\<close>
    by (metis (mono_tags, hide_lams) bij_betw_cong comp_apply)
  also have "... \<longleftrightarrow> bij_betw f' A B"
    using \<open>f' \<in> A \<rightarrow>\<^sub>E B\<close> \<open>p permutes B\<close>
    by (auto intro!: bij_betw_comp_iff2[symmetric] permutes_imp_bij)
  finally show "bij_betw f A B \<longleftrightarrow> bij_betw f' A B" .
qed

lemma domain_partitions_respects_range_permutation:
  "(\<lambda>f. (\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}) respects range_permutation A B"
proof (rule congruentI)
  fix f f'
  assume "(f, f') \<in> range_permutation A B"
  from this obtain p where p: "p permutes B" "\<forall>x \<in> A. f x = p (f' x)"
    unfolding range_permutation_def by blast
  have "{} \<in> (\<lambda>b. {x \<in> A. f' x = b}) ` B \<longleftrightarrow> \<not> (\<forall>b \<in> B. \<exists>x \<in> A. f' x = b)" by auto
  also have "(\<forall>b \<in> B. \<exists>x \<in> A. f' x = b) \<longleftrightarrow> (\<forall>b \<in> B. \<exists>x \<in> A. p (f' x) = b)"
  proof
    assume "\<forall>b\<in>B. \<exists>x\<in>A. f' x = b"
    from this show "\<forall>b\<in>B. \<exists>x\<in>A. p (f' x) = b"
      using \<open>p permutes B\<close> unfolding permutes_def by metis
  next
    assume "\<forall>b\<in>B. \<exists>x\<in>A. p (f' x) = b"
    from this show "\<forall>b\<in>B. \<exists>x\<in>A. f' x = b"
      using \<open>p permutes B\<close> by (metis bij_betwE permutes_imp_bij permutes_inverses(2))
  qed
  also have "\<not> (\<forall>b\<in>B. \<exists>x\<in>A. p (f' x) = b) \<longleftrightarrow> {} \<in> (\<lambda>b. {x \<in> A. p (f' x) = b}) ` B" by auto
  finally have "{} \<in> (\<lambda>b. {x \<in> A. f' x = b}) ` B \<longleftrightarrow> {} \<in> (\<lambda>b. {x \<in> A. p (f' x) = b}) ` B" .
  moreover have "(\<lambda>b. {x \<in> A. f' x = b}) ` B = (\<lambda>b. {x \<in> A. p (f' x) = b}) ` B"
    using \<open>p permutes B\<close> permutes_implies_inv_image_on_eq by blast
  ultimately have "(\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}} = (\<lambda>b. {x \<in> A. p (f' x) = b}) ` B - {{}}" by auto
  also have "\<dots> = (\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}"
    using \<open>\<forall>x \<in> A. f x = p (f' x)\<close> Collect_cong image_cong by auto
  finally show "(\<lambda>b. {x \<in> A. f x = b}) ` B - {{}} = (\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}}" ..
qed

subsection \<open>Permutation on the Domain and the Range\<close>

definition domain_and_range_permutation
where
  "domain_and_range_permutation A B = {(f, f') \<in> (A \<rightarrow>\<^sub>E B) \<times> (A \<rightarrow>\<^sub>E B).
    \<exists>p\<^sub>A p\<^sub>B. p\<^sub>A permutes A \<and> p\<^sub>B permutes B \<and> (\<forall>x \<in> A. f x = p\<^sub>B (f' (p\<^sub>A x)))}"

lemma equiv_domain_and_range_permutation:
  "equiv (A \<rightarrow>\<^sub>E B) (domain_and_range_permutation A B)"
proof (rule equivI)
  show "refl_on (A \<rightarrow>\<^sub>E B) (domain_and_range_permutation A B)"
  proof (rule refl_onI)
    show "domain_and_range_permutation A B \<subseteq> (A \<rightarrow>\<^sub>E B) \<times> (A \<rightarrow>\<^sub>E B)"
      unfolding domain_and_range_permutation_def by auto
  next
    fix f
    assume "f \<in> A \<rightarrow>\<^sub>E B"
    from this show "(f, f) \<in> domain_and_range_permutation A B"
      using permutes_id[of A] permutes_id[of B]
      unfolding domain_and_range_permutation_def by fastforce
  qed
next
  show "sym (domain_and_range_permutation A B)"
  proof (rule symI)
    fix f f'
    assume "(f, f') \<in> domain_and_range_permutation A B"
    from this obtain p\<^sub>A p\<^sub>B where "p\<^sub>A permutes A" "p\<^sub>B permutes B" and "\<forall>x\<in>A. f x = p\<^sub>B (f' (p\<^sub>A x))"
      unfolding domain_and_range_permutation_def by auto
    from \<open>(f, f') \<in> domain_and_range_permutation A B\<close> have f: "f \<in> A \<rightarrow>\<^sub>E B" "f' \<in> A \<rightarrow>\<^sub>E B"
      unfolding domain_and_range_permutation_def by auto
    moreover from \<open>p\<^sub>A permutes A\<close> \<open>p\<^sub>B permutes B\<close> have "inv p\<^sub>A permutes A" "inv p\<^sub>B permutes B"
      by (auto simp add: permutes_inv)
    moreover from \<open>\<forall>x\<in>A. f x = p\<^sub>B (f' (p\<^sub>A x))\<close> have "\<forall>x\<in>A. f' x = inv p\<^sub>B (f (inv p\<^sub>A x))"
      using \<open>p\<^sub>A permutes A\<close> \<open>p\<^sub>B permutes B\<close> \<open>inv p\<^sub>A permutes A\<close> \<open>inv p\<^sub>B permutes B\<close>
      by (metis (no_types, lifting) bij_betwE bij_inv_eq_iff permutes_bij permutes_imp_bij)
    ultimately show "(f', f) \<in> domain_and_range_permutation A B"
      unfolding domain_and_range_permutation_def by auto
  qed
next
  show "trans (domain_and_range_permutation A B)"
  proof (rule transI)
    fix f f' f''
    assume "(f, f') \<in> domain_and_range_permutation A B"
    assume "(f', f'') \<in> domain_and_range_permutation A B"
    from \<open>(f, f') \<in> _\<close> obtain p\<^sub>A p\<^sub>B where
      "p\<^sub>A permutes A" "p\<^sub>B permutes B" and "\<forall>x\<in>A. f x = p\<^sub>B (f' (p\<^sub>A x))"
      unfolding domain_and_range_permutation_def by auto
    from \<open>(f', f'') \<in> _\<close> obtain p'\<^sub>A p'\<^sub>B where
      "p'\<^sub>A permutes A" "p'\<^sub>B permutes B" and "\<forall>x\<in>A. f' x = p'\<^sub>B (f'' (p'\<^sub>A x))"
      unfolding domain_and_range_permutation_def by auto
    from \<open>(f, f') \<in> domain_and_range_permutation A B\<close> have "f \<in> A \<rightarrow>\<^sub>E B"
      unfolding domain_and_range_permutation_def by auto
    moreover from \<open>(f', f'') \<in> domain_and_range_permutation A B\<close> have "f'' \<in> A \<rightarrow>\<^sub>E B"
      unfolding domain_and_range_permutation_def by auto
    moreover from \<open>p\<^sub>A permutes A\<close> \<open>p'\<^sub>A permutes A\<close> have "(p'\<^sub>A \<circ> p\<^sub>A) permutes A"
      by (simp add: permutes_compose)
    moreover from \<open>p\<^sub>B permutes B\<close> \<open>p'\<^sub>B permutes B\<close> have "(p\<^sub>B \<circ> p'\<^sub>B) permutes B"
      by (simp add: permutes_compose)
    moreover have "\<forall>x\<in>A. f x = (p\<^sub>B \<circ> p'\<^sub>B) (f'' ((p'\<^sub>A \<circ> p\<^sub>A) x))"
      using \<open>\<forall>x\<in>A. f' x = p'\<^sub>B (f'' (p'\<^sub>A x))\<close> \<open>\<forall>x\<in>A. f x = p\<^sub>B (f' (p\<^sub>A x))\<close> \<open>p\<^sub>A permutes A\<close>
      by (simp add: permutes_in_image)
    ultimately show "(f, f'') \<in> domain_and_range_permutation A B"
      unfolding domain_and_range_permutation_def by fastforce
  qed
qed

subsubsection \<open>Respecting Functions\<close>

lemma inj_on_respects_domain_and_range_permutation:
  "(\<lambda>f. inj_on f A) respects domain_and_range_permutation A B"
proof (rule congruentI)
  fix f f'
  assume "(f, f') \<in> domain_and_range_permutation A B"
  from this obtain p\<^sub>A p\<^sub>B where "p\<^sub>A permutes A" "p\<^sub>B permutes B" and "\<forall>x\<in>A. f x = p\<^sub>B (f' (p\<^sub>A x))"
    unfolding domain_and_range_permutation_def by auto
  from \<open>(f, f') \<in> domain_and_range_permutation A B\<close> have "f' ` A \<subseteq> B"
    unfolding domain_and_range_permutation_def by auto
  from \<open>p\<^sub>A permutes A\<close> have "p\<^sub>A ` A = A" by (auto simp add: permutes_image)
  from \<open>p\<^sub>A permutes A\<close> have "inj_on p\<^sub>A A"
    using bij_betw_imp_inj_on permutes_imp_bij by blast
  from \<open>p\<^sub>B permutes B\<close> have "inj_on p\<^sub>B B"
    using bij_betw_imp_inj_on permutes_imp_bij by blast
  show "inj_on f A \<longleftrightarrow> inj_on f' A"
  proof -
    have "inj_on f A \<longleftrightarrow> inj_on (\<lambda>x. p\<^sub>B (f' (p\<^sub>A x))) A"
      using \<open>\<forall>x\<in>A. f x = p\<^sub>B (f' (p\<^sub>A x))\<close> inj_on_cong comp_apply by fastforce
    have "inj_on f A \<longleftrightarrow> inj_on (p\<^sub>B o f' o p\<^sub>A) A"
      by (simp add: \<open>\<forall>x\<in>A. f x = p\<^sub>B (f' (p\<^sub>A x))\<close> inj_on_def)
    also have "inj_on (p\<^sub>B o f' o p\<^sub>A) A \<longleftrightarrow> inj_on (p\<^sub>B o f') A"
      using \<open>inj_on p\<^sub>A A\<close> \<open>p\<^sub>A ` A = A\<close>
      by (auto dest: inj_on_imageI intro: comp_inj_on)
    also have "inj_on (p\<^sub>B o f') A \<longleftrightarrow> inj_on f' A"
      using \<open>inj_on p\<^sub>B B\<close> \<open>f' ` A \<subseteq> B\<close>
      by (auto dest: inj_on_imageI2 intro: comp_inj_on subset_inj_on)
    finally show ?thesis .
  qed
qed

lemma surjective_respects_domain_and_range_permutation:
  "(\<lambda>f. f ` A = B) respects domain_and_range_permutation A B"
proof (rule congruentI)
  fix f f'
  assume "(f, f') \<in> domain_and_range_permutation A B"
  from this obtain p\<^sub>A p\<^sub>B where
    permutes: "p\<^sub>A permutes A" "p\<^sub>B permutes B" and "\<forall>x\<in>A. f x = p\<^sub>B (f' (p\<^sub>A x))"
    unfolding domain_and_range_permutation_def by auto
  from permutes have "p\<^sub>A ` A = A" "p\<^sub>B ` B = B" by (auto simp add: permutes_image)
  from \<open>p\<^sub>B permutes B\<close> have "inj p\<^sub>B" by (simp add: permutes_inj)
  show "(f ` A = B) \<longleftrightarrow> (f' ` A = B)"
  proof -
    have "f ` A = B \<longleftrightarrow> (\<lambda>x. p\<^sub>B (f' (p\<^sub>A x))) ` A = B"
      using \<open>\<forall>x\<in>A. f x = p\<^sub>B (f' (p\<^sub>A x))\<close> by (metis (mono_tags, lifting) image_cong)
    also have "(\<lambda>x. p\<^sub>B (f' (p\<^sub>A x))) ` A = B \<longleftrightarrow> (\<lambda>x. p\<^sub>B (f' x)) ` A = B"
      using \<open>p\<^sub>A ` A = A\<close> by (metis image_image)
    also have "(\<lambda>x. p\<^sub>B (f' x)) ` A = B \<longleftrightarrow> (f' ` A = B)"
      using \<open>p\<^sub>B ` B = B\<close> \<open>inj p\<^sub>B\<close> by (metis image_image image_inv_f_f)
    finally show ?thesis .
  qed
qed

lemma bij_betw_respects_domain_and_range_permutation:
  "(\<lambda>f. bij_betw f A B) respects domain_and_range_permutation A B"
proof (rule congruentI)
  fix f f'
  assume "(f, f') \<in> domain_and_range_permutation A B"
  from this obtain p\<^sub>A p\<^sub>B where "p\<^sub>A permutes A" "p\<^sub>B permutes B"
    and "\<forall>x\<in>A. f x = p\<^sub>B (f' (p\<^sub>A x))" and "f' \<in> A \<rightarrow>\<^sub>E B"
    unfolding domain_and_range_permutation_def by auto
  have "bij_betw f A B \<longleftrightarrow> bij_betw (p\<^sub>B o f' o p\<^sub>A) A B"
    using \<open>\<forall>x\<in>A. f x = p\<^sub>B (f' (p\<^sub>A x))\<close> bij_betw_congI by fastforce
  also have "... \<longleftrightarrow> bij_betw (p\<^sub>B o f')  A B"
    using \<open>p\<^sub>A permutes A\<close>
    by (auto intro!: bij_betw_comp_iff[symmetric] permutes_imp_bij)
  also have "... \<longleftrightarrow> bij_betw f' A B"
    using \<open>f' \<in> A \<rightarrow>\<^sub>E B\<close> \<open>p\<^sub>B permutes B\<close>
    by (auto intro!: bij_betw_comp_iff2[symmetric] permutes_imp_bij)
  finally show "bij_betw f A B \<longleftrightarrow> bij_betw f' A B" .
qed

lemma count_image_mset':
  "count (image_mset f A) x = sum (count A) {x' \<in> set_mset A. f x' = x}"
proof -
  have "count (image_mset f A) x = sum (count A) (f -` {x} \<inter> set_mset A)"
    unfolding count_image_mset ..
  also have "\<dots> = sum (count A) {x' \<in> set_mset A. f x' = x}"
  proof -
    have "(f -` {x} \<inter> set_mset A) = {x' \<in> set_mset A. f x' = x}" by blast
    from this show ?thesis by simp
  qed
  finally show ?thesis .
qed

lemma multiset_of_partition_cards_respects_domain_and_range_permutation:
  assumes "finite B"
  shows "(\<lambda>f. image_mset (\<lambda>X. card X) (mset_set (((\<lambda>b. {x \<in> A. f x = b})) ` B - {{}}))) respects domain_and_range_permutation A B"
proof (rule congruentI)
  fix f f'
  assume "(f, f') \<in> domain_and_range_permutation A B"
  from this obtain 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))"
    unfolding domain_and_range_permutation_def by auto
  have "(\<lambda>b. {x \<in> A. f x = b}) ` B = (\<lambda>b. {x \<in> A. p\<^sub>B (f' (p\<^sub>A x)) = b}) ` B"
    using \<open>\<forall>x\<in>A. f x = p\<^sub>B (f' (p\<^sub>A x))\<close> by auto
  from this have "image_mset card (mset_set ((\<lambda>b. {x \<in> A. f x = b}) ` B - {{}})) =
    image_mset card (mset_set ((\<lambda>b. {x \<in> A. p\<^sub>B (f' (p\<^sub>A x)) = b}) ` B - {{}}))" by simp
  also 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>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>, of A] by metis
  also have "image_mset card (mset_set ((\<lambda>b. {x \<in> A. f' (p\<^sub>A x) = b}) ` B - {{}})) =
    image_mset card (mset_set ((\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}}))"
  proof (rule multiset_eqI)
    fix n
    have "bij_betw (\<lambda>X. p\<^sub>A ` X) {X \<in> (\<lambda>b. {x \<in> A. f' (p\<^sub>A x) = b}) ` B - {{}}. card X = n} {X \<in> (\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}}. card X = n}"
    proof (rule bij_betw_byWitness)
      show "\<forall>X\<in>{X \<in> (\<lambda>b. {x \<in> A. f' (p\<^sub>A x) = b}) ` B - {{}}. card X = n}. inv p\<^sub>A ` p\<^sub>A ` X = X"
        by (meson \<open>p\<^sub>A permutes A\<close> image_inv_f_f permutes_inj)
      show "\<forall>X\<in>{X \<in> (\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}}. card X = n}. p\<^sub>A ` inv p\<^sub>A ` X = X"
        by (meson \<open>p\<^sub>A permutes A\<close> image_f_inv_f permutes_surj)
      show "(\<lambda>X. p\<^sub>A ` X) ` {X \<in> (\<lambda>b. {x \<in> A. f' (p\<^sub>A x) = b}) ` B - {{}}. card X = n} \<subseteq> {X \<in> (\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}}. card X = n}"
      proof -
        have "card (p\<^sub>A ` {x \<in> A. f' (p\<^sub>A x) = b}) = card {x \<in> A. f' (p\<^sub>A x) = b}" for b
        proof -
          have "inj_on p\<^sub>A {x \<in> A. f' (p\<^sub>A x) = b}"
            by (metis (no_types, lifting) \<open>p\<^sub>A permutes A\<close> injD inj_onI permutes_inj)
          from this show ?thesis by (simp add: card_image)
        qed
        moreover have "p\<^sub>A ` {x \<in> A. f' (p\<^sub>A x) = b} = {x \<in> A. f' x = b}" for b
        proof
          show "p\<^sub>A ` {x \<in> A. f' (p\<^sub>A x) = b} \<subseteq> {x \<in> A. f' x = b}"
            by (auto simp add: \<open>p\<^sub>A permutes A\<close> permutes_in_image)
          show "{x \<in> A. f' x = b} \<subseteq> p\<^sub>A ` {x \<in> A. f' (p\<^sub>A x) = b}"
          proof
            fix x
            assume "x \<in> {x \<in> A. f' x = b}"
            moreover have "p\<^sub>A (inv p\<^sub>A x) = x"
              using \<open>p\<^sub>A permutes A\<close> permutes_inverses(1) by fastforce
            moreover from \<open>x \<in> {x \<in> A. f' x = b}\<close> have "inv p\<^sub>A x \<in> A"
              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' (p\<^sub>A x) = b}"
              by (auto intro: image_eqI[where x="inv p\<^sub>A x"])
          qed
        qed
        ultimately show ?thesis by auto
      qed
      show "(\<lambda>X. inv p\<^sub>A ` X) ` {X \<in> (\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}}. card X = n} \<subseteq> {X \<in> (\<lambda>b. {x \<in> A. f' (p\<^sub>A x) = b}) ` B - {{}}. card X = n}"
      proof -
        have "card (inv p\<^sub>A ` {x \<in> A. f' x = b}) = card {x \<in> A. f' x = b}" for b
        proof -
          have "inj_on (inv p\<^sub>A) {x \<in> A. f' x = b}"
            by (metis (no_types, lifting) \<open>p\<^sub>A permutes A\<close> injD inj_onI permutes_surj surj_imp_inj_inv)
          from this show ?thesis by (simp add: card_image)
        qed
        moreover have "inv p\<^sub>A ` {x \<in> A. f' x = b} = {x \<in> A. f' (p\<^sub>A x) = b}" for b
        proof
          show "inv p\<^sub>A ` {x \<in> A. f' x = b} \<subseteq> {x \<in> A. f' (p\<^sub>A x) = b}"
            using \<open>p\<^sub>A permutes A\<close>
            by (auto simp add: permutes_in_image permutes_inv permutes_inverses(1))
          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}"
            moreover have "inv p\<^sub>A (p\<^sub>A x) = x"
              by (meson \<open>p\<^sub>A permutes A\<close> permutes_inverses(2))
            moreover from \<open>x \<in> {x \<in> A. f' (p\<^sub>A x) = b}\<close> have "p\<^sub>A x \<in> A"
              by (simp add: \<open>p\<^sub>A permutes A\<close> permutes_in_image)
            ultimately show "x \<in> inv p\<^sub>A ` {x \<in> A. f' x = b}"
              by (auto intro: image_eqI[where x="p\<^sub>A x"])
          qed
        qed
        ultimately show ?thesis by auto
      qed
    qed
    from this have "card {x' \<in> (\<lambda>b. {x \<in> A. f' (p\<^sub>A x) = b}) ` B - {{}}. card x' = n} = card {x' \<in> (\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}}. card x' = n}"
      by (rule bij_betw_same_card)
    from this show "count (image_mset card (mset_set ((\<lambda>b. {x \<in> A. f' (p\<^sub>A x) = b}) ` B - {{}}))) n =
      count (image_mset card (mset_set ((\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}}))) n"
      using \<open>finite B\<close> by (simp add: count_image_mset')
  qed
  finally show "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 - {{}}))" .
qed

end