author ballarin Tue Jul 29 16:19:49 2008 +0200 (2008-07-29) changeset 27701 ed7a2e0fab59 parent 27700 ef4b26efa8b6 child 27702 80608e96e760
New theory on divisibility.
 src/HOL/Algebra/Congruence.thy file | annotate | diff | revisions src/HOL/Algebra/Divisibility.thy file | annotate | diff | revisions src/HOL/Algebra/GLattice.thy file | annotate | diff | revisions
     1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/src/HOL/Algebra/Congruence.thy	Tue Jul 29 16:19:49 2008 +0200
1.3 @@ -0,0 +1,407 @@
1.4 +(*
1.5 +  Title:  Algebra/Congruence.thy
1.6 +  Id:     $Id$
1.7 +  Author: Clemens Ballarin, started 3 January 2008
1.9 +*)
1.10 +
1.11 +theory Congruence imports Main begin
1.12 +
1.13 +section {* Objects *}
1.14 +
1.15 +text {* Structure with a carrier set. *}
1.16 +
1.17 +record 'a partial_object =
1.18 +  carrier :: "'a set"
1.19 +
1.20 +text {* Dito with equivalence relation *}
1.21 +
1.22 +record 'a eq_object = "'a partial_object" +
1.23 +  eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl ".=\<index>" 50)
1.24 +
1.25 +constdefs (structure S)
1.26 +  elem :: "_ \<Rightarrow> 'a \<Rightarrow> 'a set \<Rightarrow> bool" (infixl ".\<in>\<index>" 50)
1.27 +  "x .\<in> A \<equiv> (\<exists>y \<in> A. x .= y)"
1.28 +
1.29 +  set_eq :: "_ \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> bool" (infixl "{.=}\<index>" 50)
1.30 +  "A {.=} B == ((\<forall>x \<in> A. x .\<in> B) \<and> (\<forall>x \<in> B. x .\<in> A))"
1.31 +
1.32 +  eq_class_of :: "_ \<Rightarrow> 'a \<Rightarrow> 'a set" ("class'_of\<index> _")
1.33 +  "class_of x == {y \<in> carrier S. x .= y}"
1.34 +
1.35 +  eq_closure_of :: "_ \<Rightarrow> 'a set \<Rightarrow> 'a set" ("closure'_of\<index> _")
1.36 +  "closure_of A == {y \<in> carrier S. y .\<in> A}"
1.37 +
1.38 +  eq_is_closed :: "_ \<Rightarrow> 'a set \<Rightarrow> bool" ("is'_closed\<index> _")
1.39 +  "is_closed A == (A \<subseteq> carrier S \<and> closure_of A = A)"
1.40 +
1.41 +syntax
1.42 +  not_eq :: "_ \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl ".\<noteq>\<index>" 50)
1.43 +  not_elem :: "_ \<Rightarrow> 'a \<Rightarrow> 'a set \<Rightarrow> bool" (infixl ".\<notin>\<index>" 50)
1.44 +  set_not_eq :: "_ \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> bool" (infixl "{.\<noteq>}\<index>" 50)
1.45 +
1.46 +translations
1.47 +  "x .\<noteq>\<index> y" == "~(x .=\<index> y)"
1.48 +  "x .\<notin>\<index> A" == "~(x .\<in>\<index> A)"
1.49 +  "A {.\<noteq>}\<index> B" == "~(A {.=}\<index> B)"
1.50 +
1.51 +
1.52 +section {* Equivalence Relations *}
1.53 +
1.54 +locale equivalence =
1.55 +  fixes S (structure)
1.56 +  assumes refl [simp, intro]: "x \<in> carrier S \<Longrightarrow> x .= x"
1.57 +    and sym [sym]: "\<lbrakk> x .= y; x \<in> carrier S; y \<in> carrier S \<rbrakk> \<Longrightarrow> y .= x"
1.58 +    and trans [trans]: "\<lbrakk> x .= y; y .= z; x \<in> carrier S; y \<in> carrier S; z \<in> carrier S \<rbrakk> \<Longrightarrow> x .= z"
1.59 +
1.60 +lemma elemI:
1.61 +  fixes R (structure)
1.62 +  assumes "a' \<in> A" and "a .= a'"
1.63 +  shows "a .\<in> A"
1.64 +unfolding elem_def
1.65 +using assms
1.66 +by fast
1.67 +
1.68 +lemma (in equivalence) elem_exact:
1.69 +  assumes "a \<in> carrier S" and "a \<in> A"
1.70 +  shows "a .\<in> A"
1.71 +using assms
1.72 +by (fast intro: elemI)
1.73 +
1.74 +lemma elemE:
1.75 +  fixes S (structure)
1.76 +  assumes "a .\<in> A"
1.77 +    and "\<And>a'. \<lbrakk>a' \<in> A; a .= a'\<rbrakk> \<Longrightarrow> P"
1.78 +  shows "P"
1.79 +using assms
1.80 +unfolding elem_def
1.81 +by fast
1.82 +
1.83 +lemma (in equivalence) elem_cong_l [trans]:
1.84 +  assumes cong: "a' .= a"
1.85 +    and a: "a .\<in> A"
1.86 +    and carr: "a \<in> carrier S"  "a' \<in> carrier S"
1.87 +    and Acarr: "A \<subseteq> carrier S"
1.88 +  shows "a' .\<in> A"
1.89 +using a
1.90 +apply (elim elemE, intro elemI)
1.91 +proof assumption
1.92 +  fix b
1.93 +  assume bA: "b \<in> A"
1.94 +  note [simp] = carr bA[THEN subsetD[OF Acarr]]
1.95 +  note cong
1.96 +  also assume "a .= b"
1.97 +  finally show "a' .= b" by simp
1.98 +qed
1.99 +
1.100 +lemma (in equivalence) elem_subsetD:
1.101 +  assumes "A \<subseteq> B"
1.102 +    and aA: "a .\<in> A"
1.103 +  shows "a .\<in> B"
1.104 +using assms
1.105 +by (fast intro: elemI elim: elemE dest: subsetD)
1.106 +
1.107 +lemma (in equivalence) mem_imp_elem [simp, intro]:
1.108 +  "[| x \<in> A; x \<in> carrier S |] ==> x .\<in> A"
1.109 +  unfolding elem_def by blast
1.110 +
1.111 +lemma set_eqI:
1.112 +  fixes R (structure)
1.113 +  assumes ltr: "\<And>a. a \<in> A \<Longrightarrow> a .\<in> B"
1.114 +    and rtl: "\<And>b. b \<in> B \<Longrightarrow> b .\<in> A"
1.115 +  shows "A {.=} B"
1.116 +unfolding set_eq_def
1.117 +by (fast intro: ltr rtl)
1.118 +
1.119 +lemma set_eqI2:
1.120 +  fixes R (structure)
1.121 +  assumes ltr: "\<And>a b. a \<in> A \<Longrightarrow> \<exists>b\<in>B. a .= b"
1.122 +    and rtl: "\<And>b. b \<in> B \<Longrightarrow> \<exists>a\<in>A. b .= a"
1.123 +  shows "A {.=} B"
1.124 +  by (intro set_eqI, unfold elem_def) (fast intro: ltr rtl)+
1.125 +
1.126 +lemma set_eqD1:
1.127 +  fixes R (structure)
1.128 +  assumes AA': "A {.=} A'"
1.129 +    and "a \<in> A"
1.130 +  shows "\<exists>a'\<in>A'. a .= a'"
1.131 +using assms
1.132 +unfolding set_eq_def elem_def
1.133 +by fast
1.134 +
1.135 +lemma set_eqD2:
1.136 +  fixes R (structure)
1.137 +  assumes AA': "A {.=} A'"
1.138 +    and "a' \<in> A'"
1.139 +  shows "\<exists>a\<in>A. a' .= a"
1.140 +using assms
1.141 +unfolding set_eq_def elem_def
1.142 +by fast
1.143 +
1.144 +lemma set_eqE:
1.145 +  fixes R (structure)
1.146 +  assumes AB: "A {.=} B"
1.147 +    and r: "\<lbrakk>\<forall>a\<in>A. a .\<in> B; \<forall>b\<in>B. b .\<in> A\<rbrakk> \<Longrightarrow> P"
1.148 +  shows "P"
1.149 +using AB
1.150 +unfolding set_eq_def
1.151 +by (blast dest: r)
1.152 +
1.153 +lemma set_eqE2:
1.154 +  fixes R (structure)
1.155 +  assumes AB: "A {.=} B"
1.156 +    and r: "\<lbrakk>\<forall>a\<in>A. (\<exists>b\<in>B. a .= b); \<forall>b\<in>B. (\<exists>a\<in>A. b .= a)\<rbrakk> \<Longrightarrow> P"
1.157 +  shows "P"
1.158 +using AB
1.159 +unfolding set_eq_def elem_def
1.160 +by (blast dest: r)
1.161 +
1.162 +lemma set_eqE':
1.163 +  fixes R (structure)
1.164 +  assumes AB: "A {.=} B"
1.165 +    and aA: "a \<in> A" and bB: "b \<in> B"
1.166 +    and r: "\<And>a' b'. \<lbrakk>a' \<in> A; b .= a'; b' \<in> B; a .= b'\<rbrakk> \<Longrightarrow> P"
1.167 +  shows "P"
1.168 +proof -
1.169 +  from AB aA
1.170 +      have "\<exists>b'\<in>B. a .= b'" by (rule set_eqD1)
1.171 +  from this obtain b'
1.172 +      where b': "b' \<in> B" "a .= b'" by auto
1.173 +
1.174 +  from AB bB
1.175 +      have "\<exists>a'\<in>A. b .= a'" by (rule set_eqD2)
1.176 +  from this obtain a'
1.177 +      where a': "a' \<in> A" "b .= a'" by auto
1.178 +
1.179 +  from a' b'
1.180 +      show "P" by (rule r)
1.181 +qed
1.182 +
1.183 +lemma (in equivalence) eq_elem_cong_r [trans]:
1.184 +  assumes a: "a .\<in> A"
1.185 +    and cong: "A {.=} A'"
1.186 +    and carr: "a \<in> carrier S"
1.187 +    and Carr: "A \<subseteq> carrier S" "A' \<subseteq> carrier S"
1.188 +  shows "a .\<in> A'"
1.189 +using a cong
1.190 +proof (elim elemE set_eqE)
1.191 +  fix b
1.192 +  assume bA: "b \<in> A"
1.193 +     and inA': "\<forall>b\<in>A. b .\<in> A'"
1.194 +  note [simp] = carr Carr Carr[THEN subsetD] bA
1.195 +  assume "a .= b"
1.196 +  also from bA inA'
1.197 +       have "b .\<in> A'" by fast
1.198 +  finally
1.199 +       show "a .\<in> A'" by simp
1.200 +qed
1.201 +
1.202 +lemma (in equivalence) set_eq_sym [sym]:
1.203 +  assumes "A {.=} B"
1.204 +    and "A \<subseteq> carrier S" "B \<subseteq> carrier S"
1.205 +  shows "B {.=} A"
1.206 +using assms
1.207 +unfolding set_eq_def elem_def
1.208 +by fast
1.209 +
1.210 +(* FIXME: the following two required in Isabelle 2008, not Isabelle 2007 *)
1.211 +
1.212 +lemma (in equivalence) equal_set_eq_trans [trans]:
1.213 +  assumes AB: "A = B" and BC: "B {.=} C"
1.214 +  shows "A {.=} C"
1.215 +  using AB BC by simp
1.216 +
1.217 +lemma (in equivalence) set_eq_equal_trans [trans]:
1.218 +  assumes AB: "A {.=} B" and BC: "B = C"
1.219 +  shows "A {.=} C"
1.220 +  using AB BC by simp
1.221 +
1.222 +lemma (in equivalence) set_eq_trans [trans]:
1.223 +  assumes AB: "A {.=} B" and BC: "B {.=} C"
1.224 +    and carr: "A \<subseteq> carrier S"  "B \<subseteq> carrier S"  "C \<subseteq> carrier S"
1.225 +  shows "A {.=} C"
1.226 +proof (intro set_eqI)
1.227 +  fix a
1.228 +  assume aA: "a \<in> A"
1.229 +  with carr have "a \<in> carrier S" by fast
1.230 +  note [simp] = carr this
1.231 +
1.232 +  from aA
1.233 +       have "a .\<in> A" by (simp add: elem_exact)
1.234 +  also note AB
1.235 +  also note BC
1.236 +  finally
1.237 +       show "a .\<in> C" by simp
1.238 +next
1.239 +  fix c
1.240 +  assume cC: "c \<in> C"
1.241 +  with carr have "c \<in> carrier S" by fast
1.242 +  note [simp] = carr this
1.243 +
1.244 +  from cC
1.245 +       have "c .\<in> C" by (simp add: elem_exact)
1.246 +  also note BC[symmetric]
1.247 +  also note AB[symmetric]
1.248 +  finally
1.249 +       show "c .\<in> A" by simp
1.250 +qed
1.251 +
1.252 +(* FIXME: generalise for insert *)
1.253 +
1.254 +(*
1.255 +lemma (in equivalence) set_eq_insert:
1.256 +  assumes x: "x .= x'"
1.257 +    and carr: "x \<in> carrier S" "x' \<in> carrier S" "A \<subseteq> carrier S"
1.258 +  shows "insert x A {.=} insert x' A"
1.259 +  unfolding set_eq_def elem_def
1.260 +apply rule
1.261 +apply rule
1.262 +apply (case_tac "xa = x")
1.263 +using x apply fast
1.264 +apply (subgoal_tac "xa \<in> A") prefer 2 apply fast
1.265 +apply (rule_tac x=xa in bexI)
1.266 +using carr apply (rule_tac refl) apply auto [1]
1.267 +apply safe
1.268 +*)
1.269 +
1.270 +lemma (in equivalence) set_eq_pairI:
1.271 +  assumes xx': "x .= x'"
1.272 +    and carr: "x \<in> carrier S" "x' \<in> carrier S" "y \<in> carrier S"
1.273 +  shows "{x, y} {.=} {x', y}"
1.274 +unfolding set_eq_def elem_def
1.275 +proof safe
1.276 +  have "x' \<in> {x', y}" by fast
1.277 +  with xx' show "\<exists>b\<in>{x', y}. x .= b" by fast
1.278 +next
1.279 +  have "y \<in> {x', y}" by fast
1.280 +  with carr show "\<exists>b\<in>{x', y}. y .= b" by fast
1.281 +next
1.282 +  have "x \<in> {x, y}" by fast
1.283 +  with xx'[symmetric] carr
1.284 +  show "\<exists>a\<in>{x, y}. x' .= a" by fast
1.285 +next
1.286 +  have "y \<in> {x, y}" by fast
1.287 +  with carr show "\<exists>a\<in>{x, y}. y .= a" by fast
1.288 +qed
1.289 +
1.290 +lemma (in equivalence) is_closedI:
1.291 +  assumes closed: "!!x y. [| x .= y; x \<in> A; y \<in> carrier S |] ==> y \<in> A"
1.292 +    and S: "A \<subseteq> carrier S"
1.293 +  shows "is_closed A"
1.294 +  unfolding eq_is_closed_def eq_closure_of_def elem_def
1.295 +  using S
1.296 +  by (blast dest: closed sym)
1.297 +
1.298 +lemma (in equivalence) closure_of_eq:
1.299 +  "[| x .= x'; A \<subseteq> carrier S; x \<in> closure_of A; x \<in> carrier S; x' \<in> carrier S |] ==> x' \<in> closure_of A"
1.300 +  unfolding eq_closure_of_def elem_def
1.301 +  by (blast intro: trans sym)
1.302 +
1.303 +lemma (in equivalence) is_closed_eq [dest]:
1.304 +  "[| x .= x'; x \<in> A; is_closed A; x \<in> carrier S; x' \<in> carrier S |] ==> x' \<in> A"
1.305 +  unfolding eq_is_closed_def
1.306 +  using closure_of_eq [where A = A]
1.307 +  by simp
1.308 +
1.309 +lemma (in equivalence) is_closed_eq_rev [dest]:
1.310 +  "[| x .= x'; x' \<in> A; is_closed A; x \<in> carrier S; x' \<in> carrier S |] ==> x \<in> A"
1.311 +  by (drule sym) (simp_all add: is_closed_eq)
1.312 +
1.313 +lemma closure_of_closed [simp, intro]:
1.314 +  fixes S (structure)
1.315 +  shows "closure_of A \<subseteq> carrier S"
1.316 +unfolding eq_closure_of_def
1.317 +by fast
1.318 +
1.319 +lemma closure_of_memI:
1.320 +  fixes S (structure)
1.321 +  assumes "a .\<in> A"
1.322 +    and "a \<in> carrier S"
1.323 +  shows "a \<in> closure_of A"
1.324 +unfolding eq_closure_of_def
1.325 +using assms
1.326 +by fast
1.327 +
1.328 +lemma closure_ofI2:
1.329 +  fixes S (structure)
1.330 +  assumes "a .= a'"
1.331 +    and "a' \<in> A"
1.332 +    and "a \<in> carrier S"
1.333 +  shows "a \<in> closure_of A"
1.334 +unfolding eq_closure_of_def elem_def
1.335 +using assms
1.336 +by fast
1.337 +
1.338 +lemma closure_of_memE:
1.339 +  fixes S (structure)
1.340 +  assumes p: "a \<in> closure_of A"
1.341 +    and r: "\<lbrakk>a \<in> carrier S; a .\<in> A\<rbrakk> \<Longrightarrow> P"
1.342 +  shows "P"
1.343 +proof -
1.344 +  from p
1.345 +      have acarr: "a \<in> carrier S"
1.346 +      and "a .\<in> A"
1.347 +      by (simp add: eq_closure_of_def)+
1.348 +  thus "P" by (rule r)
1.349 +qed
1.350 +
1.351 +lemma closure_ofE2:
1.352 +  fixes S (structure)
1.353 +  assumes p: "a \<in> closure_of A"
1.354 +    and r: "\<And>a'. \<lbrakk>a \<in> carrier S; a' \<in> A; a .= a'\<rbrakk> \<Longrightarrow> P"
1.355 +  shows "P"
1.356 +proof -
1.357 +  from p have acarr: "a \<in> carrier S" by (simp add: eq_closure_of_def)
1.358 +
1.359 +  from p have "\<exists>a'\<in>A. a .= a'" by (simp add: eq_closure_of_def elem_def)
1.360 +  from this obtain a'
1.361 +      where "a' \<in> A" and "a .= a'" by auto
1.362 +
1.363 +  from acarr and this
1.364 +      show "P" by (rule r)
1.365 +qed
1.366 +
1.367 +(*
1.368 +lemma (in equivalence) classes_consistent:
1.369 +  assumes Acarr: "A \<subseteq> carrier S"
1.370 +  shows "is_closed (closure_of A)"
1.371 +apply (blast intro: elemI elim elemE)
1.372 +using assms
1.373 +apply (intro is_closedI closure_of_memI, simp)
1.374 + apply (elim elemE closure_of_memE)
1.375 +proof -
1.376 +  fix x a' a''
1.377 +  assume carr: "x \<in> carrier S" "a' \<in> carrier S"
1.378 +  assume a''A: "a'' \<in> A"
1.379 +  with Acarr have "a'' \<in> carrier S" by fast
1.380 +  note [simp] = carr this Acarr
1.381 +
1.382 +  assume "x .= a'"
1.383 +  also assume "a' .= a''"
1.384 +  also from a''A
1.385 +       have "a'' .\<in> A" by (simp add: elem_exact)
1.386 +  finally show "x .\<in> A" by simp
1.387 +qed
1.388 +*)
1.389 +(*
1.390 +lemma (in equivalence) classes_small:
1.391 +  assumes "is_closed B"
1.392 +    and "A \<subseteq> B"
1.393 +  shows "closure_of A \<subseteq> B"
1.394 +using assms
1.395 +by (blast dest: is_closedD2 elem_subsetD elim: closure_of_memE)
1.396 +
1.397 +lemma (in equivalence) classes_eq:
1.398 +  assumes "A \<subseteq> carrier S"
1.399 +  shows "A {.=} closure_of A"
1.400 +using assms
1.401 +by (blast intro: set_eqI elem_exact closure_of_memI elim: closure_of_memE)
1.402 +
1.403 +lemma (in equivalence) complete_classes:
1.404 +  assumes c: "is_closed A"
1.405 +  shows "A = closure_of A"
1.406 +using assms
1.407 +by (blast intro: closure_of_memI elem_exact dest: is_closedD1 is_closedD2 closure_of_memE)
1.408 +*)
1.409 +
1.410 +end

     2.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
2.2 +++ b/src/HOL/Algebra/Divisibility.thy	Tue Jul 29 16:19:49 2008 +0200
2.3 @@ -0,0 +1,3931 @@
2.4 +(*
2.5 +  Title:     Divisibility in monoids and rings
2.6 +  Id:        $Id$
2.7 +  Author:    Clemens Ballarin, started 18 July 2008
2.9 +*)
2.10 +
2.11 +theory Divisibility
2.12 +imports Permutation Coset Group GLattice
2.13 +begin
2.14 +
2.15 +subsection {* Monoid with cancelation law *}
2.16 +
2.17 +locale monoid_cancel = monoid +
2.18 +  assumes l_cancel:
2.19 +          "\<lbrakk>c \<otimes> a = c \<otimes> b; a \<in> carrier G; b \<in> carrier G; c \<in> carrier G\<rbrakk> \<Longrightarrow> a = b"
2.20 +      and r_cancel:
2.21 +          "\<lbrakk>a \<otimes> c = b \<otimes> c; a \<in> carrier G; b \<in> carrier G; c \<in> carrier G\<rbrakk> \<Longrightarrow> a = b"
2.22 +
2.23 +lemma (in monoid) monoid_cancelI:
2.24 +  assumes l_cancel:
2.25 +          "\<And>a b c. \<lbrakk>c \<otimes> a = c \<otimes> b; a \<in> carrier G; b \<in> carrier G; c \<in> carrier G\<rbrakk> \<Longrightarrow> a = b"
2.26 +      and r_cancel:
2.27 +          "\<And>a b c. \<lbrakk>a \<otimes> c = b \<otimes> c; a \<in> carrier G; b \<in> carrier G; c \<in> carrier G\<rbrakk> \<Longrightarrow> a = b"
2.28 +  shows "monoid_cancel G"
2.29 +by unfold_locales fact+
2.30 +
2.31 +lemma (in monoid_cancel) is_monoid_cancel:
2.32 +  "monoid_cancel G"
2.33 +by intro_locales
2.34 +
2.35 +interpretation group \<subseteq> monoid_cancel
2.36 +by unfold_locales simp+
2.37 +
2.38 +
2.39 +locale comm_monoid_cancel = monoid_cancel + comm_monoid
2.40 +
2.41 +lemma comm_monoid_cancelI:
2.42 +  includes comm_monoid
2.43 +  assumes cancel:
2.44 +          "\<And>a b c. \<lbrakk>a \<otimes> c = b \<otimes> c; a \<in> carrier G; b \<in> carrier G; c \<in> carrier G\<rbrakk> \<Longrightarrow> a = b"
2.45 +  shows "comm_monoid_cancel G"
2.46 +apply unfold_locales
2.47 + apply (subgoal_tac "a \<otimes> c = b \<otimes> c")
2.48 +  apply (iprover intro: cancel)
2.49 + apply (simp add: m_comm)
2.50 +apply (iprover intro: cancel)
2.51 +done
2.52 +
2.53 +lemma (in comm_monoid_cancel) is_comm_monoid_cancel:
2.54 +  "comm_monoid_cancel G"
2.55 +by intro_locales
2.56 +
2.57 +interpretation comm_group \<subseteq> comm_monoid_cancel
2.58 +by unfold_locales
2.59 +
2.60 +
2.61 +subsection {* Products of units in monoids *}
2.62 +
2.63 +lemma (in monoid) Units_m_closed[simp, intro]:
2.64 +  assumes h1unit: "h1 \<in> Units G" and h2unit: "h2 \<in> Units G"
2.65 +  shows "h1 \<otimes> h2 \<in> Units G"
2.66 +unfolding Units_def
2.67 +using assms
2.68 +apply safe
2.69 +apply fast
2.70 +apply (intro bexI[of _ "inv h2 \<otimes> inv h1"], safe)
2.71 +  apply (simp add: m_assoc Units_closed)
2.72 +  apply (simp add: m_assoc[symmetric] Units_closed Units_l_inv)
2.73 + apply (simp add: m_assoc Units_closed)
2.74 + apply (simp add: m_assoc[symmetric] Units_closed Units_r_inv)
2.75 +apply fast
2.76 +done
2.77 +
2.78 +lemma (in monoid) prod_unit_l:
2.79 +  assumes abunit[simp]: "a \<otimes> b \<in> Units G" and aunit[simp]: "a \<in> Units G"
2.80 +    and carr[simp]: "a \<in> carrier G"  "b \<in> carrier G"
2.81 +  shows "b \<in> Units G"
2.82 +proof -
2.83 +  have c: "inv (a \<otimes> b) \<otimes> a \<in> carrier G" by simp
2.84 +
2.85 +  have "(inv (a \<otimes> b) \<otimes> a) \<otimes> b = inv (a \<otimes> b) \<otimes> (a \<otimes> b)" by (simp add: m_assoc)
2.86 +  also have "\<dots> = \<one>" by (simp add: Units_l_inv)
2.87 +  finally have li: "(inv (a \<otimes> b) \<otimes> a) \<otimes> b = \<one>" .
2.88 +
2.89 +  have "\<one> = inv a \<otimes> a" by (simp add: Units_l_inv[symmetric])
2.90 +  also have "\<dots> = inv a \<otimes> \<one> \<otimes> a" by simp
2.91 +  also have "\<dots> = inv a \<otimes> ((a \<otimes> b) \<otimes> inv (a \<otimes> b)) \<otimes> a"
2.92 +       by (simp add: Units_r_inv[OF abunit, symmetric] del: Units_r_inv)
2.93 +  also have "\<dots> = ((inv a \<otimes> a) \<otimes> b) \<otimes> inv (a \<otimes> b) \<otimes> a"
2.94 +    by (simp add: m_assoc del: Units_l_inv)
2.95 +  also have "\<dots> = b \<otimes> inv (a \<otimes> b) \<otimes> a" by (simp add: Units_l_inv)
2.96 +  also have "\<dots> = b \<otimes> (inv (a \<otimes> b) \<otimes> a)" by (simp add: m_assoc)
2.97 +  finally have ri: "b \<otimes> (inv (a \<otimes> b) \<otimes> a) = \<one> " by simp
2.98 +
2.99 +  from c li ri
2.100 +      show "b \<in> Units G" by (simp add: Units_def, fast)
2.101 +qed
2.102 +
2.103 +lemma (in monoid) prod_unit_r:
2.104 +  assumes abunit[simp]: "a \<otimes> b \<in> Units G" and bunit[simp]: "b \<in> Units G"
2.105 +    and carr[simp]: "a \<in> carrier G"  "b \<in> carrier G"
2.106 +  shows "a \<in> Units G"
2.107 +proof -
2.108 +  have c: "b \<otimes> inv (a \<otimes> b) \<in> carrier G" by simp
2.109 +
2.110 +  have "a \<otimes> (b \<otimes> inv (a \<otimes> b)) = (a \<otimes> b) \<otimes> inv (a \<otimes> b)"
2.111 +    by (simp add: m_assoc del: Units_r_inv)
2.112 +  also have "\<dots> = \<one>" by simp
2.113 +  finally have li: "a \<otimes> (b \<otimes> inv (a \<otimes> b)) = \<one>" .
2.114 +
2.115 +  have "\<one> = b \<otimes> inv b" by (simp add: Units_r_inv[symmetric])
2.116 +  also have "\<dots> = b \<otimes> \<one> \<otimes> inv b" by simp
2.117 +  also have "\<dots> = b \<otimes> (inv (a \<otimes> b) \<otimes> (a \<otimes> b)) \<otimes> inv b"
2.118 +       by (simp add: Units_l_inv[OF abunit, symmetric] del: Units_l_inv)
2.119 +  also have "\<dots> = (b \<otimes> inv (a \<otimes> b) \<otimes> a) \<otimes> (b \<otimes> inv b)"
2.120 +    by (simp add: m_assoc del: Units_l_inv)
2.121 +  also have "\<dots> = b \<otimes> inv (a \<otimes> b) \<otimes> a" by simp
2.122 +  finally have ri: "(b \<otimes> inv (a \<otimes> b)) \<otimes> a = \<one> " by simp
2.123 +
2.124 +  from c li ri
2.125 +      show "a \<in> Units G" by (simp add: Units_def, fast)
2.126 +qed
2.127 +
2.128 +lemma (in comm_monoid) unit_factor:
2.129 +  assumes abunit: "a \<otimes> b \<in> Units G"
2.130 +    and [simp]: "a \<in> carrier G"  "b \<in> carrier G"
2.131 +  shows "a \<in> Units G"
2.132 +using abunit[simplified Units_def]
2.133 +proof clarsimp
2.134 +  fix i
2.135 +  assume [simp]: "i \<in> carrier G"
2.136 +    and li: "i \<otimes> (a \<otimes> b) = \<one>"
2.137 +    and ri: "a \<otimes> b \<otimes> i = \<one>"
2.138 +
2.139 +  have carr': "b \<otimes> i \<in> carrier G" by simp
2.140 +
2.141 +  have "(b \<otimes> i) \<otimes> a = (i \<otimes> b) \<otimes> a" by (simp add: m_comm)
2.142 +  also have "\<dots> = i \<otimes> (b \<otimes> a)" by (simp add: m_assoc)
2.143 +  also have "\<dots> = i \<otimes> (a \<otimes> b)" by (simp add: m_comm)
2.144 +  also note li
2.145 +  finally have li': "(b \<otimes> i) \<otimes> a = \<one>" .
2.146 +
2.147 +  have "a \<otimes> (b \<otimes> i) = a \<otimes> b \<otimes> i" by (simp add: m_assoc)
2.148 +  also note ri
2.149 +  finally have ri': "a \<otimes> (b \<otimes> i) = \<one>" .
2.150 +
2.151 +  from carr' li' ri'
2.152 +      show "a \<in> Units G" by (simp add: Units_def, fast)
2.153 +qed
2.154 +
2.155 +subsection {* Divisibility and association *}
2.156 +
2.157 +subsubsection {* Function definitions *}
2.158 +
2.159 +constdefs (structure G)
2.160 +  factor :: "[_, 'a, 'a] \<Rightarrow> bool" (infix "divides\<index>" 65)
2.161 +  "a divides b == \<exists>c\<in>carrier G. b = a \<otimes> c"
2.162 +
2.163 +constdefs (structure G)
2.164 +  associated :: "[_, 'a, 'a] => bool" (infix "\<sim>\<index>" 55)
2.165 +  "a \<sim> b == a divides b \<and> b divides a"
2.166 +
2.167 +abbreviation
2.168 +  "division_rel G == \<lparr>carrier = carrier G, eq = op \<sim>\<^bsub>G\<^esub>, le = op divides\<^bsub>G\<^esub>\<rparr>"
2.169 +
2.170 +constdefs (structure G)
2.171 +  properfactor :: "[_, 'a, 'a] \<Rightarrow> bool"
2.172 +  "properfactor G a b == a divides b \<and> \<not>(b divides a)"
2.173 +
2.174 +constdefs (structure G)
2.175 +  irreducible :: "[_, 'a] \<Rightarrow> bool"
2.176 +  "irreducible G a == a \<notin> Units G \<and> (\<forall>b\<in>carrier G. properfactor G b a \<longrightarrow> b \<in> Units G)"
2.177 +
2.178 +constdefs (structure G)
2.179 +  prime :: "[_, 'a] \<Rightarrow> bool"
2.180 +  "prime G p == p \<notin> Units G \<and>
2.181 +                (\<forall>a\<in>carrier G. \<forall>b\<in>carrier G. p divides (a \<otimes> b) \<longrightarrow> p divides a \<or> p divides b)"
2.182 +
2.183 +
2.184 +
2.185 +subsubsection {* Divisibility *}
2.186 +
2.187 +lemma dividesI:
2.188 +  fixes G (structure)
2.189 +  assumes carr: "c \<in> carrier G"
2.190 +    and p: "b = a \<otimes> c"
2.191 +  shows "a divides b"
2.192 +unfolding factor_def
2.193 +using assms by fast
2.194 +
2.195 +lemma dividesI' [intro]:
2.196 +   fixes G (structure)
2.197 +  assumes p: "b = a \<otimes> c"
2.198 +    and carr: "c \<in> carrier G"
2.199 +  shows "a divides b"
2.200 +using assms
2.201 +by (fast intro: dividesI)
2.202 +
2.203 +lemma dividesD:
2.204 +  fixes G (structure)
2.205 +  assumes "a divides b"
2.206 +  shows "\<exists>c\<in>carrier G. b = a \<otimes> c"
2.207 +using assms
2.208 +unfolding factor_def
2.209 +by fast
2.210 +
2.211 +lemma dividesE [elim]:
2.212 +  fixes G (structure)
2.213 +  assumes d: "a divides b"
2.214 +    and elim: "\<And>c. \<lbrakk>b = a \<otimes> c; c \<in> carrier G\<rbrakk> \<Longrightarrow> P"
2.215 +  shows "P"
2.216 +proof -
2.217 +  from dividesD[OF d]
2.218 +      obtain c
2.219 +      where "c\<in>carrier G"
2.220 +      and "b = a \<otimes> c"
2.221 +      by auto
2.222 +  thus "P" by (elim elim)
2.223 +qed
2.224 +
2.225 +lemma (in monoid) divides_refl[simp, intro!]:
2.226 +  assumes carr: "a \<in> carrier G"
2.227 +  shows "a divides a"
2.228 +apply (intro dividesI[of "\<one>"])
2.229 +apply (simp, simp add: carr)
2.230 +done
2.231 +
2.232 +lemma (in monoid) divides_trans [trans]:
2.233 +  assumes dvds: "a divides b"  "b divides c"
2.234 +    and acarr: "a \<in> carrier G"
2.235 +  shows "a divides c"
2.236 +using dvds[THEN dividesD]
2.237 +by (blast intro: dividesI m_assoc acarr)
2.238 +
2.239 +lemma (in monoid) divides_mult_lI [intro]:
2.240 +  assumes ab: "a divides b"
2.241 +    and carr: "a \<in> carrier G"  "b \<in> carrier G"  "c \<in> carrier G"
2.242 +  shows "(c \<otimes> a) divides (c \<otimes> b)"
2.243 +using ab
2.244 +apply (elim dividesE, simp add: m_assoc[symmetric] carr)
2.245 +apply (fast intro: dividesI)
2.246 +done
2.247 +
2.248 +lemma (in monoid_cancel) divides_mult_l [simp]:
2.249 +  assumes carr: "a \<in> carrier G"  "b \<in> carrier G"  "c \<in> carrier G"
2.250 +  shows "(c \<otimes> a) divides (c \<otimes> b) = a divides b"
2.251 +apply safe
2.252 + apply (elim dividesE, intro dividesI, assumption)
2.253 + apply (rule l_cancel[of c])
2.254 +    apply (simp add: m_assoc carr)+
2.255 +apply (fast intro: divides_mult_lI carr)
2.256 +done
2.257 +
2.258 +lemma (in comm_monoid) divides_mult_rI [intro]:
2.259 +  assumes ab: "a divides b"
2.260 +    and carr: "a \<in> carrier G"  "b \<in> carrier G"  "c \<in> carrier G"
2.261 +  shows "(a \<otimes> c) divides (b \<otimes> c)"
2.262 +using carr ab
2.263 +apply (simp add: m_comm[of a c] m_comm[of b c])
2.264 +apply (rule divides_mult_lI, assumption+)
2.265 +done
2.266 +
2.267 +lemma (in comm_monoid_cancel) divides_mult_r [simp]:
2.268 +  assumes carr: "a \<in> carrier G"  "b \<in> carrier G"  "c \<in> carrier G"
2.269 +  shows "(a \<otimes> c) divides (b \<otimes> c) = a divides b"
2.270 +using carr
2.271 +by (simp add: m_comm[of a c] m_comm[of b c])
2.272 +
2.273 +lemma (in monoid) divides_prod_r:
2.274 +  assumes ab: "a divides b"
2.275 +    and carr: "a \<in> carrier G"  "b \<in> carrier G"  "c \<in> carrier G"
2.276 +  shows "a divides (b \<otimes> c)"
2.277 +using ab carr
2.278 +by (fast intro: m_assoc)
2.279 +
2.280 +lemma (in comm_monoid) divides_prod_l:
2.281 +  assumes carr[intro]: "a \<in> carrier G"  "b \<in> carrier G"  "c \<in> carrier G"
2.282 +    and ab: "a divides b"
2.283 +  shows "a divides (c \<otimes> b)"
2.284 +using ab carr
2.285 +apply (simp add: m_comm[of c b])
2.286 +apply (fast intro: divides_prod_r)
2.287 +done
2.288 +
2.289 +lemma (in monoid) unit_divides:
2.290 +  assumes uunit: "u \<in> Units G"
2.291 +      and acarr: "a \<in> carrier G"
2.292 +  shows "u divides a"
2.293 +proof (intro dividesI[of "(inv u) \<otimes> a"], fast intro: uunit acarr)
2.294 +  from uunit acarr
2.295 +      have xcarr: "inv u \<otimes> a \<in> carrier G" by fast
2.296 +
2.297 +  from uunit acarr
2.298 +       have "u \<otimes> (inv u \<otimes> a) = (u \<otimes> inv u) \<otimes> a" by (fast intro: m_assoc[symmetric])
2.299 +  also have "\<dots> = \<one> \<otimes> a" by (simp add: Units_r_inv[OF uunit])
2.300 +  also from acarr
2.301 +       have "\<dots> = a" by simp
2.302 +  finally
2.303 +       show "a = u \<otimes> (inv u \<otimes> a)" ..
2.304 +qed
2.305 +
2.306 +lemma (in comm_monoid) divides_unit:
2.307 +  assumes udvd: "a divides u"
2.308 +      and  carr: "a \<in> carrier G"  "u \<in> Units G"
2.309 +  shows "a \<in> Units G"
2.310 +using udvd carr
2.311 +by (blast intro: unit_factor)
2.312 +
2.313 +lemma (in comm_monoid) Unit_eq_dividesone:
2.314 +  assumes ucarr: "u \<in> carrier G"
2.315 +  shows "u \<in> Units G = u divides \<one>"
2.316 +using ucarr
2.317 +by (fast dest: divides_unit intro: unit_divides)
2.318 +
2.319 +
2.320 +subsubsection {* Association *}
2.321 +
2.322 +lemma associatedI:
2.323 +  fixes G (structure)
2.324 +  assumes "a divides b"  "b divides a"
2.325 +  shows "a \<sim> b"
2.326 +using assms
2.328 +
2.329 +lemma (in monoid) associatedI2:
2.330 +  assumes uunit[simp]: "u \<in> Units G"
2.331 +    and a: "a = b \<otimes> u"
2.332 +    and bcarr[simp]: "b \<in> carrier G"
2.333 +  shows "a \<sim> b"
2.334 +using uunit bcarr
2.335 +unfolding a
2.336 +apply (intro associatedI)
2.337 + apply (rule dividesI[of "inv u"], simp)
2.338 + apply (simp add: m_assoc Units_closed Units_r_inv)
2.339 +apply fast
2.340 +done
2.341 +
2.342 +lemma (in monoid) associatedI2':
2.343 +  assumes a: "a = b \<otimes> u"
2.344 +    and uunit: "u \<in> Units G"
2.345 +    and bcarr: "b \<in> carrier G"
2.346 +  shows "a \<sim> b"
2.347 +using assms by (intro associatedI2)
2.348 +
2.349 +lemma associatedD:
2.350 +  fixes G (structure)
2.351 +  assumes "a \<sim> b"
2.352 +  shows "a divides b"
2.353 +using assms by (simp add: associated_def)
2.354 +
2.355 +lemma (in monoid_cancel) associatedD2:
2.356 +  assumes assoc: "a \<sim> b"
2.357 +    and carr: "a \<in> carrier G"  "b \<in> carrier G"
2.358 +  shows "\<exists>u\<in>Units G. a = b \<otimes> u"
2.359 +using assoc
2.360 +unfolding associated_def
2.361 +proof clarify
2.362 +  assume "b divides a"
2.363 +  hence "\<exists>u\<in>carrier G. a = b \<otimes> u" by (rule dividesD)
2.364 +  from this obtain u
2.365 +      where ucarr: "u \<in> carrier G" and a: "a = b \<otimes> u"
2.366 +      by auto
2.367 +
2.368 +  assume "a divides b"
2.369 +  hence "\<exists>u'\<in>carrier G. b = a \<otimes> u'" by (rule dividesD)
2.370 +  from this obtain u'
2.371 +      where u'carr: "u' \<in> carrier G" and b: "b = a \<otimes> u'"
2.372 +      by auto
2.373 +  note carr = carr ucarr u'carr
2.374 +
2.375 +  from carr
2.376 +       have "a \<otimes> \<one> = a" by simp
2.377 +  also have "\<dots> = b \<otimes> u" by (simp add: a)
2.378 +  also have "\<dots> = a \<otimes> u' \<otimes> u" by (simp add: b)
2.379 +  also from carr
2.380 +       have "\<dots> = a \<otimes> (u' \<otimes> u)" by (simp add: m_assoc)
2.381 +  finally
2.382 +       have "a \<otimes> \<one> = a \<otimes> (u' \<otimes> u)" .
2.383 +  with carr
2.384 +      have u1: "\<one> = u' \<otimes> u" by (fast dest: l_cancel)
2.385 +
2.386 +  from carr
2.387 +       have "b \<otimes> \<one> = b" by simp
2.388 +  also have "\<dots> = a \<otimes> u'" by (simp add: b)
2.389 +  also have "\<dots> = b \<otimes> u \<otimes> u'" by (simp add: a)
2.390 +  also from carr
2.391 +       have "\<dots> = b \<otimes> (u \<otimes> u')" by (simp add: m_assoc)
2.392 +  finally
2.393 +       have "b \<otimes> \<one> = b \<otimes> (u \<otimes> u')" .
2.394 +  with carr
2.395 +      have u2: "\<one> = u \<otimes> u'" by (fast dest: l_cancel)
2.396 +
2.397 +  from u'carr u1[symmetric] u2[symmetric]
2.398 +      have "\<exists>u'\<in>carrier G. u' \<otimes> u = \<one> \<and> u \<otimes> u' = \<one>" by fast
2.399 +  hence "u \<in> Units G" by (simp add: Units_def ucarr)
2.400 +
2.401 +  from ucarr this a
2.402 +      show "\<exists>u\<in>Units G. a = b \<otimes> u" by fast
2.403 +qed
2.404 +
2.405 +lemma associatedE:
2.406 +  fixes G (structure)
2.407 +  assumes assoc: "a \<sim> b"
2.408 +    and e: "\<lbrakk>a divides b; b divides a\<rbrakk> \<Longrightarrow> P"
2.409 +  shows "P"
2.410 +proof -
2.411 +  from assoc
2.412 +      have "a divides b"  "b divides a"
2.413 +      by (simp add: associated_def)+
2.414 +  thus "P" by (elim e)
2.415 +qed
2.416 +
2.417 +lemma (in monoid_cancel) associatedE2:
2.418 +  assumes assoc: "a \<sim> b"
2.419 +    and e: "\<And>u. \<lbrakk>a = b \<otimes> u; u \<in> Units G\<rbrakk> \<Longrightarrow> P"
2.420 +    and carr: "a \<in> carrier G"  "b \<in> carrier G"
2.421 +  shows "P"
2.422 +proof -
2.423 +  from assoc and carr
2.424 +      have "\<exists>u\<in>Units G. a = b \<otimes> u" by (rule associatedD2)
2.425 +  from this obtain u
2.426 +      where "u \<in> Units G"  "a = b \<otimes> u"
2.427 +      by auto
2.428 +  thus "P" by (elim e)
2.429 +qed
2.430 +
2.431 +lemma (in monoid) associated_refl [simp, intro!]:
2.432 +  assumes "a \<in> carrier G"
2.433 +  shows "a \<sim> a"
2.434 +using assms
2.435 +by (fast intro: associatedI)
2.436 +
2.437 +lemma (in monoid) associated_sym [sym]:
2.438 +  assumes "a \<sim> b"
2.439 +    and "a \<in> carrier G"  "b \<in> carrier G"
2.440 +  shows "b \<sim> a"
2.441 +using assms
2.442 +by (iprover intro: associatedI elim: associatedE)
2.443 +
2.444 +lemma (in monoid) associated_trans [trans]:
2.445 +  assumes "a \<sim> b"  "b \<sim> c"
2.446 +    and "a \<in> carrier G"  "b \<in> carrier G"  "c \<in> carrier G"
2.447 +  shows "a \<sim> c"
2.448 +using assms
2.449 +by (iprover intro: associatedI divides_trans elim: associatedE)
2.450 +
2.451 +lemma (in monoid) division_equiv [intro, simp]:
2.452 +  "equivalence (division_rel G)"
2.453 +  apply unfold_locales
2.454 +  apply simp_all
2.455 +  apply (rule associated_sym, assumption+)
2.456 +  apply (iprover intro: associated_trans)
2.457 +  done
2.458 +
2.459 +
2.460 +subsubsection {* Division and associativity *}
2.461 +
2.462 +lemma divides_antisym:
2.463 +  fixes G (structure)
2.464 +  assumes "a divides b"  "b divides a"
2.465 +    and "a \<in> carrier G"  "b \<in> carrier G"
2.466 +  shows "a \<sim> b"
2.467 +using assms
2.468 +by (fast intro: associatedI)
2.469 +
2.470 +lemma (in monoid) divides_cong_l [trans]:
2.471 +  assumes xx': "x \<sim> x'"
2.472 +    and xdvdy: "x' divides y"
2.473 +    and carr [simp]: "x \<in> carrier G"  "x' \<in> carrier G"  "y \<in> carrier G"
2.474 +  shows "x divides y"
2.475 +proof -
2.476 +  from xx'
2.477 +       have "x divides x'" by (simp add: associatedD)
2.478 +  also note xdvdy
2.479 +  finally
2.480 +       show "x divides y" by simp
2.481 +qed
2.482 +
2.483 +lemma (in monoid) divides_cong_r [trans]:
2.484 +  assumes xdvdy: "x divides y"
2.485 +    and yy': "y \<sim> y'"
2.486 +    and carr[simp]: "x \<in> carrier G"  "y \<in> carrier G"  "y' \<in> carrier G"
2.487 +  shows "x divides y'"
2.488 +proof -
2.489 +  note xdvdy
2.490 +  also from yy'
2.491 +       have "y divides y'" by (simp add: associatedD)
2.492 +  finally
2.493 +       show "x divides y'" by simp
2.494 +qed
2.495 +
2.496 +lemma (in monoid) division_gpartial_order [simp, intro!]:
2.497 +  "gpartial_order (division_rel G)"
2.498 +  apply unfold_locales
2.499 +  apply simp_all
2.500 +  apply (simp add: associated_sym)
2.501 +  apply (blast intro: associated_trans)
2.502 +  apply (simp add: divides_antisym)
2.503 +  apply (blast intro: divides_trans)
2.504 +  apply (blast intro: divides_cong_l divides_cong_r associated_sym)
2.505 +  done
2.506 +
2.507 +
2.508 +subsubsection {* Multiplication and associativity *}
2.509 +
2.510 +lemma (in monoid_cancel) mult_cong_r:
2.511 +  assumes "b \<sim> b'"
2.512 +    and carr: "a \<in> carrier G"  "b \<in> carrier G"  "b' \<in> carrier G"
2.513 +  shows "a \<otimes> b \<sim> a \<otimes> b'"
2.514 +using assms
2.515 +apply (elim associatedE2, intro associatedI2)
2.516 +apply (auto intro: m_assoc[symmetric])
2.517 +done
2.518 +
2.519 +lemma (in comm_monoid_cancel) mult_cong_l:
2.520 +  assumes "a \<sim> a'"
2.521 +    and carr: "a \<in> carrier G"  "a' \<in> carrier G"  "b \<in> carrier G"
2.522 +  shows "a \<otimes> b \<sim> a' \<otimes> b"
2.523 +using assms
2.524 +apply (elim associatedE2, intro associatedI2)
2.525 +    apply assumption
2.526 +   apply (simp add: m_assoc Units_closed)
2.527 +   apply (simp add: m_comm Units_closed)
2.528 +  apply simp+
2.529 +done
2.530 +
2.531 +lemma (in monoid_cancel) assoc_l_cancel:
2.532 +  assumes carr: "a \<in> carrier G"  "b \<in> carrier G"  "b' \<in> carrier G"
2.533 +    and "a \<otimes> b \<sim> a \<otimes> b'"
2.534 +  shows "b \<sim> b'"
2.535 +using assms
2.536 +apply (elim associatedE2, intro associatedI2)
2.537 +    apply assumption
2.538 +   apply (rule l_cancel[of a])
2.539 +      apply (simp add: m_assoc Units_closed)
2.540 +     apply fast+
2.541 +done
2.542 +
2.543 +lemma (in comm_monoid_cancel) assoc_r_cancel:
2.544 +  assumes "a \<otimes> b \<sim> a' \<otimes> b"
2.545 +    and carr: "a \<in> carrier G"  "a' \<in> carrier G"  "b \<in> carrier G"
2.546 +  shows "a \<sim> a'"
2.547 +using assms
2.548 +apply (elim associatedE2, intro associatedI2)
2.549 +    apply assumption
2.550 +   apply (rule r_cancel[of a b])
2.551 +      apply (simp add: m_assoc Units_closed)
2.552 +      apply (simp add: m_comm Units_closed)
2.553 +     apply fast+
2.554 +done
2.555 +
2.556 +
2.557 +subsubsection {* Units *}
2.558 +
2.559 +lemma (in monoid_cancel) assoc_unit_l [trans]:
2.560 +  assumes asc: "a \<sim> b" and bunit: "b \<in> Units G"
2.561 +    and carr: "a \<in> carrier G"
2.562 +  shows "a \<in> Units G"
2.563 +using assms
2.564 +by (fast elim: associatedE2)
2.565 +
2.566 +lemma (in monoid_cancel) assoc_unit_r [trans]:
2.567 +  assumes aunit: "a \<in> Units G" and asc: "a \<sim> b"
2.568 +    and bcarr: "b \<in> carrier G"
2.569 +  shows "b \<in> Units G"
2.570 +using aunit bcarr associated_sym[OF asc]
2.571 +by (blast intro: assoc_unit_l)
2.572 +
2.573 +lemma (in comm_monoid) Units_cong:
2.574 +  assumes aunit: "a \<in> Units G" and asc: "a \<sim> b"
2.575 +    and bcarr: "b \<in> carrier G"
2.576 +  shows "b \<in> Units G"
2.577 +using assms
2.578 +by (blast intro: divides_unit elim: associatedE)
2.579 +
2.580 +lemma (in monoid) Units_assoc:
2.581 +  assumes units: "a \<in> Units G"  "b \<in> Units G"
2.582 +  shows "a \<sim> b"
2.583 +using units
2.584 +by (fast intro: associatedI unit_divides)
2.585 +
2.586 +lemma (in monoid) Units_are_ones:
2.587 +  "Units G {.=}\<^bsub>(division_rel G)\<^esub> {\<one>}"
2.588 +apply (simp add: set_eq_def elem_def, rule, simp_all)
2.589 +proof clarsimp
2.590 +  fix a
2.591 +  assume aunit: "a \<in> Units G"
2.592 +  show "a \<sim> \<one>"
2.593 +  apply (rule associatedI)
2.594 +   apply (fast intro: dividesI[of "inv a"] aunit Units_r_inv[symmetric])
2.595 +  apply (fast intro: dividesI[of "a"] l_one[symmetric] Units_closed[OF aunit])
2.596 +  done
2.597 +next
2.598 +  have "\<one> \<in> Units G" by simp
2.599 +  moreover have "\<one> \<sim> \<one>" by simp
2.600 +  ultimately show "\<exists>a \<in> Units G. \<one> \<sim> a" by fast
2.601 +qed
2.602 +
2.603 +lemma (in comm_monoid) Units_Lower:
2.604 +  "Units G = Lower (division_rel G) (carrier G)"
2.605 +apply (simp add: Units_def Lower_def)
2.606 +apply (rule, rule)
2.607 + apply clarsimp
2.608 +  apply (rule unit_divides)
2.609 +   apply (unfold Units_def, fast)
2.610 +  apply assumption
2.611 +apply clarsimp
2.612 +proof -
2.613 +  fix x
2.614 +  assume xcarr: "x \<in> carrier G"
2.615 +  assume r[rule_format]: "\<forall>y. y \<in> carrier G \<longrightarrow> x divides y"
2.616 +  have "\<one> \<in> carrier G" by simp
2.617 +  hence "x divides \<one>" by (rule r)
2.618 +  hence "\<exists>x'\<in>carrier G. \<one> = x \<otimes> x'" by (rule dividesE, fast)
2.619 +  from this obtain x'
2.620 +      where x'carr: "x' \<in> carrier G"
2.621 +      and xx': "\<one> = x \<otimes> x'"
2.622 +      by auto
2.623 +
2.624 +  note xx'
2.625 +  also with xcarr x'carr
2.626 +       have "\<dots> = x' \<otimes> x" by (simp add: m_comm)
2.627 +  finally
2.628 +       have "\<one> = x' \<otimes> x" .
2.629 +
2.630 +  from x'carr xx'[symmetric] this[symmetric]
2.631 +      show "\<exists>y\<in>carrier G. y \<otimes> x = \<one> \<and> x \<otimes> y = \<one>" by fast
2.632 +qed
2.633 +
2.634 +
2.635 +subsubsection {* Proper factors *}
2.636 +
2.637 +lemma properfactorI:
2.638 +  fixes G (structure)
2.639 +  assumes "a divides b"
2.640 +    and "\<not>(b divides a)"
2.641 +  shows "properfactor G a b"
2.642 +using assms
2.643 +unfolding properfactor_def
2.644 +by simp
2.645 +
2.646 +lemma properfactorI2:
2.647 +  fixes G (structure)
2.648 +  assumes advdb: "a divides b"
2.649 +    and neq: "\<not>(a \<sim> b)"
2.650 +  shows "properfactor G a b"
2.651 +apply (rule properfactorI, rule advdb)
2.652 +proof (rule ccontr, simp)
2.653 +  assume "b divides a"
2.654 +  with advdb have "a \<sim> b" by (rule associatedI)
2.655 +  with neq show "False" by fast
2.656 +qed
2.657 +
2.658 +lemma (in comm_monoid_cancel) properfactorI3:
2.659 +  assumes p: "p = a \<otimes> b"
2.660 +    and nunit: "b \<notin> Units G"
2.661 +    and carr: "a \<in> carrier G"  "b \<in> carrier G"  "p \<in> carrier G"
2.662 +  shows "properfactor G a p"
2.663 +unfolding p
2.664 +using carr
2.665 +apply (intro properfactorI, fast)
2.666 +proof (clarsimp, elim dividesE)
2.667 +  fix c
2.668 +  assume ccarr: "c \<in> carrier G"
2.669 +  note [simp] = carr ccarr
2.670 +
2.671 +  have "a \<otimes> \<one> = a" by simp
2.672 +  also assume "a = a \<otimes> b \<otimes> c"
2.673 +  also have "\<dots> = a \<otimes> (b \<otimes> c)" by (simp add: m_assoc)
2.674 +  finally have "a \<otimes> \<one> = a \<otimes> (b \<otimes> c)" .
2.675 +
2.676 +  hence rinv: "\<one> = b \<otimes> c" by (intro l_cancel[of "a" "\<one>" "b \<otimes> c"], simp+)
2.677 +  also have "\<dots> = c \<otimes> b" by (simp add: m_comm)
2.678 +  finally have linv: "\<one> = c \<otimes> b" .
2.679 +
2.680 +  from ccarr linv[symmetric] rinv[symmetric]
2.681 +  have "b \<in> Units G" unfolding Units_def by fastsimp
2.682 +  with nunit
2.683 +      show "False" ..
2.684 +qed
2.685 +
2.686 +lemma properfactorE:
2.687 +  fixes G (structure)
2.688 +  assumes pf: "properfactor G a b"
2.689 +    and r: "\<lbrakk>a divides b; \<not>(b divides a)\<rbrakk> \<Longrightarrow> P"
2.690 +  shows "P"
2.691 +using pf
2.692 +unfolding properfactor_def
2.693 +by (fast intro: r)
2.694 +
2.695 +lemma properfactorE2:
2.696 +  fixes G (structure)
2.697 +  assumes pf: "properfactor G a b"
2.698 +    and elim: "\<lbrakk>a divides b; \<not>(a \<sim> b)\<rbrakk> \<Longrightarrow> P"
2.699 +  shows "P"
2.700 +using pf
2.701 +unfolding properfactor_def
2.702 +by (fast elim: elim associatedE)
2.703 +
2.704 +lemma (in monoid) properfactor_unitE:
2.705 +  assumes uunit: "u \<in> Units G"
2.706 +    and pf: "properfactor G a u"
2.707 +    and acarr: "a \<in> carrier G"
2.708 +  shows "P"
2.709 +using pf unit_divides[OF uunit acarr]
2.710 +by (fast elim: properfactorE)
2.711 +
2.712 +
2.713 +lemma (in monoid) properfactor_divides:
2.714 +  assumes pf: "properfactor G a b"
2.715 +  shows "a divides b"
2.716 +using pf
2.717 +by (elim properfactorE)
2.718 +
2.719 +lemma (in monoid) properfactor_trans1 [trans]:
2.720 +  assumes dvds: "a divides b"  "properfactor G b c"
2.721 +    and carr: "a \<in> carrier G"  "b \<in> carrier G"  "c \<in> carrier G"
2.722 +  shows "properfactor G a c"
2.723 +using dvds carr
2.724 +apply (elim properfactorE, intro properfactorI)
2.725 + apply (iprover intro: divides_trans)+
2.726 +done
2.727 +
2.728 +lemma (in monoid) properfactor_trans2 [trans]:
2.729 +  assumes dvds: "properfactor G a b"  "b divides c"
2.730 +    and carr: "a \<in> carrier G"  "b \<in> carrier G"  "c \<in> carrier G"
2.731 +  shows "properfactor G a c"
2.732 +using dvds carr
2.733 +apply (elim properfactorE, intro properfactorI)
2.734 + apply (iprover intro: divides_trans)+
2.735 +done
2.736 +
2.737 +lemma properfactor_glless:
2.738 +  fixes G (structure)
2.739 +  shows "properfactor G = glless (division_rel G)"
2.740 +apply (rule ext) apply (rule ext) apply rule
2.741 + apply (fastsimp elim: properfactorE2 intro: gllessI)
2.742 +apply (fastsimp elim: gllessE intro: properfactorI2)
2.743 +done
2.744 +
2.745 +lemma (in monoid) properfactor_cong_l [trans]:
2.746 +  assumes x'x: "x' \<sim> x"
2.747 +    and pf: "properfactor G x y"
2.748 +    and carr: "x \<in> carrier G"  "x' \<in> carrier G"  "y \<in> carrier G"
2.749 +  shows "properfactor G x' y"
2.750 +using pf
2.751 +unfolding properfactor_glless
2.752 +proof -
2.753 +  interpret gpartial_order ["division_rel G"] ..
2.754 +  from x'x
2.755 +       have "x' .=\<^bsub>division_rel G\<^esub> x" by simp
2.756 +  also assume "x \<sqsubset>\<^bsub>division_rel G\<^esub> y"
2.757 +  finally
2.758 +       show "x' \<sqsubset>\<^bsub>division_rel G\<^esub> y" by (simp add: carr)
2.759 +qed
2.760 +
2.761 +lemma (in monoid) properfactor_cong_r [trans]:
2.762 +  assumes pf: "properfactor G x y"
2.763 +    and yy': "y \<sim> y'"
2.764 +    and carr: "x \<in> carrier G"  "y \<in> carrier G"  "y' \<in> carrier G"
2.765 +  shows "properfactor G x y'"
2.766 +using pf
2.767 +unfolding properfactor_glless
2.768 +proof -
2.769 +  interpret gpartial_order ["division_rel G"] ..
2.770 +  assume "x \<sqsubset>\<^bsub>division_rel G\<^esub> y"
2.771 +  also from yy'
2.772 +       have "y .=\<^bsub>division_rel G\<^esub> y'" by simp
2.773 +  finally
2.774 +       show "x \<sqsubset>\<^bsub>division_rel G\<^esub> y'" by (simp add: carr)
2.775 +qed
2.776 +
2.777 +lemma (in monoid_cancel) properfactor_mult_lI [intro]:
2.778 +  assumes ab: "properfactor G a b"
2.779 +    and carr: "a \<in> carrier G"  "b \<in> carrier G"  "c \<in> carrier G"
2.780 +  shows "properfactor G (c \<otimes> a) (c \<otimes> b)"
2.781 +using ab carr
2.782 +by (fastsimp elim: properfactorE intro: properfactorI)
2.783 +
2.784 +lemma (in monoid_cancel) properfactor_mult_l [simp]:
2.785 +  assumes carr: "a \<in> carrier G"  "b \<in> carrier G"  "c \<in> carrier G"
2.786 +  shows "properfactor G (c \<otimes> a) (c \<otimes> b) = properfactor G a b"
2.787 +using carr
2.788 +by (fastsimp elim: properfactorE intro: properfactorI)
2.789 +
2.790 +lemma (in comm_monoid_cancel) properfactor_mult_rI [intro]:
2.791 +  assumes ab: "properfactor G a b"
2.792 +    and carr: "a \<in> carrier G"  "b \<in> carrier G"  "c \<in> carrier G"
2.793 +  shows "properfactor G (a \<otimes> c) (b \<otimes> c)"
2.794 +using ab carr
2.795 +by (fastsimp elim: properfactorE intro: properfactorI)
2.796 +
2.797 +lemma (in comm_monoid_cancel) properfactor_mult_r [simp]:
2.798 +  assumes carr: "a \<in> carrier G"  "b \<in> carrier G"  "c \<in> carrier G"
2.799 +  shows "properfactor G (a \<otimes> c) (b \<otimes> c) = properfactor G a b"
2.800 +using carr
2.801 +by (fastsimp elim: properfactorE intro: properfactorI)
2.802 +
2.803 +lemma (in monoid) properfactor_prod_r:
2.804 +  assumes ab: "properfactor G a b"
2.805 +    and carr[simp]: "a \<in> carrier G"  "b \<in> carrier G"  "c \<in> carrier G"
2.806 +  shows "properfactor G a (b \<otimes> c)"
2.807 +by (intro properfactor_trans2[OF ab] divides_prod_r, simp+)
2.808 +
2.809 +lemma (in comm_monoid) properfactor_prod_l:
2.810 +  assumes ab: "properfactor G a b"
2.811 +    and carr[simp]: "a \<in> carrier G"  "b \<in> carrier G"  "c \<in> carrier G"
2.812 +  shows "properfactor G a (c \<otimes> b)"
2.813 +by (intro properfactor_trans2[OF ab] divides_prod_l, simp+)
2.814 +
2.815 +
2.816 +subsection {* Irreducible elements and primes *}
2.817 +
2.818 +subsubsection {* Irreducible elements *}
2.819 +
2.820 +lemma irreducibleI:
2.821 +  fixes G (structure)
2.822 +  assumes "a \<notin> Units G"
2.823 +    and "\<And>b. \<lbrakk>b \<in> carrier G; properfactor G b a\<rbrakk> \<Longrightarrow> b \<in> Units G"
2.824 +  shows "irreducible G a"
2.825 +using assms
2.826 +unfolding irreducible_def
2.827 +by blast
2.828 +
2.829 +lemma irreducibleE:
2.830 +  fixes G (structure)
2.831 +  assumes irr: "irreducible G a"
2.832 +     and elim: "\<lbrakk>a \<notin> Units G; \<forall>b. b \<in> carrier G \<and> properfactor G b a \<longrightarrow> b \<in> Units G\<rbrakk> \<Longrightarrow> P"
2.833 +  shows "P"
2.834 +using assms
2.835 +unfolding irreducible_def
2.836 +by blast
2.837 +
2.838 +lemma irreducibleD:
2.839 +  fixes G (structure)
2.840 +  assumes irr: "irreducible G a"
2.841 +     and pf: "properfactor G b a"
2.842 +     and bcarr: "b \<in> carrier G"
2.843 +  shows "b \<in> Units G"
2.844 +using assms
2.845 +by (fast elim: irreducibleE)
2.846 +
2.847 +lemma (in monoid_cancel) irreducible_cong [trans]:
2.848 +  assumes irred: "irreducible G a"
2.849 +    and aa': "a \<sim> a'"
2.850 +    and carr[simp]: "a \<in> carrier G"  "a' \<in> carrier G"
2.851 +  shows "irreducible G a'"
2.852 +using assms
2.853 +apply (elim irreducibleE, intro irreducibleI)
2.854 +apply simp_all
2.855 +proof clarify
2.856 +  assume "a' \<in> Units G"
2.857 +  also note aa'[symmetric]
2.858 +  finally have aunit: "a \<in> Units G" by simp
2.859 +
2.860 +  assume "a \<notin> Units G"
2.861 +  with aunit
2.862 +      show "False" by fast
2.863 +next
2.864 +  fix b
2.865 +  assume r[rule_format]: "\<forall>b. b \<in> carrier G \<and> properfactor G b a \<longrightarrow> b \<in> Units G"
2.866 +    and bcarr[simp]: "b \<in> carrier G"
2.867 +  assume "properfactor G b a'"
2.868 +  also note aa'[symmetric]
2.869 +  finally
2.870 +       have "properfactor G b a" by simp
2.871 +
2.872 +  with bcarr
2.873 +     show "b \<in> Units G" by (fast intro: r)
2.874 +qed
2.875 +
2.876 +
2.877 +lemma (in monoid) irreducible_prod_rI:
2.878 +  assumes airr: "irreducible G a"
2.879 +    and bunit: "b \<in> Units G"
2.880 +    and carr[simp]: "a \<in> carrier G"  "b \<in> carrier G"
2.881 +  shows "irreducible G (a \<otimes> b)"
2.882 +using airr carr bunit
2.883 +apply (elim irreducibleE, intro irreducibleI, clarify)
2.884 + apply (subgoal_tac "a \<in> Units G", simp)
2.885 + apply (intro prod_unit_r[of a b] carr bunit, assumption)
2.886 +proof -
2.887 +  fix c
2.888 +  assume [simp]: "c \<in> carrier G"
2.889 +    and r[rule_format]: "\<forall>b. b \<in> carrier G \<and> properfactor G b a \<longrightarrow> b \<in> Units G"
2.890 +  assume "properfactor G c (a \<otimes> b)"
2.891 +  also have "a \<otimes> b \<sim> a" by (intro associatedI2[OF bunit], simp+)
2.892 +  finally
2.893 +       have pfa: "properfactor G c a" by simp
2.894 +  show "c \<in> Units G" by (rule r, simp add: pfa)
2.895 +qed
2.896 +
2.897 +lemma (in comm_monoid) irreducible_prod_lI:
2.898 +  assumes birr: "irreducible G b"
2.899 +    and aunit: "a \<in> Units G"
2.900 +    and carr [simp]: "a \<in> carrier G"  "b \<in> carrier G"
2.901 +  shows "irreducible G (a \<otimes> b)"
2.902 +apply (subst m_comm, simp+)
2.903 +apply (intro irreducible_prod_rI assms)
2.904 +done
2.905 +
2.906 +lemma (in comm_monoid_cancel) irreducible_prodE [elim]:
2.907 +  assumes irr: "irreducible G (a \<otimes> b)"
2.908 +    and carr[simp]: "a \<in> carrier G"  "b \<in> carrier G"
2.909 +    and e1: "\<lbrakk>irreducible G a; b \<in> Units G\<rbrakk> \<Longrightarrow> P"
2.910 +    and e2: "\<lbrakk>a \<in> Units G; irreducible G b\<rbrakk> \<Longrightarrow> P"
2.911 +  shows "P"
2.912 +using irr
2.913 +proof (elim irreducibleE)
2.914 +  assume abnunit: "a \<otimes> b \<notin> Units G"
2.915 +    and isunit[rule_format]: "\<forall>ba. ba \<in> carrier G \<and> properfactor G ba (a \<otimes> b) \<longrightarrow> ba \<in> Units G"
2.916 +
2.917 +  show "P"
2.918 +  proof (cases "a \<in> Units G")
2.919 +    assume aunit: "a \<in>  Units G"
2.920 +
2.921 +    have "irreducible G b"
2.922 +    apply (rule irreducibleI)
2.923 +    proof (rule ccontr, simp)
2.924 +      assume "b \<in> Units G"
2.925 +      with aunit have "(a \<otimes> b) \<in> Units G" by fast
2.926 +      with abnunit show "False" ..
2.927 +    next
2.928 +      fix c
2.929 +      assume ccarr: "c \<in> carrier G"
2.930 +        and "properfactor G c b"
2.931 +      hence "properfactor G c (a \<otimes> b)" by (simp add: properfactor_prod_l[of c b a])
2.932 +      from ccarr this show "c \<in> Units G" by (fast intro: isunit)
2.933 +    qed
2.934 +
2.935 +    from aunit this show "P" by (rule e2)
2.936 +  next
2.937 +    assume anunit: "a \<notin> Units G"
2.938 +    with carr have "properfactor G b (b \<otimes> a)" by (fast intro: properfactorI3)
2.939 +    hence bf: "properfactor G b (a \<otimes> b)" by (subst m_comm[of a b], simp+)
2.940 +    hence bunit: "b \<in> Units G" by (intro isunit, simp)
2.941 +
2.942 +    have "irreducible G a"
2.943 +    apply (rule irreducibleI)
2.944 +    proof (rule ccontr, simp)
2.945 +      assume "a \<in> Units G"
2.946 +      with bunit have "(a \<otimes> b) \<in> Units G" by fast
2.947 +      with abnunit show "False" ..
2.948 +    next
2.949 +      fix c
2.950 +      assume ccarr: "c \<in> carrier G"
2.951 +        and "properfactor G c a"
2.952 +      hence "properfactor G c (a \<otimes> b)" by (simp add: properfactor_prod_r[of c a b])
2.953 +      from ccarr this show "c \<in> Units G" by (fast intro: isunit)
2.954 +    qed
2.955 +
2.956 +    from this bunit show "P" by (rule e1)
2.957 +  qed
2.958 +qed
2.959 +
2.960 +
2.961 +subsubsection {* Prime elements *}
2.962 +
2.963 +lemma primeI:
2.964 +  fixes G (structure)
2.965 +  assumes "p \<notin> Units G"
2.966 +    and "\<And>a b. \<lbrakk>a \<in> carrier G; b \<in> carrier G; p divides (a \<otimes> b)\<rbrakk> \<Longrightarrow> p divides a \<or> p divides b"
2.967 +  shows "prime G p"
2.968 +using assms
2.969 +unfolding prime_def
2.970 +by blast
2.971 +
2.972 +lemma primeE:
2.973 +  fixes G (structure)
2.974 +  assumes pprime: "prime G p"
2.975 +    and e: "\<lbrakk>p \<notin> Units G; \<forall>a\<in>carrier G. \<forall>b\<in>carrier G.
2.976 +                          p divides a \<otimes> b \<longrightarrow> p divides a \<or> p divides b\<rbrakk> \<Longrightarrow> P"
2.977 +  shows "P"
2.978 +using pprime
2.979 +unfolding prime_def
2.980 +by (blast dest: e)
2.981 +
2.982 +lemma (in comm_monoid_cancel) prime_divides:
2.983 +  assumes carr: "a \<in> carrier G"  "b \<in> carrier G"
2.984 +    and pprime: "prime G p"
2.985 +    and pdvd: "p divides a \<otimes> b"
2.986 +  shows "p divides a \<or> p divides b"
2.987 +using assms
2.988 +by (blast elim: primeE)
2.989 +
2.990 +lemma (in monoid_cancel) prime_cong [trans]:
2.991 +  assumes pprime: "prime G p"
2.992 +    and pp': "p \<sim> p'"
2.993 +    and carr[simp]: "p \<in> carrier G"  "p' \<in> carrier G"
2.994 +  shows "prime G p'"
2.995 +using pprime
2.996 +apply (elim primeE, intro primeI)
2.997 +proof clarify
2.998 +  assume pnunit: "p \<notin> Units G"
2.999 +  assume "p' \<in> Units G"
2.1000 +  also note pp'[symmetric]
2.1001 +  finally
2.1002 +       have "p \<in> Units G" by simp
2.1003 +  with pnunit
2.1004 +       show False ..
2.1005 +next
2.1006 +  fix a b
2.1007 +  assume r[rule_format]:
2.1008 +         "\<forall>a\<in>carrier G. \<forall>b\<in>carrier G. p divides a \<otimes> b \<longrightarrow> p divides a \<or> p divides b"
2.1009 +  assume p'dvd: "p' divides a \<otimes> b"
2.1010 +    and carr'[simp]: "a \<in> carrier G"  "b \<in> carrier G"
2.1011 +
2.1012 +  note pp'
2.1013 +  also note p'dvd
2.1014 +  finally
2.1015 +       have "p divides a \<otimes> b" by simp
2.1016 +  hence "p divides a \<or> p divides b" by (intro r, simp+)
2.1017 +  moreover {
2.1018 +    note pp'[symmetric]
2.1019 +    also assume "p divides a"
2.1020 +    finally
2.1021 +         have "p' divides a" by simp
2.1022 +    hence "p' divides a \<or> p' divides b" by simp
2.1023 +  }
2.1024 +  moreover {
2.1025 +    note pp'[symmetric]
2.1026 +    also assume "p divides b"
2.1027 +    finally
2.1028 +         have "p' divides b" by simp
2.1029 +    hence "p' divides a \<or> p' divides b" by simp
2.1030 +  }
2.1031 +  ultimately
2.1032 +    show "p' divides a \<or> p' divides b" by fast
2.1033 +qed
2.1034 +
2.1035 +
2.1036 +subsection {* Factorization and factorial monoids *}
2.1037 +
2.1038 +(*
2.1039 +hide (open) const mult     (* Multiset.mult, conflicting with monoid.mult *)
2.1040 +*)
2.1041 +
2.1042 +subsubsection {* Function definitions *}
2.1043 +
2.1044 +constdefs (structure G)
2.1045 +  factors :: "[_, 'a list, 'a] \<Rightarrow> bool"
2.1046 +  "factors G fs a == (\<forall>x \<in> (set fs). irreducible G x) \<and> foldr (op \<otimes>) fs \<one> = a"
2.1047 +
2.1048 +  wfactors ::"[_, 'a list, 'a] \<Rightarrow> bool"
2.1049 +  "wfactors G fs a == (\<forall>x \<in> (set fs). irreducible G x) \<and> foldr (op \<otimes>) fs \<one> \<sim> a"
2.1050 +
2.1051 +abbreviation
2.1052 +  list_assoc :: "('a,_) monoid_scheme \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" (infix "[\<sim>]\<index>" 44) where
2.1053 +  "list_assoc G == list_all2 (op \<sim>\<^bsub>G\<^esub>)"
2.1054 +
2.1055 +constdefs (structure G)
2.1056 +  essentially_equal :: "[_, 'a list, 'a list] \<Rightarrow> bool"
2.1057 +  "essentially_equal G fs1 fs2 == (\<exists>fs1'. fs1 <~~> fs1' \<and> fs1' [\<sim>] fs2)"
2.1058 +
2.1059 +
2.1060 +locale factorial_monoid = comm_monoid_cancel +
2.1061 +  assumes factors_exist:
2.1062 +          "\<lbrakk>a \<in> carrier G; a \<notin> Units G\<rbrakk> \<Longrightarrow> \<exists>fs. set fs \<subseteq> carrier G \<and> factors G fs a"
2.1063 +      and factors_unique:
2.1064 +          "\<lbrakk>factors G fs a; factors G fs' a; a \<in> carrier G; a \<notin> Units G;
2.1065 +            set fs \<subseteq> carrier G; set fs' \<subseteq> carrier G\<rbrakk> \<Longrightarrow> essentially_equal G fs fs'"
2.1066 +
2.1067 +
2.1068 +subsubsection {* Comparing lists of elements *}
2.1069 +
2.1070 +text {* Association on lists *}
2.1071 +
2.1072 +lemma (in monoid) listassoc_refl [simp, intro]:
2.1073 +  assumes "set as \<subseteq> carrier G"
2.1074 +  shows "as [\<sim>] as"
2.1075 +using assms
2.1076 +by (induct as) simp+
2.1077 +
2.1078 +lemma (in monoid) listassoc_sym [sym]:
2.1079 +  assumes "as [\<sim>] bs"
2.1080 +    and "set as \<subseteq> carrier G" and "set bs \<subseteq> carrier G"
2.1081 +  shows "bs [\<sim>] as"
2.1082 +using assms
2.1083 +proof (induct as arbitrary: bs, simp)
2.1084 +  case Cons
2.1085 +  thus ?case
2.1086 +    apply (induct bs, simp)
2.1087 +    apply clarsimp
2.1088 +    apply (iprover intro: associated_sym)
2.1089 +  done
2.1090 +qed
2.1091 +
2.1092 +lemma (in monoid) listassoc_trans [trans]:
2.1093 +  assumes "as [\<sim>] bs" and "bs [\<sim>] cs"
2.1094 +    and "set as \<subseteq> carrier G" and "set bs \<subseteq> carrier G" and "set cs \<subseteq> carrier G"
2.1095 +  shows "as [\<sim>] cs"
2.1096 +using assms
2.1097 +apply (simp add: list_all2_conv_all_nth set_conv_nth, safe)
2.1098 +apply (rule associated_trans)
2.1099 +    apply (subgoal_tac "as ! i \<sim> bs ! i", assumption)
2.1100 +    apply (simp, simp)
2.1101 +  apply blast+
2.1102 +done
2.1103 +
2.1104 +lemma (in monoid_cancel) irrlist_listassoc_cong:
2.1105 +  assumes "\<forall>a\<in>set as. irreducible G a"
2.1106 +    and "as [\<sim>] bs"
2.1107 +    and "set as \<subseteq> carrier G" and "set bs \<subseteq> carrier G"
2.1108 +  shows "\<forall>a\<in>set bs. irreducible G a"
2.1109 +using assms
2.1110 +apply (clarsimp simp add: list_all2_conv_all_nth set_conv_nth)
2.1111 +apply (blast intro: irreducible_cong)
2.1112 +done
2.1113 +
2.1114 +
2.1115 +text {* Permutations *}
2.1116 +
2.1117 +lemma perm_map [intro]:
2.1118 +  assumes p: "a <~~> b"
2.1119 +  shows "map f a <~~> map f b"
2.1120 +using p
2.1121 +by induct auto
2.1122 +
2.1123 +lemma perm_map_switch:
2.1124 +  assumes m: "map f a = map f b" and p: "b <~~> c"
2.1125 +  shows "\<exists>d. a <~~> d \<and> map f d = map f c"
2.1126 +using p m
2.1127 +by (induct arbitrary: a) (simp, force, force, blast)
2.1128 +
2.1129 +lemma (in monoid) perm_assoc_switch:
2.1130 +   assumes a:"as [\<sim>] bs" and p: "bs <~~> cs"
2.1131 +   shows "\<exists>bs'. as <~~> bs' \<and> bs' [\<sim>] cs"
2.1132 +using p a
2.1133 +apply (induct bs cs arbitrary: as, simp)
2.1134 +  apply (clarsimp simp add: list_all2_Cons2, blast)
2.1135 + apply (clarsimp simp add: list_all2_Cons2)
2.1136 + apply blast
2.1137 +apply blast
2.1138 +done
2.1139 +
2.1140 +lemma (in monoid) perm_assoc_switch_r:
2.1141 +   assumes p: "as <~~> bs" and a:"bs [\<sim>] cs"
2.1142 +   shows "\<exists>bs'. as [\<sim>] bs' \<and> bs' <~~> cs"
2.1143 +using p a
2.1144 +apply (induct as bs arbitrary: cs, simp)
2.1145 +  apply (clarsimp simp add: list_all2_Cons1, blast)
2.1146 + apply (clarsimp simp add: list_all2_Cons1)
2.1147 + apply blast
2.1148 +apply blast
2.1149 +done
2.1150 +
2.1151 +declare perm_sym [sym]
2.1152 +
2.1153 +lemma perm_setP:
2.1154 +  assumes perm: "as <~~> bs"
2.1155 +    and as: "P (set as)"
2.1156 +  shows "P (set bs)"
2.1157 +proof -
2.1158 +  from perm
2.1159 +      have "multiset_of as = multiset_of bs"
2.1160 +      by (simp add: multiset_of_eq_perm)
2.1161 +  hence "set as = set bs" by (rule multiset_of_eq_setD)
2.1162 +  with as
2.1163 +      show "P (set bs)" by simp
2.1164 +qed
2.1165 +
2.1166 +lemmas (in monoid) perm_closed =
2.1167 +    perm_setP[of _ _ "\<lambda>as. as \<subseteq> carrier G"]
2.1168 +
2.1169 +lemmas (in monoid) irrlist_perm_cong =
2.1170 +    perm_setP[of _ _ "\<lambda>as. \<forall>a\<in>as. irreducible G a"]
2.1171 +
2.1172 +
2.1173 +text {* Essentially equal factorizations *}
2.1174 +
2.1175 +lemma (in monoid) essentially_equalI:
2.1176 +  assumes ex: "fs1 <~~> fs1'"  "fs1' [\<sim>] fs2"
2.1177 +  shows "essentially_equal G fs1 fs2"
2.1178 +using ex
2.1179 +unfolding essentially_equal_def
2.1180 +by fast
2.1181 +
2.1182 +lemma (in monoid) essentially_equalE:
2.1183 +  assumes ee: "essentially_equal G fs1 fs2"
2.1184 +    and e: "\<And>fs1'. \<lbrakk>fs1 <~~> fs1'; fs1' [\<sim>] fs2\<rbrakk> \<Longrightarrow> P"
2.1185 +  shows "P"
2.1186 +using ee
2.1187 +unfolding essentially_equal_def
2.1188 +by (fast intro: e)
2.1189 +
2.1190 +lemma (in monoid) ee_refl [simp,intro]:
2.1191 +  assumes carr: "set as \<subseteq> carrier G"
2.1192 +  shows "essentially_equal G as as"
2.1193 +using carr
2.1194 +by (fast intro: essentially_equalI)
2.1195 +
2.1196 +lemma (in monoid) ee_sym [sym]:
2.1197 +  assumes ee: "essentially_equal G as bs"
2.1198 +    and carr: "set as \<subseteq> carrier G"  "set bs \<subseteq> carrier G"
2.1199 +  shows "essentially_equal G bs as"
2.1200 +using ee
2.1201 +proof (elim essentially_equalE)
2.1202 +  fix fs
2.1203 +  assume "as <~~> fs"  "fs [\<sim>] bs"
2.1204 +  hence "\<exists>fs'. as [\<sim>] fs' \<and> fs' <~~> bs" by (rule perm_assoc_switch_r)
2.1205 +  from this obtain fs'
2.1206 +      where a: "as [\<sim>] fs'" and p: "fs' <~~> bs"
2.1207 +      by auto
2.1208 +  from p have "bs <~~> fs'" by (rule perm_sym)
2.1209 +  with a[symmetric] carr
2.1210 +      show ?thesis
2.1211 +      by (iprover intro: essentially_equalI perm_closed)
2.1212 +qed
2.1213 +
2.1214 +lemma (in monoid) ee_trans [trans]:
2.1215 +  assumes ab: "essentially_equal G as bs" and bc: "essentially_equal G bs cs"
2.1216 +    and ascarr: "set as \<subseteq> carrier G"
2.1217 +    and bscarr: "set bs \<subseteq> carrier G"
2.1218 +    and cscarr: "set cs \<subseteq> carrier G"
2.1219 +  shows "essentially_equal G as cs"
2.1220 +using ab bc
2.1221 +proof (elim essentially_equalE)
2.1222 +  fix abs bcs
2.1223 +  assume  "abs [\<sim>] bs" and pb: "bs <~~> bcs"
2.1224 +  hence "\<exists>bs'. abs <~~> bs' \<and> bs' [\<sim>] bcs" by (rule perm_assoc_switch)
2.1225 +  from this obtain bs'
2.1226 +      where p: "abs <~~> bs'" and a: "bs' [\<sim>] bcs"
2.1227 +      by auto
2.1228 +
2.1229 +  assume "as <~~> abs"
2.1230 +  with p
2.1231 +      have pp: "as <~~> bs'" by fast
2.1232 +
2.1233 +  from pp ascarr have c1: "set bs' \<subseteq> carrier G" by (rule perm_closed)
2.1234 +  from pb bscarr have c2: "set bcs \<subseteq> carrier G" by (rule perm_closed)
2.1235 +  note a
2.1236 +  also assume "bcs [\<sim>] cs"
2.1237 +  finally (listassoc_trans) have"bs' [\<sim>] cs" by (simp add: c1 c2 cscarr)
2.1238 +
2.1239 +  with pp
2.1240 +      show ?thesis
2.1241 +      by (rule essentially_equalI)
2.1242 +qed
2.1243 +
2.1244 +
2.1245 +subsubsection {* Properties of lists of elements *}
2.1246 +
2.1247 +text {* Multiplication of factors in a list *}
2.1248 +
2.1249 +lemma (in monoid) multlist_closed [simp, intro]:
2.1250 +  assumes ascarr: "set fs \<subseteq> carrier G"
2.1251 +  shows "foldr (op \<otimes>) fs \<one> \<in> carrier G"
2.1252 +by (insert ascarr, induct fs, simp+)
2.1253 +
2.1254 +lemma  (in comm_monoid) multlist_dividesI (*[intro]*):
2.1255 +  assumes "f \<in> set fs" and "f \<in> carrier G" and "set fs \<subseteq> carrier G"
2.1256 +  shows "f divides (foldr (op \<otimes>) fs \<one>)"
2.1257 +using assms
2.1258 +apply (induct fs)
2.1259 + apply simp
2.1260 +apply (case_tac "f = a", simp)
2.1261 + apply (fast intro: dividesI)
2.1262 +apply clarsimp
2.1263 +apply (elim dividesE, intro dividesI)
2.1264 + defer 1
2.1265 + apply (simp add: m_comm)
2.1266 + apply (simp add: m_assoc[symmetric])
2.1267 + apply (simp add: m_comm)
2.1268 +apply simp
2.1269 +done
2.1270 +
2.1271 +lemma (in comm_monoid_cancel) multlist_listassoc_cong:
2.1272 +  assumes "fs [\<sim>] fs'"
2.1273 +    and "set fs \<subseteq> carrier G" and "set fs' \<subseteq> carrier G"
2.1274 +  shows "foldr (op \<otimes>) fs \<one> \<sim> foldr (op \<otimes>) fs' \<one>"
2.1275 +using assms
2.1276 +proof (induct fs arbitrary: fs', simp)
2.1277 +  case (Cons a as fs')
2.1278 +  thus ?case
2.1279 +  apply (induct fs', simp)
2.1280 +  proof clarsimp
2.1281 +    fix b bs
2.1282 +    assume "a \<sim> b"
2.1283 +      and acarr: "a \<in> carrier G" and bcarr: "b \<in> carrier G"
2.1284 +      and ascarr: "set as \<subseteq> carrier G"
2.1285 +    hence p: "a \<otimes> foldr op \<otimes> as \<one> \<sim> b \<otimes> foldr op \<otimes> as \<one>"
2.1286 +        by (fast intro: mult_cong_l)
2.1287 +    also
2.1288 +      assume "as [\<sim>] bs"
2.1289 +         and bscarr: "set bs \<subseteq> carrier G"
2.1290 +         and "\<And>fs'. \<lbrakk>as [\<sim>] fs'; set fs' \<subseteq> carrier G\<rbrakk> \<Longrightarrow> foldr op \<otimes> as \<one> \<sim> foldr op \<otimes> fs' \<one>"
2.1291 +      hence "foldr op \<otimes> as \<one> \<sim> foldr op \<otimes> bs \<one>" by simp
2.1292 +      with ascarr bscarr bcarr
2.1293 +          have "b \<otimes> foldr op \<otimes> as \<one> \<sim> b \<otimes> foldr op \<otimes> bs \<one>"
2.1294 +          by (fast intro: mult_cong_r)
2.1295 +   finally
2.1296 +       show "a \<otimes> foldr op \<otimes> as \<one> \<sim> b \<otimes> foldr op \<otimes> bs \<one>"
2.1297 +       by (simp add: ascarr bscarr acarr bcarr)
2.1298 +  qed
2.1299 +qed
2.1300 +
2.1301 +lemma (in comm_monoid) multlist_perm_cong:
2.1302 +  assumes prm: "as <~~> bs"
2.1303 +    and ascarr: "set as \<subseteq> carrier G"
2.1304 +  shows "foldr (op \<otimes>) as \<one> = foldr (op \<otimes>) bs \<one>"
2.1305 +using prm ascarr
2.1306 +apply (induct, simp, clarsimp simp add: m_ac, clarsimp)
2.1307 +proof clarsimp
2.1308 +  fix xs ys zs
2.1309 +  assume "xs <~~> ys"  "set xs \<subseteq> carrier G"
2.1310 +  hence "set ys \<subseteq> carrier G" by (rule perm_closed)
2.1311 +  moreover assume "set ys \<subseteq> carrier G \<Longrightarrow> foldr op \<otimes> ys \<one> = foldr op \<otimes> zs \<one>"
2.1312 +  ultimately show "foldr op \<otimes> ys \<one> = foldr op \<otimes> zs \<one>" by simp
2.1313 +qed
2.1314 +
2.1315 +lemma (in comm_monoid_cancel) multlist_ee_cong:
2.1316 +  assumes "essentially_equal G fs fs'"
2.1317 +    and "set fs \<subseteq> carrier G" and "set fs' \<subseteq> carrier G"
2.1318 +  shows "foldr (op \<otimes>) fs \<one> \<sim> foldr (op \<otimes>) fs' \<one>"
2.1319 +using assms
2.1320 +apply (elim essentially_equalE)
2.1321 +apply (simp add: multlist_perm_cong multlist_listassoc_cong perm_closed)
2.1322 +done
2.1323 +
2.1324 +
2.1325 +subsubsection {* Factorization in irreducible elements *}
2.1326 +
2.1327 +lemma wfactorsI:
2.1328 +  includes (struct G)
2.1329 +  assumes "\<forall>f\<in>set fs. irreducible G f"
2.1330 +    and "foldr (op \<otimes>) fs \<one> \<sim> a"
2.1331 +  shows "wfactors G fs a"
2.1332 +using assms
2.1333 +unfolding wfactors_def
2.1334 +by simp
2.1335 +
2.1336 +lemma wfactorsE:
2.1337 +  includes (struct G)
2.1338 +  assumes wf: "wfactors G fs a"
2.1339 +    and e: "\<lbrakk>\<forall>f\<in>set fs. irreducible G f; foldr (op \<otimes>) fs \<one> \<sim> a\<rbrakk> \<Longrightarrow> P"
2.1340 +  shows "P"
2.1341 +using wf
2.1342 +unfolding wfactors_def
2.1343 +by (fast dest: e)
2.1344 +
2.1345 +lemma (in monoid) factorsI:
2.1346 +  includes (struct G)
2.1347 +  assumes "\<forall>f\<in>set fs. irreducible G f"
2.1348 +    and "foldr (op \<otimes>) fs \<one> = a"
2.1349 +  shows "factors G fs a"
2.1350 +using assms
2.1351 +unfolding factors_def
2.1352 +by simp
2.1353 +
2.1354 +lemma factorsE:
2.1355 +  includes (struct G)
2.1356 +  assumes f: "factors G fs a"
2.1357 +    and e: "\<lbrakk>\<forall>f\<in>set fs. irreducible G f; foldr (op \<otimes>) fs \<one> = a\<rbrakk> \<Longrightarrow> P"
2.1358 +  shows "P"
2.1359 +using f
2.1360 +unfolding factors_def
2.1362 +
2.1363 +lemma (in monoid) factors_wfactors:
2.1364 +  assumes "factors G as a" and "set as \<subseteq> carrier G"
2.1365 +  shows "wfactors G as a"
2.1366 +using assms
2.1367 +by (blast elim: factorsE intro: wfactorsI)
2.1368 +
2.1369 +lemma (in monoid) wfactors_factors:
2.1370 +  assumes "wfactors G as a" and "set as \<subseteq> carrier G"
2.1371 +  shows "\<exists>a'. factors G as a' \<and> a' \<sim> a"
2.1372 +using assms
2.1373 +by (blast elim: wfactorsE intro: factorsI)
2.1374 +
2.1375 +lemma (in monoid) factors_closed [dest]:
2.1376 +  assumes "factors G fs a" and "set fs \<subseteq> carrier G"
2.1377 +  shows "a \<in> carrier G"
2.1378 +using assms
2.1379 +by (elim factorsE, clarsimp)
2.1380 +
2.1381 +lemma (in monoid) nunit_factors:
2.1382 +  assumes anunit: "a \<notin> Units G"
2.1383 +    and fs: "factors G as a"
2.1384 +  shows "length as > 0"
2.1385 +apply (insert fs, elim factorsE)
2.1386 +proof (cases "length as = 0")
2.1387 +  assume "length as = 0"
2.1388 +  hence fold: "foldr op \<otimes> as \<one> = \<one>" by force
2.1389 +
2.1390 +  assume "foldr op \<otimes> as \<one> = a"
2.1391 +  with fold
2.1392 +       have "a = \<one>" by simp
2.1393 +  then have "a \<in> Units G" by fast
2.1394 +  with anunit
2.1395 +       have "False" by simp
2.1396 +  thus ?thesis ..
2.1397 +qed simp
2.1398 +
2.1399 +lemma (in monoid) unit_wfactors [simp]:
2.1400 +  assumes aunit: "a \<in> Units G"
2.1401 +  shows "wfactors G [] a"
2.1402 +using aunit
2.1403 +by (intro wfactorsI) (simp, simp add: Units_assoc)
2.1404 +
2.1405 +lemma (in comm_monoid_cancel) unit_wfactors_empty:
2.1406 +  assumes aunit: "a \<in> Units G"
2.1407 +    and wf: "wfactors G fs a"
2.1408 +    and carr[simp]: "set fs \<subseteq> carrier G"
2.1409 +  shows "fs = []"
2.1410 +proof (rule ccontr, cases fs, simp)
2.1411 +  fix f fs'
2.1412 +  assume fs: "fs = f # fs'"
2.1413 +
2.1414 +  from carr
2.1415 +      have fcarr[simp]: "f \<in> carrier G"
2.1416 +      and carr'[simp]: "set fs' \<subseteq> carrier G"
2.1417 +      by (simp add: fs)+
2.1418 +
2.1419 +  from fs wf
2.1420 +      have "irreducible G f" by (simp add: wfactors_def)
2.1421 +  hence fnunit: "f \<notin> Units G" by (fast elim: irreducibleE)
2.1422 +
2.1423 +  from fs wf
2.1424 +      have a: "f \<otimes> foldr (op \<otimes>) fs' \<one> \<sim> a" by (simp add: wfactors_def)
2.1425 +
2.1426 +  note aunit
2.1427 +  also from fs wf
2.1428 +       have a: "f \<otimes> foldr (op \<otimes>) fs' \<one> \<sim> a" by (simp add: wfactors_def)
2.1429 +       have "a \<sim> f \<otimes> foldr (op \<otimes>) fs' \<one>"
2.1430 +       by (simp add: Units_closed[OF aunit] a[symmetric])
2.1431 +  finally
2.1432 +       have "f \<otimes> foldr (op \<otimes>) fs' \<one> \<in> Units G" by simp
2.1433 +  hence "f \<in> Units G" by (intro unit_factor[of f], simp+)
2.1434 +
2.1435 +  with fnunit show "False" by simp
2.1436 +qed
2.1437 +
2.1438 +
2.1439 +text {* Comparing wfactors *}
2.1440 +
2.1441 +lemma (in comm_monoid_cancel) wfactors_listassoc_cong_l:
2.1442 +  assumes fact: "wfactors G fs a"
2.1443 +    and asc: "fs [\<sim>] fs'"
2.1444 +    and carr: "a \<in> carrier G"  "set fs \<subseteq> carrier G"  "set fs' \<subseteq> carrier G"
2.1445 +  shows "wfactors G fs' a"
2.1446 +using fact
2.1447 +apply (elim wfactorsE, intro wfactorsI)
2.1448 +proof -
2.1449 +  assume "\<forall>f\<in>set fs. irreducible G f"
2.1450 +  also note asc
2.1451 +  finally (irrlist_listassoc_cong)
2.1452 +       show "\<forall>f\<in>set fs'. irreducible G f" by (simp add: carr)
2.1453 +next
2.1454 +  from asc[symmetric]
2.1455 +       have "foldr op \<otimes> fs' \<one> \<sim> foldr op \<otimes> fs \<one>"
2.1456 +       by (simp add: multlist_listassoc_cong carr)
2.1457 +  also assume "foldr op \<otimes> fs \<one> \<sim> a"
2.1458 +  finally
2.1459 +       show "foldr op \<otimes> fs' \<one> \<sim> a" by (simp add: carr)
2.1460 +qed
2.1461 +
2.1462 +lemma (in comm_monoid) wfactors_perm_cong_l:
2.1463 +  assumes "wfactors G fs a"
2.1464 +    and "fs <~~> fs'"
2.1465 +    and "set fs \<subseteq> carrier G"
2.1466 +  shows "wfactors G fs' a"
2.1467 +using assms
2.1468 +apply (elim wfactorsE, intro wfactorsI)
2.1469 + apply (rule irrlist_perm_cong, assumption+)
2.1471 +done
2.1472 +
2.1473 +lemma (in comm_monoid_cancel) wfactors_ee_cong_l [trans]:
2.1474 +  assumes ee: "essentially_equal G as bs"
2.1475 +    and bfs: "wfactors G bs b"
2.1476 +    and carr: "b \<in> carrier G"  "set as \<subseteq> carrier G"  "set bs \<subseteq> carrier G"
2.1477 +  shows "wfactors G as b"
2.1478 +using ee
2.1479 +proof (elim essentially_equalE)
2.1480 +  fix fs
2.1481 +  assume prm: "as <~~> fs"
2.1482 +  with carr
2.1483 +       have fscarr: "set fs \<subseteq> carrier G" by (simp add: perm_closed)
2.1484 +
2.1485 +  note bfs
2.1486 +  also assume [symmetric]: "fs [\<sim>] bs"
2.1487 +  also (wfactors_listassoc_cong_l)
2.1488 +       note prm[symmetric]
2.1489 +  finally (wfactors_perm_cong_l)
2.1490 +       show "wfactors G as b" by (simp add: carr fscarr)
2.1491 +qed
2.1492 +
2.1493 +lemma (in monoid) wfactors_cong_r [trans]:
2.1494 +  assumes fac: "wfactors G fs a" and aa': "a \<sim> a'"
2.1495 +    and carr[simp]: "a \<in> carrier G"  "a' \<in> carrier G"  "set fs \<subseteq> carrier G"
2.1496 +  shows "wfactors G fs a'"
2.1497 +using fac
2.1498 +proof (elim wfactorsE, intro wfactorsI)
2.1499 +  assume "foldr op \<otimes> fs \<one> \<sim> a" also note aa'
2.1500 +  finally show "foldr op \<otimes> fs \<one> \<sim> a'" by simp
2.1501 +qed
2.1502 +
2.1503 +
2.1504 +subsubsection {* Essentially equal factorizations *}
2.1505 +
2.1506 +lemma (in comm_monoid_cancel) unitfactor_ee:
2.1507 +  assumes uunit: "u \<in> Units G"
2.1508 +    and carr: "set as \<subseteq> carrier G"
2.1509 +  shows "essentially_equal G (as[0 := (as!0 \<otimes> u)]) as" (is "essentially_equal G ?as' as")
2.1510 +using assms
2.1511 +apply (intro essentially_equalI[of _ ?as'], simp)
2.1512 +apply (cases as, simp)
2.1513 +apply (clarsimp, fast intro: associatedI2[of u])
2.1514 +done
2.1515 +
2.1516 +lemma (in comm_monoid_cancel) factors_cong_unit:
2.1517 +  assumes uunit: "u \<in> Units G" and anunit: "a \<notin> Units G"
2.1518 +    and afs: "factors G as a"
2.1519 +    and ascarr: "set as \<subseteq> carrier G"
2.1520 +  shows "factors G (as[0 := (as!0 \<otimes> u)]) (a \<otimes> u)" (is "factors G ?as' ?a'")
2.1521 +using assms
2.1522 +apply (elim factorsE, clarify)
2.1523 +apply (cases as)
2.1524 + apply (simp add: nunit_factors)
2.1525 +apply clarsimp
2.1526 +apply (elim factorsE, intro factorsI)
2.1527 + apply (clarsimp, fast intro: irreducible_prod_rI)
2.1528 +apply (simp add: m_ac Units_closed)
2.1529 +done
2.1530 +
2.1531 +lemma (in comm_monoid) perm_wfactorsD:
2.1532 +  assumes prm: "as <~~> bs"
2.1533 +    and afs: "wfactors G as a" and bfs: "wfactors G bs b"
2.1534 +    and [simp]: "a \<in> carrier G"  "b \<in> carrier G"
2.1535 +    and ascarr[simp]: "set as \<subseteq> carrier G"
2.1536 +  shows "a \<sim> b"
2.1537 +using afs bfs
2.1538 +proof (elim wfactorsE)
2.1539 +  from prm have [simp]: "set bs \<subseteq> carrier G" by (simp add: perm_closed)
2.1540 +  assume "foldr op \<otimes> as \<one> \<sim> a"
2.1541 +  hence "a \<sim> foldr op \<otimes> as \<one>" by (rule associated_sym, simp+)
2.1542 +  also from prm
2.1543 +       have "foldr op \<otimes> as \<one> = foldr op \<otimes> bs \<one>" by (rule multlist_perm_cong, simp)
2.1544 +  also assume "foldr op \<otimes> bs \<one> \<sim> b"
2.1545 +  finally
2.1546 +       show "a \<sim> b" by simp
2.1547 +qed
2.1548 +
2.1549 +lemma (in comm_monoid_cancel) listassoc_wfactorsD:
2.1550 +  assumes assoc: "as [\<sim>] bs"
2.1551 +    and afs: "wfactors G as a" and bfs: "wfactors G bs b"
2.1552 +    and [simp]: "a \<in> carrier G"  "b \<in> carrier G"
2.1553 +    and [simp]: "set as \<subseteq> carrier G"  "set bs \<subseteq> carrier G"
2.1554 +  shows "a \<sim> b"
2.1555 +using afs bfs
2.1556 +proof (elim wfactorsE)
2.1557 +  assume "foldr op \<otimes> as \<one> \<sim> a"
2.1558 +  hence "a \<sim> foldr op \<otimes> as \<one>" by (rule associated_sym, simp+)
2.1559 +  also from assoc
2.1560 +       have "foldr op \<otimes> as \<one> \<sim> foldr op \<otimes> bs \<one>" by (rule multlist_listassoc_cong, simp+)
2.1561 +  also assume "foldr op \<otimes> bs \<one> \<sim> b"
2.1562 +  finally
2.1563 +       show "a \<sim> b" by simp
2.1564 +qed
2.1565 +
2.1566 +lemma (in comm_monoid_cancel) ee_wfactorsD:
2.1567 +  assumes ee: "essentially_equal G as bs"
2.1568 +    and afs: "wfactors G as a" and bfs: "wfactors G bs b"
2.1569 +    and [simp]: "a \<in> carrier G"  "b \<in> carrier G"
2.1570 +    and ascarr[simp]: "set as \<subseteq> carrier G" and bscarr[simp]: "set bs \<subseteq> carrier G"
2.1571 +  shows "a \<sim> b"
2.1572 +using ee
2.1573 +proof (elim essentially_equalE)
2.1574 +  fix fs
2.1575 +  assume prm: "as <~~> fs"
2.1576 +  hence as'carr[simp]: "set fs \<subseteq> carrier G" by (simp add: perm_closed)
2.1577 +  from afs prm
2.1578 +      have afs': "wfactors G fs a" by (rule wfactors_perm_cong_l, simp)
2.1579 +  assume "fs [\<sim>] bs"
2.1580 +  from this afs' bfs
2.1581 +      show "a \<sim> b" by (rule listassoc_wfactorsD, simp+)
2.1582 +qed
2.1583 +
2.1584 +lemma (in comm_monoid_cancel) ee_factorsD:
2.1585 +  assumes ee: "essentially_equal G as bs"
2.1586 +    and afs: "factors G as a" and bfs:"factors G bs b"
2.1587 +    and "set as \<subseteq> carrier G"  "set bs \<subseteq> carrier G"
2.1588 +  shows "a \<sim> b"
2.1589 +using assms
2.1590 +by (blast intro: factors_wfactors dest: ee_wfactorsD)
2.1591 +
2.1592 +lemma (in factorial_monoid) ee_factorsI:
2.1593 +  assumes ab: "a \<sim> b"
2.1594 +    and afs: "factors G as a" and anunit: "a \<notin> Units G"
2.1595 +    and bfs: "factors G bs b" and bnunit: "b \<notin> Units G"
2.1596 +    and ascarr: "set as \<subseteq> carrier G" and bscarr: "set bs \<subseteq> carrier G"
2.1597 +  shows "essentially_equal G as bs"
2.1598 +proof -
2.1599 +  note carr[simp] = factors_closed[OF afs ascarr] ascarr[THEN subsetD]
2.1600 +                    factors_closed[OF bfs bscarr] bscarr[THEN subsetD]
2.1601 +
2.1602 +  from ab carr
2.1603 +      have "\<exists>u\<in>Units G. a = b \<otimes> u" by (fast elim: associatedE2)
2.1604 +  from this obtain u
2.1605 +      where uunit: "u \<in> Units G"
2.1606 +      and a: "a = b \<otimes> u" by auto
2.1607 +
2.1608 +  from uunit bscarr
2.1609 +      have ee: "essentially_equal G (bs[0 := (bs!0 \<otimes> u)]) bs"
2.1610 +                (is "essentially_equal G ?bs' bs")
2.1611 +      by (rule unitfactor_ee)
2.1612 +
2.1613 +  from bscarr uunit
2.1614 +      have bs'carr: "set ?bs' \<subseteq> carrier G"
2.1615 +      by (cases bs) (simp add: Units_closed)+
2.1616 +
2.1617 +  from uunit bnunit bfs bscarr
2.1618 +      have fac: "factors G ?bs' (b \<otimes> u)"
2.1619 +      by (rule factors_cong_unit)
2.1620 +
2.1621 +  from afs fac[simplified a[symmetric]] ascarr bs'carr anunit
2.1622 +       have "essentially_equal G as ?bs'"
2.1623 +       by (blast intro: factors_unique)
2.1624 +  also note ee
2.1625 +  finally
2.1626 +      show "essentially_equal G as bs" by (simp add: ascarr bscarr bs'carr)
2.1627 +qed
2.1628 +
2.1629 +lemma (in factorial_monoid) ee_wfactorsI:
2.1630 +  assumes asc: "a \<sim> b"
2.1631 +    and asf: "wfactors G as a" and bsf: "wfactors G bs b"
2.1632 +    and acarr[simp]: "a \<in> carrier G" and bcarr[simp]: "b \<in> carrier G"
2.1633 +    and ascarr[simp]: "set as \<subseteq> carrier G" and bscarr[simp]: "set bs \<subseteq> carrier G"
2.1634 +  shows "essentially_equal G as bs"
2.1635 +using assms
2.1636 +proof (cases "a \<in> Units G")
2.1637 +  assume aunit: "a \<in> Units G"
2.1638 +  also note asc
2.1639 +  finally have bunit: "b \<in> Units G" by simp
2.1640 +
2.1641 +  from aunit asf ascarr
2.1642 +      have e: "as = []" by (rule unit_wfactors_empty)
2.1643 +  from bunit bsf bscarr
2.1644 +      have e': "bs = []" by (rule unit_wfactors_empty)
2.1645 +
2.1646 +  have "essentially_equal G [] []"
2.1647 +      by (fast intro: essentially_equalI)
2.1648 +  thus ?thesis by (simp add: e e')
2.1649 +next
2.1650 +  assume anunit: "a \<notin> Units G"
2.1651 +  have bnunit: "b \<notin> Units G"
2.1652 +  proof clarify
2.1653 +    assume "b \<in> Units G"
2.1654 +    also note asc[symmetric]
2.1655 +    finally have "a \<in> Units G" by simp
2.1656 +    with anunit
2.1657 +         show "False" ..
2.1658 +  qed
2.1659 +
2.1660 +  have "\<exists>a'. factors G as a' \<and> a' \<sim> a" by (rule wfactors_factors[OF asf ascarr])
2.1661 +  from this obtain a'
2.1662 +      where fa': "factors G as a'"
2.1663 +      and a': "a' \<sim> a"
2.1664 +      by auto
2.1665 +  from fa' ascarr
2.1666 +      have a'carr[simp]: "a' \<in> carrier G" by fast
2.1667 +
2.1668 +  have a'nunit: "a' \<notin> Units G"
2.1669 +  proof (clarify)
2.1670 +    assume "a' \<in> Units G"
2.1671 +    also note a'
2.1672 +    finally have "a \<in> Units G" by simp
2.1673 +    with anunit
2.1674 +         show "False" ..
2.1675 +  qed
2.1676 +
2.1677 +  have "\<exists>b'. factors G bs b' \<and> b' \<sim> b" by (rule wfactors_factors[OF bsf bscarr])
2.1678 +  from this obtain b'
2.1679 +      where fb': "factors G bs b'"
2.1680 +      and b': "b' \<sim> b"
2.1681 +      by auto
2.1682 +  from fb' bscarr
2.1683 +      have b'carr[simp]: "b' \<in> carrier G" by fast
2.1684 +
2.1685 +  have b'nunit: "b' \<notin> Units G"
2.1686 +  proof (clarify)
2.1687 +    assume "b' \<in> Units G"
2.1688 +    also note b'
2.1689 +    finally have "b \<in> Units G" by simp
2.1690 +    with bnunit
2.1691 +        show "False" ..
2.1692 +  qed
2.1693 +
2.1694 +  note a'
2.1695 +  also note asc
2.1696 +  also note b'[symmetric]
2.1697 +  finally
2.1698 +       have "a' \<sim> b'" by simp
2.1699 +
2.1700 +  from this fa' a'nunit fb' b'nunit ascarr bscarr
2.1701 +  show "essentially_equal G as bs"
2.1702 +      by (rule ee_factorsI)
2.1703 +qed
2.1704 +
2.1705 +lemma (in factorial_monoid) ee_wfactors:
2.1706 +  assumes asf: "wfactors G as a"
2.1707 +    and bsf: "wfactors G bs b"
2.1708 +    and acarr: "a \<in> carrier G" and bcarr: "b \<in> carrier G"
2.1709 +    and ascarr: "set as \<subseteq> carrier G" and bscarr: "set bs \<subseteq> carrier G"
2.1710 +  shows asc: "a \<sim> b = essentially_equal G as bs"
2.1711 +using assms
2.1712 +by (fast intro: ee_wfactorsI ee_wfactorsD)
2.1713 +
2.1714 +lemma (in factorial_monoid) wfactors_exist [intro, simp]:
2.1715 +  assumes acarr[simp]: "a \<in> carrier G"
2.1716 +  shows "\<exists>fs. set fs \<subseteq> carrier G \<and> wfactors G fs a"
2.1717 +proof (cases "a \<in> Units G")
2.1718 +  assume "a \<in> Units G"
2.1719 +  hence "wfactors G [] a" by (rule unit_wfactors)
2.1720 +  thus ?thesis by (intro exI) force
2.1721 +next
2.1722 +  assume "a \<notin> Units G"
2.1723 +  hence "\<exists>fs. set fs \<subseteq> carrier G \<and> factors G fs a" by (intro factors_exist acarr)
2.1724 +  from this obtain fs
2.1725 +      where fscarr: "set fs \<subseteq> carrier G"
2.1726 +      and f: "factors G fs a"
2.1727 +      by auto
2.1728 +  from f have "wfactors G fs a" by (rule factors_wfactors) fact
2.1729 +  from fscarr this
2.1730 +      show ?thesis by fast
2.1731 +qed
2.1732 +
2.1733 +lemma (in monoid) wfactors_prod_exists [intro, simp]:
2.1734 +  assumes "\<forall>a \<in> set as. irreducible G a" and "set as \<subseteq> carrier G"
2.1735 +  shows "\<exists>a. a \<in> carrier G \<and> wfactors G as a"
2.1736 +unfolding wfactors_def
2.1737 +using assms
2.1738 +by blast
2.1739 +
2.1740 +lemma (in factorial_monoid) wfactors_unique:
2.1741 +  assumes "wfactors G fs a" and "wfactors G fs' a"
2.1742 +    and "a \<in> carrier G"
2.1743 +    and "set fs \<subseteq> carrier G" and "set fs' \<subseteq> carrier G"
2.1744 +  shows "essentially_equal G fs fs'"
2.1745 +using assms
2.1746 +by (fast intro: ee_wfactorsI[of a a])
2.1747 +
2.1748 +lemma (in monoid) factors_mult_single:
2.1749 +  assumes "irreducible G a" and "factors G fb b" and "a \<in> carrier G"
2.1750 +  shows "factors G (a # fb) (a \<otimes> b)"
2.1751 +using assms
2.1752 +unfolding factors_def
2.1753 +by simp
2.1754 +
2.1755 +lemma (in monoid_cancel) wfactors_mult_single:
2.1756 +  assumes f: "irreducible G a"  "wfactors G fb b"
2.1757 +        "a \<in> carrier G"  "b \<in> carrier G"  "set fb \<subseteq> carrier G"
2.1758 +  shows "wfactors G (a # fb) (a \<otimes> b)"
2.1759 +using assms
2.1760 +unfolding wfactors_def
2.1762 +
2.1763 +lemma (in monoid) factors_mult:
2.1764 +  assumes factors: "factors G fa a"  "factors G fb b"
2.1765 +    and ascarr: "set fa \<subseteq> carrier G" and bscarr:"set fb \<subseteq> carrier G"
2.1766 +  shows "factors G (fa @ fb) (a \<otimes> b)"
2.1767 +using assms
2.1768 +unfolding factors_def
2.1769 +apply (safe, force)
2.1770 +apply (induct fa)
2.1771 + apply simp
2.1773 +done
2.1774 +
2.1775 +lemma (in comm_monoid_cancel) wfactors_mult [intro]:
2.1776 +  assumes asf: "wfactors G as a" and bsf:"wfactors G bs b"
2.1777 +    and acarr: "a \<in> carrier G" and bcarr: "b \<in> carrier G"
2.1778 +    and ascarr: "set as \<subseteq> carrier G" and bscarr:"set bs \<subseteq> carrier G"
2.1779 +  shows "wfactors G (as @ bs) (a \<otimes> b)"
2.1780 +apply (insert wfactors_factors[OF asf ascarr])
2.1781 +apply (insert wfactors_factors[OF bsf bscarr])
2.1782 +proof (clarsimp)
2.1783 +  fix a' b'
2.1784 +  assume asf': "factors G as a'" and a'a: "a' \<sim> a"
2.1785 +     and bsf': "factors G bs b'" and b'b: "b' \<sim> b"
2.1786 +  from asf' have a'carr: "a' \<in> carrier G" by (rule factors_closed) fact
2.1787 +  from bsf' have b'carr: "b' \<in> carrier G" by (rule factors_closed) fact
2.1788 +
2.1789 +  note carr = acarr bcarr a'carr b'carr ascarr bscarr
2.1790 +
2.1791 +  from asf' bsf'
2.1792 +      have "factors G (as @ bs) (a' \<otimes> b')" by (rule factors_mult) fact+
2.1793 +
2.1794 +  with carr
2.1795 +       have abf': "wfactors G (as @ bs) (a' \<otimes> b')" by (intro factors_wfactors) simp+
2.1796 +  also from b'b carr
2.1797 +       have trb: "a' \<otimes> b' \<sim> a' \<otimes> b" by (intro mult_cong_r)
2.1798 +  also from a'a carr
2.1799 +       have tra: "a' \<otimes> b \<sim> a \<otimes> b" by (intro mult_cong_l)
2.1800 +  finally
2.1801 +       show "wfactors G (as @ bs) (a \<otimes> b)"
2.1802 +       by (simp add: carr)
2.1803 +qed
2.1804 +
2.1805 +lemma (in comm_monoid) factors_dividesI:
2.1806 +  assumes "factors G fs a" and "f \<in> set fs"
2.1807 +    and "set fs \<subseteq> carrier G"
2.1808 +  shows "f divides a"
2.1809 +using assms
2.1810 +by (fast elim: factorsE intro: multlist_dividesI)
2.1811 +
2.1812 +lemma (in comm_monoid) wfactors_dividesI:
2.1813 +  assumes p: "wfactors G fs a"
2.1814 +    and fscarr: "set fs \<subseteq> carrier G" and acarr: "a \<in> carrier G"
2.1815 +    and f: "f \<in> set fs"
2.1816 +  shows "f divides a"
2.1817 +apply (insert wfactors_factors[OF p fscarr], clarsimp)
2.1818 +proof -
2.1819 +  fix a'
2.1820 +  assume fsa': "factors G fs a'"
2.1821 +    and a'a: "a' \<sim> a"
2.1822 +  with fscarr
2.1823 +      have a'carr: "a' \<in> carrier G" by (simp add: factors_closed)
2.1824 +
2.1825 +  from fsa' fscarr f
2.1826 +       have "f divides a'" by (fast intro: factors_dividesI)
2.1827 +  also note a'a
2.1828 +  finally
2.1829 +       show "f divides a" by (simp add: f fscarr[THEN subsetD] acarr a'carr)
2.1830 +qed
2.1831 +
2.1832 +
2.1833 +subsubsection {* Factorial monoids and wfactors *}
2.1834 +
2.1835 +lemma (in comm_monoid_cancel) factorial_monoidI:
2.1836 +  assumes wfactors_exists:
2.1837 +          "\<And>a. a \<in> carrier G \<Longrightarrow> \<exists>fs. set fs \<subseteq> carrier G \<and> wfactors G fs a"
2.1838 +      and wfactors_unique:
2.1839 +          "\<And>a fs fs'. \<lbrakk>a \<in> carrier G; set fs \<subseteq> carrier G; set fs' \<subseteq> carrier G;
2.1840 +                       wfactors G fs a; wfactors G fs' a\<rbrakk> \<Longrightarrow> essentially_equal G fs fs'"
2.1841 +  shows "factorial_monoid G"
2.1842 +proof (unfold_locales)
2.1843 +  fix a
2.1844 +  assume acarr: "a \<in> carrier G" and anunit: "a \<notin> Units G"
2.1845 +
2.1846 +  from wfactors_exists[OF acarr]
2.1847 +  obtain as
2.1848 +      where ascarr: "set as \<subseteq> carrier G"
2.1849 +      and afs: "wfactors G as a"
2.1850 +      by auto
2.1851 +  from afs ascarr
2.1852 +      have "\<exists>a'. factors G as a' \<and> a' \<sim> a" by (rule wfactors_factors)
2.1853 +  from this obtain a'
2.1854 +      where afs': "factors G as a'"
2.1855 +      and a'a: "a' \<sim> a"
2.1856 +      by auto
2.1857 +  from afs' ascarr
2.1858 +      have a'carr: "a' \<in> carrier G" by fast
2.1859 +  have a'nunit: "a' \<notin> Units G"
2.1860 +  proof clarify
2.1861 +    assume "a' \<in> Units G"
2.1862 +    also note a'a
2.1863 +    finally have "a \<in> Units G" by (simp add: acarr)
2.1864 +    with anunit
2.1865 +        show "False" ..
2.1866 +  qed
2.1867 +
2.1868 +  from a'carr acarr a'a
2.1869 +      have "\<exists>u. u \<in> Units G \<and> a' = a \<otimes> u" by (blast elim: associatedE2)
2.1870 +  from this obtain  u
2.1871 +      where uunit: "u \<in> Units G"
2.1872 +      and a': "a' = a \<otimes> u"
2.1873 +      by auto
2.1874 +
2.1875 +  note [simp] = acarr Units_closed[OF uunit] Units_inv_closed[OF uunit]
2.1876 +
2.1877 +  have "a = a \<otimes> \<one>" by simp
2.1878 +  also have "\<dots> = a \<otimes> (u \<otimes> inv u)" by (simp add: Units_r_inv uunit)
2.1879 +  also have "\<dots> = a' \<otimes> inv u" by (simp add: m_assoc[symmetric] a'[symmetric])
2.1880 +  finally
2.1881 +       have a: "a = a' \<otimes> inv u" .
2.1882 +
2.1883 +  from ascarr uunit
2.1884 +      have cr: "set (as[0:=(as!0 \<otimes> inv u)]) \<subseteq> carrier G"
2.1885 +      by (cases as, clarsimp+)
2.1886 +
2.1887 +  from afs' uunit a'nunit acarr ascarr
2.1888 +      have "factors G (as[0:=(as!0 \<otimes> inv u)]) a"
2.1889 +      by (simp add: a factors_cong_unit)
2.1890 +
2.1891 +  with cr
2.1892 +      show "\<exists>fs. set fs \<subseteq> carrier G \<and> factors G fs a" by fast
2.1893 +qed (blast intro: factors_wfactors wfactors_unique)
2.1894 +
2.1895 +
2.1896 +subsection {* Factorizations as multisets *}
2.1897 +
2.1898 +text {* Gives useful operations like intersection *}
2.1899 +
2.1900 +(* FIXME: use class_of x instead of closure_of {x} *)
2.1901 +
2.1902 +abbreviation
2.1903 +  "assocs G x == eq_closure_of (division_rel G) {x}"
2.1904 +
2.1905 +constdefs (structure G)
2.1906 +  "fmset G as \<equiv> multiset_of (map (\<lambda>a. assocs G a) as)"
2.1907 +
2.1908 +
2.1909 +text {* Helper lemmas *}
2.1910 +
2.1911 +lemma (in monoid) assocs_repr_independence:
2.1912 +  assumes "y \<in> assocs G x"
2.1913 +    and "x \<in> carrier G"
2.1914 +  shows "assocs G x = assocs G y"
2.1915 +using assms
2.1916 +apply safe
2.1917 + apply (elim closure_ofE2, intro closure_ofI2[of _ _ y])
2.1918 +   apply (clarsimp, iprover intro: associated_trans associated_sym, simp+)
2.1919 +apply (elim closure_ofE2, intro closure_ofI2[of _ _ x])
2.1920 +  apply (clarsimp, iprover intro: associated_trans, simp+)
2.1921 +done
2.1922 +
2.1923 +lemma (in monoid) assocs_self:
2.1924 +  assumes "x \<in> carrier G"
2.1925 +  shows "x \<in> assocs G x"
2.1926 +using assms
2.1927 +by (fastsimp intro: closure_ofI2)
2.1928 +
2.1929 +lemma (in monoid) assocs_repr_independenceD:
2.1930 +  assumes repr: "assocs G x = assocs G y"
2.1931 +    and ycarr: "y \<in> carrier G"
2.1932 +  shows "y \<in> assocs G x"
2.1933 +unfolding repr
2.1934 +using ycarr
2.1935 +by (intro assocs_self)
2.1936 +
2.1937 +lemma (in comm_monoid) assocs_assoc:
2.1938 +  assumes "a \<in> assocs G b"
2.1939 +    and "b \<in> carrier G"
2.1940 +  shows "a \<sim> b"
2.1941 +using assms
2.1942 +by (elim closure_ofE2, simp)
2.1943 +
2.1944 +lemmas (in comm_monoid) assocs_eqD =
2.1945 +    assocs_repr_independenceD[THEN assocs_assoc]
2.1946 +
2.1947 +
2.1948 +subsubsection {* Comparing multisets *}
2.1949 +
2.1950 +lemma (in monoid) fmset_perm_cong:
2.1951 +  assumes prm: "as <~~> bs"
2.1952 +  shows "fmset G as = fmset G bs"
2.1953 +using perm_map[OF prm]
2.1954 +by (simp add: multiset_of_eq_perm fmset_def)
2.1955 +
2.1956 +lemma (in comm_monoid_cancel) eqc_listassoc_cong:
2.1957 +  assumes "as [\<sim>] bs"
2.1958 +    and "set as \<subseteq> carrier G" and "set bs \<subseteq> carrier G"
2.1959 +  shows "map (assocs G) as = map (assocs G) bs"
2.1960 +using assms
2.1961 +apply (induct as arbitrary: bs, simp)
2.1962 +apply (clarsimp simp add: Cons_eq_map_conv list_all2_Cons1, safe)
2.1963 + apply (clarsimp elim!: closure_ofE2) defer 1
2.1964 + apply (clarsimp elim!: closure_ofE2) defer 1
2.1965 +proof -
2.1966 +  fix a x z
2.1967 +  assume carr[simp]: "a \<in> carrier G"  "x \<in> carrier G"  "z \<in> carrier G"
2.1968 +  assume "x \<sim> a"
2.1969 +  also assume "a \<sim> z"
2.1970 +  finally have "x \<sim> z" by simp
2.1971 +  with carr
2.1972 +      show "x \<in> assocs G z"
2.1973 +      by (intro closure_ofI2) simp+
2.1974 +next
2.1975 +  fix a x z
2.1976 +  assume carr[simp]: "a \<in> carrier G"  "x \<in> carrier G"  "z \<in> carrier G"
2.1977 +  assume "x \<sim> z"
2.1978 +  also assume [symmetric]: "a \<sim> z"
2.1979 +  finally have "x \<sim> a" by simp
2.1980 +  with carr
2.1981 +      show "x \<in> assocs G a"
2.1982 +      by (intro closure_ofI2) simp+
2.1983 +qed
2.1984 +
2.1985 +lemma (in comm_monoid_cancel) fmset_listassoc_cong:
2.1986 +  assumes "as [\<sim>] bs"
2.1987 +    and "set as \<subseteq> carrier G" and "set bs \<subseteq> carrier G"
2.1988 +  shows "fmset G as = fmset G bs"
2.1989 +using assms
2.1990 +unfolding fmset_def
2.1992 +
2.1993 +lemma (in comm_monoid_cancel) ee_fmset:
2.1994 +  assumes ee: "essentially_equal G as bs"
2.1995 +    and ascarr: "set as \<subseteq> carrier G" and bscarr: "set bs \<subseteq> carrier G"
2.1996 +  shows "fmset G as = fmset G bs"
2.1997 +using ee
2.1998 +proof (elim essentially_equalE)
2.1999 +  fix as'
2.2000 +  assume prm: "as <~~> as'"
2.2001 +  from prm ascarr
2.2002 +      have as'carr: "set as' \<subseteq> carrier G" by (rule perm_closed)
2.2003 +
2.2004 +  from prm
2.2005 +       have "fmset G as = fmset G as'" by (rule fmset_perm_cong)
2.2006 +  also assume "as' [\<sim>] bs"
2.2007 +       with as'carr bscarr
2.2008 +       have "fmset G as' = fmset G bs" by (simp add: fmset_listassoc_cong)
2.2009 +  finally
2.2010 +       show "fmset G as = fmset G bs" .
2.2011 +qed
2.2012 +
2.2013 +lemma (in monoid_cancel) fmset_ee__hlp_induct:
2.2014 +  assumes prm: "cas <~~> cbs"
2.2015 +    and cdef: "cas = map (assocs G) as"  "cbs = map (assocs G) bs"
2.2016 +  shows "\<forall>as bs. (cas <~~> cbs \<and> cas = map (assocs G) as \<and>
2.2017 +                 cbs = map (assocs G) bs) \<longrightarrow> (\<exists>as'. as <~~> as' \<and> map (assocs G) as' = cbs)"
2.2018 +apply (rule perm.induct[of cas cbs], rule prm)
2.2019 +apply safe apply simp_all
2.2020 +  apply (simp add: map_eq_Cons_conv, blast)
2.2021 + apply force
2.2022 +proof -
2.2023 +  fix ys as bs
2.2024 +  assume p1: "map (assocs G) as <~~> ys"
2.2025 +    and r1[rule_format]:
2.2026 +        "\<forall>asa bs. map (assocs G) as = map (assocs G) asa \<and>
2.2027 +                  ys = map (assocs G) bs
2.2028 +                  \<longrightarrow> (\<exists>as'. asa <~~> as' \<and> map (assocs G) as' = map (assocs G) bs)"
2.2029 +    and p2: "ys <~~> map (assocs G) bs"
2.2030 +    and r2[rule_format]:
2.2031 +        "\<forall>as bsa. ys = map (assocs G) as \<and>
2.2032 +                  map (assocs G) bs = map (assocs G) bsa
2.2033 +                  \<longrightarrow> (\<exists>as'. as <~~> as' \<and> map (assocs G) as' = map (assocs G) bsa)"
2.2034 +    and p3: "map (assocs G) as <~~> map (assocs G) bs"
2.2035 +
2.2036 +  from p1
2.2037 +      have "multiset_of (map (assocs G) as) = multiset_of ys"
2.2038 +      by (simp add: multiset_of_eq_perm)
2.2039 +  hence setys: "set (map (assocs G) as) = set ys" by (rule multiset_of_eq_setD)
2.2040 +
2.2041 +  have "set (map (assocs G) as) = { assocs G x | x. x \<in> set as}" by clarsimp fast
2.2042 +  with setys have "set ys \<subseteq> { assocs G x | x. x \<in> set as}" by simp
2.2043 +  hence "\<exists>yy. ys = map (assocs G) yy"
2.2044 +    apply (induct ys, simp, clarsimp)
2.2045 +  proof -
2.2046 +    fix yy x
2.2047 +    show "\<exists>yya. (assocs G x) # map (assocs G) yy =
2.2048 +                map (assocs G) yya"
2.2049 +    by (rule exI[of _ "x#yy"], simp)
2.2050 +  qed
2.2051 +  from this obtain yy
2.2052 +      where ys: "ys = map (assocs G) yy"
2.2053 +      by auto
2.2054 +
2.2055 +  from p1 ys
2.2056 +      have "\<exists>as'. as <~~> as' \<and> map (assocs G) as' = map (assocs G) yy"
2.2057 +      by (intro r1, simp)
2.2058 +  from this obtain as'
2.2059 +      where asas': "as <~~> as'"
2.2060 +      and as'yy: "map (assocs G) as' = map (assocs G) yy"
2.2061 +      by auto
2.2062 +
2.2063 +  from p2 ys
2.2064 +      have "\<exists>as'. yy <~~> as' \<and> map (assocs G) as' = map (assocs G) bs"
2.2065 +      by (intro r2, simp)
2.2066 +  from this obtain as''
2.2067 +      where yyas'': "yy <~~> as''"
2.2068 +      and as''bs: "map (assocs G) as'' = map (assocs G) bs"
2.2069 +      by auto
2.2070 +
2.2071 +  from as'yy and yyas''
2.2072 +      have "\<exists>cs. as' <~~> cs \<and> map (assocs G) cs = map (assocs G) as''"
2.2073 +      by (rule perm_map_switch)
2.2074 +  from this obtain cs
2.2075 +      where as'cs: "as' <~~> cs"
2.2076 +      and csas'': "map (assocs G) cs = map (assocs G) as''"
2.2077 +      by auto
2.2078 +
2.2079 +  from asas' and as'cs
2.2080 +      have ascs: "as <~~> cs" by fast
2.2081 +  from csas'' and as''bs
2.2082 +      have "map (assocs G) cs = map (assocs G) bs" by simp
2.2083 +  from ascs and this
2.2084 +  show "\<exists>as'. as <~~> as' \<and> map (assocs G) as' = map (assocs G) bs" by fast
2.2085 +qed
2.2086 +
2.2087 +lemma (in comm_monoid_cancel) fmset_ee:
2.2088 +  assumes mset: "fmset G as = fmset G bs"
2.2089 +    and ascarr: "set as \<subseteq> carrier G" and bscarr: "set bs \<subseteq> carrier G"
2.2090 +  shows "essentially_equal G as bs"
2.2091 +proof -
2.2092 +  from mset
2.2093 +      have mpp: "map (assocs G) as <~~> map (assocs G) bs"
2.2094 +      by (simp add: fmset_def multiset_of_eq_perm)
2.2095 +
2.2096 +  have "\<exists>cas. cas = map (assocs G) as" by simp
2.2097 +  from this obtain cas where cas: "cas = map (assocs G) as" by simp
2.2098 +
2.2099 +  have "\<exists>cbs. cbs = map (assocs G) bs" by simp
2.2100 +  from this obtain cbs where cbs: "cbs = map (assocs G) bs" by simp
2.2101 +
2.2102 +  from cas cbs mpp
2.2103 +      have [rule_format]:
2.2104 +           "\<forall>as bs. (cas <~~> cbs \<and> cas = map (assocs G) as \<and>
2.2105 +                     cbs = map (assocs G) bs)
2.2106 +                     \<longrightarrow> (\<exists>as'. as <~~> as' \<and> map (assocs G) as' = cbs)"
2.2107 +      by (intro fmset_ee__hlp_induct, simp+)
2.2108 +  with mpp cas cbs
2.2109 +      have "\<exists>as'. as <~~> as' \<and> map (assocs G) as' = map (assocs G) bs"
2.2110 +      by simp
2.2111 +
2.2112 +  from this obtain as'
2.2113 +      where tp: "as <~~> as'"
2.2114 +      and tm: "map (assocs G) as' = map (assocs G) bs"
2.2115 +      by auto
2.2116 +  from tm have lene: "length as' = length bs" by (rule map_eq_imp_length_eq)
2.2117 +  from tp have "set as = set as'" by (simp add: multiset_of_eq_perm multiset_of_eq_setD)
2.2118 +  with ascarr
2.2119 +      have as'carr: "set as' \<subseteq> carrier G" by simp
2.2120 +
2.2121 +  from tm as'carr[THEN subsetD] bscarr[THEN subsetD]
2.2122 +  have "as' [\<sim>] bs"
2.2123 +    by (induct as' arbitrary: bs) (simp, fastsimp dest: assocs_eqD[THEN associated_sym])
2.2124 +
2.2125 +  from tp and this
2.2126 +    show "essentially_equal G as bs" by (fast intro: essentially_equalI)
2.2127 +qed
2.2128 +
2.2129 +lemma (in comm_monoid_cancel) ee_is_fmset:
2.2130 +  assumes "set as \<subseteq> carrier G" and "set bs \<subseteq> carrier G"
2.2131 +  shows "essentially_equal G as bs = (fmset G as = fmset G bs)"
2.2132 +using assms
2.2133 +by (fast intro: ee_fmset fmset_ee)
2.2134 +
2.2135 +
2.2136 +subsubsection {* Interpreting multisets as factorizations *}
2.2137 +
2.2138 +lemma (in monoid) mset_fmsetEx:
2.2139 +  assumes elems: "\<And>X. X \<in> set_of Cs \<Longrightarrow> \<exists>x. P x \<and> X = assocs G x"
2.2140 +  shows "\<exists>cs. (\<forall>c \<in> set cs. P c) \<and> fmset G cs = Cs"
2.2141 +proof -
2.2142 +  have "\<exists>Cs'. Cs = multiset_of Cs'"
2.2143 +      by (rule surjE[OF surj_multiset_of], fast)
2.2144 +  from this obtain Cs'
2.2145 +      where Cs: "Cs = multiset_of Cs'"
2.2146 +      by auto
2.2147 +
2.2148 +  have "\<exists>cs. (\<forall>c \<in> set cs. P c) \<and> multiset_of (map (assocs G) cs) = Cs"
2.2149 +  using elems
2.2150 +  unfolding Cs
2.2151 +    apply (induct Cs', simp)
2.2152 +    apply clarsimp
2.2153 +    apply (subgoal_tac "\<exists>cs. (\<forall>x\<in>set cs. P x) \<and>
2.2154 +                             multiset_of (map (assocs G) cs) = multiset_of Cs'")
2.2155 +  proof clarsimp
2.2156 +    fix a Cs' cs
2.2157 +    assume ih: "\<And>X. X = a \<or> X \<in> set Cs' \<Longrightarrow> \<exists>x. P x \<and> X = assocs G x"
2.2158 +      and csP: "\<forall>x\<in>set cs. P x"
2.2159 +      and mset: "multiset_of (map (assocs G) cs) = multiset_of Cs'"
2.2160 +    from ih
2.2161 +        have "\<exists>x. P x \<and> a = assocs G x" by fast
2.2162 +    from this obtain c
2.2163 +        where cP: "P c"
2.2164 +        and a: "a = assocs G c"
2.2165 +        by auto
2.2166 +    from cP csP
2.2167 +        have tP: "\<forall>x\<in>set (c#cs). P x" by simp
2.2168 +    from mset a
2.2169 +    have "multiset_of (map (assocs G) (c#cs)) = multiset_of Cs' + {#a#}" by simp
2.2170 +    from tP this
2.2171 +    show "\<exists>cs. (\<forall>x\<in>set cs. P x) \<and>
2.2172 +               multiset_of (map (assocs G) cs) =
2.2173 +               multiset_of Cs' + {#a#}" by fast
2.2174 +  qed simp
2.2175 +  thus ?thesis by (simp add: fmset_def)
2.2176 +qed
2.2177 +
2.2178 +lemma (in monoid) mset_wfactorsEx:
2.2179 +  assumes elems: "\<And>X. X \<in> set_of Cs
2.2180 +                      \<Longrightarrow> \<exists>x. (x \<in> carrier G \<and> irreducible G x) \<and> X = assocs G x"
2.2181 +  shows "\<exists>c cs. c \<in> carrier G \<and> set cs \<subseteq> carrier G \<and> wfactors G cs c \<and> fmset G cs = Cs"
2.2182 +proof -
2.2183 +  have "\<exists>cs. (\<forall>c\<in>set cs. c \<in> carrier G \<and> irreducible G c) \<and> fmset G cs = Cs"
2.2184 +      by (intro mset_fmsetEx, rule elems)
2.2185 +  from this obtain cs
2.2186 +      where p[rule_format]: "\<forall>c\<in>set cs. c \<in> carrier G \<and> irreducible G c"
2.2187 +      and Cs[symmetric]: "fmset G cs = Cs"
2.2188 +      by auto
2.2189 +
2.2190 +  from p
2.2191 +      have cscarr: "set cs \<subseteq> carrier G" by fast
2.2192 +
2.2193 +  from p
2.2194 +      have "\<exists>c. c \<in> carrier G \<and> wfactors G cs c"
2.2195 +      by (intro wfactors_prod_exists) fast+
2.2196 +  from this obtain c
2.2197 +      where ccarr: "c \<in> carrier G"
2.2198 +      and cfs: "wfactors G cs c"
2.2199 +      by auto
2.2200 +
2.2201 +  with cscarr Cs
2.2202 +      show ?thesis by fast
2.2203 +qed
2.2204 +
2.2205 +
2.2206 +subsubsection {* Multiplication on multisets *}
2.2207 +
2.2208 +lemma (in factorial_monoid) mult_wfactors_fmset:
2.2209 +  assumes afs: "wfactors G as a" and bfs: "wfactors G bs b" and cfs: "wfactors G cs (a \<otimes> b)"
2.2210 +    and carr: "a \<in> carrier G"  "b \<in> carrier G"
2.2211 +              "set as \<subseteq> carrier G"  "set bs \<subseteq> carrier G"  "set cs \<subseteq> carrier G"
2.2212 +  shows "fmset G cs = fmset G as + fmset G bs"
2.2213 +proof -
2.2214 +  from assms
2.2215 +       have "wfactors G (as @ bs) (a \<otimes> b)" by (intro wfactors_mult)
2.2216 +  with carr cfs
2.2217 +       have "essentially_equal G cs (as@bs)" by (intro ee_wfactorsI[of "a\<otimes>b" "a\<otimes>b"], simp+)
2.2218 +  with carr
2.2219 +       have "fmset G cs = fmset G (as@bs)" by (intro ee_fmset, simp+)
2.2220 +  also have "fmset G (as@bs) = fmset G as + fmset G bs" by (simp add: fmset_def)
2.2221 +  finally show "fmset G cs = fmset G as + fmset G bs" .
2.2222 +qed
2.2223 +
2.2224 +lemma (in factorial_monoid) mult_factors_fmset:
2.2225 +  assumes afs: "factors G as a" and bfs: "factors G bs b" and cfs: "factors G cs (a \<otimes> b)"
2.2226 +    and "set as \<subseteq> carrier G"  "set bs \<subseteq> carrier G"  "set cs \<subseteq> carrier G"
2.2227 +  shows "fmset G cs = fmset G as + fmset G bs"
2.2228 +using assms
2.2229 +by (blast intro: factors_wfactors mult_wfactors_fmset)
2.2230 +
2.2231 +lemma (in comm_monoid_cancel) fmset_wfactors_mult:
2.2232 +  assumes mset: "fmset G cs = fmset G as + fmset G bs"
2.2233 +    and carr: "a \<in> carrier G"  "b \<in> carrier G"  "c \<in> carrier G"
2.2234 +          "set as \<subseteq> carrier G"  "set bs \<subseteq> carrier G"  "set cs \<subseteq> carrier G"
2.2235 +    and fs: "wfactors G as a"  "wfactors G bs b"  "wfactors G cs c"
2.2236 +  shows "c \<sim> a \<otimes> b"
2.2237 +proof -
2.2238 +  from carr fs
2.2239 +       have m: "wfactors G (as @ bs) (a \<otimes> b)" by (intro wfactors_mult)
2.2240 +
2.2241 +  from mset
2.2242 +       have "fmset G cs = fmset G (as@bs)" by (simp add: fmset_def)
2.2243 +  then have "essentially_equal G cs (as@bs)" by (rule fmset_ee) (simp add: carr)+
2.2244 +  then show "c \<sim> a \<otimes> b" by (rule ee_wfactorsD[of "cs" "as@bs"]) (simp add: assms m)+
2.2245 +qed
2.2246 +
2.2247 +
2.2248 +subsubsection {* Divisibility on multisets *}
2.2249 +
2.2250 +lemma (in factorial_monoid) divides_fmsubset:
2.2251 +  assumes ab: "a divides b"
2.2252 +    and afs: "wfactors G as a" and bfs: "wfactors G bs b"
2.2253 +    and carr: "a \<in> carrier G"  "b \<in> carrier G"  "set as \<subseteq> carrier G"  "set bs \<subseteq> carrier G"
2.2254 +  shows "fmset G as \<le># fmset G bs"
2.2255 +using ab
2.2256 +proof (elim dividesE)
2.2257 +  fix c
2.2258 +  assume ccarr: "c \<in> carrier G"
2.2259 +  hence "\<exists>cs. set cs \<subseteq> carrier G \<and> wfactors G cs c" by (rule wfactors_exist)
2.2260 +  from this obtain cs
2.2261 +      where cscarr: "set cs \<subseteq> carrier G"
2.2262 +      and cfs: "wfactors G cs c" by auto
2.2263 +  note carr = carr ccarr cscarr
2.2264 +
2.2265 +  assume "b = a \<otimes> c"
2.2266 +  with afs bfs cfs carr
2.2267 +      have "fmset G bs = fmset G as + fmset G cs"
2.2268 +      by (intro mult_wfactors_fmset[OF afs cfs]) simp+
2.2269 +
2.2270 +  thus ?thesis by simp
2.2271 +qed
2.2272 +
2.2273 +lemma (in comm_monoid_cancel) fmsubset_divides:
2.2274 +  assumes msubset: "fmset G as \<le># fmset G bs"
2.2275 +    and afs: "wfactors G as a" and bfs: "wfactors G bs b"
2.2276 +    and acarr: "a \<in> carrier G" and bcarr: "b \<in> carrier G"
2.2277 +    and ascarr: "set as \<subseteq> carrier G" and bscarr: "set bs \<subseteq> carrier G"
2.2278 +  shows "a divides b"
2.2279 +proof -
2.2280 +  from afs have airr: "\<forall>a \<in> set as. irreducible G a" by (fast elim: wfactorsE)
2.2281 +  from bfs have birr: "\<forall>b \<in> set bs. irreducible G b" by (fast elim: wfactorsE)
2.2282 +
2.2283 +  have "\<exists>c cs. c \<in> carrier G \<and> set cs \<subseteq> carrier G \<and> wfactors G cs c \<and> fmset G cs = fmset G bs - fmset G as"
2.2284 +  proof (intro mset_wfactorsEx, simp)
2.2285 +    fix X
2.2286 +    assume "count (fmset G as) X < count (fmset G bs) X"
2.2287 +    hence "0 < count (fmset G bs) X" by simp
2.2288 +    hence "X \<in> set_of (fmset G bs)" by simp
2.2289 +    hence "X \<in> set (map (assocs G) bs)" by (simp add: fmset_def)
2.2290 +    hence "\<exists>x. x \<in> set bs \<and> X = assocs G x" by (induct bs) auto
2.2291 +    from this obtain x
2.2292 +        where xbs: "x \<in> set bs"
2.2293 +        and X: "X = assocs G x"
2.2294 +        by auto
2.2295 +
2.2296 +    with bscarr have xcarr: "x \<in> carrier G" by fast
2.2297 +    from xbs birr have xirr: "irreducible G x" by simp
2.2298 +
2.2299 +    from xcarr and xirr and X
2.2300 +        show "\<exists>x. x \<in> carrier G \<and> irreducible G x \<and> X = assocs G x" by fast
2.2301 +  qed
2.2302 +  from this obtain c cs
2.2303 +      where ccarr: "c \<in> carrier G"
2.2304 +      and cscarr: "set cs \<subseteq> carrier G"
2.2305 +      and csf: "wfactors G cs c"
2.2306 +      and csmset: "fmset G cs = fmset G bs - fmset G as" by auto
2.2307 +
2.2308 +  from csmset msubset
2.2309 +      have "fmset G bs = fmset G as + fmset G cs"
2.2310 +      by (simp add: multiset_eq_conv_count_eq mset_le_def)
2.2311 +  hence basc: "b \<sim> a \<otimes> c"
2.2312 +      by (rule fmset_wfactors_mult) fact+
2.2313 +
2.2314 +  thus ?thesis
2.2315 +  proof (elim associatedE2)
2.2316 +    fix u
2.2317 +    assume "u \<in> Units G"  "b = a \<otimes> c \<otimes> u"
2.2318 +    with acarr ccarr
2.2319 +        show "a divides b" by (fast intro: dividesI[of "c \<otimes> u"] m_assoc)
2.2320 +  qed (simp add: acarr bcarr ccarr)+
2.2321 +qed
2.2322 +
2.2323 +lemma (in factorial_monoid) divides_as_fmsubset:
2.2324 +  assumes "wfactors G as a" and "wfactors G bs b"
2.2325 +    and "a \<in> carrier G" and "b \<in> carrier G"
2.2326 +    and "set as \<subseteq> carrier G" and "set bs \<subseteq> carrier G"
2.2327 +  shows "a divides b = (fmset G as \<le># fmset G bs)"
2.2328 +using assms
2.2329 +by (blast intro: divides_fmsubset fmsubset_divides)
2.2330 +
2.2331 +
2.2332 +text {* Proper factors on multisets *}
2.2333 +
2.2334 +lemma (in factorial_monoid) fmset_properfactor:
2.2335 +  assumes asubb: "fmset G as \<le># fmset G bs"
2.2336 +    and anb: "fmset G as \<noteq> fmset G bs"
2.2337 +    and "wfactors G as a" and "wfactors G bs b"
2.2338 +    and "a \<in> carrier G" and "b \<in> carrier G"
2.2339 +    and "set as \<subseteq> carrier G" and "set bs \<subseteq> carrier G"
2.2340 +  shows "properfactor G a b"
2.2341 +apply (rule properfactorI)
2.2342 +apply (rule fmsubset_divides[of as bs], fact+)
2.2343 +proof
2.2344 +  assume "b divides a"
2.2345 +  hence "fmset G bs \<le># fmset G as"
2.2346 +      by (rule divides_fmsubset) fact+
2.2347 +  with asubb
2.2348 +      have "fmset G as = fmset G bs" by (simp add: mset_le_antisym)
2.2349 +  with anb
2.2350 +      show "False" ..
2.2351 +qed
2.2352 +
2.2353 +lemma (in factorial_monoid) properfactor_fmset:
2.2354 +  assumes pf: "properfactor G a b"
2.2355 +    and "wfactors G as a" and "wfactors G bs b"
2.2356 +    and "a \<in> carrier G" and "b \<in> carrier G"
2.2357 +    and "set as \<subseteq> carrier G" and "set bs \<subseteq> carrier G"
2.2358 +  shows "fmset G as \<le># fmset G bs \<and> fmset G as \<noteq> fmset G bs"
2.2359 +using pf
2.2360 +apply (elim properfactorE)
2.2361 +apply rule
2.2362 + apply (intro divides_fmsubset, assumption)
2.2363 +  apply (rule assms)+
2.2364 +proof
2.2365 +  assume bna: "\<not> b divides a"
2.2366 +  assume "fmset G as = fmset G bs"
2.2367 +  then have "essentially_equal G as bs" by (rule fmset_ee) fact+
2.2368 +  hence "a \<sim> b" by (rule ee_wfactorsD[of as bs]) fact+
2.2369 +  hence "b divides a" by (elim associatedE)
2.2370 +  with bna
2.2371 +      show "False" ..
2.2372 +qed
2.2373 +
2.2374 +
2.2375 +subsection {* Irreducible elements are prime *}
2.2376 +
2.2377 +lemma (in factorial_monoid) irreducible_is_prime:
2.2378 +  assumes pirr: "irreducible G p"
2.2379 +    and pcarr: "p \<in> carrier G"
2.2380 +  shows "prime G p"
2.2381 +using pirr
2.2382 +proof (elim irreducibleE, intro primeI)
2.2383 +  fix a b
2.2384 +  assume acarr: "a \<in> carrier G"  and bcarr: "b \<in> carrier G"
2.2385 +    and pdvdab: "p divides (a \<otimes> b)"
2.2386 +    and pnunit: "p \<notin> Units G"
2.2387 +  assume irreduc[rule_format]:
2.2388 +         "\<forall>b. b \<in> carrier G \<and> properfactor G b p \<longrightarrow> b \<in> Units G"
2.2389 +  from pdvdab
2.2390 +      have "\<exists>c\<in>carrier G. a \<otimes> b = p \<otimes> c" by (rule dividesD)
2.2391 +  from this obtain c
2.2392 +      where ccarr: "c \<in> carrier G"
2.2393 +      and abpc: "a \<otimes> b = p \<otimes> c"
2.2394 +      by auto
2.2395 +
2.2396 +  from acarr have "\<exists>fs. set fs \<subseteq> carrier G \<and> wfactors G fs a" by (rule wfactors_exist)
2.2397 +  from this obtain as where ascarr: "set as \<subseteq> carrier G" and afs: "wfactors G as a" by auto
2.2398 +
2.2399 +  from bcarr have "\<exists>fs. set fs \<subseteq> carrier G \<and> wfactors G fs b" by (rule wfactors_exist)
2.2400 +  from this obtain bs where bscarr: "set bs \<subseteq> carrier G" and bfs: "wfactors G bs b" by auto
2.2401 +
2.2402 +  from ccarr have "\<exists>fs. set fs \<subseteq> carrier G \<and> wfactors G fs c" by (rule wfactors_exist)
2.2403 +  from this obtain cs where cscarr: "set cs \<subseteq> carrier G" and cfs: "wfactors G cs c" by auto
2.2404 +
2.2405 +  note carr[simp] = pcarr acarr bcarr ccarr ascarr bscarr cscarr
2.2406 +
2.2407 +  from afs and bfs
2.2408 +      have abfs: "wfactors G (as @ bs) (a \<otimes> b)" by (rule wfactors_mult) fact+
2.2409 +
2.2410 +  from pirr cfs
2.2411 +      have pcfs: "wfactors G (p # cs) (p \<otimes> c)" by (rule wfactors_mult_single) fact+
2.2412 +  with abpc
2.2413 +      have abfs': "wfactors G (p # cs) (a \<otimes> b)" by simp
2.2414 +
2.2415 +  from abfs' abfs
2.2416 +      have "essentially_equal G (p # cs) (as @ bs)"
2.2417 +      by (rule wfactors_unique) simp+
2.2418 +
2.2419 +  hence "\<exists>ds. p # cs <~~> ds \<and> ds [\<sim>] (as @ bs)"
2.2420 +      by (fast elim: essentially_equalE)
2.2421 +  from this obtain ds
2.2422 +      where "p # cs <~~> ds"
2.2423 +      and dsassoc: "ds [\<sim>] (as @ bs)"
2.2424 +      by auto
2.2425 +
2.2426 +  then have "p \<in> set ds"
2.2427 +       by (simp add: perm_set_eq[symmetric])
2.2428 +  with dsassoc
2.2429 +       have "\<exists>p'. p' \<in> set (as@bs) \<and> p \<sim> p'"
2.2430 +       unfolding list_all2_conv_all_nth set_conv_nth
2.2431 +       by force
2.2432 +
2.2433 +  from this obtain p'
2.2434 +       where "p' \<in> set (as@bs)"
2.2435 +       and pp': "p \<sim> p'"
2.2436 +       by auto
2.2437 +
2.2438 +  hence "p' \<in> set as \<or> p' \<in> set bs" by simp
2.2439 +  moreover
2.2440 +  {
2.2441 +    assume p'elem: "p' \<in> set as"
2.2442 +    with ascarr have [simp]: "p' \<in> carrier G" by fast
2.2443 +
2.2444 +    note pp'
2.2445 +    also from afs
2.2446 +         have "p' divides a" by (rule wfactors_dividesI) fact+
2.2447 +    finally
2.2448 +         have "p divides a" by simp
2.2449 +  }
2.2450 +  moreover
2.2451 +  {
2.2452 +    assume p'elem: "p' \<in> set bs"
2.2453 +    with bscarr have [simp]: "p' \<in> carrier G" by fast
2.2454 +
2.2455 +    note pp'
2.2456 +    also from bfs
2.2457 +         have "p' divides b" by (rule wfactors_dividesI) fact+
2.2458 +    finally
2.2459 +         have "p divides b" by simp
2.2460 +  }
2.2461 +  ultimately
2.2462 +      show "p divides a \<or> p divides b" by fast
2.2463 +qed
2.2464 +
2.2465 +
2.2466 +--"A version using @{const factors}, more complicated"
2.2467 +lemma (in factorial_monoid) factors_irreducible_is_prime:
2.2468 +  assumes pirr: "irreducible G p"
2.2469 +    and pcarr: "p \<in> carrier G"
2.2470 +  shows "prime G p"
2.2471 +using pirr
2.2472 +apply (elim irreducibleE, intro primeI)
2.2473 + apply assumption
2.2474 +proof -
2.2475 +  fix a b
2.2476 +  assume acarr: "a \<in> carrier G"
2.2477 +    and bcarr: "b \<in> carrier G"
2.2478 +    and pdvdab: "p divides (a \<otimes> b)"
2.2479 +  assume irreduc[rule_format]:
2.2480 +         "\<forall>b. b \<in> carrier G \<and> properfactor G b p \<longrightarrow> b \<in> Units G"
2.2481 +  from pdvdab
2.2482 +      have "\<exists>c\<in>carrier G. a \<otimes> b = p \<otimes> c" by (rule dividesD)
2.2483 +  from this obtain c
2.2484 +      where ccarr: "c \<in> carrier G"
2.2485 +      and abpc: "a \<otimes> b = p \<otimes> c"
2.2486 +      by auto
2.2487 +  note [simp] = pcarr acarr bcarr ccarr
2.2488 +
2.2489 +  show "p divides a \<or> p divides b"
2.2490 +  proof (cases "a \<in> Units G")
2.2491 +    assume aunit: "a \<in> Units G"
2.2492 +
2.2493 +    note pdvdab
2.2494 +    also have "a \<otimes> b = b \<otimes> a" by (simp add: m_comm)
2.2495 +    also from aunit
2.2496 +         have bab: "b \<otimes> a \<sim> b"
2.2497 +         by (intro associatedI2[of "a"], simp+)
2.2498 +    finally
2.2499 +         have "p divides b" by simp
2.2500 +    thus "p divides a \<or> p divides b" ..
2.2501 +  next
2.2502 +    assume anunit: "a \<notin> Units G"
2.2503 +
2.2504 +    show "p divides a \<or> p divides b"
2.2505 +    proof (cases "b \<in> Units G")
2.2506 +      assume bunit: "b \<in> Units G"
2.2507 +
2.2508 +      note pdvdab
2.2509 +      also from bunit
2.2510 +           have baa: "a \<otimes> b \<sim> a"
2.2511 +           by (intro associatedI2[of "b"], simp+)
2.2512 +      finally
2.2513 +           have "p divides a" by simp
2.2514 +      thus "p divides a \<or> p divides b" ..
2.2515 +    next
2.2516 +      assume bnunit: "b \<notin> Units G"
2.2517 +
2.2518 +      have cnunit: "c \<notin> Units G"
2.2519 +      proof (rule ccontr, simp)
2.2520 +        assume cunit: "c \<in> Units G"
2.2521 +        from bnunit
2.2522 +             have "properfactor G a (a \<otimes> b)"
2.2523 +             by (intro properfactorI3[of _ _ b], simp+)
2.2524 +        also note abpc
2.2525 +        also from cunit
2.2526 +             have "p \<otimes> c \<sim> p"
2.2527 +             by (intro associatedI2[of c], simp+)
2.2528 +        finally
2.2529 +             have "properfactor G a p" by simp
2.2530 +
2.2531 +        with acarr
2.2532 +             have "a \<in> Units G" by (fast intro: irreduc)
2.2533 +        with anunit
2.2534 +             show "False" ..
2.2535 +      qed
2.2536 +
2.2537 +      have abnunit: "a \<otimes> b \<notin> Units G"
2.2538 +      proof clarsimp
2.2539 +        assume abunit: "a \<otimes> b \<in> Units G"
2.2540 +        hence "a \<in> Units G" by (rule unit_factor) fact+
2.2541 +        with anunit
2.2542 +             show "False" ..
2.2543 +      qed
2.2544 +
2.2545 +      from acarr anunit have "\<exists>fs. set fs \<subseteq> carrier G \<and> factors G fs a" by (rule factors_exist)
2.2546 +      then obtain as where ascarr: "set as \<subseteq> carrier G" and afac: "factors G as a" by auto
2.2547 +
2.2548 +      from bcarr bnunit have "\<exists>fs. set fs \<subseteq> carrier G \<and> factors G fs b" by (rule factors_exist)
2.2549 +      then obtain bs where bscarr: "set bs \<subseteq> carrier G" and bfac: "factors G bs b" by auto
2.2550 +
2.2551 +      from ccarr cnunit have "\<exists>fs. set fs \<subseteq> carrier G \<and> factors G fs c" by (rule factors_exist)
2.2552 +      then obtain cs where cscarr: "set cs \<subseteq> carrier G" and cfac: "factors G cs c" by auto
2.2553 +
2.2554 +      note [simp] = ascarr bscarr cscarr
2.2555 +
2.2556 +      from afac and bfac
2.2557 +          have abfac: "factors G (as @ bs) (a \<otimes> b)" by (rule factors_mult) fact+
2.2558 +
2.2559 +      from pirr cfac
2.2560 +          have pcfac: "factors G (p # cs) (p \<otimes> c)" by (rule factors_mult_single) fact+
2.2561 +      with abpc
2.2562 +          have abfac': "factors G (p # cs) (a \<otimes> b)" by simp
2.2563 +
2.2564 +      from abfac' abfac
2.2565 +          have "essentially_equal G (p # cs) (as @ bs)"
2.2566 +          by (rule factors_unique) (fact | simp)+
2.2567 +
2.2568 +      hence "\<exists>ds. p # cs <~~> ds \<and> ds [\<sim>] (as @ bs)"
2.2569 +          by (fast elim: essentially_equalE)
2.2570 +      from this obtain ds
2.2571 +          where "p # cs <~~> ds"
2.2572 +          and dsassoc: "ds [\<sim>] (as @ bs)"
2.2573 +          by auto
2.2574 +
2.2575 +      then have "p \<in> set ds"
2.2576 +           by (simp add: perm_set_eq[symmetric])
2.2577 +      with dsassoc
2.2578 +           have "\<exists>p'. p' \<in> set (as@bs) \<and> p \<sim> p'"
2.2579 +           unfolding list_all2_conv_all_nth set_conv_nth
2.2580 +           by force
2.2581 +
2.2582 +      from this obtain p'
2.2583 +	  where "p' \<in> set (as@bs)"
2.2584 +	  and pp': "p \<sim> p'" by auto
2.2585 +
2.2586 +      hence "p' \<in> set as \<or> p' \<in> set bs" by simp
2.2587 +      moreover
2.2588 +      {
2.2589 +	assume p'elem: "p' \<in> set as"
2.2590 +	with ascarr have [simp]: "p' \<in> carrier G" by fast
2.2591 +
2.2592 +	note pp'
2.2593 +	also from afac p'elem
2.2594 +	     have "p' divides a" by (rule factors_dividesI) fact+
2.2595 +	finally
2.2596 +	     have "p divides a" by simp
2.2597 +      }
2.2598 +      moreover
2.2599 +      {
2.2600 +	assume p'elem: "p' \<in> set bs"
2.2601 +	with bscarr have [simp]: "p' \<in> carrier G" by fast
2.2602 +
2.2603 +	note pp'
2.2604 +	also from bfac
2.2605 +	     have "p' divides b" by (rule factors_dividesI) fact+
2.2606 +	finally have "p divides b" by simp
2.2607 +      }
2.2608 +      ultimately
2.2609 +	  show "p divides a \<or> p divides b" by fast
2.2610 +    qed
2.2611 +  qed
2.2612 +qed
2.2613 +
2.2614 +
2.2615 +subsection {* Greatest common divisors and lowest common multiples *}
2.2616 +
2.2617 +subsubsection {* Definitions *}
2.2618 +
2.2619 +constdefs (structure G)
2.2620 +  isgcd :: "[('a,_) monoid_scheme, 'a, 'a, 'a] \<Rightarrow> bool"  ("(_ gcdof\<index> _ _)" [81,81,81] 80)
2.2621 +  "x gcdof a b \<equiv> x divides a \<and> x divides b \<and>
2.2622 +                 (\<forall>y\<in>carrier G. (y divides a \<and> y divides b \<longrightarrow> y divides x))"
2.2623 +
2.2624 +  islcm :: "[_, 'a, 'a, 'a] \<Rightarrow> bool"  ("(_ lcmof\<index> _ _)" [81,81,81] 80)
2.2625 +  "x lcmof a b \<equiv> a divides x \<and> b divides x \<and>
2.2626 +                 (\<forall>y\<in>carrier G. (a divides y \<and> b divides y \<longrightarrow> x divides y))"
2.2627 +
2.2628 +constdefs (structure G)
2.2629 +  somegcd :: "('a,_) monoid_scheme \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"
2.2630 +  "somegcd G a b == SOME x. x \<in> carrier G \<and> x gcdof a b"
2.2631 +
2.2632 +  somelcm :: "('a,_) monoid_scheme \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"
2.2633 +  "somelcm G a b == SOME x. x \<in> carrier G \<and> x lcmof a b"
2.2634 +
2.2635 +constdefs (structure G)
2.2636 +  "SomeGcd G A == ginf (division_rel G) A"
2.2637 +
2.2638 +
2.2639 +locale gcd_condition_monoid = comm_monoid_cancel +
2.2640 +  assumes gcdof_exists:
2.2641 +          "\<lbrakk>a \<in> carrier G; b \<in> carrier G\<rbrakk> \<Longrightarrow> \<exists>c. c \<in> carrier G \<and> c gcdof a b"
2.2642 +
2.2643 +locale primeness_condition_monoid = comm_monoid_cancel +
2.2644 +  assumes irreducible_prime:
2.2645 +          "\<lbrakk>a \<in> carrier G; irreducible G a\<rbrakk> \<Longrightarrow> prime G a"
2.2646 +
2.2647 +locale divisor_chain_condition_monoid = comm_monoid_cancel +
2.2648 +  assumes division_wellfounded:
2.2649 +          "wf {(x, y). x \<in> carrier G \<and> y \<in> carrier G \<and> properfactor G x y}"
2.2650 +
2.2651 +
2.2652 +subsubsection {* Connections to \texttt{Lattice.thy} *}
2.2653 +
2.2654 +lemma gcdof_ggreatestLower:
2.2655 +  fixes G (structure)
2.2656 +  assumes carr[simp]: "a \<in> carrier G"  "b \<in> carrier G"
2.2657 +  shows "(x \<in> carrier G \<and> x gcdof a b) =
2.2658 +         ggreatest (division_rel G) x (Lower (division_rel G) {a, b})"
2.2659 +unfolding isgcd_def ggreatest_def Lower_def elem_def
2.2660 +proof (simp, safe)
2.2661 +  fix xa
2.2662 +  assume r1[rule_format]: "\<forall>x. (x = a \<or> x = b) \<and> x \<in> carrier G \<longrightarrow> xa divides x"
2.2663 +  assume r2[rule_format]: "\<forall>y\<in>carrier G. y divides a \<and> y divides b \<longrightarrow> y divides x"
2.2664 +
2.2665 +  assume "xa \<in> carrier G"  "x divides a"  "x divides b"
2.2666 +  with carr
2.2667 +  show "xa divides x"
2.2668 +      by (fast intro: r1 r2)
2.2669 +next
2.2670 +  fix a' y
2.2671 +  assume r1[rule_format]:
2.2672 +         "\<forall>xa\<in>{l. \<forall>x. (x = a \<or> x = b) \<and> x \<in> carrier G \<longrightarrow> l divides x} \<inter> carrier G.
2.2673 +           xa divides x"
2.2674 +  assume "y \<in> carrier G"  "y divides a"  "y divides b"
2.2675 +  with carr
2.2676 +       show "y divides x"
2.2677 +       by (fast intro: r1)
2.2678 +qed (simp, simp)
2.2679 +
2.2680 +lemma lcmof_gleastUpper:
2.2681 +  fixes G (structure)
2.2682 +  assumes carr[simp]: "a \<in> carrier G"  "b \<in> carrier G"
2.2683 +  shows "(x \<in> carrier G \<and> x lcmof a b) =
2.2684 +         gleast (division_rel G) x (Upper (division_rel G) {a, b})"
2.2685 +unfolding islcm_def gleast_def Upper_def elem_def
2.2686 +proof (simp, safe)
2.2687 +  fix xa
2.2688 +  assume r1[rule_format]: "\<forall>x. (x = a \<or> x = b) \<and> x \<in> carrier G \<longrightarrow> x divides xa"
2.2689 +  assume r2[rule_format]: "\<forall>y\<in>carrier G. a divides y \<and> b divides y \<longrightarrow> x divides y"
2.2690 +
2.2691 +  assume "xa \<in> carrier G"  "a divides x"  "b divides x"
2.2692 +  with carr
2.2693 +  show "x divides xa"
2.2694 +      by (fast intro: r1 r2)
2.2695 +next
2.2696 +  fix a' y
2.2697 +  assume r1[rule_format]:
2.2698 +         "\<forall>xa\<in>{l. \<forall>x. (x = a \<or> x = b) \<and> x \<in> carrier G \<longrightarrow> x divides l} \<inter> carrier G.
2.2699 +           x divides xa"
2.2700 +  assume "y \<in> carrier G"  "a divides y"  "b divides y"
2.2701 +  with carr
2.2702 +       show "x divides y"
2.2703 +       by (fast intro: r1)
2.2704 +qed (simp, simp)
2.2705 +
2.2706 +lemma somegcd_gmeet:
2.2707 +  fixes G (structure)
2.2708 +  assumes carr: "a \<in> carrier G"  "b \<in> carrier G"
2.2709 +  shows "somegcd G a b = gmeet (division_rel G) a b"
2.2710 +unfolding somegcd_def gmeet_def ginf_def
2.2711 +by (simp add: gcdof_ggreatestLower[OF carr])
2.2712 +
2.2713 +lemma (in monoid) isgcd_divides_l:
2.2714 +  assumes "a divides b"
2.2715 +    and "a \<in> carrier G"  "b \<in> carrier G"
2.2716 +  shows "a gcdof a b"
2.2717 +using assms
2.2718 +unfolding isgcd_def
2.2719 +by fast
2.2720 +
2.2721 +lemma (in monoid) isgcd_divides_r:
2.2722 +  assumes "b divides a"
2.2723 +    and "a \<in> carrier G"  "b \<in> carrier G"
2.2724 +  shows "b gcdof a b"
2.2725 +using assms
2.2726 +unfolding isgcd_def
2.2727 +by fast
2.2728 +
2.2729 +
2.2730 +subsubsection {* Existence of gcd and lcm *}
2.2731 +
2.2732 +lemma (in factorial_monoid) gcdof_exists:
2.2733 +  assumes acarr: "a \<in> carrier G" and bcarr: "b \<in> carrier G"
2.2734 +  shows "\<exists>c. c \<in> carrier G \<and> c gcdof a b"
2.2735 +proof -
2.2736 +  from acarr have "\<exists>as. set as \<subseteq> carrier G \<and> wfactors G as a" by (rule wfactors_exist)
2.2737 +  from this obtain as
2.2738 +      where ascarr: "set as \<subseteq> carrier G"
2.2739 +      and afs: "wfactors G as a"
2.2740 +      by auto
2.2741 +  from afs have airr: "\<forall>a \<in> set as. irreducible G a" by (fast elim: wfactorsE)
2.2742 +
2.2743 +  from bcarr have "\<exists>bs. set bs \<subseteq> carrier G \<and> wfactors G bs b" by (rule wfactors_exist)
2.2744 +  from this obtain bs
2.2745 +      where bscarr: "set bs \<subseteq> carrier G"
2.2746 +      and bfs: "wfactors G bs b"
2.2747 +      by auto
2.2748 +  from bfs have birr: "\<forall>b \<in> set bs. irreducible G b" by (fast elim: wfactorsE)
2.2749 +
2.2750 +  have "\<exists>c cs. c \<in> carrier G \<and> set cs \<subseteq> carrier G \<and> wfactors G cs c \<and>
2.2751 +               fmset G cs = fmset G as #\<inter> fmset G bs"
2.2752 +  proof (intro mset_wfactorsEx)
2.2753 +    fix X
2.2754 +    assume "X \<in> set_of (fmset G as #\<inter> fmset G bs)"
2.2755 +    hence "X \<in> set_of (fmset G as)" by (simp add: multiset_inter_def)
2.2756 +    hence "X \<in> set (map (assocs G) as)" by (simp add: fmset_def)
2.2757 +    hence "\<exists>x. X = assocs G x \<and> x \<in> set as" by (induct as) auto
2.2758 +    from this obtain x
2.2759 +        where X: "X = assocs G x"
2.2760 +        and xas: "x \<in> set as"
2.2761 +        by auto
2.2762 +    with ascarr have xcarr: "x \<in> carrier G" by fast
2.2763 +    from xas airr have xirr: "irreducible G x" by simp
2.2764 +
2.2765 +    from xcarr and xirr and X
2.2766 +        show "\<exists>x. (x \<in> carrier G \<and> irreducible G x) \<and> X = assocs G x" by fast
2.2767 +  qed
2.2768 +
2.2769 +  from this obtain c cs
2.2770 +      where ccarr: "c \<in> carrier G"
2.2771 +      and cscarr: "set cs \<subseteq> carrier G"
2.2772 +      and csirr: "wfactors G cs c"
2.2773 +      and csmset: "fmset G cs = fmset G as #\<inter> fmset G bs" by auto
2.2774 +
2.2775 +  have "c gcdof a b"
2.2776 +  proof (simp add: isgcd_def, safe)
2.2777 +    from csmset
2.2778 +        have "fmset G cs \<le># fmset G as"
2.2779 +        by (simp add: multiset_inter_def mset_le_def)
2.2780 +    thus "c divides a" by (rule fmsubset_divides) fact+
2.2781 +  next
2.2782 +    from csmset
2.2783 +        have "fmset G cs \<le># fmset G bs"
2.2784 +        by (simp add: multiset_inter_def mset_le_def, force)
2.2785 +    thus "c divides b" by (rule fmsubset_divides) fact+
2.2786 +  next
2.2787 +    fix y
2.2788 +    assume ycarr: "y \<in> carrier G"
2.2789 +    hence "\<exists>ys. set ys \<subseteq> carrier G \<and> wfactors G ys y" by (rule wfactors_exist)
2.2790 +    from this obtain ys
2.2791 +        where yscarr: "set ys \<subseteq> carrier G"
2.2792 +        and yfs: "wfactors G ys y"
2.2793 +        by auto
2.2794 +
2.2795 +    assume "y divides a"
2.2796 +    hence ya: "fmset G ys \<le># fmset G as" by (rule divides_fmsubset) fact+
2.2797 +
2.2798 +    assume "y divides b"
2.2799 +    hence yb: "fmset G ys \<le># fmset G bs" by (rule divides_fmsubset) fact+
2.2800 +
2.2801 +    from ya yb csmset
2.2802 +    have "fmset G ys \<le># fmset G cs" by (simp add: mset_le_def multiset_inter_count)
2.2803 +    thus "y divides c" by (rule fmsubset_divides) fact+
2.2804 +  qed
2.2805 +
2.2806 +  with ccarr
2.2807 +      show "\<exists>c. c \<in> carrier G \<and> c gcdof a b" by fast
2.2808 +qed
2.2809 +
2.2810 +lemma (in factorial_monoid) lcmof_exists:
2.2811 +  assumes acarr: "a \<in> carrier G" and bcarr: "b \<in> carrier G"
2.2812 +  shows "\<exists>c. c \<in> carrier G \<and> c lcmof a b"
2.2813 +proof -
2.2814 +  from acarr have "\<exists>as. set as \<subseteq> carrier G \<and> wfactors G as a" by (rule wfactors_exist)
2.2815 +  from this obtain as
2.2816 +      where ascarr: "set as \<subseteq> carrier G"
2.2817 +      and afs: "wfactors G as a"
2.2818 +      by auto
2.2819 +  from afs have airr: "\<forall>a \<in> set as. irreducible G a" by (fast elim: wfactorsE)
2.2820 +
2.2821 +  from bcarr have "\<exists>bs. set bs \<subseteq> carrier G \<and> wfactors G bs b" by (rule wfactors_exist)
2.2822 +  from this obtain bs
2.2823 +      where bscarr: "set bs \<subseteq> carrier G"
2.2824 +      and bfs: "wfactors G bs b"
2.2825 +      by auto
2.2826 +  from bfs have birr: "\<forall>b \<in> set bs. irreducible G b" by (fast elim: wfactorsE)
2.2827 +
2.2828 +  have "\<exists>c cs. c \<in> carrier G \<and> set cs \<subseteq> carrier G \<and> wfactors G cs c \<and>
2.2829 +               fmset G cs = (fmset G as - fmset G bs) + fmset G bs"
2.2830 +  proof (intro mset_wfactorsEx)
2.2831 +    fix X
2.2832 +    assume "X \<in> set_of ((fmset G as - fmset G bs) + fmset G bs)"
2.2833 +    hence "X \<in> set_of (fmset G as) \<or> X \<in> set_of (fmset G bs)"
2.2834 +       by (cases "X :# fmset G bs", simp, simp)
2.2835 +    moreover
2.2836 +    {
2.2837 +      assume "X \<in> set_of (fmset G as)"
2.2838 +      hence "X \<in> set (map (assocs G) as)" by (simp add: fmset_def)
2.2839 +      hence "\<exists>x. x \<in> set as \<and> X = assocs G x" by (induct as) auto
2.2840 +      from this obtain x
2.2841 +          where xas: "x \<in> set as"
2.2842 +          and X: "X = assocs G x" by auto
2.2843 +
2.2844 +      with ascarr have xcarr: "x \<in> carrier G" by fast
2.2845 +      from xas airr have xirr: "irreducible G x" by simp
2.2846 +
2.2847 +      from xcarr and xirr and X
2.2848 +          have "\<exists>x. (x \<in> carrier G \<and> irreducible G x) \<and> X = assocs G x" by fast
2.2849 +    }
2.2850 +    moreover
2.2851 +    {
2.2852 +      assume "X \<in> set_of (fmset G bs)"
2.2853 +      hence "X \<in> set (map (assocs G) bs)" by (simp add: fmset_def)
2.2854 +      hence "\<exists>x. x \<in> set bs \<and> X = assocs G x" by (induct as) auto
2.2855 +      from this obtain x
2.2856 +          where xbs: "x \<in> set bs"
2.2857 +          and X: "X = assocs G x" by auto
2.2858 +
2.2859 +      with bscarr have xcarr: "x \<in> carrier G" by fast
2.2860 +      from xbs birr have xirr: "irreducible G x" by simp
2.2861 +
2.2862 +      from xcarr and xirr and X
2.2863 +          have "\<exists>x. (x \<in> carrier G \<and> irreducible G x) \<and> X = assocs G x" by fast
2.2864 +    }
2.2865 +    ultimately
2.2866 +    show "\<exists>x. (x \<in> carrier G \<and> irreducible G x) \<and> X = assocs G x" by fast
2.2867 +  qed
2.2868 +
2.2869 +  from this obtain c cs
2.2870 +      where ccarr: "c \<in> carrier G"
2.2871 +      and cscarr: "set cs \<subseteq> carrier G"
2.2872 +      and csirr: "wfactors G cs c"
2.2873 +      and csmset: "fmset G cs = fmset G as - fmset G bs + fmset G bs" by auto
2.2874 +
2.2875 +  have "c lcmof a b"
2.2876 +  proof (simp add: islcm_def, safe)
2.2877 +    from csmset have "fmset G as \<le># fmset G cs" by (simp add: mset_le_def, force)
2.2878 +    thus "a divides c" by (rule fmsubset_divides) fact+
2.2879 +  next
2.2880 +    from csmset have "fmset G bs \<le># fmset G cs" by (simp add: mset_le_def)
2.2881 +    thus "b divides c" by (rule fmsubset_divides) fact+
2.2882 +  next
2.2883 +    fix y
2.2884 +    assume ycarr: "y \<in> carrier G"
2.2885 +    hence "\<exists>ys. set ys \<subseteq> carrier G \<and> wfactors G ys y" by (rule wfactors_exist)
2.2886 +    from this obtain ys
2.2887 +        where yscarr: "set ys \<subseteq> carrier G"
2.2888 +        and yfs: "wfactors G ys y"
2.2889 +        by auto
2.2890 +
2.2891 +    assume "a divides y"
2.2892 +    hence ya: "fmset G as \<le># fmset G ys" by (rule divides_fmsubset) fact+
2.2893 +
2.2894 +    assume "b divides y"
2.2895 +    hence yb: "fmset G bs \<le># fmset G ys" by (rule divides_fmsubset) fact+
2.2896 +
2.2897 +    from ya yb csmset
2.2898 +    have "fmset G cs \<le># fmset G ys"
2.2899 +      apply (simp add: mset_le_def, clarify)
2.2900 +      apply (case_tac "count (fmset G as) a < count (fmset G bs) a")
2.2901 +       apply simp
2.2902 +      apply simp
2.2903 +    done
2.2904 +    thus "c divides y" by (rule fmsubset_divides) fact+
2.2905 +  qed
2.2906 +
2.2907 +  with ccarr
2.2908 +      show "\<exists>c. c \<in> carrier G \<and> c lcmof a b" by fast
2.2909 +qed
2.2910 +
2.2911 +
2.2912 +subsection {* Conditions for factoriality *}
2.2913 +
2.2914 +subsubsection {* Gcd condition *}
2.2915 +
2.2916 +lemma (in gcd_condition_monoid) division_glower_semilattice [simp]:
2.2917 +  shows "glower_semilattice (division_rel G)"
2.2918 +proof -
2.2919 +  interpret gpartial_order ["division_rel G"] ..
2.2920 +  show ?thesis
2.2921 +  apply (unfold_locales, simp_all)
2.2922 +  proof -
2.2923 +    fix x y
2.2924 +    assume carr: "x \<in> carrier G"  "y \<in> carrier G"
2.2925 +    hence "\<exists>z. z \<in> carrier G \<and> z gcdof x y" by (rule gcdof_exists)
2.2926 +    from this obtain z
2.2927 +        where zcarr: "z \<in> carrier G"
2.2928 +        and isgcd: "z gcdof x y"
2.2929 +        by auto
2.2930 +    with carr
2.2931 +    have "ggreatest (division_rel G) z (Lower (division_rel G) {x, y})"
2.2932 +        by (subst gcdof_ggreatestLower[symmetric], simp+)
2.2933 +    thus "\<exists>z. ggreatest (division_rel G) z (Lower (division_rel G) {x, y})" by fast
2.2934 +  qed
2.2935 +qed
2.2936 +
2.2937 +lemma (in gcd_condition_monoid) gcdof_cong_l:
2.2938 +  assumes a'a: "a' \<sim> a"
2.2939 +    and agcd: "a gcdof b c"
2.2940 +    and a'carr: "a' \<in> carrier G" and carr': "a \<in> carrier G"  "b \<in> carrier G"  "c \<in> carrier G"
2.2941 +  shows "a' gcdof b c"
2.2942 +proof -
2.2943 +  note carr = a'carr carr'
2.2944 +  interpret glower_semilattice ["division_rel G"] by simp
2.2945 +  have "a' \<in> carrier G \<and> a' gcdof b c"
2.2946 +    apply (simp add: gcdof_ggreatestLower carr')
2.2947 +    apply (subst ggreatest_Lower_cong_l[of _ a])
2.2948 +       apply (simp add: a'a)
2.2949 +      apply (simp add: carr)
2.2950 +     apply (simp add: carr)
2.2951 +    apply (simp add: carr)
2.2952 +    apply (simp add: gcdof_ggreatestLower[symmetric] agcd carr)
2.2953 +  done
2.2954 +  thus ?thesis ..
2.2955 +qed
2.2956 +
2.2957 +lemma (in gcd_condition_monoid) gcd_closed [simp]:
2.2958 +  assumes carr: "a \<in> carrier G"  "b \<in> carrier G"
2.2959 +  shows "somegcd G a b \<in> carrier G"
2.2960 +proof -
2.2961 +  interpret glower_semilattice ["division_rel G"] by simp
2.2962 +  show ?thesis
2.2963 +    apply (simp add: somegcd_gmeet[OF carr])
2.2964 +    apply (rule gmeet_closed[simplified], fact+)
2.2965 +  done
2.2966 +qed
2.2967 +
2.2968 +lemma (in gcd_condition_monoid) gcd_isgcd:
2.2969 +  assumes carr: "a \<in> carrier G"  "b \<in> carrier G"
2.2970 +  shows "(somegcd G a b) gcdof a b"
2.2971 +proof -
2.2972 +  interpret glower_semilattice ["division_rel G"] by simp
2.2973 +  from carr
2.2974 +  have "somegcd G a b \<in> carrier G \<and> (somegcd G a b) gcdof a b"
2.2975 +    apply (subst gcdof_ggreatestLower, simp, simp)
2.2976 +    apply (simp add: somegcd_gmeet[OF carr] gmeet_def)
2.2977 +    apply (rule ginf_of_two_ggreatest[simplified], assumption+)
2.2978 +  done
2.2979 +  thus "(somegcd G a b) gcdof a b" by simp
2.2980 +qed
2.2981 +
2.2982 +lemma (in gcd_condition_monoid) gcd_exists:
2.2983 +  assumes carr: "a \<in> carrier G"  "b \<in> carrier G"
2.2984 +  shows "\<exists>x\<in>carrier G. x = somegcd G a b"
2.2985 +proof -
2.2986 +  interpret glower_semilattice ["division_rel G"] by simp
2.2987 +  show ?thesis
2.2988 +    apply (simp add: somegcd_gmeet[OF carr])
2.2989 +    apply (rule gmeet_closed[simplified], fact+)
2.2990 +  done
2.2991 +qed
2.2992 +
2.2993 +lemma (in gcd_condition_monoid) gcd_divides_l:
2.2994 +  assumes carr: "a \<in> carrier G"  "b \<in> carrier G"
2.2995 +  shows "(somegcd G a b) divides a"
2.2996 +proof -
2.2997 +  interpret glower_semilattice ["division_rel G"] by simp
2.2998 +  show ?thesis
2.2999 +    apply (simp add: somegcd_gmeet[OF carr])
2.3000 +    apply (rule gmeet_left[simplified], fact+)
2.3001 +  done
2.3002 +qed
2.3003 +
2.3004 +lemma (in gcd_condition_monoid) gcd_divides_r:
2.3005 +  assumes carr: "a \<in> carrier G"  "b \<in> carrier G"
2.3006 +  shows "(somegcd G a b) divides b"
2.3007 +proof -
2.3008 +  interpret glower_semilattice ["division_rel G"] by simp
2.3009 +  show ?thesis
2.3010 +    apply (simp add: somegcd_gmeet[OF carr])
2.3011 +    apply (rule gmeet_right[simplified], fact+)
2.3012 +  done
2.3013 +qed
2.3014 +
2.3015 +lemma (in gcd_condition_monoid) gcd_divides:
2.3016 +  assumes sub: "z divides x"  "z divides y"
2.3017 +    and L: "x \<in> carrier G"  "y \<in> carrier G"  "z \<in> carrier G"
2.3018 +  shows "z divides (somegcd G x y)"
2.3019 +proof -
2.3020 +  interpret glower_semilattice ["division_rel G"] by simp
2.3021 +  show ?thesis
2.3022 +    apply (simp add: somegcd_gmeet L)
2.3023 +    apply (rule gmeet_le[simplified], fact+)
2.3024 +  done
2.3025 +qed
2.3026 +
2.3027 +lemma (in gcd_condition_monoid) gcd_cong_l:
2.3028 +  assumes xx': "x \<sim> x'"
2.3029 +    and carr: "x \<in> carrier G"  "x' \<in> carrier G"  "y \<in> carrier G"
2.3030 +  shows "somegcd G x y \<sim> somegcd G x' y"
2.3031 +proof -
2.3032 +  interpret glower_semilattice ["division_rel G"] by simp
2.3033 +  show ?thesis
2.3034 +    apply (simp add: somegcd_gmeet carr)
2.3035 +    apply (rule gmeet_cong_l[simplified], fact+)
2.3036 +  done
2.3037 +qed
2.3038 +
2.3039 +lemma (in gcd_condition_monoid) gcd_cong_r:
2.3040 +  assumes carr: "x \<in> carrier G"  "y \<in> carrier G"  "y' \<in> carrier G"
2.3041 +    and yy': "y \<sim> y'"
2.3042 +  shows "somegcd G x y \<sim> somegcd G x y'"
2.3043 +proof -
2.3044 +  interpret glower_semilattice ["division_rel G"] by simp
2.3045 +  show ?thesis
2.3046 +    apply (simp add: somegcd_gmeet carr)
2.3047 +    apply (rule gmeet_cong_r[simplified], fact+)
2.3048 +  done
2.3049 +qed
2.3050 +
2.3051 +(*
2.3052 +lemma (in gcd_condition_monoid) asc_cong_gcd_l [intro]:
2.3053 +  assumes carr: "b \<in> carrier G"
2.3054 +  shows "asc_cong (\<lambda>a. somegcd G a b)"
2.3055 +using carr
2.3056 +unfolding CONG_def
2.3057 +by clarsimp (blast intro: gcd_cong_l)
2.3058 +
2.3059 +lemma (in gcd_condition_monoid) asc_cong_gcd_r [intro]:
2.3060 +  assumes carr: "a \<in> carrier G"
2.3061 +  shows "asc_cong (\<lambda>b. somegcd G a b)"
2.3062 +using carr
2.3063 +unfolding CONG_def
2.3064 +by clarsimp (blast intro: gcd_cong_r)
2.3065 +
2.3066 +lemmas (in gcd_condition_monoid) asc_cong_gcd_split [simp] =
2.3067 +    assoc_split[OF _ asc_cong_gcd_l] assoc_split[OF _ asc_cong_gcd_r]
2.3068 +*)
2.3069 +
2.3070 +lemma (in gcd_condition_monoid) gcdI:
2.3071 +  assumes dvd: "a divides b"  "a divides c"
2.3072 +    and others: "\<forall>y\<in>carrier G. y divides b \<and> y divides c \<longrightarrow> y divides a"
2.3073 +    and acarr: "a \<in> carrier G" and bcarr: "b \<in> carrier G" and ccarr: "c \<in> carrier G"
2.3074 +  shows "a \<sim> somegcd G b c"
2.3076 +apply (rule someI2_ex)
2.3077 + apply (rule exI[of _ a], simp add: isgcd_def)
2.3078 + apply (simp add: assms)
2.3079 +apply (simp add: isgcd_def assms, clarify)
2.3080 +apply (insert assms, blast intro: associatedI)
2.3081 +done
2.3082 +
2.3083 +lemma (in gcd_condition_monoid) gcdI2:
2.3084 +  assumes "a gcdof b c"
2.3085 +    and "a \<in> carrier G" and bcarr: "b \<in> carrier G" and ccarr: "c \<in> carrier G"
2.3086 +  shows "a \<sim> somegcd G b c"
2.3087 +using assms
2.3088 +unfolding isgcd_def
2.3089 +by (blast intro: gcdI)
2.3090 +
2.3091 +lemma (in gcd_condition_monoid) SomeGcd_ex:
2.3092 +  assumes "finite A"  "A \<subseteq> carrier G"  "A \<noteq> {}"
2.3093 +  shows "\<exists>x\<in> carrier G. x = SomeGcd G A"
2.3094 +proof -
2.3095 +  interpret glower_semilattice ["division_rel G"] by simp
2.3096 +  show ?thesis
2.3097 +    apply (simp add: SomeGcd_def)
2.3098 +    apply (rule finite_ginf_closed[simplified], fact+)
2.3099 +  done
2.3100 +qed
2.3101 +
2.3102 +lemma (in gcd_condition_monoid) gcd_assoc:
2.3103 +  assumes carr: "a \<in> carrier G"  "b \<in> carrier G"  "c \<in> carrier G"
2.3104 +  shows "somegcd G (somegcd G a b) c \<sim> somegcd G a (somegcd G b c)"
2.3105 +proof -
2.3106 +  interpret glower_semilattice ["division_rel G"] by simp
2.3107 +  show ?thesis
2.3108 +    apply (subst (2 3) somegcd_gmeet, (simp add: carr)+)
2.3109 +    apply (simp add: somegcd_gmeet carr)
2.3110 +    apply (rule gmeet_assoc[simplified], fact+)
2.3111 +  done
2.3112 +qed
2.3113 +
2.3114 +lemma (in gcd_condition_monoid) gcd_mult:
2.3115 +  assumes acarr: "a \<in> carrier G" and bcarr: "b \<in> carrier G" and ccarr: "c \<in> carrier G"
2.3116 +  shows "c \<otimes> somegcd G a b \<sim> somegcd G (c \<otimes> a) (c \<otimes> b)"
2.3117 +proof - (* following Jacobson, Basic Algebra, p.140 *)
2.3118 +  let ?d = "somegcd G a b"
2.3119 +  let ?e = "somegcd G (c \<otimes> a) (c \<otimes> b)"
2.3120 +  note carr[simp] = acarr bcarr ccarr
2.3121 +  have dcarr: "?d \<in> carrier G" by simp
2.3122 +  have ecarr: "?e \<in> carrier G" by simp
2.3123 +  note carr = carr dcarr ecarr
2.3124 +
2.3125 +  have "?d divides a" by (simp add: gcd_divides_l)
2.3126 +  hence cd'ca: "c \<otimes> ?d divides (c \<otimes> a)" by (simp add: divides_mult_lI)
2.3127 +
2.3128 +  have "?d divides b" by (simp add: gcd_divides_r)
2.3129 +  hence cd'cb: "c \<otimes> ?d divides (c \<otimes> b)" by (simp add: divides_mult_lI)
2.3130 +
2.3131 +  from cd'ca cd'cb
2.3132 +      have cd'e: "c \<otimes> ?d divides ?e"
2.3133 +      by (rule gcd_divides) simp+
2.3134 +
2.3135 +  hence "\<exists>u. u \<in> carrier G \<and> ?e = c \<otimes> ?d \<otimes> u"
2.3136 +      by (elim dividesE, fast)
2.3137 +  from this obtain u
2.3138 +      where ucarr[simp]: "u \<in> carrier G"
2.3139 +      and e_cdu: "?e = c \<otimes> ?d \<otimes> u"
2.3140 +      by auto
2.3141 +
2.3142 +  note carr = carr ucarr
2.3143 +
2.3144 +  have "?e divides c \<otimes> a" by (rule gcd_divides_l) simp+
2.3145 +  hence "\<exists>x. x \<in> carrier G \<and> c \<otimes> a = ?e \<otimes> x"
2.3146 +      by (elim dividesE, fast)
2.3147 +  from this obtain x
2.3148 +      where xcarr: "x \<in> carrier G"
2.3149 +      and ca_ex: "c \<otimes> a = ?e \<otimes> x"
2.3150 +      by auto
2.3151 +  with e_cdu
2.3152 +      have ca_cdux: "c \<otimes> a = c \<otimes> ?d \<otimes> u \<otimes> x" by simp
2.3153 +
2.3154 +  from ca_cdux xcarr
2.3155 +       have "c \<otimes> a = c \<otimes> (?d \<otimes> u \<otimes> x)" by (simp add: m_assoc)
2.3156 +  then have "a = ?d \<otimes> u \<otimes> x" by (rule l_cancel[of c a]) (simp add: xcarr)+
2.3157 +  hence du'a: "?d \<otimes> u divides a" by (rule dividesI[OF xcarr])
2.3158 +
2.3159 +  have "?e divides c \<otimes> b" by (intro gcd_divides_r, simp+)
2.3160 +  hence "\<exists>x. x \<in> carrier G \<and> c \<otimes> b = ?e \<otimes> x"
2.3161 +      by (elim dividesE, fast)
2.3162 +  from this obtain x
2.3163 +      where xcarr: "x \<in> carrier G"
2.3164 +      and cb_ex: "c \<otimes> b = ?e \<otimes> x"
2.3165 +      by auto
2.3166 +  with e_cdu
2.3167 +      have cb_cdux: "c \<otimes> b = c \<otimes> ?d \<otimes> u \<otimes> x" by simp
2.3168 +
2.3169 +  from cb_cdux xcarr
2.3170 +      have "c \<otimes> b = c \<otimes> (?d \<otimes> u \<otimes> x)" by (simp add: m_assoc)
2.3171 +  with xcarr
2.3172 +      have "b = ?d \<otimes> u \<otimes> x" by (intro l_cancel[of c b], simp+)
2.3173 +  hence du'b: "?d \<otimes> u divides b" by (intro dividesI[OF xcarr])
2.3174 +
2.3175 +  from du'a du'b carr
2.3176 +      have du'd: "?d \<otimes> u divides ?d"
2.3177 +      by (intro gcd_divides, simp+)
2.3178 +  hence uunit: "u \<in> Units G"
2.3179 +  proof (elim dividesE)
2.3180 +    fix v
2.3181 +    assume vcarr[simp]: "v \<in> carrier G"
2.3182 +    assume d: "?d = ?d \<otimes> u \<otimes> v"
2.3183 +    have "?d \<otimes> \<one> = ?d \<otimes> u \<otimes> v" by simp fact
2.3184 +    also have "?d \<otimes> u \<otimes> v = ?d \<otimes> (u \<otimes> v)" by (simp add: m_assoc)
2.3185 +    finally have "?d \<otimes> \<one> = ?d \<otimes> (u \<otimes> v)" .
2.3186 +    hence i2: "\<one> = u \<otimes> v" by (rule l_cancel) simp+
2.3187 +    hence i1: "\<one> = v \<otimes> u" by (simp add: m_comm)
2.3188 +    from vcarr i1[symmetric] i2[symmetric]
2.3189 +        show "u \<in> Units G"
2.3190 +        by (unfold Units_def, simp, fast)
2.3191 +  qed
2.3192 +
2.3193 +  from e_cdu uunit
2.3194 +      have "somegcd G (c \<otimes> a) (c \<otimes> b) \<sim> c \<otimes> somegcd G a b"
2.3195 +      by (intro associatedI2[of u], simp+)
2.3196 +  from this[symmetric]
2.3197 +      show "c \<otimes> somegcd G a b \<sim> somegcd G (c \<otimes> a) (c \<otimes> b)" by simp
2.3198 +qed
2.3199 +
2.3200 +lemma (in monoid) assoc_subst:
2.3201 +  assumes ab: "a \<sim> b"
2.3202 +    and cP: "ALL a b. a : carrier G & b : carrier G & a \<sim> b
2.3203 +      --> f a : carrier G & f b : carrier G & f a \<sim> f b"
2.3204 +    and carr: "a \<in> carrier G"  "b \<in> carrier G"
2.3205 +  shows "f a \<sim> f b"
2.3206 +  using assms by auto
2.3207 +
2.3208 +lemma (in gcd_condition_monoid) relprime_mult:
2.3209 +  assumes abrelprime: "somegcd G a b \<sim> \<one>" and acrelprime: "somegcd G a c \<sim> \<one>"
2.3210 +    and carr[simp]: "a \<in> carrier G"  "b \<in> carrier G"  "c \<in> carrier G"
2.3211 +  shows "somegcd G a (b \<otimes> c) \<sim> \<one>"
2.3212 +proof -
2.3213 +  have "c = c \<otimes> \<one>" by simp
2.3214 +  also from abrelprime[symmetric]
2.3215 +       have "\<dots> \<sim> c \<otimes> somegcd G a b"
2.3216 +	 by (rule assoc_subst) (simp add: mult_cong_r)+
2.3217 +  also have "\<dots> \<sim> somegcd G (c \<otimes> a) (c \<otimes> b)" by (rule gcd_mult) fact+
2.3218 +  finally
2.3219 +       have c: "c \<sim> somegcd G (c \<otimes> a) (c \<otimes> b)" by simp
2.3220 +
2.3221 +  from carr
2.3222 +       have a: "a \<sim> somegcd G a (c \<otimes> a)"
2.3223 +       by (fast intro: gcdI divides_prod_l)
2.3224 +
2.3225 +  have "somegcd G a (b \<otimes> c) \<sim> somegcd G a (c \<otimes> b)" by (simp add: m_comm)
2.3226 +  also from a
2.3227 +       have "\<dots> \<sim> somegcd G (somegcd G a (c \<otimes> a)) (c \<otimes> b)"
2.3228 +	 by (rule assoc_subst) (simp add: gcd_cong_l)+
2.3229 +  also from gcd_assoc
2.3230 +       have "\<dots> \<sim> somegcd G a (somegcd G (c \<otimes> a) (c \<otimes> b))"
2.3231 +       by (rule assoc_subst) simp+
2.3232 +  also from c[symmetric]
2.3233 +       have "\<dots> \<sim> somegcd G a c"
2.3234 +	 by (rule assoc_subst) (simp add: gcd_cong_r)+
2.3235 +  also note acrelprime
2.3236 +  finally
2.3237 +       show "somegcd G a (b \<otimes> c) \<sim> \<one>" by simp
2.3238 +qed
2.3239 +
2.3240 +lemma (in gcd_condition_monoid) primeness_condition:
2.3241 +  "primeness_condition_monoid G"
2.3242 +apply unfold_locales
2.3243 +apply (rule primeI)
2.3244 + apply (elim irreducibleE, assumption)
2.3245 +proof -
2.3246 +  fix p a b
2.3247 +  assume pcarr: "p \<in> carrier G" and acarr: "a \<in> carrier G" and bcarr: "b \<in> carrier G"
2.3248 +    and pirr: "irreducible G p"
2.3249 +    and pdvdab: "p divides a \<otimes> b"
2.3250 +  from pirr
2.3251 +      have pnunit: "p \<notin> Units G"
2.3252 +      and r[rule_format]: "\<forall>b. b \<in> carrier G \<and> properfactor G b p \<longrightarrow> b \<in> Units G"
2.3253 +      by - (fast elim: irreducibleE)+
2.3254 +
2.3255 +  show "p divides a \<or> p divides b"
2.3256 +  proof (rule ccontr, clarsimp)
2.3257 +    assume npdvda: "\<not> p divides a"
2.3258 +    with pcarr acarr
2.3259 +    have "\<one> \<sim> somegcd G p a"
2.3260 +    apply (intro gcdI, simp, simp, simp)
2.3261 +      apply (fast intro: unit_divides)
2.3262 +     apply (fast intro: unit_divides)
2.3263 +    apply (clarsimp simp add: Unit_eq_dividesone[symmetric])
2.3264 +    apply (rule r, rule, assumption)
2.3265 +    apply (rule properfactorI, assumption)
2.3266 +    proof (rule ccontr, simp)
2.3267 +      fix y
2.3268 +      assume ycarr: "y \<in> carrier G"
2.3269 +      assume "p divides y"
2.3270 +      also assume "y divides a"
2.3271 +      finally
2.3272 +          have "p divides a" by (simp add: pcarr ycarr acarr)
2.3273 +      with npdvda
2.3274 +          show "False" ..
2.3275 +    qed simp+
2.3276 +    with pcarr acarr
2.3277 +        have pa: "somegcd G p a \<sim> \<one>" by (fast intro: associated_sym[of "\<one>"] gcd_closed)
2.3278 +
2.3279 +    assume npdvdb: "\<not> p divides b"
2.3280 +    with pcarr bcarr
2.3281 +    have "\<one> \<sim> somegcd G p b"
2.3282 +    apply (intro gcdI, simp, simp, simp)
2.3283 +      apply (fast intro: unit_divides)
2.3284 +     apply (fast intro: unit_divides)
2.3285 +    apply (clarsimp simp add: Unit_eq_dividesone[symmetric])
2.3286 +    apply (rule r, rule, assumption)
2.3287 +    apply (rule properfactorI, assumption)
2.3288 +    proof (rule ccontr, simp)
2.3289 +      fix y
2.3290 +      assume ycarr: "y \<in> carrier G"
2.3291 +      assume "p divides y"
2.3292 +      also assume "y divides b"
2.3293 +      finally have "p divides b" by (simp add: pcarr ycarr bcarr)
2.3294 +      with npdvdb
2.3295 +          show "False" ..
2.3296 +    qed simp+
2.3297 +    with pcarr bcarr
2.3298 +        have pb: "somegcd G p b \<sim> \<one>" by (fast intro: associated_sym[of "\<one>"] gcd_closed)
2.3299 +
2.3300 +    from pcarr acarr bcarr pdvdab
2.3301 +        have "p gcdof p (a \<otimes> b)" by (fast intro: isgcd_divides_l)
2.3302 +
2.3303 +    with pcarr acarr bcarr
2.3304 +         have "p \<sim> somegcd G p (a \<otimes> b)" by (fast intro: gcdI2)
2.3305 +    also from pa pb pcarr acarr bcarr
2.3306 +         have "somegcd G p (a \<otimes> b) \<sim> \<one>" by (rule relprime_mult)
2.3307 +    finally have "p \<sim> \<one>" by (simp add: pcarr acarr bcarr)
2.3308 +
2.3309 +    with pcarr
2.3310 +        have "p \<in> Units G" by (fast intro: assoc_unit_l)
2.3311 +    with pnunit
2.3312 +        show "False" ..
2.3313 +  qed
2.3314 +qed
2.3315 +
2.3316 +interpretation gcd_condition_monoid \<subseteq> primeness_condition_monoid
2.3317 +  by (rule primeness_condition)
2.3318 +
2.3319 +
2.3320 +subsubsection {* Divisor chain condition *}
2.3321 +
2.3322 +lemma (in divisor_chain_condition_monoid) wfactors_exist:
2.3323 +  assumes acarr: "a \<in> carrier G"
2.3324 +  shows "\<exists>as. set as \<subseteq> carrier G \<and> wfactors G as a"
2.3325 +proof -
2.3326 +  have r[rule_format]: "a \<in> carrier G \<longrightarrow> (\<exists>as. set as \<subseteq> carrier G \<and> wfactors G as a)"
2.3327 +    apply (rule wf_induct[OF division_wellfounded])
2.3328 +  proof -
2.3329 +    fix x
2.3330 +    assume ih: "\<forall>y. (y, x) \<in> {(x, y). x \<in> carrier G \<and> y \<in> carrier G \<and> properfactor G x y}
2.3331 +                    \<longrightarrow> y \<in> carrier G \<longrightarrow> (\<exists>as. set as \<subseteq> carrier G \<and> wfactors G as y)"
2.3332 +
2.3333 +    show "x \<in> carrier G \<longrightarrow> (\<exists>as. set as \<subseteq> carrier G \<and> wfactors G as x)"
2.3334 +    apply clarify
2.3335 +    apply (cases "x \<in> Units G")
2.3336 +     apply (rule exI[of _ "[]"], simp)
2.3337 +    apply (cases "irreducible G x")
2.3338 +     apply (rule exI[of _ "[x]"], simp add: wfactors_def)
2.3339 +    proof -
2.3340 +      assume xcarr: "x \<in> carrier G"
2.3341 +        and xnunit: "x \<notin> Units G"
2.3342 +        and xnirr: "\<not> irreducible G x"
2.3343 +      hence "\<exists>y. y \<in> carrier G \<and> properfactor G y x \<and> y \<notin> Units G"
2.3344 +        apply - apply (rule ccontr, simp)
2.3345 +        apply (subgoal_tac "irreducible G x", simp)
2.3346 +        apply (rule irreducibleI, simp, simp)
2.3347 +      done
2.3348 +      from this obtain y
2.3349 +          where ycarr: "y \<in> carrier G"
2.3350 +          and ynunit: "y \<notin> Units G"
2.3351 +          and pfyx: "properfactor G y x"
2.3352 +          by auto
2.3353 +
2.3354 +      have ih':
2.3355 +           "\<And>y. \<lbrakk>y \<in> carrier G; properfactor G y x\<rbrakk>
2.3356 +                \<Longrightarrow> \<exists>as. set as \<subseteq> carrier G \<and> wfactors G as y"
2.3357 +          by (rule ih[rule_format, simplified]) (simp add: xcarr)+
2.3358 +
2.3359 +      from ycarr pfyx
2.3360 +          have "\<exists>as. set as \<subseteq> carrier G \<and> wfactors G as y"
2.3361 +          by (rule ih')
2.3362 +      from this obtain ys
2.3363 +          where yscarr: "set ys \<subseteq> carrier G"
2.3364 +          and yfs: "wfactors G ys y"
2.3365 +          by auto
2.3366 +
2.3367 +      from pfyx
2.3368 +          have "y divides x"
2.3369 +          and nyx: "\<not> y \<sim> x"
2.3370 +          by - (fast elim: properfactorE2)+
2.3371 +      hence "\<exists>z. z \<in> carrier G \<and> x = y \<otimes> z"
2.3372 +          by (fast elim: dividesE)
2.3373 +
2.3374 +      from this obtain z
2.3375 +          where zcarr: "z \<in> carrier G"
2.3376 +          and x: "x = y \<otimes> z"
2.3377 +          by auto
2.3378 +
2.3379 +      from zcarr ycarr
2.3380 +      have "properfactor G z x"
2.3381 +        apply (subst x)
2.3382 +        apply (intro properfactorI3[of _ _ y])
2.3383 +         apply (simp add: m_comm)
2.3384 +        apply (simp add: ynunit)+
2.3385 +      done
2.3386 +      with zcarr
2.3387 +          have "\<exists>as. set as \<subseteq> carrier G \<and> wfactors G as z"
2.3388 +          by (rule ih')
2.3389 +      from this obtain zs
2.3390 +          where zscarr: "set zs \<subseteq> carrier G"
2.3391 +          and zfs: "wfactors G zs z"
2.3392 +          by auto
2.3393 +
2.3394 +      from yscarr zscarr
2.3395 +          have xscarr: "set (ys@zs) \<subseteq> carrier G" by simp
2.3396 +      from yfs zfs ycarr zcarr yscarr zscarr
2.3397 +          have "wfactors G (ys@zs) (y\<otimes>z)" by (rule wfactors_mult)
2.3398 +      hence "wfactors G (ys@zs) x" by (simp add: x)
2.3399 +
2.3400 +      from xscarr this
2.3401 +          show "\<exists>xs. set xs \<subseteq> carrier G \<and> wfactors G xs x" by fast
2.3402 +    qed
2.3403 +  qed
2.3404 +
2.3405 +  from acarr
2.3406 +      show ?thesis by (rule r)
2.3407 +qed
2.3408 +
2.3409 +
2.3410 +subsubsection {* Primeness condition *}
2.3411 +
2.3412 +lemma (in comm_monoid_cancel) multlist_prime_pos:
2.3413 +  assumes carr: "a \<in> carrier G"  "set as \<subseteq> carrier G"
2.3414 +    and aprime: "prime G a"
2.3415 +    and "a divides (foldr (op \<otimes>) as \<one>)"
2.3416 +  shows "\<exists>i<length as. a divides (as!i)"
2.3417 +proof -
2.3418 +  have r[rule_format]:
2.3419 +       "set as \<subseteq> carrier G \<and> a divides (foldr (op \<otimes>) as \<one>)
2.3420 +        \<longrightarrow> (\<exists>i. i < length as \<and> a divides (as!i))"
2.3421 +    apply (induct as)
2.3422 +     apply clarsimp defer 1
2.3423 +     apply clarsimp defer 1
2.3424 +  proof -
2.3425 +    assume "a divides \<one>"
2.3426 +    with carr
2.3427 +        have "a \<in> Units G"
2.3428 +        by (fast intro: divides_unit[of a \<one>])
2.3429 +    with aprime
2.3430 +        show "False" by (elim primeE, simp)
2.3431 +  next
2.3432 +    fix aa as
2.3433 +    assume ih[rule_format]: "a divides foldr op \<otimes> as \<one> \<longrightarrow> (\<exists>i<length as. a divides as ! i)"
2.3434 +      and carr': "aa \<in> carrier G"  "set as \<subseteq> carrier G"
2.3435 +      and "a divides aa \<otimes> foldr op \<otimes> as \<one>"
2.3436 +    with carr aprime
2.3437 +        have "a divides aa \<or> a divides foldr op \<otimes> as \<one>"
2.3438 +        by (intro prime_divides) simp+
2.3439 +    moreover {
2.3440 +      assume "a divides aa"
2.3441 +      hence p1: "a divides (aa#as)!0" by simp
2.3442 +      have "0 < Suc (length as)" by simp
2.3443 +      with p1 have "\<exists>i<Suc (length as). a divides (aa # as) ! i" by fast
2.3444 +    }
2.3445 +    moreover {
2.3446 +      assume "a divides foldr op \<otimes> as \<one>"
2.3447 +      hence "\<exists>i. i < length as \<and> a divides as ! i" by (rule ih)
2.3448 +      from this obtain i where "a divides as ! i" and len: "i < length as" by auto
2.3449 +      hence p1: "a divides (aa#as) ! (Suc i)" by simp
2.3450 +      from len have "Suc i < Suc (length as)" by simp
2.3451 +      with p1 have "\<exists>i<Suc (length as). a divides (aa # as) ! i" by force
2.3452 +   }
2.3453 +   ultimately
2.3454 +      show "\<exists>i<Suc (length as). a divides (aa # as) ! i" by fast
2.3455 +  qed
2.3456 +
2.3457 +  from assms
2.3458 +      show ?thesis
2.3459 +      by (intro r, safe)
2.3460 +qed
2.3461 +
2.3462 +lemma (in primeness_condition_monoid) wfactors_unique__hlp_induct:
2.3463 +  "\<forall>a as'. a \<in> carrier G \<and> set as \<subseteq> carrier G \<and> set as' \<subseteq> carrier G \<and>
2.3464 +           wfactors G as a \<and> wfactors G as' a \<longrightarrow> essentially_equal G as as'"
2.3465 +apply (induct as)
2.3466 +apply clarsimp defer 1
2.3467 +apply clarsimp defer 1
2.3468 +proof -
2.3469 +  fix a as'
2.3470 +  assume acarr: "a \<in> carrier G"
2.3471 +    and "wfactors G [] a"
2.3472 +  hence aunit: "a \<in> Units G"
2.3473 +    apply (elim wfactorsE)
2.3474 +    apply (simp, rule assoc_unit_r[of "\<one>"], simp+)
2.3475 +  done
2.3476 +
2.3477 +  assume "set as' \<subseteq> carrier G"  "wfactors G as' a"
2.3478 +  with aunit
2.3479 +      have "as' = []"
2.3480 +      by (intro unit_wfactors_empty[of a])
2.3481 +  thus "essentially_equal G [] as'" by simp
2.3482 +next
2.3483 +  fix a as ah as'
2.3484 +  assume ih[rule_format]:
2.3485 +         "\<forall>a as'. a \<in> carrier G \<and> set as' \<subseteq> carrier G \<and>
2.3486 +                  wfactors G as a \<and> wfactors G as' a \<longrightarrow> essentially_equal G as as'"
2.3487 +    and acarr: "a \<in> carrier G" and ahcarr: "ah \<in> carrier G"
2.3488 +    and ascarr: "set as \<subseteq> carrier G" and as'carr: "set as' \<subseteq> carrier G"
2.3489 +    and afs: "wfactors G (ah # as) a"
2.3490 +    and afs': "wfactors G as' a"
2.3491 +  hence ahdvda: "ah divides a"
2.3492 +      by (intro wfactors_dividesI[of "ah#as" "a"], simp+)
2.3493 +  hence "\<exists>a'\<in> carrier G. a = ah \<otimes> a'" by (fast elim: dividesE)
2.3494 +  from this obtain a'
2.3495 +      where a'carr: "a' \<in> carrier G"
2.3496 +      and a: "a = ah \<otimes> a'"
2.3497 +      by auto
2.3498 +  have a'fs: "wfactors G as a'"
2.3499 +    apply (rule wfactorsE[OF afs], rule wfactorsI, simp)
2.3500 +    apply (simp add: a, insert ascarr a'carr)
2.3501 +    apply (intro assoc_l_cancel[of ah _ a'] multlist_closed ahcarr, assumption+)
2.3502 +  done
2.3503 +
2.3504 +  from afs have ahirr: "irreducible G ah" by (elim wfactorsE, simp)
2.3505 +  with ascarr have ahprime: "prime G ah" by (intro irreducible_prime ahcarr)
2.3506 +
2.3507 +  note carr [simp] = acarr ahcarr ascarr as'carr a'carr
2.3508 +
2.3509 +  note ahdvda
2.3510 +  also from afs'
2.3511 +       have "a divides (foldr (op \<otimes>) as' \<one>)"
2.3512 +       by (elim wfactorsE associatedE, simp)
2.3513 +  finally have "ah divides (foldr (op \<otimes>) as' \<one>)" by simp
2.3514 +
2.3515 +  with ahprime
2.3516 +      have "\<exists>i<length as'. ah divides as'!i"
2.3517 +      by (intro multlist_prime_pos, simp+)
2.3518 +  from this obtain i
2.3519 +      where len: "i<length as'" and ahdvd: "ah divides as'!i"
2.3520 +      by auto
2.3521 +  from afs' carr have irrasi: "irreducible G (as'!i)"
2.3522 +      by (fast intro: nth_mem[OF len] elim: wfactorsE)
2.3523 +  from len carr
2.3524 +      have asicarr[simp]: "as'!i \<in> carrier G" by (unfold set_conv_nth, force)
2.3525 +  note carr = carr asicarr
2.3526 +
2.3527 +  from ahdvd have "\<exists>x \<in> carrier G. as'!i = ah \<otimes> x" by (fast elim: dividesE)
2.3528 +  from this obtain x where "x \<in> carrier G" and asi: "as'!i = ah \<otimes> x" by auto
2.3529 +
2.3530 +  with carr irrasi[simplified asi]
2.3531 +      have asiah: "as'!i \<sim> ah" apply -
2.3532 +    apply (elim irreducible_prodE[of "ah" "x"], assumption+)
2.3533 +     apply (rule associatedI2[of x], assumption+)
2.3534 +    apply (rule irreducibleE[OF ahirr], simp)
2.3535 +  done
2.3536 +
2.3537 +  note setparts = set_take_subset[of i as'] set_drop_subset[of "Suc i" as']
2.3538 +  note partscarr [simp] = setparts[THEN subset_trans[OF _ as'carr]]
2.3539 +  note carr = carr partscarr
2.3540 +
2.3541 +  have "\<exists>aa_1. aa_1 \<in> carrier G \<and> wfactors G (take i as') aa_1"
2.3542 +    apply (intro wfactors_prod_exists)
2.3543 +    using setparts afs' by (fast elim: wfactorsE, simp)
2.3544 +  from this obtain aa_1
2.3545 +      where aa1carr: "aa_1 \<in> carrier G"
2.3546 +      and aa1fs: "wfactors G (take i as') aa_1"
2.3547 +      by auto
2.3548 +
2.3549 +  have "\<exists>aa_2. aa_2 \<in> carrier G \<and> wfactors G (drop (Suc i) as') aa_2"
2.3550 +    apply (intro wfactors_prod_exists)
2.3551 +    using setparts afs' by (fast elim: wfactorsE, simp)
2.3552 +  from this obtain aa_2
2.3553 +      where aa2carr: "aa_2 \<in> carrier G"
2.3554 +      and aa2fs: "wfactors G (drop (Suc i) as') aa_2"
2.3555 +      by auto
2.3556 +
2.3557 +  note carr = carr aa1carr[simp] aa2carr[simp]
2.3558 +
2.3559 +  from aa1fs aa2fs
2.3560 +      have v1: "wfactors G (take i as' @ drop (Suc i) as') (aa_1 \<otimes> aa_2)"
2.3561 +      by (intro wfactors_mult, simp+)
2.3562 +  hence v1': "wfactors G (as'!i # take i as' @ drop (Suc i) as') (as'!i \<otimes> (aa_1 \<otimes> aa_2))"
2.3563 +      apply (intro wfactors_mult_single)
2.3564 +      using setparts afs'
2.3565 +      by (fast intro: nth_mem[OF len] elim: wfactorsE, simp+)
2.3566 +
2.3567 +  from aa2carr carr aa1fs aa2fs
2.3568 +      have "wfactors G (as'!i # drop (Suc i) as') (as'!i \<otimes> aa_2)"
2.3569 +    apply (intro wfactors_mult_single)
2.3570 +        apply (rule wfactorsE[OF afs'], fast intro: nth_mem[OF len])
2.3571 +       apply (fast intro: nth_mem[OF len])
2.3572 +      apply fast
2.3573 +     apply fast
2.3574 +    apply assumption
2.3575 +  done
2.3576 +  with len carr aa1carr aa2carr aa1fs
2.3577 +      have v2: "wfactors G (take i as' @ as'!i # drop (Suc i) as') (aa_1 \<otimes> (as'!i \<otimes> aa_2))"
2.3578 +    apply (intro wfactors_mult)
2.3579 +         apply fast
2.3580 +        apply (simp, (fast intro: nth_mem[OF len])?)+
2.3581 +  done
2.3582 +
2.3583 +  from len
2.3584 +      have as': "as' = (take i as' @ as'!i # drop (Suc i) as')"
2.3585 +      by (simp add: drop_Suc_conv_tl)
2.3586 +  with carr
2.3587 +      have eer: "essentially_equal G (take i as' @ as'!i # drop (Suc i) as') as'"
2.3588 +      by simp
2.3589 +
2.3590 +  with v2 afs' carr aa1carr aa2carr nth_mem[OF len]
2.3591 +      have "aa_1 \<otimes> (as'!i \<otimes> aa_2) \<sim> a"
2.3592 +    apply (intro ee_wfactorsD[of "take i as' @ as'!i # drop (Suc i) as'"  "as'"])
2.3593 +          apply fast+
2.3594 +        apply (simp, fast)
2.3595 +  done
2.3596 +  then
2.3597 +  have t1: "as'!i \<otimes> (aa_1 \<otimes> aa_2) \<sim> a"
2.3598 +    apply (simp add: m_assoc[symmetric])
2.3599 +    apply (simp add: m_comm)
2.3600 +  done
2.3601 +  from carr asiah
2.3602 +  have "ah \<otimes> (aa_1 \<otimes> aa_2) \<sim> as'!i \<otimes> (aa_1 \<otimes> aa_2)"
2.3603 +      apply (intro mult_cong_l)
2.3604 +      apply (fast intro: associated_sym, simp+)
2.3605 +  done
2.3606 +  also note t1
2.3607 +  finally
2.3608 +      have "ah \<otimes> (aa_1 \<otimes> aa_2) \<sim> a" by simp
2.3609 +
2.3610 +  with carr aa1carr aa2carr a'carr nth_mem[OF len]
2.3611 +      have a': "aa_1 \<otimes> aa_2 \<sim> a'"
2.3612 +      by (simp add: a, fast intro: assoc_l_cancel[of ah _ a'])
2.3613 +
2.3614 +  note v1
2.3615 +  also note a'
2.3616 +  finally have "wfactors G (take i as' @ drop (Suc i) as') a'" by simp
2.3617 +
2.3618 +  from a'fs this carr
2.3619 +      have "essentially_equal G as (take i as' @ drop (Suc i) as')"
2.3620 +      by (intro ih[of a']) simp
2.3621 +
2.3622 +  hence ee1: "essentially_equal G (ah # as) (ah # take i as' @ drop (Suc i) as')"
2.3623 +    apply (elim essentially_equalE) apply (fastsimp intro: essentially_equalI)
2.3624 +  done
2.3625 +
2.3626 +  from carr
2.3627 +  have ee2: "essentially_equal G (ah # take i as' @ drop (Suc i) as')
2.3628 +                                 (as' ! i # take i as' @ drop (Suc i) as')"
2.3629 +  proof (intro essentially_equalI)
2.3630 +    show "ah # take i as' @ drop (Suc i) as' <~~> ah # take i as' @ drop (Suc i) as'"
2.3631 +        by simp
2.3632 +  next show "ah # take i as' @ drop (Suc i) as' [\<sim>]
2.3633 +       as' ! i # take i as' @ drop (Suc i) as'"
2.3634 +    apply (simp add: list_all2_append)
2.3635 +    apply (simp add: asiah[symmetric] ahcarr asicarr)
2.3636 +    done
2.3637 +  qed
2.3638 +
2.3639 +  note ee1
2.3640 +  also note ee2
2.3641 +  also have "essentially_equal G (as' ! i # take i as' @ drop (Suc i) as')
2.3642 +                                 (take i as' @ as' ! i # drop (Suc i) as')"
2.3643 +    apply (intro essentially_equalI)
2.3644 +    apply (subgoal_tac "as' ! i # take i as' @ drop (Suc i) as' <~~>
2.3645 +                        take i as' @ as' ! i # drop (Suc i) as'")
2.3646 +apply simp
2.3647 +     apply (rule perm_append_Cons)
2.3648 +    apply simp
2.3649 +  done
2.3650 +  finally
2.3651 +      have "essentially_equal G (ah # as)
2.3652 +                                (take i as' @ as' ! i # drop (Suc i) as')" by simp
2.3653 +
2.3654 +  thus "essentially_equal G (ah # as) as'" by (subst as', assumption)
2.3655 +qed
2.3656 +
2.3657 +lemma (in primeness_condition_monoid) wfactors_unique:
2.3658 +  assumes "wfactors G as a"  "wfactors G as' a"
2.3659 +    and "a \<in> carrier G"  "set as \<subseteq> carrier G"  "set as' \<subseteq> carrier G"
2.3660 +  shows "essentially_equal G as as'"
2.3661 +apply (rule wfactors_unique__hlp_induct[rule_format, of a])
2.3663 +done
2.3664 +
2.3665 +
2.3666 +subsubsection {* Application to factorial monoids *}
2.3667 +
2.3668 +text {* Number of factors for wellfoundedness *}
2.3669 +
2.3670 +constdefs
2.3671 +  factorcount :: "_ \<Rightarrow> 'a \<Rightarrow> nat"
2.3672 +  "factorcount G a == THE c. (ALL as. set as \<subseteq> carrier G \<and>
2.3673 +                                      wfactors G as a \<longrightarrow> c = length as)"
2.3674 +
2.3675 +lemma (in monoid) ee_length:
2.3676 +  assumes ee: "essentially_equal G as bs"
2.3677 +  shows "length as = length bs"
2.3678 +apply (rule essentially_equalE[OF ee])
2.3679 +apply (subgoal_tac "length as = length fs1'")
2.3680 + apply (simp add: list_all2_lengthD)
2.3682 +done
2.3683 +
2.3684 +lemma (in factorial_monoid) factorcount_exists:
2.3685 +  assumes carr[simp]: "a \<in> carrier G"
2.3686 +  shows "EX c. ALL as. set as \<subseteq> carrier G \<and> wfactors G as a \<longrightarrow> c = length as"
2.3687 +proof -
2.3688 +  have "\<exists>as. set as \<subseteq> carrier G \<and> wfactors G as a" by (intro wfactors_exist, simp)
2.3689 +  from this obtain as
2.3690 +      where ascarr[simp]: "set as \<subseteq> carrier G"
2.3691 +      and afs: "wfactors G as a"
2.3692 +      by (auto simp del: carr)
2.3693 +
2.3694 +  have "ALL as'. set as' \<subseteq> carrier G \<and> wfactors G as' a \<longrightarrow> length as = length as'"
2.3695 +  proof clarify
2.3696 +    fix as'
2.3697 +    assume [simp]: "set as' \<subseteq> carrier G"
2.3698 +      and bfs: "wfactors G as' a"
2.3699 +    from afs bfs
2.3700 +        have "essentially_equal G as as'"
2.3701 +        by (intro ee_wfactorsI[of a a as as'], simp+)
2.3702 +    thus "length as = length as'" by (rule ee_length)
2.3703 +  qed
2.3704 +  thus "EX c. ALL as'. set as' \<subseteq> carrier G \<and> wfactors G as' a \<longrightarrow> c = length as'" ..
2.3705 +qed
2.3706 +
2.3707 +lemma (in factorial_monoid) factorcount_unique:
2.3708 +  assumes afs: "wfactors G as a"
2.3709 +    and acarr[simp]: "a \<in> carrier G" and ascarr[simp]: "set as \<subseteq> carrier G"
2.3710 +  shows "factorcount G a = length as"
2.3711 +proof -
2.3712 +  have "EX ac. ALL as. set as \<subseteq> carrier G \<and> wfactors G as a \<longrightarrow> ac = length as" by (rule factorcount_exists, simp)
2.3713 +  from this obtain ac where
2.3714 +      alen: "ALL as. set as \<subseteq> carrier G \<and> wfactors G as a \<longrightarrow> ac = length as"
2.3715 +      by auto
2.3716 +  have ac: "ac = factorcount G a"
2.3717 +    apply (simp add: factorcount_def)
2.3718 +    apply (rule theI2)
2.3719 +      apply (rule alen)
2.3720 +     apply (elim allE[of _ "as"], rule allE[OF alen, of "as"], simp add: ascarr afs)
2.3721 +    apply (elim allE[of _ "as"], rule allE[OF alen, of "as"], simp add: ascarr afs)
2.3722 +  done
2.3723 +
2.3724 +  from ascarr afs have "ac = length as" by (iprover intro: alen[rule_format])
2.3725 +  with ac show ?thesis by simp
2.3726 +qed
2.3727 +
2.3728 +lemma (in factorial_monoid) divides_fcount:
2.3729 +  assumes dvd: "a divides b"
2.3730 +    and acarr: "a \<in> carrier G" and bcarr:"b \<in> carrier G"
2.3731 +  shows "factorcount G a <= factorcount G b"
2.3732 +apply (rule dividesE[OF dvd])
2.3733 +proof -
2.3734 +  fix c
2.3735 +  from assms
2.3736 +      have "\<exists>as. set as \<subseteq> carrier G \<and> wfactors G as a" by fast
2.3737 +  from this obtain as
2.3738 +      where ascarr: "set as \<subseteq> carrier G"
2.3739 +      and afs: "wfactors G as a"
2.3740 +      by auto
2.3741 +  with acarr have fca: "factorcount G a = length as" by (intro factorcount_unique)
2.3742 +
2.3743 +  assume ccarr: "c \<in> carrier G"
2.3744 +  hence "\<exists>cs. set cs \<subseteq> carrier G \<and> wfactors G cs c" by fast
2.3745 +  from this obtain cs
2.3746 +      where cscarr: "set cs \<subseteq> carrier G"
2.3747 +      and cfs: "wfactors G cs c"
2.3748 +      by auto
2.3749 +
2.3750 +  note [simp] = acarr bcarr ccarr ascarr cscarr
2.3751 +
2.3752 +  assume b: "b = a \<otimes> c"
2.3753 +  from afs cfs
2.3754 +      have "wfactors G (as@cs) (a \<otimes> c)" by (intro wfactors_mult, simp+)
2.3755 +  with b have "wfactors G (as@cs) b" by simp
2.3756 +  hence "factorcount G b = length (as@cs)" by (intro factorcount_unique, simp+)
2.3757 +  hence "factorcount G b = length as + length cs" by simp
2.3758 +  with fca show ?thesis by simp
2.3759 +qed
2.3760 +
2.3761 +lemma (in factorial_monoid) associated_fcount:
2.3762 +  assumes acarr: "a \<in> carrier G" and bcarr:"b \<in> carrier G"
2.3763 +    and asc: "a \<sim> b"
2.3764 +  shows "factorcount G a = factorcount G b"
2.3765 +apply (rule associatedE[OF asc])
2.3766 +apply (drule divides_fcount[OF _ acarr bcarr])
2.3767 +apply (drule divides_fcount[OF _ bcarr acarr])
2.3768 +apply simp
2.3769 +done
2.3770 +
2.3771 +lemma (in factorial_monoid) properfactor_fcount:
2.3772 +  assumes acarr: "a \<in> carrier G" and bcarr:"b \<in> carrier G"
2.3773 +    and pf: "properfactor G a b"
2.3774 +  shows "factorcount G a < factorcount G b"
2.3775 +apply (rule properfactorE[OF pf], elim dividesE)
2.3776 +proof -
2.3777 +  fix c
2.3778 +  from assms
2.3779 +  have "\<exists>as. set as \<subseteq> carrier G \<and> wfactors G as a" by fast
2.3780 +  from this obtain as
2.3781 +      where ascarr: "set as \<subseteq> carrier G"
2.3782 +      and afs: "wfactors G as a"
2.3783 +      by auto
2.3784 +  with acarr have fca: "factorcount G a = length as" by (intro factorcount_unique)
2.3785 +
2.3786 +  assume ccarr: "c \<in> carrier G"
2.3787 +  hence "\<exists>cs. set cs \<subseteq> carrier G \<and> wfactors G cs c" by fast
2.3788 +  from this obtain cs
2.3789 +      where cscarr: "set cs \<subseteq> carrier G"
2.3790 +      and cfs: "wfactors G cs c"
2.3791 +      by auto
2.3792 +
2.3793 +  assume b: "b = a \<otimes> c"
2.3794 +
2.3795 +  have "wfactors G (as@cs) (a \<otimes> c)" by (rule wfactors_mult) fact+
2.3796 +  with b
2.3797 +      have "wfactors G (as@cs) b" by simp
2.3798 +  with ascarr cscarr bcarr
2.3799 +      have "factorcount G b = length (as@cs)" by (simp add: factorcount_unique)
2.3800 +  hence fcb: "factorcount G b = length as + length cs" by simp
2.3801 +
2.3802 +  assume nbdvda: "\<not> b divides a"
2.3803 +  have "c \<notin> Units G"
2.3804 +  proof (rule ccontr, simp)
2.3805 +    assume cunit:"c \<in> Units G"
2.3806 +
2.3807 +    have "b \<otimes> inv c = a \<otimes> c \<otimes> inv c" by (simp add: b)
2.3808 +    also with ccarr acarr cunit
2.3809 +        have "\<dots> = a \<otimes> (c \<otimes> inv c)" by (fast intro: m_assoc)
2.3810 +    also with ccarr cunit
2.3811 +        have "\<dots> = a \<otimes> \<one>" by (simp add: Units_r_inv)
2.3812 +    also with acarr
2.3813 +        have "\<dots> = a" by simp
2.3814 +    finally have "a = b \<otimes> inv c" by simp
2.3815 +    with ccarr cunit
2.3816 +    have "b divides a" by (fast intro: dividesI[of "inv c"])
2.3817 +    with nbdvda show False by simp
2.3818 +  qed
2.3819 +
2.3820 +  with cfs have "length cs > 0"
2.3821 +  apply -
2.3822 +  apply (rule ccontr, simp)
2.3823 +  proof -
2.3824 +    assume "wfactors G [] c"
2.3825 +    hence "\<one> \<sim> c" by (elim wfactorsE, simp)
2.3826 +    with ccarr
2.3827 +        have cunit: "c \<in> Units G" by (intro assoc_unit_r[of "\<one>" "c"], simp+)
2.3828 +    assume "c \<notin> Units G"
2.3829 +    with cunit show "False" by simp
2.3830 +  qed
2.3831 +
2.3832 +  with fca fcb show ?thesis by simp
2.3833 +qed
2.3834 +
2.3835 +interpretation factorial_monoid \<subseteq> divisor_chain_condition_monoid
2.3836 +apply unfold_locales
2.3837 +apply (rule wfUNIVI)
2.3838 +apply (rule measure_induct[of "factorcount G"])
2.3839 +apply simp (* slow *) (*
2.3840 +  [1]Applying congruence rule:
2.3841 +  \<lbrakk>factorcount G y < factorcount G xa \<equiv> ?P'; ?P' \<Longrightarrow> P y \<equiv> ?Q'\<rbrakk> \<Longrightarrow> factorcount G y < factorcount G xa \<longrightarrow> P y \<equiv> ?P' \<longrightarrow> ?Q'
2.3842 +
2.3843 +  trace_simp_depth_limit exceeded!
2.3844 +*)
2.3845 +proof -
2.3846 +  fix P x
2.3847 +  assume r1[rule_format]:
2.3848 +         "\<forall>y. (\<forall>z. z \<in> carrier G \<and> y \<in> carrier G \<and> properfactor G z y \<longrightarrow> P z) \<longrightarrow> P y"
2.3849 +    and r2[rule_format]: "\<forall>y. factorcount G y < factorcount G x \<longrightarrow> P y"
2.3850 +  show "P x"
2.3851 +    apply (rule r1)
2.3852 +    apply (rule r2)
2.3853 +    apply (rule properfactor_fcount, simp+)
2.3854 +  done
2.3855 +qed
2.3856 +
2.3857 +interpretation factorial_monoid \<subseteq> primeness_condition_monoid
2.3858 +  by (unfold_locales, rule irreducible_is_prime)
2.3859 +
2.3860 +
2.3861 +lemma (in factorial_monoid) primeness_condition:
2.3862 +  shows "primeness_condition_monoid G"
2.3863 +by unfold_locales
2.3864 +
2.3865 +lemma (in factorial_monoid) gcd_condition [simp]:
2.3866 +  shows "gcd_condition_monoid G"
2.3867 +by (unfold_locales, rule gcdof_exists)
2.3868 +
2.3869 +interpretation factorial_monoid \<subseteq> gcd_condition_monoid
2.3870 +  by (unfold_locales, rule gcdof_exists)
2.3871 +
2.3872 +lemma (in factorial_monoid) division_glattice [simp]:
2.3873 +  shows "glattice (division_rel G)"
2.3874 +proof -
2.3875 +  interpret glower_semilattice ["division_rel G"] by simp
2.3876 +
2.3877 +  show "glattice (division_rel G)"
2.3878 +  apply (unfold_locales, simp_all)
2.3879 +  proof -
2.3880 +    fix x y
2.3881 +    assume carr: "x \<in> carrier G"  "y \<in> carrier G"
2.3882 +
2.3883 +    hence "\<exists>z. z \<in> carrier G \<and> z lcmof x y" by (rule lcmof_exists)
2.3884 +    from this obtain z
2.3885 +        where zcarr: "z \<in> carrier G"
2.3886 +        and isgcd: "z lcmof x y"
2.3887 +        by auto
2.3888 +    with carr
2.3889 +    have "gleast (division_rel G) z (Upper (division_rel G) {x, y})"
2.3890 +        by (simp add: lcmof_gleastUpper[symmetric])
2.3891 +    thus "\<exists>z. gleast (division_rel G) z (Upper (division_rel G) {x, y})" by fast
2.3892 +  qed
2.3893 +qed
2.3894 +
2.3895 +
2.3896 +subsection {* Factoriality theorems *}
2.3897 +
2.3898 +theorem factorial_condition_one: (* Jacobson theorem 2.21 *)
2.3899 +  shows "(divisor_chain_condition_monoid G \<and> primeness_condition_monoid G) =
2.3900 +         factorial_monoid G"
2.3901 +apply rule
2.3902 +proof clarify
2.3903 +  assume dcc: "divisor_chain_condition_monoid G"
2.3904 +     and pc: "primeness_condition_monoid G"
2.3905 +  interpret divisor_chain_condition_monoid ["G"] by (rule dcc)
2.3906 +  interpret primeness_condition_monoid ["G"] by (rule pc)
2.3907 +
2.3908 +  show "factorial_monoid G"
2.3909 +      by (fast intro: factorial_monoidI wfactors_exist wfactors_unique)
2.3910 +next
2.3911 +  assume fm: "factorial_monoid G"
2.3912 +  interpret factorial_monoid ["G"] by (rule fm)
2.3913 +  show "divisor_chain_condition_monoid G \<and> primeness_condition_monoid G"
2.3914 +      by rule unfold_locales
2.3915 +qed
2.3916 +
2.3917 +theorem factorial_condition_two: (* Jacobson theorem 2.22 *)
2.3918 +  shows "(divisor_chain_condition_monoid G \<and> gcd_condition_monoid G) = factorial_monoid G"
2.3919 +apply rule
2.3920 +proof clarify
2.3921 +    assume dcc: "divisor_chain_condition_monoid G"
2.3922 +     and gc: "gcd_condition_monoid G"
2.3923 +  interpret divisor_chain_condition_monoid ["G"] by (rule dcc)
2.3924 +  interpret gcd_condition_monoid ["G"] by (rule gc)
2.3925 +  show "factorial_monoid G"
2.3926 +      by (simp add: factorial_condition_one[symmetric], rule, unfold_locales)
2.3927 +next
2.3928 +  assume fm: "factorial_monoid G"
2.3929 +  interpret factorial_monoid ["G"] by (rule fm)
2.3930 +  show "divisor_chain_condition_monoid G \<and> gcd_condition_monoid G"
2.3931 +      by rule unfold_locales
2.3932 +qed
2.3933 +
2.3934 +end

     3.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
3.2 +++ b/src/HOL/Algebra/GLattice.thy	Tue Jul 29 16:19:49 2008 +0200
3.3 @@ -0,0 +1,1181 @@
3.4 +(*
3.5 +  Title:     HOL/Algebra/Lattice.thy
3.6 +  Id:        $Id$
3.7 +  Author:    Clemens Ballarin, started 7 November 2003
3.9 +*)
3.10 +
3.11 +theory GLattice imports Congruence begin
3.12 +
3.13 +(* FIXME: unify with Lattice.thy *)
3.14 +
3.15 +
3.16 +section {* Orders and Lattices *}
3.17 +
3.18 +subsection {* Partial Orders *}
3.19 +
3.20 +record 'a gorder = "'a eq_object" +
3.21 +  le :: "['a, 'a] => bool" (infixl "\<sqsubseteq>\<index>" 50)
3.22 +
3.23 +locale gpartial_order = equivalence L +
3.24 +  assumes le_refl [intro, simp]:
3.25 +      "x \<in> carrier L ==> x \<sqsubseteq> x"
3.26 +    and le_anti_sym [intro]:
3.27 +      "[| x \<sqsubseteq> y; y \<sqsubseteq> x; x \<in> carrier L; y \<in> carrier L |] ==> x .= y"
3.28 +    and le_trans [trans]:
3.29 +      "[| x \<sqsubseteq> y; y \<sqsubseteq> z; x \<in> carrier L; y \<in> carrier L; z \<in> carrier L |] ==> x \<sqsubseteq> z"
3.30 +    and le_cong:
3.31 +      "\<lbrakk> x .= y; z .= w; x \<in> carrier L; y \<in> carrier L; z \<in> carrier L; w \<in> carrier L \<rbrakk> \<Longrightarrow> x \<sqsubseteq> z \<longleftrightarrow> y \<sqsubseteq> w"
3.32 +
3.33 +constdefs (structure L)
3.34 +  glless :: "[_, 'a, 'a] => bool" (infixl "\<sqsubset>\<index>" 50)
3.35 +  "x \<sqsubset> y == x \<sqsubseteq> y & x .\<noteq> y"
3.36 +
3.37 +
3.38 +subsubsection {* The order relation *}
3.39 +
3.40 +context gpartial_order begin
3.41 +
3.42 +lemma le_cong_l [intro, trans]:
3.43 +  "\<lbrakk> x .= y; y \<sqsubseteq> z; x \<in> carrier L; y \<in> carrier L; z \<in> carrier L \<rbrakk> \<Longrightarrow> x \<sqsubseteq> z"
3.44 +  by (auto intro: le_cong [THEN iffD2])
3.45 +
3.46 +lemma le_cong_r [intro, trans]:
3.47 +  "\<lbrakk> x \<sqsubseteq> y; y .= z; x \<in> carrier L; y \<in> carrier L; z \<in> carrier L \<rbrakk> \<Longrightarrow> x \<sqsubseteq> z"
3.48 +  by (auto intro: le_cong [THEN iffD1])
3.49 +
3.50 +lemma gen_refl [intro, simp]: "\<lbrakk> x .= y; x \<in> carrier L; y \<in> carrier L \<rbrakk> \<Longrightarrow> x \<sqsubseteq> y"
3.51 +  by (simp add: le_cong_l)
3.52 +
3.53 +end
3.54 +
3.55 +lemma gllessI:
3.56 +  fixes R (structure)
3.57 +  assumes "x \<sqsubseteq> y" and "~(x .= y)"
3.58 +  shows "x \<sqsubset> y"
3.59 +  using assms
3.60 +  unfolding glless_def
3.61 +  by simp
3.62 +
3.63 +lemma gllessD1:
3.64 +  fixes R (structure)
3.65 +  assumes "x \<sqsubset> y"
3.66 +  shows "x \<sqsubseteq> y"
3.67 +  using assms
3.68 +  unfolding glless_def
3.69 +  by simp
3.70 +
3.71 +lemma gllessD2:
3.72 +  fixes R (structure)
3.73 +  assumes "x \<sqsubset> y"
3.74 +  shows "\<not> (x .= y)"
3.75 +  using assms
3.76 +  unfolding glless_def
3.77 +  by simp
3.78 +
3.79 +lemma gllessE:
3.80 +  fixes R (structure)
3.81 +  assumes p: "x \<sqsubset> y"
3.82 +    and e: "\<lbrakk>x \<sqsubseteq> y; \<not> (x .= y)\<rbrakk> \<Longrightarrow> P"
3.83 +  shows "P"
3.84 +  using p
3.85 +  by (blast dest: gllessD1 gllessD2 e)
3.86 +
3.87 +(*
3.88 +lemma (in gpartial_order) lless_cong_l [trans]:
3.89 +  assumes xx': "x \<doteq> x'"
3.90 +    and xy: "x' \<sqsubset> y"
3.91 +    and carr: "x \<in> carrier L" "x' \<in> carrier L" "y \<in> carrier L"
3.92 +  shows "x \<sqsubseteq> y"
3.93 +using xy
3.94 +unfolding lless_def
3.95 +proof clarify
3.96 +  note xx'
3.97 +  also assume "x' \<sqsubseteq> y"
3.98 +  finally show "x \<sqsubseteq> y" by (simp add: carr)
3.99 +qed
3.100 +*)
3.101 +
3.102 +lemma (in gpartial_order) glless_cong_l [trans]:
3.103 +  assumes xx': "x .= x'"
3.104 +    and xy: "x' \<sqsubset> y"
3.105 +    and carr: "x \<in> carrier L" "x' \<in> carrier L" "y \<in> carrier L"
3.106 +  shows "x \<sqsubset> y"
3.107 +  using assms
3.108 +  apply (elim gllessE, intro gllessI)
3.109 +  apply (iprover intro: le_cong_l)
3.110 +  apply (iprover intro: trans sym)
3.111 +  done
3.112 +
3.113 +(*
3.114 +lemma (in gpartial_order) lless_cong_r:
3.115 +  assumes xy: "x \<sqsubset> y"
3.116 +    and  yy': "y \<doteq> y'"
3.117 +    and carr: "x \<in> carrier L" "y \<in> carrier L" "y' \<in> carrier L"
3.118 +  shows "x \<sqsubseteq> y'"
3.119 +using xy
3.120 +unfolding lless_def
3.121 +proof clarify
3.122 +  assume "x \<sqsubseteq> y"
3.123 +  also note yy'
3.124 +  finally show "x \<sqsubseteq> y'" by (simp add: carr)
3.125 +qed
3.126 +*)
3.127 +
3.128 +lemma (in gpartial_order) glless_cong_r [trans]:
3.129 +  assumes xy: "x \<sqsubset> y"
3.130 +    and  yy': "y .= y'"
3.131 +    and carr: "x \<in> carrier L" "y \<in> carrier L" "y' \<in> carrier L"
3.132 +  shows "x \<sqsubset> y'"
3.133 +  using assms
3.134 +  apply (elim gllessE, intro gllessI)
3.135 +  apply (iprover intro: le_cong_r)
3.136 +  apply (iprover intro: trans sym)
3.137 +  done
3.138 +
3.139 +(*
3.140 +lemma (in gpartial_order) glless_antisym:
3.141 +  assumes "a \<in> carrier L" "b \<in> carrier L"
3.142 +    and "a \<sqsubset> b" "b \<sqsubset> a"
3.143 +  shows "a \<doteq> b"
3.144 +  using assms
3.145 +  by (elim gllessE) (rule gle_anti_sym)
3.146 +
3.147 +lemma (in gpartial_order) glless_trans [trans]:
3.148 +  assumes "a .\<sqsubset> b" "b .\<sqsubset> c"
3.149 +    and carr[simp]: "a \<in> carrier L" "b \<in> carrier L" "c \<in> carrier L"
3.150 +  shows "a .\<sqsubset> c"
3.151 +using assms
3.152 +apply (elim gllessE, intro gllessI)
3.153 + apply (iprover dest: le_trans)
3.154 +proof (rule ccontr, simp)
3.155 +  assume ab: "a \<sqsubseteq> b" and bc: "b \<sqsubseteq> c"
3.156 +    and ac: "a \<doteq> c"
3.157 +    and nbc: "\<not> b \<doteq> c"
3.158 +  note ac[symmetric]
3.159 +  also note ab
3.160 +  finally have "c \<sqsubseteq> b" by simp
3.161 +  with bc have "b \<doteq> c" by (iprover intro: gle_anti_sym carr)
3.162 +  with nbc
3.163 +      show "False" by simp
3.164 +qed
3.165 +*)
3.166 +
3.167 +subsubsection {* Upper and lower bounds of a set *}
3.168 +
3.169 +constdefs (structure L)
3.170 +  Upper :: "[_, 'a set] => 'a set"
3.171 +  "Upper L A == {u. (ALL x. x \<in> A \<inter> carrier L --> x \<sqsubseteq> u)} \<inter> carrier L"
3.172 +
3.173 +  Lower :: "[_, 'a set] => 'a set"
3.174 +  "Lower L A == {l. (ALL x. x \<in> A \<inter> carrier L --> l \<sqsubseteq> x)} \<inter> carrier L"
3.175 +
3.176 +lemma Upper_closed [intro!, simp]:
3.177 +  "Upper L A \<subseteq> carrier L"
3.178 +  by (unfold Upper_def) clarify
3.179 +
3.180 +lemma Upper_memD [dest]:
3.181 +  fixes L (structure)
3.182 +  shows "[| u \<in> Upper L A; x \<in> A; A \<subseteq> carrier L |] ==> x \<sqsubseteq> u \<and> u \<in> carrier L"
3.183 +  by (unfold Upper_def) blast
3.184 +
3.185 +lemma (in gpartial_order) Upper_elemD [dest]:
3.186 +  "[| u .\<in> Upper L A; u \<in> carrier L; x \<in> A; A \<subseteq> carrier L |] ==> x \<sqsubseteq> u"
3.187 +  unfolding Upper_def elem_def
3.188 +  by (blast dest: sym)
3.189 +
3.190 +lemma Upper_memI:
3.191 +  fixes L (structure)
3.192 +  shows "[| !! y. y \<in> A ==> y \<sqsubseteq> x; x \<in> carrier L |] ==> x \<in> Upper L A"
3.193 +  by (unfold Upper_def) blast
3.194 +
3.195 +lemma (in gpartial_order) Upper_elemI:
3.196 +  "[| !! y. y \<in> A ==> y \<sqsubseteq> x; x \<in> carrier L |] ==> x .\<in> Upper L A"
3.197 +  unfolding Upper_def by blast
3.198 +
3.199 +lemma Upper_antimono:
3.200 +  "A \<subseteq> B ==> Upper L B \<subseteq> Upper L A"
3.201 +  by (unfold Upper_def) blast
3.202 +
3.203 +lemma (in gpartial_order) Upper_is_closed [simp]:
3.204 +  "A \<subseteq> carrier L ==> is_closed (Upper L A)"
3.205 +  by (rule is_closedI) (blast intro: Upper_memI)+
3.206 +
3.207 +lemma (in gpartial_order) Upper_mem_cong:
3.208 +  assumes a'carr: "a' \<in> carrier L" and Acarr: "A \<subseteq> carrier L"
3.209 +    and aa': "a .= a'"
3.210 +    and aelem: "a \<in> Upper L A"
3.211 +  shows "a' \<in> Upper L A"
3.212 +proof (rule Upper_memI[OF _ a'carr])
3.213 +  fix y
3.214 +  assume yA: "y \<in> A"
3.215 +  hence "y \<sqsubseteq> a" by (intro Upper_memD[OF aelem, THEN conjunct1] Acarr)
3.216 +  also note aa'
3.217 +  finally
3.218 +      show "y \<sqsubseteq> a'"
3.219 +      by (simp add: a'carr subsetD[OF Acarr yA] subsetD[OF Upper_closed aelem])
3.220 +qed
3.221 +
3.222 +lemma (in gpartial_order) Upper_cong:
3.223 +  assumes Acarr: "A \<subseteq> carrier L" and A'carr: "A' \<subseteq> carrier L"
3.224 +    and AA': "A {.=} A'"
3.225 +  shows "Upper L A = Upper L A'"
3.226 +unfolding Upper_def
3.227 +apply rule
3.228 + apply (rule, clarsimp) defer 1
3.229 + apply (rule, clarsimp) defer 1
3.230 +proof -
3.231 +  fix x a'
3.232 +  assume carr: "x \<in> carrier L" "a' \<in> carrier L"
3.233 +    and a'A': "a' \<in> A'"
3.234 +  assume aLxCond[rule_format]: "\<forall>a. a \<in> A \<and> a \<in> carrier L \<longrightarrow> a \<sqsubseteq> x"
3.235 +
3.236 +  from AA' and a'A' have "\<exists>a\<in>A. a' .= a" by (rule set_eqD2)
3.237 +  from this obtain a
3.238 +      where aA: "a \<in> A"
3.239 +      and a'a: "a' .= a"
3.240 +      by auto
3.241 +  note [simp] = subsetD[OF Acarr aA] carr
3.242 +
3.243 +  note a'a
3.244 +  also have "a \<sqsubseteq> x" by (simp add: aLxCond aA)
3.245 +  finally show "a' \<sqsubseteq> x" by simp
3.246 +next
3.247 +  fix x a
3.248 +  assume carr: "x \<in> carrier L" "a \<in> carrier L"
3.249 +    and aA: "a \<in> A"
3.250 +  assume a'LxCond[rule_format]: "\<forall>a'. a' \<in> A' \<and> a' \<in> carrier L \<longrightarrow> a' \<sqsubseteq> x"
3.251 +
3.252 +  from AA' and aA have "\<exists>a'\<in>A'. a .= a'" by (rule set_eqD1)
3.253 +  from this obtain a'
3.254 +      where a'A': "a' \<in> A'"
3.255 +      and aa': "a .= a'"
3.256 +      by auto
3.257 +  note [simp] = subsetD[OF A'carr a'A'] carr
3.258 +
3.259 +  note aa'
3.260 +  also have "a' \<sqsubseteq> x" by (simp add: a'LxCond a'A')
3.261 +  finally show "a \<sqsubseteq> x" by simp
3.262 +qed
3.263 +
3.264 +lemma Lower_closed [intro!, simp]:
3.265 +  "Lower L A \<subseteq> carrier L"
3.266 +  by (unfold Lower_def) clarify
3.267 +
3.268 +lemma Lower_memD [dest]:
3.269 +  fixes L (structure)
3.270 +  shows "[| l \<in> Lower L A; x \<in> A; A \<subseteq> carrier L |] ==> l \<sqsubseteq> x \<and> l \<in> carrier L"
3.271 +  by (unfold Lower_def) blast
3.272 +
3.273 +lemma Lower_memI:
3.274 +  fixes L (structure)
3.275 +  shows "[| !! y. y \<in> A ==> x \<sqsubseteq> y; x \<in> carrier L |] ==> x \<in> Lower L A"
3.276 +  by (unfold Lower_def) blast
3.277 +
3.278 +lemma Lower_antimono:
3.279 +  "A \<subseteq> B ==> Lower L B \<subseteq> Lower L A"
3.280 +  by (unfold Lower_def) blast
3.281 +
3.282 +lemma (in gpartial_order) Lower_is_closed [simp]:
3.283 +  "A \<subseteq> carrier L \<Longrightarrow> is_closed (Lower L A)"
3.284 +  by (rule is_closedI) (blast intro: Lower_memI dest: sym)+
3.285 +
3.286 +lemma (in gpartial_order) Lower_mem_cong:
3.287 +  assumes a'carr: "a' \<in> carrier L" and Acarr: "A \<subseteq> carrier L"
3.288 +    and aa': "a .= a'"
3.289 +    and aelem: "a \<in> Lower L A"
3.290 +  shows "a' \<in> Lower L A"
3.291 +using assms Lower_closed[of L A]
3.292 +by (intro Lower_memI) (blast intro: le_cong_l[OF aa'[symmetric]])
3.293 +
3.294 +lemma (in gpartial_order) Lower_cong:
3.295 +  assumes Acarr: "A \<subseteq> carrier L" and A'carr: "A' \<subseteq> carrier L"
3.296 +    and AA': "A {.=} A'"
3.297 +  shows "Lower L A = Lower L A'"
3.298 +using Lower_memD[of y]
3.299 +unfolding Lower_def
3.300 +apply safe
3.301 + apply clarsimp defer 1
3.302 + apply clarsimp defer 1
3.303 +proof -
3.304 +  fix x a'
3.305 +  assume carr: "x \<in> carrier L" "a' \<in> carrier L"
3.306 +    and a'A': "a' \<in> A'"
3.307 +  assume "\<forall>a. a \<in> A \<and> a \<in> carrier L \<longrightarrow> x \<sqsubseteq> a"
3.308 +  hence aLxCond: "\<And>a. \<lbrakk>a \<in> A; a \<in> carrier L\<rbrakk> \<Longrightarrow> x \<sqsubseteq> a" by fast
3.309 +
3.310 +  from AA' and a'A' have "\<exists>a\<in>A. a' .= a" by (rule set_eqD2)
3.311 +  from this obtain a
3.312 +      where aA: "a \<in> A"
3.313 +      and a'a: "a' .= a"
3.314 +      by auto
3.315 +
3.316 +  from aA and subsetD[OF Acarr aA]
3.317 +      have "x \<sqsubseteq> a" by (rule aLxCond)
3.318 +  also note a'a[symmetric]
3.319 +  finally
3.320 +      show "x \<sqsubseteq> a'" by (simp add: carr subsetD[OF Acarr aA])
3.321 +next
3.322 +  fix x a
3.323 +  assume carr: "x \<in> carrier L" "a \<in> carrier L"
3.324 +    and aA: "a \<in> A"
3.325 +  assume "\<forall>a'. a' \<in> A' \<and> a' \<in> carrier L \<longrightarrow> x \<sqsubseteq> a'"
3.326 +  hence a'LxCond: "\<And>a'. \<lbrakk>a' \<in> A'; a' \<in> carrier L\<rbrakk> \<Longrightarrow> x \<sqsubseteq> a'" by fast+
3.327 +
3.328 +  from AA' and aA have "\<exists>a'\<in>A'. a .= a'" by (rule set_eqD1)
3.329 +  from this obtain a'
3.330 +      where a'A': "a' \<in> A'"
3.331 +      and aa': "a .= a'"
3.332 +      by auto
3.333 +  from a'A' and subsetD[OF A'carr a'A']
3.334 +      have "x \<sqsubseteq> a'" by (rule a'LxCond)
3.335 +  also note aa'[symmetric]
3.336 +  finally show "x \<sqsubseteq> a" by (simp add: carr subsetD[OF A'carr a'A'])
3.337 +qed
3.338 +
3.339 +
3.340 +subsubsection {* Least and greatest, as predicate *}
3.341 +
3.342 +constdefs (structure L)
3.343 +  gleast :: "[_, 'a, 'a set] => bool"
3.344 +  "gleast L l A == A \<subseteq> carrier L & l \<in> A & (ALL x : A. l \<sqsubseteq> x)"
3.345 +
3.346 +  ggreatest :: "[_, 'a, 'a set] => bool"
3.347 +  "ggreatest L g A == A \<subseteq> carrier L & g \<in> A & (ALL x : A. x \<sqsubseteq> g)"
3.348 +
3.349 +lemma gleast_closed [intro, simp]:
3.350 +  "gleast L l A ==> l \<in> carrier L"
3.351 +  by (unfold gleast_def) fast
3.352 +
3.353 +lemma gleast_mem:
3.354 +  "gleast L l A ==> l \<in> A"
3.355 +  by (unfold gleast_def) fast
3.356 +
3.357 +lemma (in gpartial_order) gleast_unique:
3.358 +  "[| gleast L x A; gleast L y A |] ==> x .= y"
3.359 +  by (unfold gleast_def) blast
3.360 +
3.361 +lemma gleast_le:
3.362 +  fixes L (structure)
3.363 +  shows "[| gleast L x A; a \<in> A |] ==> x \<sqsubseteq> a"
3.364 +  by (unfold gleast_def) fast
3.365 +
3.366 +lemma (in gpartial_order) gleast_cong:
3.367 +  "[| x .= x'; x \<in> carrier L; x' \<in> carrier L; is_closed A |] ==> gleast L x A = gleast L x' A"
3.368 +  by (unfold gleast_def) (auto dest: sym)
3.369 +
3.370 +text {* @{const gleast} is not congruent in the second parameter for
3.371 +  @{term [locale=gpartial_order] "A {.=} A'"} *}
3.372 +
3.373 +lemma (in gpartial_order) gleast_Upper_cong_l:
3.374 +  assumes "x .= x'"
3.375 +    and "x \<in> carrier L" "x' \<in> carrier L"
3.376 +    and "A \<subseteq> carrier L"
3.377 +  shows "gleast L x (Upper L A) = gleast L x' (Upper L A)"
3.378 +  apply (rule gleast_cong) using assms by auto
3.379 +
3.380 +lemma (in gpartial_order) gleast_Upper_cong_r:
3.381 +  assumes Acarrs: "A \<subseteq> carrier L" "A' \<subseteq> carrier L" (* unneccessary with current Upper? *)
3.382 +    and AA': "A {.=} A'"
3.383 +  shows "gleast L x (Upper L A) = gleast L x (Upper L A')"
3.384 +apply (subgoal_tac "Upper L A = Upper L A'", simp)
3.385 +by (rule Upper_cong) fact+
3.386 +
3.387 +lemma gleast_UpperI:
3.388 +  fixes L (structure)
3.389 +  assumes above: "!! x. x \<in> A ==> x \<sqsubseteq> s"
3.390 +    and below: "!! y. y \<in> Upper L A ==> s \<sqsubseteq> y"
3.391 +    and L: "A \<subseteq> carrier L"  "s \<in> carrier L"
3.392 +  shows "gleast L s (Upper L A)"
3.393 +proof -
3.394 +  have "Upper L A \<subseteq> carrier L" by simp
3.395 +  moreover from above L have "s \<in> Upper L A" by (simp add: Upper_def)
3.396 +  moreover from below have "ALL x : Upper L A. s \<sqsubseteq> x" by fast
3.397 +  ultimately show ?thesis by (simp add: gleast_def)
3.398 +qed
3.399 +
3.400 +lemma gleast_Upper_above:
3.401 +  fixes L (structure)
3.402 +  shows "[| gleast L s (Upper L A); x \<in> A; A \<subseteq> carrier L |] ==> x \<sqsubseteq> s"
3.403 +  by (unfold gleast_def) blast
3.404 +
3.405 +lemma ggreatest_closed [intro, simp]:
3.406 +  "ggreatest L l A ==> l \<in> carrier L"
3.407 +  by (unfold ggreatest_def) fast
3.408 +
3.409 +lemma ggreatest_mem:
3.410 +  "ggreatest L l A ==> l \<in> A"
3.411 +  by (unfold ggreatest_def) fast
3.412 +
3.413 +lemma (in gpartial_order) ggreatest_unique:
3.414 +  "[| ggreatest L x A; ggreatest L y A |] ==> x .= y"
3.415 +  by (unfold ggreatest_def) blast
3.416 +
3.417 +lemma ggreatest_le:
3.418 +  fixes L (structure)
3.419 +  shows "[| ggreatest L x A; a \<in> A |] ==> a \<sqsubseteq> x"
3.420 +  by (unfold ggreatest_def) fast
3.421 +
3.422 +lemma (in gpartial_order) ggreatest_cong:
3.423 +  "[| x .= x'; x \<in> carrier L; x' \<in> carrier L; is_closed A |] ==>
3.424 +  ggreatest L x A = ggreatest L x' A"
3.425 +  by (unfold ggreatest_def) (auto dest: sym)
3.426 +
3.427 +text {* @{const ggreatest} is not congruent in the second parameter for
3.428 +  @{term [locale=gpartial_order] "A {.=} A'"} *}
3.429 +
3.430 +lemma (in gpartial_order) ggreatest_Lower_cong_l:
3.431 +  assumes "x .= x'"
3.432 +    and "x \<in> carrier L" "x' \<in> carrier L"
3.433 +    and "A \<subseteq> carrier L" (* unneccessary with current Lower *)
3.434 +  shows "ggreatest L x (Lower L A) = ggreatest L x' (Lower L A)"
3.435 +  apply (rule ggreatest_cong) using assms by auto
3.436 +
3.437 +lemma (in gpartial_order) ggreatest_Lower_cong_r:
3.438 +  assumes Acarrs: "A \<subseteq> carrier L" "A' \<subseteq> carrier L"
3.439 +    and AA': "A {.=} A'"
3.440 +  shows "ggreatest L x (Lower L A) = ggreatest L x (Lower L A')"
3.441 +apply (subgoal_tac "Lower L A = Lower L A'", simp)
3.442 +by (rule Lower_cong) fact+
3.443 +
3.444 +lemma ggreatest_LowerI:
3.445 +  fixes L (structure)
3.446 +  assumes below: "!! x. x \<in> A ==> i \<sqsubseteq> x"
3.447 +    and above: "!! y. y \<in> Lower L A ==> y \<sqsubseteq> i"
3.448 +    and L: "A \<subseteq> carrier L"  "i \<in> carrier L"
3.449 +  shows "ggreatest L i (Lower L A)"
3.450 +proof -
3.451 +  have "Lower L A \<subseteq> carrier L" by simp
3.452 +  moreover from below L have "i \<in> Lower L A" by (simp add: Lower_def)
3.453 +  moreover from above have "ALL x : Lower L A. x \<sqsubseteq> i" by fast
3.454 +  ultimately show ?thesis by (simp add: ggreatest_def)
3.455 +qed
3.456 +
3.457 +lemma ggreatest_Lower_below:
3.458 +  fixes L (structure)
3.459 +  shows "[| ggreatest L i (Lower L A); x \<in> A; A \<subseteq> carrier L |] ==> i \<sqsubseteq> x"
3.460 +  by (unfold ggreatest_def) blast
3.461 +
3.462 +text {* Supremum and infimum *}
3.463 +
3.464 +constdefs (structure L)
3.465 +  gsup :: "[_, 'a set] => 'a" ("\<Squnion>\<index>_" [90] 90)
3.466 +  "\<Squnion>A == SOME x. gleast L x (Upper L A)"
3.467 +
3.468 +  ginf :: "[_, 'a set] => 'a" ("\<Sqinter>\<index>_" [90] 90)
3.469 +  "\<Sqinter>A == SOME x. ggreatest L x (Lower L A)"
3.470 +
3.471 +  gjoin :: "[_, 'a, 'a] => 'a" (infixl "\<squnion>\<index>" 65)
3.472 +  "x \<squnion> y == \<Squnion> {x, y}"
3.473 +
3.474 +  gmeet :: "[_, 'a, 'a] => 'a" (infixl "\<sqinter>\<index>" 70)
3.475 +  "x \<sqinter> y == \<Sqinter> {x, y}"
3.476 +
3.477 +
3.478 +subsection {* Lattices *}
3.479 +
3.480 +locale gupper_semilattice = gpartial_order +
3.481 +  assumes gsup_of_two_exists:
3.482 +    "[| x \<in> carrier L; y \<in> carrier L |] ==> EX s. gleast L s (Upper L {x, y})"
3.483 +
3.484 +locale glower_semilattice = gpartial_order +
3.485 +  assumes ginf_of_two_exists:
3.486 +    "[| x \<in> carrier L; y \<in> carrier L |] ==> EX s. ggreatest L s (Lower L {x, y})"
3.487 +
3.488 +locale glattice = gupper_semilattice + glower_semilattice
3.489 +
3.490 +
3.491 +subsubsection {* Supremum *}
3.492 +
3.493 +lemma (in gupper_semilattice) gjoinI:
3.494 +  "[| !!l. gleast L l (Upper L {x, y}) ==> P l; x \<in> carrier L; y \<in> carrier L |]
3.495 +  ==> P (x \<squnion> y)"
3.496 +proof (unfold gjoin_def gsup_def)
3.497 +  assume L: "x \<in> carrier L"  "y \<in> carrier L"
3.498 +    and P: "!!l. gleast L l (Upper L {x, y}) ==> P l"
3.499 +  with gsup_of_two_exists obtain s where "gleast L s (Upper L {x, y})" by fast
3.500 +  with L show "P (SOME l. gleast L l (Upper L {x, y}))"
3.501 +    by (fast intro: someI2 P)
3.502 +qed
3.503 +
3.504 +lemma (in gupper_semilattice) gjoin_closed [simp]:
3.505 +  "[| x \<in> carrier L; y \<in> carrier L |] ==> x \<squnion> y \<in> carrier L"
3.506 +  by (rule gjoinI) (rule gleast_closed)
3.507 +
3.508 +lemma (in gupper_semilattice) gjoin_cong_l:
3.509 +  assumes carr: "x \<in> carrier L" "x' \<in> carrier L" "y \<in> carrier L"
3.510 +    and xx': "x .= x'"
3.511 +  shows "x \<squnion> y .= x' \<squnion> y"
3.512 +proof (rule gjoinI, rule gjoinI)
3.513 +  fix a b
3.514 +  from xx' carr
3.515 +      have seq: "{x, y} {.=} {x', y}" by (rule set_eq_pairI)
3.516 +
3.517 +  assume gleasta: "gleast L a (Upper L {x, y})"
3.518 +  assume "gleast L b (Upper L {x', y})"
3.519 +  with carr
3.520 +      have gleastb: "gleast L b (Upper L {x, y})"
3.521 +      by (simp add: gleast_Upper_cong_r[OF _ _ seq])
3.522 +
3.523 +  from gleasta gleastb
3.524 +      show "a .= b" by (rule gleast_unique)
3.525 +qed (rule carr)+
3.526 +
3.527 +lemma (in gupper_semilattice) gjoin_cong_r:
3.528 +  assumes carr: "x \<in> carrier L" "y \<in> carrier L" "y' \<in> carrier L"
3.529 +    and yy': "y .= y'"
3.530 +  shows "x \<squnion> y .= x \<squnion> y'"
3.531 +proof (rule gjoinI, rule gjoinI)
3.532 +  fix a b
3.533 +  have "{x, y} = {y, x}" by fast
3.534 +  also from carr yy'
3.535 +      have "{y, x} {.=} {y', x}" by (intro set_eq_pairI)
3.536 +  also have "{y', x} = {x, y'}" by fast
3.537 +  finally
3.538 +      have seq: "{x, y} {.=} {x, y'}" .
3.539 +
3.540 +  assume gleasta: "gleast L a (Upper L {x, y})"
3.541 +  assume "gleast L b (Upper L {x, y'})"
3.542 +  with carr
3.543 +      have gleastb: "gleast L b (Upper L {x, y})"
3.544 +      by (simp add: gleast_Upper_cong_r[OF _ _ seq])
3.545 +
3.546 +  from gleasta gleastb
3.547 +      show "a .= b" by (rule gleast_unique)
3.548 +qed (rule carr)+
3.549 +
3.550 +lemma (in gpartial_order) gsup_of_singletonI:      (* only reflexivity needed ? *)
3.551 +  "x \<in> carrier L ==> gleast L x (Upper L {x})"
3.552 +  by (rule gleast_UpperI) auto
3.553 +
3.554 +lemma (in gpartial_order) gsup_of_singleton [simp]:
3.555 +  "x \<in> carrier L ==> \<Squnion>{x} .= x"
3.556 +  unfolding gsup_def
3.557 +  by (rule someI2) (auto intro: gleast_unique gsup_of_singletonI)
3.558 +
3.559 +lemma (in gpartial_order) gsup_of_singleton_closed [simp]:
3.560 +  "x \<in> carrier L \<Longrightarrow> \<Squnion>{x} \<in> carrier L"
3.561 +  unfolding gsup_def
3.562 +  by (rule someI2) (auto intro: gsup_of_singletonI)
3.563 +
3.564 +text {* Condition on @{text A}: supremum exists. *}
3.565 +
3.566 +lemma (in gupper_semilattice) gsup_insertI:
3.567 +  "[| !!s. gleast L s (Upper L (insert x A)) ==> P s;
3.568 +  gleast L a (Upper L A); x \<in> carrier L; A \<subseteq> carrier L |]
3.569 +  ==> P (\<Squnion>(insert x A))"
3.570 +proof (unfold gsup_def)
3.571 +  assume L: "x \<in> carrier L"  "A \<subseteq> carrier L"
3.572 +    and P: "!!l. gleast L l (Upper L (insert x A)) ==> P l"
3.573 +    and gleast_a: "gleast L a (Upper L A)"
3.574 +  from L gleast_a have La: "a \<in> carrier L" by simp
3.575 +  from L gsup_of_two_exists gleast_a
3.576 +  obtain s where gleast_s: "gleast L s (Upper L {a, x})" by blast
3.577 +  show "P (SOME l. gleast L l (Upper L (insert x A)))"
3.578 +  proof (rule someI2)
3.579 +    show "gleast L s (Upper L (insert x A))"
3.580 +    proof (rule gleast_UpperI)
3.581 +      fix z
3.582 +      assume "z \<in> insert x A"
3.583 +      then show "z \<sqsubseteq> s"
3.584 +      proof
3.585 +        assume "z = x" then show ?thesis
3.586 +          by (simp add: gleast_Upper_above [OF gleast_s] L La)
3.587 +      next
3.588 +        assume "z \<in> A"
3.589 +        with L gleast_s gleast_a show ?thesis
3.590 +          by (rule_tac le_trans [where y = a]) (auto dest: gleast_Upper_above)
3.591 +      qed
3.592 +    next
3.593 +      fix y
3.594 +      assume y: "y \<in> Upper L (insert x A)"
3.595 +      show "s \<sqsubseteq> y"
3.596 +      proof (rule gleast_le [OF gleast_s], rule Upper_memI)
3.597 +	fix z
3.598 +	assume z: "z \<in> {a, x}"
3.599 +	then show "z \<sqsubseteq> y"
3.600 +	proof
3.601 +          have y': "y \<in> Upper L A"
3.602 +            apply (rule subsetD [where A = "Upper L (insert x A)"])
3.603 +             apply (rule Upper_antimono)
3.604 +	     apply blast
3.605 +	    apply (rule y)
3.606 +            done
3.607 +          assume "z = a"
3.608 +          with y' gleast_a show ?thesis by (fast dest: gleast_le)
3.609 +	next
3.610 +	  assume "z \<in> {x}"  (* FIXME "z = x"; declare specific elim rule for "insert x {}" (!?) *)
3.611 +          with y L show ?thesis by blast
3.612 +	qed
3.613 +      qed (rule Upper_closed [THEN subsetD, OF y])
3.614 +    next
3.615 +      from L show "insert x A \<subseteq> carrier L" by simp
3.616 +      from gleast_s show "s \<in> carrier L" by simp
3.617 +    qed
3.618 +  qed (rule P)
3.619 +qed
3.620 +
3.621 +lemma (in gupper_semilattice) finite_gsup_gleast:
3.622 +  "[| finite A; A \<subseteq> carrier L; A ~= {} |] ==> gleast L (\<Squnion>A) (Upper L A)"
3.623 +proof (induct set: finite)
3.624 +  case empty
3.625 +  then show ?case by simp
3.626 +next
3.627 +  case (insert x A)
3.628 +  show ?case
3.629 +  proof (cases "A = {}")
3.630 +    case True
3.631 +    with insert show ?thesis
3.632 +      by simp (simp add: gleast_cong [OF gsup_of_singleton]
3.633 +	gsup_of_singleton_closed gsup_of_singletonI)
3.634 +	(* The above step is hairy; gleast_cong can make simp loop.
3.635 +	Would want special version of simp to apply gleast_cong. *)
3.636 +  next
3.637 +    case False
3.638 +    with insert have "gleast L (\<Squnion>A) (Upper L A)" by simp
3.639 +    with _ show ?thesis
3.640 +      by (rule gsup_insertI) (simp_all add: insert [simplified])
3.641 +  qed
3.642 +qed
3.643 +
3.644 +lemma (in gupper_semilattice) finite_gsup_insertI:
3.645 +  assumes P: "!!l. gleast L l (Upper L (insert x A)) ==> P l"
3.646 +    and xA: "finite A"  "x \<in> carrier L"  "A \<subseteq> carrier L"
3.647 +  shows "P (\<Squnion> (insert x A))"
3.648 +proof (cases "A = {}")
3.649 +  case True with P and xA show ?thesis
3.650 +    by (simp add: finite_gsup_gleast)
3.651 +next
3.652 +  case False with P and xA show ?thesis
3.653 +    by (simp add: gsup_insertI finite_gsup_gleast)
3.654 +qed
3.655 +
3.656 +lemma (in gupper_semilattice) finite_gsup_closed [simp]:
3.657 +  "[| finite A; A \<subseteq> carrier L; A ~= {} |] ==> \<Squnion>A \<in> carrier L"
3.658 +proof (induct set: finite)
3.659 +  case empty then show ?case by simp
3.660 +next
3.661 +  case insert then show ?case
3.662 +    by - (rule finite_gsup_insertI, simp_all)
3.663 +qed
3.664 +
3.665 +lemma (in gupper_semilattice) gjoin_left:
3.666 +  "[| x \<in> carrier L; y \<in> carrier L |] ==> x \<sqsubseteq> x \<squnion> y"
3.667 +  by (rule gjoinI [folded gjoin_def]) (blast dest: gleast_mem)
3.668 +
3.669 +lemma (in gupper_semilattice) gjoin_right:
3.670 +  "[| x \<in> carrier L; y \<in> carrier L |] ==> y \<sqsubseteq> x \<squnion> y"
3.671 +  by (rule gjoinI [folded gjoin_def]) (blast dest: gleast_mem)
3.672 +
3.673 +lemma (in gupper_semilattice) gsup_of_two_gleast:
3.674 +  "[| x \<in> carrier L; y \<in> carrier L |] ==> gleast L (\<Squnion>{x, y}) (Upper L {x, y})"
3.675 +proof (unfold gsup_def)
3.676 +  assume L: "x \<in> carrier L"  "y \<in> carrier L"
3.677 +  with gsup_of_two_exists obtain s where "gleast L s (Upper L {x, y})" by fast
3.678 +  with L show "gleast L (SOME z. gleast L z (Upper L {x, y})) (Upper L {x, y})"
3.679 +  by (fast intro: someI2 gleast_unique)  (* blast fails *)
3.680 +qed
3.681 +
3.682 +lemma (in gupper_semilattice) gjoin_le:
3.683 +  assumes sub: "x \<sqsubseteq> z"  "y \<sqsubseteq> z"
3.684 +    and x: "x \<in> carrier L" and y: "y \<in> carrier L" and z: "z \<in> carrier L"
3.685 +  shows "x \<squnion> y \<sqsubseteq> z"
3.686 +proof (rule gjoinI [OF _ x y])
3.687 +  fix s
3.688 +  assume "gleast L s (Upper L {x, y})"
3.689 +  with sub z show "s \<sqsubseteq> z" by (fast elim: gleast_le intro: Upper_memI)
3.690 +qed
3.691 +
3.692 +lemma (in gupper_semilattice) gjoin_assoc_lemma:
3.693 +  assumes L: "x \<in> carrier L"  "y \<in> carrier L"  "z \<in> carrier L"
3.694 +  shows "x \<squnion> (y \<squnion> z) .= \<Squnion>{x, y, z}"
3.695 +proof (rule finite_gsup_insertI)
3.696 +  -- {* The textbook argument in Jacobson I, p 457 *}
3.697 +  fix s
3.698 +  assume gsup: "gleast L s (Upper L {x, y, z})"
3.699 +  show "x \<squnion> (y \<squnion> z) .= s"
3.700 +  proof (rule le_anti_sym)
3.701 +    from gsup L show "x \<squnion> (y \<squnion> z) \<sqsubseteq> s"
3.702 +      by (fastsimp intro!: gjoin_le elim: gleast_Upper_above)
3.703 +  next
3.704 +    from gsup L show "s \<sqsubseteq> x \<squnion> (y \<squnion> z)"
3.705 +    by (erule_tac gleast_le)
3.706 +      (blast intro!: Upper_memI intro: le_trans gjoin_left gjoin_right gjoin_closed)
3.707 +  qed (simp_all add: L gleast_closed [OF gsup])
3.709 +
3.710 +text {* Commutativity holds for @{text "="}. *}
3.711 +
3.712 +lemma gjoin_comm:
3.713 +  fixes L (structure)
3.714 +  shows "x \<squnion> y = y \<squnion> x"
3.715 +  by (unfold gjoin_def) (simp add: insert_commute)
3.716 +
3.717 +lemma (in gupper_semilattice) gjoin_assoc:
3.718 +  assumes L: "x \<in> carrier L"  "y \<in> carrier L"  "z \<in> carrier L"
3.719 +  shows "(x \<squnion> y) \<squnion> z .= x \<squnion> (y \<squnion> z)"
3.720 +proof -
3.721 +  (* FIXME: could be simplified by improved simp: uniform use of .=,
3.722 +     omit [symmetric] in last step. *)
3.723 +  have "(x \<squnion> y) \<squnion> z = z \<squnion> (x \<squnion> y)" by (simp only: gjoin_comm)
3.724 +  also from L have "... .= \<Squnion>{z, x, y}" by (simp add: gjoin_assoc_lemma)
3.725 +  also from L have "... = \<Squnion>{x, y, z}" by (simp add: insert_commute)
3.726 +  also from L have "... .= x \<squnion> (y \<squnion> z)" by (simp add: gjoin_assoc_lemma [symmetric])
3.727 +  finally show ?thesis by (simp add: L)
3.728 +qed
3.729 +
3.730 +
3.731 +subsubsection {* Infimum *}
3.732 +
3.733 +lemma (in glower_semilattice) gmeetI:
3.734 +  "[| !!i. ggreatest L i (Lower L {x, y}) ==> P i;
3.735 +  x \<in> carrier L; y \<in> carrier L |]
3.736 +  ==> P (x \<sqinter> y)"
3.737 +proof (unfold gmeet_def ginf_def)
3.738 +  assume L: "x \<in> carrier L"  "y \<in> carrier L"
3.739 +    and P: "!!g. ggreatest L g (Lower L {x, y}) ==> P g"
3.740 +  with ginf_of_two_exists obtain i where "ggreatest L i (Lower L {x, y})" by fast
3.741 +  with L show "P (SOME g. ggreatest L g (Lower L {x, y}))"
3.742 +  by (fast intro: someI2 ggreatest_unique P)
3.743 +qed
3.744 +
3.745 +lemma (in glower_semilattice) gmeet_closed [simp]:
3.746 +  "[| x \<in> carrier L; y \<in> carrier L |] ==> x \<sqinter> y \<in> carrier L"
3.747 +  by (rule gmeetI) (rule ggreatest_closed)
3.748 +
3.749 +lemma (in glower_semilattice) gmeet_cong_l:
3.750 +  assumes carr: "x \<in> carrier L" "x' \<in> carrier L" "y \<in> carrier L"
3.751 +    and xx': "x .= x'"
3.752 +  shows "x \<sqinter> y .= x' \<sqinter> y"
3.753 +proof (rule gmeetI, rule gmeetI)
3.754 +  fix a b
3.755 +  from xx' carr
3.756 +      have seq: "{x, y} {.=} {x', y}" by (rule set_eq_pairI)
3.757 +
3.758 +  assume ggreatesta: "ggreatest L a (Lower L {x, y})"
3.759 +  assume "ggreatest L b (Lower L {x', y})"
3.760 +  with carr
3.761 +      have ggreatestb: "ggreatest L b (Lower L {x, y})"
3.762 +      by (simp add: ggreatest_Lower_cong_r[OF _ _ seq])
3.763 +
3.764 +  from ggreatesta ggreatestb
3.765 +      show "a .= b" by (rule ggreatest_unique)
3.766 +qed (rule carr)+
3.767 +
3.768 +lemma (in glower_semilattice) gmeet_cong_r:
3.769 +  assumes carr: "x \<in> carrier L" "y \<in> carrier L" "y' \<in> carrier L"
3.770 +    and yy': "y .= y'"
3.771 +  shows "x \<sqinter> y .= x \<sqinter> y'"
3.772 +proof (rule gmeetI, rule gmeetI)
3.773 +  fix a b
3.774 +  have "{x, y} = {y, x}" by fast
3.775 +  also from carr yy'
3.776 +      have "{y, x} {.=} {y', x}" by (intro set_eq_pairI)
3.777 +  also have "{y', x} = {x, y'}" by fast
3.778 +  finally
3.779 +      have seq: "{x, y} {.=} {x, y'}" .
3.780 +
3.781 +  assume ggreatesta: "ggreatest L a (Lower L {x, y})"
3.782 +  assume "ggreatest L b (Lower L {x, y'})"
3.783 +  with carr
3.784 +      have ggreatestb: "ggreatest L b (Lower L {x, y})"
3.785 +      by (simp add: ggreatest_Lower_cong_r[OF _ _ seq])
3.786 +
3.787 +  from ggreatesta ggreatestb
3.788 +      show "a .= b" by (rule ggreatest_unique)
3.789 +qed (rule carr)+
3.790 +
3.791 +lemma (in gpartial_order) ginf_of_singletonI:      (* only reflexivity needed ? *)
3.792 +  "x \<in> carrier L ==> ggreatest L x (Lower L {x})"
3.793 +  by (rule ggreatest_LowerI) auto
3.794 +
3.795 +lemma (in gpartial_order) ginf_of_singleton [simp]:
3.796 +  "x \<in> carrier L ==> \<Sqinter>{x} .= x"
3.797 +  unfolding ginf_def
3.798 +  by (rule someI2) (auto intro: ggreatest_unique ginf_of_singletonI)
3.799 +
3.800 +lemma (in gpartial_order) ginf_of_singleton_closed:
3.801 +  "x \<in> carrier L ==> \<Sqinter>{x} \<in> carrier L"
3.802 +  unfolding ginf_def
3.803 +  by (rule someI2) (auto intro: ginf_of_singletonI)
3.804 +
3.805 +text {* Condition on @{text A}: infimum exists. *}
3.806 +
3.807 +lemma (in glower_semilattice) ginf_insertI:
3.808 +  "[| !!i. ggreatest L i (Lower L (insert x A)) ==> P i;
3.809 +  ggreatest L a (Lower L A); x \<in> carrier L; A \<subseteq> carrier L |]
3.810 +  ==> P (\<Sqinter>(insert x A))"
3.811 +proof (unfold ginf_def)
3.812 +  assume L: "x \<in> carrier L"  "A \<subseteq> carrier L"
3.813 +    and P: "!!g. ggreatest L g (Lower L (insert x A)) ==> P g"
3.814 +    and ggreatest_a: "ggreatest L a (Lower L A)"
3.815 +  from L ggreatest_a have La: "a \<in> carrier L" by simp
3.816 +  from L ginf_of_two_exists ggreatest_a
3.817 +  obtain i where ggreatest_i: "ggreatest L i (Lower L {a, x})" by blast
3.818 +  show "P (SOME g. ggreatest L g (Lower L (insert x A)))"
3.819 +  proof (rule someI2)
3.820 +    show "ggreatest L i (Lower L (insert x A))"
3.821 +    proof (rule ggreatest_LowerI)
3.822 +      fix z
3.823 +      assume "z \<in> insert x A"
3.824 +      then show "i \<sqsubseteq> z"
3.825 +      proof
3.826 +        assume "z = x" then show ?thesis
3.827 +          by (simp add: ggreatest_Lower_below [OF ggreatest_i] L La)
3.828 +      next
3.829 +        assume "z \<in> A"
3.830 +        with L ggreatest_i ggreatest_a show ?thesis
3.831 +          by (rule_tac le_trans [where y = a]) (auto dest: ggreatest_Lower_below)
3.832 +      qed
3.833 +    next
3.834 +      fix y
3.835 +      assume y: "y \<in> Lower L (insert x A)"
3.836 +      show "y \<sqsubseteq> i"
3.837 +      proof (rule ggreatest_le [OF ggreatest_i], rule Lower_memI)
3.838 +	fix z
3.839 +	assume z: "z \<in> {a, x}"
3.840 +	then show "y \<sqsubseteq> z"
3.841 +	proof
3.842 +          have y': "y \<in> Lower L A"
3.843 +            apply (rule subsetD [where A = "Lower L (insert x A)"])
3.844 +            apply (rule Lower_antimono)
3.845 +	     apply blast
3.846 +	    apply (rule y)
3.847 +            done
3.848 +          assume "z = a"
3.849 +          with y' ggreatest_a show ?thesis by (fast dest: ggreatest_le)
3.850 +	next
3.851 +          assume "z \<in> {x}"
3.852 +          with y L show ?thesis by blast
3.853 +	qed
3.854 +      qed (rule Lower_closed [THEN subsetD, OF y])
3.855 +    next
3.856 +      from L show "insert x A \<subseteq> carrier L" by simp
3.857 +      from ggreatest_i show "i \<in> carrier L" by simp
3.858 +    qed
3.859 +  qed (rule P)
3.860 +qed
3.861 +
3.862 +lemma (in glower_semilattice) finite_ginf_ggreatest:
3.863 +  "[| finite A; A \<subseteq> carrier L; A ~= {} |] ==> ggreatest L (\<Sqinter>A) (Lower L A)"
3.864 +proof (induct set: finite)
3.865 +  case empty then show ?case by simp
3.866 +next
3.867 +  case (insert x A)
3.868 +  show ?case
3.869 +  proof (cases "A = {}")
3.870 +    case True
3.871 +    with insert show ?thesis
3.872 +      by simp (simp add: ggreatest_cong [OF ginf_of_singleton]
3.873 +	ginf_of_singleton_closed ginf_of_singletonI)
3.874 +  next
3.875 +    case False
3.876 +    from insert show ?thesis
3.877 +    proof (rule_tac ginf_insertI)
3.878 +      from False insert show "ggreatest L (\<Sqinter>A) (Lower L A)" by simp
3.879 +    qed simp_all
3.880 +  qed
3.881 +qed
3.882 +
3.883 +lemma (in glower_semilattice) finite_ginf_insertI:
3.884 +  assumes P: "!!i. ggreatest L i (Lower L (insert x A)) ==> P i"
3.885 +    and xA: "finite A"  "x \<in> carrier L"  "A \<subseteq> carrier L"
3.886 +  shows "P (\<Sqinter> (insert x A))"
3.887 +proof (cases "A = {}")
3.888 +  case True with P and xA show ?thesis
3.889 +    by (simp add: finite_ginf_ggreatest)
3.890 +next
3.891 +  case False with P and xA show ?thesis
3.892 +    by (simp add: ginf_insertI finite_ginf_ggreatest)
3.893 +qed
3.894 +
3.895 +lemma (in glower_semilattice) finite_ginf_closed [simp]:
3.896 +  "[| finite A; A \<subseteq> carrier L; A ~= {} |] ==> \<Sqinter>A \<in> carrier L"
3.897 +proof (induct set: finite)
3.898 +  case empty then show ?case by simp
3.899 +next
3.900 +  case insert then show ?case
3.901 +    by (rule_tac finite_ginf_insertI) (simp_all)
3.902 +qed
3.903 +
3.904 +lemma (in glower_semilattice) gmeet_left:
3.905 +  "[| x \<in> carrier L; y \<in> carrier L |] ==> x \<sqinter> y \<sqsubseteq> x"
3.906 +  by (rule gmeetI [folded gmeet_def]) (blast dest: ggreatest_mem)
3.907 +
3.908 +lemma (in glower_semilattice) gmeet_right:
3.909 +  "[| x \<in> carrier L; y \<in> carrier L |] ==> x \<sqinter> y \<sqsubseteq> y"
3.910 +  by (rule gmeetI [folded gmeet_def]) (blast dest: ggreatest_mem)
3.911 +
3.912 +lemma (in glower_semilattice) ginf_of_two_ggreatest:
3.913 +  "[| x \<in> carrier L; y \<in> carrier L |] ==>
3.914 +  ggreatest L (\<Sqinter> {x, y}) (Lower L {x, y})"
3.915 +proof (unfold ginf_def)
3.916 +  assume L: "x \<in> carrier L"  "y \<in> carrier L"
3.917 +  with ginf_of_two_exists obtain s where "ggreatest L s (Lower L {x, y})" by fast
3.918 +  with L
3.919 +  show "ggreatest L (SOME z. ggreatest L z (Lower L {x, y})) (Lower L {x, y})"
3.920 +  by (fast intro: someI2 ggreatest_unique)  (* blast fails *)
3.921 +qed
3.922 +
3.923 +lemma (in glower_semilattice) gmeet_le:
3.924 +  assumes sub: "z \<sqsubseteq> x"  "z \<sqsubseteq> y"
3.925 +    and x: "x \<in> carrier L" and y: "y \<in> carrier L" and z: "z \<in> carrier L"
3.926 +  shows "z \<sqsubseteq> x \<sqinter> y"
3.927 +proof (rule gmeetI [OF _ x y])
3.928 +  fix i
3.929 +  assume "ggreatest L i (Lower L {x, y})"
3.930 +  with sub z show "z \<sqsubseteq> i" by (fast elim: ggreatest_le intro: Lower_memI)
3.931 +qed
3.932 +
3.933 +lemma (in glower_semilattice) gmeet_assoc_lemma:
3.934 +  assumes L: "x \<in> carrier L"  "y \<in> carrier L"  "z \<in> carrier L"
3.935 +  shows "x \<sqinter> (y \<sqinter> z) .= \<Sqinter>{x, y, z}"
3.936 +proof (rule finite_ginf_insertI)
3.937 +  txt {* The textbook argument in Jacobson I, p 457 *}
3.938 +  fix i
3.939 +  assume ginf: "ggreatest L i (Lower L {x, y, z})"
3.940 +  show "x \<sqinter> (y \<sqinter> z) .= i"
3.941 +  proof (rule le_anti_sym)
3.942 +    from ginf L show "i \<sqsubseteq> x \<sqinter> (y \<sqinter> z)"
3.943 +      by (fastsimp intro!: gmeet_le elim: ggreatest_Lower_below)
3.944 +  next
3.945 +    from ginf L show "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> i"
3.946 +    by (erule_tac ggreatest_le)
3.947 +      (blast intro!: Lower_memI intro: le_trans gmeet_left gmeet_right gmeet_closed)
3.948 +  qed (simp_all add: L ggreatest_closed [OF ginf])
3.950 +
3.951 +lemma gmeet_comm:
3.952 +  fixes L (structure)
3.953 +  shows "x \<sqinter> y = y \<sqinter> x"
3.954 +  by (unfold gmeet_def) (simp add: insert_commute)
3.955 +
3.956 +lemma (in glower_semilattice) gmeet_assoc:
3.957 +  assumes L: "x \<in> carrier L"  "y \<in> carrier L"  "z \<in> carrier L"
3.958 +  shows "(x \<sqinter> y) \<sqinter> z .= x \<sqinter> (y \<sqinter> z)"
3.959 +proof -
3.960 +  (* FIXME: improved simp, see gjoin_assoc above *)
3.961 +  have "(x \<sqinter> y) \<sqinter> z = z \<sqinter> (x \<sqinter> y)" by (simp only: gmeet_comm)
3.962 +  also from L have "... .= \<Sqinter> {z, x, y}" by (simp add: gmeet_assoc_lemma)
3.963 +  also from L have "... = \<Sqinter> {x, y, z}" by (simp add: insert_commute)
3.964 +  also from L have "... .= x \<sqinter> (y \<sqinter> z)" by (simp add: gmeet_assoc_lemma [symmetric])
3.965 +  finally show ?thesis by (simp add: L)
3.966 +qed
3.967 +
3.968 +
3.969 +subsection {* Total Orders *}
3.970 +
3.971 +locale gtotal_order = gpartial_order +
3.972 +  assumes total: "[| x \<in> carrier L; y \<in> carrier L |] ==> x \<sqsubseteq> y | y \<sqsubseteq> x"
3.973 +
3.974 +text {* Introduction rule: the usual definition of total order *}
3.975 +
3.976 +lemma (in gpartial_order) gtotal_orderI:
3.977 +  assumes total: "!!x y. [| x \<in> carrier L; y \<in> carrier L |] ==> x \<sqsubseteq> y | y \<sqsubseteq> x"
3.978 +  shows "gtotal_order L"
3.979 +  by unfold_locales (rule total)
3.980 +
3.981 +text {* Total orders are lattices. *}
3.982 +
3.983 +interpretation gtotal_order < glattice
3.984 +proof unfold_locales
3.985 +  fix x y
3.986 +  assume L: "x \<in> carrier L"  "y \<in> carrier L"
3.987 +  show "EX s. gleast L s (Upper L {x, y})"
3.988 +  proof -
3.989 +    note total L
3.990 +    moreover
3.991 +    {
3.992 +      assume "x \<sqsubseteq> y"
3.993 +      with L have "gleast L y (Upper L {x, y})"
3.994 +        by (rule_tac gleast_UpperI) auto
3.995 +    }
3.996 +    moreover
3.997 +    {
3.998 +      assume "y \<sqsubseteq> x"
3.999 +      with L have "gleast L x (Upper L {x, y})"
3.1000 +        by (rule_tac gleast_UpperI) auto
3.1001 +    }
3.1002 +    ultimately show ?thesis by blast
3.1003 +  qed
3.1004 +next
3.1005 +  fix x y
3.1006 +  assume L: "x \<in> carrier L"  "y \<in> carrier L"
3.1007 +  show "EX i. ggreatest L i (Lower L {x, y})"
3.1008 +  proof -
3.1009 +    note total L
3.1010 +    moreover
3.1011 +    {
3.1012 +      assume "y \<sqsubseteq> x"
3.1013 +      with L have "ggreatest L y (Lower L {x, y})"
3.1014 +        by (rule_tac ggreatest_LowerI) auto
3.1015 +    }
3.1016 +    moreover
3.1017 +    {
3.1018 +      assume "x \<sqsubseteq> y"
3.1019 +      with L have "ggreatest L x (Lower L {x, y})"
3.1020 +        by (rule_tac ggreatest_LowerI) auto
3.1021 +    }
3.1022 +    ultimately show ?thesis by blast
3.1023 +  qed
3.1024 +qed
3.1025 +
3.1026 +
3.1027 +subsection {* Complete lattices *}
3.1028 +
3.1029 +locale complete_lattice = glattice +
3.1030 +  assumes gsup_exists:
3.1031 +    "[| A \<subseteq> carrier L |] ==> EX s. gleast L s (Upper L A)"
3.1032 +    and ginf_exists:
3.1033 +    "[| A \<subseteq> carrier L |] ==> EX i. ggreatest L i (Lower L A)"
3.1034 +
3.1035 +text {* Introduction rule: the usual definition of complete lattice *}
3.1036 +
3.1037 +lemma (in gpartial_order) complete_latticeI:
3.1038 +  assumes gsup_exists:
3.1039 +    "!!A. [| A \<subseteq> carrier L |] ==> EX s. gleast L s (Upper L A)"
3.1040 +    and ginf_exists:
3.1041 +    "!!A. [| A \<subseteq> carrier L |] ==> EX i. ggreatest L i (Lower L A)"
3.1042 +  shows "complete_lattice L"
3.1043 +  by unfold_locales (auto intro: gsup_exists ginf_exists)
3.1044 +
3.1045 +constdefs (structure L)
3.1046 +  top :: "_ => 'a" ("\<top>\<index>")
3.1047 +  "\<top> == gsup L (carrier L)"
3.1048 +
3.1049 +  bottom :: "_ => 'a" ("\<bottom>\<index>")
3.1050 +  "\<bottom> == ginf L (carrier L)"
3.1051 +
3.1052 +
3.1053 +lemma (in complete_lattice) gsupI:
3.1054 +  "[| !!l. gleast L l (Upper L A) ==> P l; A \<subseteq> carrier L |]
3.1055 +  ==> P (\<Squnion>A)"
3.1056 +proof (unfold gsup_def)
3.1057 +  assume L: "A \<subseteq> carrier L"
3.1058 +    and P: "!!l. gleast L l (Upper L A) ==> P l"
3.1059 +  with gsup_exists obtain s where "gleast L s (Upper L A)" by blast
3.1060 +  with L show "P (SOME l. gleast L l (Upper L A))"
3.1061 +  by (fast intro: someI2 gleast_unique P)
3.1062 +qed
3.1063 +
3.1064 +lemma (in complete_lattice) gsup_closed [simp]:
3.1065 +  "A \<subseteq> carrier L ==> \<Squnion>A \<in> carrier L"
3.1066 +  by (rule gsupI) simp_all
3.1067 +
3.1068 +lemma (in complete_lattice) top_closed [simp, intro]:
3.1069 +  "\<top> \<in> carrier L"
3.1070 +  by (unfold top_def) simp
3.1071 +
3.1072 +lemma (in complete_lattice) ginfI:
3.1073 +  "[| !!i. ggreatest L i (Lower L A) ==> P i; A \<subseteq> carrier L |]
3.1074 +  ==> P (\<Sqinter>A)"
3.1075 +proof (unfold ginf_def)
3.1076 +  assume L: "A \<subseteq> carrier L"
3.1077 +    and P: "!!l. ggreatest L l (Lower L A) ==> P l"
3.1078 +  with ginf_exists obtain s where "ggreatest L s (Lower L A)" by blast
3.1079 +  with L show "P (SOME l. ggreatest L l (Lower L A))"
3.1080 +  by (fast intro: someI2 ggreatest_unique P)
3.1081 +qed
3.1082 +
3.1083 +lemma (in complete_lattice) ginf_closed [simp]:
3.1084 +  "A \<subseteq> carrier L ==> \<Sqinter>A \<in> carrier L"
3.1085 +  by (rule ginfI) simp_all
3.1086 +
3.1087 +lemma (in complete_lattice) bottom_closed [simp, intro]:
3.1088 +  "\<bottom> \<in> carrier L"
3.1089 +  by (unfold bottom_def) simp
3.1090 +
3.1091 +text {* Jacobson: Theorem 8.1 *}
3.1092 +
3.1093 +lemma Lower_empty [simp]:
3.1094 +  "Lower L {} = carrier L"
3.1095 +  by (unfold Lower_def) simp
3.1096 +
3.1097 +lemma Upper_empty [simp]:
3.1098 +  "Upper L {} = carrier L"
3.1099 +  by (unfold Upper_def) simp
3.1100 +
3.1101 +theorem (in gpartial_order) complete_lattice_criterion1:
3.1102 +  assumes top_exists: "EX g. ggreatest L g (carrier L)"
3.1103 +    and ginf_exists:
3.1104 +      "!!A. [| A \<subseteq> carrier L; A ~= {} |] ==> EX i. ggreatest L i (Lower L A)"
3.1105 +  shows "complete_lattice L"
3.1106 +proof (rule complete_latticeI)
3.1107 +  from top_exists obtain top where top: "ggreatest L top (carrier L)" ..
3.1108 +  fix A
3.1109 +  assume L: "A \<subseteq> carrier L"
3.1110 +  let ?B = "Upper L A"
3.1111 +  from L top have "top \<in> ?B" by (fast intro!: Upper_memI intro: ggreatest_le)
3.1112 +  then have B_non_empty: "?B ~= {}" by fast
3.1113 +  have B_L: "?B \<subseteq> carrier L" by simp
3.1114 +  from ginf_exists [OF B_L B_non_empty]
3.1115 +  obtain b where b_ginf_B: "ggreatest L b (Lower L ?B)" ..
3.1116 +  have "gleast L b (Upper L A)"
3.1117 +apply (rule gleast_UpperI)
3.1118 +   apply (rule ggreatest_le [where A = "Lower L ?B"])
3.1119 +    apply (rule b_ginf_B)
3.1120 +   apply (rule Lower_memI)
3.1121 +    apply (erule Upper_memD [THEN conjunct1])
3.1122 +     apply assumption
3.1123 +    apply (rule L)
3.1124 +   apply (fast intro: L [THEN subsetD])
3.1125 +  apply (erule ggreatest_Lower_below [OF b_ginf_B])
3.1126 +  apply simp
3.1127 + apply (rule L)
3.1128 +apply (rule ggreatest_closed [OF b_ginf_B])
3.1129 +done
3.1130 +  then show "EX s. gleast L s (Upper L A)" ..
3.1131 +next
3.1132 +  fix A
3.1133 +  assume L: "A \<subseteq> carrier L"
3.1134 +  show "EX i. ggreatest L i (Lower L A)"
3.1135 +  proof (cases "A = {}")
3.1136 +    case True then show ?thesis
3.1137 +      by (simp add: top_exists)
3.1138 +  next
3.1139 +    case False with L show ?thesis
3.1140 +      by (rule ginf_exists)
3.1141 +  qed
3.1142 +qed
3.1143 +
3.1144 +(* TODO: prove dual version *)
3.1145 +
3.1146 +
3.1147 +subsection {* Examples *}
3.1148 +
3.1149 +(* Not so useful for the generalised version.
3.1150 +
3.1151 +subsubsection {* Powerset of a Set is a Complete Lattice *}
3.1152 +
3.1153 +theorem powerset_is_complete_lattice:
3.1154 +  "complete_lattice (| carrier = Pow A, le = op \<subseteq> |)"
3.1155 +  (is "complete_lattice ?L")
3.1156 +proof (rule gpartial_order.complete_latticeI)
3.1157 +  show "gpartial_order ?L"
3.1158 +    by (rule gpartial_order.intro) auto
3.1159 +next
3.1160 +  fix B
3.1161 +  assume B: "B \<subseteq> carrier ?L"
3.1162 +  show "EX s. gleast ?L s (Upper ?L B)"
3.1163 +  proof
3.1164 +    from B show "gleast ?L (\<Union> B) (Upper ?L B)"
3.1165 +      by (fastsimp intro!: gleast_UpperI simp: Upper_def)
3.1166 +  qed
3.1167 +next
3.1168 +  fix B
3.1169 +  assume B: "B \<subseteq> carrier ?L"
3.1170 +  show "EX i. ggreatest ?L i (Lower ?L B)"
3.1171 +  proof
3.1172 +    from B show "ggreatest ?L (\<Inter> B \<inter> A) (Lower ?L B)"
3.1173 +      txt {* @{term "\<Inter> B"} is not the infimum of @{term B}:
3.1174 +	@{term "\<Inter> {} = UNIV"} which is in general bigger than @{term "A"}! *}
3.1175 +      by (fastsimp intro!: ggreatest_LowerI simp: Lower_def)
3.1176 +  qed
3.1177 +qed
3.1178 +
3.1179 +text {* An other example, that of the lattice of subgroups of a group,
3.1180 +  can be found in Group theory (Section~\ref{sec:subgroup-lattice}). *}
3.1181 +
3.1182 +*)
3.1183 +
3.1184 +end