proper theory for type of dual ordered lattice in distribution
authorhaftmann
Thu Mar 14 09:46:09 2019 +0100 (3 months ago ago)
changeset 700905382f5691a11
parent 70089 1bd74a0944b3
child 70091 6d768e0eeaaf
child 70092 0c0f7b4a72bf
proper theory for type of dual ordered lattice in distribution
src/HOL/Library/Dual_Ordered_Lattice.thy
src/HOL/Library/Library.thy
     1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/src/HOL/Library/Dual_Ordered_Lattice.thy	Thu Mar 14 09:46:09 2019 +0100
     1.3 @@ -0,0 +1,391 @@
     1.4 +(*  Title:      Dual_Ordered_Lattice.thy
     1.5 +    Authors:    Makarius; Peter Gammie; Brian Huffman; Florian Haftmann, TU Muenchen
     1.6 +*)
     1.7 +
     1.8 +section \<open>Type of dual ordered lattices\<close>
     1.9 +
    1.10 +theory Dual_Ordered_Lattice
    1.11 +imports Main
    1.12 +begin
    1.13 +
    1.14 +text \<open>
    1.15 +  The \<^emph>\<open>dual\<close> of an ordered structure is an isomorphic copy of the
    1.16 +  underlying type, with the \<open>\<le>\<close> relation defined as the inverse
    1.17 +  of the original one.
    1.18 +
    1.19 +  The class of lattices is closed under formation of dual structures.
    1.20 +  This means that for any theorem of lattice theory, the dualized
    1.21 +  statement holds as well; this important fact simplifies many proofs
    1.22 +  of lattice theory.
    1.23 +\<close>
    1.24 +
    1.25 +typedef 'a dual = "UNIV :: 'a set"
    1.26 +  morphisms undual dual ..
    1.27 +
    1.28 +setup_lifting type_definition_dual
    1.29 +
    1.30 +lemma dual_eqI:
    1.31 +  "x = y" if "undual x = undual y"
    1.32 +  using that by transfer assumption
    1.33 +
    1.34 +lemma dual_eq_iff:
    1.35 +  "x = y \<longleftrightarrow> undual x = undual y"
    1.36 +  by transfer simp
    1.37 +
    1.38 +lemma eq_dual_iff [iff]:
    1.39 +  "dual x = dual y \<longleftrightarrow> x = y"
    1.40 +  by transfer simp
    1.41 +
    1.42 +lemma undual_dual [simp]:
    1.43 +  "undual (dual x) = x"
    1.44 +  by transfer rule
    1.45 +
    1.46 +lemma dual_undual [simp]:
    1.47 +  "dual (undual x) = x"
    1.48 +  by transfer rule
    1.49 +
    1.50 +lemma undual_comp_dual [simp]:
    1.51 +  "undual \<circ> dual = id"
    1.52 +  by (simp add: fun_eq_iff)
    1.53 +
    1.54 +lemma dual_comp_undual [simp]:
    1.55 +  "dual \<circ> undual = id"
    1.56 +  by (simp add: fun_eq_iff)
    1.57 +
    1.58 +lemma inj_dual:
    1.59 +  "inj dual"
    1.60 +  by (rule injI) simp
    1.61 +
    1.62 +lemma inj_undual:
    1.63 +  "inj undual"
    1.64 +  by (rule injI) (rule dual_eqI)
    1.65 +
    1.66 +lemma surj_dual:
    1.67 +  "surj dual"
    1.68 +  by (rule surjI [of _ undual]) simp
    1.69 +
    1.70 +lemma surj_undual:
    1.71 +  "surj undual"
    1.72 +  by (rule surjI [of _ dual]) simp
    1.73 +
    1.74 +lemma bij_dual:
    1.75 +  "bij dual"
    1.76 +  using inj_dual surj_dual by (rule bijI)
    1.77 +
    1.78 +lemma bij_undual:
    1.79 +  "bij undual"
    1.80 +  using inj_undual surj_undual by (rule bijI)
    1.81 +
    1.82 +instance dual :: (finite) finite
    1.83 +proof
    1.84 +  from finite have "finite (range dual :: 'a dual set)"
    1.85 +    by (rule finite_imageI)
    1.86 +  then show "finite (UNIV :: 'a dual set)"
    1.87 +    by (simp add: surj_dual)
    1.88 +qed
    1.89 +
    1.90 +
    1.91 +subsection \<open>Pointwise ordering\<close>
    1.92 +
    1.93 +instantiation dual :: (ord) ord
    1.94 +begin
    1.95 +
    1.96 +lift_definition less_eq_dual :: "'a dual \<Rightarrow> 'a dual \<Rightarrow> bool"
    1.97 +  is "(\<ge>)" .
    1.98 +
    1.99 +lift_definition less_dual :: "'a dual \<Rightarrow> 'a dual \<Rightarrow> bool"
   1.100 +  is "(>)" .
   1.101 +
   1.102 +instance ..
   1.103 +
   1.104 +end
   1.105 +
   1.106 +lemma dual_less_eqI:
   1.107 +  "x \<le> y" if "undual y \<le> undual x"
   1.108 +  using that by transfer assumption
   1.109 +
   1.110 +lemma dual_less_eq_iff:
   1.111 +  "x \<le> y \<longleftrightarrow> undual y \<le> undual x"
   1.112 +  by transfer simp
   1.113 +
   1.114 +lemma less_eq_dual_iff [iff]:
   1.115 +  "dual x \<le> dual y \<longleftrightarrow> y \<le> x"
   1.116 +  by transfer simp
   1.117 +
   1.118 +lemma dual_lessI:
   1.119 +  "x < y" if "undual y < undual x"
   1.120 +  using that by transfer assumption
   1.121 +
   1.122 +lemma dual_less_iff:
   1.123 +  "x < y \<longleftrightarrow> undual y < undual x"
   1.124 +  by transfer simp
   1.125 +
   1.126 +lemma less_dual_iff [iff]:
   1.127 +  "dual x < dual y \<longleftrightarrow> y < x"
   1.128 +  by transfer simp
   1.129 +
   1.130 +instance dual :: (preorder) preorder
   1.131 +  by (standard; transfer) (auto simp add: less_le_not_le intro: order_trans)
   1.132 +
   1.133 +instance dual :: (order) order
   1.134 +  by (standard; transfer) simp
   1.135 +
   1.136 +
   1.137 +subsection \<open>Binary infimum and supremum\<close>
   1.138 +
   1.139 +instantiation dual :: (sup) inf
   1.140 +begin
   1.141 +
   1.142 +lift_definition inf_dual :: "'a dual \<Rightarrow> 'a dual \<Rightarrow> 'a dual"
   1.143 +  is sup .
   1.144 +
   1.145 +instance ..
   1.146 +
   1.147 +end
   1.148 +
   1.149 +lemma undual_inf_eq [simp]:
   1.150 +  "undual (inf x y) = sup (undual x) (undual y)"
   1.151 +  by (fact inf_dual.rep_eq)
   1.152 +
   1.153 +lemma dual_sup_eq [simp]:
   1.154 +  "dual (sup x y) = inf (dual x) (dual y)"
   1.155 +  by transfer rule
   1.156 +
   1.157 +instantiation dual :: (inf) sup
   1.158 +begin
   1.159 +
   1.160 +lift_definition sup_dual :: "'a dual \<Rightarrow> 'a dual \<Rightarrow> 'a dual"
   1.161 +  is inf .
   1.162 +
   1.163 +instance ..
   1.164 +
   1.165 +end
   1.166 +
   1.167 +lemma undual_sup_eq [simp]:
   1.168 +  "undual (sup x y) = inf (undual x) (undual y)"
   1.169 +  by (fact sup_dual.rep_eq)
   1.170 +
   1.171 +lemma dual_inf_eq [simp]:
   1.172 +  "dual (inf x y) = sup (dual x) (dual y)"
   1.173 +  by transfer simp
   1.174 +
   1.175 +instance dual :: (semilattice_sup) semilattice_inf
   1.176 +  by (standard; transfer) simp_all
   1.177 +
   1.178 +instance dual :: (semilattice_inf) semilattice_sup
   1.179 +  by (standard; transfer) simp_all
   1.180 +
   1.181 +instance dual :: (lattice) lattice ..
   1.182 +
   1.183 +instance dual :: (distrib_lattice) distrib_lattice
   1.184 +  by (standard; transfer) (fact inf_sup_distrib1)
   1.185 +
   1.186 +
   1.187 +subsection \<open>Top and bottom elements\<close>
   1.188 +
   1.189 +instantiation dual :: (top) bot
   1.190 +begin
   1.191 +
   1.192 +lift_definition bot_dual :: "'a dual"
   1.193 +  is top .
   1.194 +
   1.195 +instance ..
   1.196 +
   1.197 +end
   1.198 +
   1.199 +lemma undual_bot_eq [simp]:
   1.200 +  "undual bot = top"
   1.201 +  by (fact bot_dual.rep_eq)
   1.202 +
   1.203 +lemma dual_top_eq [simp]:
   1.204 +  "dual top = bot"
   1.205 +  by transfer rule
   1.206 +
   1.207 +instantiation dual :: (bot) top
   1.208 +begin
   1.209 +
   1.210 +lift_definition top_dual :: "'a dual"
   1.211 +  is bot .
   1.212 +
   1.213 +instance ..
   1.214 +
   1.215 +end
   1.216 +
   1.217 +lemma undual_top_eq [simp]:
   1.218 +  "undual top = bot"
   1.219 +  by (fact top_dual.rep_eq)
   1.220 +
   1.221 +lemma dual_bot_eq [simp]:
   1.222 +  "dual bot = top"
   1.223 +  by transfer rule
   1.224 +
   1.225 +instance dual :: (order_top) order_bot
   1.226 +  by (standard; transfer) simp
   1.227 +
   1.228 +instance dual :: (order_bot) order_top
   1.229 +  by (standard; transfer) simp
   1.230 +
   1.231 +instance dual :: (bounded_lattice_top) bounded_lattice_bot ..
   1.232 +
   1.233 +instance dual :: (bounded_lattice_bot) bounded_lattice_top ..
   1.234 +
   1.235 +instance dual :: (bounded_lattice) bounded_lattice ..
   1.236 +
   1.237 +
   1.238 +subsection \<open>Complement\<close>
   1.239 +
   1.240 +instantiation dual :: (uminus) uminus
   1.241 +begin
   1.242 +
   1.243 +lift_definition uminus_dual :: "'a dual \<Rightarrow> 'a dual"
   1.244 +  is uminus .
   1.245 +
   1.246 +instance ..
   1.247 +
   1.248 +end
   1.249 +
   1.250 +lemma undual_uminus_eq [simp]:
   1.251 +  "undual (- x) = - undual x"
   1.252 +  by (fact uminus_dual.rep_eq)
   1.253 +
   1.254 +lemma dual_uminus_eq [simp]:
   1.255 +  "dual (- x) = - dual x"
   1.256 +  by transfer rule
   1.257 +
   1.258 +instantiation dual :: (boolean_algebra) boolean_algebra
   1.259 +begin
   1.260 +
   1.261 +lift_definition minus_dual :: "'a dual \<Rightarrow> 'a dual \<Rightarrow> 'a dual"
   1.262 +  is "\<lambda>x y. - (y - x)" .
   1.263 +
   1.264 +instance
   1.265 +  by (standard; transfer) (simp_all add: diff_eq ac_simps)
   1.266 +
   1.267 +end
   1.268 +
   1.269 +lemma undual_minus_eq [simp]:
   1.270 +  "undual (x - y) = - (undual y - undual x)"
   1.271 +  by (fact minus_dual.rep_eq)
   1.272 +
   1.273 +lemma dual_minus_eq [simp]:
   1.274 +  "dual (x - y) = - (dual y - dual x)"
   1.275 +  by transfer simp
   1.276 +
   1.277 +
   1.278 +subsection \<open>Complete lattice operations\<close>
   1.279 +
   1.280 +text \<open>
   1.281 +  The class of complete lattices is closed under formation of dual
   1.282 +  structures.
   1.283 +\<close>
   1.284 +
   1.285 +instantiation dual :: (Sup) Inf
   1.286 +begin
   1.287 +
   1.288 +lift_definition Inf_dual :: "'a dual set \<Rightarrow> 'a dual"
   1.289 +  is Sup .
   1.290 +
   1.291 +instance ..
   1.292 +
   1.293 +end
   1.294 +
   1.295 +lemma undual_Inf_eq [simp]:
   1.296 +  "undual (Inf A) = Sup (undual ` A)"
   1.297 +  by (fact Inf_dual.rep_eq)
   1.298 +
   1.299 +lemma dual_Sup_eq [simp]:
   1.300 +  "dual (Sup A) = Inf (dual ` A)"
   1.301 +  by transfer simp
   1.302 +
   1.303 +instantiation dual :: (Inf) Sup
   1.304 +begin
   1.305 +
   1.306 +lift_definition Sup_dual :: "'a dual set \<Rightarrow> 'a dual"
   1.307 +  is Inf .
   1.308 +
   1.309 +instance ..
   1.310 +
   1.311 +end
   1.312 +
   1.313 +lemma undual_Sup_eq [simp]:
   1.314 +  "undual (Sup A) = Inf (undual ` A)"
   1.315 +  by (fact Sup_dual.rep_eq)
   1.316 +
   1.317 +lemma dual_Inf_eq [simp]:
   1.318 +  "dual (Inf A) = Sup (dual ` A)"
   1.319 +  by transfer simp
   1.320 +
   1.321 +instance dual :: (complete_lattice) complete_lattice
   1.322 +  by (standard; transfer) (auto intro: Inf_lower Sup_upper Inf_greatest Sup_least)
   1.323 +
   1.324 +context
   1.325 +  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
   1.326 +    and g :: "'a dual \<Rightarrow> 'a dual"
   1.327 +  assumes "mono f"
   1.328 +  defines "g \<equiv> dual \<circ> f \<circ> undual"
   1.329 +begin
   1.330 +
   1.331 +private lemma mono_dual:
   1.332 +  "mono g"
   1.333 +proof
   1.334 +  fix x y :: "'a dual"
   1.335 +  assume "x \<le> y"
   1.336 +  then have "undual y \<le> undual x"
   1.337 +    by (simp add: dual_less_eq_iff)
   1.338 +  with \<open>mono f\<close> have "f (undual y) \<le> f (undual x)"
   1.339 +    by (rule monoD)
   1.340 +  then have "(dual \<circ> f \<circ> undual) x \<le> (dual \<circ> f \<circ> undual) y"
   1.341 +    by simp
   1.342 +  then show "g x \<le> g y"
   1.343 +    by (simp add: g_def)
   1.344 +qed
   1.345 +
   1.346 +lemma lfp_dual_gfp:
   1.347 +  "lfp f = undual (gfp g)" (is "?lhs = ?rhs")
   1.348 +proof (rule antisym)
   1.349 +  have "dual (undual (g (gfp g))) \<le> dual (f (undual (gfp g)))"
   1.350 +    by (simp add: g_def)
   1.351 +  with mono_dual have "f (undual (gfp g)) \<le> undual (gfp g)"
   1.352 +    by (simp add: gfp_unfold [where f = g, symmetric] dual_less_eq_iff)
   1.353 +  then show "?lhs \<le> ?rhs"
   1.354 +    by (rule lfp_lowerbound)
   1.355 +  from \<open>mono f\<close> have "dual (lfp f) \<le> dual (undual (gfp g))"
   1.356 +    by (simp add: lfp_fixpoint gfp_upperbound g_def)
   1.357 +  then show "?rhs \<le> ?lhs"
   1.358 +    by (simp only: less_eq_dual_iff)
   1.359 +qed
   1.360 +
   1.361 +lemma gfp_dual_lfp:
   1.362 +  "gfp f = undual (lfp g)"
   1.363 +proof -
   1.364 +  have "mono (\<lambda>x. undual (undual x))"
   1.365 +    by (rule monoI)  (simp add: dual_less_eq_iff)
   1.366 +  moreover have "mono (\<lambda>a. dual (dual (f a)))"
   1.367 +    using \<open>mono f\<close> by (auto intro: monoI dest: monoD)
   1.368 +  moreover have "gfp f = gfp (\<lambda>x. undual (undual (dual (dual (f x)))))"
   1.369 +    by simp
   1.370 +  ultimately have "undual (undual (gfp (\<lambda>x. dual
   1.371 +    (dual (f (undual (undual x))))))) =
   1.372 +      gfp (\<lambda>x. undual (undual (dual (dual (f x)))))"
   1.373 +    by (subst gfp_rolling [where g = "\<lambda>x. undual (undual x)"]) simp_all
   1.374 +  then have "gfp f =
   1.375 +    undual
   1.376 +     (undual
   1.377 +       (gfp (\<lambda>x. dual (dual (f (undual (undual x)))))))"
   1.378 +    by simp
   1.379 +  also have "\<dots> = undual (undual (gfp (dual \<circ> g \<circ> undual)))"
   1.380 +    by (simp add: comp_def g_def)
   1.381 +  also have "\<dots> = undual (lfp g)"
   1.382 +    using mono_dual by (simp only: Dual_Ordered_Lattice.lfp_dual_gfp)
   1.383 +  finally show ?thesis .
   1.384 +qed
   1.385 +
   1.386 +end
   1.387 +
   1.388 +
   1.389 +text \<open>Finally\<close>
   1.390 +
   1.391 +lifting_update dual.lifting
   1.392 +lifting_forget dual.lifting
   1.393 +
   1.394 +end
     2.1 --- a/src/HOL/Library/Library.thy	Thu Mar 14 09:46:04 2019 +0100
     2.2 +++ b/src/HOL/Library/Library.thy	Thu Mar 14 09:46:09 2019 +0100
     2.3 @@ -23,6 +23,7 @@
     2.4    Discrete
     2.5    Disjoint_Sets
     2.6    Dlist
     2.7 +  Dual_Ordered_Lattice
     2.8    Equipollence
     2.9    Extended
    2.10    Extended_Nat