New theory on divisibility.
authorballarin
Tue Jul 29 16:19:49 2008 +0200 (2008-07-29)
changeset 27701ed7a2e0fab59
parent 27700 ef4b26efa8b6
child 27702 80608e96e760
New theory on divisibility.
src/HOL/Algebra/Congruence.thy
src/HOL/Algebra/Divisibility.thy
src/HOL/Algebra/GLattice.thy
     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.8 +  Copyright: Clemens Ballarin
     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.8 +  Copyright: Clemens Ballarin
     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.327 +by (simp add: associated_def)
   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.1361 +by (simp add: e)
  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.1470 +apply (simp add: multlist_perm_cong[symmetric])
  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.1761 +by (simp add: mult_cong_r)
  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.1772 +apply (simp add: m_assoc)
  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.1991 +by (simp add: eqc_listassoc_cong)
  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.3075 +apply (simp add: somegcd_def)
  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.3662 +apply (simp add: assms)
  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.3681 +apply (simp add: perm_length)
  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.8 +  Copyright: Clemens Ballarin
     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.708 +qed (simp_all add: L)
   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.949 +qed (simp_all add: L)
   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