Theory Stone_Algebras.Lattice_Basics

(* Title:      Lattice Basics
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at>

section ‹Lattice Basics›

text ‹
This theory provides notations, basic definitions and facts of lattice-related structures used throughout the subsequent development.

theory Lattice_Basics

imports Main


subsection ‹General Facts and Notations›

text ‹
The following results extend basic Isabelle/HOL facts.

lemma imp_as_conj:
  assumes "P x  Q x"
  shows "P x  Q x  P x"
  using assms by auto

lemma if_distrib_2:
  "f (if c then x else y) (if c then z else w) = (if c then f x z else f y w)"
  by simp

lemma left_invertible_inj:
  "(x . g (f x) = x)  inj f"
  by (metis injI)

lemma invertible_bij:
  assumes "x . g (f x) = x"
      and "y . f (g y) = y"
    shows "bij f"
  by (metis assms bijI')

lemma finite_ne_subset_induct [consumes 3, case_names singleton insert]:
  assumes "finite F"
      and "F  {}"
      and "F  S"
      and singleton: "x . P {x}"
      and insert: "x F . finite F  F  {}  F  S  x  S  x  F  P F  P (insert x F)"
    shows "P F"
  using assms(1-3)
  apply (induct rule: finite_ne_induct)
  apply (simp add: singleton)
  by (simp add: insert)

lemma finite_set_of_finite_funs_pred:
  assumes "finite { x::'a . True }"
      and "finite { y::'b . P y }"
    shows "finite { f . (x::'a . P (f x)) }"
  using assms finite_set_of_finite_funs by force

text ‹
We use the following notations for the join, meet and complement operations.
Changing the precedence of the unary complement allows us to write terms like --x› instead of -(-x)›.

context sup

notation sup (infixl "" 65)

definition additive :: "('a  'a)  bool"
  where "additive f  x y . f (x  y) = f x  f y"


context inf

notation inf (infixl "" 67)


context uminus

no_notation uminus ("- _" [81] 80)

notation uminus ("- _" [80] 80)


subsection ‹Orders›

text ‹
We use the following definition of monotonicity for operations defined in classes.
The standard mono› places a sort constraint on the target type.
We also give basic properties of Galois connections and lift orders to functions.

context ord

definition isotone :: "('a  'a)  bool"
  where "isotone f  x y . x  y  f x  f y"

definition galois :: "('a  'a)  ('a  'a)  bool"
  where "galois l u  x y . l x  y  x  u y"

definition lifted_less_eq :: "('a  'a)  ('a  'a)  bool" ("(_ ≤≤ _)" [51, 51] 50)
  where "f ≤≤ g  x . f x  g x"


context order

lemma order_lesseq_imp:
  "(z . x  z  y  z)  y  x"
  using order_trans by blast

lemma galois_char:
  "galois l u  (x . x  u (l x))  (x . l (u x)  x)  isotone l  isotone u"
  apply (rule iffI)
  apply (metis (full_types) galois_def isotone_def order_refl order_trans)
  using galois_def isotone_def order_trans by blast

lemma galois_closure:
  "galois l u  l x = l (u (l x))  u x = u (l (u x))"
  by (simp add: galois_char isotone_def order.antisym)

lemma lifted_reflexive:
  "f = g  f ≤≤ g"
  by (simp add: lifted_less_eq_def)

lemma lifted_transitive:
  "f ≤≤ g  g ≤≤ h  f ≤≤ h"
  using lifted_less_eq_def order_trans by blast

lemma lifted_antisymmetric:
  "f ≤≤ g  g ≤≤ f  f = g"
  by (rule ext, rule order.antisym) (simp_all add: lifted_less_eq_def)

text ‹
If the image of a finite non-empty set under f› is a totally ordered, there is an element that minimises the value of f›.

lemma finite_set_minimal:
  assumes "finite s"
      and "s  {}"
      and "xs . ys . f x  f y  f y  f x"
    shows "ms . zs . f m  f z"
  apply (rule finite_ne_subset_induct[where S=s])
  apply (rule assms(1))
  apply (rule assms(2))
  apply simp
  apply simp
  by (metis assms(3) insert_iff order_trans subsetD)


subsection ‹Semilattices›

text ‹
The following are basic facts in semilattices.

context semilattice_sup

lemma sup_left_isotone:
  "x  y  x  z  y  z"
  using sup.mono by blast

lemma sup_right_isotone:
  "x  y  z  x  z  y"
  using sup.mono by blast

lemma sup_left_divisibility:
  "x  y  (z . x  z = y)"
  using sup.absorb2 sup.cobounded1 by blast

lemma sup_right_divisibility:
  "x  y  (z . z  x = y)"
  by (metis sup.cobounded2 sup.orderE)

lemma sup_same_context:
  "x  y  z  y  x  z  x  z = y  z"
  by (simp add: le_iff_sup sup_left_commute)

lemma sup_relative_same_increasing:
  "x  y  x  z = x  w  y  z = y  w"
  using sup.assoc sup_right_divisibility by auto


text ‹
Every bounded semilattice is a commutative monoid.
Finite sums defined in commutative monoids are available via the following sublocale.

context bounded_semilattice_sup_bot

sublocale sup_monoid: comm_monoid_add where plus = sup and zero = bot
  apply unfold_locales
  apply (simp add: sup_assoc)
  apply (simp add: sup_commute)
  by simp


context semilattice_inf

lemma inf_same_context:
  "x  y  z  y  x  z  x  z = y  z"
  using order.antisym by auto


text ‹
The following class requires only the existence of upper bounds, which is a property common to bounded semilattices and (not necessarily bounded) lattices.
We use it in our development of filters.

class directed_semilattice_inf = semilattice_inf +
  assumes ub: "z . x  z  y  z"

text ‹
We extend the inf› sublocale, which dualises the order in semilattices, to bounded semilattices.

context bounded_semilattice_inf_top

subclass directed_semilattice_inf
  apply unfold_locales
  using top_greatest by blast

sublocale inf: bounded_semilattice_sup_bot where sup = inf and less_eq = greater_eq and less = greater and bot = top
  by unfold_locales (simp_all add: less_le_not_le)


subsection ‹Lattices›

context lattice

subclass directed_semilattice_inf
  apply unfold_locales
  using sup_ge1 sup_ge2 by blast

definition dual_additive :: "('a  'a)  bool"
  where "dual_additive f  x y . f (x  y) = f x  f y"


text ‹
Not every bounded lattice has complements, but two elements might still be complements of each other as captured in the following definition.
In this situation we can apply, for example, the shunting property shown below.
We introduce most definitions using the abbreviation› command.

context bounded_lattice

abbreviation "complement x y  x  y = top  x  y = bot"

lemma complement_symmetric:
  "complement x y  complement y x"
  by (simp add: inf.commute sup.commute)

definition conjugate :: "('a  'a)  ('a  'a)  bool"
  where "conjugate f g  x y . f x  y = bot  x  g y = bot"


class dense_lattice = bounded_lattice +
  assumes bot_meet_irreducible: "x  y = bot  x = bot  y = bot"

context distrib_lattice

lemma relative_equality:
  "x  z = y  z  x  z = y  z  x = y"
  by (metis inf.commute inf_sup_absorb inf_sup_distrib2)


text ‹
Distributive lattices with a greatest element are widely used in the construction theorem for Stone algebras.

class distrib_lattice_bot = bounded_lattice_bot + distrib_lattice

class distrib_lattice_top = bounded_lattice_top + distrib_lattice

class bounded_distrib_lattice = bounded_lattice + distrib_lattice

subclass distrib_lattice_bot ..

subclass distrib_lattice_top ..

lemma complement_shunting:
  assumes "complement z w"
    shows "z  x  y  x  w  y"
  assume 1: "z  x  y"
  have "x = (z  w)  x"
    by (simp add: assms)
  also have "...  y  (w  x)"
    using 1 sup.commute sup.left_commute inf_sup_distrib2 sup_right_divisibility by fastforce
  also have "...  w  y"
    by (simp add: inf.coboundedI1)
  finally show "x  w  y"
  assume "x  w  y"
  hence "z  x  z  (w  y)"
    using inf.sup_right_isotone by auto
  also have "... = z  y"
    by (simp add: assms inf_sup_distrib1)
  also have "...  y"
    by simp
  finally show "z  x  y"


subsection ‹Linear Orders›

text ‹
We next consider lattices with a linear order structure.
In such lattices, join and meet are selective operations, which give the maximum and the minimum of two elements, respectively.
Moreover, the lattice is automatically distributive.

class bounded_linorder = linorder + order_bot + order_top

class linear_lattice = lattice + linorder

lemma max_sup:
  "max x y = x  y"
  by (metis max.boundedI max.cobounded1 max.cobounded2 sup_unique)

lemma min_inf:
  "min x y = x  y"
  by (simp add: inf.absorb1 inf.absorb2 min_def)

lemma sup_inf_selective:
  "(x  y = x  x  y = y)  (x  y = y  x  y = x)"
  by (meson inf.absorb1 inf.absorb2 le_cases sup.absorb1 sup.absorb2)

lemma sup_selective:
  "x  y = x  x  y = y"
  using sup_inf_selective by blast

lemma inf_selective:
  "x  y = x  x  y = y"
  using sup_inf_selective by blast

subclass distrib_lattice
  apply standard
  apply (rule order.antisym)
   apply (auto simp add: le_supI2)
  apply (metis inf_selective inf.coboundedI1 inf.coboundedI2 order.eq_iff)

lemma sup_less_eq:
  "x  y  z  x  y  x  z"
  by (metis le_supI1 le_supI2 sup_selective)

lemma inf_less_eq:
  "x  y  z  x  z  y  z"
  by (metis inf.coboundedI1 inf.coboundedI2 inf_selective)

lemma sup_inf_sup:
  "x  y = (x  y)  (x  y)"
  by (metis sup_commute sup_inf_absorb sup_left_commute)


text ‹
The following class derives additional properties if the linear order of the lattice has a least and a greatest element.

class linear_bounded_lattice = bounded_lattice + linorder

subclass linear_lattice ..

subclass bounded_linorder ..

subclass bounded_distrib_lattice ..

lemma sup_dense:
  "x  top  y  top  x  y  top"
  by (metis sup_selective)

lemma inf_dense:
  "x  bot  y  bot  x  y  bot"
  by (metis inf_selective)

lemma sup_not_bot:
  "x  bot  x  y  bot"
  by simp

lemma inf_not_top:
  "x  top  x  y  top"
  by simp

subclass dense_lattice
  apply unfold_locales
  using inf_dense by blast


text ‹
Every bounded linear order can be expanded to a bounded lattice.
Join and meet are maximum and minimum, respectively.

class linorder_lattice_expansion = bounded_linorder + sup + inf +
  assumes sup_def [simp]: "x  y = max x y"
  assumes inf_def [simp]: "x  y = min x y"

subclass linear_bounded_lattice
  apply unfold_locales
  by auto


subsection ‹Non-trivial Algebras›

text ‹
Some results, such as the existence of certain filters, require that the algebras are not trivial.
This is not an assumption of the order and lattice classes that come with Isabelle/HOL; for example, bot = top› may hold in bounded lattices.

class non_trivial =
  assumes consistent: "x y . x  y"

class non_trivial_order = non_trivial + order

class non_trivial_order_bot = non_trivial_order + order_bot

class non_trivial_bounded_order = non_trivial_order_bot + order_top

lemma bot_not_top:
  "bot  top"
proof -
  from consistent obtain x y :: 'a where "x  y"
    by auto
  thus ?thesis
    by (metis bot_less top.extremum_strict)


subsection ‹Homomorphisms›

text ‹
This section gives definitions of lattice homomorphisms and isomorphisms and basic properties.

class sup_inf_top_bot_uminus = sup + inf + top + bot + uminus
class sup_inf_top_bot_uminus_ord = sup_inf_top_bot_uminus + ord

context boolean_algebra

subclass sup_inf_top_bot_uminus_ord .


abbreviation sup_homomorphism :: "('a::sup  'b::sup)  bool"
  where "sup_homomorphism f  x y . f (x  y) = f x  f y"

abbreviation inf_homomorphism :: "('a::inf  'b::inf)  bool"
  where "inf_homomorphism f  x y . f (x  y) = f x  f y"

abbreviation bot_homomorphism :: "('a::bot  'b::bot)  bool"
  where "bot_homomorphism f  f bot = bot"

abbreviation top_homomorphism :: "('a::top  'b::top)  bool"
  where "top_homomorphism f  f top = top"

abbreviation minus_homomorphism :: "('a::minus  'b::minus)  bool"
  where "minus_homomorphism f  x y . f (x - y) = f x - f y"

abbreviation uminus_homomorphism :: "('a::uminus  'b::uminus)  bool"
  where "uminus_homomorphism f  x . f (-x) = -f x"

abbreviation sup_inf_homomorphism :: "('a::{sup,inf}  'b::{sup,inf})  bool"
  where "sup_inf_homomorphism f  sup_homomorphism f  inf_homomorphism f"

abbreviation sup_inf_top_homomorphism :: "('a::{sup,inf,top}  'b::{sup,inf,top})  bool"
  where "sup_inf_top_homomorphism f  sup_inf_homomorphism f  top_homomorphism f"

abbreviation sup_inf_top_bot_homomorphism :: "('a::{sup,inf,top,bot}  'b::{sup,inf,top,bot})  bool"
  where "sup_inf_top_bot_homomorphism f  sup_inf_top_homomorphism f  bot_homomorphism f"

abbreviation bounded_lattice_homomorphism :: "('a::bounded_lattice  'b::bounded_lattice)  bool"
  where "bounded_lattice_homomorphism f  sup_inf_top_bot_homomorphism f"

abbreviation sup_inf_top_bot_uminus_homomorphism :: "('a::sup_inf_top_bot_uminus  'b::sup_inf_top_bot_uminus)  bool"
  where "sup_inf_top_bot_uminus_homomorphism f  sup_inf_top_bot_homomorphism f  uminus_homomorphism f"

abbreviation sup_inf_top_bot_uminus_ord_homomorphism :: "('a::sup_inf_top_bot_uminus_ord  'b::sup_inf_top_bot_uminus_ord)  bool"
  where "sup_inf_top_bot_uminus_ord_homomorphism f  sup_inf_top_bot_uminus_homomorphism f  (x y . x  y  f x  f y)"

abbreviation sup_inf_top_isomorphism :: "('a::{sup,inf,top}  'b::{sup,inf,top})  bool"
  where "sup_inf_top_isomorphism f  sup_inf_top_homomorphism f  bij f"

abbreviation bounded_lattice_top_isomorphism :: "('a::bounded_lattice_top  'b::bounded_lattice_top)  bool"
  where "bounded_lattice_top_isomorphism f  sup_inf_top_isomorphism f"

abbreviation sup_inf_top_bot_uminus_isomorphism :: "('a::sup_inf_top_bot_uminus  'b::sup_inf_top_bot_uminus)  bool"
  where "sup_inf_top_bot_uminus_isomorphism f  sup_inf_top_bot_uminus_homomorphism f  bij f"

abbreviation boolean_algebra_isomorphism :: "('a::boolean_algebra  'b::boolean_algebra)  bool"
  where "boolean_algebra_isomorphism f  sup_inf_top_bot_uminus_isomorphism f  minus_homomorphism f"

lemma sup_homomorphism_mono:
  "sup_homomorphism (f::'a::semilattice_sup  'b::semilattice_sup)  mono f"
  by (metis le_iff_sup monoI)

lemma sup_isomorphism_ord_isomorphism:
  assumes "sup_homomorphism (f::'a::semilattice_sup  'b::semilattice_sup)"
      and "bij f"
    shows "x  y  f x  f y"
  assume "x  y"
  thus "f x  f y"
    by (metis assms(1) le_iff_sup)
  assume "f x  f y"
  hence "f (x  y) = f y"
    by (simp add: assms(1) le_iff_sup)
  hence "x  y = y"
    by (metis injD bij_is_inj assms(2))
  thus "x  y"
    by (simp add: le_iff_sup)

lemma minus_homomorphism_default:
  assumes "x y::'a::{inf,minus,uminus} . x - y = x  -y"
      and "x y::'b::{inf,minus,uminus} . x - y = x  -y"
      and "inf_homomorphism (f::'a  'b)"
      and "uminus_homomorphism f"
    shows "minus_homomorphism f"
  by (simp add: assms)