|
1 (* Title: HOL/Library/Complemented_Lattices.thy |
|
2 Authors: Jose Manuel Rodriguez Caballero, Dominique Unruh |
|
3 *) |
|
4 |
|
5 section \<open>Complemented Lattices\<close> |
|
6 |
|
7 theory Complemented_Lattices |
|
8 imports Main |
|
9 begin |
|
10 |
|
11 text \<open>The following class \<open>complemented_lattice\<close> describes complemented lattices (with |
|
12 \<^const>\<open>uminus\<close> for the complement). The definition follows |
|
13 \<^url>\<open>https://en.wikipedia.org/wiki/Complemented_lattice#Definition_and_basic_properties\<close>. |
|
14 Additionally, it adopts the convention from \<^class>\<open>boolean_algebra\<close> of defining |
|
15 \<^const>\<open>minus\<close> in terms of the complement.\<close> |
|
16 |
|
17 class complemented_lattice = bounded_lattice + uminus + minus |
|
18 opening lattice_syntax + |
|
19 assumes inf_compl_bot [simp]: \<open>x \<sqinter> - x = \<bottom>\<close> |
|
20 and sup_compl_top [simp]: \<open>x \<squnion> - x = \<top>\<close> |
|
21 and diff_eq: \<open>x - y = x \<sqinter> - y\<close> |
|
22 begin |
|
23 |
|
24 lemma dual_complemented_lattice: |
|
25 "class.complemented_lattice (\<lambda>x y. x \<squnion> (- y)) uminus (\<squnion>) (\<lambda>x y. y \<le> x) (\<lambda>x y. y < x) (\<sqinter>) \<top> \<bottom>" |
|
26 proof (rule class.complemented_lattice.intro) |
|
27 show "class.bounded_lattice (\<squnion>) (\<lambda>x y. y \<le> x) (\<lambda>x y. y < x) (\<sqinter>) \<top> \<bottom>" |
|
28 by (rule dual_bounded_lattice) |
|
29 show "class.complemented_lattice_axioms (\<lambda>x y. x \<squnion> - y) uminus (\<squnion>) (\<sqinter>) \<top> \<bottom>" |
|
30 by (unfold_locales, auto simp add: diff_eq) |
|
31 qed |
|
32 |
|
33 lemma compl_inf_bot [simp]: \<open>- x \<sqinter> x = \<bottom>\<close> |
|
34 by (simp add: inf_commute) |
|
35 |
|
36 lemma compl_sup_top [simp]: \<open>- x \<squnion> x = \<top>\<close> |
|
37 by (simp add: sup_commute) |
|
38 |
|
39 end |
|
40 |
|
41 class complete_complemented_lattice = complemented_lattice + complete_lattice |
|
42 |
|
43 text \<open>The following class \<open>complemented_lattice\<close> describes orthocomplemented lattices, |
|
44 following \<^url>\<open>https://en.wikipedia.org/wiki/Complemented_lattice#Orthocomplementation\<close>.\<close> |
|
45 class orthocomplemented_lattice = complemented_lattice |
|
46 opening lattice_syntax + |
|
47 assumes ortho_involution [simp]: "- (- x) = x" |
|
48 and ortho_antimono: "x \<le> y \<Longrightarrow> - x \<ge> - y" begin |
|
49 |
|
50 lemma dual_orthocomplemented_lattice: |
|
51 "class.orthocomplemented_lattice (\<lambda>x y. x \<squnion> - y) uminus (\<squnion>) (\<lambda>x y. y \<le> x) (\<lambda>x y. y < x) (\<sqinter>) \<top> \<bottom>" |
|
52 proof (rule class.orthocomplemented_lattice.intro) |
|
53 show "class.complemented_lattice (\<lambda>x y. x \<squnion> - y) uminus (\<squnion>) (\<lambda>x y. y \<le> x) (\<lambda>x y. y < x) (\<sqinter>) \<top> \<bottom>" |
|
54 by (rule dual_complemented_lattice) |
|
55 show "class.orthocomplemented_lattice_axioms uminus (\<lambda>x y. y \<le> x)" |
|
56 by (unfold_locales, auto simp add: diff_eq intro: ortho_antimono) |
|
57 qed |
|
58 |
|
59 lemma compl_eq_compl_iff [simp]: \<open>- x = - y \<longleftrightarrow> x = y\<close> (is \<open>?P \<longleftrightarrow> ?Q\<close>) |
|
60 proof |
|
61 assume ?P |
|
62 then have \<open>- (- x) = - (- y)\<close> |
|
63 by simp |
|
64 then show ?Q |
|
65 by simp |
|
66 next |
|
67 assume ?Q |
|
68 then show ?P |
|
69 by simp |
|
70 qed |
|
71 |
|
72 lemma compl_bot_eq [simp]: \<open>- \<bottom> = \<top>\<close> |
|
73 proof - |
|
74 have \<open>- \<bottom> = - (\<top> \<sqinter> - \<top>)\<close> |
|
75 by simp |
|
76 also have \<open>\<dots> = \<top>\<close> |
|
77 by (simp only: inf_top_left) simp |
|
78 finally show ?thesis . |
|
79 qed |
|
80 |
|
81 lemma compl_top_eq [simp]: "- \<top> = \<bottom>" |
|
82 using compl_bot_eq ortho_involution by blast |
|
83 |
|
84 text \<open>De Morgan's law\<close> \<comment> \<open>Proof from \<^url>\<open>https://planetmath.org/orthocomplementedlattice\<close>\<close> |
|
85 lemma compl_sup [simp]: "- (x \<squnion> y) = - x \<sqinter> - y" |
|
86 proof - |
|
87 have "- (x \<squnion> y) \<le> - x" |
|
88 by (simp add: ortho_antimono) |
|
89 moreover have "- (x \<squnion> y) \<le> - y" |
|
90 by (simp add: ortho_antimono) |
|
91 ultimately have 1: "- (x \<squnion> y) \<le> - x \<sqinter> - y" |
|
92 by (simp add: sup.coboundedI1) |
|
93 have \<open>x \<le> - (-x \<sqinter> -y)\<close> |
|
94 by (metis inf.cobounded1 ortho_antimono ortho_involution) |
|
95 moreover have \<open>y \<le> - (-x \<sqinter> -y)\<close> |
|
96 by (metis inf.cobounded2 ortho_antimono ortho_involution) |
|
97 ultimately have \<open>x \<squnion> y \<le> - (-x \<sqinter> -y)\<close> |
|
98 by auto |
|
99 hence 2: \<open>-x \<sqinter> -y \<le> - (x \<squnion> y)\<close> |
|
100 using ortho_antimono by fastforce |
|
101 from 1 2 show ?thesis |
|
102 using dual_order.antisym by blast |
|
103 qed |
|
104 |
|
105 text \<open>De Morgan's law\<close> |
|
106 lemma compl_inf [simp]: "- (x \<sqinter> y) = - x \<squnion> - y" |
|
107 using compl_sup |
|
108 by (metis ortho_involution) |
|
109 |
|
110 lemma compl_mono: |
|
111 assumes "x \<le> y" |
|
112 shows "- y \<le> - x" |
|
113 by (simp add: assms local.ortho_antimono) |
|
114 |
|
115 lemma compl_le_compl_iff [simp]: "- x \<le> - y \<longleftrightarrow> y \<le> x" |
|
116 by (auto dest: compl_mono) |
|
117 |
|
118 lemma compl_le_swap1: |
|
119 assumes "y \<le> - x" |
|
120 shows "x \<le> -y" |
|
121 using assms ortho_antimono by fastforce |
|
122 |
|
123 lemma compl_le_swap2: |
|
124 assumes "- y \<le> x" |
|
125 shows "- x \<le> y" |
|
126 using assms local.ortho_antimono by fastforce |
|
127 |
|
128 lemma compl_less_compl_iff[simp]: "- x < - y \<longleftrightarrow> y < x" |
|
129 by (auto simp add: less_le) |
|
130 |
|
131 lemma compl_less_swap1: |
|
132 assumes "y < - x" |
|
133 shows "x < - y" |
|
134 using assms compl_less_compl_iff by fastforce |
|
135 |
|
136 lemma compl_less_swap2: |
|
137 assumes "- y < x" |
|
138 shows "- x < y" |
|
139 using assms compl_le_swap1 compl_le_swap2 less_le_not_le by auto |
|
140 |
|
141 lemma sup_cancel_left1: \<open>x \<squnion> a \<squnion> (- x \<squnion> b) = \<top>\<close> |
|
142 by (simp add: sup_commute sup_left_commute) |
|
143 |
|
144 lemma sup_cancel_left2: \<open>- x \<squnion> a \<squnion> (x \<squnion> b) = \<top>\<close> |
|
145 by (simp add: sup.commute sup_left_commute) |
|
146 |
|
147 lemma inf_cancel_left1: \<open>x \<sqinter> a \<sqinter> (- x \<sqinter> b) = \<bottom>\<close> |
|
148 by (simp add: inf.left_commute inf_commute) |
|
149 |
|
150 lemma inf_cancel_left2: \<open>- x \<sqinter> a \<sqinter> (x \<sqinter> b) = \<bottom>\<close> |
|
151 using inf.left_commute inf_commute by auto |
|
152 |
|
153 lemma sup_compl_top_left1 [simp]: \<open>- x \<squnion> (x \<squnion> y) = \<top>\<close> |
|
154 by (simp add: sup_assoc[symmetric]) |
|
155 |
|
156 lemma sup_compl_top_left2 [simp]: \<open>x \<squnion> (- x \<squnion> y) = \<top>\<close> |
|
157 using sup_compl_top_left1[of "- x" y] by simp |
|
158 |
|
159 lemma inf_compl_bot_left1 [simp]: \<open>- x \<sqinter> (x \<sqinter> y) = \<bottom>\<close> |
|
160 by (simp add: inf_assoc[symmetric]) |
|
161 |
|
162 lemma inf_compl_bot_left2 [simp]: \<open>x \<sqinter> (- x \<sqinter> y) = \<bottom>\<close> |
|
163 using inf_compl_bot_left1[of "- x" y] by simp |
|
164 |
|
165 lemma inf_compl_bot_right [simp]: \<open>x \<sqinter> (y \<sqinter> - x) = \<bottom>\<close> |
|
166 by (subst inf_left_commute) simp |
|
167 |
|
168 end |
|
169 |
|
170 class complete_orthocomplemented_lattice = orthocomplemented_lattice + complete_lattice |
|
171 begin |
|
172 |
|
173 subclass complete_complemented_lattice .. |
|
174 |
|
175 end |
|
176 |
|
177 text \<open>The following class \<open>orthomodular_lattice\<close> describes orthomodular lattices, |
|
178 following \<^url>\<open>https://en.wikipedia.org/wiki/Complemented_lattice#Orthomodular_lattices\<close>.\<close> |
|
179 class orthomodular_lattice = orthocomplemented_lattice |
|
180 opening lattice_syntax + |
|
181 assumes orthomodular: "x \<le> y \<Longrightarrow> x \<squnion> (- x) \<sqinter> y = y" begin |
|
182 |
|
183 lemma dual_orthomodular_lattice: |
|
184 "class.orthomodular_lattice (\<lambda>x y. x \<squnion> - y) uminus (\<squnion>) (\<lambda>x y. y \<le> x) (\<lambda>x y. y < x) (\<sqinter>) \<top> \<bottom>" |
|
185 proof (rule class.orthomodular_lattice.intro) |
|
186 show "class.orthocomplemented_lattice (\<lambda>x y. x \<squnion> - y) uminus (\<squnion>) (\<lambda>x y. y \<le> x) (\<lambda>x y. y < x) (\<sqinter>) \<top> \<bottom>" |
|
187 by (rule dual_orthocomplemented_lattice) |
|
188 show "class.orthomodular_lattice_axioms uminus (\<squnion>) (\<lambda>x y. y \<le> x) (\<sqinter>)" |
|
189 proof (unfold_locales) |
|
190 show "(x::'a) \<sqinter> (- x \<squnion> y) = y" |
|
191 if "(y::'a) \<le> x" |
|
192 for x :: 'a |
|
193 and y :: 'a |
|
194 using that local.compl_eq_compl_iff local.ortho_antimono local.orthomodular by fastforce |
|
195 qed |
|
196 |
|
197 qed |
|
198 |
|
199 end |
|
200 |
|
201 class complete_orthomodular_lattice = orthomodular_lattice + complete_lattice |
|
202 begin |
|
203 |
|
204 subclass complete_orthocomplemented_lattice .. |
|
205 |
|
206 end |
|
207 |
|
208 context boolean_algebra |
|
209 opening lattice_syntax |
|
210 begin |
|
211 |
|
212 subclass orthomodular_lattice |
|
213 proof |
|
214 fix x y |
|
215 show \<open>x \<squnion> - x \<sqinter> y = y\<close> |
|
216 if \<open>x \<le> y\<close> |
|
217 using that |
|
218 by (simp add: sup.absorb_iff2 sup_inf_distrib1) |
|
219 show \<open>x - y = x \<sqinter> - y\<close> |
|
220 by (simp add: diff_eq) |
|
221 qed auto |
|
222 |
|
223 end |
|
224 |
|
225 context complete_boolean_algebra |
|
226 begin |
|
227 |
|
228 subclass complete_orthomodular_lattice .. |
|
229 |
|
230 end |
|
231 |
|
232 lemma image_of_maximum: |
|
233 fixes f::"'a::order \<Rightarrow> 'b::conditionally_complete_lattice" |
|
234 assumes "mono f" |
|
235 and "\<And>x. x:M \<Longrightarrow> x\<le>m" |
|
236 and "m:M" |
|
237 shows "(SUP x\<in>M. f x) = f m" |
|
238 by (smt (verit, ccfv_threshold) assms(1) assms(2) assms(3) cSup_eq_maximum imageE imageI monoD) |
|
239 |
|
240 lemma cSup_eq_cSup: |
|
241 fixes A B :: \<open>'a::conditionally_complete_lattice set\<close> |
|
242 assumes bdd: \<open>bdd_above A\<close> |
|
243 assumes B: \<open>\<And>a. a\<in>A \<Longrightarrow> \<exists>b\<in>B. b \<ge> a\<close> |
|
244 assumes A: \<open>\<And>b. b\<in>B \<Longrightarrow> \<exists>a\<in>A. a \<ge> b\<close> |
|
245 shows \<open>Sup A = Sup B\<close> |
|
246 proof (cases \<open>B = {}\<close>) |
|
247 case True |
|
248 with A B have \<open>A = {}\<close> |
|
249 by auto |
|
250 with True show ?thesis by simp |
|
251 next |
|
252 case False |
|
253 have \<open>bdd_above B\<close> |
|
254 by (meson A bdd bdd_above_def order_trans) |
|
255 have \<open>A \<noteq> {}\<close> |
|
256 using A False by blast |
|
257 moreover have \<open>a \<le> Sup B\<close> if \<open>a \<in> A\<close> for a |
|
258 proof - |
|
259 obtain b where \<open>b \<in> B\<close> and \<open>b \<ge> a\<close> |
|
260 using B \<open>a \<in> A\<close> by auto |
|
261 then show ?thesis |
|
262 apply (rule cSup_upper2) |
|
263 using \<open>bdd_above B\<close> by simp |
|
264 qed |
|
265 moreover have \<open>Sup B \<le> c\<close> if \<open>\<And>a. a \<in> A \<Longrightarrow> a \<le> c\<close> for c |
|
266 using False apply (rule cSup_least) |
|
267 using A that by fastforce |
|
268 ultimately show ?thesis |
|
269 by (rule cSup_eq_non_empty) |
|
270 qed |
|
271 |
|
272 end |