(*
  Copyright (c) 2015--2019 by Clemens Ballarin
  This file is licensed under the 3-clause BSD license.
*)

theory Ring_Theory imports Group_Theory begin

no_notation plus (infixl "+" 65)
no_notation minus (infixl "-" 65)
no_notation uminus ("- _" [81] 80)
no_notation quotient (infixl "'/'/" 90)

section \<open>Rings\<close>

subsection \<open>Definition and Elementary Properties\<close>

text \<open>Def 2.1\<close>
text \<open>p 86, ll 20--28\<close>
locale ring = additive: abelian_group R "(+)" \<zero> + multiplicative: monoid R "(\<cdot>)" \<one>
  for R and addition (infixl "+" 65) and multiplication (infixl "\<cdot>" 70) and zero ("\<zero>") and unit ("\<one>") +
  assumes distributive: "\<lbrakk> a \<in> R; b \<in> R; c \<in> R \<rbrakk> \<Longrightarrow> a \<cdot> (b + c) = a \<cdot> b + a \<cdot> c"
    "\<lbrakk> a \<in> R; b \<in> R; c \<in> R \<rbrakk> \<Longrightarrow> (b + c) \<cdot> a = b \<cdot> a + c \<cdot> a"
begin

text \<open>p 86, ll 20--28\<close>
notation additive.inverse ("- _" [66] 65)
abbreviation subtraction (infixl "-" 65) where "a - b \<equiv> a + (- b)"  (* or, alternatively, a definition *)

end (* ring *)

text \<open>p 87, ll 10--12\<close>
locale subring =
  additive: subgroup S R "(+)" \<zero> + multiplicative: submonoid S R "(\<cdot>)" \<one>
  for S and R and addition (infixl "+" 65) and multiplication (infixl "\<cdot>" 70) and zero ("\<zero>") and unit ("\<one>")

context ring begin

text \<open>p 88, ll 26--28\<close>
lemma right_zero [simp]:
  assumes [simp]: "a \<in> R" shows "a \<cdot> \<zero> = \<zero>"
proof -
  have "a \<cdot> \<zero> = a \<cdot> (\<zero> + \<zero>)" by simp
  also have "\<dots> = a \<cdot> \<zero> + a \<cdot> \<zero>" by (simp add: distributive del: additive.left_unit additive.right_unit)
  finally have "a \<cdot> \<zero> - a \<cdot> \<zero> = a \<cdot> \<zero> + a \<cdot> \<zero> - a \<cdot> \<zero>" by simp
  then show ?thesis by (simp add: additive.associative del: additive.invertible_left_cancel)
qed

text \<open>p 88, l 29\<close>
lemma left_zero [simp]:
  assumes [simp]: "a \<in> R" shows "\<zero> \<cdot> a = \<zero>"
proof -
  have "\<zero> \<cdot> a = (\<zero> + \<zero>) \<cdot> a" by simp
  also have "\<dots> = \<zero> \<cdot> a + \<zero> \<cdot> a" by (simp add: distributive del: additive.left_unit additive.right_unit)
  finally have "\<zero> \<cdot> a - \<zero> \<cdot> a = \<zero> \<cdot> a + \<zero> \<cdot> a - \<zero> \<cdot> a" by simp
  then show ?thesis by (simp add: additive.associative del: additive.invertible_left_cancel)
qed

text \<open>p 88, ll 29--30; p 89, ll 1--2\<close>
lemma left_minus:
  assumes [simp]: "a \<in> R" "b \<in> R" shows "(- a) \<cdot> b = - a \<cdot> b"
proof -
  have "\<zero> = \<zero> \<cdot> b" by simp
  also have "\<dots> = (a - a) \<cdot> b" by simp
  also have "\<dots> = a \<cdot> b + (- a) \<cdot> b" by (simp add: distributive del: additive.invertible_right_inverse)
  finally have "- a \<cdot> b + \<zero> = - a \<cdot> b + a \<cdot> b + (- a) \<cdot> b" by (simp add: additive.associative del: additive.invertible_left_inverse)
  then show ?thesis by simp
qed

text \<open>p 89, l 3\<close>
lemma right_minus:
  assumes [simp]: "a \<in> R" "b \<in> R" shows "a \<cdot> (- b) = - a \<cdot> b"
proof -
  have "\<zero> = a \<cdot> \<zero>" by simp
  also have "\<dots> = a \<cdot> (b - b)" by simp
  also have "\<dots> = a \<cdot> b + a \<cdot> (- b)" by (simp add: distributive del: additive.invertible_right_inverse)
  finally have "- a \<cdot> b + \<zero> = - a \<cdot> b + a \<cdot> b + a \<cdot> (- b)" by (simp add: additive.associative del: additive.invertible_left_inverse)
  then show ?thesis by simp
qed

end (* ring *)

subsection \<open>Ideals, Quotient Rings\<close>

text \<open>p 101, ll 2--5\<close>
locale ring_congruence = ring +
  additive: group_congruence R "(+)" \<zero> E +
  multiplicative: monoid_congruence R "(\<cdot>)" \<one> E
  for E
begin

text \<open>p 101, ll 2--5\<close>
notation additive.quotient_composition (infixl "[+]" 65)
notation additive.quotient.inverse ("[-] _" [66] 65)
notation multiplicative.quotient_composition (infixl "[\<cdot>]" 70)

text \<open>p 101, ll 5--11\<close>
sublocale quotient: ring "R / E" "([+])" "([\<cdot>])" "additive.Class \<zero>" "additive.Class \<one>"
  by unfold_locales
    (auto simp: additive.Class_commutes_with_composition additive.associative additive.commutative
     multiplicative.Class_commutes_with_composition distributive elim!: additive.quotient_ClassE)

end (* ring_congruence *)

text \<open>p 101, ll 12--13\<close>
locale subgroup_of_additive_group_of_ring =
  additive: subgroup I R "(+)" \<zero> + ring R "(+)" "(\<cdot>)" \<zero> \<one>
  for I and R and addition (infixl "+" 65) and multiplication (infixl "\<cdot>" 70) and zero ("\<zero>") and unit ("\<one>")
begin

text \<open>p 101, ll 13--14\<close>
definition "Ring_Congruence = {(a, b). a \<in> R \<and> b \<in> R \<and> a - b \<in> I}"

text \<open>p 101, ll 13--14\<close>
lemma Ring_CongruenceI: "\<lbrakk> a - b \<in> I; a \<in> R; b \<in> R \<rbrakk> \<Longrightarrow> (a, b) \<in> Ring_Congruence"
  using Ring_Congruence_def by blast

text \<open>p 101, ll 13--14\<close>
lemma Ring_CongruenceD: "(a, b) \<in> Ring_Congruence \<Longrightarrow> a - b \<in> I"
  using Ring_Congruence_def by blast

text \<open>
  Jacobson's definition of ring congruence deviates from that of group congruence; this complicates
  the proof.
\<close>
text \<open>p 101, ll 12--14\<close>
sublocale additive: subgroup_of_abelian_group I R "(+)" \<zero>  (* implies normal_subgroup *)
  rewrites additive_congruence: "additive.Congruence = Ring_Congruence"
proof -
  show "subgroup_of_abelian_group I R (+) \<zero>"
    using additive.commutative additive.invertible_right_inverse2 by unfold_locales auto
  then interpret additive: subgroup_of_abelian_group I R "(+)" \<zero> .
  {
    fix a b
    assume [simp]: "a \<in> R" "b \<in> R"
    have "a - b \<in> I \<longleftrightarrow> - (a - b) \<in> I" by auto
    also have "\<dots> \<longleftrightarrow> - a + b \<in> I" by (simp add: additive.commutative additive.inverse_composition_commute)
    finally have "a - b \<in> I \<longleftrightarrow> - a + b \<in> I" .
  }
  then show "additive.Congruence = Ring_Congruence"
    unfolding additive.Congruence_def Ring_Congruence_def by auto
qed

text \<open>p 101, l 14\<close>
notation additive.Left_Coset (infixl "+|" 65)

end (* subgroup_of_additive_group_of_ring *)

text \<open>Def 2.2\<close>
text \<open>p 101, ll 21--22\<close>
locale ideal = subgroup_of_additive_group_of_ring +
  assumes ideal: "\<lbrakk> a \<in> R; b \<in> I \<rbrakk> \<Longrightarrow> a \<cdot> b \<in> I" "\<lbrakk> a \<in> R; b \<in> I \<rbrakk> \<Longrightarrow> b \<cdot> a \<in> I"

context subgroup_of_additive_group_of_ring begin

text \<open>p 101, ll 14--17\<close>
theorem multiplicative_congruence_implies_ideal:
  assumes "monoid_congruence R (\<cdot>) \<one> Ring_Congruence"
  shows "ideal I R (+) (\<cdot>) \<zero> \<one>"
proof -
  interpret multiplicative: monoid_congruence R "(\<cdot>)" \<one> Ring_Congruence by fact
  show ?thesis
  proof
    fix a b
    assume [simp]: "a \<in> R" "b \<in> I"
    have congs: "(a, a) \<in> Ring_Congruence" "(b, \<zero>) \<in> Ring_Congruence"
      by (auto simp: additive.ClassD additive.Class_unit_normal_subgroup)
    from congs have "(a \<cdot> b, \<zero>) \<in> Ring_Congruence" using multiplicative.cong by fastforce
    then show "a \<cdot> b \<in> I" using additive.Class_unit_normal_subgroup by blast
    from congs have "(b \<cdot> a, \<zero>) \<in> Ring_Congruence" using multiplicative.cong by fastforce
    then show "b \<cdot> a \<in> I"  using additive.Class_unit_normal_subgroup by blast
  qed
qed

end (* subgroup_of_additive_group_of_ring *)

context ideal begin

text \<open>p 101, ll 17--20\<close>
theorem multiplicative_congruence [intro]:
  assumes a: "(a, a') \<in> Ring_Congruence" and b: "(b, b') \<in> Ring_Congruence"
  shows "(a \<cdot> b, a' \<cdot> b') \<in> Ring_Congruence"
proof -
  note Ring_CongruenceI [intro] Ring_CongruenceD [dest]
  from a b have [simp]: "a \<in> R" "a' \<in> R" "b \<in> R" "b' \<in> R" by auto
  from a have [simp]: "a - a' \<in> I" ..
  have "a \<cdot> b - a' \<cdot> b = (a - a') \<cdot> b" by (simp add: distributive left_minus)
  also have "\<dots> \<in> I" by (simp add: ideal)
  finally have ab: "a \<cdot> b - a' \<cdot> b \<in> I" .  \<comment> \<open>ll 18--19\<close>
  from b have [simp]: "b - b' \<in> I" ..
  have "a' \<cdot> b - a' \<cdot> b' = a' \<cdot> (b - b')" by (simp add: distributive right_minus)
  also have "\<dots> \<in> I" by (simp add: ideal)
  finally have a'b': "a' \<cdot> b - a' \<cdot> b' \<in> I" .  \<comment> \<open>l 19\<close>
  have "a \<cdot> b - a' \<cdot> b' = (a \<cdot> b - a' \<cdot> b) + (a' \<cdot> b - a' \<cdot> b')"
    by (simp add: additive.associative) (simp add: additive.associative [symmetric])
  also have "\<dots> \<in> I" using ab a'b' by simp
  finally show "(a \<cdot> b, a' \<cdot> b') \<in> Ring_Congruence" by auto  \<comment> \<open>ll 19--20\<close>
qed

text \<open>p 101, ll 23--24\<close>
sublocale ring_congruence where E = Ring_Congruence by unfold_locales rule

end (* ideal *)

context ring begin

text \<open>Pulled out of @{locale ideal} to achieve standard notation.\<close>
text \<open>p 101, ll 24--26\<close>
abbreviation Quotient_Ring (infixl "'/'/" 75)
  where "S // I \<equiv> S / (subgroup_of_additive_group_of_ring.Ring_Congruence I R (+) \<zero>)"

end (* ring *)

text \<open>p 101, ll 24--26\<close>
locale quotient_ring = ideal begin

text \<open>p 101, ll 24--26\<close>
sublocale quotient: ring "R // I" "([+])" "([\<cdot>])" "additive.Class \<zero>" "additive.Class \<one>" ..

text \<open>p 101, l 26\<close>
lemmas Left_Coset = additive.Left_CosetE

text \<open>Equation 17 (1)\<close>
text \<open>p 101, l 28\<close>
lemmas quotient_addition = additive.factor_composition

text \<open>Equation 17 (2)\<close>
text \<open>p 101, l 29\<close>
theorem quotient_multiplication [simp]:
  "\<lbrakk> a \<in> R; b \<in> R \<rbrakk> \<Longrightarrow> (a +| I) [\<cdot>] (b +| I) = a \<cdot> b +| I"
  using multiplicative.Class_commutes_with_composition additive.Class_is_Left_Coset by auto

text \<open>p 101, l 30\<close>
lemmas quotient_zero = additive.factor_unit
lemmas quotient_negative = additive.factor_inverse

end (* quotient_ring *)

subsection \<open>Homomorphisms of Rings.  Basic Theorems\<close>

text \<open>Def 2.3\<close>
text \<open>p 106, ll 7--9\<close>
locale ring_homomorphism =
  map \<eta> R R' + source: ring R "(+)" "(\<cdot>)" \<zero> \<one> + target: ring R' "(+')" "(\<cdot>')" "\<zero>'" "\<one>'" +
  additive: group_homomorphism \<eta> R "(+)" \<zero> R' "(+')" "\<zero>'" +
  multiplicative: monoid_homomorphism \<eta> R "(\<cdot>)" \<one> R' "(\<cdot>')" "\<one>'"
  for \<eta>
    and R and addition (infixl "+" 65) and multiplication (infixl "\<cdot>" 70) and zero ("\<zero>") and unit ("\<one>")
    and R' and addition' (infixl "+''" 65) and multiplication' (infixl "\<cdot>''" 70) and zero' ("\<zero>''") and unit' ("\<one>''")

text \<open>p 106, l 17\<close>
locale ring_epimorphism = ring_homomorphism + surjective_map \<eta> R R'

text \<open>p 106, ll 14--18\<close>
sublocale quotient_ring \<subseteq> natural: ring_epimorphism
  where \<eta> = additive.Class and R' = "R // I" and addition' = "([+])" and multiplication' =  "([\<cdot>])"
    and zero' = "additive.Class \<zero>" and unit' = "additive.Class \<one>"
  ..

context ring_homomorphism begin

text \<open>
  Jacobson reasons via @{term "a - b \<in> additive.Ker"} being a congruence; we prefer the direct proof,
  since it is very simple.
\<close>
text \<open>p 106, ll 19--21\<close>
sublocale kernel: ideal where I = additive.Ker
  by unfold_locales (auto simp: additive.Ker_image multiplicative.commutes_with_composition)

end (* ring_homomorphism *)

text \<open>p 106, l 22\<close>
locale ring_monomorphism = ring_homomorphism + injective_map \<eta> R R'

context ring_homomorphism begin

text \<open>p 106, ll 21--23\<close>
theorem ring_monomorphism_iff_kernel_unit:
  "ring_monomorphism \<eta> R (+) (\<cdot>) \<zero> \<one> R' (+') (\<cdot>') \<zero>' \<one>' \<longleftrightarrow> additive.Ker = {\<zero>}" (is "?monom \<longleftrightarrow> ?ker")
proof
  assume ?monom then interpret ring_monomorphism . show ?ker by (simp add: additive.injective_iff_kernel_unit [symmetric])
next
  assume ?ker then show ?monom by unfold_locales (simp add: additive.injective_iff_kernel_unit)
qed

end (* ring_homomorphism *)

text \<open>p 106, ll 23--25\<close>
sublocale ring_homomorphism \<subseteq> image: subring "\<eta> ` R" R' "(+')" "(\<cdot>')" "\<zero>'" "\<one>'" ..

text \<open>p 106, ll 26--27\<close>
locale ideal_in_kernel =
  ring_homomorphism + contained: ideal I R "(+)" "(\<cdot>)" \<zero> \<one> for I +
  assumes subset: "I \<subseteq> additive.Ker"
begin

text \<open>p 106, ll 26--27\<close>
notation contained.additive.quotient_composition (infixl "[+]" 65)
notation contained.multiplicative.quotient_composition (infixl "[\<cdot>]" 70)

text \<open>Provides @{text additive.induced}, which Jacobson calls $\bar{\eta}$.\<close>
text \<open>p 106, l 30\<close>
sublocale additive: normal_subgroup_in_kernel \<eta> R "(+)" \<zero> R' "(+')" "\<zero>'" I
  rewrites "normal_subgroup.Congruence I R addition zero = contained.Ring_Congruence"
  by unfold_locales (rule subset contained.additive_congruence)+

text \<open>Only the multiplicative part needs some work.\<close>
text \<open>p 106, ll 27--30\<close>
sublocale induced: ring_homomorphism additive.induced "R // I" "([+])" "([\<cdot>])" "contained.additive.Class \<zero>" "contained.additive.Class \<one>"
  using contained.multiplicative.Class_commutes_with_composition
  by unfold_locales
    (auto elim!: contained.additive.Left_CosetE simp: contained.additive.Class_is_Left_Coset multiplicative.commutes_with_composition multiplicative.commutes_with_unit)

text \<open>p 106, l 30; p 107, ll 1--3\<close>
text \<open>
  @{term additive.induced} denotes Jacobson's $\bar{\eta}$.  We have the commutativity of the diagram, where
  @{term additive.induced} is unique: @{thm [display] additive.factorization} @{thm [display] additive.uniqueness}
\<close>

end (* ideal_in_kernel *)

text \<open>Fundamental Theorem of Homomorphisms of Rings\<close>

text \<open>p 107, l 6\<close>
locale ring_homomorphism_fundamental = ring_homomorphism begin

text \<open>p 107, l 6\<close>
notation kernel.additive.quotient_composition (infixl "[+]" 65)
notation kernel.multiplicative.quotient_composition (infixl "[\<cdot>]" 70)

text \<open>p 107, l 6\<close>
sublocale ideal_in_kernel where I = additive.Ker by unfold_locales rule

text \<open>p 107, ll 8--9\<close>
sublocale natural: ring_epimorphism
  where \<eta> = kernel.additive.Class and R' = "R // additive.Ker"
    and addition' = "kernel.additive.quotient_composition"
    and multiplication' = "kernel.multiplicative.quotient_composition"
    and zero' = "kernel.additive.Class \<zero>" and unit' = "kernel.additive.Class \<one>"
  ..

text \<open>p 107, l 9\<close>
sublocale induced: ring_monomorphism
  where \<eta> = additive.induced and R = "R // additive.Ker"
    and addition = "kernel.additive.quotient_composition"
    and multiplication = "kernel.multiplicative.quotient_composition"
    and zero = "kernel.additive.Class \<zero>" and unit = "kernel.additive.Class \<one>"
  by unfold_locales (simp add: additive.induced_inj_on)

end (* ring_homomorphism_fundamental *)

text \<open>p 107, l 11\<close>
locale ring_isomorphism = ring_homomorphism + bijective_map \<eta> R R' begin

text \<open>p 107, l 11\<close>
sublocale ring_monomorphism ..
sublocale ring_epimorphism ..

text \<open>p 107, l 11\<close>
lemma inverse_ring_isomorphism:
  "ring_isomorphism (restrict (inv_into R \<eta>) R') R' (+') (\<cdot>') \<zero>' \<one>' R (+) (\<cdot>) \<zero> \<one>"
  using additive.commutes_with_composition [symmetric] additive.commutes_with_unit
    multiplicative.commutes_with_composition [symmetric] multiplicative.commutes_with_unit surjective
  by unfold_locales auto

end (* ring_isomorphsim *)

text \<open>p 107, l 11\<close>
definition isomorphic_as_rings (infixl "\<cong>\<^sub>R" 50)
  where "\<R> \<cong>\<^sub>R \<R>' \<longleftrightarrow> (let (R, addition, multiplication, zero, unit) = \<R>; (R', addition', multiplication', zero', unit') = \<R>' in
  (\<exists>\<eta>. ring_isomorphism \<eta> R addition multiplication zero unit R' addition' multiplication' zero' unit'))"

text \<open>p 107, l 11\<close>
lemma isomorphic_as_rings_symmetric:
  "(R, addition, multiplication, zero, unit) \<cong>\<^sub>R (R', addition', multiplication', zero', unit') \<Longrightarrow>
   (R', addition', multiplication', zero', unit') \<cong>\<^sub>R (R, addition, multiplication, zero, unit)"
  by (simp add: isomorphic_as_rings_def) (meson ring_isomorphism.inverse_ring_isomorphism)

context ring_homomorphism begin

text \<open>Corollary\<close>
text \<open>p 107, ll 11--12\<close>
theorem image_is_isomorphic_to_quotient_ring:
  "\<exists>K add mult zero one. ideal K R (+) (\<cdot>) \<zero> \<one> \<and> (\<eta> ` R, (+'), (\<cdot>'), \<zero>', \<one>') \<cong>\<^sub>R (R // K, add, mult, zero, one)"
proof -
  interpret image: ring_homomorphism_fundamental where R' = "\<eta> ` R"
    by unfold_locales (auto simp: target.additive.commutative additive.commutes_with_composition
      multiplicative.commutes_with_composition target.distributive multiplicative.commutes_with_unit)
  have "ring_isomorphism image.additive.induced (R // additive.Ker) ([+]) ([\<cdot>]) (kernel.additive.Class \<zero>) (kernel.additive.Class \<one>) (\<eta> ` R) (+') (\<cdot>') \<zero>' \<one>'"
    by unfold_locales (simp add: image.additive.induced_image bij_betw_def)
  then have "(\<eta> ` R, (+'), (\<cdot>'), \<zero>', \<one>') \<cong>\<^sub>R (R // additive.Ker, ([+]), ([\<cdot>]), kernel.additive.Class \<zero>, kernel.additive.Class \<one>)"
    by (simp add: isomorphic_as_rings_def) (meson ring_isomorphism.inverse_ring_isomorphism)
  moreover have "ideal additive.Ker R (+) (\<cdot>) \<zero> \<one>" ..
  ultimately show ?thesis by blast
qed

end (* ring_homomorphism *)

end


(*  Title:      HOL/Number_Theory/UniqueFactorization.thy
    Author:     Jeremy Avigad

Unique factorization for the natural numbers and the integers.

Note: there were previous Isabelle formalizations of unique
factorization due to Thomas Marthedal Rasmussen, and, building on
that, by Jeremy Avigad and David Gray.
*)

section {* UniqueFactorization *}

theory UniqueFactorization
imports Cong "~~/src/HOL/Library/Multiset"
begin

(* As a simp or intro rule,

     prime p \<Longrightarrow> p > 0

   wreaks havoc here. When the premise includes ALL x :# M. prime x, it
   leads to the backchaining

     x > 0
     prime x
     x :# M   which is, unfortunately,
     count M x > 0
*)

(* Here is a version of set product for multisets. Is it worth moving
   to multiset.thy? If so, one should similarly define msetsum for abelian
   semirings, using of_nat. Also, is it worth developing bounded quantifiers
   "ALL i :# M. P i"?
*)

subsection {* unique factorization: multiset version *}

lemma multiset_prime_factorization_exists [rule_format]: "n > 0 -->
    (EX M. (ALL (p::nat) : set_of M. prime p) & n = (PROD i :# M. i))"
proof (rule nat_less_induct, clarify)
  fix n :: nat
  assume ih: "ALL m < n. 0 < m --> (EX M. (ALL p : set_of M. prime p) & m =
      (PROD i :# M. i))"
  assume "(n::nat) > 0"
  then have "n = 1 | (n > 1 & prime n) | (n > 1 & ~ prime n)"
    by arith
  moreover {
    assume "n = 1"
    then have "(ALL p : set_of {#}. prime p) & n = (PROD i :# {#}. i)" by auto
  } moreover {
    assume "n > 1" and "prime n"
    then have "(ALL p : set_of {# n #}. prime p) & n = (PROD i :# {# n #}. i)"
      by auto
  } moreover {
    assume "n > 1" and "~ prime n"
    with not_prime_eq_prod_nat
    obtain m k where n: "n = m * k & 1 < m & m < n & 1 < k & k < n"
      by blast
    with ih obtain Q R where "(ALL p : set_of Q. prime p) & m = (PROD i:#Q. i)"
        and "(ALL p: set_of R. prime p) & k = (PROD i:#R. i)"
      by blast
    then have "(ALL p: set_of (Q + R). prime p) & n = (PROD i :# Q + R. i)"
      by (auto simp add: n msetprod_Un)
    then have "EX M. (ALL p : set_of M. prime p) & n = (PROD i :# M. i)"..
  }
  ultimately show "EX M. (ALL p : set_of M. prime p) & n = (PROD i::nat:#M. i)"
    by blast
qed

lemma multiset_prime_factorization_unique_aux:
  fixes a :: nat
  assumes "(ALL p : set_of M. prime p)" and
    "(ALL p : set_of N. prime p)" and
    "(PROD i :# M. i) dvd (PROD i:# N. i)"
  shows
    "count M a <= count N a"
proof cases
  assume M: "a : set_of M"
  with assms have a: "prime a" by auto
  with M have "a ^ count M a dvd (PROD i :# M. i)"
    by (auto simp add: msetprod_multiplicity)
  also have "... dvd (PROD i :# N. i)" by (rule assms)
  also have "... = (PROD i : (set_of N). i ^ (count N i))"
    by (simp add: msetprod_multiplicity)
  also have "... = a^(count N a) * (PROD i : (set_of N - {a}). i ^ (count N i))"
  proof (cases)
    assume "a : set_of N"
    then have b: "set_of N = {a} Un (set_of N - {a})"
      by auto
    then show ?thesis
      by (subst (1) b, subst setprod.union_disjoint, auto)
  next
    assume "a ~: set_of N"
    then show ?thesis by auto
  qed
  finally have "a ^ count M a dvd
      a^(count N a) * (PROD i : (set_of N - {a}). i ^ (count N i))".
  moreover
  have "coprime (a ^ count M a) (PROD i : (set_of N - {a}). i ^ (count N i))"
    apply (subst gcd_commute_nat)
    apply (rule setprod_coprime_nat)
    apply (rule primes_imp_powers_coprime_nat)
    using assms M
    apply auto
    done
  ultimately have "a ^ count M a dvd a^(count N a)"
    by (elim coprime_dvd_mult_nat)
  with a show ?thesis
    apply (intro power_dvd_imp_le)
    apply auto
    done
next
  assume "a ~: set_of M"
  then show ?thesis by auto
qed

lemma multiset_prime_factorization_unique:
  assumes "(ALL (p::nat) : set_of M. prime p)" and
    "(ALL p : set_of N. prime p)" and
    "(PROD i :# M. i) = (PROD i:# N. i)"
  shows
    "M = N"
proof -
  {
    fix a
    from assms have "count M a <= count N a"
      by (intro multiset_prime_factorization_unique_aux, auto)
    moreover from assms have "count N a <= count M a"
      by (intro multiset_prime_factorization_unique_aux, auto)
    ultimately have "count M a = count N a"
      by auto
  }
  then show ?thesis by (simp add:multiset_eq_iff)
qed

definition multiset_prime_factorization :: "nat => nat multiset"
where
  "multiset_prime_factorization n ==
     if n > 0 then (THE M. ((ALL p : set_of M. prime p) &
       n = (PROD i :# M. i)))
     else {#}"

lemma multiset_prime_factorization: "n > 0 ==>
    (ALL p : set_of (multiset_prime_factorization n). prime p) &
       n = (PROD i :# (multiset_prime_factorization n). i)"
  apply (unfold multiset_prime_factorization_def)
  apply clarsimp
  apply (frule multiset_prime_factorization_exists)
  apply clarify
  apply (rule theI)
  apply (insert multiset_prime_factorization_unique)
  apply auto
done

subsection {* Prime factors and multiplicity for nats and ints *}

class unique_factorization =
  fixes multiplicity :: "'a \<Rightarrow> 'a \<Rightarrow> nat"
    and prime_factors :: "'a \<Rightarrow> 'a set"

(* definitions for the natural numbers *)

instantiation nat :: unique_factorization
begin

definition multiplicity_nat :: "nat \<Rightarrow> nat \<Rightarrow> nat"
  where "multiplicity_nat p n = count (multiset_prime_factorization n) p"

definition prime_factors_nat :: "nat \<Rightarrow> nat set"
  where "prime_factors_nat n = set_of (multiset_prime_factorization n)"

instance ..

end

(* definitions for the integers *)

instantiation int :: unique_factorization
begin

definition multiplicity_int :: "int \<Rightarrow> int \<Rightarrow> nat"
  where "multiplicity_int p n = multiplicity (nat p) (nat n)"

definition prime_factors_int :: "int \<Rightarrow> int set"
  where "prime_factors_int n = int ` (prime_factors (nat n))"

instance ..

end

subsection {* Set up transfer *}

lemma transfer_nat_int_prime_factors: "prime_factors (nat n) = nat ` prime_factors n"
  unfolding prime_factors_int_def
  apply auto
  apply (subst transfer_int_nat_set_return_embed)
  apply assumption
  done

lemma transfer_nat_int_prime_factors_closure: "n >= 0 \<Longrightarrow> nat_set (prime_factors n)"
  by (auto simp add: nat_set_def prime_factors_int_def)

lemma transfer_nat_int_multiplicity: "p >= 0 \<Longrightarrow> n >= 0 \<Longrightarrow>
    multiplicity (nat p) (nat n) = multiplicity p n"
  by (auto simp add: multiplicity_int_def)

declare transfer_morphism_nat_int[transfer add return:
  transfer_nat_int_prime_factors transfer_nat_int_prime_factors_closure
  transfer_nat_int_multiplicity]

lemma transfer_int_nat_prime_factors: "prime_factors (int n) = int ` prime_factors n"
  unfolding prime_factors_int_def by auto

lemma transfer_int_nat_prime_factors_closure: "is_nat n \<Longrightarrow>
    nat_set (prime_factors n)"
  by (simp only: transfer_nat_int_prime_factors_closure is_nat_def)

lemma transfer_int_nat_multiplicity:
    "multiplicity (int p) (int n) = multiplicity p n"
  by (auto simp add: multiplicity_int_def)

declare transfer_morphism_int_nat[transfer add return:
  transfer_int_nat_prime_factors transfer_int_nat_prime_factors_closure
  transfer_int_nat_multiplicity]

subsection {* Properties of prime factors and multiplicity for nats and ints *}

lemma prime_factors_ge_0_int [elim]: "p : prime_factors (n::int) \<Longrightarrow> p >= 0"
  unfolding prime_factors_int_def by auto

lemma prime_factors_prime_nat [intro]: "p : prime_factors (n::nat) \<Longrightarrow> prime p"
  apply (cases "n = 0")
  apply (simp add: prime_factors_nat_def multiset_prime_factorization_def)
  apply (auto simp add: prime_factors_nat_def multiset_prime_factorization)
  done

lemma prime_factors_prime_int [intro]:
  assumes "n >= 0" and "p : prime_factors (n::int)"
  shows "prime p"
  apply (rule prime_factors_prime_nat [transferred, of n p, simplified])
  using assms apply auto
  done

lemma prime_factors_gt_0_nat [elim]: "p : prime_factors x \<Longrightarrow> p > (0::nat)"
  apply (frule prime_factors_prime_nat)
  apply auto
  done

lemma prime_factors_gt_0_int [elim]: "x >= 0 \<Longrightarrow> p : prime_factors x \<Longrightarrow>
    int p > (0::int)"
  apply auto
  done

lemma prime_factors_finite_nat [iff]: "finite (prime_factors (n::nat))"
  unfolding prime_factors_nat_def by auto

lemma prime_factors_finite_int [iff]: "finite (prime_factors (n::int))"
  unfolding prime_factors_int_def by auto

lemma prime_factors_altdef_nat: "prime_factors (n::nat) =
    {p. multiplicity p n > 0}"
  by (force simp add: prime_factors_nat_def multiplicity_nat_def)

lemma prime_factors_altdef_int: "prime_factors (n::int) =
    {p. p >= 0 & multiplicity p n > 0}"
  apply (unfold prime_factors_int_def multiplicity_int_def)
  apply (subst prime_factors_altdef_nat)
  apply (auto simp add: image_def)
  done

lemma prime_factorization_nat: "(n::nat) > 0 \<Longrightarrow>
    n = (PROD p : prime_factors n. p^(multiplicity p n))"
  apply (frule multiset_prime_factorization)
  apply (simp add: prime_factors_nat_def multiplicity_nat_def msetprod_multiplicity)
  done

lemma prime_factorization_int:
  assumes "(n::int) > 0"
  shows "n = (PROD p : prime_factors n. p^(multiplicity p n))"
  apply (rule prime_factorization_nat [transferred, of n])
  using assms apply auto
  done

lemma prime_factorization_unique_nat:
  fixes f :: "nat \<Rightarrow> _"
  assumes S_eq: "S = {p. 0 < f p}" and "finite S"
    and "\<forall>p\<in>S. prime p" "n = (\<Prod>p\<in>S. p ^ f p)"
  shows "S = prime_factors n \<and> (\<forall>p. f p = multiplicity p n)"
proof -
  from assms have "f \<in> multiset"
    by (auto simp add: multiset_def)
  moreover from assms have "n > 0" by force
  ultimately have "multiset_prime_factorization n = Abs_multiset f"
    apply (unfold multiset_prime_factorization_def)
    apply (subst if_P, assumption)
    apply (rule the1_equality)
    apply (rule ex_ex1I)
    apply (rule multiset_prime_factorization_exists, assumption)
    apply (rule multiset_prime_factorization_unique)
    apply force
    apply force
    apply force
    using assms
    apply (simp add: set_of_def msetprod_multiplicity)
    done
  with `f \<in> multiset` have "count (multiset_prime_factorization n) = f"
    by simp
  with S_eq show ?thesis
    by (simp add: set_of_def multiset_def prime_factors_nat_def multiplicity_nat_def)
qed

lemma prime_factors_characterization_nat: "S = {p. 0 < f (p::nat)} \<Longrightarrow>
    finite S \<Longrightarrow> (ALL p:S. prime p) \<Longrightarrow> n = (PROD p:S. p ^ f p) \<Longrightarrow>
      prime_factors n = S"
  apply (rule prime_factorization_unique_nat [THEN conjunct1, symmetric])
  apply assumption+
  done

lemma prime_factors_characterization'_nat:
  "finite {p. 0 < f (p::nat)} \<Longrightarrow>
    (ALL p. 0 < f p \<longrightarrow> prime p) \<Longrightarrow>
      prime_factors (PROD p | 0 < f p . p ^ f p) = {p. 0 < f p}"
  apply (rule prime_factors_characterization_nat)
  apply auto
  done

(* A minor glitch:*)

thm prime_factors_characterization'_nat
    [where f = "%x. f (int (x::nat))",
      transferred direction: nat "op <= (0::int)", rule_format]

(*
  Transfer isn't smart enough to know that the "0 < f p" should
  remain a comparison between nats. But the transfer still works.
*)

lemma primes_characterization'_int [rule_format]:
    "finite {p. p >= 0 & 0 < f (p::int)} \<Longrightarrow>
      (ALL p. 0 < f p \<longrightarrow> prime p) \<Longrightarrow>
        prime_factors (PROD p | p >=0 & 0 < f p . p ^ f p) =
          {p. p >= 0 & 0 < f p}"

  apply (insert prime_factors_characterization'_nat
    [where f = "%x. f (int (x::nat))",
    transferred direction: nat "op <= (0::int)"])
  apply auto
  done

lemma prime_factors_characterization_int: "S = {p. 0 < f (p::int)} \<Longrightarrow>
    finite S \<Longrightarrow> (ALL p:S. prime (nat p)) \<Longrightarrow> n = (PROD p:S. p ^ f p) \<Longrightarrow>
      prime_factors n = S"
  apply simp
  apply (subgoal_tac "{p. 0 < f p} = {p. 0 <= p & 0 < f p}")
  apply (simp only:)
  apply (subst primes_characterization'_int)
  apply auto
  apply (metis nat_int)
  apply (metis le_cases nat_le_0 zero_not_prime_nat)
  done

lemma multiplicity_characterization_nat: "S = {p. 0 < f (p::nat)} \<Longrightarrow>
    finite S \<Longrightarrow> (ALL p:S. prime p) \<Longrightarrow> n = (PROD p:S. p ^ f p) \<Longrightarrow>
      multiplicity p n = f p"
  apply (frule prime_factorization_unique_nat [THEN conjunct2, rule_format, symmetric])
  apply auto
  done

lemma multiplicity_characterization'_nat: "finite {p. 0 < f (p::nat)} \<longrightarrow>
    (ALL p. 0 < f p \<longrightarrow> prime p) \<longrightarrow>
      multiplicity p (PROD p | 0 < f p . p ^ f p) = f p"
  apply (intro impI)
  apply (rule multiplicity_characterization_nat)
  apply auto
  done

lemma multiplicity_characterization'_int [rule_format]:
  "finite {p. p >= 0 & 0 < f (p::int)} \<Longrightarrow>
    (ALL p. 0 < f p \<longrightarrow> prime p) \<Longrightarrow> p >= 0 \<Longrightarrow>
      multiplicity p (PROD p | p >= 0 & 0 < f p . p ^ f p) = f p"
  apply (insert multiplicity_characterization'_nat
    [where f = "%x. f (int (x::nat))",
      transferred direction: nat "op <= (0::int)", rule_format])
  apply auto
  done

lemma multiplicity_characterization_int: "S = {p. 0 < f (p::int)} \<Longrightarrow>
    finite S \<Longrightarrow> (ALL p:S. prime (nat p)) \<Longrightarrow> n = (PROD p:S. p ^ f p) \<Longrightarrow>
      p >= 0 \<Longrightarrow> multiplicity p n = f p"
  apply simp
  apply (subgoal_tac "{p. 0 < f p} = {p. 0 <= p & 0 < f p}")
  apply (simp only:)
  apply (subst multiplicity_characterization'_int)
  apply auto
  apply (metis nat_int)
  apply (metis le_cases nat_le_0 zero_not_prime_nat)
  done

lemma multiplicity_zero_nat [simp]: "multiplicity (p::nat) 0 = 0"
  by (simp add: multiplicity_nat_def multiset_prime_factorization_def)

lemma multiplicity_zero_int [simp]: "multiplicity (p::int) 0 = 0"
  by (simp add: multiplicity_int_def)

lemma multiplicity_one_nat': "multiplicity p (1::nat) = 0"
  by (subst multiplicity_characterization_nat [where f = "%x. 0"], auto)

lemma multiplicity_one_nat [simp]: "multiplicity p (Suc 0) = 0"
  by (metis One_nat_def multiplicity_one_nat')

lemma multiplicity_one_int [simp]: "multiplicity p (1::int) = 0"
  by (metis multiplicity_int_def multiplicity_one_nat' transfer_nat_int_numerals(2))

lemma multiplicity_prime_nat [simp]: "prime p \<Longrightarrow> multiplicity p p = 1"
  apply (subst multiplicity_characterization_nat [where f = "(%q. if q = p then 1 else 0)"])
  apply auto
  by (metis (full_types) less_not_refl)

lemma multiplicity_prime_power_nat [simp]: "prime p \<Longrightarrow> multiplicity p (p^n) = n"
  apply (cases "n = 0")
  apply auto
  apply (subst multiplicity_characterization_nat [where f = "(%q. if q = p then n else 0)"])
  apply auto
  by (metis (full_types) less_not_refl)

lemma multiplicity_prime_power_int [simp]: "prime p \<Longrightarrow> multiplicity p ( (int p)^n) = n"
  by (metis multiplicity_prime_power_nat of_nat_power transfer_int_nat_multiplicity)

lemma multiplicity_nonprime_nat [simp]: "~ prime (p::nat) \<Longrightarrow> multiplicity p n = 0"
  apply (cases "n = 0")
  apply auto
  apply (frule multiset_prime_factorization)
  apply (auto simp add: set_of_def multiplicity_nat_def)
  done

lemma multiplicity_not_factor_nat [simp]:
    "p ~: prime_factors (n::nat) \<Longrightarrow> multiplicity p n = 0"
  apply (subst (asm) prime_factors_altdef_nat)
  apply auto
  done

lemma multiplicity_not_factor_int [simp]:
    "p >= 0 \<Longrightarrow> p ~: prime_factors (n::int) \<Longrightarrow> multiplicity p n = 0"
  apply (subst (asm) prime_factors_altdef_int)
  apply auto
  done

(*FIXME: messy*)
lemma multiplicity_product_aux_nat: "(k::nat) > 0 \<Longrightarrow> l > 0 \<Longrightarrow>
    (prime_factors k) Un (prime_factors l) = prime_factors (k * l) &
    (ALL p. multiplicity p k + multiplicity p l = multiplicity p (k * l))"
  apply (rule prime_factorization_unique_nat)
  apply (simp only: prime_factors_altdef_nat)
  apply auto
  apply (subst power_add)
  apply (subst setprod.distrib)
  apply (rule arg_cong2 [where f = "\<lambda>x y. x*y"])
  apply (subgoal_tac "prime_factors k Un prime_factors l = prime_factors k Un
      (prime_factors l - prime_factors k)")
  apply (erule ssubst)
  apply (subst setprod.union_disjoint)
  apply auto
  apply (metis One_nat_def nat_mult_1_right prime_factorization_nat setprod.neutral_const)
  apply (subgoal_tac "prime_factors k Un prime_factors l = prime_factors l Un
      (prime_factors k - prime_factors l)")
  apply (erule ssubst)
  apply (subst setprod.union_disjoint)
  apply auto
  apply (subgoal_tac "(\<Prod>p\<in>prime_factors k - prime_factors l. p ^ multiplicity p l) =
      (\<Prod>p\<in>prime_factors k - prime_factors l. 1)")
  apply auto
  apply (metis One_nat_def nat_mult_1_right prime_factorization_nat setprod.neutral_const)
  done

(* transfer doesn't have the same problem here with the right
   choice of rules. *)

lemma multiplicity_product_aux_int:
  assumes "(k::int) > 0" and "l > 0"
  shows
    "(prime_factors k) Un (prime_factors l) = prime_factors (k * l) &
    (ALL p >= 0. multiplicity p k + multiplicity p l = multiplicity p (k * l))"
  apply (rule multiplicity_product_aux_nat [transferred, of l k])
  using assms apply auto
  done

lemma prime_factors_product_nat: "(k::nat) > 0 \<Longrightarrow> l > 0 \<Longrightarrow> prime_factors (k * l) =
    prime_factors k Un prime_factors l"
  by (rule multiplicity_product_aux_nat [THEN conjunct1, symmetric])

lemma prime_factors_product_int: "(k::int) > 0 \<Longrightarrow> l > 0 \<Longrightarrow> prime_factors (k * l) =
    prime_factors k Un prime_factors l"
  by (rule multiplicity_product_aux_int [THEN conjunct1, symmetric])

lemma multiplicity_product_nat: "(k::nat) > 0 \<Longrightarrow> l > 0 \<Longrightarrow> multiplicity p (k * l) =
    multiplicity p k + multiplicity p l"
  by (rule multiplicity_product_aux_nat [THEN conjunct2, rule_format,
      symmetric])

lemma multiplicity_product_int: "(k::int) > 0 \<Longrightarrow> l > 0 \<Longrightarrow> p >= 0 \<Longrightarrow>
    multiplicity p (k * l) = multiplicity p k + multiplicity p l"
  by (rule multiplicity_product_aux_int [THEN conjunct2, rule_format,
      symmetric])

lemma multiplicity_setprod_nat: "finite S \<Longrightarrow> (ALL x : S. f x > 0) \<Longrightarrow>
    multiplicity (p::nat) (PROD x : S. f x) =
      (SUM x : S. multiplicity p (f x))"
  apply (induct set: finite)
  apply auto
  apply (subst multiplicity_product_nat)
  apply auto
  done

(* Transfer is delicate here for two reasons: first, because there is
   an implicit quantifier over functions (f), and, second, because the
   product over the multiplicity should not be translated to an integer
   product.

   The way to handle the first is to use quantifier rules for functions.
   The way to handle the second is to turn off the offending rule.
*)

lemma transfer_nat_int_sum_prod_closure3:
  "(SUM x : A. int (f x)) >= 0"
  "(PROD x : A. int (f x)) >= 0"
  apply (rule setsum_nonneg, auto)
  apply (rule setprod_nonneg, auto)
  done

declare transfer_morphism_nat_int[transfer
  add return: transfer_nat_int_sum_prod_closure3
  del: transfer_nat_int_sum_prod2 (1)]

lemma multiplicity_setprod_int: "p >= 0 \<Longrightarrow> finite S \<Longrightarrow>
  (ALL x : S. f x > 0) \<Longrightarrow>
    multiplicity (p::int) (PROD x : S. f x) =
      (SUM x : S. multiplicity p (f x))"

  apply (frule multiplicity_setprod_nat
    [where f = "%x. nat(int(nat(f x)))",
      transferred direction: nat "op <= (0::int)"])
  apply auto
  apply (subst (asm) setprod.cong)
  apply (rule refl)
  apply (rule if_P)
  apply auto
  apply (rule setsum.cong)
  apply auto
  done

declare transfer_morphism_nat_int[transfer
  add return: transfer_nat_int_sum_prod2 (1)]

lemma multiplicity_prod_prime_powers_nat:
    "finite S \<Longrightarrow> (ALL p : S. prime (p::nat)) \<Longrightarrow>
       multiplicity p (PROD p : S. p ^ f p) = (if p : S then f p else 0)"
  apply (subgoal_tac "(PROD p : S. p ^ f p) =
      (PROD p : S. p ^ (%x. if x : S then f x else 0) p)")
  apply (erule ssubst)
  apply (subst multiplicity_characterization_nat)
  prefer 5 apply (rule refl)
  apply (rule refl)
  apply auto
  apply (subst setprod.mono_neutral_right)
  apply assumption
  prefer 3
  apply (rule setprod.cong)
  apply (rule refl)
  apply auto
done

(* Here the issue with transfer is the implicit quantifier over S *)

lemma multiplicity_prod_prime_powers_int:
    "(p::int) >= 0 \<Longrightarrow> finite S \<Longrightarrow> (ALL p:S. prime (nat p)) \<Longrightarrow>
       multiplicity p (PROD p : S. p ^ f p) = (if p : S then f p else 0)"
  apply (subgoal_tac "int ` nat ` S = S")
  apply (frule multiplicity_prod_prime_powers_nat [where f = "%x. f(int x)"
    and S = "nat ` S", transferred])
  apply auto
  apply (metis linear nat_0_iff zero_not_prime_nat)
  apply (metis (full_types) image_iff int_nat_eq less_le less_linear nat_0_iff zero_not_prime_nat)
  done

lemma multiplicity_distinct_prime_power_nat: "prime p \<Longrightarrow> prime q \<Longrightarrow>
    p ~= q \<Longrightarrow> multiplicity p (q^n) = 0"
  apply (subgoal_tac "q^n = setprod (%x. x^n) {q}")
  apply (erule ssubst)
  apply (subst multiplicity_prod_prime_powers_nat)
  apply auto
  done

lemma multiplicity_distinct_prime_power_int: "prime p \<Longrightarrow> prime q \<Longrightarrow>
    p ~= q \<Longrightarrow> multiplicity p (int q ^ n) = 0"
  by (metis multiplicity_distinct_prime_power_nat of_nat_power transfer_int_nat_multiplicity)

lemma dvd_multiplicity_nat:
    "(0::nat) < y \<Longrightarrow> x dvd y \<Longrightarrow> multiplicity p x <= multiplicity p y"
  apply (cases "x = 0")
  apply (auto simp add: dvd_def multiplicity_product_nat)
  done

lemma dvd_multiplicity_int:
    "(0::int) < y \<Longrightarrow> 0 <= x \<Longrightarrow> x dvd y \<Longrightarrow> p >= 0 \<Longrightarrow>
      multiplicity p x <= multiplicity p y"
  apply (cases "x = 0")
  apply (auto simp add: dvd_def)
  apply (subgoal_tac "0 < k")
  apply (auto simp add: multiplicity_product_int)
  apply (erule zero_less_mult_pos)
  apply arith
  done

lemma dvd_prime_factors_nat [intro]:
    "0 < (y::nat) \<Longrightarrow> x dvd y \<Longrightarrow> prime_factors x <= prime_factors y"
  apply (simp only: prime_factors_altdef_nat)
  apply auto
  apply (metis dvd_multiplicity_nat le_0_eq neq0_conv)
  done

lemma dvd_prime_factors_int [intro]:
    "0 < (y::int) \<Longrightarrow> 0 <= x \<Longrightarrow> x dvd y \<Longrightarrow> prime_factors x <= prime_factors y"
  apply (auto simp add: prime_factors_altdef_int)
  apply (metis dvd_multiplicity_int le_0_eq neq0_conv)
  done

lemma multiplicity_dvd_nat: "0 < (x::nat) \<Longrightarrow> 0 < y \<Longrightarrow>
    ALL p. multiplicity p x <= multiplicity p y \<Longrightarrow> x dvd y"
  apply (subst prime_factorization_nat [of x], assumption)
  apply (subst prime_factorization_nat [of y], assumption)
  apply (rule setprod_dvd_setprod_subset2)
  apply force
  apply (subst prime_factors_altdef_nat)+
  apply auto
  apply (metis gr0I le_0_eq less_not_refl)
  apply (metis le_imp_power_dvd)
  done

lemma multiplicity_dvd_int: "0 < (x::int) \<Longrightarrow> 0 < y \<Longrightarrow>
    ALL p >= 0. multiplicity p x <= multiplicity p y \<Longrightarrow> x dvd y"
  apply (subst prime_factorization_int [of x], assumption)
  apply (subst prime_factorization_int [of y], assumption)
  apply (rule setprod_dvd_setprod_subset2)
  apply force
  apply (subst prime_factors_altdef_int)+
  apply auto
  apply (metis le_imp_power_dvd prime_factors_ge_0_int)
  done

lemma multiplicity_dvd'_nat: "(0::nat) < x \<Longrightarrow>
    \<forall>p. prime p \<longrightarrow> multiplicity p x \<le> multiplicity p y \<Longrightarrow> x dvd y"
  by (metis gcd_lcm_complete_lattice_nat.top_greatest le_refl multiplicity_dvd_nat
      multiplicity_nonprime_nat neq0_conv)

lemma multiplicity_dvd'_int:
  fixes x::int and y::int
  shows "0 < x \<Longrightarrow> 0 <= y \<Longrightarrow>
    \<forall>p. prime p \<longrightarrow> multiplicity p x \<le> multiplicity p y \<Longrightarrow> x dvd y"
by (metis GCD.dvd_int_iff abs_int_eq multiplicity_dvd'_nat multiplicity_int_def nat_int
          zero_le_imp_eq_int zero_less_imp_eq_int)

lemma dvd_multiplicity_eq_nat: "0 < (x::nat) \<Longrightarrow> 0 < y \<Longrightarrow>
    (x dvd y) = (ALL p. multiplicity p x <= multiplicity p y)"
  by (auto intro: dvd_multiplicity_nat multiplicity_dvd_nat)

lemma dvd_multiplicity_eq_int: "0 < (x::int) \<Longrightarrow> 0 < y \<Longrightarrow>
    (x dvd y) = (ALL p >= 0. multiplicity p x <= multiplicity p y)"
  by (auto intro: dvd_multiplicity_int multiplicity_dvd_int)

lemma prime_factors_altdef2_nat: "(n::nat) > 0 \<Longrightarrow>
    (p : prime_factors n) = (prime p & p dvd n)"
  apply (cases "prime p")
  apply auto
  apply (subst prime_factorization_nat [where n = n], assumption)
  apply (rule dvd_trans)
  apply (rule dvd_power [where x = p and n = "multiplicity p n"])
  apply (subst (asm) prime_factors_altdef_nat, force)
  apply rule
  apply auto
  apply (metis One_nat_def Zero_not_Suc dvd_multiplicity_nat le0 le_antisym multiplicity_not_factor_nat multiplicity_prime_nat)
  done

lemma prime_factors_altdef2_int:
  assumes "(n::int) > 0"
  shows "(p : prime_factors n) = (prime p & p dvd n)"
using assms by (simp add:  prime_factors_altdef2_nat [transferred])

lemma multiplicity_eq_nat:
  fixes x and y::nat
  assumes [arith]: "x > 0" "y > 0" and
    mult_eq [simp]: "!!p. prime p \<Longrightarrow> multiplicity p x = multiplicity p y"
  shows "x = y"
  apply (rule dvd_antisym)
  apply (auto intro: multiplicity_dvd'_nat)
  done

lemma multiplicity_eq_int:
  fixes x and y::int
  assumes [arith]: "x > 0" "y > 0" and
    mult_eq [simp]: "!!p. prime p \<Longrightarrow> multiplicity p x = multiplicity p y"
  shows "x = y"
  apply (rule dvd_antisym [transferred])
  apply (auto intro: multiplicity_dvd'_int)
  done

subsection {* An application *}

lemma gcd_eq_nat:
  assumes pos [arith]: "x > 0" "y > 0"
  shows "gcd (x::nat) y =
    (PROD p: prime_factors x Un prime_factors y.
      p ^ (min (multiplicity p x) (multiplicity p y)))"
proof -
  def z == "(PROD p: prime_factors (x::nat) Un prime_factors y.
      p ^ (min (multiplicity p x) (multiplicity p y)))"
  have [arith]: "z > 0"
    unfolding z_def by (rule setprod_pos_nat, auto)
  have aux: "!!p. prime p \<Longrightarrow> multiplicity p z =
      min (multiplicity p x) (multiplicity p y)"
    unfolding z_def
    apply (subst multiplicity_prod_prime_powers_nat)
    apply auto
    done
  have "z dvd x"
    by (intro multiplicity_dvd'_nat, auto simp add: aux)
  moreover have "z dvd y"
    by (intro multiplicity_dvd'_nat, auto simp add: aux)
  moreover have "ALL w. w dvd x & w dvd y \<longrightarrow> w dvd z"
    apply auto
    apply (case_tac "w = 0", auto)
    apply (erule multiplicity_dvd'_nat)
    apply (auto intro: dvd_multiplicity_nat simp add: aux)
    done
  ultimately have "z = gcd x y"
    by (subst gcd_unique_nat [symmetric], blast)
  then show ?thesis
    unfolding z_def by auto
qed

lemma lcm_eq_nat:
  assumes pos [arith]: "x > 0" "y > 0"
  shows "lcm (x::nat) y =
    (PROD p: prime_factors x Un prime_factors y.
      p ^ (max (multiplicity p x) (multiplicity p y)))"
proof -
  def z == "(PROD p: prime_factors (x::nat) Un prime_factors y.
      p ^ (max (multiplicity p x) (multiplicity p y)))"
  have [arith]: "z > 0"
    unfolding z_def by (rule setprod_pos_nat, auto)
  have aux: "!!p. prime p \<Longrightarrow> multiplicity p z =
      max (multiplicity p x) (multiplicity p y)"
    unfolding z_def
    apply (subst multiplicity_prod_prime_powers_nat)
    apply auto
    done
  have "x dvd z"
    by (intro multiplicity_dvd'_nat, auto simp add: aux)
  moreover have "y dvd z"
    by (intro multiplicity_dvd'_nat, auto simp add: aux)
  moreover have "ALL w. x dvd w & y dvd w \<longrightarrow> z dvd w"
    apply auto
    apply (case_tac "w = 0", auto)
    apply (rule multiplicity_dvd'_nat)
    apply (auto intro: dvd_multiplicity_nat simp add: aux)
    done
  ultimately have "z = lcm x y"
    by (subst lcm_unique_nat [symmetric], blast)
  then show ?thesis
    unfolding z_def by auto
qed

lemma multiplicity_gcd_nat:
  assumes [arith]: "x > 0" "y > 0"
  shows "multiplicity (p::nat) (gcd x y) = min (multiplicity p x) (multiplicity p y)"
  apply (subst gcd_eq_nat)
  apply auto
  apply (subst multiplicity_prod_prime_powers_nat)
  apply auto
  done

lemma multiplicity_lcm_nat:
  assumes [arith]: "x > 0" "y > 0"
  shows "multiplicity (p::nat) (lcm x y) = max (multiplicity p x) (multiplicity p y)"
  apply (subst lcm_eq_nat)
  apply auto
  apply (subst multiplicity_prod_prime_powers_nat)
  apply auto
  done

lemma gcd_lcm_distrib_nat: "gcd (x::nat) (lcm y z) = lcm (gcd x y) (gcd x z)"
  apply (cases "x = 0 | y = 0 | z = 0")
  apply auto
  apply (rule multiplicity_eq_nat)
  apply (auto simp add: multiplicity_gcd_nat multiplicity_lcm_nat lcm_pos_nat)
  done

lemma gcd_lcm_distrib_int: "gcd (x::int) (lcm y z) = lcm (gcd x y) (gcd x z)"
  apply (subst (1 2 3) gcd_abs_int)
  apply (subst lcm_abs_int)
  apply (subst (2) abs_of_nonneg)
  apply force
  apply (rule gcd_lcm_distrib_nat [transferred])
  apply auto
  done

end


(* Author: Tobias Nipkow *)

section \<open>Leftist Heap\<close>

theory Leftist_Heap
imports
  "HOL-Library.Pattern_Aliases"
  Tree2
  Priority_Queue_Specs
  Complex_Main
begin

fun mset_tree :: "('a*'b) tree \<Rightarrow> 'a multiset" where
"mset_tree Leaf = {#}" |
"mset_tree (Node l (a, _) r) = {#a#} + mset_tree l + mset_tree r"

type_synonym 'a lheap = "('a*nat)tree"

fun mht :: "'a lheap \<Rightarrow> nat" where
"mht Leaf = 0" |
"mht (Node _ (_, n) _) = n"

text\<open>The invariants:\<close>

fun (in linorder) heap :: "('a*'b) tree \<Rightarrow> bool" where
"heap Leaf = True" |
"heap (Node l (m, _) r) =
  ((\<forall>x \<in> set_tree l \<union> set_tree r. m \<le> x) \<and> heap l \<and> heap r)"

fun ltree :: "'a lheap \<Rightarrow> bool" where
"ltree Leaf = True" |
"ltree (Node l (a, n) r) =
 (min_height l \<ge> min_height r \<and> n = min_height r + 1 \<and> ltree l & ltree r)"

definition empty :: "'a lheap" where
"empty = Leaf"

definition node :: "'a lheap \<Rightarrow> 'a \<Rightarrow> 'a lheap \<Rightarrow> 'a lheap" where
"node l a r =
 (let rl = mht l; rr = mht r
  in if rl \<ge> rr then Node l (a,rr+1) r else Node r (a,rl+1) l)"

fun get_min :: "'a lheap \<Rightarrow> 'a" where
"get_min(Node l (a, n) r) = a"

text \<open>For function \<open>merge\<close>:\<close>
unbundle pattern_aliases

fun merge :: "'a::ord lheap \<Rightarrow> 'a lheap \<Rightarrow> 'a lheap" where
"merge Leaf t = t" |
"merge t Leaf = t" |
"merge (Node l1 (a1, n1) r1 =: t1) (Node l2 (a2, n2) r2 =: t2) =
   (if a1 \<le> a2 then node l1 a1 (merge r1 t2)
    else node l2 a2 (merge t1 r2))"

text \<open>Termination of @{const merge}: by sum or lexicographic product of the sizes
of the two arguments. Isabelle uses a lexicographic product.\<close>

lemma merge_code: "merge t1 t2 = (case (t1,t2) of
  (Leaf, _) \<Rightarrow> t2 |
  (_, Leaf) \<Rightarrow> t1 |
  (Node l1 (a1, n1) r1, Node l2 (a2, n2) r2) \<Rightarrow>
    if a1 \<le> a2 then node l1 a1 (merge r1 t2) else node l2 a2 (merge t1 r2))"
by(induction t1 t2 rule: merge.induct) (simp_all split: tree.split)

hide_const (open) insert

definition insert :: "'a::ord \<Rightarrow> 'a lheap \<Rightarrow> 'a lheap" where
"insert x t = merge (Node Leaf (x,1) Leaf) t"

fun del_min :: "'a::ord lheap \<Rightarrow> 'a lheap" where
"del_min Leaf = Leaf" |
"del_min (Node l _ r) = merge l r"

subsection "Lemmas"

lemma mset_tree_empty: "mset_tree t = {#} \<longleftrightarrow> t = Leaf"
by(cases t) auto

lemma mht_eq_min_height: "ltree t \<Longrightarrow> mht t = min_height t"
by(cases t) auto

lemma ltree_node: "ltree (node l a r) \<longleftrightarrow> ltree l \<and> ltree r"
by(auto simp add: node_def mht_eq_min_height)

lemma heap_node: "heap (node l a r) \<longleftrightarrow>
  heap l \<and> heap r \<and> (\<forall>x \<in> set_tree l \<union> set_tree r. a \<le> x)"
by(auto simp add: node_def)

lemma set_tree_mset: "set_tree t = set_mset(mset_tree t)"
by(induction t) auto

subsection "Functional Correctness"

lemma mset_merge: "mset_tree (merge t1 t2) = mset_tree t1 + mset_tree t2"
by (induction t1 t2 rule: merge.induct) (auto simp add: node_def ac_simps)

lemma mset_insert: "mset_tree (insert x t) = mset_tree t + {#x#}"
by (auto simp add: insert_def mset_merge)

lemma get_min: "\<lbrakk> heap t;  t \<noteq> Leaf \<rbrakk> \<Longrightarrow> get_min t = Min(set_tree t)"
by (cases t) (auto simp add: eq_Min_iff)

lemma mset_del_min: "mset_tree (del_min t) = mset_tree t - {# get_min t #}"
by (cases t) (auto simp: mset_merge)

lemma ltree_merge: "\<lbrakk> ltree l; ltree r \<rbrakk> \<Longrightarrow> ltree (merge l r)"
by(induction l r rule: merge.induct)(auto simp: ltree_node)

lemma heap_merge: "\<lbrakk> heap l; heap r \<rbrakk> \<Longrightarrow> heap (merge l r)"
proof(induction l r rule: merge.induct)
  case 3 thus ?case by(auto simp: heap_node mset_merge ball_Un set_tree_mset)
qed simp_all

lemma ltree_insert: "ltree t \<Longrightarrow> ltree(insert x t)"
by(simp add: insert_def ltree_merge del: merge.simps split: tree.split)

lemma heap_insert: "heap t \<Longrightarrow> heap(insert x t)"
by(simp add: insert_def heap_merge del: merge.simps split: tree.split)

lemma ltree_del_min: "ltree t \<Longrightarrow> ltree(del_min t)"
by(cases t)(auto simp add: ltree_merge simp del: merge.simps)

lemma heap_del_min: "heap t \<Longrightarrow> heap(del_min t)"
by(cases t)(auto simp add: heap_merge simp del: merge.simps)

text \<open>Last step of functional correctness proof: combine all the above lemmas
to show that leftist heaps satisfy the specification of priority queues with merge.\<close>

interpretation lheap: Priority_Queue_Merge
where empty = empty and is_empty = "\<lambda>t. t = Leaf"
and insert = insert and del_min = del_min
and get_min = get_min and merge = merge
and invar = "\<lambda>t. heap t \<and> ltree t" and mset = mset_tree
proof(standard, goal_cases)
  case 1 show ?case by (simp add: empty_def)
next
  case (2 q) show ?case by (cases q) auto
next
  case 3 show ?case by(rule mset_insert)
next
  case 4 show ?case by(rule mset_del_min)
next
  case 5 thus ?case by(simp add: get_min mset_tree_empty set_tree_mset)
next
  case 6 thus ?case by(simp add: empty_def)
next
  case 7 thus ?case by(simp add: heap_insert ltree_insert)
next
  case 8 thus ?case by(simp add: heap_del_min ltree_del_min)
next
  case 9 thus ?case by (simp add: mset_merge)
next
  case 10 thus ?case by (simp add: heap_merge ltree_merge)
qed

subsection "Complexity"

text\<open>Explicit termination argument: sum of sizes\<close>

fun T_merge :: "'a::ord lheap \<Rightarrow> 'a lheap \<Rightarrow> nat" where
"T_merge Leaf t = 1" |
"T_merge t Leaf = 1" |
"T_merge (Node l1 (a1, n1) r1 =: t1) (Node l2 (a2, n2) r2 =: t2) =
  (if a1 \<le> a2 then T_merge r1 t2
   else T_merge t1 r2) + 1"

definition T_insert :: "'a::ord \<Rightarrow> 'a lheap \<Rightarrow> nat" where
"T_insert x t = T_merge (Node Leaf (x, 1) Leaf) t + 1"

fun T_del_min :: "'a::ord lheap \<Rightarrow> nat" where
"T_del_min Leaf = 1" |
"T_del_min (Node l _ r) = T_merge l r + 1"

lemma T_merge_min_height: "ltree l \<Longrightarrow> ltree r \<Longrightarrow> T_merge l r \<le> min_height l + min_height r + 1"
proof(induction l r rule: merge.induct)
  case 3 thus ?case by(auto)
qed simp_all

corollary T_merge_log: assumes "ltree l" "ltree r"
  shows "T_merge l r \<le> log 2 (size1 l) + log 2 (size1 r) + 1"
using le_log2_of_power[OF min_height_size1[of l]]
  le_log2_of_power[OF min_height_size1[of r]] T_merge_min_height[of l r] assms
by linarith

corollary T_insert_log: "ltree t \<Longrightarrow> T_insert x t \<le> log 2 (size1 t) + 3"
using T_merge_log[of "Node Leaf (x, 1) Leaf" t]
by(simp add: T_insert_def split: tree.split)

(* FIXME mv ? *)
lemma ld_ld_1_less:
  assumes "x > 0" "y > 0" shows "log 2 x + log 2 y + 1 < 2 * log 2 (x+y)"
proof -
  have "2 powr (log 2 x + log 2 y + 1) = 2*x*y"
    using assms by(simp add: powr_add)
  also have "\<dots> < (x+y)^2" using assms
    by(simp add: numeral_eq_Suc algebra_simps add_pos_pos)
  also have "\<dots> = 2 powr (2 * log 2 (x+y))"
    using assms by(simp add: powr_add log_powr[symmetric])
  finally show ?thesis by simp
qed

corollary T_del_min_log: assumes "ltree t"
  shows "T_del_min t \<le> 2 * log 2 (size1 t) + 1"
proof(cases t rule: tree2_cases)
  case Leaf thus ?thesis using assms by simp
next
  case [simp]: (Node l _ _ r)
  have "T_del_min t = T_merge l r + 1" by simp
  also have "\<dots> \<le> log 2 (size1 l) + log 2 (size1 r) + 2"
    using \<open>ltree t\<close> T_merge_log[of l r] by (auto simp del: T_merge.simps)
  also have "\<dots> \<le> 2 * log 2 (size1 t) + 1"
    using ld_ld_1_less[of "size1 l" "size1 r"] by (simp)
  finally show ?thesis .
qed

end


theory Ex7_1 imports "~~/src/HOL/IMP/Big_Step" "~~/src/HOL/IMP/Small_Step" begin

section "Chapter 7 exercises"

subsection "7.1"

fun assigned :: "com \<Rightarrow> vname set" where
  "assigned (SKIP) = {}" |
  "assigned (Assign vname _) = {vname}" |
  "assigned (Seq  c0 c1) = assigned c0 \<union> assigned c1" |
  "assigned (If   _ c0 c1) = assigned c0 \<union> assigned c1" |
  "assigned (While  _ com) = assigned com"

lemma unassigned_is_unchanged:"\<lbrakk>(c,s) \<Rightarrow> t; x \<notin> assigned c\<rbrakk> \<Longrightarrow> s x = t x"
  apply(induction rule: big_step_induct)
  by auto

subsection "7.2"

fun skip :: "com \<Rightarrow> bool" where
  "skip (SKIP) = True" |
  "skip (Assign _ _) = False" |
  "skip (Seq  c0 c1) = (skip c0 \<and> skip c1)" |
  "skip (If   _ c0 c1) = (skip c0 \<and> skip c1)" |
  (* I think we'd also need to know that While terminated, then this would be: = skip com *)
  "skip (While _ com) = False"

lemma skip_like_SKIP: "skip c \<Longrightarrow> c \<sim> SKIP"
proof(induction c)
  case SKIP
  then show ?case by simp
next
  case (Assign x1 x2)
  then show ?case by simp
next
  case (Seq c1 c2)
  then show ?case by fastforce
next
  case (If bexp c1 c2)
  then show ?case
    by (meson Big_Step.IfE big_step.IfFalse big_step.IfTrue skip.simps(4))
next
  case (While bexp c)
  then show ?case
    (* Note: this is how you view the simplifier steps *)
  using [[simp_trace_new mode=full]]
    by simp
qed

subsection "7.3"

fun deskip_seq :: "com \<Rightarrow> com \<Rightarrow> com" where
  "deskip_seq SKIP c = c" |
  "deskip_seq c SKIP = c" |
  "deskip_seq c0 c1 = Seq c0 c1"

lemma deskip_seq_notskip2:"a \<noteq> SKIP \<Longrightarrow> deskip_seq a SKIP = a"
  apply(cases a)
  by(auto)

lemma deskip_seq_notskip12:"\<lbrakk>a \<noteq> SKIP ; b \<noteq> SKIP\<rbrakk> \<Longrightarrow> deskip_seq a b = Seq a b"
  apply(cases a)
      apply auto
     apply(cases b) apply(auto)
    apply(cases b) apply(auto)
   apply(cases b) apply(auto)
  apply(cases b) apply(auto)
  done

fun deskip :: "com \<Rightarrow> com" where
  "deskip (SKIP) = SKIP" |
  "deskip (Assign v a)  = Assign v a" |
  "deskip (Seq c0 c1)   = deskip_seq (deskip c0) (deskip c1)" |
  "deskip (If b c0 c1)  = If b (deskip c0) (deskip c1)" |
  "deskip (While b c) = While b (deskip c)"

lemma deskip_nochange:"deskip c \<sim> c"
proof(induction c)
  case SKIP
  then show ?case by simp
next
  case (Assign x1 x2)
  then show ?case
    by simp
next
  case (Seq c0 c1)
  then show ?case
  proof(cases "(deskip c0) = SKIP")
    case True
    hence 0:"deskip (c0;; c1) = deskip c1"
      by simp
    moreover have "c0;; c1 \<sim> c1"
      using Big_Step.SkipE Seq.IH(1) Skip True by fastforce
    ultimately show ?thesis
      by (simp add: Seq.IH(2))
  next
    case c0f:False
    then show ?thesis
    proof(cases "(deskip c1) = SKIP")
      case c1t:True
      hence "deskip (c0;; c1) = deskip_seq (deskip c0) SKIP"
        by simp
      have "deskip_seq (deskip c0) SKIP = deskip c0"
        using c0f deskip_seq_notskip2 by simp
      then show ?thesis
        using Big_Step.SkipE Seq.IH(1) Seq.IH(2) Skip c1t by fastforce
    next
      case False
      then show ?thesis
        using c0f deskip_seq_notskip12 Seq.IH(1) Seq.IH(2) by auto
    qed
  qed
next
  case (If x1 c1 c2)
  then show ?case
    by auto
next
  case (While x1 c)
  then show ?case using sim_while_cong by auto
qed

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 {* Finite Suprema *}

theory Finite_Suprema
imports Dioid
begin

text {* This file contains an adaptation of Isabelle's library for
finite sums to the case of (join) semilattices and dioids. In this
setting, addition is idempotent; finite sums are finite suprema.

We add some basic properties of finite suprema for (join) semilattices
and dioids. *}

subsection {* Auxiliary Lemmas *}

lemma fun_im: "{f a |a. a \<in> A} = {b. b \<in> f ` A}"
  by auto

lemma fset_to_im: "{f x |x. x \<in> X} = f ` X"
  by auto

lemma cart_flip_aux: "{f (snd p) (fst p) |p. p \<in> (B \<times> A)} = {f (fst p) (snd p) |p. p \<in> (A \<times> B)}"
  by auto

lemma cart_flip: "(\<lambda>p. f (snd p) (fst p)) ` (B \<times> A) = (\<lambda>p. f (fst p) (snd p)) ` (A \<times> B)"
  by (metis cart_flip_aux fset_to_im)

lemma fprod_aux: "{x \<cdot> y |x y. x \<in> (f ` A) \<and> y \<in> (g ` B)} = {f x \<cdot> g y |x y. x \<in> A \<and> y \<in> B}"
  by auto

subsection {*Finite Suprema in Semilattices *}

text {* The first lemma shows that, in the context of semilattices,
finite sums satisfy the defining property of finite suprema. *}

lemma setsum_sup:
  assumes "finite (A :: 'a::join_semilattice_zero set)"
  shows "\<Sum>A \<le> z \<longleftrightarrow> (\<forall>a \<in> A. a \<le> z)"
proof (induct rule: finite_induct[OF assms])
  fix z ::'a
  show "(\<Sum>{} \<le> z) = (\<forall>a \<in> {}. a \<le> z)"
    by (metis setsum.empty zero_least Int_empty_right disjoint_iff_not_equal)
next
  fix x z :: 'a and F :: "'a set"
  assume finF: "finite F"
    and xnF: "x \<notin> F"
    and indhyp: "(\<Sum>F \<le> z) = (\<forall>a \<in> F. a \<le> z)"
  show "(\<Sum>(insert x F) \<le> z) = (\<forall>a \<in> insert x F. a \<le> z)"
  proof -
    have "\<Sum>(insert x F) \<le> z \<longleftrightarrow> (x + \<Sum>F) \<le> z"
      by (metis finF setsum.insert xnF)
    also have "... \<longleftrightarrow> x \<le> z \<and> \<Sum>F \<le> z"
      by (metis add_lub)
    also have "... \<longleftrightarrow> x \<le> z \<and> (\<forall>a \<in> F. a \<le> z)"
      by (metis (lifting) indhyp)
    also have "... \<longleftrightarrow> (\<forall>a \<in> insert x F. a \<le> z)"
      by (metis insert_iff)
    ultimately show "(\<Sum>(insert x F) \<le> z) = (\<forall>a \<in> insert x F. a \<le> z)"
      by blast
  qed
qed

text {* This immediately implies some variants. *}

lemma setsum_less_eqI:
  "(\<And>x. x \<in> A \<Longrightarrow> f x \<le> y) \<Longrightarrow> setsum f A \<le> (y::'a::join_semilattice_zero)"
 apply (atomize (full))
 apply (case_tac "finite A")
  apply (erule finite_induct)
   apply simp_all
 apply (metis add_lub)
done

lemma setsum_less_eqE:
  "\<lbrakk> setsum f A \<le> y; x \<in> A; finite A \<rbrakk> \<Longrightarrow> f x \<le> (y::'a::join_semilattice_zero)"
 apply (erule rev_mp)
 apply (erule rev_mp)
 apply (erule finite_induct)
  apply (auto simp add: add_lub)
done

lemma setsum_fun_image_sup:
  fixes f :: "'a \<Rightarrow> 'b::join_semilattice_zero"
  assumes "finite (A :: 'a set)"
  shows "\<Sum>(f ` A) \<le> z \<longleftrightarrow> (\<forall>a \<in> A. f a \<le> z)"
  by (simp add: assms setsum_sup)

lemma setsum_fun_sup:
  fixes f :: "'a \<Rightarrow> 'b::join_semilattice_zero"
  assumes "finite (A ::'a set)"
  shows "\<Sum>{f a | a. a \<in> A} \<le> z \<longleftrightarrow> (\<forall>a \<in> A. f a \<le> z)"
  by (simp only: fset_to_im assms setsum_fun_image_sup)

lemma setsum_intro:
  assumes "finite (A :: 'a::join_semilattice_zero set)" and "finite B"
  shows "(\<forall>a \<in> A. \<exists>b \<in> B. a \<le> b) \<longrightarrow> (\<Sum>A \<le> \<Sum>B)"
  by (metis assms order_refl order_trans setsum_sup)

text {* Next we prove an additivity property for suprema. *}

lemma setsum_union:
  assumes "finite (A :: 'a::join_semilattice_zero set)"
  and "finite (B :: 'a::join_semilattice_zero set)"
  shows "\<Sum>(A \<union> B) = \<Sum>A + \<Sum>B"
proof -
    have "\<forall>z. \<Sum>(A \<union> B) \<le> z \<longleftrightarrow> (\<Sum>A + \<Sum>B \<le> z)"
      by (auto simp add: assms setsum_sup add_lub)
  thus ?thesis
    by (simp add: eq_iff)
qed

text {* It follows that the sum (supremum) of a two-element set is the
join of its elements. *}

lemma setsum_bin[simp]: "\<Sum>{(x :: 'a::join_semilattice_zero),y} = x + y"
  by (subst insert_is_Un, subst setsum_union, auto)

text {* Next we show that finite suprema are order preserving. *}

lemma setsum_iso:
  assumes "finite (B :: 'a::join_semilattice_zero set)"
  shows "A \<subseteq> B \<longrightarrow> \<Sum> A \<le> \<Sum> B"
  by (metis assms finite_subset order_refl set_rev_mp setsum_sup)

text {* The following lemmas state unfold properties for suprema and
finite sets. They are subtly different from the non-idempotent case,
where additional side conditions are required. *}

lemma setsum_insert [simp]:
  assumes "finite (A :: 'a::join_semilattice_zero set)"
  shows "\<Sum>(insert x A) = x + \<Sum>A"
proof -
  have "\<Sum>(insert x A) = \<Sum>{x} + \<Sum>A"
    by (metis insert_is_Un assms finite.emptyI finite.insertI setsum_union)
  thus ?thesis
    by auto
qed

lemma setsum_fun_insert:
  fixes f :: "'a \<Rightarrow> 'b::join_semilattice_zero"
  assumes "finite (A :: 'a set)"
  shows "\<Sum>(f ` (insert x A)) = f x + \<Sum>(f ` A)"
  by (simp add: assms)

text {* Now we show that set comprehensions with nested suprema can
be flattened. *}

lemma flatten1_im:
  fixes f :: "'a \<Rightarrow> 'a \<Rightarrow> 'b::join_semilattice_zero"
  assumes "finite (A :: 'a set)"
  and "finite (B :: 'a set)"
  shows "\<Sum>((\<lambda>x. \<Sum>(f x ` B)) ` A) = \<Sum>((\<lambda>p. f (fst p) (snd p)) ` (A \<times> B))"
proof -
  have "\<forall>z. \<Sum>((\<lambda>x. \<Sum>(f x ` B)) ` A) \<le> z \<longleftrightarrow> \<Sum>((\<lambda>p. f (fst p) (snd p)) ` (A \<times> B)) \<le> z"
    by (simp add: assms finite_cartesian_product setsum_fun_image_sup)
  thus ?thesis
    by (simp add: eq_iff)
qed

lemma flatten2_im:
  fixes f :: "'a \<Rightarrow> 'a \<Rightarrow> 'b::join_semilattice_zero"
  assumes "finite (A ::'a set)"
  and "finite (B ::'a set)"
  shows "\<Sum>((\<lambda>y. \<Sum> ((\<lambda>x. f x y) ` A)) ` B) = \<Sum>((\<lambda>p. f (fst p) (snd p)) ` (A \<times> B))"
  by (simp only: flatten1_im assms cart_flip)

lemma setsum_flatten1:
  fixes f :: "'a \<Rightarrow> 'a \<Rightarrow> 'b::join_semilattice_zero"
  assumes "finite (A :: 'a set)"
  and "finite (B :: 'a set)"
  shows "\<Sum>{\<Sum>{f x y |y. y \<in> B} |x. x \<in> A} = \<Sum>{f x y |x y. x \<in> A \<and> y \<in> B}"
 apply (simp add: fset_to_im assms flatten1_im)
 apply (subst fset_to_im[symmetric])
 apply simp
done

lemma setsum_flatten2:
  fixes f :: "'a \<Rightarrow> 'a \<Rightarrow> 'b::join_semilattice_zero"
  assumes "finite A"
  and "finite B"
  shows "\<Sum>{\<Sum> {f x y |x. x \<in> A} |y. y \<in> B} = \<Sum>{f x y |x y. x \<in> A \<and> y \<in> B}"
 apply (simp add: fset_to_im assms flatten2_im)
 apply (subst fset_to_im[symmetric])
 apply simp
done

text {* Next we show another additivity property for suprema. *}

lemma setsum_fun_sum:
  fixes f g :: "'a \<Rightarrow> 'b::join_semilattice_zero"
  assumes  "finite (A :: 'a set)"
  shows "\<Sum>((\<lambda>x. f x + g x) ` A) = \<Sum>(f ` A) + \<Sum>(g ` A)"
proof -
  {
    fix z:: 'b
    have "\<Sum>((\<lambda>x. f x + g x) ` A) \<le> z \<longleftrightarrow> \<Sum>(f ` A) + \<Sum>(g ` A) \<le> z"
      by (auto simp add: assms setsum_fun_image_sup add_lub)
  }
  thus ?thesis
    by (simp add: eq_iff)
qed

text {* The last lemma of this section prepares the distributivity
  laws that hold for dioids. It states that a strict additive function
  distributes over finite suprema, which is a continuity property in
  the finite. *}

lemma setsum_fun_add:
  fixes f :: "'a::join_semilattice_zero \<Rightarrow> 'b::join_semilattice_zero"
  assumes "finite (X :: 'a set)"
  and fstrict: "f 0 = 0"
  and fadd: "\<And>x y. f (x + y) = f x + f y"
  shows "f (\<Sum> X) = \<Sum>(f ` X)"
proof (induct rule: finite_induct[OF assms(1)])
  show "f (\<Sum>{}) = \<Sum>(f ` {})"
    by (metis fstrict image_empty setsum.empty)
  fix x :: 'a and  F ::" 'a set"
  assume finF: "finite F"
    and indhyp: "f (\<Sum>F) = \<Sum>(f ` F)"
  have "f (\<Sum>(insert x F)) = f (x + \<Sum>F)"
    by (metis setsum_insert finF)
  also have "... = f x + (f (\<Sum>F))"
    by (rule fadd)
  also have "... = f x + \<Sum>(f ` F)"
    by (metis indhyp)
  also have "... = \<Sum>(f ` (insert x F))"
    by (metis finF setsum_fun_insert)
  finally show "f (\<Sum>(insert x F)) = \<Sum>(f ` insert x F)" .
qed

subsection {* Finite Suprema in Dioids *}

text {* In this section we mainly prove variants of distributivity laws. *}

lemma setsum_distl:
  assumes "finite Y"
  shows "(x :: 'a::dioid_one_zero) \<cdot> (\<Sum>Y) = \<Sum>{x \<cdot> y|y. y \<in> Y}"
  by (simp only: setsum_fun_add assms annir distrib_left Collect_mem_eq fun_im)

lemma setsum_distr:
  assumes "finite X"
  shows "(\<Sum>X) \<cdot> (y :: 'a::dioid_one_zero) = \<Sum>{x \<cdot> y|x. x \<in> X}"
proof -
  have "(\<Sum> X) \<cdot> y = \<Sum> ((\<lambda>x. x \<cdot> y) ` X)"
    by (rule setsum_fun_add, metis assms, rule annil, rule distrib_right)
  thus ?thesis
    by (metis Collect_mem_eq fun_im)
qed

lemma setsum_fun_distl:
  fixes f :: "'a \<Rightarrow> 'b::dioid_one_zero"
  assumes "finite (Y :: 'a set)"
  shows "x \<cdot> \<Sum>(f ` Y) = \<Sum>{x \<cdot> f y |y. y \<in> Y}"
  by (simp add: assms fun_im image_image setsum_distl)

lemma setsum_fun_distr:
  fixes f :: "'a \<Rightarrow> 'b::dioid_one_zero"
  assumes "finite (X :: 'a set)"
  shows "\<Sum>(f ` X) \<cdot> y = \<Sum>{f x \<cdot> y |x. x \<in> X}"
  by (simp add: assms fun_im image_image setsum_distr)

lemma setsum_distl_flat:
  assumes "finite (X ::'a::dioid_one_zero set)"
  and "finite Y"
  shows "\<Sum>{x \<cdot> \<Sum>Y |x. x \<in> X} = \<Sum>{x \<cdot> y|x y. x \<in> X \<and> y \<in> Y}"
  by (simp only: assms setsum_distl setsum_flatten1)

lemma setsum_distr_flat:
  assumes "finite X"
  and "finite (Y :: 'a::dioid_one_zero set)"
  shows "\<Sum>{(\<Sum>X) \<cdot> y |y. y \<in> Y} = \<Sum>{x \<cdot> y|x y. x \<in> X \<and> y \<in> Y}"
  by (simp only: assms setsum_distr setsum_flatten2)

lemma setsum_sum_distl:
  assumes "finite (X :: 'a::dioid_one_zero set)"
  and "finite Y"
  shows "\<Sum>((\<lambda>x. x \<cdot> (\<Sum>Y)) ` X) = \<Sum>{x \<cdot> y |x y. x \<in> X \<and> y \<in> Y}"
proof -
  have "\<Sum>((\<lambda>x. x \<cdot> (\<Sum>Y)) ` X) = \<Sum>{\<Sum>{x \<cdot> y |y. y \<in> Y} |x. x \<in> X}"
    by (auto simp add: setsum_distl assms fset_to_im)
  thus ?thesis
    by (simp add: assms setsum_flatten1)
qed

lemma setsum_sum_distr:
  assumes "finite X"
  and "finite Y"
  shows "\<Sum>((\<lambda>y. (\<Sum>X) \<cdot> (y :: 'a::dioid_one_zero)) ` Y) = \<Sum>{x \<cdot> y|x y. x \<in> X \<and> y \<in> Y}"
proof -
  have "\<Sum>((\<lambda>y. (\<Sum>X) \<cdot> y) ` Y) = \<Sum>{\<Sum>{x \<cdot> y |x. x \<in> X} |y. y \<in> Y}"
    by (auto simp add: setsum_distr assms fset_to_im)
  thus ?thesis
    by (simp add: assms setsum_flatten2)
qed

lemma setsum_sum_distl_fun:
  fixes f g :: "'a \<Rightarrow> 'b::dioid_one_zero"
  fixes h :: "'a \<Rightarrow> 'a set"
  assumes "\<And>x. finite (h x)"
  and "finite X"
  shows "\<Sum>((\<lambda>x. f x \<cdot> \<Sum>(g ` h x)) ` X) = \<Sum>{\<Sum> {f x \<cdot> g y |y. y \<in> h x} |x. x \<in> X}"
  by (auto simp add: setsum_fun_distl assms fset_to_im)

lemma setsum_sum_distr_fun:
  fixes f g :: "'a \<Rightarrow> 'b::dioid_one_zero"
  fixes h :: "'a \<Rightarrow> 'a set"
  assumes "finite Y"
  and "\<And>y. finite (h y)"
  shows "\<Sum>((\<lambda>y. \<Sum>(f ` h y) \<cdot> g y) ` Y) = \<Sum>{\<Sum>{f x \<cdot> g y |x. x \<in> (h y)} |y. y \<in> Y}"
  by (auto simp add: setsum_fun_distr assms fset_to_im)

lemma setsum_dist:
  assumes "finite (A :: 'a::dioid_one_zero set)"
  and "finite B"
  shows "(\<Sum>A) \<cdot> (\<Sum>B) = \<Sum>{x \<cdot> y |x y. x \<in> A \<and> y \<in> B}"
proof -
  have "(\<Sum>A) \<cdot> (\<Sum>B) = \<Sum>{x \<cdot> \<Sum>B |x. x \<in> A}"
    by (simp add: assms setsum_distr)
  also have "... = \<Sum>{\<Sum>{x \<cdot> y |y. y \<in> B} |x. x \<in> A}"
    by (simp add: assms setsum_distl)
  finally show ?thesis
    by  (simp only: setsum_flatten1 assms finite_cartesian_product)
qed

lemma dioid_setsum_prod_var:
  fixes f g :: "'a \<Rightarrow> 'b::dioid_one_zero"
  assumes "finite (A ::'a set)"
  shows "(\<Sum>(f ` A)) \<cdot> (\<Sum> (g ` A)) = \<Sum>{f x \<cdot> g y |x y. x \<in> A \<and> y \<in> A}"
  by (simp add: assms setsum_dist fprod_aux)

lemma dioid_setsum_prod:
  fixes f g :: "'a \<Rightarrow> 'b::dioid_one_zero"
  assumes "finite (A :: 'a set)"
  shows "(\<Sum>{f x |x. x \<in> A}) \<cdot> (\<Sum>{g x |x. x \<in> A}) = \<Sum>{f x \<cdot> g y |x y. x \<in> A \<and> y \<in> A}"
  by (simp add: assms dioid_setsum_prod_var fset_to_im)

text {* There are interesting theorems for finite sums in Kleene
algebras; we leave them for future consideration. *}

end


theory IOL_out2 imports Main
begin
  typedecl i \<comment> \<open>type for possible worlds \<close>
  type_synonym \<tau> = "(i\<Rightarrow>bool)"
  consts r :: "i\<Rightarrow>i\<Rightarrow>bool" (infixr "r" 70)(* relation for a modal logic K *)
  abbreviation knot :: "\<tau>\<Rightarrow>\<tau>" ("\<^bold>\<not>_"[52]53) where "\<^bold>\<not>\<phi> \<equiv> \<lambda>w. \<not>\<phi>(w) "
  abbreviation kor :: "\<tau>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" (infixr "\<^bold>\<or>"50) where "\<phi>\<^bold>\<or>\<psi> \<equiv> \<lambda>w. \<phi>(w) \<or> \<psi>(w)"
  abbreviation kand :: "\<tau>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" (infixr "\<^bold>\<and>"51) where "\<phi>\<^bold>\<and>\<psi> \<equiv> \<lambda>w. \<phi>(w) \<and> \<psi>(w)"
  abbreviation kimp :: "\<tau>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" (infixr "\<^bold>\<longrightarrow>" 49) where "\<phi>\<^bold>\<longrightarrow>\<psi> \<equiv> \<lambda>w. \<phi>(w) \<longrightarrow> \<psi>(w)"
  abbreviation kvalid :: "\<tau>\<Rightarrow>bool" ("\<lfloor>_\<rfloor>" [8]109) where "\<lfloor>p\<rfloor> \<equiv> \<forall>w. p(w)"
  abbreviation kbox :: "\<tau>\<Rightarrow>\<tau>" ("\<^bold>\<box>\<^sub>k") where " \<^bold>\<box>\<^sub>k \<phi> \<equiv> \<lambda>w. \<forall>v. w r v \<longrightarrow> \<phi>(v)"
  abbreviation kdiamond :: "\<tau>\<Rightarrow>\<tau>" ("\<^bold>\<diamond>\<^sub>k") where " \<^bold>\<diamond>\<^sub>k \<phi> \<equiv> \<lambda>w. \<exists>v. w r v \<longrightarrow> \<phi>(v)"
  abbreviation ktrue  :: "\<tau>" ("\<^bold>\<top>") where "\<^bold>\<top> \<equiv> \<lambda>w. True"
  abbreviation kfalse :: "\<tau>" ("\<^bold>\<bottom>") where "\<^bold>\<bottom> \<equiv> \<lambda>w. False"

(*Idea:  x \<in> out2(G,A) iff G\<^sup>\<box>\<union>A \<turnstile>\<^sub>K\<^bold>\<box>x \<and> x \<in> Cn(G(L))  *)

locale TestExample =        (* OR example:  G = {(a,e),(b,e)}, e \<in> out2(G,{a \<or> b}) *)
  fixes a::\<tau> and b::\<tau> and e::\<tau>
 begin
 (* G\<^sup>\<box>\<union>{a \<or> b} \<turnstile>\<^sub>K \<box>e *)
 lemma "\<lfloor>((a \<^bold>\<longrightarrow>\<^bold>\<box>\<^sub>ke) \<^bold>\<and> (b\<^bold>\<longrightarrow>\<^bold>\<box>\<^sub>ke) \<^bold>\<and> (a \<^bold>\<or> b)) \<^bold>\<longrightarrow> \<^bold>\<box>\<^sub>ke  \<rfloor>" by auto
 (* e \<in> Cn(G(L)) *)
 lemma " \<lfloor> (e \<^bold>\<and> e) \<^bold>\<longrightarrow> e \<rfloor>"  by simp
 end

(*Drink and Drive Example*)
datatype indiv= Ali | Paul| Child
consts  Kill::"indiv\<Rightarrow>\<tau>" Hurt::"indiv\<Rightarrow>\<tau>" Drive_carefully::"indiv\<Rightarrow>\<tau>" Stay::"indiv\<Rightarrow>\<tau>"
               Drunk::"indiv\<Rightarrow>\<tau>" Jump::"indiv\<Rightarrow>\<tau>" Drive::"indiv\<Rightarrow>\<tau>"

locale PaulContext =
  assumes
  (* Norms *)
  A0: "\<lfloor> (\<^bold>\<top> \<^bold>\<longrightarrow> \<^bold>\<box>\<^sub>k (\<^bold>\<not> Kill Child \<^bold>\<and> \<^bold>\<not> Hurt Child )) \<rfloor>" and
  A1: "\<lfloor>  (\<^bold>\<top> \<^bold>\<longrightarrow> \<^bold>\<box>\<^sub>k ( Drive_carefully Paul ) )\<rfloor>" and
  A2: "\<lfloor>( (\<^bold>\<not>Drive_carefully Paul) \<^bold>\<longrightarrow>\<^bold>\<box>\<^sub>k(Stay Paul ) ) \<rfloor>"and
  (* Input set *)
  A3: "\<lfloor>Drunk Paul\<rfloor>" and
  A4: "\<lfloor>Drive Paul\<rfloor>"  and
  A5: "\<lfloor>Jump Child\<rfloor>" and
  A6: "\<lfloor>Drunk Paul \<^bold>\<longrightarrow> \<^bold>\<not> Drive_carefully Paul\<rfloor>" and
  A7:"\<lfloor>((\<^bold>\<not>Drive_carefully Paul) \<^bold>\<and> Drive Paul \<^bold>\<and> Jump Child )\<^bold>\<longrightarrow> ((Kill Child \<^bold>\<or> Hurt Child))\<rfloor>"
  begin
  lemma "\<lfloor>\<^bold>\<box>\<^sub>k(Stay Paul)\<rfloor>"   using A2 A3 A6 by auto
  lemma "\<lfloor>\<^bold>\<box>\<^sub>k(Drive_carefully Paul)\<^bold>\<and>(\<^bold>\<not>Drive_carefully Paul) \<rfloor>"  using A1 A3 A6 by simp
  lemma "\<lfloor>\<^bold>\<box>\<^sub>k(\<^bold>\<not>Kill Child \<^bold>\<and> \<^bold>\<not>Hurt Child ) \<^bold>\<and> (Kill Child \<^bold>\<or> Hurt Child) \<rfloor>"  using A0 A3 A4 A5 A6 A7 by simp
  lemma True  nitpick [satisfy,user_axioms,show_all,expect=genuine] oops (*consistency*)
  end

locale AliContext =
  assumes
  (* Norms *)
  A0: "\<lfloor>\<^bold>\<top> \<^bold>\<longrightarrow> \<^bold>\<box>\<^sub>k(\<^bold>\<not> Kill Child \<^bold>\<and> \<^bold>\<not> Hurt Child)\<rfloor>" and
  A1: "\<lfloor>\<^bold>\<top> \<^bold>\<longrightarrow> \<^bold>\<box>\<^sub>k(Drive_carefully Ali)\<rfloor>" and
  A2: "\<lfloor>\<^bold>\<not> Drive_carefully Ali \<^bold>\<longrightarrow> \<^bold>\<box>\<^sub>k(Stay Ali)\<rfloor>"and
  (* Input set *)
  A3: "\<lfloor>Drunk Ali\<rfloor>" and
  A4: "\<lfloor>Drive Ali\<rfloor>" and
  A6: "\<lfloor>Drunk Ali \<^bold>\<longrightarrow> \<^bold>\<not> Drive_carefully Ali\<rfloor>" and
  A7: "\<lfloor>(\<^bold>\<not> Drive_carefully Ali \<^bold>\<and> Drive Ali \<^bold>\<and> Jump Child) \<^bold>\<longrightarrow> (Kill Child \<^bold>\<or> Hurt Child)\<rfloor>"
  begin
  lemma "\<lfloor>\<^bold>\<box>\<^sub>k(Stay Ali)\<rfloor>"   using A2 A3 A6 by simp
  lemma "\<lfloor>\<^bold>\<box>\<^sub>k(Drive_carefully Ali) \<^bold>\<and> \<^bold>\<not> Drive_carefully Ali\<rfloor>"  using A1 A3 A6 by simp
  lemma"\<lfloor>\<^bold>\<box>\<^sub>k(\<^bold>\<not>Kill Child \<^bold>\<and> \<^bold>\<not>Hurt Child) \<^bold>\<and> (Kill Child \<^bold>\<or> Hurt Child)\<rfloor>" nitpick [user_axioms] oops (*countermodel*)
  lemma True  nitpick [satisfy,user_axioms,show_all,expect=genuine] oops (*consistency*)
  end

end