(***********************************************************************
* 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_Class

imports
  Lattice_Locale

begin

text {*

In order to do applied reasoning with lattices, we introduce axiomatic
classes for the various kinds of lattice.

*}

section {* Binary Lattices *}

text {*

A lattice is an order with pairwise meets and joins.

*}

class lat = ord +

fixes
  oinf :: "['a,'a] \<rightarrow> 'a" (infixl "&&" 70) and
  osup :: "['a,'a] \<rightarrow> 'a" (infixl "||" 65)

begin

end

class lattice = order + lat +
assumes
  inf_lb1: "x && y \<le> x" and
  inf_lb2: "x && y \<le> y" and
  inf_glb: "\<lbrakk> z \<le> x; z \<le> y \<rbrakk> \<turnstile> z \<le> x && y" and
  sup_ub1: "x \<le> x || y" and
  sup_ub2: "y \<le> x || y" and
  sup_lub: "\<lbrakk> x \<le> z; y \<le> z \<rbrakk> \<turnstile> x || y \<le> z"

begin

end

text {*

When discussing lattices we write
@{text "(op \<llt>)"} for less-than and
@{text "(op \<linf>)"} for infimum (meet) and
@{text "(op \<lsup>)"} for supremum (join).

*}

abbreviation
  linf :: "['a,'a] \<rightarrow> ('a::lattice)"
where
  "linf \<defs> oinf"

abbreviation
  lsup :: "['a,'a] \<rightarrow> ('a::lattice)"
where
  "lsup \<defs> osup"

notation (xsymbols)
  linf (infixl "\<linf>" 70) and
  lsup (infixl "\<lsup>" 65)

syntax ("" output)
  "_Lattice_Class\<ZZ>le" :: "['a::lattice,'a] \<rightarrow> bool" (infixl "[=" 50)
  "_Lattice_Class\<ZZ>lt" :: "['a::lattice,'a] \<rightarrow> bool" (infixl "[" 50)
  "_Lattice_Class\<ZZ>ge" :: "['a::lattice,'a] \<rightarrow> bool" (infixl "]=" 50)
  "_Lattice_Class\<ZZ>gt" :: "['a::lattice,'a] \<rightarrow> bool" (infixl "]" 50)

syntax (xsymbols output)
  "_Lattice_Class\<ZZ>le" :: "['a::lattice,'a] \<rightarrow> bool" (infixl "\<sqsubseteq>" 50)
  "_Lattice_Class\<ZZ>lt" :: "['a::lattice,'a] \<rightarrow> bool" (infixl "\<sqsubset>" 50)
  "_Lattice_Class\<ZZ>ge" :: "['a::lattice,'a] \<rightarrow> bool" (infixl "\<sqsupseteq>" 50)
  "_Lattice_Class\<ZZ>gt" :: "['a::lattice,'a] \<rightarrow> bool" (infixl "\<sqsupset>" 50)

syntax (zed)
  "_Lattice_Class\<ZZ>le" :: "['a::lattice,'a] \<rightarrow> bool" (infixl "\<lle>" 50)
  "_Lattice_Class\<ZZ>lt" :: "['a::lattice,'a] \<rightarrow> bool" (infixl "\<llt>" 50)
  "_Lattice_Class\<ZZ>ge" :: "['a::lattice,'a] \<rightarrow> bool" (infixl "\<lge>" 50)
  "_Lattice_Class\<ZZ>gt" :: "['a::lattice,'a] \<rightarrow> bool" (infixl "\<lgt>" 50)

parse_translation {*
let
  val dlattT = TFree("'_dummy_", [@{class "lattice"}]);
  val dlordT =
    dlattT --> dlattT --> boolT;
  fun trT nm _ [a, b] =
    Const(nm, dlordT) $ a $ b
    | trT nm _ [a] =
    Const(nm, dlordT) $ a
    | trT nm _ [] =
    Const(nm, dlordT);
in
  [(@{syntax_const "_Lattice_Class\<ZZ>le"}, trT @{const_syntax "less_eq"}),
   (@{syntax_const "_Lattice_Class\<ZZ>lt"}, trT @{const_syntax "less"}),
   (@{syntax_const "_Lattice_Class\<ZZ>ge"}, trT @{const_syntax "great_eq"}),
   (@{syntax_const "_Lattice_Class\<ZZ>gt"}, trT @{const_syntax "great"})]
end;
*}

definition
  ch_lle :: "['a::lattice,'a] \<rightarrow> bool"
where
  ch_lle_def: "ch_lle x y \<defs> x \<lle> y"

definition
  ch_llt :: "['a::lattice,'a] \<rightarrow> bool"
where
  ch_llt_def: "ch_llt x y \<defs> x \<llt> y"

definition
  ch_lge :: "['a::lattice,'a] \<rightarrow> bool"
where
  ch_lge_def: "ch_lge x y \<defs> x \<lge> y"

definition
  ch_lgt :: "['a::lattice,'a] \<rightarrow> bool"
where
  ch_lgt_def: "ch_lgt x y \<defs> x \<lgt> y"

syntax (xsymbols output)
  "_Lattice_Class\<ZZ>ch_lle" :: "['a, chainelt] \<rightarrow> chainrel" (infixr "\<sqsubseteq>" 50)
  "_Lattice_Class\<ZZ>ch_llt" :: "['a, chainelt] \<rightarrow> chainrel" (infixr "\<sqsubset>" 50)
  "_Lattice_Class\<ZZ>ch_lge" :: "['a, chainelt] \<rightarrow> chainrel" (infixr "\<sqsupseteq>" 50)
  "_Lattice_Class\<ZZ>ch_lgt" :: "['a, chainelt] \<rightarrow> chainrel" (infixr "\<sqsupset>" 50)

syntax (zed)
  "_Lattice_Class\<ZZ>ch_lle" :: "['a, chainelt] \<rightarrow> chainrel" (infixr "\<chLle>" 50)
  "_Lattice_Class\<ZZ>ch_llt" :: "['a, chainelt] \<rightarrow> chainrel" (infixr "\<chLlt>" 50)
  "_Lattice_Class\<ZZ>ch_lge" :: "['a, chainelt] \<rightarrow> chainrel" (infixr "\<chLge>" 50)
  "_Lattice_Class\<ZZ>ch_lgt" :: "['a, chainelt] \<rightarrow> chainrel" (infixr "\<chLgt>" 50)

parse_translation {*

[
  (chNode_tr "Lattice_Class" "ch_llt"),
  (chNode_tr "Lattice_Class" "ch_lle"),
  (chNode_tr "Lattice_Class" "ch_lgt"),
  (chNode_tr "Lattice_Class" "ch_lge")
]

*}

print_translation {*

[
  (chNode_tr' "Lattice_Class" "ch_llt"),
  (chNode_tr' "Lattice_Class" "ch_lle"),
  (chNode_tr' "Lattice_Class" "ch_lgt"),
  (chNode_tr' "Lattice_Class" "ch_lge")
]

*}

text {*

We provide a typed print translation to ensure that order predicates
only use the square cup sign when the arguments are of lattice sort.
Also for some lattices (eg nat) it may not be appropriate to use
the square cup, so we introduce a trivial class @{text "nonsqord"}
which can be used to suppress it.
Since it is not conventional to use the squared cup sign on
numbers, we suppress this translation for any type of @{text number}
class, whether a lattice or not.

*}

class
  nonsqord = lattice

typed_print_translation {*
let
  fun ck_lat sgn (Type(@{type_name "fun"}, (typ::_))) =
  let
    val ityp = typ;
  in
    Sign.of_sort sgn (ityp, [@{class "lattice"}]) andalso
    not (Sign.of_sort sgn (ityp, [@{class "nonsqord"}]))
(* andalso
    not (Sign.of_sort sgn (ityp, [@{class "number"}]))
*)
  end
   |  ck_lat _ _ = false;
  fun trT' nml ctxt typ ts =
    if ck_lat (Proof_Context.theory_of ctxt) typ then
      list_comb (Syntax.const nml, ts)
    else
      raise Match;
in
  [(@{const_syntax "less"}, trT' @{syntax_const "_Lattice_Class\<ZZ>lt"}),
   (@{const_syntax "less_eq"}, trT' @{syntax_const "_Lattice_Class\<ZZ>le"}),
   (@{const_syntax "great"}, trT' @{syntax_const "_Lattice_Class\<ZZ>gt"}),
   (@{const_syntax "great_eq"}, trT' @{syntax_const "_Lattice_Class\<ZZ>ge"})]
end;
*}

lemma inf_glbI:
    "\<^glbp>{:\<univ>:}{:(op \<lle>):} {x, y} (x \<linf> y)"
  apply (rule order_class.is_glbI)
  apply (auto intro!: inf_lb1 inf_lb2 inf_glb)
  done

lemma sup_lubI:
    "\<^lubp>{:\<univ>:}{:(op \<lle>):} {x, y} (x \<lsup> y)"
  apply (rule order_class.is_lubI)
  apply (auto intro!: sup_ub1 sup_ub2 sup_lub)
  done

theorem lattice_classI:
  assumes
    a1: "\<^lattice>{:\<univ>-[('a::{order, lat})]:}{:(op \<le>):}" and
    a2: "\<And> x y \<bullet> x && y = x \<^meet>{:\<univ>-[('a::{order, lat})]:}{:(op \<le>):} y" and
    a3: "\<And> x y \<bullet> x || y = x \<^join>{:\<univ>-[('a::{order, lat})]:}{:(op \<le>):} y"
  shows
      "OFCLASS('a::{order, lat}, lattice_class)"
  apply (intro_classes)
  apply (auto simp add: a2 a3)
  apply (auto intro!:
    lattice.meet_lbD1 [OF a1] lattice.meet_lbD2 [OF a1] lattice.meet_glbD [OF a1]
    lattice.join_ubD1 [OF a1] lattice.join_ubD2 [OF a1] lattice.join_lubD [OF a1])
  done

lemma lattice_classD:
    "\<^lattice>{:\<univ>-[('a::lattice)]:}{:(op \<lle>):}"
  apply (rule order_class.latticeI)
  apply (auto intro!: exI inf_glbI sup_lubI)
  done

lemma lattice_class_defaultD:
  assumes
    a1: "X \<noteq> \<emptyset>" and
    a2: "\<And> a b \<bullet> \<lbrakk> a \<in> X; b \<in> X \<rbrakk> \<turnstile> a \<linf> b \<in> X" and
    a3: "\<And> a b \<bullet> \<lbrakk> a \<in> X; b \<in> X \<rbrakk> \<turnstile> a \<lsup> b \<in> X"
  shows
    "\<^lattice>{:X:}{:(default_order X):}"
proof -
  from a1 interpret
    def_po: po_carrier X
    by (unfold_locales)
  from def_po.partial_order show
    "\<^lattice>{:X:}{:(default_order X):}"
  proof (unfold_locales)
    fix a b
    assume
      b1: "a \<in> X" and
      b2: "b \<in> X"
    show
        "(\<exists> x \<bullet> \<^glbp>{:X:}{:(default_order X):} {a, b} x)"
      apply (witness "a \<linf> b")
      apply (rule def_po.is_glbI)
      apply (auto intro!: inf_lb1 inf_lb2 inf_glb simp add: default_order_def subset_order_def rel2op_def op2rel_def b1 b2 a2)
      done
    show
        "(\<exists> x \<bullet> \<^lubp>{:X:}{:(default_order X):} {a, b} x)"
      apply (witness "a \<lsup> b")
      apply (rule def_po.is_lubI)
      apply (auto intro!: sup_ub1 sup_ub2 sup_lub simp add: default_order_def subset_order_def rel2op_def op2rel_def b1 b2 a3)
      done
  qed
qed

interpretation lattice_class_interpretation: Lattice_Locale.lattice "\<univ>-[('a::lattice)]" "(op <=)"
  by (rule lattice_classD)

lemma
  inf_meet: "(op \<linf>) = (\<olambda> x y \<bullet> x \<^meet>{:\<univ>:}{:(op <=):} y)"
  apply (intro ext)
  apply (rule order_class.glb_unique)
  apply (auto intro: lattice_class_interpretation.meet_glb inf_glbI)
  done

lemma
  sup_join: "(op \<lsup>) = (\<olambda> x y \<bullet> x \<^join>{:\<univ>:}{:(op <=):} y)"
  apply (intro ext)
  apply (rule order_class.lub_unique)
  apply (auto intro: lattice_class_interpretation.join_lub sup_lubI)
  done

text {*

We introduce introduction and elimination rules for making use of these
facts.

*}

lemma infE:
  assumes
    a1:
      "\<lbrakk>
        x \<linf> y \<lle> x;
        x \<linf> y \<lle> y;
        (\<And> z \<bullet> \<lbrakk> z \<le> x; z \<lle> y \<rbrakk> \<turnstile> z \<le> x \<linf> y)
       \<rbrakk> \<turnstile> R"
  shows
      "R"
proof -
  from a1 inf_glbI show R
    by (auto intro!: a1 simp add: is_glb_def is_greatest_def is_lb_def)
qed

lemma inf_lb1:
    "x \<linf> y \<lle> x"
  by (rule infE, auto)

lemma inf_lb2:
    "x \<linf> y \<lle> y"
  by (rule infE, auto)

lemma inf_glb:
    "\<lbrakk> z \<lle> x; z \<lle> y \<rbrakk> \<turnstile> z \<lle> x \<linf> y"
  by (rule infE [of x y]) (auto)

lemma inf_eq:
  "\<lbrakk>
    a \<lle> x;
    a \<lle> y;
    (\<And> z \<bullet> \<lbrakk> z \<le> x; z \<lle> y \<rbrakk> \<turnstile> z \<lle> a)
   \<rbrakk> \<turnstile> x \<linf> y = a"
  by (auto intro!: order_class.meet_unique [symmetric] order_class.is_glbI simp add: inf_meet)

lemma supE:
  assumes
    a1:
      "\<lbrakk>
        x \<lle> x \<lsup> y;
        y \<lle> x \<lsup> y;
        (\<And> z \<bullet> \<lbrakk> x \<le> z; y \<lle> z \<rbrakk> \<turnstile> x \<lsup> y \<le> z)
       \<rbrakk> \<turnstile> R"
  shows
      "R"
proof -
  from a1 sup_lubI show
      R
    by (auto intro!: a1 simp add: is_lub_def is_least_def is_ub_def)
qed

lemma sup_ub1:
    "x \<lle> x \<lsup> y"
  by (rule supE, auto)

lemma sup_ub2:
    "y \<lle> x \<lsup> y"
  by (rule supE, auto)

lemma sup_lub:
    "\<lbrakk> x \<lle> z; y \<lle> z \<rbrakk> \<turnstile> x \<lsup> y \<lle> z"
  by (rule supE [of x y]) (auto)

lemma sup_eq:
    "\<lbrakk>
      x \<lle> s;
      y \<lle> s;
      (\<And> z \<bullet> \<lbrakk> x \<le> z; y \<lle> z \<rbrakk> \<turnstile> s \<lle> z)
     \<rbrakk> \<turnstile> x \<lsup> y = s"
  by (auto intro!: order_class.join_unique [symmetric] order_class.is_lubI simp add: sup_join)

text {*

Meet and join are monotonic, idempotent, commutative, associative, and
absorbative.

*}

lemma inf_idem:
    "x \<linf> x = x"
  apply (rule inf_eq)
  apply (auto)
  done

lemma sup_idem:
    "x \<lsup> x = x"
  apply (rule sup_eq)
  apply (auto)
  done

lemma inf_com:
    "x \<linf> y = y \<linf> x"
  by (rule infE, rule inf_eq [THEN sym], auto)

lemma sup_com:
    "x \<lsup> y = y \<lsup> x"
  by (rule supE, rule sup_eq [THEN sym], auto)

lemma [mintro!(wind)]:
    "p = p' \<turnstile> p \<linf> q = p' \<linf> q"
    "q = q' \<turnstile> p \<linf> q = p \<linf> q'"
  by (auto)

lemma [mintro!(wind)]:
    "p = p' \<turnstile> p \<lsup> q = p' \<lsup> q"
    "q = q' \<turnstile> p \<lsup> q = p \<lsup> q'"
  by (auto)

lemma inf_mono1 [mintro!(wind)]:
  assumes
    a1: "x \<lle> x'"
  shows
      "x \<linf> y \<lle> x' \<linf> y"
proof (rule inf_glb)
  show
      "x \<linf> y \<lle> x'"
    by (rule a1 [THEN [2] order_trans], rule infE, assumption)
  show
      "x \<linf> y \<lle> y"
    by (rule infE, assumption)
qed

lemma inf_mono2 [mintro!(wind)]:
    "x \<lle> x' \<turnstile> y \<linf> x \<lle> y \<linf> x'"
  by (simp add: inf_com, rule inf_mono1, auto)

lemmas inf_mono = inf_mono2 [THEN [2] inf_mono1 [THEN order_trans]]

lemma sup_mono1 [mintro!(wind)]:
  assumes
    a1: "x \<lle> x'"
  shows
      "x \<lsup> y \<lle> x' \<lsup> y"
proof (rule sup_lub)
  show
      "x \<lle> x' \<lsup> y"
    by (rule a1 [THEN order_trans], rule supE, assumption)
  show
      "y \<lle> x' \<lsup> y"
    by (rule supE, assumption)
qed

lemma sup_mono2 [mintro!(wind)]:
    "x \<lle> x' \<turnstile> y \<lsup> x \<lle> y \<lsup> x'"
  by (simp add: sup_com, rule sup_mono1, auto)

lemmas sup_mono = sup_mono2 [THEN [2] sup_mono1 [THEN order_trans]]

lemma inf_assoc:
    "(x \<linf> y) \<linf> z = x \<linf> (y \<linf> z)"
proof (rule sym, rule inf_eq [THEN sym])
  show
      "x \<linf> (y \<linf> z) \<lle> x \<linf> y"
    by (rule inf_mono2, rule infE, auto)
  show
      "x \<linf> (y \<linf> z) \<lle> z"
    by (rule order_trans [of _ "y \<linf> z"], rule infE, auto,
      rule infE, auto)
  fix a
  assume
    a1: "a \<lle> x \<linf> y" and
    a2: "a \<le> z"
  have
    a3: "a \<le> x"
    by (rule a1 [THEN order_trans], rule infE, auto)
  have
    a4: "a \<le> y"
    by (rule a1 [THEN order_trans], rule infE, auto)
  have
    a5: "a \<le> y \<linf> z"
    by (rule a2 [THEN a4 [THEN inf_glb]])
  show
      "a \<le> x \<linf> (y \<linf> z)"
    by (auto intro: inf_glb a3 a5)
qed

lemma sup_assoc:
    "(x \<lsup> y) \<lsup> z = x \<lsup> (y \<lsup> z)"
proof (rule sym, rule sup_eq [THEN sym])
  show
      "x \<lsup> y \<lle> x \<lsup> (y \<lsup> z)"
    by (rule sup_mono2, rule supE, auto)
  show
      "z \<lle> x \<lsup> (y \<lsup> z)"
    by (rule order_trans [of _ "y \<lsup> z"], rule supE, auto,
      rule supE, auto)
  fix a
  assume
    a1: "x \<lsup> y \<lle> a" and
    a2: "z \<le> a"
  have
    a3: "x \<le> a"
    by (rule a1 [THEN [2] order_trans], rule supE, auto)
  have
    a4: "y \<le> a"
    by (rule a1 [THEN [2] order_trans], rule supE, auto)
  have
    a5: "y \<lsup> z \<le> a"
    by (rule a2 [THEN a4 [THEN sup_lub]])
  show
      "x \<lsup> (y \<lsup> z) \<le> a"
    by (auto intro: sup_lub a3 a5)
qed

lemma inf_lcom:
  "x \<linf> (y \<linf> z) = y \<linf> (x \<linf> z)"
proof -
  have
      "x \<linf> (y \<linf> z)
      = (x \<linf> y) \<linf> z"
    by (simp add: inf_assoc)
  also have "\<dots>
      = (y \<linf> x) \<linf> z"
    by (simp add: inf_com)
  also have "\<dots>
      = y \<linf> (x \<linf> z)"
    by (simp add: inf_assoc)
  finally show
      ?thesis
    by (this)
qed

lemma sup_lcom:
    "x \<lsup> (y \<lsup> z) = y \<lsup> (x \<lsup> z)"
proof -
  have
      "x \<lsup> (y \<lsup> z)
      = (x \<lsup> y) \<lsup> z"
    by (simp add: sup_assoc)
  also have "\<dots>
      = (y \<lsup> x) \<lsup> z"
    by (simp add: sup_com)
  also have "\<dots>
      = y \<lsup> (x \<lsup> z)"
    by (simp add: sup_assoc)
  finally show
      ?thesis
    by (this)
qed

lemmas lat_com_assoc = inf_com inf_assoc inf_lcom sup_com sup_assoc sup_lcom

lemma inf_absorption:
    "a \<linf> (a \<lsup> b) = a"
  by (rule supE, rule inf_eq, auto)

lemma sup_absorption:
    "a \<lsup> (a \<linf> b) = a"
  by (rule infE, rule sup_eq, auto)

text {*

The meet (join) of two elements is equal to one of them if and only if
they are related in the lattice order.

*}

lemma inf_min:
  assumes
    a1: "x \<lle> y"
  shows
      "x \<linf> y = x"
  using a1
  by (auto intro:  inf_eq)

lemma inf_min':
  assumes
    a1: "x \<lle> y"
  shows
      "y \<linf> x = x"
  using a1
  by (auto intro:  inf_eq)

lemma sup_max:
  assumes
    a1: "x \<lle> y"
  shows
      "x \<lsup> y = y"
  using a1
  by (auto intro:  sup_eq)

lemma sup_max':
  assumes
    a1: "x \<lle> y"
  shows
      "y \<lsup> x = y"
  using a1
  by (auto intro:  sup_eq)

lemma min_inf:
  assumes
    a1: "x \<linf> y = x"
  shows
      "x \<lle> y"
  by (rule a1 [THEN subst], rule inf_lb2)

lemma max_sup:
  assumes
    a1: "x \<lsup> y = y"
  shows
      "x \<lsup> y = y \<turnstile> x \<lle> y"
  by (rule a1 [THEN subst], rule sup_ub1)

lemma inf_correspondence:
    "(x = x \<linf> y) = (x \<lle> y)"
proof (auto intro: inf_eq [THEN sym] simp add: order_antisym)
  assume
    a1: "x = x \<linf> y"
  show
      "x \<lle> y"
    by (rule a1 [THEN ssubst], rule infE [of x y], auto)
qed

lemma sup_correspondence:
    "(y = x \<lsup> y) = (x \<lle> y)"
proof (auto intro: sup_eq [THEN sym] simp add: order_antisym)
  assume
    a1: "y = x \<lsup> y"
  show
      "x \<lle> y"
    by (rule a1 [THEN ssubst], rule supE [of x y], auto)
qed

lemma inf_correspondence':
    "(x \<linf> y = x) = (x \<lle> y)"
proof (auto intro: inf_eq simp add: order_antisym)
  assume
    a1: "x \<linf> y = x"
  show
      "x \<lle> y"
    by (rule a1 [THEN sym, THEN ssubst], rule infE [of x y], auto)
qed

lemma sup_correspondence':
    "(x \<lsup> y = y) = (x \<lle> y)"
proof (auto intro: sup_eq simp add: order_antisym)
  assume
    a1: "x \<lsup> y = y"
  show
      "x \<lle> y"
    by (rule a1 [THEN sym,THEN ssubst], rule supE [of x y], auto)
qed

section {* Bounded lattices *}

text {*

A lattice with maximal amd minimal elements is said to be bounded.

*}

class blat = Lattice_Class.lat +

fixes
  bot :: "'a" and
  top :: "'a"

begin

end

class boundlattice = Lattice_Class.lattice + Lattice_Class.blat +

assumes
  bot_lb: "bot \<le> x"

assumes
  top_ub: "x \<le> top"

begin

end

abbreviation
  bl_bot :: "'a::boundlattice"
where
  "bl_bot \<defs> bot"

abbreviation
  bl_top :: "'a::boundlattice"
where
  "bl_top \<defs> top"

notation (xsymbols)
  bl_bot ("\<lbot>") and
  bl_top ("\<ltop>")

lemma bot_eq:
    "(\<forall> x \<bullet> y \<lle> x) \<turnstile> \<lbot> = y"
  by (rule order_antisym, auto intro: bot_lb)

lemma top_eq:
    "(\<forall> x \<bullet> x \<lle> y) \<turnstile> \<ltop> = y"
  by (rule order_antisym, auto intro: top_ub)

lemma bot_min:
    "x \<lle> \<lbot> \<Leftrightarrow> x = \<lbot>"
  apply (auto intro!: bot_eq [THEN sym])
  apply (rule order_trans)
  apply (assumption)
  apply (rule bot_lb)
  done

lemma top_max:
    "\<ltop> \<lle> x \<Leftrightarrow> x = \<ltop>"
  apply (auto intro!: top_eq [THEN sym])
  apply (rule order_trans)
  apply (rule top_ub)
  apply (assumption)
  done

lemmas lat_bounds =
  bot_lb [THEN inf_min]  bot_lb [THEN sup_max]
  top_ub [THEN inf_min]  top_ub [THEN sup_max]
  bot_lb [THEN inf_min [THEN inf_com [THEN trans]]]
  bot_lb [THEN sup_max [THEN sup_com [THEN trans]]]
  top_ub [THEN inf_min [THEN inf_com [THEN trans]]]
  top_ub [THEN sup_max [THEN sup_com [THEN trans]]]

section {* Complete lattices *}

text {*

A complete lattice is one for which every collection of elements has an
infimum (supremum).

*}

class clat = blat +

fixes
  Inf :: "'a set \<rightarrow> 'a" and
  Sup :: "'a set \<rightarrow> 'a"

class clattice = clat + order +

assumes
  Inf_lb: "x \<in> P \<turnstile> Inf P \<le> x" and
  Inf_glb: "(\<And> x \<bullet> x \<in> P \<turnstile> z \<le> x) \<turnstile> z \<le> Inf P" and
  Sup_ub: "x \<in> P \<turnstile> x \<le> Sup P" and
  Sup_lub: "(\<And> x \<bullet> x \<in> P \<turnstile> x \<le> z) \<turnstile> Sup P \<le> z" and
  inf_Inf: "x && y = Inf {x, y}" and
  sup_Sup: "x || y = Sup {x, y}" and
  bot_Inf: "bot = Inf \<univ>" and
  top_Sup: "top = Sup \<univ>"

abbreviation
  lInf :: "'a set \<rightarrow> ('a::clattice)"
where
  "lInf \<defs> Inf"

abbreviation
  lSup :: "'a set \<rightarrow> ('a::clattice)"
where
  "lSup \<defs> Sup"

notation (xsymbols output)
  lInf ("\<Sqinter>") and
  lSup ("\<Squnion>")

syntax (xsymbols output)
  "_Lattice_Class\<ZZ>lInfs" :: "schematext \<rightarrow> logic" ("(1\<Sqinter>_)" 10)
  "_Lattice_Class\<ZZ>lSups" :: "schematext \<rightarrow> logic" ("(1\<Squnion>_)" 10)

notation (zed)
  lInf ("\<lInf>") and
  lSup ("\<lSup>")

syntax (xsymbols)
  "_Lattice_Class\<ZZ>lInfs" :: "schematext \<rightarrow> logic" ("(1\<lINF> _)" 10)
  "_Lattice_Class\<ZZ>lSups" :: "schematext \<rightarrow> logic" ("(1\<lSUP> _)" 10)

translations
  "_Lattice_Class\<ZZ>lInfs S" \<rightleftharpoons> "CONST lInf (_xHOL_Syntax\<ZZ>coll S)"
  "_Lattice_Class\<ZZ>lSups S" \<rightleftharpoons> "CONST lSup (_xHOL_Syntax\<ZZ>coll S)"

lemma Inf_glbI:
    "\<^glbp>{:\<univ>:}{:(op \<le>):} X (\<lInf> X)"
  apply (rule order_class.is_glbI)
  apply (auto intro!: Inf_lb Inf_glb)
  done

lemma Sup_lubI:
    "\<^lubp>{:\<univ>:}{:(op \<le>):} X (\<lSup> X)"
  apply (rule order_class.is_lubI)
  apply (auto intro!: Sup_ub Sup_lub)
  done

interpretation clattice_class_interpretation: Lattice_Locale.clattice "\<univ>-[('a::clattice)]" "(op <=)"
  apply (intro_locales)
  apply (auto intro!: exI Inf_glbI Sup_lubI simp add: Lattice_Locale.clattice_axioms_def Lattice_Locale.lattice_axioms_def)
  done

instance
  clattice < lattice
  apply (intro_classes)
  apply (auto intro!: Inf_lb Inf_glb Sup_ub Sup_lub simp add: inf_Inf sup_Sup)
  done

lemma Inf_Meet:
  "\<^Meet>{:\<univ>-['a::clattice]:}{:op \<lle>:} = Inf"
  apply (rule ext)
  apply (rule clattice_class_interpretation.Meet_unique [symmetric])
  apply (auto intro: Inf_lb Inf_glb)
  done

lemma bot_Bottom:
    "\<^Bottom>{:\<univ>-['a::clattice]:}{:(op \<lle>):} = bot"
  by (simp add: Bottom_def bot_Inf Inf_Meet)

lemma Sup_Join:
  "\<^Join>{:\<univ>-['a::clattice]:}{:op \<lle>:} = Sup"
  apply (rule ext)
  apply (rule clattice_class_interpretation.Join_unique [symmetric])
  apply (auto intro: Sup_ub Sup_lub)
  done

lemma top_Top:
    "\<^Top>{:\<univ>-['a::clattice]:}{:(op \<lle>):} = top"
  by (simp add: Top_def top_Sup Sup_Join)

theorem clattice_classI:
  assumes
    a1: "\<^clattice>{:\<univ>-[('a::{clat, order})]:}{:(op <=):}" and
    a2: "\<And> x y \<bullet> x && y = x \<^meet>{:\<univ>-[('a::{order, clat})]:}{:(op <=):} y" and
    a3: "\<And> x y \<bullet> x || y = x \<^join>{:\<univ>-[('a::{order, clat})]:}{:(op <=):} y" and
    a4: "\<And> X \<bullet> Inf X = \<^Meet>{:\<univ>-[('a::{order, clat})]:}{:(op <=):} X" and
    a5: "\<And> X \<bullet> Sup X = \<^Join>{:\<univ>-[('a::{order, clat})]:}{:(op <=):} X" and
    a6: "\<And> X \<bullet> bot = \<^Meet>{:\<univ>-[('a::{order, clat})]:}{:(op <=):} \<univ>" and
    a7: "\<And> X \<bullet> top = \<^Join>{:\<univ>-[('a::{order, clat})]:}{:(op <=):} \<univ>"
  shows
      "OFCLASS('a::{clat, order}, clattice_class)"
  apply (intro_classes)
  using a1 a2 a3 a4 a5 a6 a7
  apply (auto intro!: clattice.Meet_lbD [OF a1] clattice.Join_ubD [OF a1] clattice.Meet_glbD [OF a1] clattice.Join_lubD [OF a1] clattice.meet_Meet [OF a1] clattice.join_Join [OF a1])
  done

lemma clattice_classD:
    "\<^clattice>{:\<univ>-[('a::clattice)]:}{:(op <=):}"
  apply (rule order_class.clatticeI)
  apply (auto intro!: exI Inf_glbI Sup_lubI)
  done

lemma InfE:
  assumes
    a1:
      "\<lbrakk>
        (\<And> x \<bullet> x \<in> P \<turnstile> \<lInf> P \<lle> x);
        (\<And> y \<bullet> (\<forall> x | x \<in> P \<bullet> y \<lle> x) \<turnstile> y \<lle> (\<lInf> P))
      \<rbrakk> \<turnstile> R"
  shows
      "R"
  apply (rule a1)
  apply (auto intro:
    order_class.is_glbD1' [OF Inf_glbI]
    order_class.is_glbD2' [OF Inf_glbI])
  done

lemma SupE:
  assumes
    a1:
      "\<lbrakk>
        (\<And> x \<bullet> x \<in> P \<turnstile> x \<lle> \<lSup> P);
        (\<And> y \<bullet> ( \<forall> x | x \<in> P \<bullet> x \<lle> y) \<turnstile> (\<lSup> P) \<lle> y)
      \<rbrakk> \<turnstile> R"
  shows
      "R"
  apply (rule a1)
  apply (auto intro:
    order_class.is_lubD1' [OF Sup_lubI]
    order_class.is_lubD2' [OF Sup_lubI])
  done

instance
  clattice < boundlattice
  apply (intro_classes)
  apply (auto simp add: bot_Inf top_Sup Inf_lb Sup_ub)
  done

lemma Inf_sub:
  assumes
    a1: "P \<subseteq> Q"
  shows
      "\<lInf> Q \<lle> \<lInf> P"
  apply (rule Inf_glb)
  apply (rule Inf_lb)
  using a1
  apply (auto)
  done

lemma QTInf_dom:
  assumes
    a1: "(\<forall> x | P x \<bullet> f x \<lle> g x)"
  shows
    "(\<lINF> x | P x \<bullet> f x) \<lle> (\<lINF> x | P x \<bullet> g x)"
proof (rule Inf_glb, auto)
  fix x
  assume
    a2: "P x"
  have
      "(\<lINF> x | P x \<bullet> f x)
      \<lle> f x"
    by (rule Inf_lb, auto intro!: exI [of _ x] a2)
  also have "\<dots>
      \<lle> g x"
    by (rule a1 [rule_format], rule a2)
  finally show
      " (\<lINF> x | P x \<bullet> f x) \<lle> g x"
    by (this)
qed

lemma QInf_dom:
  assumes
    a1: "(\<forall> x \<bullet> f x \<lle> g x)"
  shows
      "(\<lINF> x \<bullet> f x) \<lle> (\<lINF> x \<bullet> g x)"
proof (rule Inf_glb, auto)
  fix x
  have
      "(\<lINF> x \<bullet> f x)
      \<lle> f x"
    by (rule Inf_lb, auto intro!: exI [of _ x])
  also have "\<dots>
      \<lle> g x"
    by (rule a1 [rule_format])
  finally show
        "(\<lINF> x \<bullet> f x) \<lle> g x"
    by (this)
qed

lemma Inf_eq:
    "\<lbrakk>
      (\<And> x \<bullet> x \<in> P \<turnstile> z \<lle> x);
      (\<And> y \<bullet> (\<forall> x | x \<in> P \<bullet> y \<lle> x) \<turnstile> y \<lle> z)
    \<rbrakk> \<turnstile> (\<lInf>P) = z"
  apply (rule order_class.glb_unique [OF _ Inf_glbI])
  apply (auto intro!: order_class.is_glbI)
  done

lemma Min_eq:
    "\<lbrakk> \<And> x \<bullet> x \<in> P \<turnstile> z \<lle> x; z \<in> P \<rbrakk> \<turnstile> (\<lInf>P) = z"
  apply (rule Inf_eq)
  apply (auto intro: order_antisym)
  done

lemma inf_Inf:
    "x \<linf> y = \<lInf> {x,y}"
  by (rule inf_eq, auto intro: Inf_lb Inf_glb)

lemma Inf_inf:
    "(\<lInf> (P::('a::clattice) set)) \<linf> (\<lInf> Q) = \<lInf> (P \<union> Q)"
proof (rule Inf_eq [THEN sym], auto simp add: Ball_def)
  fix
    x::'a
  assume
    a1: "x \<in> P"
  show
      "(\<lInf> P) \<linf> (\<lInf> Q) \<lle> x"
    by (rule a1 [THEN Inf_lb [THEN inf_mono1 [THEN order_trans]]], rule inf_lb1)
next
  fix
    x::'a
  assume
    a1: "x \<in> Q"
  show
      "(\<lInf> P) \<linf> (\<lInf> Q) \<lle> x"
    by (rule a1 [THEN Inf_lb [THEN inf_mono2 [THEN order_trans]]], rule inf_lb2)
next
  fix
    y::'a
  assume
    a1: "\<forall> x::'a \<bullet> (x \<in> P \<Rightarrow> y \<lle> x) \<and> (x \<in> Q \<Rightarrow> y \<le> x)"
  show
      "y \<lle> (\<lInf> P) \<linf> (\<lInf> Q)"
  proof (intro inf_glb Inf_glb)
    fix
      x::'a
    assume
      b1: "x \<in> P"
    show
        "y \<le> x"
      by (insert a1, elim allE [of _ x], elim conjE, simp add: b1)
  next
    fix
      x::'a
    assume
      b1: "x \<in> Q"
    show
        "y \<le> x"
      by (insert a1, elim allE [of _ x], elim conjE, simp add: b1)
  qed
qed

lemma Inf_Inf:
    "(\<lINF> x | P x \<bullet> (\<lINF> y | Q x y \<bullet> f x y)) = (\<lINF> x y | P x \<and> Q x y \<bullet> f x y)"
  apply (rule Inf_eq)
  apply (auto)
  apply (rule Inf_sub)
  apply (simp add: subset_def)
  apply (fast)
  apply (rule Inf_glb)
  apply (auto)
  apply (elim allE impE)
  apply (assumption)
  apply (rule order_trans)
  apply (assumption)
  apply (rule Inf_lb)
  apply (auto)
  done

lemma Inf_empty:
    "\<lInf> \<emptyset> = \<ltop>"
  by (rule Inf_eq, auto, rule top_ub)

lemma Inf_singleton:
    "\<lInf> {x} = x"
  by (rule Inf_eq, auto)

lemma Inf_top_unique:
    "\<lInf> X = \<ltop> \<Leftrightarrow> X = {\<ltop>} \<or> X = \<emptyset>"
proof (rule iffI)
  assume
    b1: "\<lInf> X = \<ltop>"
  have
      "(\<forall> x | x \<in> X \<bullet> \<ltop> \<lle> x)"
    by (auto simp add: b1 [symmetric] Inf_lb)
  then have
      "(\<forall> x | x \<in> X \<bullet> x = \<ltop>)"
    by (auto simp add: top_max)
  then show
      "X = {\<ltop>} \<or> X = \<emptyset>"
    by (auto)
qed (auto simp add: Inf_empty Inf_singleton)

lemma Inf_collect:
    "\<lInf> {x::'a::clattice, \<lInf> P} = \<lInf> ({x} \<union> P)"
proof (rule Inf_eq, safe, auto)
  show
      "\<lInf> (insert x P) \<lle> x"
    by (rule Inf_lb, simp)
  show
      "\<lInf> (insert x P) \<lle> \<lInf> P"
    by (rule Inf_glb, rule Inf_lb, simp)
  fix
    y::'a
  assume
    a1: "y \<lle> x" "y \<lle> \<lInf> P"
  show
      "y \<lle> \<lInf> (insert x P)"
  proof (rule Inf_glb, auto)
    from a1 show "
        y \<lle> x"
      by (safe)
    fix
      z::'a
    assume
      b1: "z \<in> P"
    from a1 have
        "y
        \<lle> \<lInf>P"
      by (auto)
    also have "\<dots>
        \<lle> z"
      by (rule b1 [THEN Inf_lb])
    finally show
        "y \<lle> z"
      by (this)
  qed
qed

lemmas fin_Inf = inf_Inf Inf_inf Inf_singleton Inf_collect ins_comm

lemma Inf_inf':
    "(\<lINF> x | P x \<bullet> f x \<linf> g x) = \<lInf>({ x | P x \<bullet> f x } \<union> { x | P x \<bullet> g x})"
  apply (rule Inf_eq)
  apply (simp_all)
  apply (msafe(inference))
  apply (simp add: Inf_inf [symmetric])
proof -
  fix x
  assume
    b1: "P x"
  then have
    b2a: "f x \<in> { x | P x \<bullet> f x }" and
    b2b: "g x \<in> { x | P x \<bullet> g x }"
    by (auto)
  show
      "(\<lINF> x | P x \<bullet> f x) \<linf> (\<lINF> x | P x \<bullet> g x) \<lle> f x \<linf> g x"
    apply (rule order_trans)
    apply (rule inf_mono1)
    apply (rule Inf_lb [OF b2a])
    apply (rule order_trans)
    apply (rule inf_mono2)
    apply (rule Inf_lb [OF b2b])
    apply (rule order_refl)
    done
next
  fix a
  assume
    b1: "(\<forall> x \<bullet> P x \<Rightarrow> a \<lle> f x \<linf> g x)"
  then have
    "(\<forall> x \<bullet> P x \<Rightarrow> a \<lle> f x \<and> a \<lle> g x)"
    apply (auto)
    apply (rule order_trans [OF _ inf_lb1])
    apply (fast)
    apply (rule order_trans [OF _ inf_lb2])
    apply (fast)
    done
  then show
      "a \<lle> \<lInf>({ x | P x \<bullet> f x } \<union> { x | P x \<bullet> g x })"
    apply (intro Inf_glb)
    apply (auto)
    done
qed

lemma Sup_sub:
  assumes
    a1: "P \<subseteq> Q"
  shows
      "\<lSup> P \<lle> \<lSup> Q"
  apply (rule Sup_lub)
  apply (rule Sup_ub)
  using a1
  apply (auto)
  done

lemma QTSup_dom:
    "(\<forall> x | P x \<bullet> f x \<lle> g x)
    \<turnstile> (\<lSUP> x | P x \<bullet> f x) \<lle> (\<lSUP> x | P x \<bullet> g x)"
proof (rule Sup_lub, auto)
  assume
    a1: "(\<forall> x | P x \<bullet> f x \<lle> g x)"
  fix x
  assume
    a2: "P x"
  have
      "f x
      \<lle> g x"
    by (rule a1 [rule_format], rule a2)
  also have "\<dots>
      \<lle> (\<lSUP> x | P x \<bullet> g x)"
    by (rule Sup_ub, auto intro!: exI [of _ x] a2)
  finally show
      "f x  \<lle> (\<lSUP> x | P x \<bullet>g x)"
    by (this)
qed

lemma QSup_dom:
    "(\<forall> x \<bullet> f x \<lle> g x)
    \<turnstile> (\<lSUP> x \<bullet> f x) \<lle> (\<lSUP> x \<bullet> g x)"
proof (rule Sup_lub, auto)
  assume
    a1: "(\<forall> x \<bullet> f x \<lle> g x)"
  fix x
  have
      "f x
      \<lle> g x"
    by (rule a1 [rule_format])
  also have "\<dots>
      \<lle> (\<lSUP> x \<bullet> g x)"
    by (rule Sup_ub, auto intro!: exI [of _ x])
  finally show
      "f x  \<lle> (\<lSUP> x \<bullet> g x)"
    by (this)
qed

lemma Sup_eq:
    "\<lbrakk>
      (\<And> x \<bullet> x \<in> P \<turnstile> x \<lle> z);
      (\<And> y \<bullet> (\<forall> x | x \<in> P \<bullet> x \<lle> y) \<turnstile> z \<lle> y)
    \<rbrakk> \<turnstile> (\<lSup>P) = z"
  apply (rule order_class.lub_unique [OF _ Sup_lubI])
  apply (auto intro!: order_class.is_lubI)
  done

lemma Max_eq:
    "\<lbrakk> \<And> x \<bullet> x \<in> P \<turnstile> x \<lle> z; z \<in> P \<rbrakk> \<turnstile> (\<lSup>P) = z"
  apply (rule Sup_eq)
  apply (auto intro: order_antisym)
  done

lemma sup_Sup:
    "x \<lsup> y = \<lSup> {x,y}"
  by (rule sup_eq, auto intro: Sup_ub Sup_lub)

lemma Sup_sup:
    "(\<lSup> (P::('a::clattice) set)) \<lsup> (\<lSup> Q) = \<lSup> (P \<union> Q)"
proof (rule Sup_eq [THEN sym], auto)
  fix
    x::'a
  assume
    a1: "x \<in> P"
  show
      "x \<lle> (\<lSup> P) \<lsup> (\<lSup> Q)"
    by (rule a1 [THEN Sup_ub [THEN order_trans]], rule sup_ub1)
next
  fix
    x::'a
  assume
    a1: "x \<in> Q"
  show
      "x \<lle> (\<lSup> P) \<lsup> (\<lSup> Q)"
    by (rule a1 [THEN Sup_ub [THEN order_trans]], rule sup_ub2)
next
  fix
    y::'a
  assume
    a1: "(\<forall> x::'a \<bullet> (x \<in> P \<Rightarrow> x \<lle> y) \<and> (x \<in> Q \<Rightarrow> x \<le> y))"
  show
      "(\<lSup> P) \<lsup> (\<lSup> Q) \<lle> y"
  proof (intro sup_lub Sup_lub)
    fix
      x::'a
    assume
      b1: "x \<in> P"
    show
        "x \<le> y"
      by (insert a1, elim allE [of _ x], elim conjE, simp add: b1)
  next
    fix
      x::'a
    assume
      b1: "x \<in> Q"
    show
        "x \<le> y"
      by (insert a1, elim allE [of _ x], elim conjE, simp add: b1)
  qed
qed

lemma Sup_Sup:
    "(\<lSUP> x | P x \<bullet> (\<lSUP> y | Q x y \<bullet> f x y)) = (\<lSUP> x y | P x \<and> Q x y \<bullet> f x y)"
  apply (rule Sup_eq)
  apply (auto)
  apply (rule Sup_sub)
  apply (simp add: subset_def)
  apply (fast)
  apply (rule Sup_lub)
  apply (auto)
  apply (elim allE impE)
  apply (assumption)
  apply (rule order_trans)
  defer 1
  apply (assumption)
  apply (rule Sup_ub)
  apply (auto)
  done

lemma Sup_empty:
    "\<lSup> \<emptyset> = \<lbot>"
  by (rule Sup_eq, auto, rule bot_lb)

lemma Sup_singleton:
    "\<lSup> {x} = x"
  by (rule Sup_eq, auto)

lemma Sup_bot_unique:
    "\<lSup> X = \<lbot> \<Leftrightarrow> X = {\<lbot>} \<or> X = \<emptyset>"
proof (rule iffI)
  assume
    b1: "\<lSup> X = \<lbot>"
  have
      "(\<forall> x | x \<in> X \<bullet> x \<lle> \<lbot>)"
    by (auto simp add: b1 [symmetric] Sup_ub)
  then have
      "(\<forall> x | x \<in> X \<bullet> x = \<lbot>)"
    by (auto simp add: bot_min)
  then show
      "X = {\<lbot>} \<or> X = \<emptyset>"
    by (auto)
qed (auto simp add: Sup_empty Sup_singleton)

lemma Sup_collect:
    "\<lSup> {x::'a::clattice, \<lSup> P} = \<lSup> ({x} \<union> P)"
proof (rule Sup_eq, safe, auto)
  show
      "x \<lle> \<lSup> (insert x P)"
    by (rule Sup_ub, simp)
  show
      "\<lSup> P \<lle> \<lSup> (insert x P)"
    by (rule Sup_lub, rule Sup_ub, simp)
  fix
    y::'a
  assume
    a1: "x \<lle> y" "\<lSup> P \<lle> y"
  show
      "\<lSup> (insert x P) \<lle> y"
  proof (rule Sup_lub, auto)
    from a1 show
        "x \<lle> y"
      by (auto)
    fix
      z::'a
    assume
      b1: "z \<in> P"
    then have
        "z
        \<lle> \<lSup> P"
      by (rule Sup_ub)
    also from a1 have "\<dots>
        \<lle> y"
      by (auto)
    finally show
        "z \<lle> y"
      by (this)
  qed
qed

lemma constant_sup_Sup:
    "\<lSup> {x \<bullet> b\<lsup>(c x)} = b\<lsup>(\<lSup>{x \<bullet> (c x)})"
  apply (rule Sup_eq,auto)
  apply (rule sup_mono2)
  apply (rule Sup_ub,auto)
proof -
  fix y
  assume
    Aa1: "\<forall> x \<bullet> b \<lsup> (c x) \<le> y"
  have
    Ra1: "b \<le> y"
    apply (rule order_trans)
    apply (rule sup_ub1)
    apply (rule Aa1 [rule_format])
    done
  have
    Ra2: "(\<forall> x \<bullet> c x \<le> y)"
    apply (rule allI)
    apply (rule order_trans)
    apply (rule sup_ub2)
    apply (rule Aa1 [rule_format])
    done
  from Ra1 Ra2 show
      "b \<lsup> (\<lSUP> x \<bullet> c x) \<le> y"
    apply (intro sup_lub, simp)
    apply (intro Sup_lub, auto)
  done
qed

lemmas fin_Sup = sup_Sup Sup_sup Sup_singleton Sup_collect ins_comm

lemma Sup_sup':
    "(\<lSUP> x | P x \<bullet> f x \<lsup> g x) = \<lSup>({ x | P x \<bullet> f x } \<union> { x | P x \<bullet> g x})"
  apply (rule Sup_eq)
  apply (simp_all)
  apply (msafe(inference))
  apply (simp add: Sup_sup [symmetric])
proof -
  fix x
  assume
    b1: "P x"
  then have
    b2a: "f x \<in> { x | P x \<bullet> f x }" and
    b2b: "g x \<in> { x | P x \<bullet> g x }"
    by (auto)
  show
      "f x \<lsup> g x \<lle> (\<lSUP> x | P x \<bullet> f x) \<lsup> (\<lSUP> x | P x \<bullet> g x)"
    apply (rule order_trans)
    apply (rule sup_mono1)
    apply (rule Sup_ub [OF b2a])
    apply (rule order_trans)
    apply (rule sup_mono2)
    apply (rule Sup_ub [OF b2b])
    apply (rule order_refl)
    done
next
  fix a
  assume
    b1: "(\<forall> x \<bullet> P x \<Rightarrow> f x \<lsup> g x \<lle> a)"
  then have
    "(\<forall> x \<bullet> P x \<Rightarrow> f x \<lle> a \<and> g x \<lle> a)"
    apply (auto)
    apply (rule order_trans)
    apply (rule sup_ub1)
    apply (fast)
    apply (rule order_trans)
    apply (rule sup_ub2)
    apply (fast)
    done
  then show
      "\<lSup>({ x | P x \<bullet> f x } \<union> { x | P x \<bullet> g x }) \<lle> a"
    apply (intro Sup_lub)
    apply (auto)
    done
qed

lemma Sup_bot_rem:
  "\<lSup> (A - {\<lbot>}) = \<lSup> A"
proof (cases "\<lbot> \<in> A")
  assume
      "\<lbot> \<in> A"
  then have
    b1: "{\<lbot>} \<union> (A - {\<lbot>}) = A"
    by (auto)
  have
      "\<lSup> (A - {\<lbot>})
      = \<lbot> \<lsup> (\<lSup>(A - {\<lbot>}))"
    by (simp add: lat_bounds)
  also have "\<dots>
      = (\<lSup>{\<lbot>}) \<lsup> (\<lSup>(A - {\<lbot>}))"
    by (simp add: Sup_singleton)
  also have "\<dots>
      = \<lSup> ({\<lbot>} \<union> (A - {\<lbot>}))"
    by (simp add: Sup_sup)
  also from b1 have "\<dots>
      = \<lSup> A"
    by (simp)
  finally show
        "?thesis"
    by (this)
next
  assume
      "\<lbot> \<notin> A"
  then have
      "A - {\<lbot>} = A"
    by (auto)
  then show
      "?thesis"
    by (simp)
qed

lemma Inf_top_rem:
    "\<lInf> (A - {\<ltop>}) = \<lInf> A"
proof (cases "\<ltop> \<in> A")
  assume
      "\<ltop> \<in> A"
  then have
    b1: "{\<ltop>} \<union> (A - {\<ltop>}) = A"
    by (auto)
  have
      "\<lInf> (A - {\<ltop>})
      = \<ltop> \<linf> (\<lInf>(A - {\<ltop>}))"
    by (simp add: lat_bounds)
  also have "\<dots>
      = (\<lInf>{\<ltop>}) \<linf> (\<lInf>(A - {\<ltop>}))"
    by (simp add: Inf_singleton)
  also have "\<dots>
      = \<lInf> ({\<ltop>} \<union> (A - {\<ltop>}))"
    by (simp add: Inf_inf)
  also from b1 have "\<dots>
      = \<lInf> A"
    by (simp)
  finally show
      "?thesis"
    by (this)
next
  assume
      "\<ltop> \<notin> A"
  then have
      "A - {\<ltop>} = A"
    by (auto)
  then show
      "?thesis"
    by (simp)
qed

lemma clattice_class_defaultD:
  fixes
    X :: "('a::clattice) set"
  assumes
    a1: "X \<noteq> \<emptyset>" and
    a2: "\<And> P \<bullet> \<lbrakk> P \<noteq> \<emptyset>; P \<subseteq> X \<rbrakk> \<turnstile> \<lInf> P \<in> X" and
    a3: "\<And> P \<bullet> \<lbrakk> P \<noteq> \<emptyset>; P \<subseteq> X \<rbrakk> \<turnstile> \<lSup> P \<in> X"
  shows "\<^clattice>{:X:}{:(default_order X):}"
proof -
  from a1 interpret
    def_po: po_carrier X
    by (unfold_locales)
  from def_po.partial_order show
      "\<^clattice>{:X:}{:(default_order X):}"
  proof (unfold_locales)
    fix
      P
    assume
      b1: "P \<subseteq> X"
    show
        "(\<exists> x \<bullet> \<^glbp>{:X:}{:(default_order X):} P x)"
    proof (cases "P = \<emptyset>")
      assume
        c1: "P = \<emptyset>"
      then show
          ?thesis
        apply (witness "\<lSup> X")
        apply (rule def_po.is_glbI)
        apply (auto intro!: Sup_ub Sup_lub a3 [OF a1] simp add: default_order_def subset_order_def rel2op_def op2rel_def)
        done
    next
      assume
        c1: "P \<noteq> \<emptyset>"
      with b1 show
          ?thesis
        apply (witness "\<lInf> P")
        apply (rule def_po.is_glbI)
        apply (auto intro!: Inf_lb Inf_glb simp add: default_order_def subset_order_def rel2op_def op2rel_def a2)
        done
    qed
    show
        "(\<exists> x \<bullet> \<^lubp>{:X:}{:(default_order X):} P x)"
    proof (cases "P = \<emptyset>")
      assume
        c1: "P = \<emptyset>"
      then show
          ?thesis
        apply (witness "\<lInf> X")
        apply (rule def_po.is_lubI)
        apply (auto intro!:Inf_lb Inf_glb a2 [OF a1] simp add: default_order_def subset_order_def rel2op_def op2rel_def)
        done
    next
      assume
        c1: "P \<noteq> \<emptyset>"
      with b1 show
          ?thesis
        apply (witness "\<lSup> P")
        apply (rule def_po.is_lubI)
        apply (auto intro!: Sup_ub Sup_lub simp add: default_order_def subset_order_def rel2op_def op2rel_def a3)
        done
    qed
  qed
qed

lemma [mintro!(wind)]:
    "(\<And> x \<bullet> P x \<turnstile> f x = g x) \<turnstile> (\<lSUP> x | P x \<bullet> f x) = (\<lSUP> x | P x \<bullet> g x)"
  apply (rule arg_cong [of _ _ "Sup"])
  apply (mauto(wind))
  done

lemma [mintro!(wind)]:
    "(\<And> x \<bullet> P x \<turnstile> f x = g x) \<turnstile> (\<lINF> x | P x \<bullet> f x) = (\<lINF> x | P x \<bullet> g x)"
  apply (rule arg_cong [of _ _ "Inf"])
  apply (mauto(wind))
  done

lemma [mintro!(wind)]:
    "(\<And> x \<bullet> f x = g x) \<turnstile> (\<lSUP> x \<bullet> f x) = (\<lSUP> x \<bullet> g x)"
  apply (rule arg_cong [of _ _ "Sup"])
  apply (mauto(wind))
  done

lemma [mintro!(wind)]:
    "(\<And> x \<bullet> f x = g x) \<turnstile> (\<lINF> x \<bullet> f x) = (\<lINF> x \<bullet> g x)"
  apply (rule arg_cong [of _ _ "Inf"])
  apply (mauto(wind))
  done

lemma [mintro!(wind)]:
    "(\<And> x \<bullet> P x \<turnstile> f x \<lle> g x)
    \<turnstile> (\<lSUP> x | P x \<bullet> f x) \<lle> (\<lSUP> x | P x \<bullet> g x)"
  apply (rule QTSup_dom)
  apply (auto)
  done

lemma [mintro!(wind)]:
    "(\<And> x \<bullet> P x \<turnstile> f x \<lge> g x)
    \<turnstile> (\<lSUP> x | P x \<bullet> f x) \<lge> (\<lSUP> x | P x \<bullet> g x)"
  apply (unfold ge_def)
  apply (rule QTSup_dom)
  apply (auto)
  done

lemma [mintro!(wind)]:
    "(\<And> x \<bullet> P x \<turnstile> f x \<lle> g x)
    \<turnstile> (\<lINF> x | P x \<bullet> f x) \<lle> (\<lINF> x | P x \<bullet> g x)"
  apply (rule QTInf_dom)
  apply (auto)
  done

lemma [mintro!(wind)]:
    "(\<And> x \<bullet> P x \<turnstile> f x \<lge> g x)
    \<turnstile> (\<lINF> x | P x \<bullet> f x) \<lge> (\<lINF> x | P x \<bullet> g x)"
  apply (unfold ge_def)
  apply (rule QTInf_dom)
  apply (auto)
  done

lemma [mintro!(wind)]:
    "(\<And> x \<bullet> f x \<lle> g x)
    \<turnstile> (\<lSUP> x \<bullet> f x) \<lle> (\<lSUP> x \<bullet> g x)"
  apply (rule QSup_dom)
  apply (auto)
  done

lemma [mintro!(wind)]:
    "(\<And> x \<bullet> f x \<lge> g x)
    \<turnstile> (\<lSUP> x \<bullet> f x) \<lge> (\<lSUP> x \<bullet> g x)"
  apply (unfold ge_def)
  apply (rule QSup_dom)
  apply (auto)
  done

lemma [mintro!(wind)]:
  "(\<And> x \<bullet> f x \<lle> g x)
  \<turnstile> (\<lINF> x \<bullet> f x) \<lle> (\<lINF> x \<bullet> g x)"
  apply (rule QInf_dom)
  apply (auto)
  done

lemma [mintro!(wind)]:
    "(\<And> x \<bullet> f x \<lge> g x)
    \<turnstile> (\<lINF> x \<bullet> f x) \<lge> (\<lINF> x \<bullet> g x)"
  apply (unfold ge_def)
  apply (rule QInf_dom)
  apply (auto)
  done

text{*

It is convenient to have a ``Sup indexed over type''.  Moreover, because
controlling the print translation of the syntax forms is difficult, we
will introduce a const for this case.

*}

definition
  ISup :: "('x \<rightarrow> ('a::clattice)) \<rightarrow> 'a"
where
  ISup_def: "ISup f \<defs> (\<lSup> { x \<bullet> f x })"

syntax ("" output)
  "_Lattice_Class\<ZZ>ISup" :: "[pttrns, logic] \<rightarrow> logic" ("d|| _ @/ [ _ ]" [0,0] 10)

syntax (xsymbols output)
  "_Lattice_Class\<ZZ>ISup" :: "[pttrns, logic] \<rightarrow> logic" ("\<Lambda> _ \<bullet>/ [ _ ]" [0,0] 10)

syntax (zed)
  "_Lattice_Class\<ZZ>ISup" :: "[pttrns, logic] \<rightarrow> logic" ("\<ISup> _\<bullet>/ [ _ ]" [0,0] 10)

parse_translation {* [
  Syntax_Trans.mk_binder_tr("_Lattice_Class\<ZZ>ISup","\<^const>Lattice_Class.ISup")
] *}

print_translation {* [
  Syntax_Trans.mk_binder_tr'("\<^const>Lattice_Class.ISup","_Lattice_Class\<ZZ>ISup")
] *}

lemma sett_range:
  "{ x \<bullet> f x } = range f"
  by (auto)

lemma ISup_lubI:
    "\<^lubp>{:\<univ>:}{:(op \<le>):} (range f) (\<ISup> x \<bullet> [f x])"
  by (auto simp add: ISup_def Sup_lubI sett_range)

lemma ISupE:
  assumes
    a1:
      "(\<lbrakk>
        (\<And> x \<bullet> x \<in> (range f) \<turnstile> x \<lle> (\<ISup> i \<bullet> [f i]));
        (\<And> y \<bullet> ( \<forall> x | x \<in> (range f) \<bullet> x \<lle> y) \<turnstile> (\<ISup> i \<bullet> [f i]) \<lle> y)
      \<rbrakk> \<turnstile> R)"
  shows
      "R"
  apply (rule SupE [where ?P = "range f"])
  apply (rule a1)
  apply (simp add: ISup_def sett_range)+
  done

lemma ISupE':
  assumes
    a1:
      "\<lbrakk>
        (\<And> x \<bullet> f x \<lle> (\<ISup> i \<bullet> [f i]));
        (\<And> y \<bullet> (\<forall> x \<bullet> f x \<lle> y) \<turnstile> (\<ISup> i \<bullet> [f i]) \<lle> y)
      \<rbrakk> \<turnstile> R"
  shows
      "R"
  apply (rule ISupE [where ?f = "f"])
  apply (rule a1)
  apply (auto simp add: sett_range)+
  done

lemma ISup_ub:
    "x \<in> (range f) \<turnstile> x \<lle> (\<ISup> i \<bullet> [f i])"
  apply (simp add: ISup_def sett_range)
  apply (rule Sup_ub, assumption)
  done

lemma ISup_ub':
    "f x \<lle> (\<ISup> i \<bullet> [f i])"
  by (rule ISup_ub, simp add: sett_range)

lemma ISup_lub:
    "(\<And> x \<bullet> x \<in> (range f) \<turnstile> x \<lle> z) \<turnstile> (\<ISup> i \<bullet> [f i]) \<lle> z"
  by (rule ISupE, auto)

lemma ISup_lub':
    "(\<And> x \<bullet> f x \<lle> z) \<turnstile> (\<ISup> i \<bullet> [f i]) \<lle> z"
  by (rule ISup_lub, auto)

lemma ISup_dom:
  assumes
    a1: "(\<forall> x \<bullet> f x \<lle> g x)"
  shows
      "(\<ISup> x \<bullet> [f x]) \<lle> (\<ISup> x \<bullet> [g x])"
proof (rule ISup_lub, auto)
  fix i
  have
      "f i
      \<lle> g i"
    by (rule a1 [rule_format])
  also have "\<dots>
      \<lle> (ISup g)"
    by (rule ISup_ub, auto)
  finally show
      "f i \<lle> (ISup g)"
    by (this)
qed

lemma ISup_eq:
    "\<lbrakk>
      (\<And> x \<bullet> f x \<lle> z);
      (\<And> y \<bullet> (\<forall> x \<bullet> f x \<lle> y) \<turnstile> z \<lle> y)
    \<rbrakk> \<turnstile> (\<ISup> x \<bullet> [f x]) = z"
  apply (simp add: ISup_def)
  apply (rule Sup_eq, auto)
  done

lemma IMax_eq:
    "(\<And> x \<bullet> f x \<lle> f z) \<turnstile> (\<ISup> x \<bullet> [f x]) = f z"
  apply (simp add: ISup_def)
  apply (rule Max_eq, auto)
  done

section {* Distributive lattices *}

text {*

If meet distributes through join we say that the lattice is
distributive.

*}

class dlattice = Lattice_Class.lattice +

assumes
  sup_dist: "x && (y || z) = (x && y) || (x && z)"

text {*

In a distributive lattice, join also distributes through meet.

*}

lemma inf_dist:
    "(x::'a::dlattice) \<lsup> (y \<linf> z) = (x \<lsup> y) \<linf> (x \<lsup> z)"
proof -
  txt {*
    Following the reasoning of Davey~\cite[p 130]{Davey:Lattice}.
  *}
  have
      "(x \<lsup> y) \<linf> (x \<lsup> z)
      = ((x \<lsup> y) \<linf> x) \<lsup> ((x \<lsup> y) \<linf> z)"
    by (simp add: sup_dist)
  also have "\<dots>
      = x \<lsup> (z \<linf> (x \<lsup> y))"
    by (simp add: inf_absorption inf_com)
  also have "\<dots>
      = x \<lsup> ((z \<linf> x) \<lsup> (z \<linf> y))"
   by (simp add: sup_dist)
  also have "\<dots>
      = (x \<lsup> (x \<linf> z)) \<lsup> (y \<linf> z)"
   by (simp add: sup_assoc inf_com)
  also have "\<dots>
      = x \<lsup> (y \<linf> z)"
    by (simp add: sup_absorption)
  finally show
      ?thesis
    by (rule sym)
qed

section {* Boolean lattices *}

text {*

A lattice complement is an inverse under both meet and join.
A distributive, bound lattice with complements is called a boolean lattice.

*}

class bllat = blat +

fixes
  "ocomp" :: "'a \<rightarrow> 'a" ("o~")

class boollattice = dlattice + boundlattice + bllat +

assumes
  comp_inf: "x && (o~ x) = bot" and
  comp_sup: "x || (o~ x) = top"

abbreviation
  lcomp :: "('a::boollattice) \<rightarrow> 'a"
where
  "lcomp \<defs> ocomp"

notation (xsymbols)
  lcomp ("\<lcomp>_" [90] 90)

text {*

Complements are unique.

*}

lemma comp_eq:
  fixes
    x::"'a::boollattice" and
    cx::"'a::boollattice"
  assumes
    a1: "x \<linf> cx = \<lbot>" and
    a2: "x \<lsup> cx = \<ltop>"
  shows
      "\<lcomp>x = cx"
proof -
  have
    a5:
      "\<And>(y::'a) y' \<bullet> \<lbrakk> x \<lsup> y' = \<ltop>; x \<linf> y = \<lbot> \<rbrakk>
      \<turnstile> y \<lle> y'"
  proof -
    txt {*
    Following the reasoning of Davey~\cite[p 143]{Davey:Lattice}.
    *}
    fix
      y::'a and y'::'a
    assume
      b1: "x \<lsup> y' = \<ltop>" and
      b2: "x \<linf> y = \<lbot>"
    have
       "y
       = y\<linf> \<ltop>"
       by (simp add: top_ub [THEN inf_min])
    also have "\<dots>
       = y \<linf> (x \<lsup> y')"
      by (simp add: b1)
    also have "\<dots>
       = (y \<linf> x) \<lsup> (y \<linf> y')"
      by (simp add: sup_dist)
    also have "\<dots>
       = (y \<linf> y')"
      by (simp add: inf_com b2 bot_lb [THEN sup_max])
    finally show
        "y \<lle> y'"
      by (rule sym [THEN min_inf])
  qed
  show
      "\<lcomp>x = cx"
  proof (rule order_antisym)
    show
        "\<lcomp>x \<lle> cx"
      by (rule comp_inf [THEN a2 [THEN a5]])
    show
        "cx \<lle> \<lcomp>x"
      by (rule a1 [THEN comp_sup [THEN a5]])
  qed
qed

text {*

The top and bottom elements are complements.

*}

lemma comp_bot_conv:
    "\<lcomp>\<lbot> = \<ltop>"
proof (rule comp_eq)
  show
      "\<lbot> \<linf> \<ltop> = \<lbot>"
    by (rule bot_lb [THEN inf_min])
  show
      "\<lbot> \<lsup> \<ltop> = \<ltop>"
    by (rule top_ub [THEN sup_max])
qed

lemma comp_top_conv:
    "\<lcomp>\<ltop> = \<lbot>"
proof (rule comp_eq)
  show
      "\<ltop> \<linf> \<lbot> = \<lbot>"
    by (rule bot_lb [THEN inf_min [THEN inf_com [THEN trans]]])
  show
      "\<ltop> \<lsup> \<lbot> = \<ltop>"
    by (rule top_ub [THEN sup_max [THEN sup_com [THEN trans]]])
qed

text {*

An element is the complement of its complement.

*}

lemma comp_involution:
    "\<lcomp>(\<lcomp>x) = x"
proof (rule comp_eq)
  show
      "\<lcomp>x \<linf> x = \<lbot>"
    by (rule comp_inf [THEN inf_com [THEN trans]])
  show
      "\<lcomp>x \<lsup> x = \<ltop>"
    by (rule comp_sup [THEN sup_com [THEN trans]])
qed

text {*

Complements satisfy de Morgan's laws.

*}

lemma inf_demorgan:
    "\<lcomp>(x \<linf> y) = \<lcomp>x \<lsup> \<lcomp>y"
proof (rule comp_eq)
  have
      "(x \<linf> y) \<linf> (\<lcomp>x \<lsup> \<lcomp>y)
      = (x \<linf> \<lcomp>x \<linf> y) \<lsup> (x \<linf> (y \<linf> \<lcomp>y))"
    by (simp add: lat_com_assoc sup_dist)
  also have "\<dots>
      = \<lbot>"
    by (simp add: comp_inf lat_bounds)
  finally show
      "(x \<linf> y) \<linf> (\<lcomp>x \<lsup> \<lcomp>y) = \<lbot>"
    by (this)
  have
      "(x \<linf> y) \<lsup> (\<lcomp>x \<lsup> \<lcomp>y)
      = (x \<lsup> \<lcomp>x \<lsup> \<lcomp>y) \<linf> (\<lcomp>x \<lsup> (y \<lsup>\<lcomp>y))"
    by (simp add: lat_com_assoc inf_dist)
  also have "\<dots>
      = \<ltop>"
    by (simp add: comp_sup lat_bounds)
  finally show
      "(x \<linf> y) \<lsup> (\<lcomp>x \<lsup> \<lcomp>y) = \<ltop>"
    by (this)
qed

lemma sup_demorgan:
    "\<lcomp>(x \<lsup> y) = \<lcomp>x \<linf> \<lcomp>y"
proof (rule comp_eq)
  have
      "(x \<lsup> y) \<linf> (\<lcomp>x \<linf> \<lcomp>y)
      = (x \<linf> \<lcomp>x \<linf> \<lcomp>y) \<lsup> (\<lcomp>x \<linf> (y \<linf> \<lcomp>y))"
    by (simp add: lat_com_assoc sup_dist)
  also have "\<dots>
      = \<lbot>"
    by (simp add: comp_inf lat_bounds)
  finally show
      "(x \<lsup> y) \<linf> (\<lcomp>x \<linf> \<lcomp>y) = \<lbot>"
    by (this)
  have
      "(x \<lsup> y) \<lsup> (\<lcomp>x \<linf> \<lcomp>y)
      = (x \<lsup> \<lcomp>x \<lsup> y) \<linf> (x \<lsup> (y \<lsup> \<lcomp>y))"
    by (simp add: lat_com_assoc inf_dist)
  also have "\<dots>
      = \<ltop>"
    by (simp add: comp_sup lat_bounds)
  finally show
      "(x \<lsup> y) \<lsup> (\<lcomp>x \<linf> \<lcomp>y) = \<ltop>"
    by (this)
qed

text {*

The complement operator is a bijection.

*}

lemma comp_bij:
    "(\<lcomp>x = \<lcomp>y) = (x = y)"
proof (rule iffI)
  assume
    a1: "\<lcomp>x = \<lcomp>y"
  have
    a2: "x = y \<Leftrightarrow> (\<lcomp>(\<lcomp>x) = \<lcomp>(\<lcomp>y))"
    by (simp add: comp_involution)
  show
      "x = y"
    by (simp add: a1 a2)
next
  assume
      "x = y"
  then show
      "\<lcomp>x = \<lcomp>y"
    by (simp)
qed

text {*

The complement operator is a antimonotonic.

*}

lemma comp_antimono:
    "(\<lcomp>x \<lle> \<lcomp>y) = (y \<lle> x)"
proof -
  have
      "(\<lcomp>x \<lle> \<lcomp>y)
      \<Leftrightarrow> (\<lcomp>y = \<lcomp>x \<lsup> \<lcomp>y)"
    by (rule sup_correspondence [THEN sym])
  also have "\<dots>
      \<Leftrightarrow> (\<lcomp>y = \<lcomp>(x \<linf> y))"
    by (simp add: inf_demorgan)
  also have "\<dots>
      \<Leftrightarrow> (y = (y \<linf> x))"
    by (simp add: comp_bij lat_com_assoc)
  also have "\<dots>
      \<Leftrightarrow> (y \<lle> x)"
    by (rule inf_correspondence)
  finally show
      ?thesis
    by (this)
qed

text {*

If a boolean lattice is complete, it satisfies distributed versions of
the de Morgan laws.

*}

lemma Inf_demorgan:
    "\<lcomp>(\<lInf>(P::(('a::{boollattice,clattice})set))) = (\<lSUP> x | x \<in> P \<bullet> \<lcomp>x)"
proof (rule Sup_eq [THEN sym], auto)
  fix
    x::'a
  assume
    a1: "x \<in> P"
  show
      "\<lcomp>x \<lle> \<lcomp>(\<lInf>P)"
    by (simp add: comp_antimono) (rule a1 [THEN Inf_lb])
next
  fix
    x'::'a
  assume
    a1: "(\<forall> y' \<bullet> y' \<in> P \<Rightarrow> \<lcomp>y' \<lle> x')"
  have
      "(\<lcomp>(\<lInf>P) \<lle> x')
      = (\<lcomp>(\<lInf>P) \<lle> \<lcomp>(\<lcomp>x'))"
    by (simp add: comp_involution)
  also have "\<dots>
      = (\<lcomp>x' \<lle> \<lInf>P)"
    by (rule comp_antimono)
  finally have
    a2: "(\<lcomp>(\<lInf>P) \<lle> x') = (\<lcomp>x' \<lle> \<lInf>P)"
    by (this)
  show
      "\<lcomp>(\<lInf>P) \<lle> x'"
  proof (simp add: a2, rule Inf_glb)
    fix
      y::'a
    assume
      b1: "y \<in> P"
    have
      b2: "\<lcomp>y \<lle> x'"
      by (rule a1 [rule_format, OF b1])
    have
        "(\<lcomp>x' \<lle> y)
        = (\<lcomp>x' \<lle> \<lcomp>(\<lcomp>y))"
      by (simp add: comp_involution)
    also have "\<dots>
        = (\<lcomp>y \<lle> x')"
      by (rule comp_antimono)
    finally have
      b3: "(\<lcomp>x' \<lle> y) = (\<lcomp>y \<lle> x')"
      by (this)
    show
        "\<lcomp>x' \<lle> y"
      by (simp add: b3 b2)
  qed
qed

lemma Sup_demorgan:
    "\<lcomp>(\<lSup>(P::(('a::{boollattice,clattice})set))) = (\<lINF> x | x \<in> P \<bullet> \<lcomp>x)"
  apply (rule comp_bij [THEN iffD1])
  apply (simp add: Inf_demorgan comp_involution)
  apply (rule arg_cong [of _ _ "lSup"])
  apply (auto simp add: comp_involution eind_comp)
  done

section {* Other lattice class relations *}

text {*

Finally we show that every linear order admits a lattice structure.

*}

class linlat = linorder + lat +

assumes
  inf_linorder_eq: "x && y = \<if> x \<le> y \<then> x \<else> y \<fi>" and
  sup_linorder_eq: "x || y = \<if> x \<le> y \<then> y \<else> x \<fi>"

instance
  linlat < lattice
  apply (intro_classes)
  apply (auto simp add: inf_linorder_eq sup_linorder_eq)
  done

end


section \<open> Grid Points \<close>

theory Grid_Point
imports "HOL-Analysis.Multivariate_Analysis"
begin

type_synonym grid_point = "(nat \<times> int) list"

definition lv :: "grid_point \<Rightarrow> nat \<Rightarrow> nat"
  where "lv p d = fst (p ! d)"

definition ix :: "grid_point \<Rightarrow> nat \<Rightarrow> int"
  where "ix p d = snd (p ! d)"

definition level :: "grid_point \<Rightarrow> nat"
  where "level p = (\<Sum> i < length p. lv p i)"

lemma level_all_eq:
  assumes "\<And>d. d < length p \<Longrightarrow> lv p d = lv p' d"
  and "length p = length p'"
  shows "level p' = level p"
  unfolding level_def using assms by auto

datatype dir = left | right

fun sgn :: "dir \<Rightarrow> int"
where
    "sgn left  = -1"
  | "sgn right =  1"

fun inv :: "dir \<Rightarrow> dir"
where
    "inv left = right"
  | "inv right = left"

lemma inv_inv[simp]: "inv (inv dir) = dir"
  by (cases dir) simp_all

lemma sgn_inv[simp]: "sgn (inv dir) = - sgn dir"
  by (cases dir, auto)

definition child :: "grid_point \<Rightarrow> dir \<Rightarrow> nat \<Rightarrow> grid_point"
  where "child p dir d = p[d := (lv p d + 1, 2 * (ix p d) + sgn dir)]"

lemma child_length[simp]: "length (child p dir d) = length p"
  unfolding child_def by simp

lemma child_odd[simp]: "d < length p \<Longrightarrow> odd (ix (child p dir d) d)"
  unfolding child_def ix_def by (cases dir, auto)

lemma child_eq: "p ! d = (l, i) \<Longrightarrow> \<exists> j. child p dir d = p[d := (l + 1, j)]"
  by (auto simp add: child_def ix_def lv_def)

lemma child_other: "d \<noteq> d' \<Longrightarrow> child p dir d ! d' = p ! d'"
  unfolding child_def lv_def ix_def by (cases "d' < length p", auto)

lemma child_invariant: assumes "d' < length p" shows "(child p dir d ! d' = p ! d') = (d \<noteq> d')"
proof -
  obtain l i where "p ! d' = (l, i)" using prod.exhaust .
  with assms show ?thesis
    unfolding child_def ix_def lv_def by auto
qed

lemma child_single_level: "d < length p \<Longrightarrow> lv (child p dir d) d > lv p d"
  unfolding lv_def child_def by simp

lemma child_lv: "d < length p \<Longrightarrow> lv (child p dir d) d = lv p d + 1"
  unfolding child_def lv_def by simp

lemma child_lv_other: assumes "d' \<noteq> d" shows "lv (child p dir d') d = lv p d"
  using child_other[OF assms] unfolding lv_def by simp

lemma child_ix_left: "d < length p \<Longrightarrow> ix (child p left d) d = 2 * ix p d - 1"
  unfolding child_def ix_def by simp

lemma child_ix_right: "d < length p \<Longrightarrow> ix (child p right d) d = 2 * ix p d + 1"
  unfolding child_def ix_def by simp

lemma child_ix: "d < length p \<Longrightarrow> ix (child p dir d) d = 2 * ix p d + sgn dir"
  unfolding child_def ix_def by simp

lemma child_level[simp]: assumes "d < length p"
  shows "level (child p dir d) = level p + 1"
proof -
  have inter: "{0..<length p} \<inter> {d} = {d}" using assms by auto

  have "level (child p dir d) =
    (\<Sum> d' = 0..<length p. if d' \<in> {d} then lv p d + 1 else lv p d')"
    by (auto intro!: sum.cong simp add: child_lv_other child_lv level_def)
  moreover have "level p + 1 =
    (\<Sum> d' = 0..<length p. if d' \<in> {d} then lv p d else lv p d') + 1"
    by (auto intro!: sum.cong simp add: child_lv_other child_lv level_def)
  ultimately show ?thesis
    unfolding sum.If_cases[OF finite_atLeastLessThan] inter
    using assms by auto
qed

lemma child_ex_neighbour: "\<exists> b'. child b dir d = child b' (inv dir) d"
proof
  show "child b dir d = child (b[d := (lv b d, ix b d + sgn dir)]) (inv dir) d"
    unfolding child_def ix_def lv_def by (cases "d < length b", auto simp add: algebra_simps)
qed

lemma child_level_gt[simp]: "level (child p dir d) >= level p"
  by (cases "d < length p", simp, simp add: child_def)

lemma child_estimate_child:
  assumes "d < length p"
    and "l \<le> lv p d"
    and i'_range: "ix p d < (i + 1) * 2^(lv p d - l) \<and>
                   ix p d > (i - 1) * 2^(lv p d - l)"
                  (is "?top p \<and> ?bottom p")
    and is_child: "p' = child p dir d"
  shows "?top p' \<and> ?bottom p'"
proof
  from is_child and \<open>d < length p\<close>
  have "lv p' d = lv p d + 1" by (auto simp add: child_def ix_def lv_def)
  hence "lv p' d - l = lv p d - l + 1" using \<open>lv p d >= l\<close> by auto
  hence pow_l'': "(2^(lv p' d - l) :: int) = 2 * 2^(lv p d - l)" by auto

  show "?top p'"
  proof -
    from is_child and \<open>d < length p\<close>
    have "ix p' d \<le> 2 * (ix p d) + 1"
      by (cases dir, auto simp add: child_def lv_def ix_def)
    also have "\<dots> < (i + 1) * (2 * 2^(lv p d - l))" using i'_range by auto
    finally show ?thesis using pow_l'' by auto
  qed

  show "?bottom p'"
  proof -
    have "(i - 1) * 2^(lv p' d - l) = 2 * ((i - 1) * 2^(lv p d - l))"
      using pow_l'' by simp
    also have "\<dots> < 2 * ix p d - 1" using i'_range by auto
    finally show ?thesis using is_child and \<open>d < length p\<close>
      by (cases dir, auto simp add: child_def lv_def ix_def)
  qed
qed

lemma child_neighbour: assumes "child p (inv dir) d = child ps dir d" (is "?c_p = ?c_ps")
  shows "ps = p[d := (lv p d, ix p d - sgn dir)]" (is "_ = ?ps")
proof (rule nth_equalityI)
  have "length ?c_ps = length ?c_p" using \<open>?c_p = ?c_ps\<close> by simp
  hence len_eq: "length ps = length p" by simp
  thus "length ps = length ?ps" by simp

  show "ps ! i = ?ps ! i" if "i < length ps" for i
  proof -
    have "i < length p"
      using that len_eq by auto

    show "ps ! i = ?ps ! i"
    proof (cases "d = i")
      case [simp]: True

      have "?c_p ! i = ?c_ps ! i" using \<open>?c_p = ?c_ps\<close> by auto
      hence "ix p i = ix ps d + sgn dir" and "lv p i = lv ps i"
        by (auto simp add: child_def
          nth_list_update_eq[OF \<open>i < length p\<close>]
          nth_list_update_eq[OF \<open>i < length ps\<close>])
      thus ?thesis by (simp add: lv_def ix_def \<open>i < length p\<close>)
    next
      assume "d \<noteq> i"
      with child_other[OF this, of ps dir] child_other[OF this, of p "inv dir"]
      show ?thesis using assms by auto
    qed
  qed
qed

definition start :: "nat \<Rightarrow> grid_point"
where
  "start dm = replicate dm (0, 1)"

lemma start_lv[simp]: "d < dm \<Longrightarrow> lv (start dm) d = 0"
  unfolding start_def lv_def by simp

lemma start_ix[simp]: "d < dm \<Longrightarrow> ix (start dm) d = 1"
  unfolding start_def ix_def by simp

lemma start_length[simp]: "length (start dm) = dm"
  unfolding start_def by auto

lemma level_start_0[simp]: "level (start dm) = 0"
  using level_def by auto

end


section \<open>Quantum mechanics basics\<close>

theory Quantum
  imports
    Finite_Tensor_Product
    "HOL-Library.Z2"
    Jordan_Normal_Form.Matrix_Impl
    Real_Impl.Real_Impl
    "HOL-Library.Code_Target_Numeral"
begin

type_synonym ('a,'b) matrix = \<open>('a ell2, 'b ell2) cblinfun\<close>

subsection \<open>Basic quantum states\<close>

subsubsection \<open>EPR pair\<close>

definition "vector_\<beta>00 = vec_of_list [ 1/sqrt 2::complex, 0, 0, 1/sqrt 2 ]"
definition \<beta>00 :: \<open>(bit\<times>bit) ell2\<close> where [code del]: "\<beta>00 = basis_enum_of_vec vector_\<beta>00"
lemma vec_of_basis_enum_\<beta>00[simp]: "vec_of_basis_enum \<beta>00 = vector_\<beta>00"
  by (auto simp add: \<beta>00_def vector_\<beta>00_def)
lemma vec_of_ell2_\<beta>00[simp, code]: "vec_of_ell2 \<beta>00 = vector_\<beta>00"
  by (simp add: vec_of_ell2_def)

lemma norm_\<beta>00[simp]: "norm \<beta>00 = 1"
  by eval

subsubsection \<open>Ket plus\<close>

definition "vector_ketplus = vec_of_list [ 1/sqrt 2::complex, 1/sqrt 2 ]"
definition ketplus :: \<open>bit ell2\<close> ("|+\<rangle>") where [code del]: \<open>ketplus = basis_enum_of_vec vector_ketplus\<close>
lemma vec_of_basis_enum_ketplus[simp]: "vec_of_basis_enum ketplus = vector_ketplus"
  by (auto simp add: ketplus_def vector_ketplus_def)
lemma vec_of_ell2_ketplus[simp, code]: "vec_of_ell2 ketplus = vector_ketplus"
  by (simp add: vec_of_ell2_def)

subsection \<open>Basic quantum gates\<close>

subsubsection \<open>Pauli X\<close>

definition "matrix_pauliX = mat_of_rows_list 2 [ [0::complex, 1], [1, 0] ]"
definition pauliX :: \<open>(bit, bit) matrix\<close> where [code del]: "pauliX = cblinfun_of_mat matrix_pauliX"
lemma [simp, code]: "mat_of_cblinfun pauliX = matrix_pauliX"
  apply (auto simp add: pauliX_def matrix_pauliX_def)
  apply (subst cblinfun_of_mat_inverse)
  by (auto)

derive (eq) ceq bit

instantiation bit :: ccompare begin
definition "CCOMPARE(bit) = Some (\<lambda>b1 b2. case (b1, b2) of (0, 0) \<Rightarrow> order.Eq | (0, 1) \<Rightarrow> order.Lt | (1, 0) \<Rightarrow> order.Gt | (1, 1) \<Rightarrow> order.Eq)"
instance
  by intro_classes(unfold_locales; auto simp add: ccompare_bit_def split!: bit.splits)
end

derive (dlist) set_impl bit

lemma pauliX_adjoint[simp]: "pauliX* = pauliX"
  by eval
lemma pauliXX[simp]: "pauliX o\<^sub>C\<^sub>L pauliX = id_cblinfun"
  by eval

subsubsection \<open>Pauli Z\<close>

definition "matrix_pauliZ = mat_of_rows_list 2 [ [1::complex, 0], [0, -1] ]"
definition pauliZ :: \<open>(bit, bit) matrix\<close> where [code del]: "pauliZ = cblinfun_of_mat matrix_pauliZ"
lemma [simp, code]: "mat_of_cblinfun pauliZ = matrix_pauliZ"
  apply (auto simp add: pauliZ_def matrix_pauliZ_def)
  apply (subst cblinfun_of_mat_inverse)
  by (auto)
lemma pauliZ_adjoint[simp]: "pauliZ* = pauliZ"
  by eval
lemma pauliZZ[simp]: "pauliZ o\<^sub>C\<^sub>L pauliZ = id_cblinfun"
  by eval

subsubsection Hadamard

definition "matrix_hadamard = mat_of_rows_list 2 [ [1/sqrt 2::complex, 1/sqrt 2], [1/sqrt 2, -1/sqrt 2] ]"
definition hadamard :: \<open>(bit,bit) matrix\<close> where [code del]: "hadamard = cblinfun_of_mat matrix_hadamard"

lemma [simp, code]: "mat_of_cblinfun hadamard = matrix_hadamard"
  apply (auto simp add: hadamard_def matrix_hadamard_def)
  apply (subst cblinfun_of_mat_inverse)
  by (auto)

lemma hada_adj[simp]: "hadamard* = hadamard"
  by eval

subsubsection CNOT

definition "matrix_CNOT = mat_of_rows_list 4 [ [1::complex,0,0,0], [0,1,0,0], [0,0,0,1], [0,0,1,0] ]"
definition CNOT :: \<open>(bit*bit, bit*bit) matrix\<close> where [code del]: "CNOT = cblinfun_of_mat matrix_CNOT"

lemma [simp, code]: "mat_of_cblinfun CNOT = matrix_CNOT"
  apply (auto simp add: CNOT_def matrix_CNOT_def)
  apply (subst cblinfun_of_mat_inverse)
  by (auto)

lemma cnot_apply[simp]: \<open>CNOT *\<^sub>V ket (i,j) = ket (i,j+i)\<close>
  apply (rule spec[where x=i], rule spec[where x=j])
  by eval

subsubsection \<open>Qubit swap\<close>

definition "matrix_Uswap = mat_of_rows_list 4 [ [1::complex, 0, 0, 0], [0,0,1,0], [0,1,0,0], [0,0,0,1] ]"
definition Uswap :: \<open>(bit\<times>bit, bit\<times>bit) matrix\<close> where
  [code del]: \<open>Uswap = cblinfun_of_mat matrix_Uswap\<close>

lemma mat_of_cblinfun_Uswap[simp, code]: "mat_of_cblinfun Uswap = matrix_Uswap"
  apply (auto simp add: Uswap_def matrix_Uswap_def)
  apply (subst cblinfun_of_mat_inverse)
  by (auto)

lemma dim_col_Uswap[simp]: "dim_col matrix_Uswap = 4"
  unfolding matrix_Uswap_def by simp
lemma dim_row_Uswap[simp]: "dim_row matrix_Uswap = 4"
  unfolding matrix_Uswap_def by simp
lemma Uswap_adjoint[simp]: "Uswap* = Uswap"
  by eval
lemma Uswap_involution[simp]: "Uswap o\<^sub>C\<^sub>L Uswap = id_cblinfun"
  by eval
lemma unitary_Uswap[simp]: "unitary Uswap"
  unfolding unitary_def by simp

lemma Uswap_apply[simp]: \<open>Uswap *\<^sub>V s \<otimes>\<^sub>s t = t \<otimes>\<^sub>s s\<close>
  apply (rule clinear_equal_ket[where f=\<open>\<lambda>s. Uswap *\<^sub>V s \<otimes>\<^sub>s t\<close>, THEN fun_cong])
    apply (simp add: cblinfun.add_right clinearI tensor_ell2_add1 tensor_ell2_scaleC1)
   apply (simp add: clinear_tensor_ell21)
  apply (rule clinear_equal_ket[where f=\<open>\<lambda>t. Uswap *\<^sub>V _ \<otimes>\<^sub>s t\<close>, THEN fun_cong])
    apply (simp add: cblinfun.add_right clinearI tensor_ell2_add2 tensor_ell2_scaleC2)
   apply (simp add: clinear_tensor_ell22)
  apply (rule basis_enum_eq_vec_of_basis_enumI)
  apply (simp add: mat_of_cblinfun_cblinfun_apply vec_of_basis_enum_ket)
  by (case_tac i; case_tac ia; hypsubst_thin; normalization)

end


theory SINVAR_BLPbasic
imports "../TopoS_Helper"
begin

subsection \<open>SecurityInvariant Basic Bell LaPadula\<close>

type_synonym security_level = nat

definition default_node_properties :: "security_level"
  where  "default_node_properties \<equiv> 0"

fun sinvar :: "'v graph \<Rightarrow> ('v \<Rightarrow> security_level) \<Rightarrow> bool" where
  "sinvar G nP = (\<forall> (e1,e2) \<in> edges G. (nP e1) \<le> (nP e2))"

text\<open>What we call a @{typ security_level} is also referred to as security label
(or security clearance of subjects and classification of objects) in the literature.
The lowest security level is @{term "0::nat"}, which can be understood as unclassified.
Consequently, 1 = confidential, 2 = secret, 3 = topSecret, ....
The total order of the security levels corresponds to the total order of the natural numbers \<open>\<le>\<close>.
It is important that there is smallest security level (i.e. @{const default_node_properties}),
otherwise, a unique and secure default parameter could not exist.
Hence, it is not possible to extend the security levels to @{typ int} to model unlimited ``un-confidentialness''.
\<close>

definition receiver_violation :: "bool" where "receiver_violation \<equiv> True"

interpretation SecurityInvariant_preliminaries
where sinvar = sinvar
  apply unfold_locales
    apply(frule_tac finite_distinct_list[OF wf_graph.finiteE])
    apply(erule_tac exE)
    apply(rename_tac list_edges)
    apply(rule_tac ff="list_edges" in SecurityInvariant_withOffendingFlows.mono_imp_set_offending_flows_not_empty[OF sinvar_mono])
        apply(auto)[6]
   apply(auto simp add: SecurityInvariant_withOffendingFlows.is_offending_flows_def graph_ops)[1]
  apply(fact SecurityInvariant_withOffendingFlows.sinvar_mono_imp_is_offending_flows_mono[OF sinvar_mono])
 done

lemma BLP_def_unique: "otherbot \<noteq> 0 \<Longrightarrow>
    \<exists>G p i f. wf_graph G \<and> \<not> sinvar G p \<and> f \<in> (SecurityInvariant_withOffendingFlows.set_offending_flows sinvar G p) \<and>
       sinvar (delete_edges G f) p \<and>
        i \<in> snd ` f \<and> sinvar G (p(i := otherbot)) "
  apply(simp)
  apply (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_def)
  apply (simp add:graph_ops)
  apply (simp split: prod.split_asm prod.split)
  apply(rule_tac x="\<lparr> nodes=set [vertex_1,vertex_2], edges = set [(vertex_1,vertex_2)] \<rparr>" in exI, simp)
  apply(rule conjI)
   apply(simp add: wf_graph_def)
  apply(rule_tac x="(\<lambda> x. 0)(vertex_1 := 1, vertex_2 := 0)" in exI, simp)
  apply(rule_tac x="vertex_2" in exI, simp)
  apply(rule_tac x="set [(vertex_1,vertex_2)]" in exI, simp)
  done

(*Test instantiation without any fancy lemmata*)
(*
interpretation SecurityInvariant
where default_node_properties = default_node_properties
and sinvar = sinvar
and receiver_violation = receiver_violation
  unfolding default_node_properties_def
  unfolding receiver_violation_def
  apply unfold_locales

  apply(simp)
  apply (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_def)
  apply (simp add:graph_ops)
  apply (simp split: prod.split_asm prod.split add:case_prod_beta)
   apply(auto intro!:bexI)[1]
   (*apply (smt image_iff offending_in_edges prod.collapse)*)
  apply(blast intro: BLP_def_unique)
done
*)

subsubsection \<open>ENF\<close>
  lemma zero_default_candidate: "\<And> nP e1 e2. \<not> ((\<le>)::security_level \<Rightarrow> security_level \<Rightarrow> bool) (nP e1) (nP e2) \<Longrightarrow> \<not> (\<le>) (nP e1) 0"
    by simp_all
  lemma zero_default_candidate_rule: "\<And> (nP::('v \<Rightarrow> security_level)) e1 e2. \<not> (nP e1) \<le> (nP e2) \<Longrightarrow> \<not> (nP e1) \<le> 0"
    by simp_all
  lemma privacylevel_refl: "((\<le>)::security_level \<Rightarrow> security_level \<Rightarrow> bool) e e"
    by(simp_all)
  lemma BLP_ENF: "SecurityInvariant_withOffendingFlows.sinvar_all_edges_normal_form sinvar (\<le>)"
    unfolding SecurityInvariant_withOffendingFlows.sinvar_all_edges_normal_form_def
    by simp
  lemma BLP_ENF_refl: "SecurityInvariant_withOffendingFlows.ENF_refl sinvar (\<le>)"
    unfolding SecurityInvariant_withOffendingFlows.ENF_refl_def
    apply(rule conjI)
     apply(simp add: BLP_ENF)
    apply(simp add: privacylevel_refl)
  done

  definition BLP_offending_set:: "'v graph \<Rightarrow> ('v \<Rightarrow> security_level) \<Rightarrow> ('v \<times> 'v) set set" where
  "BLP_offending_set G nP = (if sinvar G nP then
      {}
     else
      { {e \<in> edges G. case e of (e1,e2) \<Rightarrow> (nP e1) > (nP e2)} })"
  lemma BLP_offending_set: "SecurityInvariant_withOffendingFlows.set_offending_flows sinvar = BLP_offending_set"
    apply(simp only: fun_eq_iff SecurityInvariant_withOffendingFlows.ENF_offending_set[OF BLP_ENF] BLP_offending_set_def)
    apply(rule allI)+
    apply(rename_tac G nP)
    apply(auto)
  done

  interpretation BLPbasic: SecurityInvariant_IFS sinvar default_node_properties
  rewrites "SecurityInvariant_withOffendingFlows.set_offending_flows sinvar = BLP_offending_set"
    unfolding receiver_violation_def
    unfolding default_node_properties_def
    apply(unfold_locales)
      apply(rule ballI)
      apply(rule SecurityInvariant_withOffendingFlows.ENF_snds_refl_instance[OF BLP_ENF_refl])
         apply(simp_all add: BLP_ENF BLP_ENF_refl)[3]
     apply(erule default_uniqueness_by_counterexample_IFS)
     apply(fact BLP_def_unique)
    apply(fact BLP_offending_set)
   done

  lemma TopoS_BLPBasic: "SecurityInvariant sinvar default_node_properties receiver_violation"
  unfolding receiver_violation_def by unfold_locales

text\<open>Alternate definition of the @{const sinvar}:
      For all reachable nodes, the security level is higher\<close>
lemma sinvar_BLPbasic_tancl:
  "wf_graph G \<Longrightarrow> sinvar G nP = (\<forall> v \<in> nodes G. \<forall>v' \<in> succ_tran G v. (nP v) \<le> (nP v'))"
  proof(unfold sinvar.simps, rule iffI, goal_cases)
  case 1
      have "(v, v') \<in> (edges G)\<^sup>+ \<Longrightarrow> nP v \<le> nP v'" for v v'
        proof(induction rule: trancl_induct)
        case base thus ?case using 1(2) by fastforce
        next
        case step thus ?case using 1(2) by fastforce
        qed
      thus ?case
      by(simp add: succ_tran_def)
    next
    case 2
      from 2(1)[simplified wf_graph_def] have f1: "fst ` edges G \<subseteq> nodes G" by simp
      from f1 2(2) have "\<forall>v \<in> (fst ` edges G). \<forall>v'\<in>succ_tran G v. nP v \<le> nP v'" by auto
      thus ?case unfolding succ_tran_def by fastforce
  qed

hide_fact (open) sinvar_mono
hide_fact BLP_def_unique zero_default_candidate zero_default_candidate_rule privacylevel_refl BLP_ENF BLP_ENF_refl

hide_const (open) sinvar receiver_violation default_node_properties

end


(*  Title:      HOL/Hoare/Arith2.thy
    Author:     Norbert Galm
    Copyright   1995 TUM
*)

section \<open>More arithmetic\<close>

theory Arith2
  imports Main
begin

definition cd :: "[nat, nat, nat] \<Rightarrow> bool"
  where "cd x m n \<longleftrightarrow> x dvd m \<and> x dvd n"

definition gcd :: "[nat, nat] \<Rightarrow> nat"
  where "gcd m n = (SOME x. cd x m n & (\<forall>y.(cd y m n) \<longrightarrow> y\<le>x))"

primrec fac :: "nat \<Rightarrow> nat"
where
  "fac 0 = Suc 0"
| "fac (Suc n) = Suc n * fac n"

subsection \<open>cd\<close>

lemma cd_nnn: "0<n \<Longrightarrow> cd n n n"
  apply (simp add: cd_def)
  done

lemma cd_le: "[| cd x m n; 0<m; 0<n |] ==> x<=m & x<=n"
  apply (unfold cd_def)
  apply (blast intro: dvd_imp_le)
  done

lemma cd_swap: "cd x m n = cd x n m"
  apply (unfold cd_def)
  apply blast
  done

lemma cd_diff_l: "n\<le>m \<Longrightarrow> cd x m n = cd x (m-n) n"
  apply (unfold cd_def)
  apply (fastforce dest: dvd_diffD)
  done

lemma cd_diff_r: "m\<le>n \<Longrightarrow> cd x m n = cd x m (n-m)"
  apply (unfold cd_def)
  apply (fastforce dest: dvd_diffD)
  done

subsection \<open>gcd\<close>

lemma gcd_nnn: "0<n \<Longrightarrow> n = gcd n n"
  apply (unfold gcd_def)
  apply (frule cd_nnn)
  apply (rule some_equality [symmetric])
  apply (blast dest: cd_le)
  apply (blast intro: le_antisym dest: cd_le)
  done

lemma gcd_swap: "gcd m n = gcd n m"
  apply (simp add: gcd_def cd_swap)
  done

lemma gcd_diff_l: "n\<le>m \<Longrightarrow> gcd m n = gcd (m-n) n"
  apply (unfold gcd_def)
  apply (subgoal_tac "n\<le>m \<Longrightarrow> \<forall>x. cd x m n = cd x (m-n) n")
  apply simp
  apply (rule allI)
  apply (erule cd_diff_l)
  done

lemma gcd_diff_r: "m\<le>n \<Longrightarrow> gcd m n = gcd m (n-m)"
  apply (unfold gcd_def)
  apply (subgoal_tac "m\<le>n \<Longrightarrow> \<forall>x. cd x m n = cd x m (n-m) ")
  apply simp
  apply (rule allI)
  apply (erule cd_diff_r)
  done

subsection \<open>pow\<close>

lemma sq_pow_div2 [simp]:
    "m mod 2 = 0 \<Longrightarrow> ((n::nat)*n)^(m div 2) = n^m"
  apply (simp add: power2_eq_square [symmetric] power_mult [symmetric] minus_mod_eq_mult_div [symmetric])
  done

end


theory FOL_Extra
  imports
    Type_Instances_Impl
    "FOL-Fitting.FOL_Fitting"
    "HOL-Library.FSet"
begin

section \<open>Additional support for FOL-Fitting\<close>
subsection \<open>Iff\<close>

definition Iff where
  "Iff p q = And (Impl p q) (Impl q p)"

lemma eval_Iff:
  "eval e f g (Iff p q) \<longleftrightarrow> (eval e f g p \<longleftrightarrow> eval e f g q)"
  by (auto simp: Iff_def)

subsection \<open>Replacement of subformulas\<close>

datatype ('a, 'b) ctxt
  = Hole
  | And1 "('a, 'b) ctxt" "('a, 'b) form"
  | And2 "('a, 'b) form" "('a, 'b) ctxt"
  | Or1 "('a, 'b) ctxt" "('a, 'b) form"
  | Or2 "('a, 'b) form" "('a, 'b) ctxt"
  | Impl1 "('a, 'b) ctxt" "('a, 'b) form"
  | Impl2 "('a, 'b) form" "('a, 'b) ctxt"
  | Neg1 "('a, 'b) ctxt"
  | Forall1 "('a, 'b) ctxt"
  | Exists1 "('a, 'b) ctxt"

primrec apply_ctxt :: "('a, 'b) ctxt \<Rightarrow> ('a, 'b) form \<Rightarrow> ('a, 'b) form" where
  "apply_ctxt Hole p = p"
| "apply_ctxt (And1 c v) p = And (apply_ctxt c p) v"
| "apply_ctxt (And2 u c) p = And u (apply_ctxt c p)"
| "apply_ctxt (Or1 c v) p = Or (apply_ctxt c p) v"
| "apply_ctxt (Or2 u c) p = Or u (apply_ctxt c p)"
| "apply_ctxt (Impl1 c v) p = Impl (apply_ctxt c p) v"
| "apply_ctxt (Impl2 u c) p = Impl u (apply_ctxt c p)"
| "apply_ctxt (Neg1 c) p = Neg (apply_ctxt c p)"
| "apply_ctxt (Forall1 c) p = Forall (apply_ctxt c p)"
| "apply_ctxt (Exists1 c) p = Exists (apply_ctxt c p)"

lemma replace_subformula:
  assumes "\<And>e. eval e f g (Iff p q)"
  shows "eval e f g (Iff (apply_ctxt c p) (apply_ctxt c q))"
  by (induct c arbitrary: e) (auto simp: assms[unfolded eval_Iff] Iff_def)

subsection \<open>Propositional identities\<close>

lemma prop_ids:
  "eval e f g (Iff (And p q) (And q p))"
  "eval e f g (Iff (Or p q) (Or q p))"
  "eval e f g (Iff (Or p (Or q r)) (Or (Or p q) r))"
  "eval e f g (Iff (And p (And q r)) (And (And p q) r))"
  "eval e f g (Iff (Neg (Or p q)) (And (Neg p) (Neg q)))"
  "eval e f g (Iff (Neg (And p q)) (Or (Neg p) (Neg q)))"
  (* ... *)
  by (auto simp: Iff_def)

subsection \<open>de Bruijn index manipulation for formulas; cf. @{term liftt}\<close>

primrec liftti :: "nat \<Rightarrow> 'a term \<Rightarrow> 'a term" where
  "liftti i (Var j) = (if i > j then Var j else Var (Suc j))"
| "liftti i (App f ts) = App f (map (liftti i) ts)"

lemma liftts_def':
  "liftts ts = map liftt ts"
  by (induct ts) auto

text \<open>@{term liftt} is a special case of @{term liftti}\<close>
lemma lifttti_0:
  "liftti 0 t = liftt t"
  by (induct t) (auto simp: liftts_def')

primrec lifti :: "nat \<Rightarrow> ('a, 'b) form \<Rightarrow> ('a, 'b) form" where
  "lifti i FF = FF"
| "lifti i TT = TT"
| "lifti i (Pred b ts) = Pred b (map (liftti i) ts)"
| "lifti i (And p q) = And (lifti i p) (lifti i q)"
| "lifti i (Or p q) = Or (lifti i p) (lifti i q)"
| "lifti i (Impl p q) = Impl (lifti i p) (lifti i q)"
| "lifti i (Neg p) = Neg (lifti i p)"
| "lifti i (Forall p) = Forall (lifti (Suc i) p)"
| "lifti i (Exists p) = Exists (lifti (Suc i) p)"

abbreviation lift where
  "lift \<equiv> lifti 0"

text \<open>interaction of @{term lifti} and @{term eval}\<close>

lemma evalts_def':
  "evalts e f ts = map (evalt e f) ts"
  by (induct ts) auto

lemma evalt_liftti:
  "evalt (e\<langle>i:z\<rangle>) f (liftti i t) = evalt e f t"
  by (induct t) (auto simp: evalts_def' cong: map_cong)

lemma eval_lifti [simp]:
  "eval (e\<langle>i:z\<rangle>) f g (lifti i p) = eval e f g p"
  by (induct p arbitrary: e i) (auto simp: evalt_liftti evalts_def' comp_def)

subsection \<open>Quantifier Identities\<close>

lemma quant_ids:
  "eval e f g (Iff (Neg (Exists p)) (Forall (Neg p)))"
  "eval e f g (Iff (Neg (Forall p)) (Exists (Neg p)))"
  "eval e f g (Iff (And p (Forall q)) (Forall (And (lift p) q)))"
  "eval e f g (Iff (And p (Exists q)) (Exists (And (lift p) q)))"
  "eval e f g (Iff (Or p (Forall q)) (Forall (Or (lift p) q)))"
  "eval e f g (Iff (Or p (Exists q)) (Exists (Or (lift p) q)))"
  (* ... *)
  by (auto simp: Iff_def)

(* We'd need a bit of more machinery to deal with "\<forall>x y. P(x,y) \<longleftrightarrow> \<forall>y x. P(x, y)":
 * swapping of de Bruijn indices (perhaps arbitrary permutation?) *)

subsection \<open>Function symbols and predicates, with arities.\<close>

primrec predas_form :: "('a, 'b) form \<Rightarrow> ('b \<times> nat) set" where
  "predas_form FF = {}"
| "predas_form TT = {}"
| "predas_form (Pred b ts) = {(b, length ts)}"
| "predas_form (And p q) = predas_form p \<union> predas_form q"
| "predas_form (Or p q) = predas_form p \<union> predas_form q"
| "predas_form (Impl p q) = predas_form p \<union> predas_form q"
| "predas_form (Neg p) = predas_form p"
| "predas_form (Forall p) = predas_form p"
| "predas_form (Exists p) = predas_form p"

primrec funas_term :: "'a term \<Rightarrow> ('a \<times> nat) set" where
  "funas_term (Var x) = {}"
| "funas_term (App f ts) = {(f, length ts)} \<union> \<Union>(set (map funas_term ts))"

primrec terms_form :: "('a, 'b) form \<Rightarrow> 'a term set" where
  "terms_form FF = {}"
| "terms_form TT = {}"
| "terms_form (Pred b ts) = set ts"
| "terms_form (And p q) = terms_form p \<union> terms_form q"
| "terms_form (Or p q) = terms_form p \<union> terms_form q"
| "terms_form (Impl p q) = terms_form p \<union> terms_form q"
| "terms_form (Neg p) = terms_form p"
| "terms_form (Forall p) = terms_form p"
| "terms_form (Exists p) = terms_form p"

definition funas_form :: "('a, 'b) form \<Rightarrow> ('a \<times> nat) set" where
  "funas_form f \<equiv> \<Union>(funas_term ` terms_form f)"

subsection \<open>Negation Normal Form\<close>

inductive is_nnf :: "('a, 'b) form \<Rightarrow> bool" where
  "is_nnf TT"
| "is_nnf FF"
| "is_nnf (Pred p ts)"
| "is_nnf (Neg (Pred p ts))"
| "is_nnf p \<Longrightarrow> is_nnf q \<Longrightarrow> is_nnf (And p q)"
| "is_nnf p \<Longrightarrow> is_nnf q \<Longrightarrow> is_nnf (Or p q)"
| "is_nnf p \<Longrightarrow> is_nnf (Forall p)"
| "is_nnf p \<Longrightarrow> is_nnf (Exists p)"

primrec nnf' :: "bool \<Rightarrow> ('a, 'b) form \<Rightarrow> ('a, 'b) form" where
  "nnf' b TT          = (if b then TT else FF)"
| "nnf' b FF          = (if b then FF else TT)"
| "nnf' b (Pred p ts) = (if b then id else Neg) (Pred p ts)"
| "nnf' b (And p q)   = (if b then And else Or) (nnf' b p) (nnf' b q)"
| "nnf' b (Or p q)    = (if b then Or else And) (nnf' b p) (nnf' b q)"
| "nnf' b (Impl p q)  = (if b then Or else And) (nnf' (\<not> b) p) (nnf' b q)"
| "nnf' b (Neg p)     = nnf' (\<not> b) p"
| "nnf' b (Forall p)  = (if b then Forall else Exists) (nnf' b p)"
| "nnf' b (Exists p)  = (if b then Exists else Forall) (nnf' b p)"

lemma eval_nnf':
  "eval e f g (nnf' b p) \<longleftrightarrow> (eval e f g p \<longleftrightarrow> b)"
  by (induct p arbitrary: e b) auto

lemma is_nnf_nnf':
  "is_nnf (nnf' b p)"
  by (induct p arbitrary: b) (auto intro: is_nnf.intros)

abbreviation nnf where
  "nnf \<equiv> nnf' True"

lemmas nnf_simpls [simp] = eval_nnf'[where b = True, unfolded eq_True] is_nnf_nnf'[where b = True]

subsection \<open>Reasoning modulo ACI01\<close>

datatype ('a, 'b) form_aci
  = TT_aci
  | FF_aci
  | Pred_aci bool 'b "'a term list"
  | And_aci "('a, 'b) form_aci fset"
  | Or_aci "('a, 'b) form_aci fset"
  | Forall_aci "('a, 'b) form_aci"
  | Exists_aci "('a, 'b) form_aci"

text \<open>evaluation, see @{const eval}\<close>

primrec eval_aci :: \<open>(nat \<Rightarrow> 'c) \<Rightarrow> ('a \<Rightarrow> 'c list \<Rightarrow> 'c) \<Rightarrow>
  ('b \<Rightarrow> 'c list \<Rightarrow> bool) \<Rightarrow> ('a, 'b) form_aci \<Rightarrow> bool\<close> where
  "eval_aci e f g FF_aci            \<longleftrightarrow> False"
| "eval_aci e f g TT_aci            \<longleftrightarrow> True"
| "eval_aci e f g (Pred_aci b a ts) \<longleftrightarrow> (g a (evalts e f ts) \<longleftrightarrow> b)"
| "eval_aci e f g (And_aci ps)      \<longleftrightarrow> fBall (fimage (eval_aci e f g) ps) id"
| "eval_aci e f g (Or_aci ps)       \<longleftrightarrow> fBex (fimage (eval_aci e f g) ps) id"
| "eval_aci e f g (Forall_aci p)    \<longleftrightarrow> (\<forall>z. eval_aci (e\<langle>0:z\<rangle>) f g p)"
| "eval_aci e f g (Exists_aci p)    \<longleftrightarrow> (\<exists>z. eval_aci (e\<langle>0:z\<rangle>) f g p)"

text \<open>smart constructor: conjunction\<close>

fun and_aci where
  "and_aci FF_aci       _            = FF_aci"
| "and_aci _            FF_aci       = FF_aci"
| "and_aci TT_aci       q            = q"
| "and_aci p            TT_aci       = p"
| "and_aci (And_aci ps) (And_aci qs) = And_aci (ps |\<union>| qs)"
| "and_aci (And_aci ps) q            = And_aci (ps |\<union>| {|q|})"
| "and_aci p            (And_aci qs) = And_aci ({|p|} |\<union>| qs)"
| "and_aci p            q            = (if p = q then p else And_aci {|p,q|})"

lemma eval_and_aci [simp]:
  "eval_aci e f g (and_aci p q) \<longleftrightarrow> eval_aci e f g p \<and> eval_aci e f g q"
  by (cases "(p, q)" rule: and_aci.cases) (simp_all add: fBall_funion, meson+)

declare and_aci.simps [simp del]

text \<open>smart constructor: disjunction\<close>

fun or_aci where
  "or_aci TT_aci       _            = TT_aci"
| "or_aci _            TT_aci       = TT_aci"
| "or_aci FF_aci       q            = q"
| "or_aci p            FF_aci       = p"
| "or_aci (Or_aci ps)  (Or_aci qs)  = Or_aci (ps |\<union>| qs)"
| "or_aci (Or_aci ps)  q            = Or_aci (ps |\<union>| {|q|})"
| "or_aci p            (Or_aci qs)  = Or_aci ({|p|} |\<union>| qs)"
| "or_aci p            q            = (if p = q then p else Or_aci {|p,q|})"

lemma eval_or_aci [simp]:
  "eval_aci e f g (or_aci p q) \<longleftrightarrow> eval_aci e f g p \<or> eval_aci e f g q"
  by (cases "(p, q)" rule: or_aci.cases) (simp_all add: fBex_funion, meson+)

declare or_aci.simps [simp del]

text \<open>convert negation normal form to ACIU01 normal form\<close>

fun nnf_to_aci :: "('a, 'b) form \<Rightarrow> ('a, 'b) form_aci" where
  "nnf_to_aci FF                = FF_aci"
| "nnf_to_aci TT                = TT_aci"
| "nnf_to_aci (Pred b ts)       = Pred_aci True b ts"
| "nnf_to_aci (Neg (Pred b ts)) = Pred_aci False b ts"
| "nnf_to_aci (And p q)         = and_aci (nnf_to_aci p) (nnf_to_aci q)"
| "nnf_to_aci (Or p q)          = or_aci (nnf_to_aci p) (nnf_to_aci q)"
| "nnf_to_aci (Forall p)        = Forall_aci (nnf_to_aci p)"
| "nnf_to_aci (Exists p)        = Exists_aci (nnf_to_aci p)"
| "nnf_to_aci _                 = undefined" (* the remaining cases are impossible for NNFs *)

lemma eval_nnf_to_aci:
  "is_nnf p \<Longrightarrow> eval_aci e f g (nnf_to_aci p) \<longleftrightarrow> eval e f g p"
  by (induct p arbitrary: e rule: is_nnf.induct) simp_all

subsection \<open>A (mostly) Propositional Equivalence Check\<close>

text \<open>We reason modulo $\forall = \neg\exists\neg$, de Morgan, double negation, and
  ACUI01 of $\vee$ and $\wedge$, by converting to negation normal form, and then collapsing
  conjunctions and disjunctions taking units, absorption, commutativity, associativity, and
  idempotence into account. We only need soundness for a certifier.\<close>

lemma check_equivalence_by_nnf_aci:
  "nnf_to_aci (nnf p) = nnf_to_aci (nnf q) \<Longrightarrow> eval e f g p \<longleftrightarrow> eval e f g q"
  by (metis eval_nnf_to_aci is_nnf_nnf' eval_nnf')

subsection \<open>Reasoning modulo ACI01\<close>

datatype ('a, 'b) form_list_aci
  = TT_aci
  | FF_aci
  | Pred_aci bool 'b "'a term list"
  | And_aci "('a, 'b) form_list_aci list"
  | Or_aci "('a, 'b) form_list_aci list"
  | Forall_aci "('a, 'b) form_list_aci"
  | Exists_aci "('a, 'b) form_list_aci"

text \<open>evaluation, see @{const eval}\<close>

fun eval_list_aci :: \<open>(nat \<Rightarrow> 'c) \<Rightarrow> ('a \<Rightarrow> 'c list \<Rightarrow> 'c) \<Rightarrow>
  ('b \<Rightarrow> 'c list \<Rightarrow> bool) \<Rightarrow> ('a, 'b) form_list_aci \<Rightarrow> bool\<close> where
  "eval_list_aci e f g FF_aci            \<longleftrightarrow> False"
| "eval_list_aci e f g TT_aci            \<longleftrightarrow> True"
| "eval_list_aci e f g (Pred_aci b a ts) \<longleftrightarrow> (g a (evalts e f ts) \<longleftrightarrow> b)"
| "eval_list_aci e f g (And_aci ps)      \<longleftrightarrow> list_all (\<lambda> fm. eval_list_aci e f g fm) ps"
| "eval_list_aci e f g (Or_aci ps)       \<longleftrightarrow> list_ex (\<lambda> fm. eval_list_aci e f g fm) ps"
| "eval_list_aci e f g (Forall_aci p)    \<longleftrightarrow> (\<forall>z. eval_list_aci (e\<langle>0:z\<rangle>) f g p)"
| "eval_list_aci e f g (Exists_aci p)    \<longleftrightarrow> (\<exists>z. eval_list_aci (e\<langle>0:z\<rangle>) f g p)"

text \<open>smart constructor: conjunction\<close>

fun and_list_aci where
  "and_list_aci FF_aci       _            = FF_aci"
| "and_list_aci _            FF_aci       = FF_aci"
| "and_list_aci TT_aci       q            = q"
| "and_list_aci p            TT_aci       = p"
| "and_list_aci (And_aci ps) (And_aci qs) = And_aci (remdups (ps @ qs))"
| "and_list_aci (And_aci ps) q            = And_aci (List.insert q ps)"
| "and_list_aci p            (And_aci qs) = And_aci (List.insert p qs)"
| "and_list_aci p            q            = (if p = q then p else And_aci [p,q])"

lemma eval_and_list_aci [simp]:
  "eval_list_aci e f g (and_list_aci p q) \<longleftrightarrow> eval_list_aci e f g p \<and> eval_list_aci e f g q"
  apply (cases "(p, q)" rule: and_list_aci.cases)
  apply (simp_all add: list.pred_set list_ex_iff)
  apply blast+
  done

declare and_list_aci.simps [simp del]

text \<open>smart constructor: disjunction\<close>

fun or_list_aci where
  "or_list_aci TT_aci       _            = TT_aci"
| "or_list_aci _            TT_aci       = TT_aci"
| "or_list_aci FF_aci       q            = q"
| "or_list_aci p            FF_aci       = p"
| "or_list_aci (Or_aci ps)  (Or_aci qs)  = Or_aci (remdups (ps @ qs))"
| "or_list_aci (Or_aci ps)  q            = Or_aci (List.insert q ps)"
| "or_list_aci p            (Or_aci qs)  = Or_aci (List.insert p qs)"
| "or_list_aci p            q            = (if p = q then p else Or_aci [p,q])"

lemma eval_or_list_aci [simp]:
  "eval_list_aci e f g (or_list_aci p q) \<longleftrightarrow> eval_list_aci e f g p \<or> eval_list_aci e f g q"
  by (cases "(p, q)" rule: or_list_aci.cases) (simp_all add: list.pred_set list_ex_iff, blast+)

declare or_list_aci.simps [simp del]

text \<open>convert negation normal form to ACIU01 normal form\<close>

fun nnf_to_list_aci :: "('a, 'b) form \<Rightarrow> ('a, 'b) form_list_aci" where
  "nnf_to_list_aci FF                = FF_aci"
| "nnf_to_list_aci TT                = TT_aci"
| "nnf_to_list_aci (Pred b ts)       = Pred_aci True b ts"
| "nnf_to_list_aci (Neg (Pred b ts)) = Pred_aci False b ts"
| "nnf_to_list_aci (And p q)         = and_list_aci (nnf_to_list_aci p) (nnf_to_list_aci q)"
| "nnf_to_list_aci (Or p q)          = or_list_aci (nnf_to_list_aci p) (nnf_to_list_aci q)"
| "nnf_to_list_aci (Forall p)        = Forall_aci (nnf_to_list_aci p)"
| "nnf_to_list_aci (Exists p)        = Exists_aci (nnf_to_list_aci p)"
| "nnf_to_list_aci _                 = undefined" (* the remaining cases are impossible for NNFs *)

lemma eval_nnf_to_list_aci:
  "is_nnf p \<Longrightarrow> eval_list_aci e f g (nnf_to_list_aci p) \<longleftrightarrow> eval e f g p"
  by (induct p arbitrary: e rule: is_nnf.induct) simp_all

subsection \<open>A (mostly) Propositional Equivalence Check\<close>

text \<open>We reason modulo $\forall = \neg\exists\neg$, de Morgan, double negation, and
  ACUI01 of $\vee$ and $\wedge$, by converting to negation normal form, and then collapsing
  conjunctions and disjunctions taking units, absorption, commutativity, associativity, and
  idempotence into account. We only need soundness for a certifier.\<close>

derive linorder "term"
derive compare "term"
derive linorder form_list_aci
derive compare form_list_aci

fun ord_form_list_aci where
  "ord_form_list_aci TT_aci = TT_aci"
| "ord_form_list_aci FF_aci = FF_aci"
| "ord_form_list_aci (Pred_aci bool b ts) = Pred_aci bool b ts"
| "ord_form_list_aci (And_aci fm) = (And_aci (sort (map ord_form_list_aci fm)))"
| "ord_form_list_aci (Or_aci fm) = (Or_aci (sort (map ord_form_list_aci fm)))"
| "ord_form_list_aci (Forall_aci fm) = (Forall_aci (ord_form_list_aci fm))"
| "ord_form_list_aci (Exists_aci fm) = Exists_aci (ord_form_list_aci fm)"

lemma and_list_aci_simps:
  "and_list_aci TT_aci q = q"
  "and_list_aci q FF_aci = FF_aci"
  by (cases q, auto simp add: and_list_aci.simps)+

lemma ord_form_list_idemp:
  "ord_form_list_aci (ord_form_list_aci q) = ord_form_list_aci q"
  apply (induct q) apply (auto simp: list.set_map)
  apply (smt imageE list.set_map map_idI set_sort sorted_sort_id sorted_sort_key)+
  done

lemma eval_lsit_aci_ord_form_list_aci:
  "eval_list_aci e f g (ord_form_list_aci p) \<longleftrightarrow> eval_list_aci e f g p"
  by (induct p arbitrary: e) (auto simp: list.pred_set list_ex_iff)

lemma check_equivalence_by_nnf_sortedlist_aci:
  "ord_form_list_aci (nnf_to_list_aci (nnf p)) = ord_form_list_aci (nnf_to_list_aci (nnf q)) \<Longrightarrow> eval e f g p \<longleftrightarrow> eval e f g q"
  by (metis eval_nnf_to_list_aci eval_lsit_aci_ord_form_list_aci is_nnf_nnf' eval_nnf')

hide_type (open) "term"
hide_const (open) Var
hide_type (open) ctxt

end