(*  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 Sudoku
imports Main

begin

definition valid :: "[nat, nat, nat, nat, nat, nat, nat, nat, nat] \<Rightarrow> bool" where
"valid e1 e2 e3 e4 e5 e6 e7 e8 e9 ==
(e1 \<noteq> e2) \<and> (e1 \<noteq> e3) \<and> (e1 \<noteq> e4) \<and> (e1 \<noteq> e5) \<and> (e1 \<noteq> e6) \<and> (e1 \<noteq> e7) \<and> (e1 \<noteq> e8) \<and> (e1 \<noteq> e9) \<and>
(e2 \<noteq> e3) \<and> (e2 \<noteq> e4) \<and> (e2 \<noteq> e5) \<and> (e2 \<noteq> e6) \<and> (e2 \<noteq> e7) \<and> (e2 \<noteq> e8) \<and> (e2 \<noteq> e9) \<and>
(e3 \<noteq> e4) \<and> (e3 \<noteq> e5) \<and> (e3 \<noteq> e6) \<and> (e3 \<noteq> e7) \<and> (e3 \<noteq> e8) \<and> (e3 \<noteq> e9) \<and>
(e4 \<noteq> e5) \<and> (e4 \<noteq> e6) \<and> (e4 \<noteq> e7) \<and> (e4 \<noteq> e8) \<and> (e4 \<noteq> e9) \<and>
(e5 \<noteq> e6) \<and> (e5 \<noteq> e7) \<and> (e5 \<noteq> e8) \<and> (e5 \<noteq> e9) \<and>
(e6 \<noteq> e7) \<and> (e6 \<noteq> e8) \<and> (e6 \<noteq> e9) \<and>
(e7 \<noteq> e8) \<and> (e7 \<noteq> e9) \<and>
(e8 \<noteq> e9) \<and>
(e1 < 10) \<and> (e2 < 10) \<and> (e3 < 10) \<and> (e4 < 10) \<and> (e5 < 10)
\<and> (e6 < 10) \<and> (e7 < 10) \<and> (e8 < 10) \<and> (e9 < 10)  \<and>
(e1 \<ge> 1) \<and> (e2  \<ge> 1) \<and> (e3  \<ge> 1) \<and> (e4  \<ge> 1) \<and> (e5  \<ge> 1)
\<and> (e6 \<ge> 1) \<and> (e7 \<ge> 1) \<and> (e8  \<ge> 1) \<and> (e9  \<ge> 1)"

definition sudoku :: "[nat, nat, nat, nat, nat, nat, nat, nat, nat,
                       nat, nat, nat, nat, nat, nat, nat, nat, nat,
                       nat, nat, nat, nat, nat, nat, nat, nat, nat,
                       nat, nat, nat, nat, nat, nat, nat, nat, nat,
                       nat, nat, nat, nat, nat, nat, nat, nat, nat,
                       nat, nat, nat, nat, nat, nat, nat, nat, nat,
                       nat, nat, nat, nat, nat, nat, nat, nat, nat,
                       nat, nat, nat, nat, nat, nat, nat, nat, nat,
                       nat, nat, nat, nat, nat, nat, nat, nat, nat] \<Rightarrow> bool" where

  "sudoku e11 e12 e13 e14 e15 e16 e17 e18 e19
          e21 e22 e23 e24 e25 e26 e27 e28 e29
          e31 e32 e33 e34 e35 e36 e37 e38 e39
          e41 e42 e43 e44 e45 e46 e47 e48 e49
          e51 e52 e53 e54 e55 e56 e57 e58 e59
          e61 e62 e63 e64 e65 e66 e67 e68 e69
          e71 e72 e73 e74 e75 e76 e77 e78 e79
          e81 e82 e83 e84 e85 e86 e87 e88 e89
          e91 e92 e93 e94 e95 e96 e97 e98 e99  ==

          valid e11 e12 e13 e14 e15 e16 e17 e18 e19
   \<and> valid e21 e22 e23 e24 e25 e26 e27 e28 e29
   \<and> valid e31 e32 e33 e34 e35 e36 e37 e38 e39
   \<and> valid e41 e42 e43 e44 e45 e46 e47 e48 e49
   \<and> valid e51 e52 e53 e54 e55 e56 e57 e58 e59
   \<and> valid e61 e62 e63 e64 e65 e66 e67 e68 e69
   \<and> valid e71 e72 e73 e74 e75 e76 e77 e78 e79
   \<and> valid e81 e82 e83 e84 e85 e86 e87 e88 e89
   \<and> valid e91 e92 e93 e94 e95 e96 e97 e98 e99

   \<and> valid e11 e21 e31 e41 e51 e61 e71 e81 e91
   \<and> valid e12 e22 e32 e42 e52 e62 e72 e82 e92
   \<and> valid e13 e23 e33 e43 e53 e63 e73 e83 e93
   \<and> valid e14 e24 e34 e44 e54 e64 e74 e84 e94
   \<and> valid e15 e25 e35 e45 e55 e65 e75 e85 e95
   \<and> valid e16 e26 e36 e46 e56 e66 e76 e86 e96
   \<and> valid e17 e27 e37 e47 e57 e67 e77 e87 e97
   \<and> valid e18 e28 e38 e48 e58 e68 e78 e88 e98
   \<and> valid e19 e29 e39 e49 e59 e69 e79 e89 e99

   \<and> valid e11 e12 e13 e21 e22 e23 e31 e32 e33
   \<and> valid e41 e42 e43 e51 e52 e53 e61 e62 e63
   \<and> valid e71 e72 e73 e81 e82 e83 e91 e92 e93
   \<and> valid e14 e15 e16 e24 e25 e26 e34 e35 e36
   \<and> valid e44 e45 e46 e54 e55 e56 e64 e65 e66
   \<and> valid e74 e75 e76 e84 e85 e86 e94 e95 e96
   \<and> valid e17 e18 e19 e27 e28 e29 e37 e38 e39
   \<and> valid e47 e48 e49 e57 e58 e59 e67 e68 e69
   \<and> valid e77 e78 e79 e87 e88 e89 e97 e98 e99"
(*
(*Пустое судоку*)
lemma test10: "~ sudoku
    e11 e12 e13 e14 e15 e16 e17 e18 e19
    e21 e22 e23 e24 e25 e26 e27 e28 e29
    e31 e32 e33 e34 e35 e36 e37 e38 e39
    e41 e42 e43 e44 e45 e46 e47 e48 e49
    e51 e52 e53 e54 e55 e56 e57 e58 e59
    e61 e62 e63 e64 e65 e66 e67 e68 e69
    e71 e72 e73 e74 e75 e76 e77 e78 e79
    e81 e82 e83 e84 e85 e86 e87 e88 e89
    e91 e92 e93 e94 e95 e96 e97 e98 e99 "
nitpick[verbose] (*7,3 секунды*)

(* Обычно судоку подразделяют на 3 уровня сложности:
  легкий - 30-35 "подсказок"
  средний - 25-30 "подсказок"
  трудный - 20-25 "подсказок"
  Рассмотрим несколько судоку из этих типов, а также несколько
  пустых судоку, судоку с одной цифрой и судоку без одной цифры *)

(*легкие судоку*)

lemma test20: "~ sudoku
    e11  4   6   5   1  e16  3  e18  9
    e21 e22 e23  7  e25 e26 e27 e28  2
     1  e32 e33  3   8  e36 e37 e38 e39
     3  e42 e43  6   7  e46 e47 e48 e49
    e51  5  e53 e54 e55 e56 e57 e58 e59
     6   7   4  e64 e65 e66 e67  9  e69
     5  e72 e73  9   3  e76  4  e78  7
    e81  6   7   2   5   1  e87  3  e89
     8  e92 e93  4  e95 e96 e97  5  e99 "
nitpick[verbose] (*11,2 секунды*)

lemma test21: "~ sudoku
    e11 e12 e13 e14 e15  4   9  e18 e19
     1  e22 e23 e24 e25 e26  6   4  e29
    e31 e32  4   6   5  e36  1  e38 e39
    e41  2   1  e44 e45  9  e47  8  e49
    e51 e52 e53 e54 e55  1  e57 e58 e59
    e61 e62  9  e64  7  e66  4  e68  6
    e71 e72  6   3  e75  5  e77  9  e79
     9  e82  5  e84 e85 e86 e87  6  e89
    e91  1   2  e94  9   6  e97 e98 e99 "
nitpick[verbose] (*11,1 секунды*)

lemma test22: "~ sudoku
    e11 e12  4   7  e15  9  e17 e18 e19
    e21 e22  5  e24 e25  2   1  e28 e29
    e31 e32  9  e34 e35  1  e37 e38 e39
     2   8   3   4   1  e46  9   6   5
    e51 e52 e53  2   3  e56  8  e58 e59
    e61  5  e63 e64 e65 e66  2  e68 e69
    e71 e72 e73 e74 e75 e76 e77 e78 e79
    e81 e82  8  e84 e85  3   5   2   6
     5  e92 e93  1   8   6  e97  9  e99 "
nitpick[verbose] (*11,5 секунды*)
(*Средние судоку*)
lemma test30: "~ sudoku
    e11  2  e13 e14 e15 e16  8   5  e19
     7  e22 e23 e24  5   6   4  e28  3
    e31 e32 e33  8  e35 e36 e37 e38  9
     6   7   8  e44 e45  1   9  e48 e49
    e51  3  e53  7  e55 e56 e57  6  e59
    e61  4   5   9  e65 e66 e67 e68 e69
    e71 e72  7   6   8   5  e77  1  e79
    e81 e82 e83  2  e85  4  e87  8  e89
    e91  6  e93  3  e95 e96  2   9  e99 "
nitpick[verbose] (*11,2 секунды*)

lemma test31: "~ sudoku
    e11 e12 e13 e14 e15 e16 e17  1  e19
    e21 e22 e23 e24  5  e26 e27  4   9
     8   2   9   4  e35  1   5   7   6
    e41 e42 e43  7  e45 e46  9   5  e49
    e51  6  e53  9   1  e56  2   3  e59
    e61 e62  1   3   2  e66  6  e68  7
     5  e72  6  e74 e75 e76 e77 e78 e79
     1  e82 e83 e84  4   6   7  e88 e89
     2  e92 e93  5   7  e96 e97 e98  8  "
nitpick[verbose] (*11,7 секунды*)

lemma test32: "~ sudoku
     9   1  e13 e14  6   4  e17  8  e19
    e21 e22 e23 e24  1  e26 e27 e28 e29
    e31 e32 e33  8  e35  7  e37  4  e39
     2  e42 e43 e44 e45  1  e47 e48  8
    e51 e52 e53 e54  9  e56 e57 e58 e59
    e61 e62 e63 e64 e65 e66 e67  2  e69
    e71 e72  3   5  e75  9   7   6  e79
     5   7  e83 e84 e85 e86  4  e88 e89
     1  e92 e93 e94  7  e96  8  e98  3  "
nitpick[verbose] (*11,5 секунды*)

(*Трудные судоку*)

lemma test40: "~ sudoku
    e11  4  e13  5  e15  2  e17 e18 e19
    e21 e22  7  e24  3  e26 e27  9  e29
    e31  3  e33  1   9  e36 e37  2  e39
    e41  5  e43 e44 e45 e46 e47  6   3
     7  e52 e53  4  e55 e56 e57 e58 e59
     6   2  e63 e64 e65  9  e67  5  e69
    e71 e72 e73 e74 e75  1  e77 e78 e79
    e81 e82 e83  2  e85 e86 e87  3  e89
    e91 e92 e93 e94  6  e96  7   1  e99 "
nitpick[verbose] (*12,0 секунды*)
*)
(*
lemma test41: "~ sudoku
     6  e12  5  e14  2  e16 e17  9  e19
    e21 e22 e23  6  e25  7  e27 e28 e29
    e31 e32 e33 e34 e35 e36 e37 e38  5
    e41 e42  2  e44 e45 e46 e47 e48  4
     9  e52  8  e54  1  e56 e57 e58 e59
    e61  7  e63  5   9  e66  2  e68 e69
     1  e72 e73 e74 e75  3  e77 e78  7
    e81  3  e83 e84  4  e86 e87 e88 e89
    e91  9  e93 e94 e95 e96 e97 e98 e99 "
nitpick[verbose] (*12,1 секунды*)
(*
lemma test42: "~ sudoku
    e11  2  e13 e14  6  e16 e17 e18 e19
     7  e22 e23 e24 e25 e26 e27  5   3
    e31 e32 e33  4  e35  1  e37 e38 e39
     2  e42  1  e44 e45 e46 e47  9  e49
    e51 e52 e53  3  e55 e56 e57 e58  4
     8  e62 e63 e64 e65  2  e67 e68 e69
    e71 e72  5  e74 e75 e76 e77 e78  8
    e81 e82 e83 e84 e85  8  e87  3   6
     3   6  e93 e94 e95 e96 e97  4   7  "
nitpick[verbose] (*12,7 секунды*)   *)

(* Судоку с одной случайной цифрой *)
lemma test50: "~ sudoku
    e11 e12 e13 e14 e15 e16 e17 e18 e19
    e21  1  e23 e24 e25 e26 e27 e28 e29
    e31 e32 e33 e34 e35 e36 e37 e38 e39
    e41 e42 e43 e44 e45 e46 e47 e48 e49
    e51 e52 e53 e54 e55 e56 e57 e58 e59
    e61 e62 e63 e64 e65 e66 e67 e68 e69
    e71 e72 e73 e74 e75 e76 e77 e78 e79
    e81 e82 e83 e84 e85 e86 e87 e88 e89
    e91 e92 e93 e94 e95 e96 e97 e98 e99 "
nitpick[verbose] (*7,5 секунды*)

lemma test51: "~ sudoku
    e11 e12 e13 e14 e15 e16 e17 e18 e19
    e21 e22 e23 e24 e25 e26 e27 e28 e29
    e31 e32 e33 e34 e35 e36 e37 e38 e39
    e41 e42 e43 e44 e45 e46 e47 e48 e49
    e51 e52 e53 e54 e55 e56 e57 e58 e59
    e61 e62 e63 e64 e65 e66  6  e68 e69
    e71 e72 e73 e74 e75 e76 e77 e78 e79
    e81 e82 e83 e84 e85 e86 e87 e88 e89
    e91 e92 e93 e94 e95 e96 e97 e98 e99 "
nitpick[verbose] (*7,8 секунды*)

lemma test52: "~ sudoku
    e11 e12 e13 e14 e15 e16 e17 e18 e19
    e21 e22 e23 e24 e25 e26 e27 e28 e29
    e31 e32 e33 e34 e35 e36 e37 e38 e39
    e41 e42 e43 e44 e45 e46 e47 e48 e49
    e51 e52 e53 e54 e55 e56 e57 e58 e59
    e61 e62 e63 e64 e65 e66 e67 e68 e69
    e71 e72 e73 e74 e75 e76 e77 e78 e79
    e81 e82 e83 e84 e85 e86 e87 e88 e89
     4  e92 e93 e94 e95 e96 e97 e98 e99 "
nitpick[verbose] (*7,1 секунды*)

(*Судоку без одной случайной цифры*)

lemma test60: "~ sudoku
   e11  5   9   4   3   1   6   7   8
    3   7   6   5   2   8   1   9   4
    1   8   4   9   6   7   3   2   5
    8   9   7   6   5   4   2   3   1
    6   4   2   8   1   3   9   5   7
    5   1   3   2   7   9   8   4   6
    9   6   1   3   4   5   7   8   2
    4   2   8   7   9   6   5   1   3
    7   3   5   1   8   2   4   6   9 "
nitpick[verbose] (*10,2 секунды*)

lemma test61: "~ sudoku
    7   9   5   3   8   4   1   6   2
    1   4   8   7   2   6   9   3   5
    2   3   6   5   1   9   4   8   7
    3   7   1   2   5   8   6   4   9
    6   5   4   9   3   1   7   2   8
    9  e62  2   6   4   7   3   5   1
    5   6   3   1   9   2   8   7   4
    4   1   7   8   6   5   2   9   3
    8   2   9   4   7   3   5   1   6"
nitpick[verbose] (*10,3 секунды*)

lemma test62: "~ sudoku
    4   3   6   8   2   5   7   9   1
    5   7   1   6   9   4   8   3   2
    2   8   9   1   7   3   6   5   4
    1   4   3   7   5   2   9  e48  8
    8   2   7   9   1   6   5   4   3
    6   9   5   3   4   8   2   1   7
    3   6   2   5   8   1   4   7   9
    7   1   4   2   6   9   3   8   5
    9   5   8   4   3   7   1   2   6 "
nitpick[verbose] (*9,9 секунды*)
*)

lemma test41: "~ sudoku
    e11 e12 e13 e14 e15 e16 e17 e18 e19
    e21 e22 e23 e24 e25 e26 e27 e28 e29
    e31 e32 e33 e34 e35 e36 e37 e38 e39
    e41 e42 e43 e44 e45 e46 e47 e48 e49
    e51 e52 e53 e54 e55 e56 e57 e58 e59
    e61 e62 e63 e64 e65 e66 e67 e68 e69
    e71 e72 e73 e74 e75 e76 e77 e78 e79
    e81 e82 e83 e84 e85 e86 e87 e88 e89
    e91 e92 e93 e94 e95 e96 e97 e98 e99 "
nitpick[verbose] (*12,1 секунды*)

lemma test40: "~ sudoku
    e11  4  e13  5  e15  2  e17 e18 e19
    e21 e22  7  e24  3  e26 e27  9  e29
    e31  3  e33  1   9  e36 e37  2  e39
    e41  5  e43 e44 e45 e46 e47  6   3
     7  e52 e53  4  e55 e56 e57 e58 e59
     6   2  e63 e64 e65  9  e67  5  e69
    e71 e72 e73 e74 e75  1  e77 e78 e79
    e81 e82 e83  2  e85 e86 e87  3  e89
    e91 e92 e93 e94  6  e96  7   1  e99 "
nitpick[verbose]
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