(*  Title:      HOL/Algebra/Sylow.thy
    Author:     Florian Kammueller, with new proofs by L C Paulson
*)

theory Sylow
imports Coset Exponent
begin

text {*
  See also @{cite "Kammueller-Paulson:1999"}.
*}

text{*The combinatorial argument is in theory Exponent*}

locale sylow = group +
  fixes p and a and m and calM and RelM
  assumes prime_p:   "prime p"
      and order_G:   "order(G) = (p^a) * m"
      and finite_G [iff]:  "finite (carrier G)"
  defines "calM == {s. s \<subseteq> carrier(G) & card(s) = p^a}"
      and "RelM == {(N1,N2). N1 \<in> calM & N2 \<in> calM &
                             (\<exists>g \<in> carrier(G). N1 = (N2 #> g) )}"

lemma (in sylow) RelM_refl_on: "refl_on calM RelM"
apply (auto simp add: refl_on_def RelM_def calM_def)
apply (blast intro!: coset_mult_one [symmetric])
done

lemma (in sylow) RelM_sym: "sym RelM"
proof (unfold sym_def RelM_def, clarify)
  fix y g
  assume   "y \<in> calM"
    and g: "g \<in> carrier G"
  hence "y = y #> g #> (inv g)" by (simp add: coset_mult_assoc calM_def)
  thus "\<exists>g'\<in>carrier G. y = y #> g #> g'" by (blast intro: g)
qed

lemma (in sylow) RelM_trans: "trans RelM"
by (auto simp add: trans_def RelM_def calM_def coset_mult_assoc)

lemma (in sylow) RelM_equiv: "equiv calM RelM"
apply (unfold equiv_def)
apply (blast intro: RelM_refl_on RelM_sym RelM_trans)
done

lemma (in sylow) M_subset_calM_prep: "M' \<in> calM // RelM  ==> M' \<subseteq> calM"
apply (unfold RelM_def)
apply (blast elim!: quotientE)
done

subsection{*Main Part of the Proof*}

locale sylow_central = sylow +
  fixes H and M1 and M
  assumes M_in_quot:  "M \<in> calM // RelM"
      and not_dvd_M:  "~(p ^ Suc(exponent p m) dvd card(M))"
      and M1_in_M:    "M1 \<in> M"
  defines "H == {g. g\<in>carrier G & M1 #> g = M1}"

lemma (in sylow_central) M_subset_calM: "M \<subseteq> calM"
by (rule M_in_quot [THEN M_subset_calM_prep])

lemma (in sylow_central) card_M1: "card(M1) = p^a"
apply (cut_tac M_subset_calM M1_in_M)
apply (simp add: calM_def, blast)
done

lemma card_nonempty: "0 < card(S) ==> S \<noteq> {}"
by force

lemma (in sylow_central) exists_x_in_M1: "\<exists>x. x\<in>M1"
apply (subgoal_tac "0 < card M1")
 apply (blast dest: card_nonempty)
apply (cut_tac prime_p [THEN prime_gt_Suc_0_nat])
apply (simp (no_asm_simp) add: card_M1)
done

lemma (in sylow_central) M1_subset_G [simp]: "M1 \<subseteq> carrier G"
apply (rule subsetD [THEN PowD])
apply (rule_tac [2] M1_in_M)
apply (rule M_subset_calM [THEN subset_trans])
apply (auto simp add: calM_def)
done

lemma (in sylow_central) M1_inj_H: "\<exists>f \<in> H\<rightarrow>M1. inj_on f H"
  proof -
    from exists_x_in_M1 obtain m1 where m1M: "m1 \<in> M1"..
    have m1G: "m1 \<in> carrier G" by (simp add: m1M M1_subset_G [THEN subsetD])
    show ?thesis
    proof
      show "inj_on (\<lambda>z\<in>H. m1 \<otimes> z) H"
        by (simp add: inj_on_def l_cancel [of m1 x y, THEN iffD1] H_def m1G)
      show "restrict (op \<otimes> m1) H \<in> H \<rightarrow> M1"
      proof (rule restrictI)
        fix z assume zH: "z \<in> H"
        show "m1 \<otimes> z \<in> M1"
        proof -
          from zH
          have zG: "z \<in> carrier G" and M1zeq: "M1 #> z = M1"
            by (auto simp add: H_def)
          show ?thesis
            by (rule subst [OF M1zeq], simp add: m1M zG rcosI)
        qed
      qed
    qed
  qed

subsection{*Discharging the Assumptions of @{text sylow_central}*}

lemma (in sylow) EmptyNotInEquivSet: "{} \<notin> calM // RelM"
by (blast elim!: quotientE dest: RelM_equiv [THEN equiv_class_self])

lemma (in sylow) existsM1inM: "M \<in> calM // RelM ==> \<exists>M1. M1 \<in> M"
apply (subgoal_tac "M \<noteq> {}")
 apply blast
apply (cut_tac EmptyNotInEquivSet, blast)
done

lemma (in sylow) zero_less_o_G: "0 < order(G)"
apply (unfold order_def)
apply (blast intro: zero_less_card_empty)
done

lemma (in sylow) zero_less_m: "m > 0"
apply (cut_tac zero_less_o_G)
apply (simp add: order_G)
done

lemma (in sylow) card_calM: "card(calM) = (p^a) * m choose p^a"
by (simp add: calM_def n_subsets order_G [symmetric] order_def)

lemma (in sylow) zero_less_card_calM: "card calM > 0"
by (simp add: card_calM zero_less_binomial le_extend_mult zero_less_m)

lemma (in sylow) max_p_div_calM:
     "~ (p ^ Suc(exponent p m) dvd card(calM))"
apply (subgoal_tac "exponent p m = exponent p (card calM) ")
 apply (cut_tac zero_less_card_calM prime_p)
 apply (force dest: power_Suc_exponent_Not_dvd)
apply (simp add: card_calM zero_less_m [THEN const_p_fac])
done

lemma (in sylow) finite_calM: "finite calM"
apply (unfold calM_def)
apply (rule_tac B = "Pow (carrier G) " in finite_subset)
apply auto
done

lemma (in sylow) lemma_A1:
     "\<exists>M \<in> calM // RelM. ~ (p ^ Suc(exponent p m) dvd card(M))"
apply (rule max_p_div_calM [THEN contrapos_np])
apply (simp add: finite_calM equiv_imp_dvd_card [OF _ RelM_equiv])
done

subsubsection{*Introduction and Destruct Rules for @{term H}*}

lemma (in sylow_central) H_I: "[|g \<in> carrier G; M1 #> g = M1|] ==> g \<in> H"
by (simp add: H_def)

lemma (in sylow_central) H_into_carrier_G: "x \<in> H ==> x \<in> carrier G"
by (simp add: H_def)

lemma (in sylow_central) in_H_imp_eq: "g : H ==> M1 #> g = M1"
by (simp add: H_def)

lemma (in sylow_central) H_m_closed: "[| x\<in>H; y\<in>H|] ==> x \<otimes> y \<in> H"
apply (unfold H_def)
apply (simp add: coset_mult_assoc [symmetric])
done

lemma (in sylow_central) H_not_empty: "H \<noteq> {}"
apply (simp add: H_def)
apply (rule exI [of _ \<one>], simp)
done

lemma (in sylow_central) H_is_subgroup: "subgroup H G"
apply (rule subgroupI)
apply (rule subsetI)
apply (erule H_into_carrier_G)
apply (rule H_not_empty)
apply (simp add: H_def, clarify)
apply (erule_tac P = "%z. ?lhs(z) = M1" in subst)
apply (simp add: coset_mult_assoc )
apply (blast intro: H_m_closed)
done

lemma (in sylow_central) rcosetGM1g_subset_G:
     "[| g \<in> carrier G; x \<in> M1 #>  g |] ==> x \<in> carrier G"
by (blast intro: M1_subset_G [THEN r_coset_subset_G, THEN subsetD])

lemma (in sylow_central) finite_M1: "finite M1"
by (rule finite_subset [OF M1_subset_G finite_G])

lemma (in sylow_central) finite_rcosetGM1g: "g\<in>carrier G ==> finite (M1 #> g)"
apply (rule finite_subset)
apply (rule subsetI)
apply (erule rcosetGM1g_subset_G, assumption)
apply (rule finite_G)
done

lemma (in sylow_central) M1_cardeq_rcosetGM1g:
     "g \<in> carrier G ==> card(M1 #> g) = card(M1)"
by (simp (no_asm_simp) add: card_cosets_equal rcosetsI)

lemma (in sylow_central) M1_RelM_rcosetGM1g:
     "g \<in> carrier G ==> (M1, M1 #> g) \<in> RelM"
apply (simp add: RelM_def calM_def card_M1)
apply (rule conjI)
 apply (blast intro: rcosetGM1g_subset_G)
apply (simp add: card_M1 M1_cardeq_rcosetGM1g)
apply (metis M1_subset_G coset_mult_assoc coset_mult_one r_inv_ex)
done

subsection{*Equal Cardinalities of @{term M} and the Set of Cosets*}

text{*Injections between @{term M} and @{term "rcosets\<^bsub>G\<^esub> H"} show that
 their cardinalities are equal.*}

lemma ElemClassEquiv:
     "[| equiv A r; C \<in> A // r |] ==> \<forall>x \<in> C. \<forall>y \<in> C. (x,y)\<in>r"
by (unfold equiv_def quotient_def sym_def trans_def, blast)

lemma (in sylow_central) M_elem_map:
     "M2 \<in> M ==> \<exists>g. g \<in> carrier G & M1 #> g = M2"
apply (cut_tac M1_in_M M_in_quot [THEN RelM_equiv [THEN ElemClassEquiv]])
apply (simp add: RelM_def)
apply (blast dest!: bspec)
done

lemmas (in sylow_central) M_elem_map_carrier =
        M_elem_map [THEN someI_ex, THEN conjunct1]

lemmas (in sylow_central) M_elem_map_eq =
        M_elem_map [THEN someI_ex, THEN conjunct2]

lemma (in sylow_central) M_funcset_rcosets_H:
     "(%x:M. H #> (SOME g. g \<in> carrier G & M1 #> g = x)) \<in> M \<rightarrow> rcosets H"
  by (metis (lifting) H_is_subgroup M_elem_map_carrier rcosetsI restrictI subgroup_imp_subset)

lemma (in sylow_central) inj_M_GmodH: "\<exists>f \<in> M\<rightarrow>rcosets H. inj_on f M"
apply (rule bexI)
apply (rule_tac [2] M_funcset_rcosets_H)
apply (rule inj_onI, simp)
apply (rule trans [OF _ M_elem_map_eq])
prefer 2 apply assumption
apply (rule M_elem_map_eq [symmetric, THEN trans], assumption)
apply (rule coset_mult_inv1)
apply (erule_tac [2] M_elem_map_carrier)+
apply (rule_tac [2] M1_subset_G)
apply (rule coset_join1 [THEN in_H_imp_eq])
apply (rule_tac [3] H_is_subgroup)
prefer 2 apply (blast intro: M_elem_map_carrier)
apply (simp add: coset_mult_inv2 H_def M_elem_map_carrier subset_eq)
done

subsubsection{*The Opposite Injection*}

lemma (in sylow_central) H_elem_map:
     "H1 \<in> rcosets H ==> \<exists>g. g \<in> carrier G & H #> g = H1"
by (auto simp add: RCOSETS_def)

lemmas (in sylow_central) H_elem_map_carrier =
        H_elem_map [THEN someI_ex, THEN conjunct1]

lemmas (in sylow_central) H_elem_map_eq =
        H_elem_map [THEN someI_ex, THEN conjunct2]

lemma (in sylow_central) rcosets_H_funcset_M:
  "(\<lambda>C \<in> rcosets H. M1 #> (@g. g \<in> carrier G \<and> H #> g = C)) \<in> rcosets H \<rightarrow> M"
apply (simp add: RCOSETS_def)
apply (fast intro: someI2
            intro!: M1_in_M in_quotient_imp_closed [OF RelM_equiv M_in_quot _  M1_RelM_rcosetGM1g])
done

text{*close to a duplicate of @{text inj_M_GmodH}*}
lemma (in sylow_central) inj_GmodH_M:
     "\<exists>g \<in> rcosets H\<rightarrow>M. inj_on g (rcosets H)"
apply (rule bexI)
apply (rule_tac [2] rcosets_H_funcset_M)
apply (rule inj_onI)
apply (simp)
apply (rule trans [OF _ H_elem_map_eq])
prefer 2 apply assumption
apply (rule H_elem_map_eq [symmetric, THEN trans], assumption)
apply (rule coset_mult_inv1)
apply (erule_tac [2] H_elem_map_carrier)+
apply (rule_tac [2] H_is_subgroup [THEN subgroup.subset])
apply (rule coset_join2)
apply (blast intro: H_elem_map_carrier)
apply (rule H_is_subgroup)
apply (simp add: H_I coset_mult_inv2 H_elem_map_carrier)
done

lemma (in sylow_central) calM_subset_PowG: "calM \<subseteq> Pow(carrier G)"
by (auto simp add: calM_def)

lemma (in sylow_central) finite_M: "finite M"
by (metis M_subset_calM finite_calM rev_finite_subset)

lemma (in sylow_central) cardMeqIndexH: "card(M) = card(rcosets H)"
apply (insert inj_M_GmodH inj_GmodH_M)
apply (blast intro: card_bij finite_M H_is_subgroup
             rcosets_subset_PowG [THEN finite_subset]
             finite_Pow_iff [THEN iffD2])
done

lemma (in sylow_central) index_lem: "card(M) * card(H) = order(G)"
by (simp add: cardMeqIndexH lagrange H_is_subgroup)

lemma (in sylow_central) lemma_leq1: "p^a \<le> card(H)"
apply (rule dvd_imp_le)
 apply (rule div_combine [OF prime_p not_dvd_M])
 prefer 2 apply (blast intro: subgroup.finite_imp_card_positive H_is_subgroup)
apply (simp add: index_lem order_G power_add mult_dvd_mono power_exponent_dvd
                 zero_less_m)
done

lemma (in sylow_central) lemma_leq2: "card(H) \<le> p^a"
apply (subst card_M1 [symmetric])
apply (cut_tac M1_inj_H)
apply (blast intro!: M1_subset_G intro:
             card_inj H_into_carrier_G finite_subset [OF _ finite_G])
done

lemma (in sylow_central) card_H_eq: "card(H) = p^a"
by (blast intro: le_antisym lemma_leq1 lemma_leq2)

lemma (in sylow) sylow_thm: "\<exists>H. subgroup H G & card(H) = p^a"
apply (cut_tac lemma_A1, clarify)
apply (frule existsM1inM, clarify)
apply (subgoal_tac "sylow_central G p a m M1 M")
 apply (blast dest:  sylow_central.H_is_subgroup sylow_central.card_H_eq)
apply (simp add: sylow_central_def sylow_central_axioms_def sylow_axioms calM_def RelM_def)
done

text{*Needed because the locale's automatic definition refers to
   @{term "semigroup G"} and @{term "group_axioms G"} rather than
  simply to @{term "group G"}.*}
lemma sylow_eq: "sylow G p a m = (group G & sylow_axioms G p a m)"
by (simp add: sylow_def group_def)

subsection {* Sylow's Theorem *}

theorem sylow_thm:
     "[| prime p;  group(G);  order(G) = (p^a) * m; finite (carrier G)|]
      ==> \<exists>H. subgroup H G & card(H) = p^a"
apply (rule sylow.sylow_thm [of G p a m])
apply (simp add: sylow_eq sylow_axioms_def)
done

end


(*  Title:       Category theory using Isar and Locales
    Author:      Greg O'Keefe, June, July, August 2003
    License: LGPL
*)

header {* {{\sf Set}} is a Category *}

theory SetCat
imports Cat
begin

subsection{* Definitions *}

record 'c set_arrow =
  set_dom :: "'c set"
  set_func :: "'c \<Rightarrow> 'c"
  set_cod :: "'c set"

definition
  set_arrow :: "['c set, 'c set_arrow] \<Rightarrow> bool" where
  "set_arrow U f \<longleftrightarrow> set_dom f \<subseteq> U & set_cod f \<subseteq> U
    & (set_func f): (set_dom f) \<rightarrow> (set_cod f)
    & set_func f \<in> extensional (set_dom f)"

definition
  set_id :: "['c set, 'c set] \<Rightarrow> 'c set_arrow" where
  "set_id U = (\<lambda>s\<in>Pow U. \<lparr>set_dom=s, set_func=\<lambda>x\<in>s. x, set_cod=s\<rparr>)"

definition
  set_comp :: "['c set_arrow, 'c set_arrow] \<Rightarrow> 'c set_arrow"  (infix "\<odot>" 70) where
  "set_comp g f =
  \<lparr>
    set_dom = set_dom f,
    set_func = compose (set_dom f) (set_func g) (set_func f),
    set_cod = set_cod g
  \<rparr>"

definition
  set_cat :: "'c set \<Rightarrow> ('c set, 'c set_arrow) category" where
  "set_cat U =
  \<lparr>
    ob = Pow U,
    ar = {f. set_arrow U f},
    dom = set_dom,
    cod = set_cod,
    id = set_id U,
    comp = set_comp
  \<rparr>"

subsection {* Simple Rules and Lemmas *}

lemma set_objectI [intro]: "A \<subseteq> U \<Longrightarrow> A \<in> ob (set_cat U)"
  by (simp add: set_cat_def)

lemma set_objectE [intro]: "A \<in> ob (set_cat U) \<Longrightarrow> A \<subseteq> U"
  by (simp add: set_cat_def)

lemma set_homI [intro]:
  assumes "A \<subseteq> U"
  and "B \<subseteq> U"
  and "f : A\<rightarrow>B"
  and "f \<in> extensional A"
  shows "\<lparr>set_dom=A, set_func=f, set_cod=B\<rparr> \<in> hom (set_cat U) A B"
  using assms by (simp add: set_cat_def hom_def set_arrow_def)

lemma set_dom [simp]: "dom (set_cat U) f = set_dom f"
  by (simp add: set_cat_def)

lemma set_cod [simp]: "cod (set_cat U) f = set_cod f"
  by (simp add: set_cat_def)

lemma set_id [simp]: "id (set_cat U) A = set_id U A"
  by (simp add: set_cat_def)

lemma set_comp [simp]: "comp (set_cat U) g f = g \<odot> f"
  by (simp add: set_cat_def)

lemma set_dom_cod_object_subset [intro]:
  assumes f: "f \<in> ar (set_cat U)"
  shows "dom (set_cat U) f \<in> ob (set_cat U)"
    and "cod (set_cat U) f \<in> ob (set_cat U)"
    and "set_cod f \<subseteq> U"
    and "set_dom f \<subseteq> U"
proof-
  note [simp] = set_cat_def set_arrow_def
  have "dom (set_cat U) f = set_dom f" using f by simp
  also show "\<dots> \<subseteq> U" using f by simp
  finally show "dom (set_cat U) f \<in> ob (set_cat U)" ..
  have "cod (set_cat U) f = set_cod f" using f by simp
  also show "\<dots> \<subseteq> U" using f by simp
  finally show "cod (set_cat U) f \<in> ob (set_cat U)" ..
qed

text {* In this context, @{text "f \<in> hom A B"} is quite a strong claim. *}

lemma set_homE [intro]:
  assumes f: "f \<in> hom (set_cat U) A B"
  shows "A \<subseteq> U"
    and "B \<subseteq> U"
    and "set_dom f = A"
    and "set_func f : A \<rightarrow> B"
    and "set_cod f = B"
proof-
  have 1: "f \<in> ar (set_cat U)"
    using f by (simp add: hom_def set_cat_def)
  show 2: "set_dom f = A"
    using f by (simp add: set_cat_def hom_def set_arrow_def)
  from 1 have "set_dom f \<subseteq> U" ..
  thus "A \<subseteq> U" by (simp add: 2)
  show 3: "set_cod f = B"
    using f by (simp add: set_cat_def hom_def set_arrow_def)
  from 1 have "set_cod f \<subseteq> U" ..
  thus "B \<subseteq> U" by (simp add: 3)
  have "set_func f \<in> (set_dom f) \<rightarrow> (set_cod f)"
    using f by (auto simp add: set_cat_def hom_def set_arrow_def)
  thus "set_func f \<in> A \<rightarrow> B"
    by (simp add: 2 3)
qed

subsection {* Set is a Category *}
lemma set_id_left:
  assumes f: "f \<in> ar (set_cat U)"
  shows "set_id U (set_cod f) \<odot> f = f"
proof-
  from `f \<in> ar (set_cat U)` have "set_cod f \<subseteq> U" ..
  hence 1: "set_id U (set_cod f) \<odot> f =
    \<lparr>
    set_dom=set_dom f,
    set_func=compose (set_dom f) (\<lambda>x\<in>set_cod f. x) (set_func f),
    set_cod=set_cod f
    \<rparr>"
    using f by (simp add: set_comp_def set_id_def)
  have 2: "compose (set_dom f)  (\<lambda>x\<in>set_cod f. x) (set_func f) = set_func f"
  proof (rule extensionalityI)
    show "compose (set_dom f) (\<lambda>x\<in>set_cod f. x) (set_func f) \<in> extensional (set_dom f)"
      by (rule compose_extensional)
    show "set_func f \<in> extensional (set_dom f)"
      using f by (simp add: set_cat_def set_arrow_def)
    fix x
    assume x_in_dom: "x \<in> set_dom f"
    have f_into_cod: "set_func f : (set_dom f) \<rightarrow> (set_cod f)"
      using f by (simp add: set_cat_def set_arrow_def)
    from f_into_cod and x_in_dom
    have f_x_in_cod: "set_func f x \<in> set_cod f"
      by (rule funcset_mem)
    show "compose (set_dom f) (\<lambda>x\<in>set_cod f. x) (set_func f) x = set_func f x"
      by (simp add: x_in_dom f_x_in_cod compose_def)
  qed
  from 1 have "set_id U (set_cod f) \<odot> f =
    \<lparr>
    set_dom=set_dom f,
    set_func=set_func f,
    set_cod=set_cod f
    \<rparr>"
    by (simp only: 2)
  also have "\<dots> = f"
    by simp
  finally show ?thesis .
qed

lemma set_id_right:
  assumes f: "f \<in> ar (set_cat U)"
  shows "f \<odot> (set_id U (set_dom f)) = f"
proof-
  from `f \<in> ar (set_cat U)` have "set_dom f \<subseteq> U" ..
  hence 1: "f \<odot> (set_id U (set_dom f)) =
    \<lparr>
    set_dom=set_dom f,
    set_func=compose (set_dom f) (set_func f) (\<lambda>x\<in>set_dom f. x),
    set_cod=set_cod f
    \<rparr>"
    using f by (simp add: set_comp_def set_id_def)
  have 2: "compose (set_dom f) (set_func f) (\<lambda>x\<in>set_dom f. x) = set_func f"
  proof (rule extensionalityI)
    show "compose (set_dom f) (set_func f) (\<lambda>x\<in>set_dom f. x) \<in> extensional (set_dom f)"
      by (rule compose_extensional)
    show "set_func f \<in> extensional (set_dom f)"
      using f by (simp add: set_cat_def set_arrow_def)
    fix x
    assume x_in_dom: "x \<in> set_dom f"
    thus "compose (set_dom f) (set_func f) (\<lambda>x\<in>set_dom f. x) x = set_func f x"
      by (simp add: compose_def)
  qed
  from 1 have "f \<odot> (set_id U (set_dom f)) =
    \<lparr>
    set_dom=set_dom f,
    set_func=set_func f,
    set_cod=set_cod f
    \<rparr>"
    by (simp only: 2)
  also have "\<dots> = f"
    by simp
  finally show ?thesis .
qed

lemma set_id_hom:
  assumes "A \<in> ob (set_cat U)"
  shows "id (set_cat U) A \<in> hom (set_cat U) A A"
proof-
  from `A \<in> ob (set_cat U)` have 1: "A \<subseteq> U" ..
  hence "id (set_cat U) A = \<lparr>set_dom=A, set_func=\<lambda>x\<in>A. x, set_cod=A\<rparr>"
    by (simp add: set_cat_def set_id_def)
  also have "\<dots> \<in> hom (set_cat U) A A"
  proof (rule set_homI)
    show "(\<lambda>x\<in>A. x) \<in> A \<rightarrow> A"
      by (rule funcsetI, auto)
    show "(\<lambda>x\<in>A. x) \<in> extensional A"
      by (rule restrict_extensional)
  qed (rule 1, rule 1)
  finally show ?thesis .
qed

lemma set_comp_types:
"comp (set_cat U) \<in> hom (set_cat U) B C \<rightarrow> hom (set_cat U) A B \<rightarrow> hom (set_cat U) A C"
proof (rule funcsetI)
  fix g
  assume g_BC: "g \<in> hom (set_cat U) B C"
  hence comp_cod: "set_cod g = C" ..
  show "comp (set_cat U) g \<in> hom (set_cat U) A B \<rightarrow> hom (set_cat U) A C"
  proof (rule funcsetI)
    fix f
    assume f_AB: "f \<in> hom (set_cat U) A B"
    hence comp_dom: "set_dom f = A" ..
    show "comp (set_cat U) g f \<in> hom (set_cat U) A C"
    proof-
      have "comp (set_cat U) g f =
        \<lparr>
        set_dom = A,
        set_func = compose (set_dom f) (set_func g) (set_func f),
        set_cod = C
        \<rparr>"
        by (simp add: set_cat_def set_comp_def comp_cod comp_dom)
      also have "\<dots> \<in> hom (set_cat U) A C"
      proof (rule set_homI)
        from f_AB show "A \<subseteq> U" ..
        from g_BC show "C \<subseteq> U" ..
        from f_AB have fs_f: "set_func f: A \<rightarrow> B" ..
        from g_BC have fs_g: "set_func g: B \<rightarrow> C" ..
        from fs_g and fs_f
        show " compose (set_dom f) (set_func g) (set_func f) : A \<rightarrow> C"
          by (simp only: comp_dom) (rule funcset_compose)
        show "compose (set_dom f) (set_func g) (set_func f) \<in> extensional A"
          by (simp only: comp_dom) (rule compose_extensional)
      qed
      finally show ?thesis .
    qed
  qed
qed

text {* We reason explicitly about the function component of the
composite arrow, leaving the rest to the simplifier. *}

lemma set_comp_associative:
  fixes f and g and h
  assumes f: "f \<in> ar (set_cat U)"
    and g: "g \<in> ar (set_cat U)"
    and h: "h \<in> ar (set_cat U)"
    and hg: "cod (set_cat U) h = dom (set_cat U) g"
    and gf: "cod (set_cat U) g = dom (set_cat U) f"
  shows "comp (set_cat U) f (comp (set_cat U) g h) =
  comp (set_cat U) (comp (set_cat U) f g) h"
proof (simp add: set_cat_def set_comp_def)
  show "compose (set_dom h) (set_func f) (compose (set_dom h) (set_func g) (set_func h)) =
    compose (set_dom h) (compose (set_dom g) (set_func f) (set_func g)) (set_func h)"
  proof (rule compose_assoc)
    have 1: "set_cod h = set_dom g" using hg by simp
    have 2: "set_cod g = set_dom f" using gf by simp
    show "set_func h \<in> set_dom h \<rightarrow> set_dom g"
      using h by (simp add: set_cat_def set_arrow_def 1)
    show "set_func g \<in> set_dom g \<rightarrow> set_dom f"
      using g by (simp add: set_cat_def set_arrow_def 2)
    show "set_func f \<in> set_dom f \<rightarrow> set_cod f"
      using f by (simp add: set_cat_def set_arrow_def)
  qed
qed

theorem set_cat_cat:  "category (set_cat U)"
proof (rule category.intro)
  fix f
  assume f: "f \<in> ar (set_cat U)"
  show "dom (set_cat U) f \<in> ob (set_cat U)" using f ..
  show "cod (set_cat U) f \<in> ob (set_cat U)" using f ..
  show "comp (set_cat U) (id (set_cat U) (cod (set_cat U) f)) f = f"
    using f by (simp add: set_id_left)
  show "comp (set_cat U) f (id (set_cat U) (dom (set_cat U) f)) = f"
    using f by (simp add: set_id_right)
next
  fix A
  assume "A \<in> ob (set_cat U)"
  then show "id (set_cat U) A \<in> hom (set_cat U) A A"
    by (rule set_id_hom)
next
  fix A and B and C
  show "comp (set_cat U) \<in> hom (set_cat U) B C \<rightarrow> hom (set_cat U) A B \<rightarrow> hom (set_cat U) A C"
    by (rule set_comp_types)
next
  fix f and g and h
  assume "f \<in> ar (set_cat U)"
    and  "g \<in> ar (set_cat U)"
    and  "h \<in> ar (set_cat U)"
    and "cod (set_cat U) h = dom (set_cat U) g"
    and "cod (set_cat U) g = dom (set_cat U) f"
  then show "comp (set_cat U) f (comp (set_cat U) g h) =
    comp (set_cat U) (comp (set_cat U) f g) h"
    by (rule set_comp_associative)
qed

end


(*  Title:      HOL/Probability/Infinite_Product_Measure.thy
    Author:     Johannes Hölzl, TU München
*)

section \<open>Infinite Product Measure\<close>

theory Infinite_Product_Measure
  imports Probability_Measure Projective_Family
begin

lemma (in product_prob_space) distr_PiM_restrict_finite:
  assumes "finite J" "J \<subseteq> I"
  shows "distr (PiM I M) (PiM J M) (\<lambda>x. restrict x J) = PiM J M"
proof (rule PiM_eqI)
  fix X assume X: "\<And>i. i \<in> J \<Longrightarrow> X i \<in> sets (M i)"
  { fix J X assume J: "J \<noteq> {} \<or> I = {}" "finite J" "J \<subseteq> I" and X: "\<And>i. i \<in> J \<Longrightarrow> X i \<in> sets (M i)"
    have "emeasure (PiM I M) (emb I J (Pi\<^sub>E J X)) = (\<Prod>i\<in>J. M i (X i))"
    proof (subst emeasure_extend_measure_Pair[OF PiM_def, where \<mu>'=lim], goal_cases)
      case 1 then show ?case
        by (simp add: M.emeasure_space_1 emeasure_PiM Pi_iff sets_PiM_I_finite emeasure_lim_emb)
    next
      case (2 J X)
      then have "emb I J (Pi\<^sub>E J X) \<in> sets (PiM I M)"
        by (intro measurable_prod_emb sets_PiM_I_finite) auto
      from this[THEN sets.sets_into_space] show ?case
        by (simp add: space_PiM)
    qed (insert assms J X, simp_all del: sets_lim
      add: M.emeasure_space_1 sets_lim[symmetric] emeasure_countably_additive emeasure_positive) }
  note * = this

  have "emeasure (PiM I M) (emb I J (Pi\<^sub>E J X)) = (\<Prod>i\<in>J. M i (X i))"
  proof (cases "J \<noteq> {} \<or> I = {}")
    case False
    then obtain i where i: "J = {}" "i \<in> I" by auto
    then have "emb I {} {\<lambda>x. undefined} = emb I {i} (\<Pi>\<^sub>E i\<in>{i}. space (M i))"
      by (auto simp: space_PiM prod_emb_def)
    with i show ?thesis
      by (simp add: * M.emeasure_space_1)
  next
    case True
    then show ?thesis
      by (simp add: *[OF _ assms X])
  qed
  with assms show "emeasure (distr (Pi\<^sub>M I M) (Pi\<^sub>M J M) (\<lambda>x. restrict x J)) (Pi\<^sub>E J X) = (\<Prod>i\<in>J. emeasure (M i) (X i))"
    by (subst emeasure_distr_restrict[OF _ refl]) (auto intro!: sets_PiM_I_finite X)
qed (insert assms, auto)

lemma (in product_prob_space) emeasure_PiM_emb':
  "J \<subseteq> I \<Longrightarrow> finite J \<Longrightarrow> X \<in> sets (PiM J M) \<Longrightarrow> emeasure (Pi\<^sub>M I M) (emb I J X) = PiM J M X"
  by (subst distr_PiM_restrict_finite[symmetric, of J])
     (auto intro!: emeasure_distr_restrict[symmetric])

lemma (in product_prob_space) emeasure_PiM_emb:
  "J \<subseteq> I \<Longrightarrow> finite J \<Longrightarrow> (\<And>i. i \<in> J \<Longrightarrow> X i \<in> sets (M i)) \<Longrightarrow>
    emeasure (Pi\<^sub>M I M) (emb I J (Pi\<^sub>E J X)) = (\<Prod> i\<in>J. emeasure (M i) (X i))"
  by (subst emeasure_PiM_emb') (auto intro!: emeasure_PiM)

sublocale product_prob_space \<subseteq> P?: prob_space "Pi\<^sub>M I M"
proof
  have *: "emb I {} {\<lambda>x. undefined} = space (PiM I M)"
    by (auto simp: prod_emb_def space_PiM)
  show "emeasure (Pi\<^sub>M I M) (space (Pi\<^sub>M I M)) = 1"
    using emeasure_PiM_emb[of "{}" "\<lambda>_. {}"] by (simp add: *)
qed

lemma prob_space_PiM:
  assumes M: "\<And>i. i \<in> I \<Longrightarrow> prob_space (M i)" shows "prob_space (PiM I M)"
proof -
  let ?M = "\<lambda>i. if i \<in> I then M i else count_space {undefined}"
  interpret M': prob_space "?M i" for i
    using M by (cases "i \<in> I") (auto intro!: prob_spaceI)
  interpret product_prob_space ?M I
    by unfold_locales
  have "prob_space (\<Pi>\<^sub>M i\<in>I. ?M i)"
    by unfold_locales
  also have "(\<Pi>\<^sub>M i\<in>I. ?M i) = (\<Pi>\<^sub>M i\<in>I. M i)"
    by (intro PiM_cong) auto
  finally show ?thesis .
qed

lemma (in product_prob_space) emeasure_PiM_Collect:
  assumes X: "J \<subseteq> I" "finite J" "\<And>i. i \<in> J \<Longrightarrow> X i \<in> sets (M i)"
  shows "emeasure (Pi\<^sub>M I M) {x\<in>space (Pi\<^sub>M I M). \<forall>i\<in>J. x i \<in> X i} = (\<Prod> i\<in>J. emeasure (M i) (X i))"
proof -
  have "{x\<in>space (Pi\<^sub>M I M). \<forall>i\<in>J. x i \<in> X i} = emb I J (Pi\<^sub>E J X)"
    unfolding prod_emb_def using assms by (auto simp: space_PiM Pi_iff)
  with emeasure_PiM_emb[OF assms] show ?thesis by simp
qed

lemma (in product_prob_space) emeasure_PiM_Collect_single:
  assumes X: "i \<in> I" "A \<in> sets (M i)"
  shows "emeasure (Pi\<^sub>M I M) {x\<in>space (Pi\<^sub>M I M). x i \<in> A} = emeasure (M i) A"
  using emeasure_PiM_Collect[of "{i}" "\<lambda>i. A"] assms
  by simp

lemma (in product_prob_space) measure_PiM_emb:
  assumes "J \<subseteq> I" "finite J" "\<And>i. i \<in> J \<Longrightarrow> X i \<in> sets (M i)"
  shows "measure (PiM I M) (emb I J (Pi\<^sub>E J X)) = (\<Prod> i\<in>J. measure (M i) (X i))"
  using emeasure_PiM_emb[OF assms]
  unfolding emeasure_eq_measure M.emeasure_eq_measure
  by (simp add: prod_ennreal measure_nonneg prod_nonneg)

lemma sets_Collect_single':
  "i \<in> I \<Longrightarrow> {x\<in>space (M i). P x} \<in> sets (M i) \<Longrightarrow> {x\<in>space (PiM I M). P (x i)} \<in> sets (PiM I M)"
  using sets_Collect_single[of i I "{x\<in>space (M i). P x}" M]
  by (simp add: space_PiM PiE_iff cong: conj_cong)

lemma (in finite_product_prob_space) finite_measure_PiM_emb:
  "(\<And>i. i \<in> I \<Longrightarrow> A i \<in> sets (M i)) \<Longrightarrow> measure (PiM I M) (Pi\<^sub>E I A) = (\<Prod>i\<in>I. measure (M i) (A i))"
  using measure_PiM_emb[of I A] finite_index prod_emb_PiE_same_index[OF sets.sets_into_space, of I A M]
  by auto

lemma (in product_prob_space) PiM_component:
  assumes "i \<in> I"
  shows "distr (PiM I M) (M i) (\<lambda>\<omega>. \<omega> i) = M i"
proof (rule measure_eqI[symmetric])
  fix A assume "A \<in> sets (M i)"
  moreover have "((\<lambda>\<omega>. \<omega> i) -` A \<inter> space (PiM I M)) = {x\<in>space (PiM I M). x i \<in> A}"
    by auto
  ultimately show "emeasure (M i) A = emeasure (distr (PiM I M) (M i) (\<lambda>\<omega>. \<omega> i)) A"
    by (auto simp: \<open>i\<in>I\<close> emeasure_distr measurable_component_singleton emeasure_PiM_Collect_single)
qed simp

lemma (in product_prob_space) PiM_eq:
  assumes M': "sets M' = sets (PiM I M)"
  assumes eq: "\<And>J F. finite J \<Longrightarrow> J \<subseteq> I \<Longrightarrow> (\<And>j. j \<in> J \<Longrightarrow> F j \<in> sets (M j)) \<Longrightarrow>
    emeasure M' (prod_emb I M J (\<Pi>\<^sub>E j\<in>J. F j)) = (\<Prod>j\<in>J. emeasure (M j) (F j))"
  shows "M' = (PiM I M)"
proof (rule measure_eqI_PiM_infinite[symmetric, OF refl M'])
  show "finite_measure (Pi\<^sub>M I M)"
    by standard (simp add: P.emeasure_space_1)
qed (simp add: eq emeasure_PiM_emb)

lemma (in product_prob_space) AE_component: "i \<in> I \<Longrightarrow> AE x in M i. P x \<Longrightarrow> AE x in PiM I M. P (x i)"
  apply (rule AE_distrD[of "\<lambda>\<omega>. \<omega> i" "PiM I M" "M i" P])
  apply simp
  apply (subst PiM_component)
  apply simp_all
  done

lemma emeasure_PiM_emb:
  assumes M: "\<And>i. i \<in> I \<Longrightarrow> prob_space (M i)"
  assumes J: "J \<subseteq> I" "finite J" and A: "\<And>i. i \<in> J \<Longrightarrow> A i \<in> sets (M i)"
  shows "emeasure (Pi\<^sub>M I M) (prod_emb I M J (Pi\<^sub>E J A)) = (\<Prod>i\<in>J. emeasure (M i) (A i))"
proof -
  let ?M = "\<lambda>i. if i \<in> I then M i else count_space {undefined}"
  interpret M': prob_space "?M i" for i
    using M by (cases "i \<in> I") (auto intro!: prob_spaceI)
  interpret P: product_prob_space ?M I
    by unfold_locales
  have "emeasure (Pi\<^sub>M I M) (prod_emb I M J (Pi\<^sub>E J A)) = emeasure (Pi\<^sub>M I ?M) (P.emb I J (Pi\<^sub>E J A))"
    by (auto simp: prod_emb_def PiE_iff intro!: arg_cong2[where f=emeasure] PiM_cong)
  also have "\<dots> = (\<Prod>i\<in>J. emeasure (M i) (A i))"
    using J A by (subst P.emeasure_PiM_emb[OF J]) (auto intro!: prod.cong)
  finally show ?thesis .
qed

lemma distr_pair_PiM_eq_PiM:
  fixes i' :: "'i" and I :: "'i set" and M :: "'i \<Rightarrow> 'a measure"
  assumes M: "\<And>i. i \<in> I \<Longrightarrow> prob_space (M i)" "prob_space (M i')"
  shows "distr (M i' \<Otimes>\<^sub>M (\<Pi>\<^sub>M i\<in>I. M i)) (\<Pi>\<^sub>M i\<in>insert i' I. M i) (\<lambda>(x, X). X(i' := x)) =
    (\<Pi>\<^sub>M i\<in>insert i' I. M i)" (is "?L = _")
proof (rule measure_eqI_PiM_infinite[symmetric, OF refl])
  interpret M': prob_space "M i'" by fact
  interpret I: prob_space "(\<Pi>\<^sub>M i\<in>I. M i)"
    using M by (intro prob_space_PiM) auto
  interpret I': prob_space "(\<Pi>\<^sub>M i\<in>insert i' I. M i)"
    using M by (intro prob_space_PiM) auto
  show "finite_measure (\<Pi>\<^sub>M i\<in>insert i' I. M i)"
    by unfold_locales
  fix J A assume J: "finite J" "J \<subseteq> insert i' I" and A: "\<And>i. i \<in> J \<Longrightarrow> A i \<in> sets (M i)"
  let ?X = "prod_emb (insert i' I) M J (Pi\<^sub>E J A)"
  have "Pi\<^sub>M (insert i' I) M ?X = (\<Prod>i\<in>J. M i (A i))"
    using M J A by (intro emeasure_PiM_emb) auto
  also have "\<dots> = M i' (if i' \<in> J then (A i') else space (M i')) * (\<Prod>i\<in>J-{i'}. M i (A i))"
    using prod.insert_remove[of J "\<lambda>i. M i (A i)" i'] J M'.emeasure_space_1
    by (cases "i' \<in> J") (auto simp: insert_absorb)
  also have "(\<Prod>i\<in>J-{i'}. M i (A i)) = Pi\<^sub>M I M (prod_emb I M (J - {i'}) (Pi\<^sub>E (J - {i'}) A))"
    using M J A by (intro emeasure_PiM_emb[symmetric]) auto
  also have "M i' (if i' \<in> J then (A i') else space (M i')) * \<dots> =
    (M i' \<Otimes>\<^sub>M Pi\<^sub>M I M) ((if i' \<in> J then (A i') else space (M i')) \<times> prod_emb I M (J - {i'}) (Pi\<^sub>E (J - {i'}) A))"
    using J A by (intro I.emeasure_pair_measure_Times[symmetric] sets_PiM_I) auto
  also have "((if i' \<in> J then (A i') else space (M i')) \<times> prod_emb I M (J - {i'}) (Pi\<^sub>E (J - {i'}) A)) =
    (\<lambda>(x, X). X(i' := x)) -` ?X \<inter> space (M i' \<Otimes>\<^sub>M Pi\<^sub>M I M)"
    using A[of i', THEN sets.sets_into_space] unfolding set_eq_iff
    by (simp add: prod_emb_def space_pair_measure space_PiM PiE_fun_upd ac_simps cong: conj_cong)
       (auto simp add: Pi_iff Ball_def all_conj_distrib)
  finally show "Pi\<^sub>M (insert i' I) M ?X = ?L ?X"
    using J A by (simp add: emeasure_distr)
qed simp

lemma distr_PiM_reindex:
  assumes M: "\<And>i. i \<in> K \<Longrightarrow> prob_space (M i)"
  assumes f: "inj_on f I" "f \<in> I \<rightarrow> K"
  shows "distr (Pi\<^sub>M K M) (\<Pi>\<^sub>M i\<in>I. M (f i)) (\<lambda>\<omega>. \<lambda>n\<in>I. \<omega> (f n)) = (\<Pi>\<^sub>M i\<in>I. M (f i))"
    (is "distr ?K ?I ?t = ?I")
proof (rule measure_eqI_PiM_infinite[symmetric, OF refl])
  interpret prob_space ?I
    using f M by (intro prob_space_PiM) auto
  show "finite_measure ?I"
    by unfold_locales
  fix A J assume J: "finite J" "J \<subseteq> I" and A: "\<And>i. i \<in> J \<Longrightarrow> A i \<in> sets (M (f i))"
  have [simp]: "i \<in> J \<Longrightarrow> the_inv_into I f (f i) = i" for i
    using J f by (intro the_inv_into_f_f) auto
  have "?I (prod_emb I (\<lambda>i. M (f i)) J (Pi\<^sub>E J A)) = (\<Prod>j\<in>J. M (f j) (A j))"
    using f J A by (intro emeasure_PiM_emb M) auto
  also have "\<dots> = (\<Prod>j\<in>f`J. M j (A (the_inv_into I f j)))"
    using f J by (subst prod.reindex) (auto intro!: prod.cong intro: inj_on_subset simp: the_inv_into_f_f)
  also have "\<dots> = ?K (prod_emb K M (f`J) (\<Pi>\<^sub>E j\<in>f`J. A (the_inv_into I f j)))"
    using f J A by (intro emeasure_PiM_emb[symmetric] M) (auto simp: the_inv_into_f_f)
  also have "prod_emb K M (f`J) (\<Pi>\<^sub>E j\<in>f`J. A (the_inv_into I f j)) = ?t -` prod_emb I (\<lambda>i. M (f i)) J (Pi\<^sub>E J A) \<inter> space ?K"
    using f J A by (auto simp: prod_emb_def space_PiM Pi_iff PiE_iff Int_absorb1)
  also have "?K \<dots> = distr ?K ?I ?t (prod_emb I (\<lambda>i. M (f i)) J (Pi\<^sub>E J A))"
    using f J A by (intro emeasure_distr[symmetric] sets_PiM_I) (auto simp: Pi_iff)
  finally show "?I (prod_emb I (\<lambda>i. M (f i)) J (Pi\<^sub>E J A)) = distr ?K ?I ?t (prod_emb I (\<lambda>i. M (f i)) J (Pi\<^sub>E J A))" .
qed simp

lemma distr_PiM_component:
  assumes M: "\<And>i. i \<in> I \<Longrightarrow> prob_space (M i)"
  assumes "i \<in> I"
  shows "distr (Pi\<^sub>M I M) (M i) (\<lambda>\<omega>. \<omega> i) = M i"
proof -
  have *: "(\<lambda>\<omega>. \<omega> i) -` A \<inter> space (Pi\<^sub>M I M) = prod_emb I M {i} (\<Pi>\<^sub>E i'\<in>{i}. A)" for A
    by (auto simp: prod_emb_def space_PiM)
  show ?thesis
    apply (intro measure_eqI)
    apply (auto simp add: emeasure_distr \<open>i\<in>I\<close> * emeasure_PiM_emb M)
    apply (subst emeasure_PiM_emb)
    apply (simp_all add: M \<open>i\<in>I\<close>)
    done
qed

lemma AE_PiM_component:
  "(\<And>i. i \<in> I \<Longrightarrow> prob_space (M i)) \<Longrightarrow> i \<in> I \<Longrightarrow> AE x in M i. P x \<Longrightarrow> AE x in PiM I M. P (x i)"
  using AE_distrD[of "\<lambda>x. x i" "PiM I M" "M i"]
  by (subst (asm) distr_PiM_component[of I _ i]) (auto intro: AE_distrD[of "\<lambda>x. x i" _ _ P])

lemma decseq_emb_PiE:
  "incseq J \<Longrightarrow> decseq (\<lambda>i. prod_emb I M (J i) (\<Pi>\<^sub>E j\<in>J i. X j))"
  by (fastforce simp: decseq_def prod_emb_def incseq_def Pi_iff)

subsection \<open>Sequence space\<close>

definition comb_seq :: "nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> (nat \<Rightarrow> 'a)" where
  "comb_seq i \<omega> \<omega>' j = (if j < i then \<omega> j else \<omega>' (j - i))"

lemma split_comb_seq: "P (comb_seq i \<omega> \<omega>' j) \<longleftrightarrow> (j < i \<longrightarrow> P (\<omega> j)) \<and> (\<forall>k. j = i + k \<longrightarrow> P (\<omega>' k))"
  by (auto simp: comb_seq_def not_less)

lemma split_comb_seq_asm: "P (comb_seq i \<omega> \<omega>' j) \<longleftrightarrow> \<not> ((j < i \<and> \<not> P (\<omega> j)) \<or> (\<exists>k. j = i + k \<and> \<not> P (\<omega>' k)))"
  by (auto simp: comb_seq_def)

lemma measurable_comb_seq:
  "(\<lambda>(\<omega>, \<omega>'). comb_seq i \<omega> \<omega>') \<in> measurable ((\<Pi>\<^sub>M i\<in>UNIV. M) \<Otimes>\<^sub>M (\<Pi>\<^sub>M i\<in>UNIV. M)) (\<Pi>\<^sub>M i\<in>UNIV. M)"
proof (rule measurable_PiM_single)
  show "(\<lambda>(\<omega>, \<omega>'). comb_seq i \<omega> \<omega>') \<in> space ((\<Pi>\<^sub>M i\<in>UNIV. M) \<Otimes>\<^sub>M (\<Pi>\<^sub>M i\<in>UNIV. M)) \<rightarrow> (UNIV \<rightarrow>\<^sub>E space M)"
    by (auto simp: space_pair_measure space_PiM PiE_iff split: split_comb_seq)
  fix j :: nat and A assume A: "A \<in> sets M"
  then have *: "{\<omega> \<in> space ((\<Pi>\<^sub>M i\<in>UNIV. M) \<Otimes>\<^sub>M (\<Pi>\<^sub>M i\<in>UNIV. M)). case_prod (comb_seq i) \<omega> j \<in> A} =
    (if j < i then {\<omega> \<in> space (\<Pi>\<^sub>M i\<in>UNIV. M). \<omega> j \<in> A} \<times> space (\<Pi>\<^sub>M i\<in>UNIV. M)
              else space (\<Pi>\<^sub>M i\<in>UNIV. M) \<times> {\<omega> \<in> space (\<Pi>\<^sub>M i\<in>UNIV. M). \<omega> (j - i) \<in> A})"
    by (auto simp: space_PiM space_pair_measure comb_seq_def dest: sets.sets_into_space)
  show "{\<omega> \<in> space ((\<Pi>\<^sub>M i\<in>UNIV. M) \<Otimes>\<^sub>M (\<Pi>\<^sub>M i\<in>UNIV. M)). case_prod (comb_seq i) \<omega> j \<in> A} \<in> sets ((\<Pi>\<^sub>M i\<in>UNIV. M) \<Otimes>\<^sub>M (\<Pi>\<^sub>M i\<in>UNIV. M))"
    unfolding * by (auto simp: A intro!: sets_Collect_single)
qed

lemma measurable_comb_seq'[measurable (raw)]:
  assumes f: "f \<in> measurable N (\<Pi>\<^sub>M i\<in>UNIV. M)" and g: "g \<in> measurable N (\<Pi>\<^sub>M i\<in>UNIV. M)"
  shows "(\<lambda>x. comb_seq i (f x) (g x)) \<in> measurable N (\<Pi>\<^sub>M i\<in>UNIV. M)"
  using measurable_compose[OF measurable_Pair[OF f g] measurable_comb_seq] by simp

lemma comb_seq_0: "comb_seq 0 \<omega> \<omega>' = \<omega>'"
  by (auto simp add: comb_seq_def)

lemma comb_seq_Suc: "comb_seq (Suc n) \<omega> \<omega>' = comb_seq n \<omega> (case_nat (\<omega> n) \<omega>')"
  by (auto simp add: comb_seq_def not_less less_Suc_eq le_imp_diff_is_add intro!: ext split: nat.split)

lemma comb_seq_Suc_0[simp]: "comb_seq (Suc 0) \<omega> = case_nat (\<omega> 0)"
  by (intro ext) (simp add: comb_seq_Suc comb_seq_0)

lemma comb_seq_less: "i < n \<Longrightarrow> comb_seq n \<omega> \<omega>' i = \<omega> i"
  by (auto split: split_comb_seq)

lemma comb_seq_add: "comb_seq n \<omega> \<omega>' (i + n) = \<omega>' i"
  by (auto split: nat.split split_comb_seq)

lemma case_nat_comb_seq: "case_nat s' (comb_seq n \<omega> \<omega>') (i + n) = case_nat (case_nat s' \<omega> n) \<omega>' i"
  by (auto split: nat.split split_comb_seq)

lemma case_nat_comb_seq':
  "case_nat s (comb_seq i \<omega> \<omega>') = comb_seq (Suc i) (case_nat s \<omega>) \<omega>'"
  by (auto split: split_comb_seq nat.split)

locale sequence_space = product_prob_space "\<lambda>i. M" "UNIV :: nat set" for M
begin

abbreviation "S \<equiv> \<Pi>\<^sub>M i\<in>UNIV::nat set. M"

lemma infprod_in_sets[intro]:
  fixes E :: "nat \<Rightarrow> 'a set" assumes E: "\<And>i. E i \<in> sets M"
  shows "Pi UNIV E \<in> sets S"
proof -
  have "Pi UNIV E = (\<Inter>i. emb UNIV {..i} (\<Pi>\<^sub>E j\<in>{..i}. E j))"
    using E E[THEN sets.sets_into_space]
    by (auto simp: prod_emb_def Pi_iff extensional_def)
  with E show ?thesis by auto
qed

lemma measure_PiM_countable:
  fixes E :: "nat \<Rightarrow> 'a set" assumes E: "\<And>i. E i \<in> sets M"
  shows "(\<lambda>n. \<Prod>i\<le>n. measure M (E i)) \<longlonglongrightarrow> measure S (Pi UNIV E)"
proof -
  let ?E = "\<lambda>n. emb UNIV {..n} (Pi\<^sub>E {.. n} E)"
  have "\<And>n. (\<Prod>i\<le>n. measure M (E i)) = measure S (?E n)"
    using E by (simp add: measure_PiM_emb)
  moreover have "Pi UNIV E = (\<Inter>n. ?E n)"
    using E E[THEN sets.sets_into_space]
    by (auto simp: prod_emb_def extensional_def Pi_iff)
  moreover have "range ?E \<subseteq> sets S"
    using E by auto
  moreover have "decseq ?E"
    by (auto simp: prod_emb_def Pi_iff decseq_def)
  ultimately show ?thesis
    by (simp add: finite_Lim_measure_decseq)
qed

lemma nat_eq_diff_eq:
  fixes a b c :: nat
  shows "c \<le> b \<Longrightarrow> a = b - c \<longleftrightarrow> a + c = b"
  by auto

lemma PiM_comb_seq:
  "distr (S \<Otimes>\<^sub>M S) S (\<lambda>(\<omega>, \<omega>'). comb_seq i \<omega> \<omega>') = S" (is "?D = _")
proof (rule PiM_eq)
  let ?I = "UNIV::nat set" and ?M = "\<lambda>n. M"
  let "distr _ _ ?f" = "?D"

  fix J E assume J: "finite J" "J \<subseteq> ?I" "\<And>j. j \<in> J \<Longrightarrow> E j \<in> sets M"
  let ?X = "prod_emb ?I ?M J (\<Pi>\<^sub>E j\<in>J. E j)"
  have "\<And>j x. j \<in> J \<Longrightarrow> x \<in> E j \<Longrightarrow> x \<in> space M"
    using J(3)[THEN sets.sets_into_space] by (auto simp: space_PiM Pi_iff subset_eq)
  with J have "?f -` ?X \<inter> space (S \<Otimes>\<^sub>M S) =
    (prod_emb ?I ?M (J \<inter> {..<i}) (\<Pi>\<^sub>E j\<in>J \<inter> {..<i}. E j)) \<times>
    (prod_emb ?I ?M (((+) i) -` J) (\<Pi>\<^sub>E j\<in>((+) i) -` J. E (i + j)))" (is "_ = ?E \<times> ?F")
   by (auto simp: space_pair_measure space_PiM prod_emb_def all_conj_distrib PiE_iff
               split: split_comb_seq split_comb_seq_asm)
  then have "emeasure ?D ?X = emeasure (S \<Otimes>\<^sub>M S) (?E \<times> ?F)"
    by (subst emeasure_distr[OF measurable_comb_seq])
       (auto intro!: sets_PiM_I simp: split_beta' J)
  also have "\<dots> = emeasure S ?E * emeasure S ?F"
    using J by (intro P.emeasure_pair_measure_Times)  (auto intro!: sets_PiM_I finite_vimageI simp: inj_on_def)
  also have "emeasure S ?F = (\<Prod>j\<in>((+) i) -` J. emeasure M (E (i + j)))"
    using J by (intro emeasure_PiM_emb) (simp_all add: finite_vimageI inj_on_def)
  also have "\<dots> = (\<Prod>j\<in>J - (J \<inter> {..<i}). emeasure M (E j))"
    by (rule prod.reindex_cong [of "\<lambda>x. x - i"])
      (auto simp: image_iff ac_simps nat_eq_diff_eq cong: conj_cong intro!: inj_onI)
  also have "emeasure S ?E = (\<Prod>j\<in>J \<inter> {..<i}. emeasure M (E j))"
    using J by (intro emeasure_PiM_emb) simp_all
  also have "(\<Prod>j\<in>J \<inter> {..<i}. emeasure M (E j)) * (\<Prod>j\<in>J - (J \<inter> {..<i}). emeasure M (E j)) = (\<Prod>j\<in>J. emeasure M (E j))"
    by (subst mult.commute) (auto simp: J prod.subset_diff[symmetric])
  finally show "emeasure ?D ?X = (\<Prod>j\<in>J. emeasure M (E j))" .
qed simp_all

lemma PiM_iter:
  "distr (M \<Otimes>\<^sub>M S) S (\<lambda>(s, \<omega>). case_nat s \<omega>) = S" (is "?D = _")
proof (rule PiM_eq)
  let ?I = "UNIV::nat set" and ?M = "\<lambda>n. M"
  let "distr _ _ ?f" = "?D"

  fix J E assume J: "finite J" "J \<subseteq> ?I" "\<And>j. j \<in> J \<Longrightarrow> E j \<in> sets M"
  let ?X = "prod_emb ?I ?M J (\<Pi>\<^sub>E j\<in>J. E j)"
  have "\<And>j x. j \<in> J \<Longrightarrow> x \<in> E j \<Longrightarrow> x \<in> space M"
    using J(3)[THEN sets.sets_into_space] by (auto simp: space_PiM Pi_iff subset_eq)
  with J have "?f -` ?X \<inter> space (M \<Otimes>\<^sub>M S) = (if 0 \<in> J then E 0 else space M) \<times>
    (prod_emb ?I ?M (Suc -` J) (\<Pi>\<^sub>E j\<in>Suc -` J. E (Suc j)))" (is "_ = ?E \<times> ?F")
   by (auto simp: space_pair_measure space_PiM PiE_iff prod_emb_def all_conj_distrib
      split: nat.split nat.split_asm)
  then have "emeasure ?D ?X = emeasure (M \<Otimes>\<^sub>M S) (?E \<times> ?F)"
    by (subst emeasure_distr)
       (auto intro!: sets_PiM_I simp: split_beta' J)
  also have "\<dots> = emeasure M ?E * emeasure S ?F"
    using J by (intro P.emeasure_pair_measure_Times) (auto intro!: sets_PiM_I finite_vimageI)
  also have "emeasure S ?F = (\<Prod>j\<in>Suc -` J. emeasure M (E (Suc j)))"
    using J by (intro emeasure_PiM_emb) (simp_all add: finite_vimageI)
  also have "\<dots> = (\<Prod>j\<in>J - {0}. emeasure M (E j))"
    by (rule prod.reindex_cong [of "\<lambda>x. x - 1"])
      (auto simp: image_iff nat_eq_diff_eq ac_simps cong: conj_cong intro!: inj_onI)
  also have "emeasure M ?E * (\<Prod>j\<in>J - {0}. emeasure M (E j)) = (\<Prod>j\<in>J. emeasure M (E j))"
    by (auto simp: M.emeasure_space_1 prod.remove J)
  finally show "emeasure ?D ?X = (\<Prod>j\<in>J. emeasure M (E j))" .
qed simp_all

end

lemma PiM_return:
  assumes "finite I"
  assumes [measurable]: "\<And>i. i \<in> I \<Longrightarrow> {a i} \<in> sets (M i)"
  shows "PiM I (\<lambda>i. return (M i) (a i)) = return (PiM I M) (restrict a I)"
proof -
  have [simp]: "a i \<in> space (M i)" if "i \<in> I" for i
    using assms(2)[OF that] by (meson insert_subset sets.sets_into_space)
  interpret prob_space "PiM I (\<lambda>i. return (M i) (a i))"
    by (intro prob_space_PiM prob_space_return) auto
  have "AE x in PiM I (\<lambda>i. return (M i) (a i)). \<forall>i\<in>I. x i = restrict a I i"
    by (intro eventually_ball_finite ballI AE_PiM_component prob_space_return assms)
       (auto simp: AE_return)
  moreover have "AE x in PiM I (\<lambda>i. return (M i) (a i)). x \<in> space (PiM I (\<lambda>i. return (M i) (a i)))"
    by simp
  ultimately have "AE x in PiM I (\<lambda>i. return (M i) (a i)). x = restrict a I"
    by eventually_elim (auto simp: fun_eq_iff space_PiM)
  hence "Pi\<^sub>M I (\<lambda>i. return (M i) (a i)) = return (Pi\<^sub>M I (\<lambda>i. return (M i) (a i))) (restrict a I)"
    by (rule AE_eq_constD)
  also have "\<dots> = return (PiM I M) (restrict a I)"
    by (intro return_cong sets_PiM_cong) auto
  finally show ?thesis .
qed

lemma distr_PiM_finite_prob_space':
  assumes fin: "finite I"
  assumes "\<And>i. i \<in> I \<Longrightarrow> prob_space (M i)"
  assumes "\<And>i. i \<in> I \<Longrightarrow> prob_space (M' i)"
  assumes [measurable]: "\<And>i. i \<in> I \<Longrightarrow> f \<in> measurable (M i) (M' i)"
  shows   "distr (PiM I M) (PiM I M') (compose I f) = PiM I (\<lambda>i. distr (M i) (M' i) f)"
proof -
  define N where "N = (\<lambda>i. if i \<in> I then M i else return (count_space UNIV) undefined)"
  define N' where "N' = (\<lambda>i. if i \<in> I then M' i else return (count_space UNIV) undefined)"
  have [simp]: "PiM I N = PiM I M" "PiM I N' = PiM I M'"
    by (intro PiM_cong; simp add: N_def N'_def)+

  have "distr (PiM I N) (PiM I N') (compose I f) = PiM I (\<lambda>i. distr (N i) (N' i) f)"
  proof (rule distr_PiM_finite_prob_space)
    show "product_prob_space N"
      by (rule product_prob_spaceI) (auto simp: N_def intro!: prob_space_return assms)
    show "product_prob_space N'"
      by (rule product_prob_spaceI) (auto simp: N'_def intro!: prob_space_return assms)
  qed (auto simp: N_def N'_def fin)
  also have "Pi\<^sub>M I (\<lambda>i. distr (N i) (N' i) f) = Pi\<^sub>M I (\<lambda>i. distr (M i) (M' i) f)"
    by (intro PiM_cong) (simp_all add: N_def N'_def)
  finally show ?thesis by simp
qed

end


theory prop_50
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun le :: "Nat => Nat => bool" where
  "le (Z) y = True"
  | "le (S z) (Z) = False"
  | "le (S z) (S x2) = le z x2"
  fun insert2 :: "Nat => Nat list => Nat list" where
  "insert2 x (Nil2) = Cons2 x (Nil2)"
  | "insert2 x (Cons2 z xs) =
       (if le x z then Cons2 x (Cons2 z xs) else Cons2 z (insert2 x xs))"
  fun isort :: "Nat list => Nat list" where
  "isort (Nil2) = Nil2"
  | "isort (Cons2 y xs) = insert2 y (isort xs)"
  fun equal2 :: "Nat => Nat => bool" where
  "equal2 (Z) (Z) = True"
  | "equal2 (Z) (S z) = False"
  | "equal2 (S x2) (Z) = False"
  | "equal2 (S x2) (S y2) = equal2 x2 y2"
  fun count :: "Nat => Nat list => Nat" where
  "count x (Nil2) = Z"
  | "count x (Cons2 z xs) =
       (if equal2 x z then S (count x xs) else count x xs)"
  (*hipster le insert2 isort equal2 count *)
hipster count equal2
lemma lemma_a [thy_expl]: "equal2 x2 y2 = equal2 y2 x2"
by (hipster_induct_schemes count.simps equal2.simps)

lemma lemma_aa [thy_expl]: "equal2 x2 x2 = True"
by (hipster_induct_schemes count.simps equal2.simps)

lemma lemma_ab [thy_expl]: "equal2 x2 (S x2) = False"
by (hipster_induct_schemes count.simps equal2.simps)

lemma lemma_ac [thy_expl]: "equal2 y2 x2 \<Longrightarrow> x2 = y2"
by (hipster_induct_schemes equal2.simps count.simps)

lemma lemma_ad [thy_expl]: "le x2 x2 = True"
by (hipster_induct_schemes le.simps)

lemma lemma_ae [thy_expl]: "le x2 (S x2) = True"
by (hipster_induct_schemes le.simps)

lemma lemma_af [thy_expl]: "le (S x2) x2 = False"
by (hipster_induct_schemes le.simps)

(*hipster_cond le*)
lemma lemma_ag [thy_expl]: "le x2 y2 \<Longrightarrow> le x2 (S y2) = True"
by (hipster_induct_schemes le.simps)

lemma lemma_ah [thy_expl]: "le y2 x2 \<Longrightarrow> le (S x2) y2 = False"
by (hipster_induct_schemes le.simps)

lemma lemma_ai [thy_expl]: "le y x \<and> le x y \<Longrightarrow> x = y"
by (hipster_induct_schemes le.simps Nat.exhaust)

lemma le_trans [thy_expl]: "le z y \<and> le x z \<Longrightarrow> le x y = True"
by (hipster_induct_schemes le.simps Nat.exhaust)

hipster_cond le equal2 insert2 isort count
lemma lemma_aj [thy_expl]: "count x26 (insert2 x26 y26) = S (count x26 y26)"
by (hipster_induct_schemes le.simps equal2.simps insert2.simps isort.simps count.simps)

lemma lemma_ak [thy_expl]: "insert2 Z (insert2 x26 y26) = insert2 x26 (insert2 Z y26)"
by (hipster_induct_schemes le.simps equal2.simps insert2.simps isort.simps count.simps)

lemma lemma_al [thy_expl]: "count (S x26) (insert2 x26 y26) = count (S x26) y26"
by (hipster_induct_schemes le.simps equal2.simps insert2.simps isort.simps count.simps)

lemma lemma_am [thy_expl]: "insert2 Z (isort x3) = isort (insert2 Z x3)"
by (hipster_induct_schemes le.simps equal2.simps insert2.simps isort.simps count.simps)

lemma lemma_an [thy_expl]: "count (S x4) (insert2 Z y4) = count (S x4) y4"
by (hipster_induct_schemes le.simps equal2.simps insert2.simps isort.simps count.simps)

lemma lemma_ao [thy_expl]: "le y26 x26 \<Longrightarrow> count (S x26) (insert2 y26 z26) = count (S x26) z26"
by (hipster_induct_schemes le.simps equal2.simps insert2.simps isort.simps count.simps)

lemma unknown [thy_expl]: "insert2 x (insert2 y z) = insert2 y (insert2 x z)"
oops

lemma unknown [thy_expl]: "count x (isort y) = count x y"
oops

lemma unknown [thy_expl]: "isort (insert2 x y) = insert2 x (isort y)"
oops

lemma unknown [thy_expl]: "isort (isort x) = isort x"
oops

lemma unknown [thy_expl]: "count (count x y) (isort z) = count (count x y) z"
oops

lemma unknown [thy_expl]: "count (count x y) (isort y) = count (count x y) y"
oops

lemma unknown [thy_expl]: "count (S x) (isort y) = count (S x) y"
oops

lemma unknown [thy_expl]: "count Z (isort x) = count Z x"
oops

lemma unknown [thy_expl]: "count (count Z x) (isort y) = count (count Z x) y"
oops

lemma unknown [thy_expl]: "count (count Z x) (isort x) = count (count Z x) x"
oops

lemma unknown [thy_expl]: "count (S Z) (isort x) = count (S Z) x"
oops

datatype NL = NN | NC Nat NL

  fun ins2 :: "Nat => NL => NL" where
  "ins2 x (NN) = NC x (NN)"
  | "ins2 x (NC z xs) =
       (if le x z then NC x (NC z xs) else NC z (ins2 x xs))"
  fun cou :: "Nat => NL => Nat" where
  "cou x (NN) = Z"
  | "cou x (NC z xs) =
       (if equal2 x z then S (cou x xs) else cou x xs)"
hipster cou ins2 le equal2
lemma lemma_ap [thy_expl]: "NC Z x3 = ins2 Z x3"
by (hipster_induct_schemes cou.simps ins2.simps le.simps equal2.simps)

lemma lemma_aq [thy_expl]: "count x (Cons2 y z) = count x (insert2 y z)"
by (hipster_induct_schemes count.simps insert2.simps le.simps equal2.simps)

lemma unknown [thy_expl]: "ins2 x (ins2 y z) = ins2 y (ins2 x z)"
oops

lemma unknown [thy_expl]: "ins2 x (ins2 y NN) = ins2 y (ins2 x NN)"
oops
(*hipster count insert2 isort le*)

  theorem x0 :
    "(count x (isort y)) = (count x y)"
    by (hipster_induct_schemes count.simps isort.simps insert2.simps le.simps equal2.simps)
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


(*
Title: Fusion Laws
Author: Georg Struth
Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
*)

section \<open>Galois Connection and Fixpoint Fusion\<close>

theory Galois_Fusion
  imports "Two_KA"

begin

text \<open>This comes from an AFP entry for lattices.\<close>

unbundle "lattice_syntax"

definition adj :: "('a::ord \<Rightarrow> 'b::ord) \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> bool" (infixl "\<stileturn>" 70) where
  "(f \<stileturn> g) = (\<forall>x y. (f x \<le> y) = (x \<le> g y))"

definition "ladj (g::'a::Inf \<Rightarrow> 'b::ord) = (\<lambda>x. \<Sqinter>{y. x \<le> g y})"

definition "radj (f::'a::Sup \<Rightarrow> 'b::ord)  = (\<lambda>y. \<Squnion>{x. f x \<le> y})"

lemma adj_iso1: "f \<stileturn> g \<Longrightarrow> mono f"
  unfolding adj_def mono_def by (meson dual_order.refl dual_order.trans)

lemma adj_iso2: "f \<stileturn> g \<Longrightarrow> mono g"
  unfolding adj_def mono_def by (meson dual_order.refl dual_order.trans)

lemma adj_comp: "f \<stileturn> g \<Longrightarrow> adj h k \<Longrightarrow> (f \<circ> h) \<stileturn> (k \<circ> g)"
  by (simp add: adj_def)

lemma adj_cancel1:
  fixes f :: "'a::preorder \<Rightarrow> 'b::ord"
  shows "f \<stileturn> g \<Longrightarrow> f \<circ> g \<le> id"
  by (simp add: adj_def le_funI)

lemma adj_cancel2:
  fixes f :: "'a::ord \<Rightarrow> 'b::preorder"
  shows "f \<stileturn> g \<Longrightarrow> id \<le> g \<circ> f"
  by (simp add: adj_def eq_iff le_funI)

lemma adj_prop:
  fixes f :: "'a::preorder \<Rightarrow>'a"
  shows "f \<stileturn> g \<Longrightarrow> f \<circ> g \<le> g \<circ> f"
  using adj_cancel1 adj_cancel2 order_trans by blast

lemma adj_cancel_eq1:
  fixes f :: "'a::preorder \<Rightarrow> 'b::order"
  shows "f \<stileturn> g \<Longrightarrow> f \<circ> g \<circ> f = f"
  unfolding adj_def comp_def fun_eq_iff by (meson eq_iff order_refl order_trans)

lemma adj_cancel_eq2:
  fixes f :: "'a::order \<Rightarrow> 'b::preorder"
  shows "f \<stileturn> g \<Longrightarrow> g \<circ> f \<circ> g = g"
  unfolding adj_def comp_def fun_eq_iff by (meson eq_iff order_refl order_trans)

lemma adj_idem1:
  fixes f :: "'a::preorder \<Rightarrow> 'b::order"
  shows "f \<stileturn> g \<Longrightarrow> (f \<circ> g) \<circ> (f \<circ> g) = f \<circ> g"
  by (simp add: adj_cancel_eq1 rewriteL_comp_comp)

lemma adj_idem2:
  fixes f :: "'a::order \<Rightarrow> 'b::preorder"
  shows "f \<stileturn> g \<Longrightarrow> (g \<circ> f) \<circ> (g \<circ> f) = g \<circ> f"
  by (simp add: adj_cancel_eq2 rewriteL_comp_comp)

lemma adj_iso3:
  fixes f :: "'a::order \<Rightarrow> 'b::order"
  shows "f \<stileturn> g \<Longrightarrow> mono (f \<circ> g)"
  by (simp add: adj_iso1 adj_iso2 monoD monoI)

lemma adj_iso4:
  fixes f :: "'a::order \<Rightarrow> 'b::order"
  shows "f \<stileturn> g \<Longrightarrow> mono (g \<circ> f)"
  by (simp add: adj_iso1 adj_iso2 monoD monoI)

lemma adj_canc1:
  fixes f :: "'a::order \<Rightarrow> 'b::ord"
  shows "f \<stileturn> g \<Longrightarrow> ((f \<circ> g) x = (f \<circ> g) y \<longrightarrow> g x = g y)"
  unfolding adj_def comp_def by (metis eq_iff)

lemma adj_canc2:
  fixes f :: "'a::ord \<Rightarrow> 'b::order"
  shows "f \<stileturn> g \<Longrightarrow> ((g \<circ> f) x = (g \<circ> f) y \<longrightarrow> f x = f y)"
  unfolding adj_def comp_def by (metis eq_iff)

lemma adj_sur_inv:
  fixes f :: "'a::preorder \<Rightarrow> 'b::order"
  shows "f \<stileturn> g \<Longrightarrow> ((surj f) = (f \<circ> g = id))"
  unfolding adj_def surj_def comp_def by (metis eq_id_iff eq_iff order_refl order_trans)

lemma adj_surj_inj:
  fixes f :: "'a::order \<Rightarrow> 'b::order"
  shows "f \<stileturn> g \<Longrightarrow> ((surj f) = (inj g))"
  unfolding adj_def inj_def surj_def by (metis eq_iff order_trans)

lemma adj_inj_inv:
  fixes f :: "'a::preorder \<Rightarrow> 'b::order"
  shows "f \<stileturn> g \<Longrightarrow> ((inj f) = (g \<circ> f = id))"
  by (metis adj_cancel_eq1 eq_id_iff inj_def o_apply)

lemma adj_inj_surj:
  fixes f :: "'a::order \<Rightarrow> 'b::order"
  shows "f \<stileturn> g \<Longrightarrow> ((inj f) = (surj g))"
  unfolding adj_def inj_def surj_def by (metis eq_iff order_trans)

lemma surj_id_the_inv: "surj f \<Longrightarrow> g \<circ> f = id \<Longrightarrow> g = the_inv f"
  by (metis comp_apply id_apply inj_on_id inj_on_imageI2 surj_fun_eq the_inv_f_f)

lemma inj_id_the_inv: "inj f \<Longrightarrow> f \<circ> g = id \<Longrightarrow> f = the_inv g"
  by (metis fun.set_map image_inv_f_f inj_imp_surj_inv surj_id surj_id_the_inv)

abbreviation Sup_pres :: "('a::Sup \<Rightarrow> 'b::Sup) \<Rightarrow> bool" where
  "Sup_pres f \<equiv> f \<circ> Sup = Sup \<circ> image f"

abbreviation Inf_pres :: "('a::Inf \<Rightarrow> 'b::Inf) \<Rightarrow> bool" where
  "Inf_pres f \<equiv> f \<circ> Inf = Inf \<circ> image f"

lemma radj_Inf_pres:
  fixes g :: "'b::complete_lattice \<Rightarrow> 'a::complete_lattice"
  shows "(\<exists>f. f \<stileturn> g) \<Longrightarrow> Inf_pres g"
  apply (rule antisym, simp_all add: le_fun_def adj_def, safe)
  apply (meson INF_greatest Inf_lower dual_order.refl dual_order.trans)
  by (meson Inf_greatest dual_order.refl le_INF_iff)

lemma ladj_Sup_pres:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows "(\<exists>g. f \<stileturn> g) \<Longrightarrow> Sup_pres f"
  apply (rule antisym, simp_all add: le_fun_def adj_def, safe)
  apply (metis SUP_upper Sup_least)
  by (meson SUP_least Sup_upper order_refl order_trans)

lemma radj_adj:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows "f \<stileturn> g \<Longrightarrow> g = (radj f)"
  unfolding adj_def radj_def by (metis (mono_tags, lifting) cSup_eq_maximum eq_iff mem_Collect_eq)

lemma ladj_adj:
  fixes g :: "'b::complete_lattice \<Rightarrow> 'a::complete_lattice"
  shows "f \<stileturn> g \<Longrightarrow> f = (ladj g)"
  unfolding adj_def ladj_def by (metis (no_types, lifting) cInf_eq_minimum eq_iff mem_Collect_eq)

lemma Inf_subdistl_iso:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows "f \<circ> Inf \<le> Inf \<circ> image f \<Longrightarrow> mono f"
  unfolding mono_def le_fun_def comp_def by (metis complete_lattice_class.le_INF_iff Inf_atLeast atLeast_iff)

lemma Inf_pres_radj_aux:
  fixes g :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows "Inf_pres g \<Longrightarrow> (ladj g) \<stileturn> g"
proof-
  assume a: "Inf_pres g"
  {fix x y
   assume b: "ladj g x \<le> y"
   hence "g (ladj g x) \<le> g y"
    by (simp add: Inf_subdistl_iso a monoD)
  hence "\<Sqinter>{g y |y. x \<le> g y} \<le> g y"
    by (metis a comp_eq_dest_lhs setcompr_eq_image ladj_def)
  hence "x \<le> g y"
    using dual_order.trans le_Inf_iff by blast
  hence "ladj g x \<le> y \<longrightarrow> x \<le> g y"
    by simp}
  thus ?thesis
    unfolding adj_def ladj_def by (meson CollectI Inf_lower)
qed

lemma Sup_supdistl_iso:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows "Sup \<circ> (`) f \<le> f \<circ> Sup \<Longrightarrow> mono f"
  unfolding mono_def le_fun_def comp_def by (metis complete_lattice_class.SUP_le_iff Sup_atMost atMost_iff)

lemma Sup_pres_ladj_aux:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows "Sup_pres f \<Longrightarrow> f \<stileturn> (radj f)"
proof-
  assume a: "Sup_pres f"
  {fix x y
   assume b: "x \<le> radj f y"
   hence "f x \<le> f (radj f y)"
     by (simp add: Sup_supdistl_iso a monoD)
   hence "f x \<le> \<Squnion>{f x |x. f x \<le> y}"
     by (metis a comp_eq_dest_lhs setcompr_eq_image radj_def)
   hence "f x \<le> y"
     by (smt (verit, ccfv_SIG) Sup_eq_Inf le_Inf_iff mem_Collect_eq)
  hence "x \<le> radj f y \<longrightarrow> f x \<le> y"
    by simp}
  thus ?thesis
    unfolding adj_def radj_def by (meson CollectI Sup_upper)
qed

lemma Inf_pres_radj:
  fixes g :: "'b::complete_lattice \<Rightarrow> 'a::complete_lattice"
  shows "Inf_pres g \<Longrightarrow> (\<exists>f. f \<stileturn> g)"
  using Inf_pres_radj_aux by fastforce

lemma Sup_pres_ladj:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows "Sup_pres f \<Longrightarrow> (\<exists>g. f \<stileturn> g)"
  using Sup_pres_ladj_aux by fastforce

lemma Inf_pres_upper_adj_eq:
  fixes g :: "'b::complete_lattice \<Rightarrow> 'a::complete_lattice"
  shows "(Inf_pres g) = (\<exists>f. f \<stileturn> g)"
  using radj_Inf_pres Inf_pres_radj by blast

lemma Sup_pres_ladj_eq:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows  "(Sup_pres f) = (\<exists>g. f \<stileturn> g)"
  using Sup_pres_ladj ladj_Sup_pres by blast

definition Fix :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a set" where
  "Fix f = {x. f x = x}"

lemma lfp_Fix:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  shows "mono f \<Longrightarrow> lfp f = \<Sqinter>(Fix f)"
  unfolding lfp_def Fix_def
  apply (rule antisym)
  apply (simp add: Collect_mono Inf_superset_mono)
  by (metis (mono_tags) Inf_lower lfp_def lfp_unfold mem_Collect_eq)

lemma gfp_Fix:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  shows "mono f \<Longrightarrow> gfp f = \<Squnion>(Fix f)"
  unfolding gfp_def Fix_def
  apply (rule antisym)
  apply (metis (mono_tags, lifting) Sup_mono def_gfp_unfold gfp_upperbound mem_Collect_eq)
  by (simp add: Collect_mono Sup_subset_mono)

lemma gfp_little_fusion:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  and g :: "'b::complete_lattice \<Rightarrow> 'b"
  assumes "mono f"
  assumes "h \<circ> f \<le> g \<circ> h"
  shows "h (gfp f) \<le> gfp g"
  by (metis assms(1) assms(2) comp_apply gfp_unfold gfp_upperbound le_funD)

lemma lfp_little_fusion:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  and g :: "'b::complete_lattice \<Rightarrow> 'b"
  assumes "mono f"
  assumes "g \<circ> h \<le> h \<circ> f"
  shows "lfp g \<le> h (lfp f)"
  by (metis assms(1) assms(2) comp_apply le_funD lfp_lowerbound lfp_unfold)

lemma gfp_fusion:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  and g :: "'b::complete_lattice \<Rightarrow> 'b"
  assumes "\<exists>f. f \<stileturn> h"
  and "mono f"
  and "mono g"
  and "h \<circ> f = g \<circ> h"
shows "h (gfp f) = gfp g"
  by (smt (verit, ccfv_threshold) adj_def assms(1) assms(2) assms(3) assms(4) comp_eq_elim gfp_eqI gfp_fixpoint gfp_upperbound monoD order_refl)

lemma lfp_fusion:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  and g :: "'b::complete_lattice \<Rightarrow> 'b"
  assumes "\<exists>f. h \<stileturn> f"
  and "mono f"
  and "mono g"
  and "h \<circ> f = g \<circ> h"
shows "h (lfp f) = lfp g"
  by (smt (verit, del_insts) adj_def assms(1) assms(2) assms(3) assms(4) comp_eq_elim dual_order.antisym lfp_lowerbound lfp_unfold monoD order_refl)

lemma gfp_fusion_inf_pres:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  and g :: "'b::complete_lattice \<Rightarrow> 'b"
  assumes "Inf_pres h"
  and "mono f"
  and "mono g"
  and "h \<circ> f = g \<circ> h"
  shows "h (gfp f) = gfp g"
  by (simp add: Inf_pres_radj assms gfp_fusion)

lemma k_adju:
  fixes k :: "'a::order \<Rightarrow> 'b::complete_lattice"
  shows "\<forall>y.\<exists>F. (F::'b \<Rightarrow> 'a \<Rightarrow> 'b) \<stileturn> (\<lambda>k. k y)"
  by (force intro!: fun_eq_iff Inf_pres_radj)

lemma k_adju_var: "\<forall>y.\<exists>F.\<forall>x.\<forall>f::'a::order \<Rightarrow> 'b::complete_lattice. (F x \<le> f) = (x \<le> (\<lambda>k. k y) f)"
  using k_adju unfolding adj_def by blast

lemma gfp_fusion_var:
  fixes F :: "('a::order \<Rightarrow> 'b::complete_lattice) \<Rightarrow> 'a \<Rightarrow> 'b"
  and g :: "'b \<Rightarrow> 'b"
  assumes "mono F"
  and "mono g"
  and "\<forall>h. F h x = g (h x)"
shows "gfp F x = gfp g"
  by (metis (no_types, opaque_lifting) antisym assms(1) assms(2) assms(3) dual_order.refl gfp_unfold gfp_upperbound k_adju_var monoD)

end


theory WordInterval_Lists
imports IP_Addresses.WordInterval
  Negation_Type
begin

fun l2wi_negation_type_union :: "('a::len word \<times> 'a::len word) negation_type list \<Rightarrow> 'a::len wordinterval" where
  "l2wi_negation_type_union [] = Empty_WordInterval" |
  "l2wi_negation_type_union ((Pos (s,e))#ls) = wordinterval_union (WordInterval s e) (l2wi_negation_type_union ls)" |
  "l2wi_negation_type_union ((Neg (s,e))#ls) = wordinterval_union (wordinterval_invert (WordInterval s e)) (l2wi_negation_type_union ls)"

lemma l2wi_negation_type_union: "wordinterval_to_set (l2wi_negation_type_union l) =
                      (\<Union> (i,j) \<in> set (getPos l). {i .. j}) \<union> (\<Union> (i,j) \<in> set (getNeg l). - {i .. j})"
apply(simp add: l2wi)
apply(induction l rule: l2wi_negation_type_union.induct)
  apply(simp_all)
 apply fast+
done

definition l2wi_intersect :: "('a::len word \<times> 'a::len word) list \<Rightarrow> 'a::len wordinterval" where
  "l2wi_intersect = foldl (\<lambda> acc (s,e). wordinterval_intersection (WordInterval s e) acc) wordinterval_UNIV"

lemma l2wi_intersect: "wordinterval_to_set (l2wi_intersect l) = (\<Inter> (i,j) \<in> set l. {i .. j})"
  proof -
  { fix U \<comment> \<open>@{const wordinterval_UNIV} generalized\<close>
    have "wordinterval_to_set (foldl (\<lambda>acc (s, e). wordinterval_intersection (WordInterval s e) acc) U l) = (wordinterval_to_set U) \<inter> (\<Inter>(i, j)\<in>set l. {i..j})"
        apply(induction l arbitrary: U)
         apply(simp)
        by force
  } thus ?thesis
    unfolding l2wi_intersect_def by simp
  qed

fun l2wi_negation_type_intersect :: "('a::len word \<times> 'a::len word) negation_type list \<Rightarrow> 'a::len wordinterval" where
  "l2wi_negation_type_intersect [] = wordinterval_UNIV" |
  "l2wi_negation_type_intersect ((Pos (s,e))#ls) = wordinterval_intersection (WordInterval s e) (l2wi_negation_type_intersect ls)" |
  "l2wi_negation_type_intersect ((Neg (s,e))#ls) = wordinterval_intersection (wordinterval_invert (WordInterval s e)) (l2wi_negation_type_intersect ls)"

lemma l2wi_negation_type_intersect_alt: "wordinterval_to_set (l2wi_negation_type_intersect l) =
                wordinterval_to_set (wordinterval_setminus (l2wi_intersect (getPos l)) (l2wi (getNeg l)))"
  apply(simp add: l2wi_intersect l2wi)
  apply(induction l rule :l2wi_negation_type_intersect.induct)
     apply(simp_all)
    apply(fast)+
  done

lemma l2wi_negation_type_intersect: "wordinterval_to_set (l2wi_negation_type_intersect l) =
                      (\<Inter> (i,j) \<in> set (getPos l). {i .. j}) - (\<Union> (i,j) \<in> set (getNeg l). {i .. j})"
  by(simp add: l2wi_negation_type_intersect_alt l2wi_intersect l2wi)

end


theory Ex047
  imports Main
begin

theorem "(\<forall>A B . ((A \<longrightarrow> B) \<longrightarrow> A) \<longrightarrow> A) \<longleftrightarrow> (\<forall>A. \<not>A \<or> A)"
proof -
  {
    assume a:"\<forall>A B. ((A \<longrightarrow> B) \<longrightarrow> A) \<longrightarrow> A"
    {
      fix AA B
      {
        assume b:"(AA \<longrightarrow> B)"
          with a have

      }
    }
  }

(*simple version*)

theorem "(\<forall>A B . ((A \<longrightarrow> B) \<longrightarrow> A) \<longrightarrow> A) \<longleftrightarrow> (\<forall>A. \<not>A \<or> A)"
proof -
  {
    assume a:"\<forall>A B. ((A \<longrightarrow> B) \<longrightarrow> A) \<longrightarrow> A"
    {
      fix AA
      {
        assume b:"\<not>(\<not>AA \<or> AA)"
        {
          assume "\<not>AA"
          hence "\<not>AA \<or> AA" by (rule disjI1)
          with b have False by contradiction
        }
        hence "AA" by (rule notI[THEN notnotD])
        hence "\<not>AA \<or> AA" by (rule disjI2)
        with b have False by contradiction
      }
      hence "\<not>AA \<or> AA" by (rule notI[THEN notnotD])
    }
    hence "\<forall>A. \<not>A \<or> A" by (rule allI)
  }
  moreover
  {
    assume "\<forall>A . \<not>A \<or> A"
  }


(*<*)
(*
 * The worker/wrapper transformation, following Gill and Hutton.
 * (C)opyright 2009-2011, Peter Gammie, peteg42 at gmail.com.
 * License: BSD
 *)

theory Nub
imports
  HOLCF
  LList
  Maybe
  Nats
  WorkerWrapperNew
begin
(*>*)

section{* Transforming $O(n^2)$ \emph{nub} into an $O(n\lg n)$ one *}

text{* Andy Gill's solution, mechanised. *}

subsection{* The @{term "nub"} function. *}

fixrec nub :: "Nat llist \<rightarrow> Nat llist"
where
  "nub\<cdot>lnil = lnil"
| "nub\<cdot>(x :@ xs) = x :@ nub\<cdot>(lfilter\<cdot>(neg oo (\<Lambda> y. x =\<^sub>B y))\<cdot>xs)"

lemma nub_strict[simp]: "nub\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

fixrec nub_body :: "(Nat llist \<rightarrow> Nat llist) \<rightarrow> Nat llist \<rightarrow> Nat llist"
where
  "nub_body\<cdot>f\<cdot>lnil = lnil"
| "nub_body\<cdot>f\<cdot>(x :@ xs) = x :@ f\<cdot>(lfilter\<cdot>(neg oo (\<Lambda> y. x =\<^sub>B y))\<cdot>xs)"

lemma nub_nub_body_eq: "nub = fix\<cdot>nub_body"
  by (rule cfun_eqI, subst nub_def, subst nub_body.unfold, simp)

(* **************************************** *)

subsection{* Optimised data type. *}

text {* Implement sets using lazy lists for now. Lifting up HOL's @{typ "'a
set"} type causes continuity grief. *}

type_synonym NatSet = "Nat llist"

definition
  SetEmpty :: "NatSet" where
  "SetEmpty \<equiv> lnil"

definition
  SetInsert :: "Nat \<rightarrow> NatSet \<rightarrow> NatSet" where
  "SetInsert \<equiv> lcons"

definition
  SetMem :: "Nat \<rightarrow> NatSet \<rightarrow> tr" where
  "SetMem \<equiv> lmember\<cdot>(bpred (op =))"

lemma SetMem_strict[simp]: "SetMem\<cdot>x\<cdot>\<bottom> = \<bottom>" by (simp add: SetMem_def)
lemma SetMem_SetEmpty[simp]: "SetMem\<cdot>x\<cdot>SetEmpty = FF"
  by (simp add: SetMem_def SetEmpty_def)
lemma SetMem_SetInsert: "SetMem\<cdot>v\<cdot>(SetInsert\<cdot>x\<cdot>s) = (SetMem\<cdot>v\<cdot>s orelse x =\<^sub>B v)"
  by (simp add: SetMem_def SetInsert_def)

text {* AndyG's new type. *}

domain R = R (lazy resultR :: "Nat llist") (lazy exceptR :: "NatSet")

definition
  nextR :: "R \<rightarrow> (Nat * R) Maybe" where
  "nextR = (\<Lambda> r. case ldropWhile\<cdot>(\<Lambda> x. SetMem\<cdot>x\<cdot>(exceptR\<cdot>r))\<cdot>(resultR\<cdot>r) of
                     lnil \<Rightarrow> Nothing
                   | x :@ xs \<Rightarrow> Just\<cdot>(x, R\<cdot>xs\<cdot>(exceptR\<cdot>r)))"

lemma nextR_strict1[simp]: "nextR\<cdot>\<bottom> = \<bottom>" by (simp add: nextR_def)
lemma nextR_strict2[simp]: "nextR\<cdot>(R\<cdot>\<bottom>\<cdot>S) = \<bottom>" by (simp add: nextR_def)

lemma nextR_lnil[simp]: "nextR\<cdot>(R\<cdot>lnil\<cdot>S) = Nothing" by (simp add: nextR_def)

definition
  filterR :: "Nat \<rightarrow> R \<rightarrow> R" where
  "filterR \<equiv> (\<Lambda> v r. R\<cdot>(resultR\<cdot>r)\<cdot>(SetInsert\<cdot>v\<cdot>(exceptR\<cdot>r)))"

definition
  c2a :: "Nat llist \<rightarrow> R" where
  "c2a \<equiv> \<Lambda> xs. R\<cdot>xs\<cdot>SetEmpty"

definition
  a2c :: "R \<rightarrow> Nat llist" where
  "a2c \<equiv> \<Lambda> r. lfilter\<cdot>(\<Lambda> v. neg\<cdot>(SetMem\<cdot>v\<cdot>(exceptR\<cdot>r)))\<cdot>(resultR\<cdot>r)"

lemma a2c_strict[simp]: "a2c\<cdot>\<bottom> = \<bottom>" unfolding a2c_def by simp

lemma a2c_c2a_id: "a2c oo c2a = ID"
  by (rule cfun_eqI, simp add: a2c_def c2a_def lfilter_const_true)

definition
  wrap :: "(R \<rightarrow> Nat llist) \<rightarrow> Nat llist \<rightarrow> Nat llist" where
  "wrap \<equiv> \<Lambda> f xs. f\<cdot>(c2a\<cdot>xs)"

definition
  unwrap :: "(Nat llist \<rightarrow> Nat llist) \<rightarrow> R \<rightarrow> Nat llist" where
  "unwrap \<equiv> \<Lambda> f r. f\<cdot>(a2c\<cdot>r)"

lemma unwrap_strict[simp]: "unwrap\<cdot>\<bottom> = \<bottom>"
  unfolding unwrap_def by (rule cfun_eqI, simp)

lemma wrap_unwrap_id: "wrap oo unwrap = ID"
  using cfun_fun_cong[OF a2c_c2a_id]
  by - ((rule cfun_eqI)+, simp add: wrap_def unwrap_def)

text {* Equivalences needed for later. *}

lemma TR_deMorgan: "neg\<cdot>(x orelse y) = (neg\<cdot>x andalso neg\<cdot>y)"
  by (rule trE[where p=x], simp_all)

lemma case_maybe_case:
  "(case (case L of lnil \<Rightarrow> Nothing | x :@ xs \<Rightarrow> Just\<cdot>(h\<cdot>x\<cdot>xs)) of
     Nothing \<Rightarrow> f | Just\<cdot>(a, b) \<Rightarrow> g\<cdot>a\<cdot>b)
   =
   (case L of lnil \<Rightarrow> f | x :@ xs \<Rightarrow> g\<cdot>(fst (h\<cdot>x\<cdot>xs))\<cdot>(snd (h\<cdot>x\<cdot>xs)))"
  apply (cases L, simp_all)
  apply (case_tac "h\<cdot>a\<cdot>llist")
  apply simp
  done

lemma case_a2c_case_caseR:
    "(case a2c\<cdot>w of lnil \<Rightarrow> f | x :@ xs \<Rightarrow> g\<cdot>x\<cdot>xs)
   = (case nextR\<cdot>w of Nothing \<Rightarrow> f | Just\<cdot>(x, r) \<Rightarrow> g\<cdot>x\<cdot>(a2c\<cdot>r))" (is "?lhs = ?rhs")
proof -
  have "?rhs = (case (case ldropWhile\<cdot>(\<Lambda> x. SetMem\<cdot>x\<cdot>(exceptR\<cdot>w))\<cdot>(resultR\<cdot>w) of
                     lnil \<Rightarrow> Nothing
                   | x :@ xs \<Rightarrow> Just\<cdot>(x, R\<cdot>xs\<cdot>(exceptR\<cdot>w))) of Nothing \<Rightarrow> f | Just\<cdot>(x, r) \<Rightarrow> g\<cdot>x\<cdot>(a2c\<cdot>r))"
    by (simp add: nextR_def)
  also have "\<dots> = (case ldropWhile\<cdot>(\<Lambda> x. SetMem\<cdot>x\<cdot>(exceptR\<cdot>w))\<cdot>(resultR\<cdot>w) of
                     lnil \<Rightarrow> f | x :@ xs \<Rightarrow> g\<cdot>x\<cdot>(a2c\<cdot>(R\<cdot>xs\<cdot>(exceptR\<cdot>w))))"
    using case_maybe_case[where L="ldropWhile\<cdot>(\<Lambda> x. SetMem\<cdot>x\<cdot>(exceptR\<cdot>w))\<cdot>(resultR\<cdot>w)"
                            and f=f and g="\<Lambda> x r. g\<cdot>x\<cdot>(a2c\<cdot>r)" and h="\<Lambda> x xs. (x, R\<cdot>xs\<cdot>(exceptR\<cdot>w))"]
    by simp
  also have "\<dots> = ?lhs"
    apply (simp add: a2c_def)
    apply (cases "resultR\<cdot>w")
      apply simp_all
    apply (rule_tac p="SetMem\<cdot>a\<cdot>(exceptR\<cdot>w)" in trE)
      apply simp_all
    apply (induct_tac llist)
       apply simp_all
    apply (rule_tac p="SetMem\<cdot>aa\<cdot>(exceptR\<cdot>w)" in trE)
      apply simp_all
    done
  finally show "?lhs = ?rhs" by simp
qed

lemma filter_filterR: "lfilter\<cdot>(neg oo (\<Lambda> y. x =\<^sub>B y))\<cdot>(a2c\<cdot>r) = a2c\<cdot>(filterR\<cdot>x\<cdot>r)"
  using filter_filter[where p="Tr.neg oo (\<Lambda> y. x =\<^sub>B y)" and q="\<Lambda> v. Tr.neg\<cdot>(SetMem\<cdot>v\<cdot>(exceptR\<cdot>r))"]
  unfolding a2c_def filterR_def
  by (cases r, simp_all add: SetMem_SetInsert TR_deMorgan)

text{* Apply worker/wrapper. Unlike Gill/Hutton, we manipulate the body of
the worker into the right form then apply the lemma. *}

definition
  nub_body' :: "(R \<rightarrow> Nat llist) \<rightarrow> R \<rightarrow> Nat llist" where
  "nub_body' \<equiv> \<Lambda> f r. case a2c\<cdot>r of lnil \<Rightarrow> lnil
                                   | x :@ xs \<Rightarrow> x :@ f\<cdot>(c2a\<cdot>(lfilter\<cdot>(neg oo (\<Lambda> y. x =\<^sub>B y))\<cdot>xs))"

lemma nub_body_nub_body'_eq: "unwrap oo nub_body oo wrap = nub_body'"
  unfolding nub_body_def nub_body'_def unwrap_def wrap_def a2c_def c2a_def
  by ((rule cfun_eqI)+
     , case_tac "lfilter\<cdot>(\<Lambda> v. Tr.neg\<cdot>(SetMem\<cdot>v\<cdot>(exceptR\<cdot>xa)))\<cdot>(resultR\<cdot>xa)"
     , simp_all add: fix_const)

definition
  nub_body'' :: "(R \<rightarrow> Nat llist) \<rightarrow> R \<rightarrow> Nat llist" where
  "nub_body'' \<equiv> \<Lambda> f r. case nextR\<cdot>r of Nothing \<Rightarrow> lnil
                                      | Just\<cdot>(x, xs) \<Rightarrow> x :@ f\<cdot>(c2a\<cdot>(lfilter\<cdot>(neg oo (\<Lambda> y. x =\<^sub>B y))\<cdot>(a2c\<cdot>xs)))"

lemma nub_body'_nub_body''_eq: "nub_body' = nub_body''"
proof(rule cfun_eqI)+
  fix f r show "nub_body'\<cdot>f\<cdot>r = nub_body''\<cdot>f\<cdot>r"
    unfolding nub_body'_def nub_body''_def
    using case_a2c_case_caseR[where f="lnil" and g="\<Lambda> x xs. x :@ f\<cdot>(c2a\<cdot>(lfilter\<cdot>(Tr.neg oo (\<Lambda> y. x =\<^sub>B y))\<cdot>xs))" and w="r"]
    by simp
qed

definition
  nub_body''' :: "(R \<rightarrow> Nat llist) \<rightarrow> R \<rightarrow> Nat llist" where
  "nub_body''' \<equiv> (\<Lambda> f r. case nextR\<cdot>r of Nothing \<Rightarrow> lnil
                                      | Just\<cdot>(x, xs) \<Rightarrow> x :@ f\<cdot>(filterR\<cdot>x\<cdot>xs))"

lemma nub_body''_nub_body'''_eq: "nub_body'' = nub_body''' oo (unwrap oo wrap)"
  unfolding nub_body''_def nub_body'''_def wrap_def unwrap_def
  by ((rule cfun_eqI)+, simp add: filter_filterR)

text{* Finally glue it all together. *}

lemma nub_wrap_nub_body''': "nub = wrap\<cdot>(fix\<cdot>nub_body''')"
  using worker_wrapper_fusion_new[OF wrap_unwrap_id unwrap_strict, where body=nub_body]
        nub_nub_body_eq
        nub_body_nub_body'_eq
        nub_body'_nub_body''_eq
        nub_body''_nub_body'''_eq
  by simp

end


(* Title:      Kleene Algebra
   Author:     Alasdair Armstrong, Georg Struth, Tjark Weber
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
               Tjark Weber <tjark.weber at it.uu.se>
*)

header {* Infinite Matrices *}

theory Inf_Matrix
imports Finite_Suprema
begin

text {* Matrices are functions from two index sets into some suitable
algebra. We consider arbitrary index sets, not necessarily the
positive natural numbers up to some bounds; our coefficient algebra is
a dioid. Our only restriction is that summation in the product of
matrices is over a finite index set. This follows essentially Droste
and Kuich's introductory article in the Handbook of Weighted Automata~\cite{weightedautomata09}.

Under these assumptions we show that dioids are closed under matrix
formation. Our proof are similar to those for formal power series, but
simpler. *}

class finite =
  assumes finiteuniv: "finite UNIV"

type_synonym ('a, 'b, 'c) matrix = "'a \<Rightarrow> 'b \<Rightarrow> 'c"

definition mat_one :: "('a, 'a, 'c::dioid_one_zero) matrix" ("\<epsilon>") where
  "\<epsilon> i j \<equiv> (if (i = j) then 1 else 0)"

definition mat_zero :: "('a, 'b, 'c::dioid_one_zero) matrix" ("\<delta>") where
  "\<delta> \<equiv> \<lambda>j i. 0"

definition mat_add :: "('a, 'b, 'c::dioid_one_zero) matrix \<Rightarrow> ('a, 'b, 'c) matrix \<Rightarrow> ('a, 'b, 'c) matrix" (infixl "\<oplus>" 70) where
  "(f \<oplus> g)  \<equiv> \<lambda>i j. (f i j) + (g i j)"

lemma mat_add_assoc: "(f \<oplus> g) \<oplus> h =  f \<oplus>  (g \<oplus> h)"
  by (auto simp add: mat_add_def)

lemma mat_add_idem[simp]: "f \<oplus> f = f"
  by (auto simp add: mat_add_def)

lemma mat_zerol[simp]: "f \<oplus> \<delta> = f"
  by (auto simp add: mat_add_def mat_zero_def)

lemma mat_zeror[simp]: "\<delta> \<oplus> f = f"
  by (auto simp add: mat_add_def mat_zero_def)

definition mat_mult :: "('a, 'k::finite, 'c::dioid_one_zero) matrix \<Rightarrow> ('k, 'b, 'c) matrix \<Rightarrow> ('a, 'b, 'c) matrix" (infixl "\<otimes>" 60) where
  "(f \<otimes> g) i j  \<equiv> \<Sum> {(f i k) \<cdot> (g k j) | k. k \<in> UNIV}"

lemma mat_annil[simp]: "\<delta> \<otimes> f = \<delta>"
  by (rule ext, auto simp add: mat_mult_def mat_zero_def)

lemma mat_annir[simp]: "f \<otimes> \<delta>  = \<delta>"
  by (rule ext, auto simp add: mat_mult_def mat_zero_def)

lemma mat_distl: "f \<otimes> (g \<oplus> h) = (f \<otimes> g) \<oplus> (f \<otimes> h)"
proof -
  {
    fix i j
    have "(f \<otimes> (g \<oplus> h)) i j  = \<Sum>{f i k \<cdot> (g k j + h k j) |k. k \<in> UNIV}"
      by (simp only: mat_mult_def mat_add_def)
    also have "... = \<Sum>{f i k \<cdot> g k j + f i k \<cdot> h k j |k. k \<in> UNIV}"
      by (simp only: distrib_left)
    also have "... = \<Sum>{f i k \<cdot> g k j |k. k \<in> UNIV} + \<Sum>{f i k \<cdot> h k j |k. k \<in> UNIV}"
      by (simp only: fset_to_im setsum_fun_sum finiteuniv)
    finally have "(f \<otimes> (g \<oplus> h)) i j  = ((f \<otimes> g) \<oplus> (f \<otimes> h)) i j"
      by (simp only: mat_mult_def mat_add_def)
  }
  thus ?thesis
    by auto
qed

lemma mat_distr: "(f \<oplus> g) \<otimes> h = (f \<otimes> h) \<oplus> (g \<otimes> h)"
proof -
  {
    fix i j
    have "((f \<oplus> g) \<otimes> h) i j  = \<Sum>{(f i k + g i k) \<cdot> h k j |k. k \<in> UNIV}"
      by (simp only: mat_mult_def mat_add_def)
    also have "... = \<Sum>{f i k \<cdot> h k j + g i k \<cdot> h k j |k. k \<in> UNIV}"
      by (simp only: distrib_right)
    also have "... = \<Sum>{f i k \<cdot> h k j |k. k \<in> UNIV} + \<Sum>{g i k \<cdot> h k j |k. k \<in> UNIV}"
      by (simp only: fset_to_im setsum_fun_sum finiteuniv)
    finally have "((f \<oplus> g) \<otimes> h) i j  = ((f \<otimes> h) \<oplus> (g \<otimes> h)) i j"
      by (simp only: mat_mult_def mat_add_def)
  }
  thus ?thesis
    by auto
qed

lemma logic_aux1: "(\<exists>k. (i = k \<longrightarrow> x = f i j) \<and> (i \<noteq> k \<longrightarrow> x = 0)) \<longleftrightarrow> (\<exists>k. i = k \<and> x = f i j) \<or> (\<exists>k. i \<noteq> k \<and> x = 0)"
  by blast

lemma logic_aux2: "(\<exists>k. (k = j \<longrightarrow> x = f i j) \<and> (k \<noteq> j \<longrightarrow> x = 0)) \<longleftrightarrow> (\<exists>k. k = j \<and> x = f i j) \<or> (\<exists>k. k \<noteq> j \<and> x = 0)"
  by blast

lemma mat_onel[simp]: "\<epsilon> \<otimes> f = f"
proof -
  {
    fix i j
    have "(\<epsilon> \<otimes> f) i j = \<Sum>{x. (\<exists>k. (i = k \<longrightarrow> x = f i j) \<and> (i \<noteq> k \<longrightarrow> x = 0))}"
      by (auto simp add: mat_mult_def mat_one_def)
    also have "... = \<Sum>({x. \<exists>k. (i = k \<and> x = f i j)} \<union> {x. \<exists>k. (i \<noteq> k \<and> x = 0)})"
      by (simp only: Collect_disj_eq logic_aux1)
    also have "... = \<Sum>{x. \<exists>k. (i = k \<and> x = f i j)} + \<Sum>{x. \<exists>k. (i \<noteq> k \<and> x = 0)}"
      by (rule setsum_union, auto)
    finally have "(\<epsilon> \<otimes> f) i j = f i j"
      by (auto simp add: setsum.neutral)
  }
  thus ?thesis
    by auto
qed

lemma mat_oner[simp]: "f \<otimes> \<epsilon> = f"
proof -
  {
    fix i j
    have "(f \<otimes> \<epsilon>) i j = \<Sum>{x. (\<exists>k. (k = j \<longrightarrow> x = f i j) \<and> (k \<noteq> j \<longrightarrow> x = 0))}"
      by (auto simp add: mat_mult_def mat_one_def)
    also have "... = \<Sum>({x. \<exists>k. (k = j \<and> x = f i j)} \<union> {x. \<exists>k. (k \<noteq> j \<and> x = 0)})"
      by (simp only: Collect_disj_eq logic_aux2)
    also have "... = \<Sum>{x. \<exists>k. (k = j \<and> x = f i j)} + \<Sum>{x. \<exists>k. (k \<noteq> j \<and> x = 0)}"
      by (rule setsum_union, auto)
    finally have "(f \<otimes> \<epsilon>) i j = f i j"
      by (auto simp add: setsum.neutral)
  }
  thus ?thesis
    by auto
qed

lemma mat_rearrange:
  fixes F :: "'a \<Rightarrow> 'k1 \<Rightarrow> 'k2 \<Rightarrow> 'b \<Rightarrow> 'c::dioid_one_zero"
  assumes fUNk1: "finite (UNIV::'k1 set)"
  assumes fUNk2: "finite (UNIV::'k2 set)"
  shows "\<Sum>{\<Sum>{F i k1 k2 j |k2. k2 \<in> (UNIV::'k2 set)} |k1. k1 \<in> (UNIV::'k1 set)} = \<Sum>{\<Sum>{F i k1 k2 j |k1. k1 \<in> UNIV} |k2. k2 \<in> UNIV}"
proof -
  {
    fix z :: 'c
    let ?lhs = "\<Sum>{\<Sum>{F i k1 k2 j |k2. k2 \<in> UNIV} |k1. k1 \<in> UNIV}"
    let ?rhs = "\<Sum>{\<Sum>{F i k1 k2 j |k1. k1 \<in> UNIV} |k2. k2 \<in> UNIV}"
    have "?lhs \<le> z \<longleftrightarrow> (\<forall>k1 k2. F i k1 k2 j \<le> z)"
      by (simp only: fset_to_im setsum_fun_image_sup fUNk1 fUNk2, auto)
    hence "?lhs \<le> z \<longleftrightarrow> ?rhs \<le> z"
      by (simp only: fset_to_im setsum_fun_image_sup fUNk1 fUNk2, auto)
  }
  thus ?thesis
    by (simp add: eq_iff)
qed

lemma mat_mult_assoc: "f \<otimes> (g \<otimes> h) = (f \<otimes> g) \<otimes> h"
proof -
  {
    fix i j
    have "(f \<otimes> (g \<otimes> h)) i j = \<Sum>{f i k1 \<cdot> \<Sum>{g k1 k2 \<cdot> h k2 j |k2. k2 \<in> UNIV} |k1. k1 \<in> UNIV}"
      by (simp only: mat_mult_def)
    also have "... = \<Sum>{\<Sum>{f i k1 \<cdot> g k1 k2 \<cdot> h k2 j |k2. k2 \<in> UNIV} |k1. k1 \<in> UNIV}"
      by (simp only: fset_to_im setsum_fun_distl finiteuniv mult.assoc)
    also have "... = \<Sum>{\<Sum>{(f i k1 \<cdot> g k1 k2) \<cdot> h k2 j|k1. k1 \<in> UNIV} |k2. k2 \<in> UNIV}"
      by (rule mat_rearrange, auto simp add: finiteuniv)
    also have "... = \<Sum>{\<Sum>{f i k1 \<cdot> g k1 k2 |k1. k1 \<in> UNIV} \<cdot> h k2 j |k2. k2 \<in> UNIV}"
      by (simp only: fset_to_im setsum_fun_distr finiteuniv)
    finally have "(f \<otimes> (g \<otimes> h)) i j  = ((f \<otimes> g) \<otimes> h) i j "
      by (simp only: mat_mult_def)
  }
  thus ?thesis
    by auto
qed

definition mat_less_eq :: "('a, 'b, 'c::dioid_one_zero) matrix \<Rightarrow> ('a, 'b, 'c) matrix \<Rightarrow> bool" where
  "mat_less_eq f g   = (f \<oplus> g  = g)"

definition mat_less :: "('a, 'b, 'c::dioid_one_zero) matrix \<Rightarrow> ('a, 'b, 'c) matrix \<Rightarrow> bool" where
  "mat_less f g  = (mat_less_eq f g \<and> f \<noteq> g)"

interpretation matrix_dioid: dioid_one_zero  mat_add mat_mult mat_one mat_zero mat_less_eq mat_less
  by (unfold_locales) (metis mat_add_assoc mat_add_comm mat_mult_assoc[symmetric] mat_distr mat_onel mat_oner mat_zeror mat_annil mat_annir mat_less_eq_def mat_less_def mat_add_idem mat_distl)+

text {* As in the case of formal power series we currently do not
implement the Kleene star of matrices, since this is complicated. *}

end


subsection \<open>Multisets\<close>

text \<open>Some preliminary results about multisets.\<close>

theory Expander_Graphs_Multiset_Extras
  imports Frequency_Moments.Frequency_Moments_Preliminary_Results Extra_Congruence_Method
begin

unbundle intro_cong_syntax

lemma sum_mset_conv:
  fixes f :: "'a \<Rightarrow> 'b::{semiring_1}"
  shows "sum_mset (image_mset f A) = sum (\<lambda>x. of_nat (count A x) * f x) (set_mset A)"
proof (induction A rule: disj_induct_mset)
  case 1
  then show ?case by simp
next
  case (2 n M x)
  moreover have "count M x = 0" using 2 by (simp add: count_eq_zero_iff)
  moreover have "\<And>y. y \<in> set_mset M \<Longrightarrow> y \<noteq> x" using 2 by blast
  ultimately show ?case by (simp add:algebra_simps)
qed

lemma sum_mset_conv_2:
  fixes f :: "'a \<Rightarrow> 'b::{semiring_1}"
  assumes "set_mset A \<subseteq> B" "finite B"
  shows "sum_mset (image_mset f A) = sum (\<lambda>x. of_nat (count A x) * f x) B" (is "?L = ?R")
proof -
  have "?L = sum (\<lambda>x. of_nat (count A x) * f x) (set_mset A)"
    unfolding sum_mset_conv by simp
  also have "... = ?R"
    by (intro sum.mono_neutral_left assms) (simp_all add: iffD2[OF count_eq_zero_iff])
  finally show ?thesis by simp
qed

lemma count_mset_exp: "count A x = size (filter_mset (\<lambda>y. y = x) A)"
  by (induction A, simp, simp)

lemma mset_repl: "mset (replicate k x) = replicate_mset k x"
  by (induction k, auto)

lemma count_image_mset_inj:
  assumes "inj f"
  shows "count (image_mset f A) (f x) = count A x"
proof (cases "x \<in> set_mset A")
  case True
  hence "f -` {f x} \<inter> set_mset A = {x}"
    using assms by (auto simp add:vimage_def inj_def)
  then show ?thesis by (simp add:count_image_mset)
next
  case False
  hence "f -` {f x} \<inter> set_mset A = {}"
    using assms by (auto simp add:vimage_def inj_def)
  thus ?thesis  using False by (simp add:count_image_mset count_eq_zero_iff)
qed

lemma count_image_mset_0_triv:
  assumes "x \<notin> range f"
  shows "count (image_mset f A) x = 0"
proof -
  have "x \<notin> set_mset (image_mset f A)"
    using assms by auto
  thus ?thesis
    by (meson count_inI)
qed

lemma filter_mset_ex_predicates:
  assumes "\<And>x. \<not> P x \<or> \<not> Q x"
  shows "filter_mset P M + filter_mset Q M = filter_mset (\<lambda>x. P x \<or> Q x) M"
  using assms by (induction M, auto)

lemma sum_count_2:
  assumes "finite F"
  shows "sum (count M) F = size (filter_mset (\<lambda>x. x \<in> F) M)"
  using assms
proof (induction F rule:finite_induct)
  case empty
  then show ?case by simp
next
  case (insert x F)
  have "sum (count M) (insert x F) = size ({#y \<in># M. y = x#} + {#x \<in># M. x \<in> F#})"
    using insert(1,2,3) by (simp add:count_mset_exp)
  also have "... = size ({#y \<in># M. y = x \<or> y \<in> F#})"
    using insert(2)
    by (intro arg_cong[where f="size"] filter_mset_ex_predicates) simp
  also have "... = size (filter_mset (\<lambda>y. y \<in> insert x F) M)"
    by simp
  finally show ?case by simp
qed

definition concat_mset :: "('a multiset) multiset \<Rightarrow> 'a multiset"
  where "concat_mset xss = fold_mset (\<lambda>xs ys. xs + ys) {#} xss"

lemma image_concat_mset:
  "image_mset f (concat_mset xss) = concat_mset (image_mset (image_mset f) xss)"
  unfolding concat_mset_def by (induction xss, auto)

lemma concat_add_mset:
  "concat_mset (image_mset (\<lambda>x. f x + g x) xs) = concat_mset (image_mset f xs) + concat_mset (image_mset g xs)"
  unfolding concat_mset_def by (induction xs) auto

lemma concat_add_mset_2:
  "concat_mset (xs + ys) = concat_mset xs + concat_mset ys"
  unfolding concat_mset_def by (induction xs, auto)

lemma size_concat_mset:
  "size (concat_mset xss) = sum_mset (image_mset size xss)"
  unfolding concat_mset_def by (induction xss, auto)

lemma filter_concat_mset:
  "filter_mset P (concat_mset xss) = concat_mset (image_mset (filter_mset P) xss)"
  unfolding concat_mset_def by (induction xss, auto)

lemma count_concat_mset:
  "count (concat_mset xss) xs = sum_mset (image_mset (\<lambda>x. count x xs) xss)"
  unfolding concat_mset_def by (induction xss, auto)

lemma set_mset_concat_mset:
  "set_mset (concat_mset xss) = \<Union> (set_mset ` (set_mset xss))"
  unfolding concat_mset_def by (induction xss, auto)

lemma concat_mset_empty: "concat_mset {#} = {#}"
  unfolding concat_mset_def by simp

lemma concat_mset_single: "concat_mset {#x#} = x"
  unfolding concat_mset_def by simp

lemma concat_disjoint_union_mset:
  assumes "finite I"
  assumes "\<And>i. i \<in> I \<Longrightarrow> finite (A i)"
  assumes "\<And>i j. i \<in> I \<Longrightarrow> j \<in> I \<Longrightarrow> i \<noteq> j \<Longrightarrow> A i \<inter> A j = {}"
  shows  "mset_set (\<Union> (A ` I)) = concat_mset (image_mset (mset_set \<circ> A) (mset_set I))"
  using assms
proof (induction I rule:finite_induct)
  case empty
  then show ?case by (simp add:concat_mset_empty)
next
  case (insert x F)
  have "mset_set (\<Union> (A ` insert x F)) = mset_set (A x \<union> (\<Union> (A ` F)))"
    by simp
  also have "... = mset_set (A x) + mset_set (\<Union> (A ` F))"
    using insert by (intro mset_set_Union) auto
  also have "... = mset_set (A x) + concat_mset (image_mset (mset_set \<circ> A) (mset_set F))"
    using insert by (intro arg_cong2[where f="(+)"] insert(3)) auto
  also have "... = concat_mset (image_mset (mset_set \<circ> A) ({#x#} + mset_set F))"
    by (simp add:concat_mset_def)
  also have "... = concat_mset (image_mset (mset_set \<circ> A) (mset_set (insert x F)))"
    using insert by (intro_cong "[\<sigma>\<^sub>1 concat_mset, \<sigma>\<^sub>2 image_mset]") auto
  finally show ?case by blast
qed

lemma size_filter_mset_conv:
  "size (filter_mset f A) = sum_mset (image_mset (\<lambda>x. of_bool (f x) :: nat) A)"
  by (induction A, auto)

lemma filter_mset_const: "filter_mset (\<lambda>_. c) xs = (if c then xs else {#})"
  by simp

lemma repeat_image_concat_mset:
  "repeat_mset n (image_mset f A) = concat_mset (image_mset (\<lambda>x. replicate_mset n (f x)) A)"
  unfolding concat_mset_def by (induction A, auto)

lemma mset_prod_eq:
  assumes "finite A" "finite B"
  shows
    "mset_set (A \<times> B) = concat_mset {# {# (x,y). y \<in># mset_set B #} .x \<in># mset_set A #}"
  using assms(1)
proof (induction rule:finite_induct)
  case empty
  then show ?case unfolding concat_mset_def by simp
next
  case (insert x F)
  have "mset_set (insert x F \<times> B) = mset_set (F \<times> B \<union> (\<lambda>y. (x,y)) ` B)"
    by (intro arg_cong[where f="mset_set"]) auto
  also have "... = mset_set (F \<times> B) + mset_set ((\<lambda>y. (x,y)) ` B)"
    using insert(1,2) assms(2) by (intro mset_set_Union finite_cartesian_product) auto
  also have "... = mset_set (F \<times> B) + {# (x,y). y \<in># mset_set B #}"
    by (intro arg_cong2[where f="(+)"] image_mset_mset_set[symmetric] inj_onI) auto
  also have "... = concat_mset {#image_mset (Pair x) (mset_set B). x \<in># {#x#} + (mset_set F)#}"
    unfolding insert image_mset_union concat_add_mset_2 by (simp add:concat_mset_single)
  also have "... = concat_mset {#image_mset (Pair x) (mset_set B). x \<in># mset_set (insert x F)#}"
    using insert(1,2) by (intro_cong "[\<sigma>\<^sub>1 concat_mset, \<sigma>\<^sub>2 image_mset]") auto
  finally show ?case by simp
qed

lemma sum_mset_repeat:
  fixes f :: "'a \<Rightarrow> 'b :: {comm_monoid_add,semiring_1}"
  shows "sum_mset (image_mset f (repeat_mset n A)) = of_nat n * sum_mset (image_mset f A)"
  by (induction n, auto simp add:sum_mset.distrib algebra_simps)

unbundle no_intro_cong_syntax

end