(***********************************************************************
* HiVe theory files
*
* Copyright (C) 2015 Commonwealth of Australia as represented by Defence Science and Technology
* Group (DST Group)
*
* All rights reserved.
*
* The HiVe theory files are free software: released for redistribution and use, and/or modification,
* under the BSD License, details of which can be found in the LICENSE file included in the
* distribution.
************************************************************************)

theory Lattice_Locale

imports
  Order_Locale

begin

text {*

A lattice is non-empty set @{text X} with operators
@{text "\<sqinter>"} ({\em meet}) and @{text "\<squnion>"} ({\em join}) that
are idempotent, commutative, associative and which satisfy the absorption
law.

*}

no_notation Lattices.inf (infixl "\<sqinter>" 70)
no_notation Lattices.sup (infixl "\<squnion>" 65)

no_notation Complete_Lattices.Inf ("\<Sqinter>_" [900] 900)

no_notation Complete_Lattices.Sup ("\<Squnion>_" [900] 900)

locale lattice_sig =
  carrier_sig X
  for
    X :: "'a set" +
  fixes
    BS_sqcap ::"['a, 'a] \<rightarrow> 'a" (infixl "\<sqinter>" 70) and
    BS_sqcup ::"['a, 'a] \<rightarrow> 'a" (infixl "\<squnion>" 65)

locale pure_lattice =
  carrier +
  lattice_sig +
assumes
  meetR [simp]: "\<lbrakk> x \<in> X; y \<in> X \<rbrakk> \<turnstile> x \<sqinter> y \<in> X" and
  meetID: "x \<in> X \<turnstile> x \<sqinter> x = x" and
  meetC: "\<lbrakk> x \<in> X; y \<in> X \<rbrakk> \<turnstile> x \<sqinter> y = y \<sqinter> x" and
  meetA: "\<lbrakk> x \<in> X; y \<in> X; z \<in> X \<rbrakk> \<turnstile> (x \<sqinter> y) \<sqinter> z = x \<sqinter> (y \<sqinter> z)" and
  meetAB: "\<lbrakk> x \<in> X; y \<in> X \<rbrakk> \<turnstile> x \<sqinter> (x \<squnion> y) = x" and
  joinR [simp]: "\<lbrakk> x \<in> X; y \<in> X \<rbrakk> \<turnstile> x \<squnion> y \<in> X" and
  joinID: "x \<in> X \<turnstile> x \<squnion> x = x" and
  joinC: "\<lbrakk> x \<in> X; y \<in> X \<rbrakk> \<turnstile> x \<squnion> y = y \<squnion> x" and
  joinA: "\<lbrakk> x \<in> X; y \<in> X; z \<in> X \<rbrakk> \<turnstile> (x \<squnion> y) \<squnion> z = x \<squnion> (y \<squnion> z)" and
  joinAB: "\<lbrakk> x \<in> X; y \<in> X \<rbrakk> \<turnstile> x \<squnion> (x \<sqinter> y) = x"

begin

lemmas pure_lattice_carrier = carrier

end

notation (zed)
  pure_lattice ("\<^purelat>{:_:}{:_:}{:_:}")

lemma (in pure_lattice) pure_lattice:
    "\<^purelat>{:X:}{:BS_sqcap:}{:BS_sqcup:}"
  by (intro_locales)

lemma (in pure_lattice) meetLC:
  assumes
    a1: "x \<in> X" "y \<in> X" "z \<in> X"
  shows
    "x \<sqinter> (y \<sqinter> z) = y \<sqinter> (x \<sqinter> z)"
  apply (rule AC_LC' [of "BS_sqcap"])
  apply (auto intro!: meetA meetC a1)
  done

lemma (in pure_lattice) joinLC:
  assumes
    a1: "x \<in> X" "y \<in> X" "z \<in> X"
  shows
    "x \<squnion> (y \<squnion> z) = y \<squnion> (x \<squnion> z)"
  apply (rule AC_LC' [of "BS_sqcup"])
  apply (auto intro: joinA joinC a1)
  done

text {*

The default ordering on a lattice is generated by relating all pairs,
@{text x} and @{text y}
for which @{text "x \<sqinter> y = x"} (or equivalently for which @{text "y \<squnion> x = y"}).
Under this order, the lattice forms a poset.

*}

context lattice_sig

begin

definition
  meet_order :: "['a, 'a] \<rightarrow> \<bool>"
where
  meet_order_def: "meet_order \<defs> (\<olambda> x y \<bullet> \<lch> x, y \<chIn> X \<rch> \<and> x \<sqinter> y = x)"

notation (xsymbols)
  meet_order (infixl "\<sqsubseteq>\<^sub>\<sqinter>" 50)

definition
  join_order :: "['a, 'a] \<rightarrow> \<bool>"
where
  join_order_def: "join_order \<defs> (\<olambda> x y \<bullet> \<lch> x, y \<chIn> X \<rch> \<and> y \<squnion> x = y)"

notation (xsymbols)
  join_order (infixl "\<sqsubseteq>\<^sub>\<squnion>" 50)

end

lemma (in pure_lattice) order_equiv:
    "(op \<sqsubseteq>\<^sub>\<sqinter>) = (op \<sqsubseteq>\<^sub>\<squnion>)"
proof (simp add: meet_order_def join_order_def fun_eq_def, intro allI, mauto(wind))
  fix x y
  assume
    b1: "x \<in> X" "y \<in> X"
  show
      "x \<sqinter> y = x \<Leftrightarrow> y \<squnion> x = y"
  proof (msafe(inference))
    assume
        "x \<sqinter> y = x"
    then have
        "y \<squnion> x
        = y \<squnion> (x \<sqinter> y)"
      by (simp)
    also have "\<dots>
        =  y \<squnion> (y \<sqinter> x)"
      by (simp add: b1 meetC)
    also have "\<dots>
        = y"
      by (simp add: b1 joinAB)
    finally show
        "y \<squnion> x = y"
      by (this)
  next
    assume
        "y \<squnion> x = y"
    then have
        "x \<sqinter> y
        = x \<sqinter> (y \<squnion> x)"
      by (simp)
    also have "\<dots>
        =  x \<sqinter> (x \<squnion> y)"
      by (simp add: b1 joinC)
    also have "\<dots>
        = x"
      by (simp add: b1 meetAB)
    finally show
        "x \<sqinter> y = x"
      by (this)
  qed
qed

locale po_lattice =
  pure_lattice X BS_sqcap BS_sqcup +
  setrel_sig X r

for
  X :: "'a set" and
  r :: "'a orderT" and
  BS_sqcap ::"['a, 'a] \<rightarrow> 'a" (infixl "\<sqinter>" 70) and
  BS_sqcup ::"['a, 'a] \<rightarrow> 'a" (infixl "\<squnion>" 65) +
assumes
  r_def: "r \<defs> (op \<sqsubseteq>\<^sub>\<sqinter>)"

begin

notation
 r (infixl "\<sqsubseteq>" 50)

lemmas po_lattice_pure_lattice = pure_lattice

end

notation (zed)
  po_lattice ("\<^polat>{:_:}{:_:}{:_:}{:_:}")

lemma (in po_lattice) po_lattice:
    "\<^polat>{:X:}{:(op \<sqsubseteq>):}{:BS_sqcap:}{:BS_sqcup:}"
  by (unfold_locales)

sublocale po_lattice \<subseteq> lpo: partial_order
  apply (intro_locales)
  apply (simp_all add: setrel_axioms_def reflexive_axioms_def transitive_axioms_def antisymmetric_axioms_def r_def meet_order_def)
  apply (msafe(inference))
proof -
  show
      "\<^oprel>{:(\<olambda> x y \<bullet> x \<in> X \<and> y \<in> X \<and> x \<sqinter> y = x):} \<in> X \<zrel> X"
    by (auto simp add: rel_def op2rel_def)
next
  fix x assume
    b1: "x \<in> X"
  then show
      "x \<sqinter> x = x"
    by (rule meetID)
next
  fix x y z
  assume
    c1: "x \<in> X" "y \<in> X" "z \<in> X" and
    c2: "x \<sqinter> y = x" and
    c3: "y \<sqinter> z = y"
  have
      "x \<sqinter> z
      = (x \<sqinter> y) \<sqinter> z"
    by (simp add: c2)
  also have "\<dots>
      = x \<sqinter> (y \<sqinter> z)"
    by (simp add: c1 meetA)
  also have "\<dots>
      = x \<sqinter> y"
    by (simp add: c3)
  also have "\<dots>
      = x"
    by (simp add: c2)
  finally show
      "x \<sqinter> z = x"
    by (this)
next
  fix x y
  assume
      "x \<in> X"
      "y \<in> X"
      "x \<sqinter> y = x"
      "y \<sqinter> x = y"
  then show
      "x = y"
    by (auto simp add: meetC)
qed

lemmas (in po_lattice) po_lattice_partial_order = lpo.partial_order

text {*

The meet and join operators are then pairwise glb and lub respectively.

*}

context po_lattice

begin

lemma meet_glb:
  assumes
    a1: "x \<in> X" "y \<in> X"
  shows
    "is_glb {x, y} (x \<sqinter> y)"
proof (rule is_glbI)
  show
      "x \<sqinter> y \<in> X"
    by (simp add: a1 meetR)
next
  fix a assume
    b1: "a \<in> {x, y}"
  then show
      "x \<sqinter> y \<sqsubseteq> a"
  proof (cases "a = x", simp_all)
    have
        "(x \<sqinter> y) \<sqinter> x
        = (x \<sqinter> x) \<sqinter> y"
      by (simp add: a1 meetC meetA meetLC)
    also have "\<dots>
        = x \<sqinter> y"
      by (simp add: a1 meetID)
    finally show
        "(x \<sqinter> y) \<sqsubseteq> x"
      by (simp add: a1 r_def meet_order_def)
  next
    have
        "(x \<sqinter> y) \<sqinter> y
        = x \<sqinter> (y \<sqinter> y)"
      by (simp add: a1 meetC meetA meetLC)
    also have "\<dots>
        = x \<sqinter> y"
      by (simp add: a1 meetID)
    finally show
        "(x \<sqinter> y) \<sqsubseteq> y"
      by (simp add: a1 r_def meet_order_def)
  qed
next
  fix b
  assume
    b1: "b \<in> X" and
    b2: "\<forall> z \<bullet> z \<in> {x, y} \<Rightarrow> b \<sqsubseteq> z"
  from b2 have
    b3: "b \<sqinter> x = b"
    by (simp add: a1 r_def meet_order_def)
  from b2 have
    b4: "b \<sqinter> y = b"
    by (simp add: a1 r_def meet_order_def)
  have
      "b \<sqinter> (x \<sqinter> y)
      = (b \<sqinter> x) \<sqinter> y"
    by (simp add: b1 a1 meetC meetA meetLC)
  also have "\<dots>
      = b \<sqinter> y"
    by (simp add: b3)
  also have "\<dots>
      = b"
    by (simp add: b4)
  finally show
      "b \<sqsubseteq> (x \<sqinter> y)"
    by (simp add: b1 a1 r_def meet_order_def)
qed

lemma join_lub:
  assumes
    a1: "x \<in> X" "y \<in> X"
  shows
    "is_lub {x, y} (x \<squnion> y)"
proof (rule is_lubI)
  show
      "x \<squnion> y \<in> X"
    by (simp add: a1)
next
  fix a assume
    b1: "a \<in> {x, y}"
  then show
      "a \<sqsubseteq> (x \<squnion> y)"
  proof (cases "a = x", simp_all)
    have
        "(x \<squnion> y) \<squnion> x
        = (x \<squnion> x) \<squnion> y"
      by (simp add: a1 joinC joinA joinLC)
    also have "\<dots>
        = x \<squnion> y"
      by (simp add: a1 joinID)
    finally show
        "x \<sqsubseteq> (x \<squnion> y)"
      by (simp add: a1 r_def order_equiv join_order_def)
  next
    have
        "(x \<squnion> y) \<squnion> y
        = x \<squnion> (y \<squnion> y)"
      by (simp add: a1 joinC joinA joinLC)
    also have "\<dots>
        = x \<squnion> y"
      by (simp add: a1 joinID)
    finally show
        "y \<sqsubseteq> (x \<squnion> y)"
      by (simp add: a1 r_def order_equiv join_order_def)
  qed
next
  fix b
  assume
    b1: "b \<in> X" and
    b2: "\<forall> z \<bullet> z \<in> {x, y} \<Rightarrow> z \<sqsubseteq> b"
  from b2 have
    b3: "b \<squnion> x = b"
    by (simp add: b1 a1 r_def order_equiv join_order_def joinC)
  from b2 have
    b4: "b \<squnion> y = b"
    by (simp add: b1 a1 r_def order_equiv join_order_def joinC)
  have
      "b \<squnion> (x \<squnion> y)
      = (b \<squnion> x) \<squnion> y"
    by (simp add: b1 a1 joinC joinA joinLC)
  also have "\<dots>
      = b \<squnion> y"
    by (simp add: b3)
  also have "\<dots>
      = b"
    by (simp add: b4)
  finally show
      "(x \<squnion> y) \<sqsubseteq> b"
    by (simp add: b1 a1 r_def order_equiv join_order_def joinC)
qed

end

text {*

In fact these properties of meet and join can be used to induce a lattice
structure on any poset with pairwise glb lub, thus giving an order-centric
development of lattice theory.

*}

definition
  meet :: "['a, 'a set, 'a orderT, 'a] \<rightarrow> 'a"
where
  meet_def: "meet \<defs> (\<olambda> x X r y \<bullet> (\<mu> a | \<^glbp>{:X:}{:r:} {x, y} a))"

definition
  join :: "['a, 'a set, 'a orderT, 'a] \<rightarrow> 'a"
where
  join_def: "join \<defs> (\<olambda> x X r y \<bullet> (\<mu> a | \<^lubp>{:X:}{:r:} {x, y} a))"

notation (xsymbols output)
  meet ("_ \<sqinter>\<^bsub>_, _\<^esub> _" [70, 0, 0, 71] 70) and
  join ("_ \<squnion>\<^bsub>_, _\<^esub> _" [65, 0, 0, 66] 65)

notation (zed)
  meet ("_ \<^meet>{:_:}{:_:} _" [70, 0, 0, 71] 70) and
  meet ("_ \<^meeta>{:_:}{:_:} _" [70, 0, 0, 71] 70) and
  join ("_ \<^join>{:_:}{:_:} _" [65, 0, 0, 66] 65) and
  join ("_ \<^joina>{:_:}{:_:} _" [65, 0, 0, 66] 65)

definition
  meet_op :: "['a set, 'a orderT, 'a, 'a] \<rightarrow> 'a"
where
  meet_op_def [simp]: "meet_op \<defs> (\<olambda> X r x y \<bullet> x \<^meet>{:X:}{:r:} y)"

definition
  join_op :: "['a set, 'a orderT, 'a, 'a] \<rightarrow> 'a"
where
  join_op_def [simp]: "join_op \<defs> (\<olambda> X r x y \<bullet> x \<^join>{:X:}{:r:} y)"

notation (xsymbols output)
  meet_op ("op \<sqinter>\<^bsub>_, _\<^esub>" 0) and
  join_op ("op \<squnion>\<^bsub>_, _\<^esub>" 0)

notation (zed)
  meet_op ("\<^meetop>{:_:}{:_:}") and
  join_op ("\<^joinop>{:_:}{:_:}")

context setrel_sig

begin

abbreviation
  meet :: "['a, 'a] \<rightarrow> 'a"
where
  "meet \<defs> (\<olambda> x y \<bullet> x \<^meet>{:X:}{:(op \<hookrightarrow>):} y)"

abbreviation
  join :: "['a, 'a] \<rightarrow> 'a"
where
  "join \<defs> (\<olambda> x y \<bullet> x \<^join>{:X:}{:(op \<hookrightarrow>):} y)"

notation
  meet (infixl "\<sqinter>" 70) and
  join (infixl "\<squnion>" 65)

end

context partial_order

begin

lemma meet_unique:
  assumes
    a1:"is_glb {x, y} a"
  shows
    "a = x \<sqinter> y"
  apply (unfold meet_def)
  apply (rule the_equality [symmetric])
  apply (rule a1)
  apply (rule glb_unique)
  apply (rule a1)
  apply (assumption)
  done

lemma join_unique:
  assumes
    a1:"is_lub {x, y} a"
  shows
    "a = x \<squnion> y"
  apply (unfold join_def)
  apply (rule the_equality [symmetric])
  apply (rule a1)
  apply (rule lub_unique)
  apply (rule a1)
  apply (assumption)
  done

end

locale lattice =
  partial_order +
assumes
  ex_glb2: "\<And> x y \<bullet> \<lbrakk> x \<in> X; y \<in> X \<rbrakk> \<turnstile> (\<exists> a \<bullet> is_glb {x, y} a)" and
  ex_lub2: "\<And> x y \<bullet> \<lbrakk> x \<in> X; y \<in> X \<rbrakk> \<turnstile> (\<exists> a \<bullet> is_lub {x, y} a)"

begin

notation
 r (infixl "\<sqsubseteq>" 50)

lemmas lattice_partial_order = partial_order

end

notation (zed)
  lattice ("\<^lattice>{:_:}{:_:}")

context lattice

begin

lemma lattice:
    "\<^lattice>{:X:}{:op \<sqsubseteq>:}"
  by (intro_locales)

lemma meet_glb:
  assumes
    a1: "x \<in> X" "y \<in> X"
  shows
    "is_glb {x, y} (x \<sqinter> y)"
proof -
  from a1 have
      "(\<exists> a \<bullet> is_glb {x, y} a)"
    by (rule ex_glb2)
  then obtain a where
    b1: "is_glb {x, y} a"
    by (auto)
  show
      "is_glb {x, y} (x \<sqinter> y)"
    apply (unfold meet_def)
    apply (rule theI)
    apply (rule b1)
  proof -
    fix b
    assume
      c1: "is_glb {x, y} b"
    from b1 c1 show
        "b = a"
      by (rule glb_unique)
  qed
qed

lemma join_lub:
  assumes
    a1: "x \<in> X" "y \<in> X"
  shows
    "is_lub {x, y} (x \<squnion> y)"
proof -
  from a1 have
      "(\<exists> a \<bullet> is_lub {x, y} a)"
    by (rule ex_lub2)
  then obtain a where
    b1: "is_lub {x, y} a"
    by (auto)
  show
      "is_lub {x, y} (x \<squnion> y)"
    apply (unfold join_def)
    apply (rule theI)
    apply (rule b1)
  proof -
    fix b
    assume
      c1: "is_lub {x, y} b"
    from b1 c1 show
        "b = a"
      by (rule lub_unique)
  qed
qed

end

sublocale lattice \<subseteq> pure_lattice X "(op \<sqinter>)" "(op \<squnion>)"
  apply (intro_locales)
  apply (rule pure_lattice_axioms.intro)
proof -
  fix x y z assume
    b1: "x \<in> X"  and
    b2: "y \<in> X" and
    b3: "z \<in> X"
  {
    fix x y assume
      "x \<in> X" "y \<in> X"
    with meet_glb [simplified is_glb_def] have
        "(x \<sqinter> y) \<in> X"
      by (auto intro: greatest_elt)
  } note b4 = this
  with b1 b2 show
      "(x \<sqinter> y) \<in> X" -- range
    by (simp)
  {
    fix x y
    assume
        "x \<in> X" "y \<in> X"
    with join_lub [simplified is_lub_def] have
        "x \<squnion> y \<in> X"
      by (auto intro: least_elt)
  } note b5 = this
  with b1 b2 show
      "x \<squnion> y \<in> X" -- range
    by (simp)
  have "is_glb {x, x} x"
    apply (rule is_glbI)
    apply (auto simp add: b1 refl)
    done
  with meet_glb [OF b1 b1]
  show
      "x \<sqinter> x = x" -- idempotent
    by (rule glb_unique [THEN sym])
  have
      "is_lub {x, x} x"
    apply (rule is_lubI)
    apply (auto simp add: b1 refl)
    done
  with join_lub [OF b1 b1] show
      "x \<squnion> x = x" -- idempotent
    by (rule lub_unique [THEN sym])
  from meet_glb [OF b2 b1] meet_glb [OF b1 b2] show
    b6: "x \<sqinter> y = y \<sqinter> x" -- commutative
    by (auto intro!: glb_unique)
  from join_lub [OF b2 b1] join_lub [OF b1 b2] show
    b7: "x \<squnion> y = y \<squnion> x" -- commutative
    by (auto intro!: lub_unique)
  show
      "(x \<sqinter> y) \<sqinter> z = x \<sqinter> (y \<sqinter> z)" -- associative
  proof (auto intro!: glb_unique meet_glb simp add: b1 b2 b3 b4 b5)
    show "is_glb {x, y \<sqinter> z} ((x \<sqinter> y) \<sqinter> z)"
    proof (rule is_glbI, simp_all add: b1 b2 b3 b4 all_conj_distrib, msafe(inference), simp_all)
      from meet_glb [OF b4 [OF b1 b2] b3] have
          "(x \<sqinter> y) \<sqinter> z
          \<sqsubseteq> x \<sqinter> y"
        by (simp add: is_glb_def is_greatest_def is_lb_def split_beta)
      also from meet_glb [OF b1 b2] have "\<dots>
          \<sqsubseteq> x"
        by (simp add: is_glb_def is_greatest_def is_lb_def split_beta)
      finally show
          "(x \<sqinter> y) \<sqinter> z \<sqsubseteq> x"
        by (this)
    next
      from meet_glb [OF b4 [OF b1 b2] b3] have
          "(x \<sqinter> y) \<sqinter> z
          \<sqsubseteq> x \<sqinter> y"
        by (simp add: is_glb_def is_greatest_def is_lb_def split_beta)
      also from meet_glb [OF b1 b2] have "\<dots>
          \<sqsubseteq> y"
        by (simp add: is_glb_def is_greatest_def is_lb_def split_beta)
      finally have
        d1: "(x \<sqinter> y) \<sqinter> z \<sqsubseteq> y"
        by (this)
      from meet_glb [OF b4 [OF b1 b2] b3] have
        d2: "(x \<sqinter> y) \<sqinter> z \<sqsubseteq> z"
        by (simp add: is_glb_def is_greatest_def is_lb_def split_beta)
      from b1 b2 b3 b4 d1 d2 meet_glb [OF b2 b3] show
          "(x \<sqinter> y) \<sqinter> z \<sqsubseteq> y \<sqinter> z"
        by (simp add: is_glb_def is_greatest_def is_lb_def split_beta)
    next
      fix b
      assume
        d1: "b \<in> X" and
        d2: "b \<sqsubseteq> x" and
        d3: "b \<sqsubseteq> y \<sqinter> z"
      note d3
      also from meet_glb [OF b2 b3] have
          "y \<sqinter> z \<sqsubseteq> y"
        by (simp add: is_glb_def is_greatest_def is_lb_def split_beta all_conj_distrib)
      finally have
        d4: "b \<sqsubseteq> y"
        by (this)
      note d3
      also from meet_glb [OF b2 b3] have
          "y \<sqinter> z \<sqsubseteq> z"
        by (simp add: is_glb_def is_greatest_def is_lb_def split_beta)
      finally have
        d5: "b \<sqsubseteq> z"
        by (this)
      from d1 d2 d4 meet_glb [OF b1 b2] have
        d6: "b \<sqsubseteq> x \<sqinter> y"
        by (simp add: is_glb_def is_greatest_def is_lb_def split_beta)
      from d1 meet_glb [OF b4 [OF b1 b2] b3] d5 d6 show
          "b \<sqsubseteq> (x \<sqinter> y) \<sqinter> z"
        by (simp add: is_glb_def is_greatest_def is_lb_def split_beta)
    qed
  qed
  show
      "(x \<squnion> y) \<squnion> z = x \<squnion> (y \<squnion> z)" -- associative
  proof (auto intro!: lub_unique join_lub simp add: b1 b2 b3 b4 b5)
    show
        "is_lub {x, y \<squnion> z} ((x \<squnion> y) \<squnion> z)"
    proof (rule is_lubI, simp_all add: b1 b2 b3 b5 all_conj_distrib, msafe(inference), simp_all)
      from join_lub [OF b1 b2]
      have
          "x
          \<sqsubseteq> x \<squnion> y"
        by (simp add: is_lub_def is_least_def is_ub_def split_beta)
      also from join_lub [OF b5 [OF b1 b2] b3] have "\<dots>
          \<sqsubseteq> (x \<squnion> y) \<squnion> z"
        by (simp add: is_lub_def is_least_def is_ub_def split_beta)
      finally show
          "x \<sqsubseteq> (x \<squnion> y) \<squnion> z"
        by (this)
    next
      from join_lub [OF b1 b2]
      have
          "y
          \<sqsubseteq> x \<squnion> y"
        by (simp add: is_lub_def is_least_def is_ub_def split_beta)
      also from join_lub [OF b5 [OF b1 b2] b3] have "\<dots>
          \<sqsubseteq> (x \<squnion> y) \<squnion> z"
        by (simp add: is_lub_def is_least_def is_ub_def split_beta)
      finally have
        d1: "y \<sqsubseteq> (x \<squnion> y) \<squnion> z"
        by (this)
      from join_lub [OF b5 [OF b1 b2] b3] have
        d2: "z \<sqsubseteq> (x \<squnion> y) \<squnion> z"
        by (simp add: is_lub_def is_least_def is_ub_def split_beta)
      from b1 b2 b3 b5 d1 d2 join_lub [OF b2 b3]
      show
          "y \<squnion> z \<sqsubseteq> (x \<squnion> y) \<squnion> z"
        by (simp add: is_lub_def is_least_def is_ub_def split_beta)
    next
      fix b
      assume
        d1: "b \<in> X" and
        d2: "x \<sqsubseteq> b" and
        d3: "y \<squnion> z \<sqsubseteq> b"
      from join_lub [OF b2 b3] have
          "y
          \<sqsubseteq> y \<squnion> z"
        by (simp add: is_lub_def is_least_def is_ub_def split_beta all_conj_distrib)
      also note d3
      finally have
        d4: "y \<sqsubseteq> b"
        by (this)
      from join_lub [OF b2 b3] have
          "z \<sqsubseteq> y \<squnion> z"
        by (simp add: is_lub_def is_least_def is_ub_def split_beta all_conj_distrib)
      also note d3
      finally have
        d5: "z \<sqsubseteq> b"
        by (this)
      from d1 d2 d4 join_lub [OF b1 b2] have
        d6: "x \<squnion> y \<sqsubseteq> b"
        by (simp add: is_lub_def is_least_def is_ub_def split_beta)
      from d1 join_lub [OF b5 [OF b1 b2] b3] d5 d6 show
          "(x \<squnion> y) \<squnion> z \<sqsubseteq> b"
        by (simp add: is_lub_def is_least_def is_ub_def split_beta)
    qed
  qed
  from meet_glb [OF b1 b5 [OF b1 b2]] show
    "x \<sqinter> (x \<squnion> y) = x"
  proof (rule glb_unique [THEN sym])
    from b1 refl join_lub [OF b1 b2] show
        "is_glb {x, x \<squnion> y} x"
      by (auto intro!: is_glbI simp add: is_lub_def is_least_def is_ub_def split_beta)
  qed
  from join_lub [OF b1 b4 [OF b1 b2]] show
      "x \<squnion> (x \<sqinter> y) = x"
  proof (rule lub_unique [THEN sym])
    from b1 refl meet_glb [OF b1 b2] show
        "is_lub {x, x \<sqinter> y} x"
      by (auto intro!: is_lubI simp add: is_glb_def is_greatest_def is_lb_def split_beta)
  qed
qed

lemmas (in lattice) lattice_pure_lattice = pure_lattice

text {*

Having established this correspondence between a pure view of lattices
and a partial order view, we find it convenient to finally adopt
a view of lattice that is order oriented. An important factor in this
consideration is the degree of freedom in the action of meet and join
off the carrier set in the pure view.

*}

context lattice

begin

lemma order_fixed:
  "lattice_sig.meet_order X (op \<sqinter>) = (op \<sqsubseteq>)"
proof (auto simp add: meet_order_def fun_eq_def relD1 relD2)
  fix x y
  assume
    b1: "x \<sqsubseteq> y"
  from b1 have
    b2: "is_glb {x, y} x"
    by (auto intro!: is_glbI relD1 reflD)
  from b1 meet_glb have
    b3: "is_glb {x, y} (x \<sqinter> y)"
    by (simp add: relD1 relD2)
  from b2 b3 show
      "x \<sqinter> y = x"
    by (rule glb_unique)
next
  fix x y
  assume
    b1: "x \<in> X" "y \<in> X" and
    b2: "x \<sqinter> y = x"
  from b1 b2 meet_glb [of x y] have
    b3: "is_glb {x, y} x"
    by (simp)
  then show
      "x \<sqsubseteq> y"
    by (simp add: is_glbD1')
qed

lemma meet_order:
    "x \<sqsubseteq> y \<Leftrightarrow> x \<in> X \<and> y \<in> X \<and> x \<sqinter> y = x"
proof -
  have
      "x \<sqsubseteq> y
      \<Leftrightarrow> \<^infopa>{:x:}{:lattice_sig.meet_order X (op \<sqinter>):}{:y:}"
    by (simp add: order_fixed)
  also have "\<dots>
      \<Leftrightarrow> x \<in> X \<and> y \<in> X \<and> x \<sqinter> y = x"
    by (simp add: meet_order_def)
  finally show
      ?thesis
    by (this)
qed

lemma join_order:
    "x \<sqsubseteq> y \<Leftrightarrow> x \<in> X \<and> y \<in> X \<and> y \<squnion> x = y"
proof -
  have
      "x \<preceq> y
      \<Leftrightarrow> \<^infopa>{:x:}{:lattice_sig.join_order X (op \<squnion>):}{:y:}"
    by (simp add: order_fixed order_equiv [THEN sym])
  also have "\<dots>
      \<Leftrightarrow> x \<in> X \<and> y \<in> X \<and> y \<squnion> x = y"
    by (simp add: join_order_def)
  finally show ?thesis by (this)
qed

end

lemma (in partial_order) latticeI:
  "\<lbrakk>
    (\<And> x y \<bullet> \<lbrakk> x \<in> X; y \<in> X \<rbrakk> \<turnstile> (\<exists> a \<bullet> is_glb {x, y} a));
    (\<And> x y \<bullet> \<lbrakk> x \<in> X; y \<in> X \<rbrakk> \<turnstile> (\<exists> a \<bullet> is_lub {x, y} a))
   \<rbrakk> \<turnstile> \<^lattice>{:X:}{:(op \<preceq>):}"
  apply (intro_locales)
  apply (auto simp add: lattice_axioms_def)
  done

text {*

Finally some reasoning rules for calculating with meets and joins.

*}

context lattice

begin

lemma meet_lbD1:
    "\<lbrakk> x \<in> X; y \<in> X \<rbrakk> \<turnstile> x \<sqinter> y \<sqsubseteq> x"
  by (auto intro!: is_glbD1' [OF meet_glb])

lemma meet_lbD2:
    "\<lbrakk> x \<in> X; y \<in> X \<rbrakk> \<turnstile> x \<sqinter> y \<sqsubseteq> y"
  by (auto intro!: is_glbD1' [OF meet_glb])

lemma meet_glbD:
    "\<lbrakk> z \<preceq> x; z \<preceq> y \<rbrakk> \<turnstile> z \<sqsubseteq> x \<sqinter> y"
  by (auto intro: is_glbD2' [OF meet_glb] relD1 relD2)

lemma join_ubD1:
    "\<lbrakk> x \<in> X; y \<in> X \<rbrakk> \<turnstile> x \<sqsubseteq> x \<squnion> y"
  by (auto intro!: is_lubD1' [OF join_lub])

lemma join_ubD2:
    "\<lbrakk> x \<in> X; y \<in> X \<rbrakk> \<turnstile> y \<sqsubseteq> x \<squnion> y"
  by (auto intro!: is_lubD1' [OF join_lub])

lemma  join_lubD:
    "\<lbrakk> x \<preceq> z; y \<preceq> z \<rbrakk> \<turnstile> x \<squnion> y \<sqsubseteq> z"
  by (auto intro: is_lubD2' [OF join_lub] relD1 relD2)

lemma meet_mono:
  assumes
    a1: "x \<sqsubseteq> x'" and
    a2: "y \<sqsubseteq> y'"
  shows
    "x \<sqinter> y \<sqsubseteq> x' \<sqinter> y'"
proof -
  from a1 a2 have
    b1 [simplified]: "\<lch> x, y, x', y' \<chIn> X \<rch>"
    by (auto simp add: relD1 relD2)
  have
      "x \<sqinter> y
      \<sqsubseteq> x"
    by (rule meet_lbD1, auto simp add: b1)
  also have "\<dots>
      \<sqsubseteq> x'"
    by (rule a1)
  finally have
    b2: "x \<sqinter> y \<sqsubseteq> x'"
    by (this)
  have
      "x \<sqinter> y
      \<sqsubseteq> y"
    by (rule meet_lbD2, auto simp add: b1)
  also have "\<dots>
      \<sqsubseteq> y'"
    by (rule a2)
  finally have
    b3: "x \<sqinter> y \<sqsubseteq> y'"
    by (this)
  from b2 b3 show
      "x \<sqinter> y \<sqsubseteq> x' \<sqinter> y'"
    by (auto intro!: meet_glbD simp add: b1)
qed

lemma join_mono:
  assumes
    a1: "x \<sqsubseteq> x'" and
    a2: "y \<sqsubseteq> y'"
  shows
    "x \<squnion> y \<sqsubseteq> x' \<squnion> y'"
proof -
  from a1 a2 have
    b1 [simplified]:
      "\<lch> x, y, x', y' \<chIn> X \<rch>"
    by (auto simp add: relD1 relD2)
  have
      "x
      \<sqsubseteq> x'"
    by (rule a1)
  also have "\<dots>
      \<sqsubseteq> x' \<squnion> y'"
    by (rule join_ubD1, auto simp add: b1)
  finally have
    b2: "x \<sqsubseteq> x' \<squnion> y'"
    by (this)
  have
      "y
      \<sqsubseteq> y'"
    by (rule a2)
  also have "\<dots>
      \<sqsubseteq> x' \<squnion> y'"
    by (rule join_ubD2, auto simp add: b1)
  finally have
    b3: "y \<sqsubseteq> x' \<squnion> y'"
    by (this)
  from b2 b3 show
      "x \<squnion> y \<sqsubseteq> x' \<squnion> y'"
    by (auto intro!: join_lubD simp add: b1)
qed

end

section {* Complete lattices *}

text {*

The existence of pairwise meets and joins in a lattice also ensures the
existence of arbitrary finite (nonempty) meets and joins.

*}

context lattice

begin

lemma finite_glb:
  assumes
    a1: "Y \<subseteq> X" and
    a2: "finite Y" and
    a3: "Y \<noteq> \<emptyset>"
  shows
    "\<exists> a \<bullet> is_glb Y a"
proof -
  from a2 have
      "Y \<subseteq> X \<and> Y \<noteq> \<emptyset> \<Rightarrow> (\<exists> a \<bullet> is_glb Y a)"
  proof (induct rule: finite_induct, simp, msafe(inference))
    fix x Y
    assume
      c1: "finite Y" and
      c2: "x \<notin> Y" and
      c3: "insert x Y \<subseteq> X" and
      c4: "Y \<subseteq> X \<and> Y \<noteq> \<emptyset> \<Rightarrow> (\<exists> a \<bullet> is_glb Y a)"
    from c3 have
      c5: "x \<in> X"
      by (auto)
    from c3 have
      c6: "Y \<subseteq> X"
      by (auto)
    show "\<exists> a \<bullet> is_glb (insert x Y) a"
    proof (cases "Y = \<emptyset>")
      assume
        d1: "Y = \<emptyset>"
      with c5 have
          "is_glb (insert x Y) x"
        by (auto intro!: is_glbI reflD)
      then show
          ?thesis
        by (auto)
    next
      assume
        d1: "Y \<noteq> \<emptyset>"
      with c6 c4 have
        d2: "\<exists> a \<bullet> is_glb Y a"
        by (simp)
      then obtain a where
        d3: "is_glb Y a"
        by (auto)
      from d3 have
        d4: "a \<in> X"
        by (rule glb_elt)
      with c5 have
        d5: "x \<sqinter> a \<in> X"
        by (rule meetR)
      then have
        d6: "is_glb (insert x Y) (x \<sqinter> a)"
      proof (rule is_glbI)
        fix y assume
          e1: "y \<in> insert x Y"
        then show
            "x \<sqinter> a \<sqsubseteq> y"
        proof (auto)
          from c5 d4 show
              "x \<sqinter> a \<sqsubseteq> x"
            by (rule meet_lbD1)
        next
          assume
            f1: "y \<in> Y"
          from c5 d4 have
              "x \<sqinter> a
              \<sqsubseteq> a"
            by (rule meet_lbD2)
          also from d3 f1 have "\<dots>
              \<sqsubseteq> y"
            by (rule is_glbD1')
          finally show
              "x \<sqinter> a \<sqsubseteq> y"
            by (this)
        qed
      next
        fix b assume
          e1: "b \<in> X" and
          e2: "(\<forall> y | y \<in> insert x Y \<bullet> b \<sqsubseteq> y)"
        from e2 have
          e3: "b \<preceq> x"
          by (auto)
        from e2 have
          e4: "(\<forall> y | y \<in> Y \<bullet> b \<sqsubseteq> y)"
          by (auto)
        from d3 e1 have
          e5: "b \<sqsubseteq> a"
          apply (rule is_glbD2')
          apply (auto simp add: e4)
          done
        from e3 e5 show
          "b \<sqsubseteq> x \<sqinter> a"
          by (rule meet_glbD)
      qed
      then show
          ?thesis
        by (auto)
    qed
  qed
  with a1 a3 show
      ?thesis
    by (auto)
qed

lemma  finite_lub:
  assumes
    a1: "Y \<subseteq> X" and
    a2: "finite Y" and
    a3: "Y \<noteq> \<emptyset>"
  shows
      "(\<exists> a \<bullet> is_lub Y a)"
proof -
  from a2 have
      "Y \<subseteq> X \<and> Y \<noteq> \<emptyset> \<Rightarrow> (\<exists> a \<bullet> is_lub Y a)"
  proof (induct rule: finite_induct, simp, msafe(inference))
    fix x Y
    assume
      c1: "finite Y" and
      c2: "x \<notin> Y" and
      c3: "insert x Y \<subseteq> X" and
      c4: "Y \<subseteq> X \<and> Y \<noteq> \<emptyset> \<Rightarrow> (\<exists> a \<bullet> is_lub Y a)"
    from c3 have
      c5: "x \<in> X" by (auto)
    from c3 have
      c6: "Y \<subseteq> X" by (auto)
    show
        "(\<exists> a \<bullet> is_lub (insert x Y) a)"
    proof (cases "Y = \<emptyset>")
      assume
        d1: "Y = \<emptyset>"
      with c5 have
          "is_lub (insert x Y) x"
        by (auto intro!: is_lubI reflD)
      then show
          ?thesis
        by (auto)
    next
      assume
        d1: "Y \<noteq> \<emptyset>"
      with c6 c4 have
        d2: "(\<exists> a \<bullet> is_lub Y a)"
        by (simp)
      then obtain a where
        d3: "is_lub Y a"
        by (auto)
      from d3 have
        d4: "a \<in> X"
        by (rule lub_elt)
      with c5 have
        d5: "x \<squnion> a \<in> X"
        by (rule joinR)
      then have
        d6: "is_lub (insert x Y) (x \<squnion> a)"
      proof (rule is_lubI)
        fix y assume
          e1: "y \<in> insert x Y"
        then show
            "y \<sqsubseteq> x \<squnion> a"
        proof (auto)
          from c5 d4 show
              "x \<sqsubseteq> x \<squnion> a"
            by (rule join_ubD1)
        next
          assume
            f1: "y \<in> Y"
          from d3 f1 have
              "y
              \<sqsubseteq> a"
            by (rule is_lubD1')
          also from c5 d4 have "\<dots>
              \<sqsubseteq> x \<squnion> a"
            by (rule join_ubD2)
          finally show
              "y \<sqsubseteq> x \<squnion> a"
            by (this)
        qed
      next
        fix b assume
          e1: "b \<in> X" and
          e2: "(\<forall> y | y \<in> insert x Y \<bullet> y \<preceq> b)"
        from e2 have
          e3: "x \<sqsubseteq> b"
          by (auto)
        from e2 have
          e4: "(\<forall> y | y \<in> Y \<bullet> y \<sqsubseteq> b)"
          by (auto)
        from d3 e1 have
          e5: "a \<sqsubseteq> b"
          apply (rule is_lubD2')
          apply (auto simp add: e4)
          done
        from e3 e5 show
            "x \<squnion> a \<sqsubseteq> b"
          by (rule join_lubD)
      qed
      then show ?thesis by (auto)
    qed
  qed
  with a1 a3 show ?thesis
    by (auto)
qed

end

text {*

A complete lattice is a partial order that has extremals for every
subset.

The existence of extremals allows us to introduce generalised meet and join
operators on complete lattices.

*}

definition
  Meet :: "['a set, 'a orderT, 'a set] \<rightarrow> 'a"
where
  Meet_def: "Meet \<defs> (\<olambda> X r Y \<bullet> (\<mu> a | \<^glbp>{:X:}{:r:} Y a))"

definition
  Join :: "['a set, 'a orderT, 'a set] \<rightarrow> 'a"
where
  Join_def: "Join \<defs> (\<olambda> X r Y \<bullet> (\<mu> a | \<^lubp>{:X:}{:r:} Y a))"

notation (xsymbols output)
  Meet ("\<Sqinter>\<^bsub>_, _\<^esub>_") and
  Join ("\<Squnion>\<^bsub>_, _\<^esub>_")

notation (zed)
  Meet ("\<^Meet>{:_:}{:_:}") and
  Join ("\<^Join>{:_:}{:_:}")

context setrel_sig

begin

abbreviation
  Meet :: "'a set \<rightarrow> 'a"
where
  "Meet \<defs> \<^Meet>{:X:}{:r:}"

abbreviation
  Join :: "'a set \<rightarrow> 'a"
where
  "Join \<defs> \<^Join>{:X:}{:r:}"

notation
  Meet ("\<Sqinter>_") and
  Join ("\<Squnion>_")

end

context partial_order

begin

lemma Meet_unique:
  assumes
    a1: "is_glb S a"
  shows
      "a = \<Sqinter>S"
  apply (unfold Meet_def)
  apply (rule the_equality [symmetric])
  apply (rule a1)
  apply (rule glb_unique)
  apply (rule a1)
  apply (assumption)
  done

lemma Join_unique:
  assumes
    a1: "is_lub S a"
  shows
      "a = \<Squnion>S"
  apply (unfold Join_def)
  apply (rule the_equality [symmetric])
  apply (rule a1)
  apply (rule lub_unique)
  apply (rule a1)
  apply (assumption)
  done

end

no_notation Orderings.bot ("\<bottom>")
no_notation Orderings.top ("\<top>")

definition
  Bottom :: "['a set, 'a orderT] \<rightarrow> 'a"
where
  Bottom_def: "Bottom \<defs> (\<olambda> X r \<bullet> \<^Meet>{:X:}{:r:}X)"

definition
  Top :: "['a set, 'a orderT] \<rightarrow> 'a"
where
  Top_def: "Top \<defs> (\<olambda> X r \<bullet> \<^Join>{:X:}{:r:}X)"

notation (zed)
  Bottom ("\<^Bottom>{:_:}{:_:}") and
  Top ("\<^Top>{:_:}{:_:}")

context setrel_sig

begin

abbreviation
  Bottom :: "'a" ("\<bottom>")
where
  "\<bottom> \<defs> \<^Bottom>{:X:}{:r:}"

abbreviation
  Top :: "'a" ("\<top>")
where
  "\<top> \<defs> \<^Top>{:X:}{:r:}"

end

context partial_order

begin

lemma Bottom_unique:
  assumes
    a1:"is_glb X a"
  shows
      "a = \<bottom>"
  apply (unfold Bottom_def)
  apply (rule Meet_unique)
  apply (rule a1)
  done

lemma Top_unique:
  assumes
    a1:"is_lub X a"
  shows
      "a = \<top>"
  apply (unfold Top_def)
  apply (rule Join_unique)
  apply (rule a1)
  done

lemma Bottom_eq:
    "\<lbrakk> y \<in> X; (\<forall> x | x \<in> X \<bullet> y \<preceq> x) \<rbrakk> \<turnstile> \<bottom> = y"
  apply (unfold Bottom_def)
  apply (rule Meet_unique [symmetric])
  apply (rule is_glbI)
  apply (auto)
  done

lemma Top_eq:
  "\<lbrakk> y \<in> X; (\<forall> x | x \<in> X \<bullet> x \<preceq> y) \<rbrakk> \<turnstile> \<top> = y"
  apply (unfold Top_def)
  apply (rule Join_unique [symmetric])
  apply (rule is_lubI)
  apply (auto)
  done

end

locale clattice_sig =
  carrier_sig X
  for
    X :: "'a set" +
  fixes
    BS_bigsqcap :: "'a set \<rightarrow> 'a" and
    BS_bigsqcup :: "'a set \<rightarrow> 'a" and
    BS_bot :: "'a" and
    BS_top :: "'a"

locale clattice =
  partial_order +
assumes
  ex_glb: "\<And> Y \<bullet> Y \<subseteq> X \<turnstile> (\<exists> a \<bullet> is_glb Y a)" and
  ex_lub: "\<And> Y \<bullet> Y \<subseteq> X \<turnstile> (\<exists> a \<bullet> is_lub Y a)"

sublocale clattice \<subseteq> lattice
  apply (unfold_locales)
  apply (auto intro!: ex_glb ex_lub)
  done

context clattice

begin

lemmas clattice_lattice = lattice

end

notation (zed)
  clattice ("\<^clattice>{:_:}{:_:}")

lemma (in clattice) clattice:
    "\<^clattice>{:X:}{:(op \<preceq>):}"
  by (intro_locales)

text {*

A complete lattice is a lattice.

*}

lemma (in partial_order) clatticeI:
  "\<lbrakk>
    (\<And> Y \<bullet> Y \<subseteq> X \<turnstile> (\<exists> a \<bullet> is_glb Y a));
    (\<And> Y \<bullet> Y \<subseteq> X \<turnstile> (\<exists> a \<bullet> is_lub Y a))
   \<rbrakk> \<turnstile> \<^clattice>{:X:}{:(op \<preceq>):}"
  apply (rule clattice.intro)
  apply (rule partial_order)
  apply (simp_all add: clattice_axioms_def)
  done

lemma (in partial_order) ex_Meet_glb:
  assumes
    a1: "A \<subseteq> X" and
    a2: "(\<exists> a \<bullet> is_glb A a)"
  shows
      "is_glb A (\<Sqinter>A)"
proof -
  from a2 a1 obtain a where
    b1: "is_glb A a"
    by (auto)
  show ?thesis
    apply (simp add: Meet_def)
    apply (rule theI [of "is_glb A" "a", OF b1])
    apply (auto intro: glb_unique [OF b1])
    done
qed

lemma (in lattice) fin_Meet_glb:
    "\<lbrakk> A \<subseteq> X; finite A; A \<noteq> \<emptyset> \<rbrakk>
    \<turnstile> is_glb A (\<Sqinter>A)"
  by (intro ex_Meet_glb finite_glb)

lemma (in clattice) Meet_glb:
    "A \<subseteq> X \<turnstile> is_glb A (\<Sqinter>A)"
  by (intro ex_Meet_glb ex_glb)

lemmas (in clattice) MeetR = glb_elt [OF Meet_glb]

lemma (in partial_order) ex_Join_lub:
  assumes
    a1: "A \<subseteq> X" and
    a2: "(\<exists> a \<bullet> is_lub A a)"
  shows
      "is_lub A (\<Squnion>A)"
proof -
  from a2 a1 obtain a where
    b1: "is_lub A a"
    by (auto)
  show
      ?thesis
    apply (simp add: Join_def)
    apply (rule theI [of "is_lub A" a, OF b1])
    apply (auto intro: lub_unique [OF b1])
    done
qed

lemma (in lattice) fin_Join_lub:
    "\<lbrakk> A \<subseteq> X; finite A; A \<noteq> \<emptyset> \<rbrakk>
    \<turnstile> is_lub A (\<Squnion>A)"
  by (intro ex_Join_lub finite_lub)

lemma (in clattice) Join_lub:
    "A \<subseteq> X \<turnstile> is_lub A (\<Squnion>A)"
  by (intro ex_Join_lub ex_lub)

lemmas (in clattice) JoinR = lub_elt [OF Join_lub]

text {*

The general meet and join operators satisfy similar rules to the pair-wise
versions.

*}

context clattice

begin

lemma Meet_lbD:
    "\<lbrakk> A \<subseteq> X; a \<in> A \<rbrakk>
    \<turnstile> (\<Sqinter>A) \<sqsubseteq> a"
  apply (rule is_glbD1')
  apply (rule Meet_glb)
  apply (assumption+)
  done

lemma Join_ubD:
  "\<lbrakk> A \<subseteq> X; a \<in> A \<rbrakk>
  \<turnstile> a \<sqsubseteq> (\<Squnion>A)"
  apply (rule is_lubD1')
  apply (rule Join_lub)
  apply (assumption+)
  done

lemma Meet_glbD:
  "\<lbrakk> A \<subseteq> X; a \<in> X; (\<forall> x \<bullet> x \<in> A \<Rightarrow> a \<sqsubseteq> x) \<rbrakk>
  \<turnstile> a \<sqsubseteq> (\<Sqinter>A)"
  apply (rule is_glbD2')
  apply (rule Meet_glb)
  apply (auto)
  done

lemma Join_lubD:
  "\<lbrakk> A \<subseteq> X; a \<in> X; (\<forall> x \<bullet> x \<in> A \<Rightarrow> x \<sqsubseteq> a) \<rbrakk>
  \<turnstile> (\<Squnion>A) \<sqsubseteq> a"
  apply (rule is_lubD2')
  apply (rule Join_lub)
  apply (auto)
  done

lemmas Meet_unique = glb_unique [OF Meet_glb, OF _ is_glbI]

lemmas Join_unique = lub_unique [OF Join_lub, OF _ is_lubI]

lemma Meet_sub:
  assumes
    a1: "\<lch> Z \<chSubseteq> Y \<chSubseteq> X \<rch>"
  shows
      "(\<Sqinter>Y) \<sqsubseteq> (\<Sqinter>Z)"
proof -
  from a1 have
    b1: "Z \<subseteq> X"
    by (auto)
  from a1 b1 show
        ?thesis
    apply (intro Meet_glbD)
    apply (auto simp add: MeetR Meet_lbD)
    done
qed

lemma Join_sub:
  assumes
    a1: "\<lch> Z \<chSubseteq> Y \<chSubseteq> X \<rch>"
  shows
      "(\<Squnion>Z) \<sqsubseteq> (\<Squnion>Y)"
proof -
  from a1 have
    b1: "Z \<subseteq> X"
    by (auto)
  from a1 b1 show
      ?thesis
    apply (intro Join_lubD)
    apply (auto intro!: Join_ubD simp add: JoinR)
    done
qed

lemma Meet_dom:
  assumes
    a1: "f\<lparr>{y | P y}\<rparr> \<subseteq> X" and
    a2: "g\<lparr>{y | P y}\<rparr> \<subseteq> X" and
    a3: "(\<And> y \<bullet> P y \<turnstile> f y \<sqsubseteq> g y)"
  shows
      "(\<Sqinter>{y | P y \<bullet> f y}) \<sqsubseteq> (\<Sqinter>{y | P y \<bullet> g y})"
  apply (rule Meet_glbD)
  using a1 a2 a3
  apply (auto intro!: MeetR simp add: eind_def)
  apply (rule transD)
  apply (rule Meet_lbD)
  apply (auto intro!: MeetR)
  done

lemma Join_dom:
  assumes
    a1: "f\<lparr>{y | P y}\<rparr> \<subseteq> X" and
    a2: "g\<lparr>{y | P y}\<rparr> \<subseteq> X" and
    a3: "(\<And> y \<bullet> P y \<turnstile> f y \<sqsubseteq> g y)"
  shows
      "(\<Squnion>{y | P y \<bullet> f y}) \<sqsubseteq> (\<Squnion>{y | P y \<bullet> g y})"
  apply (rule Join_lubD)
  using a1 a2 a3
  apply (auto intro!: JoinR simp add: eind_def)
  apply (rule transD)
  defer 1
  apply (rule Join_ubD)
  apply (auto intro!: JoinR)
  done

text {*

The pairwise meet and join are special case of general meet and join.

*}

lemma meet_Meet:
  "\<lbrakk> x \<in> X; y \<in> X \<rbrakk> \<turnstile> x \<sqinter> y = (\<Sqinter>{x, y})"
  apply (rule glb_unique [OF Meet_glb meet_glb])
  apply (auto)
  done

lemma join_Join:
  "\<lbrakk> x \<in> X; y \<in> X \<rbrakk> \<turnstile> x \<squnion> y = (\<Squnion>{x, y})"
  apply (rule lub_unique [OF Join_lub join_lub])
  apply (auto)
  done

text {*

The meet and join of the entire space are called bottom and top respectively.

*}

lemma Bottom_Join:
  "\<bottom> = (\<Squnion>\<emptyset>)"
  apply (rule Join_unique)
  apply (auto intro: MeetR Meet_lbD Meet_glbD simp add: Bottom_def)
  done

lemma BottomR:
  "\<bottom> \<in> X"
  by (auto simp add: Bottom_def MeetR)

lemma Bottom_lb:
  assumes
    a1: "x \<in> X"
  shows
      "\<bottom> \<sqsubseteq> x"
proof -
  have "(\<Sqinter>X) \<sqsubseteq> x"
    apply (rule Meet_lbD [OF _ a1])
    apply (simp)
    done
  then show
      ?thesis
    by (simp add: Bottom_def)
qed

lemma Bottom_min:
  assumes
    a1: "x \<in> X"
  shows
    "x \<sqsubseteq> \<bottom> \<Leftrightarrow> x = \<bottom>"
  apply (auto intro!: Bottom_eq [symmetric] a1)
  apply (rule transD)
  apply (assumption)
  apply (rule Bottom_lb)
  apply (assumption)
  apply (rule reflD)
  apply (rule BottomR)
  done

lemma Top_Meet:
    "\<top> = (\<Sqinter>\<emptyset>)"
  apply (rule Meet_unique)
  apply (auto intro: JoinR Join_ubD Join_lubD simp add: Top_def)
  done

lemma TopR:
    "\<top> \<in> X"
  by (auto simp add: Top_def JoinR)

lemma Top_ub:
  assumes
    a1: "x \<in> X"
  shows
      "x \<sqsubseteq> \<top>"
proof -
  have "x \<sqsubseteq> (\<Squnion>X)"
    apply (rule Join_ubD [OF _ a1])
    apply (simp)
    done
  then show
      ?thesis
    by (simp add: Top_def)
qed

lemma  Top_max:
  assumes
    a1: "x \<in> X"
  shows
      "\<top> \<sqsubseteq> x \<Leftrightarrow> x = \<top>"
  apply (auto intro!: Top_eq [symmetric] a1)
  apply (rule transD)
  apply (rule Top_ub)
  apply (assumption)
  apply (assumption)
  apply (rule reflD)
  apply (rule TopR)
  done

end

section {* Distributive lattices *}

text {*

A lattice in which the meet and join operators distribute is
called a distributive lattice.

*}

locale dlattice =
  lattice +

assumes
  meet_dist: "\<lbrakk> x \<in> X; y \<in> X; z \<in> X \<rbrakk> \<turnstile> x \<squnion> (y \<sqinter> z) = (x \<squnion> y) \<sqinter> (x \<squnion> z)" and
  join_dist: "\<lbrakk> x \<in> X; y \<in> X; z \<in> X \<rbrakk> \<turnstile> x \<sqinter> (y \<squnion> z) = (x \<sqinter> y) \<squnion> (x \<sqinter> z)"

begin

lemmas dlattice_lattice = lattice

end

notation (zed)
  dlattice ("\<^dlattice>{:_:}{:_:}")

lemma (in dlattice) dlattice:
    "\<^dlattice>{:X:}{:(op \<sqsubseteq>):}"
  by (intro_locales)

lemma (in lattice) dlatticeI:
  assumes
    a1: "(\<forall> x y z | \<lch> x, y, z \<chIn> X \<rch> \<bullet> x \<squnion> (y \<sqinter> z) = (x \<squnion> y) \<sqinter> (x \<squnion> z))" and
    a2: "(\<forall> x y z | \<lch> x, y, z \<chIn> X \<rch> \<bullet> x \<sqinter> (y \<squnion> z) = (x \<sqinter> y) \<squnion> (x \<sqinter> z))"
  shows
    "\<^dlattice>{:X:}{:(op \<sqsubseteq>):}"
  apply (rule dlattice.intro)
  apply (rule lattice)
  apply (unfold dlattice_axioms_def)
  apply (msafe(inference))
  apply (rule a1 [rule_format])
  apply (simp)
  apply (rule a2 [rule_format])
  apply (simp)
  done

locale dclattice =
  clattice +

assumes
  Meet_dist: "\<lbrakk> x \<in> X; Y \<subseteq> X \<rbrakk> \<turnstile> x \<squnion> (\<Sqinter>Y) = (\<Sqinter>{y | y \<in> Y \<bullet> (x \<squnion> y)})" and
  Join_dist: "\<lbrakk> x \<in> X; Y \<subseteq> X \<rbrakk> \<turnstile> x \<sqinter> (\<Squnion>Y) = (\<Squnion>{y | y \<in> Y \<bullet> (x \<sqinter> y)})"

begin

lemmas dclattice_clattice = clattice

end

notation (zed)
  dclattice ("\<^dclattice>{:_:}{:_:}")

lemma (in dclattice) dclattice:
  "\<^dclattice>{:X:}{:(op \<sqsubseteq>):}"
  by (intro_locales)

lemma (in clattice) dclatticeI:
  "\<lbrakk>
    (\<forall> x Y | x \<in> X \<and> Y \<subseteq> X \<bullet> x \<squnion> (\<Sqinter>Y) = (\<Sqinter>{y | y \<in> Y \<bullet> (x \<squnion> y)}));
    (\<forall> x Y | x \<in> X \<and> Y \<subseteq> X \<bullet> x \<sqinter> (\<Squnion>Y) = (\<Squnion>{y | y \<in> Y \<bullet> (x \<sqinter> y)}))
  \<rbrakk> \<turnstile> \<^dclattice>{:X:}{:(op \<preceq>):}"
  apply (rule dclattice.intro)
  apply (auto intro: carrier_axioms setrel_axioms reflexive_axioms transitive_axioms
    antisymmetric_axioms clattice_axioms)
  apply (rule dclattice_axioms.intro)
  apply (auto)
  done

context dclattice

begin

lemma  Meet_distD:
    "\<lbrakk> x \<in> X; Y \<subseteq> X \<rbrakk> \<turnstile> (\<Sqinter>{y | y \<in> Y \<bullet> x \<squnion> y}) = x \<squnion> (\<Sqinter>Y)"
  by (insert Meet_dist, auto)

lemma Meet_distD':
  assumes
    a1: "x \<in> X" "Y \<subseteq> X"
  shows
      "(\<Sqinter>{y | y \<in> Y \<bullet> y \<squnion> x}) = (\<Sqinter>Y) \<squnion> x"
proof -
  from a1 have
      "(\<Sqinter>Y) \<squnion> x
      = x \<squnion> (\<Sqinter>Y)"
    by (simp add: joinC MeetR)
  also from a1 have "\<dots>
      = (\<Sqinter>{y | y \<in> Y \<bullet> x \<squnion> y})"
    by (simp add: Meet_distD)
  also from a1 have
      "{y | y \<in> Y \<bullet> x \<squnion> y}
      = {y | y \<in> Y \<bullet> y \<squnion> x}"
    apply (mauto(wind))
    apply (auto simp add: joinC)
    done
  finally show
      ?thesis
    by (simp)
qed

lemma Join_distD:
    "\<lbrakk> x \<in> X; Y \<subseteq> X \<rbrakk> \<turnstile> (\<Squnion>{y | y \<in> Y \<bullet> x \<sqinter> y}) = x \<sqinter> (\<Squnion>Y)"
  by (insert Join_dist, auto)

lemma Join_distD':
  assumes
    a1: "x \<in> X" "Y \<subseteq> X"
  shows
      "(\<Squnion>{y | y \<in> Y \<bullet> y \<sqinter> x}) = (\<Squnion>Y) \<sqinter> x"
proof -
  from a1 have "
      (\<Squnion>Y) \<sqinter> x
      = x \<sqinter> (\<Squnion>Y)"
    by (simp add: meetC JoinR)
  also from a1 have "\<dots>
      = (\<Squnion>{y | y \<in> Y \<bullet> x \<sqinter> y})"
    by (simp add: Join_distD)
  also from a1 have
      "{y | y \<in> Y \<bullet> x \<sqinter> y}
      = {y | y \<in> Y \<bullet> y \<sqinter> x}"
    apply (mauto(wind))
    apply (auto simp add: meetC)
    done
  finally show
      ?thesis
    by (simp)
qed

end

sublocale dclattice \<subseteq> dlattice
  apply (intro_locales)
  apply (rule dlattice_axioms.intro)
  apply (simp add: meet_Meet Meet_dist eind_def)
  apply (rule arg_cong [where f = "Meet"])
  apply (fast)
  apply (simp add: join_Join Join_dist eind_def)
  apply (rule arg_cong [where f = "Join"])
  apply (fast)
  done

lemmas (in dclattice) dclattice_dlattice = dlattice

section {* Boolean lattices *}

text {*

Following the general analogy of the lattice as abstraction for the booleans,
a negation or complement operator can be introduced, resulting in a boolean
lattice or algebra.

*}

definition
  complement :: "['a set, 'a orderT, 'a] \<rightarrow> 'a"
where
  complement_def: "complement \<defs> (\<olambda> X r x \<bullet> (\<mu> y | y \<in> X \<and> x \<^meet>{:X:}{:r:} y = \<^Bottom>{:X:}{:r:} \<and> x \<^join>{:X:}{:r:} y = \<^Top>{:X:}{:r:}))"

context setrel_sig

begin

abbreviation
  complement :: "'a \<rightarrow> 'a" ("\<sim>_" [90] 90)
where
  "complement \<defs> Lattice_Locale.complement X r"

end

lemma (in dclattice) complement_unique:
  assumes
    a1: "x \<in> X" "y \<in> X" and
    a2: "x \<sqinter> y = \<bottom>" and
    a3: "x \<squnion> y = \<top>"
  shows
    "y = \<sim>x"
  apply (simp add: complement_def)
  apply (rule the_equality [symmetric])
  using a1 a2 a3
  apply (auto)
  apply (simp add: a2 a3)
proof -
  fix y'
  assume
    b1: "y' \<in> X" and
    b2: "x \<sqinter> y' = \<bottom>" and
    b3: "x \<squnion> y' = \<top>"
  show
      "y' = y"
  proof (rule antisymD)
    txt {*
    Following the reasoning of Davey~\cite[p 143]{Davey:Lattice}.
    *}
    from a1 have
        "y \<sqsubseteq> \<top>"
      by (simp add: Top_ub)
    then have
        "y
        = y \<sqinter> \<top>"
      by (simp add: meet_order)
    also have "\<dots>
        = y \<sqinter> (x \<squnion> y')"
      by (simp add: b3)
    also from a1 b1 have "\<dots>
        = (x \<sqinter> y) \<squnion> (y \<sqinter> y')"
      by (simp add: join_dist meetC)
    also from a1 b1 a2 a3 b2 b3 Bottom_lb [of "y \<sqinter> y'"]
    have " \<dots>
        = y \<sqinter> y'"
      by (simp add: join_order MeetR Bottom_def joinC meetR)
    finally show
        "y \<sqsubseteq> y'"
      by (simp add: meet_order a1 b1)
    from b1 have
        "y' \<sqsubseteq> \<top>"
      by (simp add: Top_ub)
    then have
        "y'
        = y' \<sqinter> \<top>"
      by (simp add: meet_order)
    also have "\<dots>
        = y' \<sqinter> (x \<squnion> y)"
      by (simp add: a3)
    also from a1 b1 have "\<dots>
        = (x \<sqinter> y') \<squnion> (y' \<sqinter> y)"
      by (simp add: join_dist meetC)
    also from a1 b1 a2 a3 b2 b3 Bottom_lb [of "y' \<sqinter> y"] have " \<dots>
        = y' \<sqinter> y"
      by (simp add: join_order Bottom_def MeetR joinC meetR)
    finally show
        "y' \<sqsubseteq> y"
      by (simp add: meet_order a1 b1)
  qed
qed

locale bool_lattice_sig =

fixes
  lcomp :: "'a \<rightarrow> 'a" ("\<sim>_" [1000] 999)

locale bool_lattice =
  dclattice +

assumes
  ex_complement:
    "(\<forall> x | x \<in> X \<bullet> (\<exists> y | y \<in> X \<bullet> x \<sqinter> y = \<bottom> \<and> x \<squnion> y = \<top>))"

begin

lemmas bool_lattice_dclattice = dclattice

end

notation (zed)
  bool_lattice ("\<^bllattice>{:_:}{:_:}")

lemma (in bool_lattice) bool_lattice:
  "\<^bllattice>{:X:}{:(op \<sqsubseteq>):}"
  by (intro_locales)

lemma (in dclattice) bool_latticeI:
  "(\<forall> x | x \<in> X \<bullet> (\<exists> y | y \<in> X \<bullet> x \<sqinter> y = \<bottom> \<and> x \<squnion> y = \<top>))
  \<turnstile> \<^bllattice>{:X:}{:(op \<sqsubseteq>):}"
  apply (rule bool_lattice.intro)
  apply (auto intro: carrier_axioms setrel_axioms reflexive_axioms transitive_axioms
    antisymmetric_axioms clattice_axioms dclattice_axioms)
  apply (rule bool_lattice_axioms.intro)
  apply (assumption)
  done

context bool_lattice

begin

lemma ex1_complement:
  assumes
    a1: "x \<in> X"
  shows
      "(\<exists>\<subone> y | y \<in> X \<bullet> x \<sqinter> y = \<bottom> \<and> x \<squnion> y = \<top>)"
  apply (rule ex_ex1I [OF ex_complement [rule_format]])
  apply (msafe(inference))
  apply (rule a1)
proof -
  fix y y'
  assume
    b1a: "y \<in> X" and b1b: "y' \<in> X" and
    b2a: "x \<sqinter> y = \<bottom>" and b2b: "x \<sqinter> y' = \<bottom>" and
    b3a: "x \<squnion> y = \<top>" and b3b: "x \<squnion> y' = \<top>"
  show "y = y'"
    by (simp add: complement_unique [OF a1 b1a b2a b3a] complement_unique [OF a1 b1b b2b b3b])
qed

lemma compR [simp]:
  "x \<in> X \<turnstile> \<sim>x \<in> X"
  using ex1_complement [THEN theI']
  by (simp add: complement_def )

lemma compD1:
  "x \<in> X \<turnstile> x \<sqinter> \<sim>x = \<bottom>"
  using ex1_complement [THEN theI']
  by (simp add: complement_def)

lemma compD2:
  "x \<in> X \<turnstile> x \<squnion> \<sim>x = \<top>"
  by (simp add: complement_def ex1_complement [THEN theI'])

lemma deMorgan_Meet:
  assumes
    a1: "Y \<subseteq> X"
  shows
      "\<sim>(\<Sqinter>Y) = (\<Squnion>{ y | y \<in> Y \<bullet> \<sim>y})"
  apply (rule complement_unique [symmetric])
  using a1
  apply (auto intro!: MeetR JoinR compR)
proof -
  from a1 [THEN subsetD] have
    b1: "{y | y \<in> Y \<bullet> \<sim>y} \<subseteq> X"
    by (auto simp add: compR)
{ from a1 b1 Join_distD [OF MeetR [OF a1] b1, THEN sym] have
      "(\<Sqinter>Y) \<sqinter> (\<Squnion>{ y | y \<in> Y \<bullet> \<sim>y})
      = (\<Squnion>{ y | y \<in> Y \<bullet> (\<Sqinter>Y) \<sqinter> \<sim>y})"
    by (auto intro!: set_eqI arg_cong [of _ _ "Join"] simp add: eind_comp)
  also from a1 have "\<dots>
      \<sqsubseteq> (\<Squnion>{ y | y \<in> Y \<bullet> y \<sqinter> \<sim>y})"
    apply (intro Join_dom)
    apply (auto intro!: compR meetR MeetR JoinR)
    apply (rule meet_mono)
    apply (rule Meet_lbD)
    apply (auto)
    apply (rule reflD)
    apply (auto)
    done
  also from a1 subsetD have "\<dots>
      \<sqsubseteq> \<bottom>"
    by (auto intro!: Join_lubD reflD simp add: BottomR meetR compR compD1 [OF subsetD])
  finally show
      "(\<Sqinter>Y) \<sqinter> (\<Squnion>{ y | y \<in> Y \<bullet> \<sim>y}) = \<bottom>"
    using a1 b1
    by (auto intro!: antisymD Bottom_lb meetR compR MeetR JoinR simp add: a1 [THEN subsetD])
next
  from a1 have
      "\<top>
      = (\<Sqinter>{y | y \<in> Y \<bullet> y \<squnion> \<sim>y})"
    by (auto intro!: Meet_unique joinR compR TopR reflD Top_ub simp add: compD2 [OF subsetD])
  also from a1 have "\<dots>
      \<sqsubseteq> (\<Sqinter>{y | y \<in> Y \<bullet> y \<squnion> (\<Squnion>{y | y \<in> Y \<bullet> \<sim>y})})"
    apply (auto intro!: Meet_glbD joinR compR JoinR MeetR simp add: subsetD [OF a1] )
    apply (rule transD)
    apply (auto intro!: Meet_lbD join_mono reflD Join_ubD joinR compR JoinR MeetR)
    done
  also from a1 b1 have "\<dots>
      = (\<Sqinter>Y) \<squnion> (\<Squnion>{y | y \<in> Y \<bullet> \<sim>y})"
    by (simp add: Meet_distD'[OF JoinR a1] compR)
  finally show
      "(\<Sqinter>Y) \<squnion> (\<Squnion>{y | y \<in> Y \<bullet> \<sim>y}) = \<top>"
    using a1 b1
    by (auto intro!: antisymD Top_ub joinR compR JoinR MeetR) }
qed

end

section {* Atomic lattices *}

text {*

In a complete lattice, an element is called an atom if and only if it
has no lower bounds but bottom and itself.

*}

context clattice

begin

definition
  atoms :: "'a set" ("\<atoms>")
where
  atoms_def: "\<atoms> \<defs> { x | x \<noteq> \<bottom> \<and> (\<forall> y \<bullet> y \<sqsubseteq> x \<Rightarrow> y = \<top> \<or> y = x)}"

definition
    basis_set :: "'a \<rightarrow> 'a set" ("\<^basis>{:_:}")
where
    basis_set_def: "\<^basis>{:y:} \<defs> {b | b \<in> \<atoms> \<and> b \<sqsubseteq> y}"

end

notation (zed)
  clattice.atoms ("\<^atom>{:_:}{:_:}") and
  clattice.atoms ("\<^atoma>{:_:}{:_:}")

text {*

A lattice is atomic if every element can be expressed as a join of atomic
elements.

*}

locale atomic_lattice =
  clattice +

assumes
  atom_decomp: "(\<forall> x | x \<in> X \<bullet> x = (\<Squnion>{y | y \<in> \<atoms> \<and> y \<sqsubseteq> x}))"

begin

lemmas atomic_lattice_clattice = clattice

end

notation (zed)
  atomic_lattice ("\<^alattice>{:_:}{:_:}")

lemma (in atomic_lattice) atomic_lattice:
    "\<^alattice>{:X:}{:(op \<sqsubseteq>):}"
  by (intro_locales)

section {* Dual lattices *}

text {*

The notions of meet and join are dual and so the dual of a
(complete) lattice is also a
(complete) lattice.

*}

context setrel_sig

begin

lemma meet_dual:
    "x \<^meet>{:X:}{:(op \<hookleftarrow>):} y = x \<squnion> y"
  by (simp add: meet_def join_def is_glb_dual)

lemma join_dual:
    "x \<^join>{:X:}{:(op \<hookleftarrow>):} y = x \<sqinter> y"
  by (simp add: meet_def join_def is_lub_dual)

lemma Meet_dual:
    "\<^Meet>{:X:}{:(op \<hookleftarrow>):}Y = \<Squnion>Y"
  by (simp add: Meet_def Join_def is_glb_dual)

lemma Join_dual:
    "\<^Join>{:X:}{:(op \<hookleftarrow>):}Y = \<Sqinter>Y"
  by (simp add: Meet_def Join_def is_lub_dual)

lemma Bottom_dual:
    "\<^Bottom>{:X:}{:(op \<hookleftarrow>):} = \<top>"
  by (simp add: Bottom_def Top_def Meet_dual Join_dual)

lemma Top_dual:
    "\<^Top>{:X:}{:(op \<hookleftarrow>):} = \<bottom>"
  by (simp add: Bottom_def Top_def Meet_dual Join_dual)

lemma complement_dual:
    "Lattice_Locale.complement X (op \<hookleftarrow>) = complement"
  by (auto
        intro!: arg_cong [of _ _ "The"]
        simp add: complement_def fun_eq_def meet_dual join_dual Bottom_dual Top_dual)

end

(*
interpretation lattice ["X" "\<^dualord>{:BS_leq:}"]
  apply (rule partial_order.latticeI [OF dual_poI])
  apply (simp_all add: is_glb_dual is_lub_dual ex_glb2 ex_lub2)
  done

lemma (in dlattic) dual_dlatticeI:
  "dlattice X \<^dualord>{:BS_leq:}"
  apply (rule lattice.dlatticeI [OF dual_latticeI])
  apply (fold BS_sqcap_def)
  apply (simp_all add: meet_dual join_dual meet_dist join_dist)
  done

lemma (in clattice) dual_clatticeI:
  "clattice X \<^dualord>{:BS_leq:}"
  apply (rule partial_order.clatticeI [OF dual_poI])
  apply (simp_all add: is_glb_dual is_lub_dual ex_glb ex_lub)
  done

lemma (in dclattice) dual_dclatticeI:
  "dclattice X \<^dualord>{:BS_leq:}"
  apply (rule clattice.dclatticeI [OF dual_clatticeI])
  apply (simp_all add:
    Meet_dual Join_dual
    join_dual meet_dual
    Meet_distD Join_distD)
  done

lemma (in bool_lattice) dual_bool_latticeI:
  "bool_lattice X \<^dualord>{:BS_leq:}"
  apply (rule dclattice.bool_latticeI [OF dual_dclatticeI])
  apply (insert ex_complement)
  apply (auto simp add:
    join_dual meet_dual
    Bottom_dual Top_dual)
  done

text {*

This leads to a duality principle for lattice properties.

*}

lemma dual_lattice_principle:
  fixes P::"['a set, ['a, 'a] \<rightarrow> 'a, ['a, 'a] \<rightarrow> 'a] \<rightarrow> \<bool>"
  assumes a1: "\<forall> X BS_leq | lattice X BS_leq \<bullet> P X (meet X BS_leq) (join X BS_leq)"
  shows "\<forall> X BS_leq | lattice X BS_leq \<bullet> P X (join X BS_leq) (meet X BS_leq)"
proof (auto)
  fix X::"'a set" and BS_leq::"['a, 'a] \<rightarrow> \<bool>"
  assume b1: "lattice X BS_leq"
  then have "lattice X \<^dualord>{:BS_leq:}"
    by (rule lattice.dual_latticeI)
  with a1 have "P X (meet X \<^dualord>{:BS_leq:}) (join X \<^dualord>{:BS_leq:})"
    by (auto)
  then show "P X (join X BS_leq) (meet X BS_leq)"
    by (simp add: meet_dual join_dual)
qed

lemma dual_clattice_principle:
  fixes P::"['a set, 'a set \<rightarrow> 'a, 'a set \<rightarrow> 'a] \<rightarrow> \<bool>"
  assumes a1: "\<forall> X BS_leq | clattice X BS_leq \<bullet> P X (Meet X BS_leq) (Join X BS_leq)"
  shows "\<forall> X BS_leq | clattice X BS_leq \<bullet> P X (Join X BS_leq) (Meet X BS_leq)"
proof (auto)
  fix X::"'a set" and BS_leq::"['a, 'a] \<rightarrow> \<bool>"
  assume b1: "clattice X BS_leq"
  then have "clattice X \<^dualord>{:BS_leq:}"
    by (rule clattice.dual_clatticeI)
  with a1 have "P X (Meet X \<^dualord>{:BS_leq:}) (Join X \<^dualord>{:BS_leq:})"
    by (auto)
  then show "P X (Join X BS_leq) (Meet X BS_leq)"
    by (simp add: Meet_dual Join_dual)
qed

lemma dual_bool_lattice_principle:
  fixes P::"['a set, 'a set \<rightarrow> 'a, 'a set \<rightarrow> 'a, 'a \<rightarrow> 'a] \<rightarrow> \<bool>"
  assumes a1: "\<forall> X BS_leq | bool_lattice X BS_leq \<bullet> P X (Meet X BS_leq) (Join X BS_leq) (complement X BS_leq)"
  shows "\<forall> X BS_leq | bool_lattice X BS_leq \<bullet> P X (Join X BS_leq) (Meet X BS_leq) (complement X BS_leq)"
proof (auto)
  fix X::"'a set" and BS_leq::"['a, 'a] \<rightarrow> \<bool>"
  assume b1: "bool_lattice X BS_leq"
  then have "bool_lattice X \<^dualord>{:BS_leq:}"
    by (rule bool_lattice.dual_bool_latticeI)
  with a1 have "P X (Meet X \<^dualord>{:BS_leq:}) (Join X \<^dualord>{:BS_leq:}) (complement X \<^dualord>{:BS_leq:})"
    by (auto)
  then show "P X (Join X BS_leq) (Meet X BS_leq) (complement X BS_leq)"
    by (simp add: Meet_dual Join_dual complement_dual)
qed

text {*

A an example in the use of the dual principle we consider de Morgan's law for
joins.

*}

lemma (in bool_lattice) deMorgan_Join:
  assumes a1: "Y \<subseteq> X"
  shows "\<^lcomp>{:X:}{:BS_leq:}{:\<^Join>{:X:}{:BS_leq:}{:Y:}:} = \<^Meet>{:X:}{:BS_leq:}{:{ y | y \<in> Y \<bullet> \<^lcomp>{:X:}{:BS_leq:}{:y:}}:}"
proof -
  have "Y \<subseteq> X \<Rightarrow> \<^lcomp>{:X:}{:BS_leq:}{:\<^Join>{:X:}{:BS_leq:}{:Y:}:} = \<^Meet>{:X:}{:BS_leq:}{:{ y | y \<in> Y \<bullet> \<^lcomp>{:X:}{:BS_leq:}{:y:}}:}"
    apply (rule dual_bool_lattice_principle [rule_format])
    apply (inference)
    apply (rule bool_lattice.deMorgan_Meet)
    apply (insert a1, auto ! simp add: bool_lattice_def)
    done
  with a1 show ?thesis
    by (auto)
qed
*)

section {* Sub-lattices *}

text {*

If the sub-order @{text "(Y, \<^subord>{:Y:}{:BS_leq:})"},
@{text "Y \<subseteq> X"}, forms a lattice we say that it is a {\em sub-lattice}
of @{text "(X, BS_leq)"}. A sub order need not be a sub-lattice, since
meets and joins may not always exist in the sub-order. Even where they
do exist, they may not be the same as for the super-lattice. However,
when a sub-order is closed under meets and joins, it
does indeed form a sub-lattice.

*}

locale X_lattice =
  X: lattice X r
for
  X::"'a set" and
  r::"'a orderT"

begin

notation
  r (infixl "\<sqsubseteq>\<^sub>X" 50)

notation
  X.meet (infixl "\<sqinter>\<^sub>X" 70) and
  X.join (infixl "\<squnion>\<^sub>X" 65)

end

sublocale X_lattice \<subseteq> X_partial_order
  by (unfold_locales)

locale Y_lattice =
  Y: lattice Y s
for
  Y::"'a set" and
  s::"'a orderT"

begin

notation
  s (infixl "\<sqsubseteq>\<^sub>Y" 50)

notation
  Y.meet (infixl "\<sqinter>\<^sub>Y" 70) and
  Y.join (infixl "\<squnion>\<^sub>Y" 65)

end

sublocale Y_lattice \<subseteq> Y_partial_order
  by (unfold_locales)

locale sub_lattice =
  sub_partial_order +
  X_lattice

begin

lemmas sub_lattice_X_lattice = X.lattice

lemmas sub_lattice_Y_poI = Y_poI

lemma sublatticeI:
  assumes
    ex_glb: "(\<And> x y \<bullet> \<lbrakk> x \<in> Y; y \<in> Y \<rbrakk> \<turnstile> (\<exists> a \<bullet> is_glb\<^sub>Y {x, y} a))" and
    ex_lub: "(\<And> x y \<bullet> \<lbrakk> x \<in> Y; y \<in> Y \<rbrakk> \<turnstile> (\<exists> a \<bullet> is_lub\<^sub>Y {x, y} a))"
  shows
      "\<^lattice>{:Y:}{:(op \<preceq>\<^sub>Y):}"
  using Y.latticeI ex_glb ex_lub
  by (auto)

lemma submeetI:
  assumes
    a1: "(\<forall> x y | x \<in> Y \<and> y \<in> Y \<bullet> x \<sqinter>\<^sub>X y \<in> Y)" and
    b1: "x \<in> Y" and b2: "y \<in> Y"
  shows
      "is_glb\<^sub>Y {x, y} (x \<sqinter>\<^sub>X y)"
proof -
  from subset_Y b1 b2 have
    b3: "is_glb\<^sub>X {x, y} (x \<sqinter>\<^sub>X y)"
    by (auto intro!: meet_glb)
  show
      "is_glb\<^sub>Y {x, y} (x \<sqinter>\<^sub>X y)"
    apply (intro Y.is_glbI)
    apply (auto simp add: subset_order_def op2rel_def rel2op_def b1 b2 a1 [rule_format])
  proof -
    show "x \<sqinter>\<^sub>X y \<sqsubseteq>\<^sub>X x"
      apply (rule X.is_glbD1' [OF b3])
      apply (simp)
      done
    show "x \<sqinter>\<^sub>X y \<sqsubseteq>\<^sub>X y"
      apply (rule X.is_glbD1' [OF b3])
      apply (simp)
      done
    fix
      b
    assume
        "b \<in> Y" "b \<sqsubseteq>\<^sub>X x" "b \<sqsubseteq>\<^sub>X y"
    with subset_Y show
        "b \<sqsubseteq>\<^sub>X x \<sqinter>\<^sub>X y"
      apply (intro X.is_glbD2' [OF b3])
      apply (auto)
      done
  qed
qed

lemma subjoinI:
  assumes
    a1: "\<forall> x y | x \<in> Y \<and> y \<in> Y \<bullet> x \<squnion>\<^sub>X y \<in> Y" and
    b1: "x \<in> Y" and b2: "y \<in> Y"
  shows
      "is_lub\<^sub>Y {x, y} (x \<squnion>\<^sub>X y)"
proof -
  from subset_Y b1 b2 have
    b3: "is_lub\<^sub>X {x, y} (x \<squnion>\<^sub>X y)"
    by (auto intro!: join_lub)
  show
      "is_lub\<^sub>Y {x, y} (x \<squnion>\<^sub>X y)"
    apply (intro Y.is_lubI)
    apply (auto simp add: subset_order_def op2rel_def rel2op_def b1 b2 a1 [rule_format])
  proof -
    show "x \<sqsubseteq>\<^sub>X x \<squnion>\<^sub>X y"
      apply (rule X.is_lubD1' [OF b3])
      apply (simp)
      done
    show "y \<sqsubseteq>\<^sub>X x \<squnion>\<^sub>X y"
      apply (rule X.is_lubD1' [OF b3])
      apply (simp)
      done
    fix b
    assume
      "b \<in> Y" "x \<sqsubseteq>\<^sub>X b" "y \<sqsubseteq>\<^sub>X b"
    with subset_Y show
        "x \<squnion>\<^sub>X y \<sqsubseteq>\<^sub>X b"
      apply (intro X.is_lubD2' [OF b3])
      apply (auto)
      done
  qed
qed

lemma sublatticeI':
  assumes
    a1: "(\<forall> x y | x \<in> Y \<and> y \<in> Y \<bullet> x \<sqinter>\<^sub>X y \<in> Y \<and> x \<squnion>\<^sub>X y \<in> Y)"
  shows
      "\<^lattice>{:Y:}{:(op \<preceq>\<^sub>Y):}"
  apply (rule Y.latticeI)
  apply (auto intro!: exI submeetI subjoinI simp add: subset_Y a1 [rule_format])
  done

end

locale X_clattice =
  X: clattice X r
for
  X::"'a set" and
  r::"'a orderT"

begin

notation
  X.Meet ("\<Sqinter>\<^sub>X_") and
  X.Join ("\<Squnion>\<^sub>X_")

notation
  X.Bottom ("\<bottom>\<^sub>X") and
  X.Top ("\<top>\<^sub>X")

end

sublocale X_clattice \<subseteq> X_lattice
  by (unfold_locales)

locale Y_clattice =
  Y: clattice Y s
for
  Y::"'a set" and
  s::"'a orderT"

begin

notation
  Y.Meet ("\<Sqinter>\<^sub>Y_") and
  Y.Join ("\<Squnion>\<^sub>Y_")

notation
  Y.Bottom ("\<bottom>\<^sub>Y") and
  Y.Top ("\<top>\<^sub>Y")

end

sublocale Y_clattice \<subseteq> Y_lattice
  by (unfold_locales)

locale sub_clattice =
  sub_partial_order +
  X_clattice

begin

lemmas sub_clattice_lattice = X.clattice

lemmas sub_clattice_Y_poI = Y_poI

lemma subclatticeI:
  assumes
    ex_glb: "\<And> A \<bullet> A \<subseteq> Y \<turnstile> (\<exists> a \<bullet> is_glb\<^sub>Y A a)" and
    ex_lub: "\<And> A \<bullet> A \<subseteq> Y \<turnstile> (\<exists> a \<bullet> is_lub\<^sub>Y A a)"
  shows
      "clattice Y (op \<preceq>\<^sub>Y)"
  using Y.clatticeI ex_glb ex_lub subset_Y
  by (auto)

lemma subMeetI:
  assumes
    a1: "\<forall> A | A \<subseteq> Y \<bullet> (\<Sqinter>\<^sub>XA) \<in> Y" and
    b1: "A \<subseteq> Y"
  shows
      "is_glb\<^sub>Y A (\<Sqinter>\<^sub>XA)"
proof -
  from subset_Y a1 b1 have
    b3: "is_glb\<^sub>X A (\<Sqinter>\<^sub>XA)"
    by (auto intro!: Meet_glb)
  show
      "is_glb\<^sub>Y A (\<Sqinter>\<^sub>XA)"
  proof (rule Y.is_glbI)
    from a1 b1 show
        "(\<Sqinter>\<^sub>XA) \<in> Y"
      by (auto)
  next
    fix
      x
    assume
      c1: "x \<in> A"
    from c1 b1 subset_Y have
        "(\<Sqinter>\<^sub>XA) \<sqsubseteq>\<^sub>X x"
      apply (intro Meet_lbD)
      apply (auto)
      done
    with c1 b1 a1 subset_Y show
        "(\<Sqinter>\<^sub>XA) \<preceq>\<^sub>Y x"
      by (auto simp add: subset_order_def op2rel_def rel2op_def)
  next
    fix a
    assume
      c1: "a \<in> Y" and
      c2: "\<forall> x | x \<in> A \<bullet> a \<preceq>\<^sub>Y x"
    from c2 have
      c3: "\<forall> x | x \<in> A \<bullet> a \<preceq> x"
      by (auto simp add: subset_order_def op2rel_def rel2op_def)
    with c1 b1 subset_Y have
        "a \<sqsubseteq>\<^sub>X (\<Sqinter>\<^sub>XA)"
      apply (intro Meet_glbD)
      apply (auto simp add: subset_order_def op2rel_def rel2op_def)
      done
    with c1 b1 a1 show
        "a \<preceq>\<^sub>Y (\<Sqinter>\<^sub>XA)"
      by (simp add: subset_order_def op2rel_def rel2op_def)
  qed
qed

lemma subJoinI:
  assumes
    a1: "(\<forall> A | A \<subseteq> Y \<bullet> (\<Squnion>\<^sub>XA) \<in> Y)" and
    b1: "A \<subseteq> Y"
  shows
      "is_lub\<^sub>Y A (\<Squnion>\<^sub>XA)"
proof -
  from b1 subset_Y have
    b3: "is_lub\<^sub>X A (\<Squnion>\<^sub>XA)"
    by (auto intro!: Join_lub)
  show
      "is_lub\<^sub>Y A (\<Squnion>\<^sub>XA)"
  proof (rule Y.is_lubI)
    from b1 a1 show
        "(\<Squnion>\<^sub>XA) \<in> Y"
      by (auto)
  next
    fix
      x
    assume
      c1: "x \<in> A"
    from c1 b1 subset_Y have
        "x \<sqsubseteq>\<^sub>X (\<Squnion>\<^sub>XA)"
      apply (intro Join_ubD)
      apply (auto)
      done
    with c1 b1 a1 subset_Y show
        "x \<preceq>\<^sub>Y (\<Squnion>\<^sub>XA)"
      by (auto simp add: subset_order_def op2rel_def rel2op_def)
  next
    fix a
    assume
      c1: "a \<in> Y" and
      c2: "(\<forall> x | x \<in> A \<bullet> x \<preceq>\<^sub>Y a)"
    from c2 have
      c3: "(\<forall> x | x \<in> A \<bullet> x \<sqsubseteq>\<^sub>X a)"
      by (auto simp add: subset_order_def op2rel_def rel2op_def)
    with c1 b1 subset_Y have
        "(\<Squnion>\<^sub>XA) \<sqsubseteq>\<^sub>X a"
      apply (intro Join_lubD)
      apply (auto)
      done
    with c1 b1 a1 show
        "(\<Squnion>\<^sub>XA) \<preceq>\<^sub>Y a"
      by (simp add: subset_order_def op2rel_def rel2op_def)
  qed
qed

lemma subclatticeI':
  assumes
    a3: "(\<And> A \<bullet> A \<subseteq> Y \<turnstile> (\<Sqinter>\<^sub>XA) \<in> Y)" and
    a4: "(\<And> A \<bullet> A \<subseteq> Y \<turnstile> (\<Squnion>\<^sub>XA) \<in> Y)"
  shows
    "\<^clattice>{:Y:}{:(op \<preceq>\<^sub>Y):}"
  apply (rule Y.clatticeI)
  apply (auto intro!: exI subJoinI subMeetI a3 a4)
  done

end (* locale clattice_subset *)

end (* theory Lattice_Locale*)


(*
    File:     Generated_Groups_Extend.thy
    Author:   Joseph Thommes, TU München
*)
section \<open>Generated Groups\<close>

theory Generated_Groups_Extend
  imports Miscellaneous_Groups
begin

text \<open>This section extends the lemmas and facts about \<open>generate\<close>. Starting with a basic fact.\<close>

lemma (in group) generate_sincl:
  "A \<subseteq> generate G A"
  using generate.incl by fast

text \<open>The following lemmas reflect some of the idempotence characteristics of \<open>generate\<close> and have
proved useful at several occasions.\<close>

lemma (in group) generate_idem:
  assumes "A \<subseteq> carrier G"
  shows "generate G (generate G A) = generate G A"
  using assms generateI group.generate_is_subgroup by blast

lemma (in group) generate_idem':
  assumes "A \<subseteq> carrier G" "B \<subseteq> carrier G"
  shows "generate G (generate G A \<union> B) = generate G (A \<union> B)"
proof
  show "generate G (generate G A \<union> B) \<subseteq> generate G (A \<union> B)"
  proof -
    have "generate G A \<union> B \<subseteq> generate G (A \<union> B)"
    proof -
      have "generate G A \<subseteq> generate G (A \<union> B)" using mono_generate by simp
      moreover have "B \<subseteq> generate G (A \<union> B)" by (simp add: generate.incl subset_iff)
      ultimately show ?thesis by simp
    qed
    then have "generate G (generate G A \<union> B) \<subseteq> generate G (generate G (A \<union> B))"
      using mono_generate by auto
    with generate_idem[of "A \<union> B"] show ?thesis using assms by simp
  qed
  show "generate G (A \<union> B) \<subseteq> generate G (generate G A \<union> B)"
  proof -
    have "A \<subseteq> generate G A" using generate.incl by fast
    thus ?thesis using mono_generate[of "A \<union> B" "generate G A \<union> B"] by blast
  qed
qed

lemma (in group) generate_idem'_right:
  assumes "A \<subseteq> carrier G" "B \<subseteq> carrier G"
  shows "generate G (A \<union> generate G B) = generate G (A \<union> B)"
  using generate_idem'[OF assms(2) assms(1)] by (simp add: sup_commute)

lemma (in group) generate_idem_Un:
  assumes "A \<subseteq> carrier G"
  shows "generate G (\<Union>x\<in>A. generate G {x}) = generate G A"
proof
  have "A \<subseteq> (\<Union>x\<in>A. generate G {x})" using generate.incl by force
  thus "generate G A \<subseteq> generate G (\<Union>x\<in>A. generate G {x})" using mono_generate by presburger
  have "\<And>x. x \<in> A \<Longrightarrow> generate G {x} \<subseteq> generate G A" using mono_generate by auto
  hence "(\<Union>x\<in>A. generate G {x}) \<subseteq> generate G A" by blast
  thus "generate G (\<Union>x\<in>A. generate G {x}) \<subseteq> generate G A"
    using generate_idem[OF assms] mono_generate by blast
qed

lemma (in group) generate_idem_fUn:
  assumes "f A \<subseteq> carrier G"
  shows "generate G (\<Union> {generate G {x} |x. x \<in> f A}) = generate G (f A)"
proof
  have "f A \<subseteq> \<Union> {generate G {x} |x. x \<in> f A}"
  proof
    fix x
    assume x: "x \<in> f A"
    have "x \<in> generate G {x}" using generate.incl by fast
    thus "x \<in> \<Union> {generate G {x} |x. x \<in> f A}" using x by blast
  qed
  thus "generate G (f A) \<subseteq> generate G (\<Union> {generate G {x} |x. x \<in> f A})" using mono_generate by auto
  have "\<And>x. x \<in> f A \<Longrightarrow> generate G {x} \<subseteq> generate G (f A)" using mono_generate by simp
  hence "(\<Union> {generate G {x} |x. x \<in> f A}) \<subseteq> generate G (f A)" by blast
  with mono_generate[OF this] show "generate G (\<Union> {generate G {x} |x. x \<in> f A}) \<subseteq> generate G (f A)"
    using generate_idem[OF assms] by simp
qed

lemma (in group) generate_idem_fim_Un:
  assumes "\<Union>(f ` A) \<subseteq> carrier G"
  shows "generate G (\<Union>S \<in> A. generate G (f S)) = generate G (\<Union> {generate G {x} |x. x \<in> \<Union> (f ` A)})"
proof

  have "\<And>S. S \<in> A \<Longrightarrow> generate G (f S) = generate G (\<Union> {generate G {x} |x. x \<in> f S})"
    using generate_idem_fUn[of f] assms by blast
  then have "generate G (\<Union>S \<in> A. generate G (f S))
           = generate G (\<Union>S \<in> A. generate G (\<Union> {generate G {x} |x. x \<in> f S}))" by simp

  have "\<Union> {generate G {x} |x. x \<in> \<Union> (f ` A)} \<subseteq> (\<Union>S\<in>A. generate G (f S))"
  proof
    fix x
    assume x: "x \<in> \<Union> {generate G {x} |x. x \<in> \<Union> (f ` A)}"
    then obtain a where a: "x \<in> generate G {a}" "a \<in> \<Union> (f ` A)" by blast
    then obtain M where M: "a \<in> f M" "M \<in> A" by blast
    then have "generate G {a} \<subseteq> generate G (f M)"
      using generate.incl[OF M(1), of G] mono_generate[of "{a}" "generate G (f M)"]
            generate_idem assms by auto
    then have "x \<in> generate G (f M)" using a by blast
    thus "x \<in> (\<Union>S\<in>A. generate G (f S))" using M by blast
  qed
  thus "generate G (\<Union> {generate G {x} |x. x \<in> \<Union> (f ` A)}) \<subseteq> generate G (\<Union>S\<in>A. generate G (f S))"
    using mono_generate by simp
  have a: "generate G (\<Union>S\<in>A. generate G (f S)) \<subseteq> generate G (\<Union> (f ` A))"
  proof -
    have "\<And>S. S \<in> A \<Longrightarrow> generate G (f S) \<subseteq> generate G (\<Union> (f ` A))"
      using mono_generate[of _ "\<Union> (f ` A)"] by blast
    then have "(\<Union>S\<in>A. generate G (f S)) \<subseteq> generate G (\<Union> (f ` A))" by blast
    then have "generate G (\<Union>S\<in>A. generate G (f S)) \<subseteq> generate G (generate G (\<Union> (f ` A)))"
      using mono_generate by meson
    thus "generate G (\<Union>S\<in>A. generate G (f S)) \<subseteq>  generate G (\<Union> (f ` A))"
      using generate_idem assms by blast
  qed
  have "\<Union> {generate G {x} |x. x \<in> \<Union> (f ` A)} = (\<Union>x\<in>\<Union> (f ` A). generate G {x})" by blast
  with generate_idem_Un[OF assms]
  have "generate G (\<Union> {generate G {x} |x. x \<in> \<Union> (f ` A)}) = generate G (\<Union> (f ` A))" by simp
  with a show "generate G (\<Union>S\<in>A. generate G (f S))
             \<subseteq> generate G (\<Union> {generate G {x} |x. x \<in> \<Union> (f ` A)})" by blast
qed

text \<open>The following two rules allow for convenient proving of the equality of two generated sets.\<close>

lemma (in group) generate_eqI:
  assumes "A \<subseteq> carrier G" "B \<subseteq> carrier G" "A \<subseteq> generate G B" "B \<subseteq> generate G A"
  shows "generate G A = generate G B"
  using assms generate_idem by (metis generate_idem' inf_sup_aci(5) sup.absorb2)

lemma (in group) generate_one_switched_eqI:
  assumes "A \<subseteq> carrier G" "a \<in> A" "B = (A - {a}) \<union> {b}"
  and "b \<in> generate G A" "a \<in> generate G B"
  shows "generate G A = generate G B"
proof(intro generate_eqI)
  show "A \<subseteq> carrier G" by fact
  show "B \<subseteq> carrier G" using assms generate_incl by blast
  show "A \<subseteq> generate G B" using assms generate_sincl[of B] by blast
  show "B \<subseteq> generate G A" using assms generate_sincl[of A] by blast
qed

lemma (in group) generate_subset_eqI:
  assumes "A \<subseteq> carrier G" "B \<subseteq> A" "A - B \<subseteq> generate G B"
  shows "generate G A = generate G B"
proof
  show "generate G B \<subseteq> generate G A" by (intro mono_generate, fact)
  show "generate G A \<subseteq> generate G B"
  proof(subst generate_idem[of "B", symmetric])
    show "generate G A \<subseteq> generate G (generate G B)"
      by (intro mono_generate, use assms generate_sincl[of B] in auto)
  qed (use assms in blast)
qed

text \<open>Some smaller lemmas about \<open>generate\<close>.\<close>

lemma (in group) generate_subset_change_eqI:
  assumes "A \<subseteq> carrier G" "B \<subseteq> carrier G" "C \<subseteq> carrier G" "generate G A = generate G B"
  shows "generate G (A \<union> C) = generate G (B \<union> C)"
  by (metis assms generate_idem')

lemma (in group) generate_subgroup_id:
  assumes "subgroup H G"
  shows "generate G H = H"
  using assms generateI by auto

lemma (in group) generate_consistent':
  assumes "subgroup H G" "A \<subseteq> H"
  shows "\<forall>x \<in> A. generate G {x} = generate (G\<lparr>carrier := H\<rparr>) {x}"
  using generate_consistent assms by auto

lemma (in group) generate_singleton_one:
  assumes "generate G {a} = {\<one>}"
  shows "a = \<one>"
  using generate.incl[of a "{a}" G] assms by auto

lemma (in group) generate_inv_eq:
  assumes "a \<in> carrier G"
  shows "generate G {a} = generate G {inv a}"
  by (intro generate_eqI;
      use assms generate.inv[of a] generate.inv[of "inv a" "{inv a}" G] inv_inv[OF assms] in auto)

lemma (in group) generate_eq_imp_subset:
  assumes "generate G A = generate G B"
  shows "A \<subseteq> generate G B"
  using generate.incl assms by fast

text \<open>The neutral element does not play a role when generating a subgroup.\<close>

lemma (in group) generate_one_irrel:
  "generate G A = generate G (A \<union> {\<one>})"
proof
  show "generate G A \<subseteq> generate G (A \<union> {\<one>})" by (intro mono_generate, blast)
  show "generate G (A \<union> {\<one>}) \<subseteq> generate G A"
  proof(rule subsetI)
    show "x \<in> generate G A" if "x \<in> generate G (A \<union> {\<one>})" for x using that
      by (induction rule: generate.induct;
          use generate.one generate.incl generate.inv generate.eng in auto)
  qed
qed

lemma (in group) generate_one_irrel':
  "generate G A = generate G (A - {\<one>})"
  using generate_one_irrel by (metis Un_Diff_cancel2)

text \<open>Also, we can express the subgroup generated by a singleton with finite order using just its
powers up to its order.\<close>

lemma (in group) generate_nat_pow:
  assumes "ord a \<noteq> 0" "a \<in> carrier G"
  shows "generate G {a} = {a [^] k |k. k \<in> {0..ord a - 1}}"
  using assms generate_pow_nat ord_elems_inf_carrier by auto

lemma (in group) generate_nat_pow':
  assumes "ord a \<noteq> 0" "a \<in> carrier G"
  shows "generate G {a} = {a [^] k |k. k \<in> {1..ord a}}"
proof -
  have "{a [^] k |k. k \<in> {1..ord a}} = {a [^] k |k. k \<in> {0..ord a - 1}}"
  proof -
    have "a [^] k \<in> {a [^] k |k. k \<in> {0..ord a - 1}}" if "k \<in> {1..ord a}" for k
      using that pow_nat_mod_ord[OF assms(2, 1), of "ord a"] assms by (cases "k = ord a"; force)
    moreover have "a [^] k \<in> {a [^] k |k. k \<in> {1..ord a}}" if "k \<in> {0..ord a - 1}" for k
    proof(cases "k = 0")
      case True
      hence "a [^] k = a [^] ord a" using pow_ord_eq_1[OF assms(2)] by auto
      moreover have "ord a \<in> {1..ord a}"
        using assms unfolding atLeastAtMost_def atLeast_def atMost_def by auto
      ultimately show ?thesis by blast
    next
      case False
      then show ?thesis using that by auto
    qed
    ultimately show ?thesis by blast
  qed
  with generate_nat_pow[OF assms] show ?thesis by simp
qed

end