diff --git a/thys/Algebraic_VCs/Domain_Quantale.thy b/thys/Algebraic_VCs/Domain_Quantale.thy
--- a/thys/Algebraic_VCs/Domain_Quantale.thy
+++ b/thys/Algebraic_VCs/Domain_Quantale.thy
@@ -1,523 +1,524 @@
 (* Title: Domain Quantales
    Author: Victor Gomes, Georg Struth
    Maintainer: Victor Gomes <victor.gomes@cl.cam.ac.uk>
                Georg Struth <g.struth@sheffield.ac.uk> 
 *)
 
 section \<open>Component for Recursive Programs\<close>
 
 theory Domain_Quantale
   imports KAD.Modal_Kleene_Algebra
 
 begin
 
 text \<open>This component supports the verification and step-wise refinement of recursive programs
 in a partial correctness setting.\<close>
 
 notation
   times (infixl "\<cdot>" 70) and
   bot ("\<bottom>") and
   top ("\<top>") and
   inf (infixl "\<sqinter>" 65) and
   sup (infixl "\<squnion>" 65)
 (*
   Inf ("\<Sqinter>_" [900] 900) and
   Sup ("\<Squnion>_" [900] 900)
 *)
 
 (*
 syntax
   "_INF1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Sqinter>_./ _)" [0, 10] 10)
   "_INF"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Sqinter>_\<in>_./ _)" [0, 0, 10] 10)
   "_SUP1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Squnion>_./ _)" [0, 10] 10)
   "_SUP"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Squnion>_\<in>_./ _)" [0, 0, 10] 10)
 
 *)
 
 subsection \<open>Lattice-Ordered Monoids with Domain\<close>
 
 class bd_lattice_ordered_monoid = bounded_lattice + distrib_lattice + monoid_mult +
   assumes left_distrib: "x \<cdot> (y \<squnion> z) = x \<cdot> y \<squnion> x \<cdot> z"
   and right_distrib: "(x \<squnion> y) \<cdot> z = x \<cdot> z \<squnion> y \<cdot> z"
   and bot_annil [simp]: "\<bottom> \<cdot> x = \<bottom>"
   and bot_annir [simp]: "x \<cdot> \<bottom> = \<bottom>"
 
 begin
 
 sublocale semiring_one_zero "(\<squnion>)" "(\<cdot>)" "1" "bot" 
   by (standard, auto simp: sup.assoc sup.commute sup_left_commute left_distrib right_distrib sup_absorb1)   
 
 sublocale dioid_one_zero "(\<squnion>)" "(\<cdot>)" "1" bot "(\<le>)" "(<)"
   by (standard, simp add: le_iff_sup, auto)
 
 end
 
 no_notation ads_d ("d")
   and ars_r ("r")
   and antirange_op ("ar _" [999] 1000)
 
 class domain_bdlo_monoid = bd_lattice_ordered_monoid +
   assumes rdv: "(z \<sqinter> x \<cdot> top) \<cdot> y = z \<cdot> y \<sqinter> x \<cdot> top"  
 
 begin 
 
 definition "d x = 1 \<sqinter> x \<cdot> \<top>"
 
 sublocale ds: domain_semiring "(\<squnion>)" "(\<cdot>)" "1" "\<bottom>" "d" "(\<le>)" "(<)"
 proof standard
   fix x y
   show "x \<squnion> d x \<cdot> x = d x \<cdot> x"
     by (metis d_def inf_sup_absorb left_distrib mult_1_left mult_1_right rdv sup.absorb_iff1 sup.idem sup.left_commute top_greatest)
   show "d (x \<cdot> d y) = d (x \<cdot> y)"
     by (simp add: d_def inf_absorb2 rdv  mult_assoc)
   show "d x \<squnion> 1 = 1"
     by (simp add: d_def sup.commute)
   show "d bot = bot"
     by (simp add: d_def inf.absorb1 inf.commute)
   show "d (x \<squnion> y) = d x \<squnion> d y"
     by (simp add: d_def inf_sup_distrib1)
 qed
 
 end
 
 subsection\<open>Boolean Monoids with Domain\<close>
 
 class boolean_monoid = boolean_algebra + monoid_mult +  
   assumes left_distrib': "x \<cdot> (y \<squnion> z) = x \<cdot> y \<squnion> x \<cdot> z"
   and right_distrib': "(x \<squnion> y) \<cdot> z = x \<cdot> z \<squnion> y \<cdot> z"
   and bot_annil' [simp]: "\<bottom> \<cdot> x = \<bottom>"
   and bot_annir' [simp]: "x \<cdot> \<bottom> = \<bottom>"
 
 begin
 
 subclass bd_lattice_ordered_monoid
   by (standard, simp_all add: left_distrib' right_distrib')
 
 lemma inf_bot_iff_le: "x \<sqinter> y = \<bottom> \<longleftrightarrow> x \<le> -y"
   by (metis le_iff_inf inf_sup_distrib1 inf_top_right sup_bot.left_neutral sup_compl_top compl_inf_bot inf.assoc inf_bot_right)
 
 end
 
 class domain_boolean_monoid = boolean_monoid + 
   assumes rdv': "(z \<sqinter> x \<cdot> \<top>) \<cdot> y = z \<cdot> y \<sqinter> x \<cdot> \<top>"     
 
 begin
 
 sublocale dblo: domain_bdlo_monoid "1" "(\<cdot>)" "(\<sqinter>)" "(\<le>)" "(<)" "(\<squnion>)" "\<bottom>" "\<top>"
   by (standard, simp add: rdv')
 
 definition "a x = 1 \<sqinter> -(dblo.d x)"
                                 
 lemma a_d_iff: "a x = 1 \<sqinter> -(x \<cdot> \<top>)"
   by (clarsimp simp: a_def dblo.d_def inf_sup_distrib1) 
 
 lemma topr: "-(x \<cdot> \<top>) \<cdot> \<top> = -(x \<cdot> \<top>)" 
 proof (rule order.antisym)
   show "-(x \<cdot> \<top>) \<le> -(x \<cdot> \<top>) \<cdot> \<top>"
     by (metis mult_isol_var mult_oner order_refl top_greatest)
   have "-(x \<cdot> \<top>) \<sqinter> (x \<cdot> \<top>) = \<bottom>"
     by simp
   hence "(-(x \<cdot> \<top>) \<sqinter> (x \<cdot> \<top>)) \<cdot> \<top>  = \<bottom>"
     by simp 
   hence "-(x \<cdot> \<top>) \<cdot> \<top> \<sqinter> (x \<cdot> \<top>)  = \<bottom>"
     by (metis rdv') 
   thus "-(x \<cdot> \<top>) \<cdot> \<top> \<le> -(x \<cdot> \<top>)"
     by (simp add: inf_bot_iff_le)
 qed
 
 lemma dd_a: "dblo.d x = a (a x)"
   by (metis a_d_iff dblo.d_def double_compl inf_top.left_neutral mult_1_left rdv' topr)
 
 lemma ad_a [simp]: "a (dblo.d x) = a x"
   by (simp add: a_def)
 
 lemma da_a [simp]: "dblo.d (a x) = a x"
   using ad_a dd_a by auto
 
 lemma a1 [simp]: "a x \<cdot> x = \<bottom>"
 proof -
   have "a x \<cdot> x \<cdot> \<top> = \<bottom>"
     by (metis a_d_iff inf_compl_bot mult_1_left rdv' topr)
   then show ?thesis
     by (metis (no_types) dblo.d_def dblo.ds.domain_very_strict inf_bot_right)
 qed
 
 lemma a2 [simp]: "a (x \<cdot> y) \<squnion> a (x \<cdot> a (a y)) = a (x \<cdot> a (a y))"
   by (metis a_def dblo.ds.dsr2 dd_a sup.idem)
 
 lemma a3 [simp]: "a (a x) \<squnion> a x = 1"
   by (metis a_def da_a inf.commute sup.commute sup_compl_top sup_inf_absorb sup_inf_distrib1)
 
 subclass domain_bdlo_monoid ..
 
 text \<open>The next statement shows that every boolean monoid with domain is an antidomain semiring. 
 In this setting the domain operation has been defined explicitly.\<close>
 
 sublocale ad: antidomain_semiring a "(\<squnion>)" "(\<cdot>)" "1" "\<bottom>" "(\<le>)" "(<)"
   rewrites ad_eq: "ad.ads_d x = d x"
 proof -
   show "class.antidomain_semiring a (\<squnion>) (\<cdot>) 1 \<bottom> (\<le>) (<)"
     by (standard, simp_all)
   then interpret ad: antidomain_semiring a "(\<squnion>)" "(\<cdot>)" "1" "\<bottom>" "(\<le>)" "(<)" .
   show "ad.ads_d x = d x"
     by (simp add: ad.ads_d_def dd_a)
 qed
 
 end 
 
 subsection\<open>Boolean Monoids with Range\<close>
 
 class range_boolean_monoid = boolean_monoid + 
   assumes ldv': "y \<cdot> (z \<sqinter> \<top> \<cdot> x) = y \<cdot> z \<sqinter> \<top> \<cdot> x"
 
 begin
 
 definition "r x = 1 \<sqinter> \<top> \<cdot> x"
 
 definition "ar x = 1 \<sqinter> -(r x)"
                                 
 lemma ar_r_iff: "ar x = 1 \<sqinter> -(\<top> \<cdot> x)"
   by (simp add: ar_def inf_sup_distrib1 r_def)
 
 lemma topl: "\<top>\<cdot>(-(\<top> \<cdot> x)) = -(\<top> \<cdot> x)" 
 proof (rule order.antisym)
   show "\<top> \<cdot> - (\<top> \<cdot> x) \<le> - (\<top> \<cdot> x)"
     by (metis bot_annir' compl_inf_bot inf_bot_iff_le ldv')
   show "- (\<top> \<cdot> x) \<le> \<top> \<cdot> - (\<top> \<cdot> x)"
     by (metis inf_le2 inf_top.right_neutral mult_1_left mult_isor)
 qed
 
 lemma r_ar: "r x = ar (ar x)"
   by (metis ar_r_iff double_compl inf.commute inf_top.right_neutral ldv' mult_1_right r_def topl)
 
 lemma ar_ar [simp]: "ar (r x) = ar x"
   by (simp add: ar_def ldv' r_def)
 
 lemma rar_ar [simp]: "r (ar x) = ar x"
   using r_ar ar_ar by force
 
 lemma ar1 [simp]: "x \<cdot> ar x = \<bottom>"
 proof -
   have "\<top> \<cdot> x \<cdot> ar x = \<bottom>"
     by (metis ar_r_iff inf_compl_bot ldv' mult_oner topl)
   then show ?thesis
     by (metis inf_bot_iff_le inf_le2 inf_top.right_neutral mult_1_left mult_isor mult_oner topl)
 qed
 
 lemma ars: "r (r x \<cdot> y) = r (x \<cdot> y)"
   by (metis inf.commute inf_top.right_neutral ldv' mult_oner mult_assoc r_def)
 
 lemma ar2 [simp]: "ar (x \<cdot> y) \<squnion> ar (ar (ar x) \<cdot> y) = ar (ar (ar x) \<cdot> y)"
   by (metis ar_def ars r_ar sup.idem)
                          
 lemma ar3 [simp]: "ar (ar x) \<squnion> ar x = 1 "
   by (metis ar_def rar_ar inf.commute sup.commute sup_compl_top sup_inf_absorb sup_inf_distrib1)
 
 sublocale ar: antirange_semiring "(\<squnion>)" "(\<cdot>)" "1" "\<bottom>" ar "(\<le>)" "(<)"
   rewrites ar_eq: "ar.ars_r x = r x"
 proof -
   show "class.antirange_semiring (\<squnion>) (\<cdot>) 1 \<bottom> ar (\<le>) (<)"
     by (standard, simp_all)
   then interpret ar: antirange_semiring "(\<squnion>)" "(\<cdot>)" "1" "\<bottom>" ar "(\<le>)" "(<)" .
   show "ar.ars_r x = r x"
     by (simp add: ar.ars_r_def r_ar)
 qed
 
 end
 
 subsection \<open>Quantales\<close>
 
 text \<open>This part will eventually move into an AFP quantale entry.\<close> 
 
 class quantale = complete_lattice + monoid_mult +
   assumes Sup_distr: "Sup X \<cdot> y = Sup {z. \<exists>x \<in> X. z = x \<cdot> y}"
   and Sup_distl: "x \<cdot> Sup Y = Sup {z. \<exists>y \<in> Y. z = x \<cdot> y}"       
 
 begin
 
 lemma bot_annil'' [simp]: "\<bottom> \<cdot> x = \<bottom>"
   using Sup_distr[where X="{}"] by auto
 
 lemma bot_annirr'' [simp]: "x \<cdot> \<bottom> = \<bottom>"
   using Sup_distl[where Y="{}"] by auto
 
 lemma sup_distl: "x \<cdot> (y \<squnion> z) = x \<cdot> y \<squnion> x \<cdot> z"
   using Sup_distl[where Y="{y, z}"] by (fastforce intro!: Sup_eqI)
 
 lemma sup_distr: "(x \<squnion> y) \<cdot> z = x \<cdot> z \<squnion> y \<cdot> z"
   using Sup_distr[where X="{x, y}"] by (fastforce intro!: Sup_eqI)
 
 sublocale semiring_one_zero "(\<squnion>)" "(\<cdot>)" "1" "\<bottom>" 
   by (standard, auto simp: sup.assoc sup.commute sup_left_commute sup_distl sup_distr)     
 
 sublocale dioid_one_zero "(\<squnion>)" "(\<cdot>)" "1" "\<bottom>" "(\<le>)" "(<)"
   by (standard, simp add: le_iff_sup, auto)
 
 lemma Sup_sup_pred: "x \<squnion> Sup{y. P y} = Sup{y. y = x \<or> P y}"
   apply (rule order.antisym)
   apply (simp add: Collect_mono Sup_subset_mono Sup_upper) 
   using Sup_least Sup_upper le_supI2 by fastforce
 
 definition star :: "'a \<Rightarrow> 'a" where
   "star x = (SUP i. x ^ i)"
 
 lemma star_def_var1: "star x = Sup{y. \<exists>i. y = x ^ i}"
   by (simp add: star_def full_SetCompr_eq)
 
 lemma star_def_var2: "star x = Sup{x ^ i |i. True}"
   by (simp add: star_def full_SetCompr_eq)
 
 lemma star_unfoldl' [simp]: "1 \<squnion> x \<cdot> (star x) = star x"
 proof -
   have "1 \<squnion> x \<cdot> (star x) = x ^ 0 \<squnion> x \<cdot> Sup{y. \<exists>i. y = x ^ i}"
     by (simp add: star_def_var1)
   also have "... = x ^ 0 \<squnion> Sup{y. \<exists>i. y = x ^ (i + 1)}"
     by (simp add: Sup_distl, metis)
   also have "... = Sup{y. y = x ^ 0 \<or> (\<exists>i. y = x ^ (i + 1))}"
     using Sup_sup_pred by simp
   also have "... = Sup{y. \<exists>i. y = x ^ i}"
     by (metis Suc_eq_plus1 power.power.power_Suc power.power_eq_if)
   finally show ?thesis
     by (simp add: star_def_var1)
 qed
 
 lemma star_unfoldr' [simp]: "1 \<squnion> (star x) \<cdot> x = star x"
 proof -
   have "1 \<squnion> (star x) \<cdot> x = x ^ 0 \<squnion> Sup{y. \<exists>i. y = x ^ i} \<cdot> x"
     by (simp add: star_def_var1)
   also have "... = x ^ 0 \<squnion> Sup{y. \<exists>i. y = x ^ i \<cdot> x}"
     by (simp add: Sup_distr, metis)
   also have "... = x ^ 0 \<squnion> Sup{y. \<exists>i. y = x ^ (i + 1)}"
     using power_Suc2 by simp 
    also have "... = Sup{y. y = x ^ 0 \<or> (\<exists>i. y = x ^ (i + 1))}"
     using Sup_sup_pred by simp
   also have "... = Sup{y. \<exists>i. y = x ^ i}"
     by (metis Suc_eq_plus1 power.power.power_Suc power.power_eq_if)
   finally show ?thesis
     by (simp add: star_def_var1)
 qed
 
 lemma (in dioid_one_zero) power_inductl: "z + x \<cdot> y \<le> y \<Longrightarrow> (x ^ n) \<cdot> z \<le> y"
 proof (induct n)
   case 0 show ?case
     using "0.prems" by simp
   case Suc thus ?case
     by (simp, metis mult.assoc mult_isol order_trans)
 qed
 
 lemma (in dioid_one_zero) power_inductr: "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> (x ^ n) \<le> y"
 proof (induct n)
   case 0 show ?case
     using "0.prems" by auto
   case Suc
   {
     fix n
     assume "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> x ^ n \<le> y"
       and "z + y \<cdot> x \<le> y"
     hence "z \<cdot> x ^ n \<le> y"
       by simp
     also have "z \<cdot> x ^ Suc n = z \<cdot> x \<cdot> x ^ n"
       by (metis mult.assoc power_Suc)
     moreover have "... = (z \<cdot> x ^ n) \<cdot> x"
       by (metis mult.assoc power_commutes)
     moreover have "... \<le> y \<cdot> x"
       by (metis calculation(1) mult_isor)
     moreover have "... \<le> y"
       using \<open>z + y \<cdot> x \<le> y\<close> by simp
     ultimately have "z \<cdot> x ^ Suc n \<le> y" by simp
   }
   thus ?case
     by (metis Suc)
 qed
 
 lemma star_inductl': "z \<squnion> x \<cdot> y \<le> y \<Longrightarrow> (star x) \<cdot> z \<le> y" 
 proof -
   assume "z \<squnion> x \<cdot> y \<le> y"
   hence "\<forall>i. x ^ i \<cdot> z \<le> y"
     by (simp add: power_inductl)
   hence "Sup{w. \<exists>i. w = x ^ i \<cdot> z} \<le> y"
     by (intro Sup_least, fast)
   hence "Sup{w. \<exists>i. w = x ^ i} \<cdot> z \<le> y"
     using Sup_distr Sup_le_iff by auto
   thus "(star x) \<cdot> z \<le> y"
     by (simp add: star_def_var1)
 qed
 
 lemma star_inductr': "z \<squnion> y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> (star x) \<le> y" 
 proof -
   assume "z \<squnion> y \<cdot> x \<le> y"
   hence "\<forall>i. z \<cdot> x ^ i  \<le> y"
     by (simp add: power_inductr)
   hence "Sup{w. \<exists>i. w = z \<cdot> x ^ i} \<le> y"
     by (intro Sup_least, fast)
   hence "z \<cdot> Sup{w. \<exists>i. w = x ^ i} \<le> y"
     using Sup_distl Sup_le_iff by auto
   thus "z \<cdot> (star x) \<le> y"
     by (simp add: star_def_var1)
 qed
 
 sublocale ka: kleene_algebra "(\<squnion>)" "(\<cdot>)" "1" "\<bottom>" "(\<le>)" "(<)" star
   by standard (simp_all add: star_inductl' star_inductr')
 
 end
 
 text \<open>Distributive quantales are often assumed to satisfy infinite distributivity laws between
 joins and meets, but finite ones suffice for our purposes.\<close>
 
 class distributive_quantale = quantale + distrib_lattice 
 
 begin
 
 subclass bd_lattice_ordered_monoid
   by (standard, simp_all add: distrib_left)
 
 lemma "(1 \<sqinter> x \<cdot> \<top>) \<cdot> x = x"
 (* nitpick [expect=genuine]*)
 oops
 
 end 
 
 subsection \<open>Domain Quantales\<close>
 
 class domain_quantale = distributive_quantale +
   assumes rdv'': "(z \<sqinter> x \<cdot> \<top>) \<cdot> y = z \<cdot> y \<sqinter> x \<cdot> \<top>"  
 
 begin
 
 subclass domain_bdlo_monoid 
   by (standard, simp add: rdv'')
 
 end
 
 class range_quantale = distributive_quantale +
   assumes ldv'': "y \<cdot> (z \<sqinter> \<top> \<cdot> x) = y \<cdot> z \<sqinter> \<top> \<cdot> x"
 
 class boolean_quantale = quantale + complete_boolean_algebra
 
 begin
 
 subclass boolean_monoid
   by (standard, simp_all add: sup_distl)
 
 lemma "(1 \<sqinter> x \<cdot> \<top>) \<cdot> x = x"
 (*nitpick[expect=genuine]*)
 oops
 
 lemma "(1 \<sqinter> -(x \<cdot> \<top>)) \<cdot> x = \<bottom>"
 (*nitpick[expect=genuine]*)
 oops
 
 end
 
 subsection\<open>Boolean Domain Quantales\<close> 
 
 class domain_boolean_quantale = domain_quantale + boolean_quantale
 
 begin
 
 subclass domain_boolean_monoid
   by (standard, simp add: rdv'')
 
 lemma fbox_eq: "ad.fbox x q = Sup{d p |p. d p \<cdot> x \<le> x \<cdot> d q}"
   apply (rule Sup_eqI[symmetric])
   apply clarsimp
   using ad.fbox_demodalisation3 ad.fbox_simp apply auto[1]
   apply clarsimp
   by (metis ad.fbox_def ad.fbox_demodalisation3 ad.fbox_simp da_a eq_refl)
 
 lemma fdia_eq: "ad.fdia x p = Inf{d q |q. x \<cdot> d p \<le> d q \<cdot> x}"
   apply (rule Inf_eqI[symmetric])
   apply clarsimp
   using ds.fdemodalisation2 apply auto[1]
   apply clarsimp
   by (metis ad.fd_eq_fdia ad.fdia_def da_a double_compl ds.fdemodalisation2 inf_bot_iff_le inf_compl_bot)
 
 text \<open>The specification statement can be defined explicitly.\<close>
 
 definition R :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
   "R p q \<equiv> Sup{x. (d p) \<cdot> x \<le> x \<cdot> d q}"
 
 lemma "x \<le> R p q \<Longrightarrow> d p \<le> ad.fbox x (d q)"
 proof (simp add: R_def ad.kat_1_equiv ad.kat_2_equiv)
   assume "x \<le> Sup{x. d p \<cdot> x \<cdot> a q = \<bottom>}"
   hence "d p \<cdot> x \<cdot> a q \<le> d p \<cdot> Sup{x. d p \<cdot> x \<cdot> a q = \<bottom>} \<cdot> a q "
     using mult_double_iso by blast
   also have "... = Sup{d p \<cdot> x \<cdot> a q |x. d p \<cdot> x \<cdot> a q = \<bottom>}"
     apply (subst Sup_distl)
     apply (subst Sup_distr)
     apply clarsimp
     by metis
   also have "... = \<bottom>"
     by (auto simp: Sup_eqI)
   finally show ?thesis
     using ad.fbox_demodalisation3 ad.kat_3 ad.kat_4 le_bot by blast
 qed
 
 lemma "d p \<le> ad.fbox x (d q) \<Longrightarrow> x \<le> R p q"
   apply (simp add: R_def)
   apply (rule Sup_upper)
   apply simp
   using ad.fbox_demodalisation3 ad.fbox_simp apply auto[1]
 done
 
 end
 
 subsection\<open>Relational Model of Boolean Domain Quantales\<close>
 
-interpretation rel_dbq: domain_boolean_quantale Inter Union "(\<inter>)" "(\<subseteq>)" "(\<subset>)" "(\<union>)" "{}" UNIV minus uminus Id "(O)"
-  apply (standard, simp_all add: O_assoc)
-  by blast +
+interpretation rel_dbq: domain_boolean_quantale
+  \<open>(-)\<close> uminus \<open>(\<inter>)\<close> \<open>(\<subseteq>)\<close> \<open>(\<subset>)\<close> \<open>(\<union>)\<close> \<open>{}\<close> UNIV \<open>\<Inter>\<close> \<open>\<Union>\<close> Id \<open>(O)\<close>
+  by standard auto
+
 
 subsection\<open>Modal Boolean Quantales\<close>
 
 class range_boolean_quantale = range_quantale + boolean_quantale
 
 begin
 
 subclass range_boolean_monoid
   by (standard, simp add: ldv'')
 
 lemma fbox_eq: "ar.bbox x (r q) = Sup{r p |p. x \<cdot> r p \<le> (r q) \<cdot> x}"
   apply (rule Sup_eqI[symmetric])
   apply clarsimp
   using ar.ardual.fbox_demodalisation3 ar.ardual.fbox_simp apply auto[1]
   apply clarsimp
   by (metis ar.ardual.fbox_def ar.ardual.fbox_demodalisation3 eq_refl rar_ar)
 
 lemma fdia_eq: "ar.bdia x (r p) = Inf{r q |q. (r p) \<cdot> x \<le> x \<cdot> r q}"
   apply (rule Inf_eqI[symmetric])
   apply clarsimp
   using ar.ars_r_def ar.ardual.fdemodalisation22 ar.ardual.kat_3_equiv_opp ar.ardual.kat_4_equiv_opp apply auto[1]
   apply clarsimp
   using ar.bdia_def ar.ardual.ds.fdemodalisation2 r_ar by fastforce
 
 end
 
 class modal_boolean_quantale = domain_boolean_quantale + range_boolean_quantale +
   assumes domrange' [simp]: "d (r x) = r x"
   and rangedom' [simp]: "r (d x) = d x"
 
 begin
 
 sublocale mka: modal_kleene_algebra "(\<squnion>)" "(\<cdot>)" 1 \<bottom> "(\<le>)" "(<)" star a ar
   by standard (simp_all add: ar_eq ad_eq)
 
 end
 
 no_notation fbox ("( |_] _)" [61,81] 82)
   and antidomain_semiringl_class.fbox ("( |_] _)" [61,81] 82)
 
 notation ad.fbox ("( |_] _)" [61,81] 82)
 
 subsection \<open>Recursion Rule\<close>
 
 lemma recursion: "mono (f :: 'a \<Rightarrow> 'a :: domain_boolean_quantale) \<Longrightarrow> 
   (\<And>x. d p \<le> |x] d q \<Longrightarrow> d p \<le> |f x] d q) \<Longrightarrow>  d p \<le> |lfp f] d q"
   apply (erule lfp_ordinal_induct [where f=f], simp)
   by (auto simp: ad.addual.ardual.fbox_demodalisation3 Sup_distr Sup_distl intro: Sup_mono)
 
 text \<open>We have already tested this rule in the context of test quantales~\cite{ArmstrongGS15}, which is based
 on a formalisation of quantales that is currently not in the AFP. The two theories will be merged as
 soon as the quantale is available in the AFP.\<close>
 
 end
diff --git a/thys/MonoBoolTranAlgebra/Statements.thy b/thys/MonoBoolTranAlgebra/Statements.thy
--- a/thys/MonoBoolTranAlgebra/Statements.thy
+++ b/thys/MonoBoolTranAlgebra/Statements.thy
@@ -1,445 +1,437 @@
 section \<open>Program statements, Hoare and refinement rules\<close>
 
 theory Statements
 imports Assertion_Algebra
 begin
 
 text \<open>In this section we introduce assume, if, and while program statements
 as well as Hoare triples, and data refienment. We prove Hoare correctness
 rules for the program statements and we prove some theorems linking Hoare
 correctness statement to (data) refinement. Most of the theorems assume
 a monotonic boolean transformers algebra. The theorem stating the 
 equivalence between a Hoare
 correctness triple and a refinement statement holds under the
 assumption that we have a monotonic boolean transformers algebra with
 post condition statement.\<close>
 
 definition
   "assume" :: "'a::mbt_algebra Assertion \<Rightarrow> 'a"  ("[\<cdot> _ ]" [0] 1000) where
   "[\<cdot>p] =  {\<cdot>p} ^ o"
 
 lemma [simp]: "{\<cdot>p} * \<top> \<sqinter> [\<cdot>p] = {\<cdot>p}"
   apply (subgoal_tac "{\<cdot>p} \<in> assertion")
   apply (subst (asm) assertion_def, simp add: assume_def)
   by simp
 
 lemma [simp]: "[\<cdot>p] * x \<squnion> {\<cdot>-p} * \<top> = [\<cdot>p] * x"
   by (simp add: assume_def  uminus_Assertion_def)
 
 lemma [simp]: "{\<cdot>p} * \<top> \<squnion> [\<cdot>-p] * x = [\<cdot>-p] * x"
   by (simp add: assume_def  uminus_Assertion_def)
 
 lemma assert_sup: "{\<cdot>p \<squnion> q} = {\<cdot>p} \<squnion> {\<cdot>q}"
   by (simp add: sup_Assertion_def)
 
 lemma assert_inf: "{\<cdot>p \<sqinter> q} = {\<cdot>p} \<sqinter> {\<cdot>q}"
   by (simp add: inf_Assertion_def)
 
 lemma assert_neg: "{\<cdot>-p} = neg_assert {\<cdot>p}"
   by (simp add: uminus_Assertion_def)
 
 lemma assert_false [simp]: "{\<cdot>\<bottom>} = \<bottom>"
   by (simp add: bot_Assertion_def)
 
 lemma if_Assertion_assumption: "({\<cdot>p} * x) \<squnion> ({\<cdot>-p} * y) = ([\<cdot>p] * x) \<sqinter> ([\<cdot>-p] * y)"
 proof -
     have "({\<cdot>p} * x) \<squnion> {\<cdot>-p} * y = ({\<cdot>p} * \<top> \<sqinter> [\<cdot>p]) * x \<squnion> ({\<cdot>-p} * \<top> \<sqinter> [\<cdot>-p]) * y" by simp
     also have "\<dots> = ({\<cdot>p} * \<top> \<sqinter> ([\<cdot>p] * x)) \<squnion> ({\<cdot>-p} * \<top> \<sqinter> ([\<cdot>-p] * y))" by (unfold inf_comp, simp)
     also have "\<dots> = (({\<cdot>p} * \<top> \<sqinter> ([\<cdot>p] * x)) \<squnion> ({\<cdot>-p} * \<top>)) \<sqinter> (({\<cdot>p} * \<top> \<sqinter> ([\<cdot>p] * x)) \<squnion> ([\<cdot>-p] * y))" by (simp add: sup_inf_distrib)
     also have "\<dots> = (({\<cdot>p} * \<top>  \<squnion> ({\<cdot>-p} * \<top>)) \<sqinter> (([\<cdot>p] * x))) \<sqinter> (([\<cdot>-p] * y) \<sqinter> (([\<cdot>p] * x) \<squnion> ([\<cdot>-p] * y)))"
       by (simp add: sup_inf_distrib2)
     also have "\<dots> = ([\<cdot>p] * x) \<sqinter>  ([\<cdot>-p] * y) \<sqinter> (([\<cdot>p] * x) \<squnion> ([\<cdot>-p] * y))"
       apply (simp add: sup_comp [THEN sym] )
       by (simp add: assert_sup [THEN sym] inf_assoc)
     also have "\<dots> = ([\<cdot>p] * x) \<sqinter>  ([\<cdot>-p] * y)"
       by (rule antisym, simp_all add: inf_assoc)
     finally show ?thesis .
   qed
 
 definition
   "wp x p = abs_wpt (x * {\<cdot>p})"
 
 lemma wp_assume: "wp [\<cdot>p] q = -p \<squnion> q"
   apply (simp add: wp_def abs_wpt_def)
   apply (rule assert_injective)
   apply simp
   by (simp add: assert_sup assert_neg assume_def wpt_dual_assertion_comp)
 
 lemma assert_commute: "y \<in> conjunctive \<Longrightarrow> y * {\<cdot>p} = {\<cdot> wp y p } * y"
   apply (simp add: wp_def abs_wpt_def)
   by (rule assertion_commute, simp_all)
 
 lemma wp_assert: "wp {\<cdot>p} q = p \<sqinter> q"
   by (simp add: wp_def assertion_inf_comp_eq [THEN sym] assert_inf [THEN sym])
 
 lemma wp_mono [simp]: "mono (wp x)"
   apply (simp add: le_fun_def wp_def abs_wpt_def less_eq_Assertion_def mono_def)
   apply (simp add: wpt_def, safe)
   apply (rule_tac y = " x * {\<cdot> xa } * \<top>" in order_trans, simp_all)
   apply (rule le_comp_right)
   by (rule le_comp, simp)
 
 lemma wp_mono2: "p \<le> q \<Longrightarrow> wp x p \<le> wp x q"
   apply (cut_tac x = x in wp_mono)
   apply (unfold mono_def)
   by blast
 
 lemma wp_fun_mono [simp]: "mono wp"
   apply (simp add: le_fun_def wp_def abs_wpt_def less_eq_Assertion_def mono_def)
   apply (simp add: wpt_def, safe)
   apply (rule_tac y = " x * {\<cdot> xa } * \<top>" in order_trans, simp_all)
   apply (rule le_comp_right)
   by (rule le_comp_right, simp) 
 
 
 lemma wp_fun_mono2: "x \<le> y \<Longrightarrow> wp x p \<le> wp y p"
   apply (cut_tac wp_fun_mono)
   apply (unfold mono_def)
   apply (simp add: le_fun_def)
   by blast
 
 
 lemma wp_comp: "wp (x * y) p = wp x (wp y p)"
   apply (simp add: wp_def abs_wpt_def)
   by (unfold wpt_comp_2 [THEN sym] mult.assoc, simp)
 
 lemma wp_choice: "wp (x \<sqinter> y) = wp x \<sqinter> wp y"
   apply (simp add: fun_eq_iff wp_def inf_fun_def inf_comp inf_Assertion_def abs_wpt_def)
   by (simp add: wpt_choice)
 
 lemma [simp]: "wp 1 = id"
   apply (unfold fun_eq_iff, safe)
   apply (rule assert_injective)
   by (simp add: wp_def abs_wpt_def)
 
 lemma wp_omega_fix: "wp (x ^ \<omega>) p = wp x (wp (x ^ \<omega>) p) \<sqinter> p"
   apply (subst omega_fix)
   by (simp add: wp_choice wp_comp)
 
 lemma wp_omega_least: "(wp x r) \<sqinter> p \<le> r \<Longrightarrow> wp (x ^ \<omega>) p \<le> r"
   apply (simp add: wp_def abs_wpt_def inf_Assertion_def less_eq_Assertion_def)
   apply (simp add: wpt_def)
   apply (rule_tac y = "{\<cdot>r} * \<top> \<sqinter> 1" in order_trans)
   apply simp
   apply (rule_tac y = "x ^ \<omega> * {\<cdot> p } * \<top>" in order_trans, simp)
   apply (simp add: mult.assoc)
   apply (rule omega_least)
   apply (drule_tac z = \<top> in le_comp_right)
   apply (simp add: inf_comp mult.assoc [THEN sym])
   by (simp add: assertion_prop)
 
 lemma Assertion_wp: "{\<cdot>wp x p} = (x * {\<cdot>p} * \<top>) \<sqinter> 1"
   apply (simp add: wp_def abs_wpt_def)
   by (simp add: wpt_def)
 
 definition
   "hoare p S q = (p \<le> wp S q)"
 
 definition
   "grd x = - (wp x \<bottom>)"
 
 lemma grd_comp: "[\<cdot>grd x] * x = x"
   apply (simp add: grd_def wp_def uminus_Assertion_def assume_def neg_assert_def abs_wpt_def dual_sup sup_comp)
   apply (simp add: wpt_def dual_inf sup_comp dual_comp bot_Assertion_def)
   by (rule antisym, simp_all)
 
 lemma assert_assume: "{\<cdot>p} * [\<cdot>p] = {\<cdot> p}"
   by (simp add: assume_def)
 
 lemma dual_assume: "[\<cdot>p] ^ o = {\<cdot>p}"
   by (simp add: assume_def)
 
 lemma assume_prop: "([\<cdot>p] * \<bottom>) \<squnion> 1 = [\<cdot>p]"
   by (simp add: assume_def dual_assertion_prop)
 
 text\<open>An alternative definition of a Hoare triple\<close>
 
 definition "hoare1 p S q = ([\<cdot> p ] * S * [\<cdot> -q ] = \<top>)"
 
 lemma "hoare1  p S q = hoare p S q"
   apply (simp add: hoare1_def dual_inf dual_comp)
   apply (simp add: hoare_def wp_def less_eq_Assertion_def abs_wpt_def)
   apply (simp add: wpt_def)
   apply safe
   proof -
     assume A: "[\<cdot> p ] * S * [\<cdot> - q ] = \<top>"
     have "{\<cdot>p} \<le> {\<cdot>p} * \<top>" by simp
     also have "... \<le> {\<cdot>p} * \<top> * \<bottom>" by (unfold mult.assoc, simp)
     also have "... = {\<cdot>p} * [\<cdot> p ] * S * [\<cdot> - q ] * \<bottom>" by (subst A [THEN sym], simp add: mult.assoc)
     also have "... = {\<cdot>p} * S * [\<cdot> - q ] * \<bottom>" by (simp add: assert_assume)
     also have "... \<le> {\<cdot>p} * S * {\<cdot> q } * \<top>"
       apply (simp add: mult.assoc)
       apply (rule le_comp, rule le_comp)
       apply (simp add: assume_def uminus_Assertion_def)
       by (simp add: neg_assert_def dual_inf dual_comp sup_comp)
     also have "... \<le> S * {\<cdot> q } * \<top>" by (simp add: mult.assoc)
     finally show "{\<cdot>p} \<le> S * {\<cdot> q } * \<top>" .
   next
     assume A: "{\<cdot> p } \<le> S * {\<cdot> q } * \<top>"
     have "\<top> = ((S * {\<cdot>q}) ^ o) * \<bottom> \<squnion> S * {\<cdot>q} * \<top>" by simp
     also have "\<dots> \<le> [\<cdot>p] * \<bottom> \<squnion> S * {\<cdot>q} * \<top>"
       apply (simp del: dual_neg_top)
       apply (rule_tac y = "[\<cdot>p] * \<bottom>" in order_trans, simp_all)
       apply (subst dual_le)
       apply (simp add: dual_comp dual_assume)
       apply (cut_tac x = "{\<cdot>p}" and y = "S * {\<cdot>q} * \<top>" and z = \<top> in le_comp_right)
       apply (rule A)
       by (simp add: mult.assoc)
     also have "\<dots> = [\<cdot>p] * S * ({\<cdot>q} * \<top>)"
       apply (subst (2) assume_prop [THEN sym])
       by (simp_all add: sup_comp mult.assoc)
     also have "\<dots> \<le> [\<cdot>p] * S * ({\<cdot>q} * \<top> \<squnion> 1)"
       by (rule le_comp, simp)
     also have "\<dots> = [\<cdot>p] * S * [\<cdot>-q]"
       apply (simp add: assume_def uminus_Assertion_def)
       by (simp add: neg_assert_def dual_inf dual_comp)
     finally show "[\<cdot>p] * S * [\<cdot> - q] = \<top>"
       by (rule_tac antisym, simp_all)
   qed
 
 lemma hoare_choice: "hoare p (x \<sqinter> y) q = ((hoare p) x q & (hoare p y q))"
   apply (unfold hoare_def wp_choice inf_fun_def)
   by auto
 
 definition
   if_stm:: "'a::mbt_algebra Assertion \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("(If (_)/ then (_)/ else (_))" [0, 0, 10] 10) where
   "if_stm b x y = (([\<cdot> b ] * x) \<sqinter> ([\<cdot> -b ] * y))"
 
 lemma if_assertion: "(If p then x else y) = {\<cdot>p} * x \<squnion> {\<cdot> -p} * y"
   by (simp add: if_stm_def if_Assertion_assumption)
 
-lemma (in Lattices.boolean_algebra) sup_neg_inf:
-  "(p \<le> q \<squnion> r) = (p \<sqinter> -q \<le> r)"
-  apply (safe)
-  apply(cut_tac a = p and c = "q \<squnion> r" and b = "-q" and d = "-q" in inf_mono)
-  apply simp apply simp apply (simp add: inf_sup_distrib2)
-  apply(cut_tac b = "p \<sqinter> - q" and d = "r" and a = "q" and c = "q" in sup_mono)
-  apply simp apply simp  by (simp add: sup_inf_distrib)
-
 lemma hoare_if: "hoare p (If b then x else y) q = (hoare (p \<sqinter> b) x q \<and> hoare (p \<sqinter> -b) y q)"
   by (simp add: hoare_def if_stm_def wp_choice inf_fun_def wp_comp wp_assume sup_neg_inf)
 
 lemma hoare_comp: "hoare p (x * y) q = (\<exists> r . (hoare p x r) \<and> (hoare r y q))"
    apply (simp add: hoare_def wp_comp)
    apply safe
    apply (rule_tac x = "wp y q" in exI, simp)
    apply (rule_tac y = "wp x r" in order_trans, simp)
    apply (rule_tac f = "wp x" in monoD)
    by simp_all
 
 lemma hoare_refinement: "hoare p S q = ({\<cdot>p} * (post {\<cdot>q}) \<le> S)"
   apply (simp add: hoare_def less_eq_Assertion_def Assertion_wp)
   proof
     assume A: "{\<cdot>p} \<le> S * {\<cdot>q} * \<top>"
     have "{\<cdot>p} * post {\<cdot>q} = ({\<cdot>p} * \<top> \<sqinter> 1) * post {\<cdot>q}" by (simp add: assertion_prop)
     also have "\<dots> = {\<cdot>p} * \<top> \<sqinter> post {\<cdot>q}" by (simp add: inf_comp)
     also have "\<dots> \<le> S * {\<cdot>q} * \<top> \<sqinter> post {\<cdot>q}" apply simp
       apply (rule_tac y = "{\<cdot>p} * \<top>" in order_trans, simp_all)
       apply (cut_tac x = "{\<cdot>p}" and y = "S * {\<cdot>q} * \<top>" and z = \<top> in le_comp_right)
       by (rule A, simp)
     also have "\<dots> \<le> S" by (simp add: post_2)
     finally show "{\<cdot>p} * post {\<cdot>q} \<le> S".
   next
     assume A: "{\<cdot>p} * post {\<cdot>q} \<le> S"
     have "{\<cdot>p} = {\<cdot>p} * \<top> \<sqinter> 1" by (simp add: assertion_prop)
     also have "\<dots> = {\<cdot>p} * ((post {\<cdot>q}) * {\<cdot>q} * \<top>) \<sqinter> 1" by (simp add: post_1)
     also have "\<dots> \<le> {\<cdot>p} * ((post {\<cdot>q}) * {\<cdot>q} * \<top>)" by simp
     also have "\<dots> \<le> S * {\<cdot>q} * \<top>" 
       apply (cut_tac x = "{\<cdot>p} * post {\<cdot>q}" and y = S and z = "{\<cdot>q} * \<top>" in le_comp_right)
       apply (simp add: A)
       by (simp add: mult.assoc)
     finally show "{\<cdot>p} \<le> S * {\<cdot>q} * \<top>" .
   qed
 
  theorem hoare_fixpoint_mbt:
   "F x = x
      \<Longrightarrow> (!! (w::'a::well_founded) f . (\<And>v. v < w \<Longrightarrow> hoare (p v) f q) \<Longrightarrow> hoare (p w) (F f) q) 
      \<Longrightarrow> hoare (p u) x q"
   apply (rule less_induct1)
   proof -
     fix xa
     assume A: "\<And> w f. (\<And> v . v < w \<Longrightarrow> hoare (p v) f q) \<Longrightarrow> hoare (p w) (F f) q"
     assume B: "F x  = x"
     assume C: "\<And>y . y < xa \<Longrightarrow> hoare (p y) x q"
     have D: "hoare (p xa) (F x) q"
       apply (rule A)
       by (rule C, simp)
     show "hoare (p xa) x q"
       by (cut_tac D, simp add: B)
     qed
 
 lemma hoare_Sup: "hoare (Sup P) x q = (\<forall> p \<in> P . hoare p x q)" 
   apply (simp add: hoare_def)
   apply auto
   apply (rule_tac y = "Sup P" in order_trans, simp_all add: Sup_upper)
   apply (rule Sup_least)
   by simp
 
 theorem hoare_fixpoint_complete_mbt:
   "F x = x
      \<Longrightarrow> (!! w f . hoare (Sup_less p w) f q \<Longrightarrow> hoare (p w) (F f) q) 
      \<Longrightarrow> hoare (Sup (range p)) x q"
   apply (simp add: hoare_Sup Sup_less_def, safe)
   apply (rule_tac F = F in hoare_fixpoint_mbt)
   by auto
 
 definition
   while:: "'a::mbt_algebra Assertion \<Rightarrow> 'a \<Rightarrow> 'a" ("(While (_)/ do (_))" [0, 10] 10) where
   "while p x = ([\<cdot> p] * x) ^ \<omega> * [\<cdot> -p ]"
 
 lemma while_false: "(While \<bottom> do x) = 1"
   apply (unfold while_def)
   apply (subst omega_fix)
   by (simp_all add: assume_def)
 
 lemma while_true: "(While \<top> do 1) = \<bottom>"
   apply (unfold while_def)
   by (rule antisym, simp_all add: assume_def)
 
 lemma hoare_wp [simp]: "hoare (wp x q) x q"
   by (simp add: hoare_def)
 
 lemma hoare_comp_wp: "hoare p (x * y) q = hoare p x (wp y q)"
   apply (unfold hoare_comp, safe)
   apply (simp add: hoare_def)
   apply (rule_tac y = "wp x r" in order_trans, simp)
   apply (rule wp_mono2, simp)
   by (rule_tac x = "wp y q" in exI, simp)
 
 lemma (in mbt_algebra) hoare_assume: "hoare p [\<cdot>b] q = (p \<sqinter> b \<le> q)"
   by (simp add: hoare_def wp_assume sup_neg_inf)
 
 lemma (in mbt_algebra) hoare_assume_comp: "hoare p ([\<cdot>b] * x) q = hoare (p \<sqinter> b) x q"
   apply (simp add: hoare_comp_wp hoare_assume)
   by (simp add: hoare_def)
 
 lemma hoare_while_mbt:
   "(\<forall> (w::'b::well_founded) r . (\<forall> v . v < w \<longrightarrow> p v \<le> r) \<longrightarrow> hoare ((p w) \<sqinter> b) x r) \<Longrightarrow> 
        (\<forall> u . p u \<le> q) \<Longrightarrow> hoare  (p w) (While b do x) (q \<sqinter> -b)"
   apply (unfold while_def)
   apply (rule_tac F = "\<lambda>z. [\<cdot> b ] * x * z \<sqinter> [\<cdot> - b ]" in hoare_fixpoint_mbt)
   apply (simp add: mult.assoc [THEN sym])
   apply (simp add: omega_comp_fix)
   apply (unfold hoare_choice)
   apply safe
   apply (subst hoare_comp_wp)
   apply (subst hoare_assume_comp)
   apply (drule_tac x = w in spec)
   apply (drule_tac x = "wp f (q \<sqinter> - b)" in spec)
   apply (auto simp add: hoare_def) [1]
   apply (auto simp add: hoare_assume)
   apply (rule_tac y = "p w" in order_trans)
   by simp_all
 
 lemma hoare_while_complete_mbt:
   "(\<forall> w::'b::well_founded . hoare ((p w) \<sqinter> b) x (Sup_less p w)) \<Longrightarrow> 
        hoare  (Sup (range p)) (While b do x) ((Sup (range p)) \<sqinter> -b)"
   apply (simp add: hoare_Sup, safe)
   apply (rule hoare_while_mbt)
   apply safe
   apply (drule_tac x = w in spec)
   apply (simp add: hoare_def)
   apply (rule_tac y = "wp x (Sup_less p w)" in order_trans, simp_all)
   apply (rule wp_mono2)
   apply (simp add: Sup_less_def)
   apply (rule Sup_least, auto)
   by (rule SUP_upper, simp)
 
 definition 
   "datarefin S S1 D D1 = (D * S \<le> S1 * D1)"
 
 lemma "hoare p S q \<Longrightarrow> datarefin S S1 D D1 \<Longrightarrow> hoare (wp D p) S1 (wp D1 q)"
   apply (simp add: hoare_def datarefin_def)
   apply (simp add: wp_comp [THEN sym] mult.assoc [THEN sym])
   apply (rule_tac y = "wp (D * S) q" in order_trans)
   apply (subst wp_comp)
   apply (rule monoD, simp_all)
   by (rule wp_fun_mono2, simp_all)
 
 lemma "hoare p S q \<Longrightarrow> datarefin ({\<cdot>p} * S) S1 D D1 \<Longrightarrow> hoare (wp D p) S1 (wp D1 q)"
   apply (simp add: hoare_def datarefin_def)
   apply (rule_tac y = "wp (D * {\<cdot>p} * S) q" in order_trans)
   apply (simp add: mult.assoc)
   apply (subst wp_comp)
   apply (rule monoD, simp_all)
   apply (subst wp_comp)
   apply (unfold wp_assert, simp)
   apply (unfold wp_comp [THEN sym])
   apply (rule wp_fun_mono2)
   by (simp add: mult.assoc)
 
 lemma inf_pres_conj: "x \<in> conjunctive \<Longrightarrow> y \<in> conjunctive \<Longrightarrow> x \<sqinter> y \<in> conjunctive"
   apply (subst conjunctive_def, safe)
   apply (simp add: inf_comp conjunctiveD)
   by (metis (opaque_lifting, no_types) inf_assoc inf_left_commute)
 
 lemma sup_pres_disj: "x \<in> disjunctive \<Longrightarrow> y \<in> disjunctive \<Longrightarrow> x \<squnion> y \<in> disjunctive"
   apply (subst disjunctive_def, safe)
   apply (simp add: sup_comp disjunctiveD)
   by (metis (opaque_lifting, no_types) sup_assoc sup_left_commute)
 
 lemma assumption_conjuncive [simp]: "[\<cdot>p] \<in> conjunctive"
   by (simp add: assume_def dual_disjunctive assertion_disjunctive)
 
 lemma assumption_disjuncive [simp]: "[\<cdot>p] \<in> disjunctive"
   by (simp add: assume_def dual_conjunctive assertion_conjunctive)
 
 lemma if_pres_conj: "x \<in> conjunctive \<Longrightarrow> y \<in> conjunctive \<Longrightarrow> (If p then x else y) \<in> conjunctive"
   apply (unfold if_stm_def)
   by (simp add: inf_pres_conj comp_pres_conj)
 
 lemma if_pres_disj: "x \<in> disjunctive \<Longrightarrow> y \<in> disjunctive \<Longrightarrow> (If p then x else y) \<in> disjunctive"
   apply (unfold if_assertion)
   by (simp add: sup_pres_disj comp_pres_disj assertion_disjunctive)
 
 lemma while_dual_star: "(While p do (x::'a::mbt_algebra)) = (({\<cdot> p} * x)^\<otimes> * {\<cdot> -p })"
   apply (simp add: while_def)
   apply (rule antisym)
   apply (rule omega_least)
    proof -
      have "([\<cdot> p] * x * (({\<cdot> p} * x)^\<otimes> * {\<cdot>-p}) \<sqinter> [\<cdot>-p]) = ({\<cdot> p} * x * (({\<cdot> p} * x)^\<otimes> * {\<cdot>-p})) \<squnion> {\<cdot>-p}"
         apply (unfold mult.assoc)
         by (cut_tac p = p and x = "(x * (({\<cdot> p } * x)^\<otimes> * {\<cdot> -p }))" and y = 1 in if_Assertion_assumption, simp)
      also have "\<dots> = ({\<cdot> p} * x)^\<otimes> * {\<cdot>-p}"
         by (simp add: mult.assoc [THEN sym], simp add: dual_star_comp_fix [THEN sym])
      finally show "[\<cdot> p ] * x * (({\<cdot> p } * x)^\<otimes> * {\<cdot> - p }) \<sqinter> [\<cdot> - p ] \<le> ({\<cdot> p } * x)^\<otimes> * {\<cdot> - p }" by simp
    next
      show "({\<cdot> p } * x)^\<otimes> * {\<cdot> - p } \<le> ([\<cdot> p ] * x) ^ \<omega> * [\<cdot> - p ]"
        apply (rule dual_star_least)
        proof -
         have "{\<cdot> p } * x * (([\<cdot> p ] * x) ^ \<omega> * [\<cdot> - p ]) \<squnion> {\<cdot> - p } = [\<cdot> p ] * x * (([\<cdot> p ] * x) ^ \<omega> * [\<cdot> - p ]) \<sqinter> [\<cdot> - p ]"
         apply (unfold mult.assoc)
         by (cut_tac p = p and x = "(x * (([\<cdot>p] * x)^\<omega> * [\<cdot>-p]))" and y = 1 in if_Assertion_assumption, simp)
         also have "... = ([\<cdot> p ] * x) ^ \<omega> * [\<cdot> - p ]"
           apply (simp add: mult.assoc [THEN sym])
           by (metis omega_comp_fix)
         finally show "{\<cdot> p } * x * (([\<cdot> p ] * x) ^ \<omega> * [\<cdot> - p ]) \<squnion> {\<cdot> - p } \<le> ([\<cdot> p ] * x) ^ \<omega> * [\<cdot> - p ] " by simp
      qed
    qed
 
 lemma while_pres_disj: "(x::'a::mbt_algebra) \<in> disjunctive \<Longrightarrow> (While p do x) \<in> disjunctive"
   apply (unfold while_dual_star)
   apply (rule comp_pres_disj)
   apply (rule dual_star_pres_disj)
   by (rule comp_pres_disj, simp_all add: assertion_disjunctive)
 
 lemma while_pres_conj: "(x::'a::mbt_algebra_fusion) \<in> conjunctive \<Longrightarrow> (While p do x) \<in> conjunctive"
   apply(unfold while_def)
   by (simp add: comp_pres_conj omega_pres_conj)
 
 no_notation
   bot  ("\<bottom>") and
   top  ("\<top>") and
   inf  (infixl "\<sqinter>" 70) and
   sup  (infixl "\<squnion>" 65) and
   Inf  ("\<Sqinter>_" [900] 900) and
   Sup  ("\<Squnion>_" [900] 900)
 
 no_syntax
   "_INF1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Sqinter>_./ _)" [0, 10] 10)
   "_INF"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Sqinter>_\<in>_./ _)" [0, 0, 10] 10)
   "_SUP1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Squnion>_./ _)" [0, 10] 10)
   "_SUP"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Squnion>_\<in>_./ _)" [0, 0, 10] 10)
 
 end
 
diff --git a/thys/Order_Lattice_Props/Order_Duality.thy b/thys/Order_Lattice_Props/Order_Duality.thy
--- a/thys/Order_Lattice_Props/Order_Duality.thy
+++ b/thys/Order_Lattice_Props/Order_Duality.thy
@@ -1,315 +1,315 @@
 (* 
   Title: Ad-Hoc Duality for Orderings and Lattices
   Author: Georg Struth 
   Maintainer: Georg Struth <g.struth@sheffield.ac.uk> 
 *)
 
 section \<open>Ad-Hoc Duality for Orderings and Lattices\<close>
 
 theory Order_Duality
   imports Sup_Lattice
 
 begin
 
 text \<open>This component presents an "explicit" formalisation of order and lattice duality. It augments the data type based one
  used by Wenzel in his lattice components \cite{Wenzel}, and complements the "implicit" formalisation given by locales. It uses a functor dual, 
 supplied within a type class, which is simply a bijection (isomorphism) between types, with the constraint that
 the dual of a dual object is the original object. In Wenzel's formalisation, by contrast, dual is a bijection, but not
  idempotent or involutive. In the past, Preoteasa has used a similar approach with Isabelle~\cite{Preoteasa11b}.\<close>
 
 text \<open>Duality is such a fundamental concept in order and lattice theory that it probably deserves to be included in the type classes
 for these objects, as in this section.\<close>
 
 class dual =
   fixes dual :: "'a \<Rightarrow> 'a" ("\<partial>")
   assumes inj_dual: "inj \<partial>"
   and invol_dual [simp]: "\<partial> \<circ> \<partial> = id"
 
 text \<open>This type class allows one to define a type dual. It is actually a dependent type
 for which dual can be instantiated.\<close>
 
 typedef (overloaded) 'a dual = "range (dual::'a::dual \<Rightarrow> 'a)"
   by fastforce
 
 setup_lifting type_definition_dual
 
 text \<open>At the moment I have no use for this type.\<close>
 
 context dual
 begin
 
 lemma invol_dual_var [simp]: "\<partial> (\<partial> x) = x"
   by (simp add: pointfree_idE)
 
 lemma surj_dual: "surj \<partial>"
   unfolding surj_def by (metis invol_dual_var)
 
 lemma bij_dual: "bij \<partial>"
   by (simp add: bij_def inj_dual surj_dual)
 
 lemma inj_dual_iff: "(\<partial> x = \<partial> y) = (x = y)"
   by (meson inj_dual injD)
 
 lemma dual_iff: "(\<partial> x = y) = (x = \<partial> y)"
   by auto
 
 lemma the_inv_dual: "the_inv \<partial> = \<partial>"
   by (metis comp_apply id_def invol_dual_var inj_dual surj_dual surj_fun_eq the_inv_f_o_f_id)
 
 end
 
 text \<open>In boolean algebras, duality is of course De Morgan duality and can be expressed within the language.\<close>
 
-sublocale Lattices.boolean_algebra \<subseteq> ba_dual: dual "uminus"  
+sublocale boolean_algebra \<subseteq> ba_dual: dual "uminus"  
   by (unfold_locales, simp_all add: inj_def)
 
 definition map_dual:: "('a \<Rightarrow> 'b) \<Rightarrow> 'a::dual \<Rightarrow> 'b::dual" ("\<partial>\<^sub>F") where 
   "\<partial>\<^sub>F f = \<partial> \<circ> f \<circ> \<partial>"  
 
 lemma map_dual_func1: "\<partial>\<^sub>F (f \<circ> g) = \<partial>\<^sub>F f \<circ> \<partial>\<^sub>F g"
   by (metis (no_types, lifting) comp_assoc comp_id invol_dual map_dual_def)
 
 lemma map_dual_func2 [simp]: "\<partial>\<^sub>F id = id"
   by (simp add: map_dual_def)
 
 lemma map_dual_nat_iso: "\<partial>\<^sub>F f \<circ> \<partial> = \<partial> \<circ> id f"
   by (simp add: comp_assoc map_dual_def)
 
 lemma map_dual_invol [simp]: "\<partial>\<^sub>F \<circ> \<partial>\<^sub>F = id"
   unfolding map_dual_def comp_def fun_eq_iff by simp
   
 text \<open>Thus map-dual is naturally isomorphic to the identify functor: The function dual is a natural transformation 
 between  map-dual and the identity functor, and, because it has a two-sided inverse --- itself, it is a natural isomorphism.\<close>
 
 text \<open>The generic function set-dual provides another natural transformation (see below). Before introducing it, we introduce useful notation 
 for a widely used function.\<close>
 
 abbreviation "\<eta> \<equiv> (\<lambda>x. {x})"
 
 lemma eta_inj: "inj \<eta>"
   by simp
 
 definition "set_dual = \<eta> \<circ> \<partial>"
 
 lemma set_dual_prop: "set_dual (\<partial> x) = {x}"
   by (metis comp_apply dual_iff set_dual_def)
 
 text \<open>The next four lemmas show that (functional) image and preimage are functors (on functions). This does not really belong here, 
 but it is useful for what follows. The interaction between duality and (pre)images is needed in applications.\<close>
 
 lemma image_func1: "(`) (f \<circ> g) = (`) f \<circ> (`) g"
   unfolding fun_eq_iff by (simp add: image_comp) 
 
 lemma image_func2: "(`) id = id"
   by simp
 
 lemma vimage_func1: "(-`) (f \<circ> g) = (-`) g \<circ> (-`) f"
   unfolding fun_eq_iff by (simp add: vimage_comp)
 
 lemma vimage_func2: "(-`) id = id"
   by simp
 
 lemma iso_image: "mono ((`) f)"
   by (simp add: image_mono monoI)
 
 lemma iso_preimage: "mono ((-`) f)"
   by (simp add: monoI vimage_mono)
 
 context dual
 begin
 
 lemma image_dual [simp]: "(`) \<partial> \<circ> (`) \<partial> = id"
   by (metis image_func1 image_func2 invol_dual)
 
 lemma vimage_dual [simp]: "(-`) \<partial> \<circ> (-`) \<partial> = id"
   by (simp add: set.comp)
 
 end
 
 text \<open>The following natural transformation between the powerset functor (image) and the identity functor
 is well known.\<close>
 
 lemma power_set_func_nat_trans: "\<eta> \<circ> id f = (`) f \<circ> \<eta>"
   unfolding fun_eq_iff comp_def by simp
 
 text \<open>As an instance, set-dual is a natural transformation with built-in type coercion.\<close>
 
 lemma dual_singleton: "(`) \<partial> \<circ> \<eta> = \<eta> \<circ> \<partial>"  
   by auto
 
 lemma finite_dual [simp]: "finite \<circ> (`) \<partial> = finite"
   unfolding fun_eq_iff comp_def using inj_dual finite_vimageI inj_vimage_image_eq by fastforce
 
 lemma finite_dual_var [simp]: "finite (\<partial> ` X) = finite X"
   by (metis comp_def finite_dual)
 
 lemma subset_dual: "(X = \<partial> ` Y) = (\<partial> ` X = Y)"
   by (metis image_dual pointfree_idE)
 
 lemma subset_dual1: "(X \<subseteq> Y) = (\<partial> ` X \<subseteq> \<partial> ` Y)"
   by (simp add: inj_dual inj_image_subset_iff) 
 
 lemma dual_empty [simp]: "\<partial> ` {} = {}"
   by simp
 
 lemma dual_UNIV [simp]: "\<partial> ` UNIV = UNIV"
   by (simp add: surj_dual)
 
 lemma fun_dual1: "(f = g \<circ> \<partial>) = (f \<circ> \<partial> = g)"
   by (metis comp_assoc comp_id invol_dual)
 
 lemma fun_dual2: "(f = \<partial> \<circ> g) = (\<partial> \<circ> f = g)"
   by (metis comp_assoc fun.map_id invol_dual)
 
 lemma fun_dual3: "(f = g \<circ> (`) \<partial>) = (f \<circ> (`) \<partial> = g)"
   by (metis comp_id image_dual o_assoc)
 
 lemma fun_dual4: "(f = (`) \<partial> \<circ> g) = ((`) \<partial> \<circ> f = g)"
   by (metis comp_assoc id_comp image_dual)
 
 lemma fun_dual5: "(f = \<partial> \<circ> g \<circ> \<partial>) = (\<partial> \<circ> f \<circ> \<partial> = g)"
   by (metis comp_assoc fun_dual1 fun_dual2)
 
 lemma fun_dual6: "(f = (`) \<partial> \<circ> g \<circ> (`) \<partial>) = ((`) \<partial> \<circ> f \<circ> (`) \<partial> = g)"
   by (simp add: comp_assoc fun_dual3 fun_dual4)
 
 lemma fun_dual7: "(f = \<partial> \<circ> g \<circ> (`) \<partial>) = (\<partial> \<circ> f \<circ> (`) \<partial> = g)"
   by (simp add: comp_assoc fun_dual2 fun_dual3)
 
 lemma fun_dual8: "(f = (`) \<partial> \<circ> g \<circ> \<partial>) = ((`) \<partial> \<circ> f \<circ> \<partial> = g)"
   by (simp add: comp_assoc fun_dual1 fun_dual4)
 
 lemma map_dual_dual: "(\<partial>\<^sub>F f = g) = (\<partial>\<^sub>F g = f)"
   by (metis map_dual_invol pointfree_idE)
 
 text \<open>The next facts show incrementally that the dual of a complete lattice is a complete lattice.\<close>
 
 class ord_with_dual = dual + ord +
   assumes ord_dual: "x \<le> y \<Longrightarrow> \<partial> y \<le> \<partial> x"
 
 begin
 
 lemma dual_dual_ord: "(\<partial> x \<le> \<partial> y) = (y \<le> x)"
   by (metis dual_iff ord_dual)
 
 end
 
 lemma ord_pres_dual:
   fixes f :: "'a::ord_with_dual \<Rightarrow> 'b::ord_with_dual"   
   shows "ord_pres f \<Longrightarrow> ord_pres (\<partial>\<^sub>F f)"
   by (simp add: dual_dual_ord map_dual_def ord_pres_def)
 
 lemma map_dual_anti: "(f::'a::ord_with_dual \<Rightarrow> 'b::ord_with_dual) \<le> g  \<Longrightarrow> \<partial>\<^sub>F g \<le> \<partial>\<^sub>F f"
   by (simp add: le_fun_def map_dual_def ord_dual)
   
 class preorder_with_dual = ord_with_dual + preorder
 
 begin
 
 lemma less_dual_def_var: "(\<partial> y < \<partial> x) = (x < y)"
   by (simp add: dual_dual_ord less_le_not_le)
 
 end
 
 class order_with_dual = preorder_with_dual + order
 
 lemma iso_map_dual: 
   fixes f :: "'a::order_with_dual \<Rightarrow> 'b::order_with_dual"   
   shows "mono f \<Longrightarrow> mono (\<partial>\<^sub>F f)"
   by (simp add: ord_pres_dual ord_pres_mono)
 
 class lattice_with_dual = lattice + dual +
   assumes sup_dual_def: "\<partial> (x \<squnion> y) = \<partial> x \<sqinter> \<partial> y"
 
 begin
 
 subclass order_with_dual
   by (unfold_locales, metis inf.absorb_iff2 sup_absorb1 sup_commute sup_dual_def)
 
 lemma inf_dual: "\<partial> (x \<sqinter> y) = \<partial> x \<squnion> \<partial> y"
   by (metis invol_dual_var sup_dual_def) 
 
 lemma inf_to_sup: "x \<sqinter> y = \<partial> (\<partial> x \<squnion> \<partial> y)"
   using inf_dual dual_iff by fastforce
 
 lemma sup_to_inf: "x \<squnion> y = \<partial> (\<partial> x \<sqinter> \<partial> y)"
   by (simp add: inf_dual)
 
 end
 
 class bounded_lattice_with_dual = lattice_with_dual + bounded_lattice
 
 begin
 
 lemma bot_dual: "\<partial> \<bottom> = \<top>"
   by (metis dual_dual_ord dual_iff le_bot top_greatest)
 
 lemma top_dual: "\<partial> \<top> = \<bottom>"
   using bot_dual dual_iff by force
 
 end
 
 class boolean_algebra_with_dual = lattice_with_dual + boolean_algebra
 
-sublocale Lattices.boolean_algebra \<subseteq> badual: boolean_algebra_with_dual _ _ _ _ _ _ _ _ uminus
+sublocale boolean_algebra \<subseteq> badual: boolean_algebra_with_dual _ _ _ _ _ _ _ _ uminus
   by unfold_locales simp_all
 
 class Sup_lattice_with_dual = Sup_lattice + dual +
   assumes Sups_dual_def: "\<partial> \<circ> Sup = Infs \<circ> (`) \<partial>"
 
 class Inf_lattice_with_dual = Inf_lattice + dual +
   assumes Sups_dual_def: "\<partial> \<circ> Supi = Inf \<circ> (`) \<partial>"
 
 class complete_lattice_with_dual = complete_lattice + dual +
   assumes Sups_dual_def: "\<partial> \<circ> Sup = Inf \<circ> (`) \<partial>"
 
 sublocale Sup_lattice_with_dual \<subseteq> sclatd: complete_lattice_with_dual Infs Sup infs "(\<le>)" le sups bots tops "\<partial>"
   by (unfold_locales, simp add: Sups_dual_def)
 
 sublocale Inf_lattice_with_dual \<subseteq> iclatd: complete_lattice_with_dual Inf Supi infi "(\<le>)" le supi boti topi "\<partial>"
   by (unfold_locales, simp add: Sups_dual_def)
 
 context complete_lattice_with_dual
 begin
 
 lemma Inf_dual: "\<partial> \<circ> Inf = Sup \<circ> (`) \<partial>"
   by (metis comp_assoc comp_id fun.map_id Sups_dual_def image_dual invol_dual)
 
 lemma Inf_dual_var: "\<partial> (\<Sqinter>X) = \<Squnion>(\<partial> ` X)"
   using comp_eq_dest Inf_dual by fastforce
 
 lemma Inf_to_Sup: "Inf = \<partial> \<circ> Sup \<circ> (`) \<partial>"
   by (auto simp add: Sups_dual_def image_comp)
 
 lemma Inf_to_Sup_var: "\<Sqinter>X = \<partial> (\<Squnion>(\<partial> ` X))"
   using Inf_dual_var dual_iff by fastforce
 
 lemma Sup_to_Inf: "Sup = \<partial> \<circ> Inf \<circ> (`) \<partial>"
   by (auto simp add: Inf_dual image_comp)
 
 lemma Sup_to_Inf_var: "\<Squnion>X = \<partial> (\<Sqinter>(\<partial> ` X))"
   using Sup_to_Inf by force
 
 lemma Sup_dual_def_var: "\<partial> (\<Squnion>X) = \<Sqinter> (\<partial> ` X)"
   using comp_eq_dest Sups_dual_def by fastforce
 
 lemma bot_dual_def: "\<partial> \<top> = \<bottom>"
   by (smt Inf_UNIV Sup_UNIV Sups_dual_def surj_dual o_eq_dest)
 
 lemma top_dual_def: "\<partial> \<bottom> = \<top>"
   using bot_dual_def dual_iff by blast
 
 lemma inf_dual2: "\<partial> (x \<sqinter> y) = \<partial> x \<squnion> \<partial> y"
   by (smt comp_eq_elim Inf_dual Inf_empty Inf_insert SUP_insert inf_top.right_neutral)
 
 lemma sup_dual: "\<partial> (x \<squnion> y) = \<partial> x \<sqinter> \<partial> y"
   by (metis inf_dual2 dual_iff)
 
 subclass lattice_with_dual
   by (unfold_locales, auto simp: inf_dual sup_dual)
 
 subclass bounded_lattice_with_dual..
 
 end
 
 end
diff --git a/thys/Order_Lattice_Props/Order_Lattice_Props.thy b/thys/Order_Lattice_Props/Order_Lattice_Props.thy
--- a/thys/Order_Lattice_Props/Order_Lattice_Props.thy
+++ b/thys/Order_Lattice_Props/Order_Lattice_Props.thy
@@ -1,1269 +1,1227 @@
 (* 
   Title: Properties of Orderings and Lattices
   Author: Georg Struth 
   Maintainer: Georg Struth <g.struth@sheffield.ac.uk> 
 *)
 
 section \<open>Properties of Orderings and Lattices\<close>
 
 theory Order_Lattice_Props
   imports Order_Duality
 
 begin
 
 subsection \<open>Basic Definitions for Orderings and Lattices\<close>
 
 text \<open>The first definition is for order morphisms --- isotone (order-preserving, monotone) functions. 
 An order isomorphism is an order-preserving bijection. This should be defined in the class ord, but mono requires order.\<close>
 
 definition ord_homset :: "('a::order \<Rightarrow> 'b::order) set" where
  "ord_homset = {f::'a::order \<Rightarrow> 'b::order. mono f}"
 
 definition ord_embed :: "('a::order \<Rightarrow> 'b::order) \<Rightarrow> bool" where
  "ord_embed f = (\<forall>x y. f x \<le> f y \<longleftrightarrow> x \<le> y)"
 
 definition ord_iso :: "('a::order \<Rightarrow> 'b::order) \<Rightarrow> bool" where
   "ord_iso = bij \<sqinter> mono \<sqinter> (mono \<circ> the_inv)"
 
 lemma ord_embed_alt: "ord_embed f = (mono f \<and> (\<forall>x y. f x \<le> f y \<longrightarrow> x \<le> y))"
   using mono_def ord_embed_def by auto
 
 lemma ord_embed_homset: "ord_embed f \<Longrightarrow> f \<in> ord_homset"
   by (simp add: mono_def ord_embed_def ord_homset_def)
 
 lemma ord_embed_inj: "ord_embed f \<Longrightarrow> inj f"
   unfolding ord_embed_def inj_def by (simp add: eq_iff)
 
 lemma ord_iso_ord_embed: "ord_iso f \<Longrightarrow> ord_embed f"
   unfolding ord_iso_def ord_embed_def bij_def inj_def mono_def
   by (clarsimp, metis inj_def the_inv_f_f)
 
 lemma ord_iso_alt: "ord_iso f = (ord_embed f \<and> surj f)"
   unfolding ord_iso_def ord_embed_def surj_def bij_def inj_def mono_def 
   apply safe
   by simp_all (metis eq_iff inj_def the_inv_f_f)+
 
 lemma ord_iso_the_inv: "ord_iso f \<Longrightarrow> mono (the_inv f)"
   by (simp add: ord_iso_def)
 
 lemma ord_iso_inv1: "ord_iso f \<Longrightarrow> (the_inv f) \<circ> f = id"
   using ord_embed_inj ord_iso_ord_embed the_inv_into_f_f by fastforce
 
 lemma ord_iso_inv2: "ord_iso f \<Longrightarrow> f \<circ> (the_inv f) = id"
   using f_the_inv_into_f ord_embed_inj ord_iso_alt by fastforce
 
 typedef (overloaded) ('a,'b) ord_homset = "ord_homset::('a::order \<Rightarrow> 'b::order) set" 
   by (force simp: ord_homset_def mono_def) 
 
 setup_lifting type_definition_ord_homset 
 
 text \<open>The next definition is for the set of fixpoints of a given function. It is important in the context of orders,
 for instance for proving Tarski's fixpoint theorem, but does not really belong here.\<close>
 
 definition Fix :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a set" where 
   "Fix f = {x. f x = x}"
 
 lemma retraction_prop: "f \<circ> f = f \<Longrightarrow> f x = x \<longleftrightarrow> x \<in> range f"
   by (metis comp_apply f_inv_into_f rangeI)
 
 lemma retraction_prop_fix: "f \<circ> f = f \<Longrightarrow> range f = Fix f"
   unfolding Fix_def using retraction_prop by fastforce
 
 lemma Fix_map_dual: "Fix \<circ> \<partial>\<^sub>F = (`) \<partial> \<circ> Fix"
   unfolding Fix_def map_dual_def comp_def fun_eq_iff
   by (smt Collect_cong invol_dual pointfree_idE setcompr_eq_image)
 
 lemma Fix_map_dual_var: "Fix (\<partial>\<^sub>F f) = \<partial> ` (Fix f)"
   by (metis Fix_map_dual o_def)
 
 lemma gfp_dual: "(\<partial>::'a::complete_lattice_with_dual \<Rightarrow> 'a) \<circ> gfp = lfp \<circ> \<partial>\<^sub>F"
 proof-
   {fix f:: "'a \<Rightarrow> 'a"
   have "\<partial> (gfp f) = \<partial> (\<Squnion>{u. u \<le> f u})"
     by (simp add: gfp_def)
   also have "... = \<Sqinter>(\<partial> ` {u. u \<le> f u})"
     by (simp add: Sup_dual_def_var)
   also have "... = \<Sqinter>{\<partial> u |u. u \<le> f u}"
     by (simp add: setcompr_eq_image)
   also have "... = \<Sqinter>{u |u. (\<partial>\<^sub>F f) u \<le> u}"
     by (metis (no_types, opaque_lifting) dual_dual_ord dual_iff map_dual_def o_def)
   finally have "\<partial> (gfp f) = lfp (\<partial>\<^sub>F f)"
     by (metis lfp_def)}
   thus ?thesis
     by auto
 qed
 
 lemma gfp_dual_var: 
   fixes f :: "'a::complete_lattice_with_dual \<Rightarrow> 'a"
   shows "\<partial> (gfp f) = lfp (\<partial>\<^sub>F f)"
   using comp_eq_elim gfp_dual by blast
 
 lemma gfp_to_lfp: "gfp = (\<partial>::'a::complete_lattice_with_dual \<Rightarrow> 'a) \<circ> lfp \<circ> \<partial>\<^sub>F"
   by (simp add: comp_assoc fun_dual2 gfp_dual)
 
 lemma gfp_to_lfp_var: 
   fixes f :: "'a::complete_lattice_with_dual \<Rightarrow> 'a"
   shows "gfp f = \<partial> (lfp (\<partial>\<^sub>F f))"
   by (metis gfp_dual_var invol_dual_var)
 
 lemma lfp_dual: "(\<partial>::'a::complete_lattice_with_dual \<Rightarrow> 'a) \<circ> lfp = gfp \<circ> \<partial>\<^sub>F"
   by (simp add: comp_assoc gfp_to_lfp map_dual_invol)
 
 lemma lfp_dual_var: 
   fixes f :: "'a::complete_lattice_with_dual \<Rightarrow> 'a"
   shows "\<partial> (lfp f) = gfp (map_dual f)"
   using comp_eq_dest_lhs lfp_dual by fastforce
 
 lemma lfp_to_gfp: "lfp = (\<partial>::'a::complete_lattice_with_dual \<Rightarrow> 'a) \<circ> gfp \<circ> \<partial>\<^sub>F"
   by (simp add: comp_assoc gfp_dual map_dual_invol)
 
 lemma lfp_to_gfp_var: 
   fixes f :: "'a::complete_lattice_with_dual \<Rightarrow> 'a"
   shows "lfp f = \<partial> (gfp (\<partial>\<^sub>F f))"
   by (metis invol_dual_var lfp_dual_var)
 
 lemma lfp_in_Fix: 
   fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
   shows "mono f \<Longrightarrow> lfp f \<in> Fix f"
   by (metis (mono_tags, lifting) Fix_def lfp_unfold mem_Collect_eq)
 
 lemma gfp_in_Fix: 
   fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
   shows "mono f \<Longrightarrow> gfp f \<in> Fix f"
   by (metis (mono_tags, lifting) Fix_def gfp_unfold mem_Collect_eq)
 
 lemma nonempty_Fix: 
   fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
   shows "mono f \<Longrightarrow> Fix f \<noteq> {}"
   using lfp_in_Fix by fastforce
 
 
 text \<open>Next the minimal and maximal elements of an ordering are defined.\<close>
 
 context ord
 begin
 
 definition min_set :: "'a set \<Rightarrow> 'a set" where 
   "min_set X = {y \<in> X. \<forall>x \<in> X. x \<le> y \<longrightarrow> x = y}"
 
 definition max_set :: "'a set \<Rightarrow> 'a set" where 
   "max_set X = {x \<in> X. \<forall>y \<in> X. x \<le> y \<longrightarrow> x = y}"
 
 end
 
 context ord_with_dual
 begin
 
 lemma min_max_set_dual: "(`) \<partial> \<circ> min_set = max_set \<circ> (`) \<partial>"  
   unfolding max_set_def min_set_def fun_eq_iff comp_def 
   apply safe
   using dual_dual_ord inj_dual_iff by auto
 
 lemma min_max_set_dual_var: "\<partial> ` (min_set X) = max_set (\<partial> ` X)"
   using comp_eq_dest min_max_set_dual by fastforce  
 
 lemma max_min_set_dual: "(`) \<partial> \<circ> max_set = min_set \<circ> (`) \<partial>"
   by (metis (no_types, opaque_lifting) comp_id fun.map_comp id_comp image_dual min_max_set_dual)  
 
 lemma min_to_max_set: "min_set = (`) \<partial> \<circ> max_set \<circ> (`) \<partial>"
   by (metis comp_id image_dual max_min_set_dual o_assoc)
 
 lemma max_min_set_dual_var: "\<partial> ` (max_set X) = min_set (\<partial> ` X)"
   using comp_eq_dest max_min_set_dual by fastforce
 
 lemma min_to_max_set_var: "min_set X = \<partial> ` (max_set (\<partial> ` X))"
   by (simp add: max_min_set_dual_var pointfree_idE)
 
 end
 
 text \<open>Next, directed and filtered sets, upsets, downsets, filters and ideals in posets are defined.\<close>
 
 context ord
 begin
 
 definition directed :: "'a set \<Rightarrow> bool" where
  "directed X = (\<forall>Y. finite Y \<and> Y \<subseteq> X \<longrightarrow> (\<exists>x \<in> X. \<forall>y \<in> Y. y \<le> x))"
 
 definition filtered :: "'a set \<Rightarrow> bool" where
  "filtered X = (\<forall>Y. finite Y \<and> Y \<subseteq> X \<longrightarrow> (\<exists>x \<in> X. \<forall>y \<in> Y. x \<le> y))"
 
 definition downset_set :: "'a set \<Rightarrow> 'a set" ("\<Down>") where
   "\<Down>X = {y. \<exists>x \<in> X. y \<le> x}"
 
 definition upset_set :: "'a set \<Rightarrow> 'a set" ("\<Up>") where
  "\<Up>X = {y. \<exists>x \<in> X. x \<le> y}"
 
 definition downset :: "'a \<Rightarrow> 'a set" ("\<down>") where 
   "\<down> = \<Down> \<circ> \<eta>"
 
 definition upset :: "'a \<Rightarrow> 'a set" ("\<up>") where 
   "\<up> = \<Up> \<circ> \<eta>"
 
 definition downsets :: "'a set set" where  
   "downsets = Fix \<Down>"
  
 definition upsets :: "'a set set" where
   "upsets = Fix \<Up>"
 
 definition "downclosed_set X = (X \<in> downsets)"
 
 definition "upclosed_set X = (X \<in> upsets)"
 
 definition ideals :: "'a set set" where
   "ideals = {X. X \<noteq> {} \<and> downclosed_set X \<and> directed X}"
 
 definition filters :: "'a set set" where
   "filters = {X. X \<noteq> {} \<and> upclosed_set X \<and> filtered X}"
 
 abbreviation "idealp X \<equiv> X \<in> ideals"
 
 abbreviation "filterp X \<equiv> X \<in> filters"
 
 end
 
 text \<open>These notions are pair-wise dual.\<close>
 
 text \<open>Filtered and directed sets are dual.\<close>
 
 context ord_with_dual
 begin
 
 lemma filtered_directed_dual: "filtered \<circ> (`) \<partial> = directed"
   unfolding filtered_def directed_def fun_eq_iff comp_def
   apply clarsimp
   apply safe
    apply (meson finite_imageI imageI image_mono dual_dual_ord)
   by (smt finite_subset_image imageE ord_dual)
 
 lemma directed_filtered_dual: "directed \<circ> (`) \<partial> = filtered"
   using filtered_directed_dual by (metis comp_id image_dual o_assoc) 
 
 lemma filtered_to_directed: "filtered X = directed (\<partial> ` X)"
   by (metis comp_apply directed_filtered_dual)
 
 text \<open>Upsets and downsets are dual.\<close>
 
 lemma downset_set_upset_set_dual: "(`) \<partial> \<circ> \<Down> = \<Up> \<circ> (`) \<partial>"
   unfolding downset_set_def upset_set_def fun_eq_iff comp_def
   apply safe
    apply (meson image_eqI ord_dual)
   by (clarsimp, metis (mono_tags, lifting) dual_iff image_iff mem_Collect_eq ord_dual)
 
 lemma upset_set_downset_set_dual: "(`) \<partial> \<circ> \<Up> = \<Down> \<circ> (`) \<partial>"
   using downset_set_upset_set_dual by (metis (no_types, opaque_lifting) comp_id id_comp image_dual o_assoc)
 
 lemma upset_set_to_downset_set: "\<Up> = (`) \<partial> \<circ> \<Down> \<circ> (`) \<partial>"
   by (simp add: comp_assoc downset_set_upset_set_dual)
 
 lemma upset_set_to_downset_set2: "\<Up> X = \<partial> ` (\<Down> (\<partial> ` X))"
   by (simp add: upset_set_to_downset_set)
 
 lemma downset_upset_dual: "(`) \<partial> \<circ> \<down> = \<up> \<circ> \<partial>"
   using downset_def upset_def upset_set_to_downset_set by fastforce
 
 lemma upset_to_downset: "(`) \<partial> \<circ> \<up> = \<down> \<circ> \<partial>"
   by (metis comp_assoc id_apply ord.downset_def ord.upset_def power_set_func_nat_trans upset_set_downset_set_dual)
 
 lemma upset_to_downset2: "\<up> = (`) \<partial> \<circ> \<down> \<circ> \<partial>"
   by (simp add: comp_assoc downset_upset_dual)
 
 lemma upset_to_downset3: "\<up> x = \<partial> ` (\<down> (\<partial> x))"
   by (simp add: upset_to_downset2)
 
 lemma downsets_upsets_dual: "(X \<in> downsets) = (\<partial> ` X \<in> upsets)"
   unfolding downsets_def upsets_def Fix_def
   by (smt comp_eq_dest downset_set_upset_set_dual image_inv_f_f inj_dual mem_Collect_eq)
 
 lemma downset_setp_upset_setp_dual: "upclosed_set \<circ> (`) \<partial> = downclosed_set"
   unfolding downclosed_set_def upclosed_set_def using downsets_upsets_dual by fastforce
 
 lemma upsets_to_downsets: "(X \<in> upsets) = (\<partial> ` X \<in> downsets)"
   by (simp add: downsets_upsets_dual image_comp)
 
 lemma upset_setp_downset_setp_dual: "downclosed_set \<circ> (`) \<partial> = upclosed_set"
   by (metis comp_id downset_setp_upset_setp_dual image_dual o_assoc)
 
 text \<open>Filters and ideals are dual.\<close>
 
 lemma ideals_filters_dual: "(X \<in> ideals) = ((\<partial> ` X) \<in> filters)"
   by (smt comp_eq_dest_lhs directed_filtered_dual image_inv_f_f image_is_empty inv_unique_comp filters_def ideals_def inj_dual invol_dual mem_Collect_eq upset_setp_downset_setp_dual)
 
 lemma idealp_filterp_dual: "idealp = filterp \<circ> (`) \<partial>"
   unfolding fun_eq_iff by (simp add: ideals_filters_dual)
 
 lemma filters_to_ideals: "(X \<in> filters) = ((\<partial> ` X) \<in> ideals)"
   by (simp add: ideals_filters_dual image_comp)
 
 lemma filterp_idealp_dual: "filterp = idealp \<circ> (`) \<partial>"
   unfolding fun_eq_iff by (simp add: filters_to_ideals)
 
 end
 
 subsection \<open>Properties of Orderings\<close>
 
 context ord
 begin
 
 lemma directed_nonempty: "directed X \<Longrightarrow> X \<noteq> {}"
   unfolding directed_def by fastforce
 
 lemma directed_ub: "directed X \<Longrightarrow> (\<forall>x \<in> X. \<forall>y \<in> X. \<exists>z \<in> X. x \<le> z \<and> y \<le> z)"
   by (meson empty_subsetI directed_def finite.emptyI finite_insert insert_subset order_refl)
 
 lemma downset_set_prop: "\<Down> = Union \<circ> (`) \<down>"
   unfolding downset_set_def downset_def fun_eq_iff by fastforce
 
 lemma downset_set_prop_var: "\<Down>X = (\<Union>x \<in> X. \<down>x)"
   by (simp add: downset_set_prop)
 
 lemma downset_prop: "\<down>x = {y. y \<le> x}"
   unfolding downset_def downset_set_def fun_eq_iff by fastforce
 
 lemma downset_prop2: "y \<le> x \<Longrightarrow> y \<in> \<down>x"
   by (simp add: downset_prop)
 
 lemma ideals_downsets: "X \<in> ideals \<Longrightarrow> X \<in> downsets"
   by (simp add: downclosed_set_def ideals_def)
 
 lemma ideals_directed: "X \<in> ideals \<Longrightarrow> directed X"
   by (simp add: ideals_def)
 
 end
 
 context preorder
 begin
 
 lemma directed_prop: "X \<noteq> {} \<Longrightarrow> (\<forall>x \<in> X. \<forall>y \<in> X. \<exists>z \<in> X. x \<le> z \<and> y \<le> z) \<Longrightarrow> directed X"
 proof-
   assume h1: "X \<noteq> {}"
   and h2: "\<forall>x \<in> X. \<forall>y \<in> X. \<exists>z \<in> X. x \<le> z \<and> y \<le> z"
   {fix Y
   have "finite Y \<Longrightarrow> Y \<subseteq> X \<Longrightarrow> (\<exists>x \<in> X. \<forall>y \<in> Y. y \<le> x)"
   proof (induct rule: finite_induct)
     case empty
     then show ?case
       using h1 by blast 
   next
     case (insert x F)
     then show ?case
       by (metis h2 insert_iff insert_subset order_trans) 
   qed}
   thus ?thesis
     by (simp add: directed_def)
 qed
 
 lemma directed_alt: "directed X = (X \<noteq> {} \<and> (\<forall>x \<in> X. \<forall>y \<in> X. \<exists>z \<in> X. x \<le> z \<and> y \<le> z))"
   by (metis directed_prop directed_nonempty directed_ub)
 
 lemma downset_set_prop_var2: "x \<in> \<Down>X \<Longrightarrow> y \<le> x \<Longrightarrow> y \<in> \<Down>X"
   unfolding downset_set_def using order_trans by blast
 
 lemma downclosed_set_iff: "downclosed_set X = (\<forall>x \<in> X. \<forall>y. y \<le> x \<longrightarrow> y \<in> X)"
   unfolding downclosed_set_def downsets_def Fix_def downset_set_def by auto
 
 lemma downclosed_downset_set: "downclosed_set (\<Down>X)"
   by (simp add: downclosed_set_iff downset_set_prop_var2 downset_def)
 
 lemma downclosed_downset: "downclosed_set (\<down>x)"
   by (simp add: downclosed_downset_set downset_def)
  
 lemma downset_set_ext: "id \<le> \<Down>"
   unfolding le_fun_def id_def downset_set_def by auto 
 
 lemma downset_set_iso: "mono \<Down>"
   unfolding mono_def downset_set_def by blast
 
 lemma downset_set_idem [simp]: "\<Down> \<circ> \<Down> = \<Down>"
   unfolding fun_eq_iff downset_set_def using order_trans by auto
 
 lemma downset_faithful: "\<down>x \<subseteq> \<down>y \<Longrightarrow> x \<le> y"
   by (simp add: downset_prop subset_eq)
 
 lemma downset_iso_iff: "(\<down>x \<subseteq> \<down>y) = (x \<le> y)"
   using atMost_iff downset_prop order_trans by blast
 
 text \<open>The following proof uses the Axiom of Choice.\<close>
 
 lemma downset_directed_downset_var [simp]: "directed (\<Down>X) = directed X"
 proof
   assume h1: "directed X"
   {fix Y
   assume h2: "finite Y" and h3: "Y \<subseteq> \<Down>X"
   hence "\<forall>y. \<exists>x. y \<in> Y \<longrightarrow> x \<in> X \<and>  y \<le> x"
     by (force simp: downset_set_def)
   hence "\<exists>f. \<forall>y. y \<in> Y \<longrightarrow>  f y \<in> X \<and> y \<le> f y"
     by (rule choice)
   hence "\<exists>f. finite (f ` Y) \<and> f ` Y \<subseteq> X \<and> (\<forall>y \<in> Y. y \<le> f y)"
     by (metis finite_imageI h2 image_subsetI)
   hence "\<exists>Z. finite Z \<and> Z \<subseteq> X \<and> (\<forall>y \<in> Y. \<exists> z \<in> Z. y \<le> z)"
     by fastforce
   hence "\<exists>Z. finite Z \<and> Z \<subseteq> X \<and> (\<forall>y \<in> Y. \<exists> z \<in> Z. y \<le> z) \<and> (\<exists>x \<in> X. \<forall> z \<in> Z. z \<le> x)"
     by (metis directed_def h1)
   hence "\<exists>x \<in> X. \<forall>y \<in> Y. y \<le> x"
     by (meson order_trans)}
   thus "directed (\<Down>X)"
     unfolding directed_def downset_set_def by fastforce
 next 
   assume "directed (\<Down>X)"
   thus "directed X"
     unfolding directed_def downset_set_def 
     apply clarsimp
     by (smt Ball_Collect order_refl order_trans subsetCE)
 qed
 
 lemma downset_directed_downset [simp]: "directed \<circ> \<Down> = directed"
   unfolding fun_eq_iff by simp
 
 lemma directed_downset_ideals: "directed (\<Down>X) = (\<Down>X \<in> ideals)"
   by (metis (mono_tags, lifting) CollectI Fix_def directed_alt downset_set_idem downclosed_set_def downsets_def ideals_def o_def ord.ideals_directed)
 
 lemma downclosed_Fix: "downclosed_set X = (\<Down>X = X)"
   by (metis (mono_tags, lifting) CollectD Fix_def downclosed_downset_set downclosed_set_def downsets_def)
   
 end
 
 lemma downset_iso: "mono (\<down>::'a::order \<Rightarrow> 'a set)"
   by (simp add: downset_iso_iff mono_def)
 
 lemma mono_downclosed: 
   fixes f :: "'a::order \<Rightarrow> 'b::order"
   assumes "mono f"
   shows "\<forall>Y. downclosed_set Y \<longrightarrow> downclosed_set (f -` Y)"   
   by (simp add: assms downclosed_set_iff monoD)
 
 lemma
   fixes f :: "'a::order \<Rightarrow> 'b::order"
   assumes "mono f"
   shows "\<forall>Y. downclosed_set X \<longrightarrow> downclosed_set (f ` X)" (*nitpick*)
   oops
 
 lemma downclosed_mono:
   fixes f :: "'a::order \<Rightarrow> 'b::order"
   assumes "\<forall>Y. downclosed_set Y \<longrightarrow> downclosed_set (f -` Y)"
   shows "mono f"
 proof-
   {fix x y :: "'a::order"
   assume h: "x \<le> y"
   have "downclosed_set (\<down> (f y))"
     unfolding downclosed_set_def downsets_def Fix_def downset_set_def downset_def by auto
   hence "downclosed_set (f -` (\<down> (f y)))"
     by (simp add: assms)
   hence "downclosed_set {z. f z \<le> f y}"
     unfolding vimage_def downset_def downset_set_def by auto
   hence "\<forall>z w. (f z \<le> f y \<and> w \<le> z) \<longrightarrow> f w \<le> f y"
     unfolding downclosed_set_def downclosed_set_def downsets_def Fix_def downset_set_def by force
   hence "f x \<le> f y"
     using h by blast}
   thus ?thesis..
 qed
 
 lemma mono_downclosed_iff: "mono f = (\<forall>Y. downclosed_set Y \<longrightarrow> downclosed_set (f -` Y))"
   using mono_downclosed downclosed_mono by auto
 
 context order
 begin
 
 lemma downset_inj: "inj \<down>"
   by (metis injI downset_iso_iff order.eq_iff)
 
 lemma "(X \<subseteq> Y) = (\<Down>X \<subseteq> \<Down>Y)" (*nitpick*)
   oops
 
 end
 
 context lattice
 begin
 
 lemma lat_ideals: "X \<in> ideals = (X \<noteq> {} \<and> X \<in> downsets \<and> (\<forall>x \<in> X. \<forall> y \<in> X. x \<squnion> y \<in> X))"
   unfolding ideals_def directed_alt downsets_def Fix_def downset_set_def downclosed_set_def
   by (clarsimp, smt sup.cobounded1 sup.orderE sup.orderI sup_absorb2 sup_left_commute mem_Collect_eq)
 
 end
 
 context bounded_lattice
 begin
 
 lemma bot_ideal: "X \<in> ideals \<Longrightarrow> \<bottom> \<in> X"
   unfolding ideals_def downclosed_set_def downsets_def Fix_def downset_set_def by fastforce
 
 end
 
 context complete_lattice
 begin
 
 lemma Sup_downset_id [simp]: "Sup \<circ> \<down> = id"
   using Sup_atMost atMost_def downset_prop by fastforce
 
 lemma downset_Sup_id: "id \<le> \<down> \<circ> Sup"
   by (simp add: Sup_upper downset_prop le_funI subsetI)
 
 lemma Inf_Sup_var: "\<Squnion>(\<Inter>x \<in> X. \<down>x) = \<Sqinter>X"
   unfolding downset_prop by (simp add: Collect_ball_eq Inf_eq_Sup)
 
 lemma Inf_pres_downset_var: "(\<Inter>x \<in> X. \<down>x) = \<down>(\<Sqinter>X)"
   unfolding downset_prop by (safe, simp_all add: le_Inf_iff)
 
 end
 
 
 subsection \<open>Dual Properties of Orderings\<close>
 
 context ord_with_dual
 begin
 
 lemma filtered_nonempty: "filtered X \<Longrightarrow> X \<noteq> {}"
   using filtered_to_directed ord.directed_nonempty by auto
 
 lemma filtered_lb: "filtered X \<Longrightarrow> (\<forall>x \<in> X. \<forall>y \<in> X. \<exists>z \<in> X. z \<le> x \<and> z \<le> y)"
   using filtered_to_directed directed_ub dual_dual_ord by fastforce
 
 lemma upset_set_prop_var: "\<Up>X = (\<Union>x \<in> X. \<up>x)"
   by (simp add: image_Union downset_set_prop_var upset_set_to_downset_set2 upset_to_downset2)
 
 lemma upset_set_prop: "\<Up> = Union \<circ> (`) \<up>"
   unfolding fun_eq_iff by (simp add: upset_set_prop_var)
 
 lemma upset_prop: "\<up>x = {y. x \<le> y}"
   unfolding upset_to_downset3 downset_prop image_def using dual_dual_ord by fastforce
 
 lemma upset_prop2: "x \<le> y \<Longrightarrow> y \<in> \<up>x"
   by (simp add: upset_prop)
 
 lemma filters_upsets: "X \<in> filters \<Longrightarrow> X \<in> upsets"
   by (simp add: upclosed_set_def filters_def)
 
 lemma filters_filtered: "X \<in> filters \<Longrightarrow> filtered X"
   by (simp add: filters_def)
 
 end
 
 context preorder_with_dual
 begin
 
 lemma filtered_prop: "X \<noteq> {} \<Longrightarrow> (\<forall>x \<in> X. \<forall>y \<in> X. \<exists>z \<in> X. z \<le> x \<and> z \<le> y) \<Longrightarrow> filtered X"
   unfolding filtered_to_directed 
     by (rule directed_prop, blast, metis (full_types) image_iff ord_dual)
  
 lemma filtered_alt: "filtered X = (X \<noteq> {} \<and> (\<forall>x \<in> X. \<forall>y \<in> X. \<exists>z \<in> X. z \<le> x \<and> z \<le> y))"
   by (metis image_empty directed_alt filtered_to_directed filtered_lb filtered_prop)
 
 lemma up_set_prop_var2: "x \<in> \<Up>X \<Longrightarrow> x \<le> y \<Longrightarrow> y \<in> \<Up>X"
   using downset_set_prop_var2 dual_iff ord_dual upset_set_to_downset_set2 by fastforce
 
 lemma upclosed_set_iff: "upclosed_set X = (\<forall>x \<in> X. \<forall>y. x \<le> y \<longrightarrow> y \<in> X)"
   unfolding upclosed_set_def upsets_def Fix_def upset_set_def by auto
 
 lemma upclosed_upset_set: "upclosed_set (\<Up>X)"
   using up_set_prop_var2 upclosed_set_iff by blast
 
 lemma upclosed_upset: "upclosed_set (\<up>x)"
   by (simp add: upset_def upclosed_upset_set) 
   
 lemma upset_set_ext: "id \<le> \<Up>"
   by (smt comp_def comp_id image_mono le_fun_def downset_set_ext image_dual upset_set_to_downset_set2)
 
 lemma upset_set_anti: "mono \<Up>"
   by (metis image_mono downset_set_iso upset_set_to_downset_set2 mono_def)
 
 lemma up_set_idem [simp]: "\<Up> \<circ> \<Up> = \<Up>"
   by (metis comp_assoc downset_set_idem upset_set_downset_set_dual upset_set_to_downset_set)
 
 lemma upset_faithful: "\<up>x \<subseteq> \<up>y \<Longrightarrow> y \<le> x"
   by (metis inj_image_subset_iff downset_faithful dual_dual_ord inj_dual upset_to_downset3)
 
 lemma upset_anti_iff: "(\<up>y \<subseteq> \<up>x) = (x \<le> y)"
   by (metis downset_iso_iff ord_dual upset_to_downset3 subset_image_iff upset_faithful)
 
 lemma upset_filtered_upset [simp]: "filtered \<circ> \<Up> = filtered"
   by (metis comp_assoc directed_filtered_dual downset_directed_downset upset_set_downset_set_dual)
 
 lemma filtered_upset_filters: "filtered (\<Up>X) = (\<Up>X \<in> filters)"
   by (metis comp_apply directed_downset_ideals filtered_to_directed filterp_idealp_dual upset_set_downset_set_dual)
 
 lemma upclosed_Fix: "upclosed_set X = (\<Up>X = X)"
   by (simp add: Fix_def upclosed_set_def upsets_def)
 
 end
 
 lemma upset_anti: "antimono (\<up>::'a::order_with_dual \<Rightarrow> 'a set)"
   by (simp add: antimono_def upset_anti_iff)
 
 lemma mono_upclosed: 
   fixes f :: "'a::order_with_dual \<Rightarrow> 'b::order_with_dual"
   assumes "mono f"
   shows "\<forall>Y. upclosed_set Y \<longrightarrow> upclosed_set (f -` Y)"
   by (simp add: assms monoD upclosed_set_iff)
 
 lemma mono_upclosed: 
   fixes f :: "'a::order_with_dual \<Rightarrow> 'b::order_with_dual"
   assumes "mono f"
   shows "\<forall>Y. upclosed_set X \<longrightarrow> upclosed_set (f ` X)" (*nitpick*)
   oops
 
 lemma upclosed_mono:
   fixes f :: "'a::order_with_dual \<Rightarrow> 'b::order_with_dual"
   assumes "\<forall>Y. upclosed_set Y \<longrightarrow> upclosed_set (f -` Y)"
   shows "mono f"
   by (metis (mono_tags, lifting) assms dual_order.refl mem_Collect_eq monoI order.trans upclosed_set_iff vimageE vimageI2)
 
 lemma mono_upclosed_iff: 
   fixes f :: "'a::order_with_dual \<Rightarrow> 'b::order_with_dual"
   shows "mono f = (\<forall>Y. upclosed_set Y \<longrightarrow> upclosed_set (f -` Y))"
   using mono_upclosed upclosed_mono by auto
 
 context order_with_dual
 begin
 
 lemma upset_inj: "inj \<up>"
   by (metis inj_compose inj_on_imageI2 downset_inj inj_dual upset_to_downset)
 
 lemma "(X \<subseteq> Y) = (\<Up>Y \<subseteq> \<Up>X)" (*nitpick*)
   oops
 
 end
 
 context lattice_with_dual
 begin
 
 lemma lat_filters: "X \<in> filters = (X \<noteq> {} \<and> X \<in> upsets \<and> (\<forall>x \<in> X. \<forall> y \<in> X. x \<sqinter> y \<in> X))"
   unfolding filters_to_ideals upsets_to_downsets inf_to_sup lat_ideals
   by (smt image_iff image_inv_f_f image_is_empty inj_image_mem_iff inv_unique_comp inj_dual invol_dual)
 
 end
 
 context bounded_lattice_with_dual
 begin
 
 lemma top_filter: "X \<in> filters \<Longrightarrow> \<top> \<in> X"
   using bot_ideal inj_image_mem_iff inj_dual filters_to_ideals top_dual by fastforce
 
 end
 
 context complete_lattice_with_dual
 begin
 
 lemma Inf_upset_id [simp]: "Inf \<circ> \<up> = id"
   by (metis comp_assoc comp_id Sup_downset_id Sups_dual_def downset_upset_dual invol_dual)
 
 lemma upset_Inf_id: "id \<le> \<up> \<circ> Inf"
   by (simp add: Inf_lower le_funI subsetI upset_prop)
 
 lemma Sup_Inf_var: " \<Sqinter>(\<Inter>x \<in> X. \<up>x) = \<Squnion>X"
   unfolding upset_prop by (simp add: Collect_ball_eq Sup_eq_Inf)
 
 lemma Sup_dual_upset_var: "(\<Inter>x \<in> X. \<up>x) = \<up>(\<Squnion>X)"
   unfolding upset_prop by (safe, simp_all add: Sup_le_iff)
 
 end
 
 
-subsection \<open>Shunting Laws\<close>
-
-text \<open>The first set of laws supplies so-called shunting laws for boolean algebras. 
-Such laws rather belong into Isabelle Main.\<close>
-
-context Lattices.boolean_algebra
-begin
-    
-lemma shunt1: "(x \<sqinter> y \<le> z) = (x \<le> -y \<squnion> z)"
-proof standard
-  assume "x \<sqinter> y \<le> z"
-  hence  "-y \<squnion> (x \<sqinter> y) \<le> -y \<squnion> z"
-    using sup.mono by blast
-  hence "-y \<squnion> x \<le> -y \<squnion> z"
-    by (simp add: sup_inf_distrib1)
-  thus "x \<le> -y \<squnion> z"
-    by simp
-next
-  assume "x \<le> -y \<squnion> z"
-  hence "x \<sqinter> y \<le> (-y \<squnion> z) \<sqinter> y"
-    using inf_mono by auto
-  thus  "x \<sqinter> y \<le> z"
-    using inf.boundedE inf_sup_distrib2 by auto
-qed
-
-lemma shunt2: "(x \<sqinter> -y \<le> z) = (x \<le> y \<squnion> z)"
-  by (simp add: shunt1)
-
-lemma meet_shunt: "(x \<sqinter> y = \<bottom>) = (x \<le> -y)"
-  by (simp add: order.eq_iff shunt1)
-  
-lemma join_shunt: "(x \<squnion> y = \<top>) = (-x \<le> y)"
-  by (metis compl_sup compl_top_eq double_compl meet_shunt)
-
-lemma meet_shunt_var: "(x - y = \<bottom>) = (x \<le> y)"
-  by (simp add: diff_eq meet_shunt)
-
-lemma join_shunt_var: "(x \<longrightarrow> y = \<top>) = (x \<le> y)"  
-  by simp
-
-end
-
 subsection \<open>Properties of Complete Lattices\<close>
 
 definition "Inf_closed_set X = (\<forall>Y \<subseteq> X. \<Sqinter>Y \<in> X)"
 
 definition "Sup_closed_set X = (\<forall>Y \<subseteq> X. \<Squnion>Y \<in> X)"
 
 definition "inf_closed_set X = (\<forall>x \<in> X. \<forall>y \<in> X. x \<sqinter> y \<in> X)" 
 
 definition "sup_closed_set X = (\<forall>x \<in> X. \<forall>y \<in> X. x \<squnion> y \<in> X)"
 
 text \<open>The following facts about complete lattices add to those in the Isabelle libraries.\<close>
 
 context complete_lattice 
 begin
 
 text \<open>The translation between sup and Sup could be improved. The sup-theorems should be direct
 consequences of Sup-ones. In addition, duality between sup and inf is currently not exploited.\<close>
 
 lemma sup_Sup: "x \<squnion> y = \<Squnion>{x,y}"
   by simp
 
 lemma inf_Inf: "x \<sqinter> y = \<Sqinter>{x,y}"
   by simp
 
 text \<open>The next two lemmas are about Sups and Infs of indexed families. These are interesting for
 iterations and fixpoints.\<close>
 
 lemma fSup_unfold: "(f::nat \<Rightarrow> 'a) 0 \<squnion> (\<Squnion>n. f (Suc n)) = (\<Squnion>n. f n)"
   apply (intro order.antisym sup_least)
     apply (rule Sup_upper, force)
    apply (rule Sup_mono, force)
   apply (safe intro!: Sup_least)
  by (case_tac n, simp_all add: Sup_upper le_supI2)
 
 lemma fInf_unfold: "(f::nat \<Rightarrow> 'a) 0 \<sqinter> (\<Sqinter>n. f (Suc n)) = (\<Sqinter>n. f n)"
   apply (intro order.antisym inf_greatest)
   apply (rule Inf_greatest, safe)
   apply (case_tac n)
    apply simp_all
   using Inf_lower inf.coboundedI2 apply force
    apply (simp add: Inf_lower)
   by (auto intro: Inf_mono)
 
 end
 
 lemma Sup_sup_closed: "Sup_closed_set (X::'a::complete_lattice set) \<Longrightarrow> sup_closed_set X"
   by (metis Sup_closed_set_def empty_subsetI insert_subsetI sup_Sup sup_closed_set_def)
 
 lemma Inf_inf_closed: "Inf_closed_set (X::'a::complete_lattice set) \<Longrightarrow> inf_closed_set X"
   by (metis Inf_closed_set_def empty_subsetI inf_Inf inf_closed_set_def insert_subset)
 
 
 subsection \<open>Sup- and Inf-Preservation\<close>
 
 text \<open>Next, important notation for morphism between posets and lattices is introduced: 
 sup-preservation, inf-preservation and related properties.\<close>
 
 abbreviation Sup_pres :: "('a::Sup \<Rightarrow> 'b::Sup) \<Rightarrow> bool" where
   "Sup_pres f \<equiv> f \<circ> Sup = Sup \<circ> (`) f"
 
 abbreviation Inf_pres :: "('a::Inf \<Rightarrow> 'b::Inf) \<Rightarrow> bool" where
   "Inf_pres f \<equiv> f \<circ> Inf = Inf \<circ> (`) f"
 
 abbreviation sup_pres :: "('a::sup \<Rightarrow> 'b::sup) \<Rightarrow> bool" where
   "sup_pres f \<equiv> (\<forall>x y. f (x \<squnion> y) = f x \<squnion> f y)"
 
 abbreviation inf_pres :: "('a::inf \<Rightarrow> 'b::inf) \<Rightarrow> bool" where
  "inf_pres f \<equiv> (\<forall>x y. f (x \<sqinter> y) = f x \<sqinter> f y)"
 
 abbreviation bot_pres :: "('a::bot \<Rightarrow> 'b::bot) \<Rightarrow> bool" where
   "bot_pres f \<equiv> f \<bottom> = \<bottom>"
 
 abbreviation top_pres :: "('a::top \<Rightarrow> 'b::top) \<Rightarrow> bool" where
   "top_pres f \<equiv> f \<top> = \<top>"
 
 abbreviation Sup_dual :: "('a::Sup \<Rightarrow> 'b::Inf) \<Rightarrow> bool" where
   "Sup_dual f \<equiv> f \<circ> Sup = Inf \<circ> (`) f"
 
 abbreviation Inf_dual :: "('a::Inf \<Rightarrow> 'b::Sup) \<Rightarrow> bool" where
   "Inf_dual f \<equiv> f \<circ> Inf = Sup \<circ> (`) f"
 
 abbreviation sup_dual :: "('a::sup \<Rightarrow> 'b::inf) \<Rightarrow> bool" where
   "sup_dual f \<equiv> (\<forall>x y. f (x \<squnion> y) = f x \<sqinter> f y)"
 
 abbreviation inf_dual :: "('a::inf \<Rightarrow> 'b::sup) \<Rightarrow> bool" where
  "inf_dual f \<equiv> (\<forall>x y. f (x \<sqinter> y) = f x \<squnion> f y)"
 
 abbreviation bot_dual :: "('a::bot \<Rightarrow> 'b::top) \<Rightarrow> bool" where 
  "bot_dual f \<equiv> f \<bottom> = \<top>"
 
 abbreviation top_dual :: "('a::top \<Rightarrow> 'b::bot) \<Rightarrow> bool" where 
   "top_dual f \<equiv> f \<top> = \<bottom>"
 
 text \<open>Inf-preservation and sup-preservation relate with duality.\<close>
 
 lemma Inf_pres_map_dual_var: 
   "Inf_pres f = Sup_pres (\<partial>\<^sub>F f)"
   for f :: "'a::complete_lattice_with_dual \<Rightarrow> 'b::complete_lattice_with_dual"
 proof -
   { fix x :: "'a set"
     assume "\<partial> (f (\<Sqinter> (\<partial> ` x))) = (\<Squnion>y\<in>x. \<partial> (f (\<partial> y)))" for x
     then have "\<Sqinter> (f ` \<partial> ` A) = f (\<partial> (\<Squnion> A))" for A
       by (metis (no_types) Sup_dual_def_var image_image invol_dual_var subset_dual)
     then have "\<Sqinter> (f ` x) = f (\<Sqinter> x)"
       by (metis Sup_dual_def_var subset_dual) }
   then show ?thesis
     by (auto simp add: map_dual_def fun_eq_iff Inf_dual_var Sup_dual_def_var image_comp)
 qed
 
 lemma Inf_pres_map_dual: "Inf_pres = Sup_pres \<circ> (\<partial>\<^sub>F::('a::complete_lattice_with_dual \<Rightarrow> 'b::complete_lattice_with_dual) \<Rightarrow> 'a \<Rightarrow> 'b)"
 proof-
   {fix f::"'a \<Rightarrow> 'b"
   have "Inf_pres f = (Sup_pres \<circ> \<partial>\<^sub>F) f"
     by (simp add: Inf_pres_map_dual_var)}
   thus ?thesis
     by force
 qed
 
 lemma Sup_pres_map_dual_var: 
   fixes f :: "'a::complete_lattice_with_dual \<Rightarrow> 'b::complete_lattice_with_dual"
   shows "Sup_pres f = Inf_pres (\<partial>\<^sub>F f)"
   by (metis Inf_pres_map_dual_var fun_dual5 map_dual_def)
 
 lemma Sup_pres_map_dual: "Sup_pres = Inf_pres \<circ> (\<partial>\<^sub>F::('a::complete_lattice_with_dual \<Rightarrow> 'b::complete_lattice_with_dual) \<Rightarrow> 'a \<Rightarrow> 'b)"
   by (simp add: Inf_pres_map_dual comp_assoc map_dual_invol)
 
 text \<open>The following lemmas relate isotonicity of functions between complete lattices 
 with weak (left) preservation properties of sups and infs.\<close>
 
 lemma fun_isol: "mono f \<Longrightarrow> mono ((\<circ>) f)"
   by (simp add: le_fun_def mono_def)
 
 lemma fun_isor: "mono f \<Longrightarrow> mono (\<lambda>x. x \<circ> f)"
   by (simp add: le_fun_def mono_def)
 
 lemma Sup_sup_pres: 
   fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
   shows "Sup_pres f \<Longrightarrow> sup_pres f"
   by (metis (no_types, opaque_lifting) Sup_empty Sup_insert comp_apply image_insert sup_bot.right_neutral)
 
 lemma Inf_inf_pres: 
   fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
   shows"Inf_pres f \<Longrightarrow> inf_pres f"
   by (smt INF_insert Inf_empty Inf_insert comp_eq_elim inf_top.right_neutral)
 
 lemma Sup_bot_pres: 
   fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
   shows "Sup_pres f \<Longrightarrow> bot_pres f"
   by (metis SUP_empty Sup_empty comp_eq_elim)
 
 lemma Inf_top_pres: 
   fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
   shows "Inf_pres f \<Longrightarrow> top_pres f"
   by (metis INF_empty Inf_empty comp_eq_elim)
 
 lemma Sup_sup_dual: 
   fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
   shows "Sup_dual f \<Longrightarrow> sup_dual f"
   by (smt comp_eq_elim image_empty image_insert inf_Inf sup_Sup)    
 
 lemma Inf_inf_dual: 
   fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
   shows "Inf_dual f \<Longrightarrow> inf_dual f"
   by (smt comp_eq_elim image_empty image_insert inf_Inf sup_Sup)   
 
 lemma Sup_bot_dual: 
   fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
   shows "Sup_dual f \<Longrightarrow> bot_dual f"
   by (metis INF_empty Sup_empty comp_eq_elim)
 
 lemma Inf_top_dual: 
   fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
   shows "Inf_dual f \<Longrightarrow> top_dual f"
   by (metis Inf_empty SUP_empty comp_eq_elim)
 
 text \<open>However, Inf-preservation does not imply top-preservation and 
 Sup-preservation does not imply bottom-preservation.\<close>
 
 lemma
   fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
   shows "Sup_pres f \<Longrightarrow> top_pres f" (*nitpick*)
   oops
 
 lemma  
   fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
   shows "Inf_pres f \<Longrightarrow> bot_pres f" (*nitpick*)
   oops
 
 context complete_lattice
 begin
 
 lemma iso_Inf_subdistl: 
   fixes f :: "'a \<Rightarrow> 'b::complete_lattice"
   shows "mono f \<Longrightarrow>f \<circ> Inf \<le> Inf \<circ> (`) f"
   by (simp add: complete_lattice_class.le_Inf_iff le_funI Inf_lower monoD)
 
 lemma iso_Sup_supdistl: 
   fixes f :: "'a \<Rightarrow> 'b::complete_lattice" 
   shows "mono f \<Longrightarrow> Sup \<circ> (`) f \<le> f \<circ> Sup"
   by (simp add: complete_lattice_class.Sup_le_iff le_funI Sup_upper monoD)
 
 lemma Inf_subdistl_iso: 
   fixes f :: "'a \<Rightarrow> 'b::complete_lattice"
   shows "f \<circ> Inf \<le> Inf \<circ> (`) f \<Longrightarrow> mono f"
   unfolding mono_def le_fun_def comp_def by (metis complete_lattice_class.le_INF_iff Inf_atLeast atLeast_iff)
 
 lemma Sup_supdistl_iso: 
   fixes f :: "'a \<Rightarrow> 'b::complete_lattice"
   shows "Sup \<circ> (`) f \<le> f \<circ> Sup \<Longrightarrow> mono f"
   unfolding mono_def le_fun_def comp_def by (metis complete_lattice_class.SUP_le_iff Sup_atMost atMost_iff)
 
 lemma supdistl_iso: 
   fixes f :: "'a \<Rightarrow> 'b::complete_lattice"
   shows "(Sup \<circ> (`) f \<le> f \<circ> Sup) = mono f"
   using Sup_supdistl_iso iso_Sup_supdistl by force
 
 lemma subdistl_iso: 
   fixes f :: "'a \<Rightarrow> 'b::complete_lattice"
   shows "(f \<circ> Inf \<le> Inf \<circ> (`) f) = mono f"
   using Inf_subdistl_iso iso_Inf_subdistl by force
 
 end
 
 lemma ord_iso_Inf_pres: 
   fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
   shows "ord_iso f \<Longrightarrow> Inf \<circ> (`) f = f \<circ> Inf"
 proof-
   let ?g = "the_inv f"
   assume h: "ord_iso f"
   hence a: "mono ?g"
     by (simp add: ord_iso_the_inv)
   {fix X :: "'a::complete_lattice set"
     {fix y :: "'b::complete_lattice"
    have "(y \<le> f (\<Sqinter>X)) = (?g y \<le> \<Sqinter>X)"
      by (metis (mono_tags, lifting) UNIV_I f_the_inv_into_f h monoD ord_embed_alt ord_embed_inj ord_iso_alt)
    also have "... = (\<forall>x \<in> X. ?g y \<le> x)"
     by (simp add: le_Inf_iff)
   also have "... = (\<forall>x \<in> X. y \<le> f x)"
     by (metis (mono_tags, lifting) UNIV_I f_the_inv_into_f h monoD ord_embed_alt ord_embed_inj ord_iso_alt)
   also have "... = (y \<le> \<Sqinter> (f ` X))"
     by (simp add: le_INF_iff)
   finally have "(y \<le> f (\<Sqinter>X)) = (y \<le> \<Sqinter> (f ` X))".}
   hence "f (\<Sqinter>X) = \<Sqinter> (f ` X)"
     by (meson dual_order.antisym order_refl)}
   thus ?thesis
     unfolding fun_eq_iff by simp
 qed
 
 lemma ord_iso_Sup_pres: 
   fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
   shows "ord_iso f \<Longrightarrow> Sup \<circ> (`) f = f \<circ> Sup"
 proof-
   let ?g = "the_inv f"
   assume h: "ord_iso f"
   hence a: "mono ?g"
     by (simp add: ord_iso_the_inv)
   {fix X :: "'a::complete_lattice set"
     {fix y :: "'b::complete_lattice"
    have "(f (\<Squnion>X) \<le> y) = (\<Squnion>X \<le> ?g y)"
      by (metis (mono_tags, lifting) UNIV_I f_the_inv_into_f h monoD ord_embed_alt ord_embed_inj ord_iso_alt)
    also have "... = (\<forall>x \<in> X. x \<le> ?g y)"
      by (simp add: Sup_le_iff)
      also have "... = (\<forall>x \<in> X. f x \<le> y)"
     by (metis (mono_tags, lifting) UNIV_I f_the_inv_into_f h monoD ord_embed_alt ord_embed_inj ord_iso_alt)
   also have "... = (\<Squnion> (f ` X) \<le> y)"
     by (simp add: SUP_le_iff)
   finally have "(f (\<Squnion>X) \<le> y) = (\<Squnion> (f ` X) \<le> y)".}
   hence "f (\<Squnion>X) = \<Squnion> (f ` X)"
     by (meson dual_order.antisym order_refl)}
   thus ?thesis
     unfolding fun_eq_iff by simp
 qed
 
 text \<open>Right preservation of sups and infs is trivial.\<close>
 
 lemma fSup_distr: "Sup_pres (\<lambda>x. x \<circ> f)"
   unfolding fun_eq_iff by (simp add: image_comp)
 
 lemma fSup_distr_var: "\<Squnion>F \<circ> g = (\<Squnion>f \<in> F. f \<circ> g)"
   unfolding fun_eq_iff by (simp add: image_comp)
 
 lemma fInf_distr: "Inf_pres (\<lambda>x. x \<circ> f)"
   unfolding fun_eq_iff comp_def
   by (smt INF_apply Inf_fun_def Sup.SUP_cong) 
 
 lemma fInf_distr_var: "\<Sqinter>F \<circ> g = (\<Sqinter>f \<in> F. f \<circ> g)"
   unfolding fun_eq_iff comp_def
   by (smt INF_apply INF_cong INF_image Inf_apply image_comp image_def image_image)
 
 
 text \<open>The next set of lemma revisits the preservation properties in the function space.\<close>
 
 lemma fSup_subdistl: 
   assumes "mono (f::'a::complete_lattice \<Rightarrow> 'b::complete_lattice)"
   shows "Sup \<circ> (`) ((\<circ>) f) \<le> (\<circ>) f \<circ> Sup"
   using assms by (simp add: fun_isol supdistl_iso) 
 
 lemma fSup_subdistl_var: 
   fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
   shows  "mono f \<Longrightarrow> (\<Squnion>g \<in> G. f \<circ> g) \<le> f \<circ> \<Squnion>G"
   by (simp add: fun_isol mono_Sup)
 
 lemma fInf_subdistl: 
   fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
   shows  "mono f \<Longrightarrow> (\<circ>) f \<circ> Inf \<le> Inf \<circ> (`) ((\<circ>) f)"
   by (simp add: fun_isol subdistl_iso)
 
 lemma fInf_subdistl_var: 
   fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
   shows "mono f \<Longrightarrow> f \<circ> \<Sqinter>G \<le> (\<Sqinter>g \<in> G. f \<circ> g)"
   by (simp add: fun_isol mono_Inf)
 
 lemma fSup_distl: "Sup_pres f \<Longrightarrow> Sup_pres ((\<circ>) f)"
   unfolding fun_eq_iff by (simp add: image_comp)
 
 lemma fSup_distl_var: "Sup_pres f \<Longrightarrow> f \<circ> \<Squnion>G = (\<Squnion>g \<in> G. f \<circ> g)"
   unfolding fun_eq_iff by (simp add: image_comp)
 
 lemma fInf_distl: "Inf_pres f \<Longrightarrow> Inf_pres ((\<circ>) f)"
   unfolding fun_eq_iff by (simp add: image_comp)
 
 lemma fInf_distl_var: "Inf_pres f \<Longrightarrow> f \<circ> \<Sqinter>G = (\<Sqinter>g \<in> G. f \<circ> g)"
   unfolding fun_eq_iff by (simp add: image_comp)
 
 text \<open>Downsets preserve infs whereas upsets preserve sups.\<close>
 
 lemma Inf_pres_downset: "Inf_pres (\<down>::'a::complete_lattice_with_dual \<Rightarrow> 'a set)"
   unfolding downset_prop fun_eq_iff
   by (safe, simp_all add: le_Inf_iff)
  
 lemma Sup_dual_upset: "Sup_dual (\<up>::'a::complete_lattice_with_dual \<Rightarrow> 'a set)"
   unfolding upset_prop fun_eq_iff
   by (safe, simp_all add: Sup_le_iff)
 
 text \<open>Images of Sup-morphisms are closed under Sups and images of Inf-morphisms are closed under Infs.\<close>
 
 lemma Sup_pres_Sup_closed: "Sup_pres f \<Longrightarrow> Sup_closed_set (range f)"
   by (metis (mono_tags, lifting) Sup_closed_set_def comp_eq_elim range_eqI subset_image_iff)
 
 lemma Inf_pres_Inf_closed: "Inf_pres f \<Longrightarrow> Inf_closed_set (range f)"
   by (metis (mono_tags, lifting) Inf_closed_set_def comp_eq_elim range_eqI subset_image_iff)
 
 text \<open>It is well known that functions into complete lattices form complete lattices. Here, such results are shown for
 the subclasses of isotone functions, where additional closure conditions must be respected.\<close>
 
 typedef (overloaded) 'a iso = "{f::'a::order \<Rightarrow> 'a::order. mono f}"
   by (metis Abs_ord_homset_cases ord_homset_def)
 
 setup_lifting type_definition_iso
 
 instantiation iso :: (complete_lattice) complete_lattice
 begin
 
 lift_definition Inf_iso :: "'a::complete_lattice iso set \<Rightarrow> 'a iso" is Sup
   by (metis (mono_tags, lifting) SUP_subset_mono Sup_apply mono_def subsetI)
 
 lift_definition Sup_iso :: "'a::complete_lattice iso set \<Rightarrow> 'a iso" is Inf
   by (smt INF_lower2 Inf_apply le_INF_iff mono_def)
 
 lift_definition bot_iso :: "'a::complete_lattice iso" is "\<top>"
   by (simp add: monoI)
 
 lift_definition sup_iso :: "'a::complete_lattice iso \<Rightarrow> 'a iso \<Rightarrow> 'a iso" is inf
   by (smt inf_apply inf_mono monoD monoI)
 
 lift_definition top_iso :: "'a::complete_lattice iso" is "\<bottom>"
   by (simp add: mono_def)
 
 lift_definition inf_iso :: "'a::complete_lattice iso \<Rightarrow> 'a iso \<Rightarrow> 'a iso" is sup
   by (smt mono_def sup.mono sup_apply)
 
 lift_definition less_eq_iso :: "'a::complete_lattice iso \<Rightarrow> 'a iso \<Rightarrow> bool" is "(\<ge>)".
 
 lift_definition less_iso :: "'a::complete_lattice iso \<Rightarrow> 'a iso \<Rightarrow> bool" is "(>)".
 
 instance
   by (intro_classes; transfer, simp_all add: less_fun_def Sup_upper Sup_least Inf_lower Inf_greatest)
 
 end
 
 text \<open>Duality has been baked into this result because of its relevance for predicate transformers. A proof
 where Sups are mapped to Sups and Infs to Infs is certainly possible, but two instantiation of the same type
 and the same classes are unfortunately impossible. Interpretations could be used instead.
 
 A corresponding result for Inf-preseving functions and Sup-lattices, is proved in components on transformers,
 as more advanced properties about Inf-preserving functions are needed.\<close>
 
 
 subsection \<open>Alternative Definitions for Complete Boolean Algebras\<close>
 
 text \<open>The current definitions of complete boolean algebras deviates from that in most textbooks in that
 a distributive law with infinite sups and infinite infs is used. There are interesting applications, for instance 
 in topology, where weaker laws are needed --- for instance for frames and locales.\<close>
 
 class complete_heyting_algebra = complete_lattice +
   assumes ch_dist: "x \<sqinter> \<Squnion>Y = (\<Squnion>y \<in> Y. x \<sqinter> y)"
 
 text \<open>Complete Heyting algebras are also known as frames or locales (they differ with respect to their morphisms).\<close>
 
 class complete_co_heyting_algebra = complete_lattice +
   assumes co_ch_dist: "x \<squnion> \<Sqinter>Y = (\<Sqinter>y \<in> Y. x \<squnion> y)"
 
 class complete_boolean_algebra_alt = complete_lattice + boolean_algebra
 
 instance set :: (type) complete_boolean_algebra_alt..
 
 context complete_boolean_algebra_alt
 begin
 
 subclass complete_heyting_algebra
 proof
   fix x Y 
   {fix t
     have "(x \<sqinter> \<Squnion>Y \<le> t) = (\<Squnion>Y \<le> -x \<squnion> t)"
       by (simp add: inf.commute shunt1[symmetric])
     also have "... = (\<forall>y \<in> Y. y \<le> -x \<squnion> t)"
       using Sup_le_iff by blast
     also have "... = (\<forall>y \<in> Y. x \<sqinter> y \<le> t)"
       by (simp add: inf.commute shunt1)
     finally have "(x \<sqinter> \<Squnion>Y \<le> t) = ((\<Squnion>y\<in>Y. x \<sqinter> y) \<le> t)"
       by (simp add: local.SUP_le_iff)}
   thus "x \<sqinter> \<Squnion>Y = (\<Squnion>y\<in>Y. x \<sqinter> y)"
     using order.eq_iff by blast
 qed
 
 subclass complete_co_heyting_algebra
   apply unfold_locales
   apply (rule order.antisym)
    apply (simp add: INF_greatest Inf_lower2)
   by (meson eq_refl le_INF_iff le_Inf_iff shunt2)
 
 lemma de_morgan1: "-(\<Squnion>X) = (\<Sqinter>x \<in> X. -x)"
 proof-
   {fix y
   have "(y \<le> -(\<Squnion>X)) = (\<Squnion>X \<le> -y)"
     using compl_le_swap1 by blast
   also have "... = (\<forall>x \<in> X. x \<le> -y)"
     by (simp add: Sup_le_iff)
   also have "... = (\<forall>x \<in> X. y \<le> -x)"
     using compl_le_swap1 by blast
   also have "... = (y \<le> (\<Sqinter>x \<in> X. -x))"
     using le_INF_iff by force
   finally have "(y \<le> -(\<Squnion>X)) = (y \<le>(\<Sqinter>x \<in> X. -x))".}
   thus ?thesis
     using order.antisym by blast
 qed
 
 lemma de_morgan2: "-(\<Sqinter>X) = (\<Squnion>x \<in> X. -x)"
   by (metis de_morgan1 ba_dual.dual_iff ba_dual.image_dual pointfree_idE)
 
 end
 
 class complete_boolean_algebra_alt_with_dual = complete_lattice_with_dual + complete_boolean_algebra_alt
 
 instantiation set :: (type) complete_boolean_algebra_alt_with_dual
 begin
 
 definition dual_set :: "'a set \<Rightarrow> 'a set" where
   "dual_set = uminus"
 
 instance
   by intro_classes (simp_all add: ba_dual.inj_dual dual_set_def comp_def uminus_Sup id_def)
 
 end
 
 context complete_boolean_algebra_alt
 begin
 
 sublocale cba_dual: complete_boolean_algebra_alt_with_dual _ _ _ _ _ _ _ _ uminus _ _
   by unfold_locales (auto simp: de_morgan2 de_morgan1)
 
 end
 
 
 subsection \<open>Atomic Boolean Algebras\<close>
 
 text \<open>Next, atomic boolean algebras are defined.\<close>
 
 context bounded_lattice
 begin
 
 text \<open>Atoms are covers of bottom.\<close>
 
 definition "atom x = (x \<noteq> \<bottom> \<and> \<not>(\<exists>y. \<bottom> < y \<and> y < x))"
 
 definition "atom_map x = {y. atom y \<and> y \<le> x}"
 
 lemma atom_map_def_var: "atom_map x = \<down>x \<inter> Collect atom"
   unfolding atom_map_def downset_def downset_set_def comp_def atom_def by fastforce
 
 lemma atom_map_atoms: "\<Union>(range atom_map) = Collect atom"
   unfolding atom_map_def atom_def by auto
 
 end
 
 typedef (overloaded) 'a atoms = "range (atom_map::'a::bounded_lattice \<Rightarrow> 'a set)"
   by blast
 
 setup_lifting type_definition_atoms
 
 definition at_map :: "'a::bounded_lattice \<Rightarrow> 'a atoms" where
   "at_map = Abs_atoms \<circ> atom_map"
 
 class atomic_boolean_algebra = boolean_algebra +
   assumes atomicity: "x \<noteq> \<bottom> \<Longrightarrow> (\<exists>y. atom y \<and> y \<le> x)"
 
 class complete_atomic_boolean_algebra = complete_lattice + atomic_boolean_algebra
 
 begin
 
 subclass complete_boolean_algebra_alt..
 
 end
 
 text \<open>Here are two equivalent definitions for atoms; first in boolean algebras, and then in complete 
 boolean algebras.\<close>
 
-context Lattices.boolean_algebra
+context boolean_algebra
 begin
 
 text \<open>The following two conditions are taken from Koppelberg's book~\cite{Koppelberg89}.\<close>
 
 lemma atom_neg: "atom x \<Longrightarrow> x \<noteq> \<bottom> \<and> (\<forall>y z. x \<le> y \<or> x \<le> -y)"
-  by (metis atom_def dual_order.order_iff_strict inf.cobounded1 inf.commute meet_shunt)
+  by (auto simp add: atom_def) (metis local.dual_order.not_eq_order_implies_strict local.inf.cobounded1 local.inf.cobounded2 local.inf_shunt)
 
 lemma atom_sup: "(\<forall>y. x \<le> y \<or> x \<le> -y) \<Longrightarrow> (\<forall>y z. (x \<le> y \<or> x \<le> z) = (x \<le> y \<squnion> z))"
   by (metis inf.orderE le_supI1 shunt2)
 
 lemma sup_atom: "x \<noteq> \<bottom> \<Longrightarrow> (\<forall>y z. (x \<le> y \<or> x \<le> z) = (x \<le> y \<squnion> z)) \<Longrightarrow> atom x"
-  unfolding atom_def apply clarsimp by (metis bot_less inf.absorb2 less_le_not_le meet_shunt sup_compl_top)
+  by (auto simp add: atom_def) (metis (full_types) local.inf.boundedI local.inf.cobounded2 local.inf_shunt local.inf_sup_ord(4) local.le_iff_sup local.shunt1 local.sup.absorb1 local.sup.strict_order_iff)
 
 lemma atom_sup_iff: "atom x = (x \<noteq> \<bottom> \<and> (\<forall>y z. (x \<le> y \<or> x \<le> z) = (x \<le> y \<squnion> z)))"
-  by  (standard, auto simp add: atom_neg atom_sup sup_atom)  
+  by rule (auto simp add: atom_neg atom_sup sup_atom)  
 
 lemma atom_neg_iff: "atom x = (x \<noteq> \<bottom> \<and> (\<forall>y z. x \<le> y \<or> x \<le> -y))"
-  by  (standard, auto simp add: atom_neg atom_sup sup_atom)
+  by rule (auto simp add: atom_neg atom_sup sup_atom)
 
 lemma atom_map_bot_pres: "atom_map \<bottom> = {}"
   using atom_def atom_map_def le_bot by auto
 
 lemma atom_map_top_pres: "atom_map \<top> = Collect atom"
   using atom_map_def by auto
 
 end
 
 context complete_boolean_algebra_alt
 begin
 
 lemma atom_Sup: "\<And>Y. x \<noteq> \<bottom> \<Longrightarrow> (\<forall>y. x \<le> y \<or> x \<le> -y) \<Longrightarrow> ((\<exists>y \<in> Y. x \<le> y) = (x \<le> \<Squnion>Y))"
-  by (metis Sup_least Sup_upper2 compl_le_swap1 le_iff_inf meet_shunt)
+  by (metis Sup_least Sup_upper2 compl_le_swap1 le_iff_inf inf_shunt)
 
 lemma Sup_atom: "x \<noteq> \<bottom> \<Longrightarrow> (\<forall>Y. (\<exists>y \<in> Y. x \<le> y) = (x \<le> \<Squnion>Y)) \<Longrightarrow> atom x"
 proof-
   assume h1: "x \<noteq> \<bottom>"
   and h2: "\<forall>Y. (\<exists>y \<in> Y. x \<le> y) = (x \<le> \<Squnion>Y)"
   hence "\<forall>y z. (x \<le> y \<or> x \<le> z) = (x \<le> y \<squnion> z)"
 
     by (smt insert_iff sup_Sup sup_bot.right_neutral)
   thus "atom x"
     by (simp add: h1 sup_atom)
 qed
 
 lemma atom_Sup_iff: "atom x = (x \<noteq> \<bottom> \<and> (\<forall>Y. (\<exists>y \<in> Y. x \<le> y) = (x \<le> \<Squnion>Y)))"
   by standard (auto simp: atom_neg atom_Sup Sup_atom)
 
 end
 
 end
diff --git a/thys/Order_Lattice_Props/Order_Lattice_Props_Loc.thy b/thys/Order_Lattice_Props/Order_Lattice_Props_Loc.thy
--- a/thys/Order_Lattice_Props/Order_Lattice_Props_Loc.thy
+++ b/thys/Order_Lattice_Props/Order_Lattice_Props_Loc.thy
@@ -1,575 +1,575 @@
 (* 
   Title: Locale-Based Duality
   Author: Georg Struth 
   Maintainer:Georg Struth <g.struth@sheffield.ac.uk> 
 *)
 
 section \<open>Locale-Based Duality\<close>
 
 theory Order_Lattice_Props_Loc
   imports Main 
           "HOL-Library.Lattice_Syntax"
 
 begin
 
 text \<open>This section explores order and lattice duality based on locales. Used within the context of a class or locale, 
 this is very effective, though more opaque than the previous approach. Outside of such a context, however, it apparently
 cannot be used for dualising theorems. Examples are properties of  functions between orderings or lattices.\<close>
 
 definition Fix :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a set" where 
   "Fix f = {x. f x = x}"
 
 context ord
 begin
 
 definition min_set :: "'a set \<Rightarrow> 'a set" where 
  "min_set X = {y \<in> X. \<forall>x \<in> X. x \<le> y \<longrightarrow> x = y}"
 
 definition max_set :: "'a set \<Rightarrow> 'a set" where 
  "max_set X = {x \<in> X. \<forall>y \<in> X. x \<le> y \<longrightarrow> x = y}"
 
 definition directed :: "'a set \<Rightarrow> bool" where
  "directed X = (\<forall>Y. finite Y \<and> Y \<subseteq> X \<longrightarrow> (\<exists>x \<in> X. \<forall>y \<in> Y. y \<le> x))"
 
 definition filtered :: "'a set \<Rightarrow> bool" where
  "filtered X = (\<forall>Y. finite Y \<and> Y \<subseteq> X \<longrightarrow> (\<exists>x \<in> X. \<forall>y \<in> Y. x \<le> y))"
 
 definition downset_set :: "'a set \<Rightarrow> 'a set" ("\<Down>") where
   "\<Down>X = {y. \<exists>x \<in> X. y \<le> x}"
 
 definition upset_set :: "'a set \<Rightarrow> 'a set" ("\<Up>") where
  "\<Up>X = {y. \<exists>x \<in> X. x \<le> y}"
 
 definition downset :: "'a \<Rightarrow> 'a set" ("\<down>") where 
   "\<down> = \<Down> \<circ> (\<lambda>x. {x})"
 
 definition upset :: "'a \<Rightarrow> 'a set" ("\<up>") where 
   "\<up> = \<Up> \<circ> (\<lambda>x. {x})"
 
 definition downsets :: "'a set set" where  
   "downsets = Fix \<Down>"
  
 definition upsets :: "'a set set" where
   "upsets = Fix \<Up>"
 
 abbreviation "downset_setp X \<equiv> X \<in> downsets"
 
 abbreviation "upset_setp X \<equiv> X \<in> upsets"
 
 definition ideals :: "'a set set" where
   "ideals = {X. X \<noteq> {} \<and> downset_setp X \<and> directed X}"
 
 definition filters :: "'a  set set" where
   "filters = {X. X \<noteq> {} \<and> upset_setp X \<and> filtered X}"
 
 abbreviation "idealp X \<equiv> X \<in> ideals"
 
 abbreviation "filterp X \<equiv> X \<in> filters"
 
 end
 
 abbreviation Sup_pres :: "('a::Sup \<Rightarrow> 'b::Sup) \<Rightarrow> bool" where
   "Sup_pres f \<equiv> f \<circ> Sup = Sup \<circ> (`) f"
 
 abbreviation Inf_pres :: "('a::Inf \<Rightarrow> 'b::Inf) \<Rightarrow> bool" where
   "Inf_pres f \<equiv> f \<circ> Inf = Inf \<circ> (`) f"
 
 abbreviation sup_pres :: "('a::sup \<Rightarrow> 'b::sup) \<Rightarrow> bool" where
   "sup_pres f \<equiv> (\<forall>x y. f (x \<squnion> y) = f x \<squnion> f y)"
 
 abbreviation inf_pres :: "('a::inf \<Rightarrow> 'b::inf) \<Rightarrow> bool" where
  "inf_pres f \<equiv> (\<forall>x y. f (x \<sqinter> y) = f x \<sqinter> f y)"
 
 abbreviation bot_pres :: "('a::bot \<Rightarrow> 'b::bot) \<Rightarrow> bool" where
   "bot_pres f \<equiv> f \<bottom> = \<bottom>"
 
 abbreviation top_pres :: "('a::top \<Rightarrow> 'b::top) \<Rightarrow> bool" where
   "top_pres f \<equiv> f \<top> = \<top>"
 
 abbreviation Sup_dual :: "('a::Sup \<Rightarrow> 'b::Inf) \<Rightarrow> bool" where
   "Sup_dual f \<equiv> f \<circ> Sup = Inf \<circ> (`) f"
 
 abbreviation Inf_dual :: "('a::Inf \<Rightarrow> 'b::Sup) \<Rightarrow> bool" where
   "Inf_dual f \<equiv> f \<circ> Inf = Sup \<circ> (`) f"
 
 abbreviation sup_dual :: "('a::sup \<Rightarrow> 'b::inf) \<Rightarrow> bool" where
   "sup_dual f \<equiv> (\<forall>x y. f (x \<squnion> y) = f x \<sqinter> f y)"
 
 abbreviation inf_dual :: "('a::inf \<Rightarrow> 'b::sup) \<Rightarrow> bool" where
  "inf_dual f \<equiv> (\<forall>x y. f (x \<sqinter> y) = f x \<squnion> f y)"
 
 abbreviation bot_dual :: "('a::bot \<Rightarrow> 'b::top) \<Rightarrow> bool" where 
  "bot_dual f \<equiv> f \<bottom> = \<top>"
 
 abbreviation top_dual :: "('a::top \<Rightarrow> 'b::bot) \<Rightarrow> bool" where 
   "top_dual f \<equiv> f \<top> = \<bottom>"
 
 
 subsection \<open>Duality via Locales\<close>
 
 sublocale ord \<subseteq> dual_ord: ord "(\<ge>)" "(>)"
   rewrites dual_max_set: "max_set = dual_ord.min_set"
   and dual_filtered: "filtered = dual_ord.directed"
   and dual_upset_set: "upset_set = dual_ord.downset_set"
   and dual_upset: "upset = dual_ord.downset"
   and dual_upsets: "upsets = dual_ord.downsets"
   and dual_filters: "filters = dual_ord.ideals"
        apply unfold_locales
   unfolding max_set_def ord.min_set_def fun_eq_iff apply blast
   unfolding filtered_def ord.directed_def apply simp 
   unfolding upset_set_def ord.downset_set_def apply simp
   apply (simp add: ord.downset_def ord.downset_set_def ord.upset_def ord.upset_set_def)
   unfolding upsets_def ord.downsets_def apply (metis ord.downset_set_def upset_set_def)
   unfolding filters_def ord.ideals_def Fix_def ord.downsets_def upsets_def ord.downset_set_def upset_set_def ord.directed_def filtered_def
   by simp
 
 sublocale preorder \<subseteq> dual_preorder: preorder "(\<ge>)" "(>)"
   apply unfold_locales
   apply (simp add: less_le_not_le)
   apply simp
   using order_trans by blast
 
 sublocale order \<subseteq> dual_order: order "(\<ge>)" "(>)"
   by (unfold_locales, simp)
 
 sublocale lattice \<subseteq> dual_lattice: lattice sup "(\<ge>)" "(>)" inf
   by (unfold_locales, simp_all)
 
 sublocale bounded_lattice \<subseteq> dual_bounded_lattice: bounded_lattice sup "(\<ge>)" "(>)" inf \<top> \<bottom>
   by (unfold_locales, simp_all)
 
-sublocale Lattices.boolean_algebra \<subseteq> dual_boolean_algebra: Lattices.boolean_algebra "\<lambda>x y. x \<squnion> -y" uminus sup "(\<ge>)" "(>)" inf \<top> \<bottom>
+sublocale boolean_algebra \<subseteq> dual_boolean_algebra: boolean_algebra "\<lambda>x y. x \<squnion> -y" uminus sup "(\<ge>)" "(>)" inf \<top> \<bottom>
   by (unfold_locales, simp_all add: inf_sup_distrib1)
 
 sublocale complete_lattice \<subseteq> dual_complete_lattice: complete_lattice Sup Inf sup "(\<ge>)" "(>)" inf \<top> \<bottom>
   rewrites dual_gfp: "gfp = dual_complete_lattice.lfp"  
 proof-
   show "class.complete_lattice Sup Inf sup (\<ge>) (>) inf \<top> \<bottom>"
     by (unfold_locales, simp_all add: Sup_upper Sup_least Inf_lower Inf_greatest)
   then interpret dual_complete_lattice: complete_lattice Sup Inf sup "(\<ge>)" "(>)" inf \<top> \<bottom>.
   show "gfp = dual_complete_lattice.lfp"  
     unfolding gfp_def dual_complete_lattice.lfp_def fun_eq_iff by simp
 qed
 
 context ord
 begin
 
 lemma dual_min_set: "min_set = dual_ord.max_set"
   by (simp add: dual_ord.dual_max_set)
 
 lemma dual_directed: "directed = dual_ord.filtered"
   by (simp add:dual_ord.dual_filtered)
 
 lemma dual_downset: "downset = dual_ord.upset"
   by (simp add: dual_ord.dual_upset)
 
 lemma dual_downset_set: "downset_set = dual_ord.upset_set"
   by (simp add: dual_ord.dual_upset_set)
 
 lemma dual_downsets: "downsets = dual_ord.upsets"
   by (simp add: dual_ord.dual_upsets)
 
 lemma dual_ideals: "ideals = dual_ord.filters"
   by (simp add: dual_ord.dual_filters)
 
 end
 
 context complete_lattice
 begin
 
 lemma dual_lfp: "lfp = dual_complete_lattice.gfp"
   by (simp add: dual_complete_lattice.dual_gfp)
 
 end
 
 subsection \<open>Properties of Orderings, Again\<close>
 
 context ord
 begin
 
 lemma directed_nonempty: "directed X \<Longrightarrow> X \<noteq> {}"
   unfolding directed_def by fastforce
 
 lemma directed_ub: "directed X \<Longrightarrow> (\<forall>x \<in> X. \<forall>y \<in> X. \<exists>z \<in> X. x \<le> z \<and> y \<le> z)"
   by (meson empty_subsetI directed_def finite.emptyI finite_insert insert_subset order_refl)
 
 lemma downset_set_prop: "\<Down> = Union \<circ> (`) \<down>"
   unfolding downset_set_def downset_def fun_eq_iff by fastforce
 
 lemma downset_set_prop_var: "\<Down>X = (\<Union>x \<in> X. \<down>x)"
   by (simp add: downset_set_prop)
 
 lemma downset_prop: "\<down>x = {y. y \<le> x}"
   unfolding downset_def downset_set_def fun_eq_iff comp_def by fastforce
 
 end
 
 context preorder
 begin
 
 lemma directed_prop: "X \<noteq> {} \<Longrightarrow> (\<forall>x \<in> X. \<forall>y \<in> X. \<exists>z \<in> X. x \<le> z \<and> y \<le> z) \<Longrightarrow> directed X"
 proof-
   assume h1: "X \<noteq> {}"
   and h2: "\<forall>x \<in> X. \<forall>y \<in> X. \<exists>z \<in> X. x \<le> z \<and> y \<le> z"
   {fix Y
   have "finite Y \<Longrightarrow> Y \<subseteq> X \<Longrightarrow> (\<exists>x \<in> X. \<forall>y \<in> Y. y \<le> x)"
   proof (induct rule: finite_induct)
     case empty
     then show ?case
       using h1 by blast 
   next
     case (insert x F)
     then show ?case
       by (metis h2 insert_iff insert_subset order_trans) 
   qed}
   thus ?thesis
     by (simp add: directed_def)
 qed
 
 lemma directed_alt: "directed X = (X \<noteq> {} \<and> (\<forall>x \<in> X. \<forall>y \<in> X. \<exists>z \<in> X. x \<le> z \<and> y \<le> z))"
   by (metis directed_prop directed_nonempty directed_ub)
 
 lemma downset_set_ext: "id \<le> \<Down>"
   unfolding le_fun_def id_def downset_set_def by auto 
 
 lemma downset_set_iso: "mono \<Down>"
   unfolding mono_def downset_set_def by blast
 
 lemma downset_set_idem [simp]: "\<Down> \<circ> \<Down> = \<Down>"
   unfolding fun_eq_iff downset_set_def comp_def using order_trans by auto
 
 lemma downset_faithful: "\<down>x \<subseteq> \<down>y \<Longrightarrow> x \<le> y"
   by (simp add: downset_prop subset_eq)
 
 lemma downset_iso_iff: "(\<down>x \<subseteq> \<down>y) = (x \<le> y)"
   using atMost_iff downset_prop order_trans by blast
 
 lemma downset_directed_downset_var [simp]: "directed (\<Down>X) = directed X"
 proof
   assume h1: "directed X"
   {fix Y
   assume h2: "finite Y" and h3: "Y \<subseteq> \<Down>X"
   hence "\<forall>y. \<exists>x. y \<in> Y \<longrightarrow> x \<in> X \<and>  y \<le> x"
     by (force simp: downset_set_def)
   hence "\<exists>f. \<forall>y. y \<in> Y \<longrightarrow>  f y \<in> X \<and> y \<le> f y"
     by (rule choice)
   hence "\<exists>f. finite (f ` Y) \<and> f ` Y \<subseteq> X \<and> (\<forall>y \<in> Y. y \<le> f y)"
     by (metis finite_imageI h2 image_subsetI)
   hence "\<exists>Z. finite Z \<and> Z \<subseteq> X \<and> (\<forall>y \<in> Y. \<exists> z \<in> Z. y \<le> z)"
     by fastforce
   hence "\<exists>Z. finite Z \<and> Z \<subseteq> X \<and> (\<forall>y \<in> Y. \<exists> z \<in> Z. y \<le> z) \<and> (\<exists>x \<in> X. \<forall> z \<in> Z. z \<le> x)"
     by (metis directed_def h1)
   hence "\<exists>x \<in> X. \<forall>y \<in> Y. y \<le> x"
     by (meson order_trans)}
   thus "directed (\<Down>X)"
     unfolding directed_def downset_set_def by fastforce
 next 
   assume "directed (\<Down>X)"
   thus "directed X"
     unfolding directed_def downset_set_def 
     apply clarsimp
     by (smt Ball_Collect order_refl order_trans subsetCE)
 qed
 
 lemma downset_directed_downset [simp]: "directed \<circ> \<Down> = directed"
   unfolding fun_eq_iff comp_def by simp
 
 lemma directed_downset_ideals: "directed (\<Down>X) = (\<Down>X \<in> ideals)"
   by (metis (mono_tags, lifting) Fix_def comp_apply directed_alt downset_set_idem downsets_def ideals_def mem_Collect_eq)
 
 end
 
 lemma downset_iso: "mono (\<down>::'a::order \<Rightarrow> 'a set)"
   by (simp add: downset_iso_iff mono_def)
 
 context order
 begin
 
 lemma downset_inj: "inj \<down>"
   by (metis injI downset_iso_iff order.eq_iff)
 
 end
 
 context lattice
 begin
 
 lemma lat_ideals: "X \<in> ideals = (X \<noteq> {} \<and> X \<in> downsets \<and> (\<forall>x \<in> X. \<forall> y \<in> X. x \<squnion> y \<in> X))"
   unfolding ideals_def directed_alt downsets_def Fix_def downset_set_def 
   by (clarsimp, smt sup.cobounded1 sup.orderE sup.orderI sup_absorb2 sup_left_commute mem_Collect_eq)
 
 end
 
 context bounded_lattice
 begin
 
 lemma bot_ideal: "X \<in> ideals \<Longrightarrow> \<bottom> \<in> X"
   unfolding ideals_def downsets_def Fix_def downset_set_def by fastforce
 
 end
 
 context complete_lattice
 begin
 
 lemma Sup_downset_id [simp]: "Sup \<circ> \<down> = id"
   using Sup_atMost atMost_def downset_prop by fastforce
 
 lemma downset_Sup_id: "id \<le> \<down> \<circ> Sup"
   by (simp add: Sup_upper downset_prop le_funI subsetI)
 
 lemma Inf_Sup_var: "\<Squnion>(\<Inter>x \<in> X. \<down>x) = \<Sqinter>X"
   unfolding downset_prop by (simp add: Collect_ball_eq Inf_eq_Sup)
 
 lemma Inf_pres_downset_var: "(\<Inter>x \<in> X. \<down>x) = \<down>(\<Sqinter>X)"
   unfolding downset_prop by (safe, simp_all add: le_Inf_iff)
 
 end
 
 lemma lfp_in_Fix: 
   fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
   shows "mono f \<Longrightarrow> lfp f \<in> Fix f"
   using Fix_def lfp_unfold by fastforce
 
 lemma gfp_in_Fix: 
   fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
   shows "mono f \<Longrightarrow> gfp f \<in> Fix f"
   using Fix_def gfp_unfold by fastforce
 
 lemma nonempty_Fix: 
   fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
   shows "mono f \<Longrightarrow> Fix f \<noteq> {}"
   using lfp_in_Fix by fastforce
 
 
 subsection \<open>Dual Properties of Orderings from Locales\<close>
 
 text \<open>These properties can be proved very smoothly overall. But only within the context of a class
 or locale!\<close>
 
 context ord
 begin
 
 lemma filtered_nonempty: "filtered X \<Longrightarrow> X \<noteq> {}"
   by (simp add: dual_filtered dual_ord.directed_nonempty)
 
 lemma filtered_lb: "filtered X \<Longrightarrow> (\<forall>x \<in> X. \<forall>y \<in> X. \<exists>z \<in> X. z \<le> x \<and> z \<le> y)"
   by (simp add: dual_filtered dual_ord.directed_ub)
 
 lemma upset_set_prop: "\<Up> = Union \<circ> (`) \<up>"
   by (simp add: dual_ord.downset_set_prop dual_upset dual_upset_set)
 
 lemma upset_set_prop_var: "\<Up>X = (\<Union>x \<in> X. \<up>x)"
   by (simp add: dual_ord.downset_set_prop_var dual_upset dual_upset_set)
 
 lemma upset_prop: "\<up>x = {y. x \<le> y}"
   by (simp add: dual_ord.downset_prop dual_upset)
 
 end
 
 context preorder
 begin
 
 lemma filtered_prop: "X \<noteq> {} \<Longrightarrow> (\<forall>x \<in> X. \<forall>y \<in> X. \<exists>z \<in> X. z \<le> x \<and> z \<le> y) \<Longrightarrow> filtered X"
   by (simp add: dual_filtered dual_preorder.directed_prop)
 
 lemma filtered_alt: "filtered X = (X \<noteq> {} \<and> (\<forall>x \<in> X. \<forall>y \<in> X. \<exists>z \<in> X. z \<le> x \<and> z \<le> y))"
   by (simp add: dual_filtered dual_preorder.directed_alt)
 
 lemma upset_set_ext: "id \<le> \<Up>"
   by (simp add: dual_preorder.downset_set_ext dual_upset_set)
 
 lemma upset_set_anti: "mono \<Up>"
   by (simp add: dual_preorder.downset_set_iso dual_upset_set) 
 
 lemma up_set_idem [simp]: "\<Up> \<circ> \<Up> = \<Up>"
   by (simp add: dual_upset_set)
 
 lemma upset_faithful: "\<up>x \<subseteq> \<up>y \<Longrightarrow> y \<le> x"
   by (metis dual_preorder.downset_faithful dual_upset)
 
 lemma upset_anti_iff: "(\<up>y \<subseteq> \<up>x) = (x \<le> y)"
   by (simp add: dual_preorder.downset_iso_iff dual_upset)
 
 lemma upset_filtered_upset [simp]: "filtered \<circ> \<Up> = filtered"
   by (simp add: dual_filtered dual_upset_set)
 
 lemma filtered_upset_filters: "filtered (\<Up>X) = (\<Up>X \<in> filters)"
   using dual_filtered dual_preorder.directed_downset_ideals dual_upset_set ord.dual_filters by fastforce
 
 end
 
 context order
 begin
 
 lemma upset_inj: "inj \<up>"
   by (simp add: dual_order.downset_inj dual_upset)
 
 end
 
 context lattice
 begin
 
 lemma lat_filters: "X \<in> filters = (X \<noteq> {} \<and> X \<in> upsets \<and> (\<forall>x \<in> X. \<forall> y \<in> X. x \<sqinter> y \<in> X))"
   by (simp add: dual_filters dual_lattice.lat_ideals dual_ord.downsets_def dual_upset_set upsets_def)
 
 end
 
 context bounded_lattice
 begin
 
 lemma top_filter: "X \<in> filters \<Longrightarrow> \<top> \<in> X"
   by (simp add: dual_bounded_lattice.bot_ideal dual_filters)
 
 end
 
 context complete_lattice
 begin
 
 lemma Inf_upset_id [simp]: "Inf \<circ> \<up> = id"
   by (simp add:  dual_upset)
 
 lemma upset_Inf_id: "id \<le> \<up> \<circ> Inf"
   by (simp add: dual_complete_lattice.downset_Sup_id dual_upset)
 
 lemma Sup_Inf_var: " \<Sqinter>(\<Inter>x \<in> X. \<up>x) = \<Squnion>X"
   by (simp add: dual_complete_lattice.Inf_Sup_var dual_upset)
 
 lemma Sup_dual_upset_var: "(\<Inter>x \<in> X. \<up>x) = \<up>(\<Squnion>X)"
   by (simp add: dual_complete_lattice.Inf_pres_downset_var dual_upset)
 
 end
 
 subsection \<open>Examples that Do Not Dualise\<close>
 
 lemma upset_anti: "antimono (\<up>::'a::order \<Rightarrow> 'a set)"
   by (simp add: antimono_def upset_anti_iff)
 
 context complete_lattice 
 begin
 
 lemma fSup_unfold: "(f::nat \<Rightarrow> 'a) 0 \<squnion> (\<Squnion>n. f (Suc n)) = (\<Squnion>n. f n)"
   apply (intro order.antisym sup_least)
     apply (rule Sup_upper, force)
    apply (rule Sup_mono, force)
   apply (safe intro!: Sup_least)
  by (case_tac n, simp_all add: Sup_upper le_supI2)
 
 
 lemma fInf_unfold: "(f::nat \<Rightarrow> 'a) 0 \<sqinter> (\<Sqinter>n. f (Suc n)) = (\<Sqinter>n. f n)"
   apply (intro order.antisym inf_greatest)
   apply (rule Inf_greatest, safe)
   apply (case_tac n)
    apply simp_all
   using Inf_lower inf.coboundedI2 apply force
    apply (simp add: Inf_lower)
   by (auto intro: Inf_mono)
 
 end
 
 lemma fun_isol: "mono f \<Longrightarrow> mono ((\<circ>) f)"
   by (simp add: le_fun_def mono_def)
 
 lemma fun_isor: "mono f \<Longrightarrow> mono (\<lambda>x. x \<circ> f)"
   by (simp add: le_fun_def mono_def)
 
 lemma Sup_sup_pres: 
   fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
   shows "Sup_pres f \<Longrightarrow> sup_pres f"
   by (metis (no_types, opaque_lifting) Sup_empty Sup_insert comp_apply image_insert sup_bot.right_neutral)
 
 lemma Inf_inf_pres: 
   fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
   shows"Inf_pres f \<Longrightarrow> inf_pres f"
   by (smt INF_insert comp_eq_elim dual_complete_lattice.Sup_empty dual_complete_lattice.Sup_insert inf_top.right_neutral)
 
 lemma Sup_bot_pres: 
   fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
   shows "Sup_pres f \<Longrightarrow> bot_pres f"
   by (metis SUP_empty Sup_empty comp_eq_elim)
 
 lemma Inf_top_pres: 
   fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
   shows "Inf_pres f \<Longrightarrow> top_pres f"
   by (metis INF_empty comp_eq_elim dual_complete_lattice.Sup_empty)
 
 context complete_lattice
 begin
 
 lemma iso_Inf_subdistl: 
   assumes "mono (f::'a \<Rightarrow> 'b::complete_lattice)"
   shows "f \<circ> Inf \<le> Inf \<circ> (`) f"
   by (simp add: assms complete_lattice_class.le_Inf_iff le_funI Inf_lower monoD)
 
 lemma iso_Sup_supdistl: 
   assumes "mono (f::'a \<Rightarrow> 'b::complete_lattice)"
   shows "Sup \<circ> (`) f \<le> f \<circ> Sup"
   by (simp add: assms complete_lattice_class.SUP_le_iff le_funI dual_complete_lattice.Inf_lower monoD)
 
 lemma Inf_subdistl_iso: 
   fixes f :: "'a \<Rightarrow> 'b::complete_lattice"
   shows "f \<circ> Inf \<le> Inf \<circ> (`) f \<Longrightarrow> mono f"
   unfolding mono_def le_fun_def comp_def by (metis complete_lattice_class.le_INF_iff Inf_atLeast atLeast_iff)
 
 lemma Sup_supdistl_iso: 
   fixes f :: "'a \<Rightarrow> 'b::complete_lattice"
   shows "Sup \<circ> (`) f \<le> f \<circ> Sup \<Longrightarrow> mono f"
   unfolding mono_def le_fun_def comp_def by (metis complete_lattice_class.SUP_le_iff Sup_atMost atMost_iff)
 
 lemma supdistl_iso: 
   fixes f :: "'a \<Rightarrow> 'b::complete_lattice"
   shows "(Sup \<circ> (`) f \<le> f \<circ> Sup) = mono f"
   using Sup_supdistl_iso iso_Sup_supdistl by force
 
 lemma subdistl_iso: 
   fixes f :: "'a \<Rightarrow> 'b::complete_lattice"
   shows "(f \<circ> Inf \<le> Inf \<circ> (`) f) = mono f"
   using Inf_subdistl_iso iso_Inf_subdistl by force
 
 end
 
 lemma fSup_distr: "Sup_pres (\<lambda>x. x \<circ> f)"
   unfolding fun_eq_iff comp_def
   by (smt Inf.INF_cong SUP_apply Sup_apply)
 
 lemma fSup_distr_var: "\<Squnion>F \<circ> g = (\<Squnion>f \<in> F. f \<circ> g)"
   unfolding fun_eq_iff comp_def
   by (smt Inf.INF_cong SUP_apply Sup_apply)
 
 lemma fInf_distr: "Inf_pres (\<lambda>x. x \<circ> f)"
   unfolding fun_eq_iff comp_def
   by (smt INF_apply Inf.INF_cong Inf_apply)
 
 lemma fInf_distr_var: "\<Sqinter>F \<circ> g = (\<Sqinter>f \<in> F. f \<circ> g)"
   unfolding fun_eq_iff comp_def
   by (smt INF_apply Inf.INF_cong Inf_apply)
 
 lemma fSup_subdistl: 
   assumes "mono (f::'a::complete_lattice \<Rightarrow> 'b::complete_lattice)"
   shows "Sup \<circ> (`) ((\<circ>) f) \<le> (\<circ>) f \<circ> Sup"
   using assms by (simp add: SUP_least Sup_upper le_fun_def monoD image_comp)
 
 lemma fSup_subdistl_var: 
   fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
   shows  "mono f \<Longrightarrow> (\<Squnion>g \<in> G. f \<circ> g) \<le> f \<circ> \<Squnion>G"
   by (simp add: SUP_least Sup_upper le_fun_def monoD image_comp)
 
 lemma fInf_subdistl: 
   fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
   shows  "mono f \<Longrightarrow> (\<circ>) f \<circ> Inf \<le> Inf \<circ> (`) ((\<circ>) f)"
   by (simp add: INF_greatest Inf_lower le_fun_def monoD image_comp)
 
 lemma fInf_subdistl_var: 
   fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
   shows "mono f \<Longrightarrow> f \<circ> \<Sqinter>G \<le> (\<Sqinter>g \<in> G. f \<circ> g)"
   by (simp add: INF_greatest Inf_lower le_fun_def monoD image_comp)
 
 lemma Inf_pres_downset: "Inf_pres (\<down>::'a::complete_lattice \<Rightarrow> 'a set)"
   unfolding downset_prop fun_eq_iff comp_def
   by (safe, simp_all add: le_Inf_iff)
  
 lemma Sup_dual_upset: "Sup_dual (\<up>::'a::complete_lattice \<Rightarrow> 'a set)"
   unfolding upset_prop fun_eq_iff comp_def
   by (safe, simp_all add: Sup_le_iff)
 
 text \<open>This approach could probably be combined with the explicit functor-based one. This may be good for proofs, but seems conceptually rather ugly.\<close>
 
 end
\ No newline at end of file
diff --git a/thys/Order_Lattice_Props/Representations.thy b/thys/Order_Lattice_Props/Representations.thy
--- a/thys/Order_Lattice_Props/Representations.thy
+++ b/thys/Order_Lattice_Props/Representations.thy
@@ -1,620 +1,620 @@
 (* 
   Title: Representation Theorems for Orderings and Lattices
   Author: Georg Struth 
   Maintainer: Georg Struth <g.struth@sheffield.ac.uk> 
 *)
 
 section \<open>Representation Theorems for Orderings and Lattices\<close>
 
 theory Representations
   imports Order_Lattice_Props
 
 begin
 
 subsection \<open>Representation of Posets\<close>
 
 text \<open>The isomorphism between partial orders and downsets with set inclusion is well known. It forms the basis of Priestley and Stone duality.
 I show it not only for objects, but also order morphisms, hence establish equivalences and isomorphisms between categories.\<close>
 
 typedef (overloaded) 'a downset = "range (\<down>::'a::ord \<Rightarrow> 'a set)"
   by fastforce
 
 setup_lifting type_definition_downset
   
 text \<open>The map ds yields the isomorphism between the set and the powerset level if its range is restricted to downsets.\<close>
   
 definition ds :: "'a::ord \<Rightarrow> 'a downset" where 
   "ds = Abs_downset \<circ> \<down>"
 
 text \<open>In a complete lattice, its inverse is Sup.\<close>
 
 definition SSup :: "'a::complete_lattice downset \<Rightarrow> 'a" where
   "SSup = Sup \<circ> Rep_downset"
 
 lemma ds_SSup_inv: "ds \<circ> SSup = (id::'a::complete_lattice downset \<Rightarrow> 'a downset)"
   unfolding ds_def SSup_def
   by (smt Rep_downset Rep_downset_inverse cSup_atMost eq_id_iff imageE o_def ord_class.atMost_def ord_class.downset_prop)
 
 lemma SSup_ds_inv: "SSup \<circ> ds = (id::'a::complete_lattice \<Rightarrow> 'a)"
   unfolding ds_def SSup_def fun_eq_iff id_def comp_def by (simp add: Abs_downset_inverse pointfree_idE) 
 
 instantiation downset :: (ord) order
 begin 
   
 lift_definition less_eq_downset :: "'a downset \<Rightarrow> 'a downset \<Rightarrow> bool" is "(\<lambda>X Y. Rep_downset X \<subseteq> Rep_downset Y)" .
 
 lift_definition less_downset :: "'a downset \<Rightarrow> 'a downset \<Rightarrow> bool" is "(\<lambda>X Y. Rep_downset X \<subset> Rep_downset Y)" .
 
 instance
   by (intro_classes, transfer, auto simp: Rep_downset_inject less_eq_downset_def)
 
 end
 
 lemma ds_iso: "mono ds"
   unfolding mono_def ds_def fun_eq_iff comp_def
   by (metis Abs_downset_inverse downset_iso_iff less_eq_downset.rep_eq rangeI)
  
 lemma ds_faithful: "ds x \<le> ds y \<Longrightarrow> x \<le> (y::'a::order)"
   by (simp add: Abs_downset_inverse downset_faithful ds_def less_eq_downset.rep_eq)
 
 lemma ds_inj: "inj (ds::'a::order \<Rightarrow> 'a downset)"
   by (simp add: ds_faithful dual_order.antisym injI)
 
 lemma ds_surj: "surj ds"
   by (metis (no_types, opaque_lifting) Rep_downset Rep_downset_inverse ds_def image_iff o_apply surj_def)
 
 lemma ds_bij: "bij (ds::'a::order \<Rightarrow> 'a downset)"
   by (simp add: bijI ds_inj ds_surj)
 
 lemma ds_ord_iso: "ord_iso ds"
   unfolding ord_iso_def comp_def inf_bool_def by (smt UNIV_I ds_bij ds_faithful ds_inj ds_iso ds_surj f_the_inv_into_f inf1I mono_def)
 
 text \<open>The morphishms between orderings and downsets are isotone functions. One can define functors mapping back and forth between these.\<close>
 
 definition map_ds :: "('a::complete_lattice \<Rightarrow> 'b::complete_lattice) \<Rightarrow> ('a downset \<Rightarrow> 'b downset)" where
   "map_ds f = ds \<circ> f \<circ> SSup"
 
 text \<open>This definition is actually contrived. We have shown that a function f between posets P and Q is isotone if and only if the 
 inverse image of f maps downclosed sets in Q to downclosed sets in P. There is the following duality: ds is a natural transformation 
 between the identity functor and the preimage functor as a contravariant functor from P to Q. Hence orderings with isotone maps and 
 downsets with downset-preserving maps are dual, which is a first step towards Stone duality. I don't see a way of proving this with Isabelle, 
 as the types of the preimage of f are the wrong way and I don't see how I could capture opposition with what I have.\<close> 
 
 (*lemma "mono (f::'a::complete_lattice \<Rightarrow> 'b::complete_lattimap_ds f = Abs_downset \<circ> (-`) f \<circ> Rep_downset" doesn't work! *)
 
 lemma map_ds_prop: 
   fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice" 
   shows "map_ds f \<circ> ds = ds \<circ> f"
   unfolding map_ds_def by (simp add: SSup_ds_inv comp_assoc)
 
 lemma map_ds_prop2: 
   fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
   shows "map_ds f \<circ> ds = ds \<circ> id f"
   unfolding map_ds_def by (simp add: SSup_ds_inv comp_assoc)
 
 text \<open>This is part of showing that map-ds is naturally isomorphic to the identity functor, ds being the natural isomorphism.\<close>
 
 definition map_SSup :: "('a downset \<Rightarrow> 'b downset) \<Rightarrow> ('a::complete_lattice \<Rightarrow> 'b::complete_lattice)" where
   "map_SSup F = SSup \<circ> F \<circ> ds"
 
 lemma map_ds_iso_pres: 
   fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
   shows "mono f \<Longrightarrow> mono (map_ds f)"
   unfolding fun_eq_iff mono_def map_ds_def ds_def SSup_def comp_def
   by (metis Abs_downset_inverse Sup_subset_mono downset_iso_iff less_eq_downset.rep_eq rangeI)
 
 lemma map_SSup_iso_pres: 
   fixes F :: "'a::complete_lattice downset \<Rightarrow> 'b::complete_lattice downset"
   shows "mono F \<Longrightarrow> mono (map_SSup F)"
   unfolding fun_eq_iff mono_def map_SSup_def ds_def SSup_def comp_def
   by (metis Abs_downset_inverse Sup_subset_mono downset_iso_iff less_eq_downset.rep_eq rangeI)
 
 lemma map_SSup_prop: 
   fixes F :: "'a::complete_lattice downset \<Rightarrow> 'b::complete_lattice downset"
   shows "ds \<circ> map_SSup F = F \<circ> ds"
   unfolding map_SSup_def by (metis ds_SSup_inv fun.map_id0 id_def rewriteL_comp_comp)
 
 lemma map_SSup_prop2: 
   fixes F :: "'a::complete_lattice downset \<Rightarrow> 'b::complete_lattice downset"
   shows "ds \<circ> map_SSup F = id F \<circ> ds"
   by (simp add: map_SSup_prop)
 
 lemma map_ds_func1: "map_ds id = (id::'a::complete_lattice downset\<Rightarrow> 'a downset)"
   by (simp add: ds_SSup_inv map_ds_def)
 
 lemma map_ds_func2: 
   fixes g :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
   shows "map_ds (f \<circ> g) = map_ds f \<circ> map_ds g"
   unfolding map_ds_def fun_eq_iff comp_def ds_def SSup_def
   by (metis Abs_downset_inverse Sup_atMost atMost_def downset_prop rangeI)
 
 lemma map_SSup_func1: "map_SSup (id::'a::complete_lattice downset\<Rightarrow> 'a downset) = id"
   by (simp add: SSup_ds_inv map_SSup_def)
 
 lemma map_SSup_func2: 
   fixes F :: "'c::complete_lattice downset \<Rightarrow> 'b::complete_lattice downset"
   and G :: "'a::complete_lattice downset \<Rightarrow> 'c downset"
   shows "map_SSup (F \<circ> G) = map_SSup F \<circ> map_SSup G"
   unfolding map_SSup_def fun_eq_iff comp_def id_def ds_def
   by (metis comp_apply ds_SSup_inv ds_def id_apply)
 
 lemma map_SSup_map_ds_inv: "map_SSup \<circ> map_ds = (id::('a::complete_lattice \<Rightarrow> 'b::complete_lattice) \<Rightarrow> ('a \<Rightarrow> 'b))"
   by (metis (no_types, opaque_lifting) SSup_ds_inv comp_def eq_id_iff fun.map_comp fun.map_id0 id_apply map_SSup_prop map_ds_prop)
 
 lemma map_ds_map_SSup_inv: "map_ds \<circ> map_SSup = (id::('a::complete_lattice downset \<Rightarrow> 'b::complete_lattice downset) \<Rightarrow> ('a downset \<Rightarrow> 'b downset))"
   unfolding map_SSup_def map_ds_def SSup_def ds_def id_def comp_def fun_eq_iff
   by (metis (no_types, lifting) Rep_downset Rep_downset_inverse Sup_downset_id image_iff pointfree_idE)
 
 lemma inj_map_ds: "inj (map_ds::('a::complete_lattice \<Rightarrow> 'b::complete_lattice) \<Rightarrow> ('a downset \<Rightarrow> 'b downset))"
   by (metis (no_types, lifting) SSup_ds_inv fun.map_id0 id_comp inj_def map_ds_prop rewriteR_comp_comp2)
 
 lemma inj_map_SSup: "inj (map_SSup::('a::complete_lattice downset \<Rightarrow> 'b::complete_lattice downset) \<Rightarrow> ('a \<Rightarrow> 'b))"
   by (metis inj_on_id inj_on_imageI2 map_ds_map_SSup_inv)
 
 lemma map_ds_map_SSup_iff: 
   fixes g :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
   shows "(f = map_ds g) = (map_SSup f = g)"
   by (metis inj_eq inj_map_ds map_ds_map_SSup_inv pointfree_idE)
 
 text \<open>This gives an isomorphism between categories.\<close>
 
 lemma surj_map_ds: "surj (map_ds::('a::complete_lattice \<Rightarrow> 'b::complete_lattice) \<Rightarrow> ('a downset \<Rightarrow> 'b downset))"
   by (simp add: map_ds_map_SSup_iff surj_def)
 
 lemma surj_map_SSup: "surj (map_SSup::('a::complete_lattice_with_dual downset \<Rightarrow> 'b::complete_lattice_with_dual downset) \<Rightarrow> ('a \<Rightarrow> 'b))"
   by (metis map_ds_map_SSup_iff surjI)
 
 text \<open>There is of course a dual result for upsets with the reverse inclusion ordering. Once again, it seems impossible to capture 
 the "real" duality that uses the inverse image functor.\<close>
 
 typedef (overloaded) 'a upset = "range (\<up>::'a::ord \<Rightarrow> 'a set)"
   by fastforce
 
 setup_lifting type_definition_upset
     
 definition us :: "'a::ord \<Rightarrow> 'a upset" where 
   "us = Abs_upset \<circ> \<up>"
 
 definition IInf :: "'a::complete_lattice upset \<Rightarrow> 'a" where
   "IInf = Inf \<circ> Rep_upset"
 
 lemma us_ds: "us = Abs_upset \<circ> (`) \<partial> \<circ> Rep_downset \<circ> ds \<circ> (\<partial>::'a::ord_with_dual \<Rightarrow> 'a)" 
   unfolding us_def ds_def fun_eq_iff comp_def by (simp add: Abs_downset_inverse upset_to_downset2)
 
 lemma IInf_SSup: "IInf = \<partial> \<circ> SSup \<circ> Abs_downset \<circ> (`) (\<partial>::'a::complete_lattice_with_dual \<Rightarrow> 'a) \<circ> Rep_upset"
   unfolding IInf_def SSup_def fun_eq_iff comp_def
   by (metis (no_types, opaque_lifting) Abs_downset_inverse Rep_upset Sup_dual_def_var image_iff rangeI subset_dual upset_to_downset3)
 
 lemma us_IInf_inv: "us \<circ> IInf = (id::'a::complete_lattice_with_dual upset \<Rightarrow> 'a upset)"
   unfolding us_def IInf_def fun_eq_iff id_def comp_def
   by (metis (no_types, lifting) Inf_upset_id Rep_upset Rep_upset_inverse f_the_inv_into_f pointfree_idE upset_inj)
 
 lemma IInf_us_inv: "IInf \<circ> us = (id::'a::complete_lattice_with_dual \<Rightarrow> 'a)"
   unfolding us_def IInf_def fun_eq_iff id_def comp_def
   by (metis Abs_upset_inverse Sup_Inf_var Sup_atLeastAtMost Sup_dual_upset_var order_refl rangeI)
  
 instantiation upset :: (ord) order
 begin
   
 lift_definition less_eq_upset :: "'a upset \<Rightarrow> 'a upset \<Rightarrow> bool" is "(\<lambda>X Y. Rep_upset X \<supseteq> Rep_upset Y)" .
 
 lift_definition less_upset :: "'a upset \<Rightarrow> 'a upset \<Rightarrow> bool" is "(\<lambda>X Y. Rep_upset X \<supset> Rep_upset Y)" .
 
 instance
   by (intro_classes, transfer, simp_all add: less_le_not_le less_eq_upset.rep_eq Rep_upset_inject)
 
 end
   
 lemma us_iso: "x \<le> y \<Longrightarrow> us x \<le> us (y::'a::order_with_dual)"
   by (simp add: Abs_upset_inverse less_eq_upset.rep_eq upset_anti_iff us_def)
  
 lemma us_faithful: "us x \<le> us y \<Longrightarrow> x \<le> (y::'a::order_with_dual)"
   by (simp add: Abs_upset_inverse upset_faithful us_def less_eq_upset.rep_eq)
 
 lemma us_inj: "inj (us::'a::order_with_dual \<Rightarrow> 'a upset)"
   unfolding inj_def by (simp add: us_faithful dual_order.antisym)
 
 lemma us_surj: "surj (us::'a::order_with_dual \<Rightarrow> 'a upset)"
   unfolding surj_def by (metis Rep_upset Rep_upset_inverse comp_def image_iff us_def)
 
 lemma us_bij: "bij (us::'a::order_with_dual \<Rightarrow> 'a upset)"
   by (simp add: bij_def us_surj us_inj)
 
 lemma us_ord_iso: "ord_iso (us::'a::order_with_dual \<Rightarrow> 'a upset)"
   unfolding ord_iso_def 
   by (simp, metis (no_types, lifting) UNIV_I f_the_inv_into_f monoI us_iso us_bij us_faithful us_inj us_surj)
 
 definition map_us :: "('a::complete_lattice \<Rightarrow> 'b::complete_lattice) \<Rightarrow> ('a upset \<Rightarrow> 'b upset)" where
   "map_us f = us \<circ> f \<circ> IInf"
 
 lemma map_us_prop: "map_us f \<circ> (us::'a::complete_lattice_with_dual \<Rightarrow> 'a upset) = us \<circ> id f"
   unfolding map_us_def by (simp add: IInf_us_inv comp_assoc) 
 
 definition map_IInf :: "('a upset \<Rightarrow> 'b upset) \<Rightarrow> ('a::complete_lattice \<Rightarrow> 'b::complete_lattice)" where
   "map_IInf F = IInf \<circ> F \<circ> us"
 
 lemma map_IInf_prop: "(us::'a::complete_lattice_with_dual \<Rightarrow> 'a upset) \<circ> map_IInf F = id F \<circ> us"
 proof-
   have "us \<circ> map_IInf F = (us \<circ> IInf) \<circ> F \<circ> us"
     by (simp add: fun.map_comp map_IInf_def)
   thus ?thesis
     by (simp add: us_IInf_inv)
 qed
 
 lemma map_us_func1: "map_us id = (id::'a::complete_lattice_with_dual upset \<Rightarrow> 'a upset)"
   unfolding map_us_def fun_eq_iff comp_def us_def id_def IInf_def
   by (metis (no_types, lifting) Inf_upset_id Rep_upset Rep_upset_inverse image_iff pointfree_idE)
 
 lemma map_us_func2: 
   fixes f :: "'c::complete_lattice_with_dual \<Rightarrow> 'b::complete_lattice_with_dual"
   and g :: "'a::complete_lattice_with_dual \<Rightarrow> 'c"
   shows "map_us (f \<circ> g) = map_us f \<circ> map_us g"
   unfolding map_us_def fun_eq_iff comp_def us_def IInf_def
   by (metis Abs_upset_inverse Sup_Inf_var Sup_atLeastAtMost Sup_dual_upset_var order_refl rangeI)
 
 lemma map_IInf_func1: "map_IInf id = (id::'a::complete_lattice_with_dual \<Rightarrow> 'a)"
   unfolding map_IInf_def fun_eq_iff comp_def id_def us_def IInf_def by (simp add: Abs_upset_inverse pointfree_idE)
 
 lemma map_IInf_func2: 
   fixes F :: "'c::complete_lattice_with_dual upset \<Rightarrow> 'b::complete_lattice_with_dual upset"
   and G :: "'a::complete_lattice_with_dual upset \<Rightarrow> 'c upset"
   shows "map_IInf (F \<circ> G) = map_IInf F \<circ> map_IInf G"
   unfolding map_IInf_def fun_eq_iff comp_def id_def us_def
   by (metis comp_apply id_apply us_IInf_inv us_def)
 
 lemma map_IInf_map_us_inv: "map_IInf \<circ> map_us = (id::('a::complete_lattice_with_dual \<Rightarrow> 'b::complete_lattice_with_dual) \<Rightarrow> ('a \<Rightarrow> 'b))"
   unfolding map_IInf_def map_us_def IInf_def us_def id_def comp_def fun_eq_iff by (simp add: Abs_upset_inverse pointfree_idE)
 
 lemma map_us_map_IInf_inv: "map_us \<circ> map_IInf = (id::('a::complete_lattice_with_dual upset \<Rightarrow> 'b::complete_lattice_with_dual upset) \<Rightarrow> ('a upset \<Rightarrow> 'b upset))"
   unfolding map_IInf_def map_us_def IInf_def us_def id_def comp_def fun_eq_iff
   by (metis (no_types, lifting) Inf_upset_id Rep_upset Rep_upset_inverse image_iff pointfree_idE)
 
 lemma inj_map_us: "inj (map_us::('a::complete_lattice_with_dual \<Rightarrow> 'b::complete_lattice_with_dual) \<Rightarrow> ('a upset \<Rightarrow> 'b upset))"
   unfolding map_us_def us_def IInf_def inj_def comp_def fun_eq_iff
   by (metis (no_types, opaque_lifting) Abs_upset_inverse Inf_upset_id pointfree_idE rangeI)
 
 lemma inj_map_IInf: "inj (map_IInf::('a::complete_lattice_with_dual upset \<Rightarrow> 'b::complete_lattice_with_dual upset) \<Rightarrow> ('a \<Rightarrow> 'b))"
   unfolding map_IInf_def fun_eq_iff inj_def comp_def IInf_def us_def
   by (metis (no_types, opaque_lifting) Inf_upset_id Rep_upset Rep_upset_inverse image_iff pointfree_idE)
 
 lemma map_us_map_IInf_iff: 
   fixes g :: "'a::complete_lattice_with_dual \<Rightarrow> 'b::complete_lattice_with_dual" 
   shows "(f = map_us g) = (map_IInf f = g)"
   by (metis inj_eq inj_map_us map_us_map_IInf_inv pointfree_idE)
 
 lemma map_us_mono_pres: 
   fixes f :: "'a::complete_lattice_with_dual \<Rightarrow> 'b::complete_lattice_with_dual"
   shows "mono f \<Longrightarrow> mono (map_us f)"
   unfolding mono_def map_us_def comp_def us_def IInf_def
   by (metis Abs_upset_inverse Inf_superset_mono less_eq_upset.rep_eq rangeI upset_anti_iff)
 
 lemma map_IInf_mono_pres: 
   fixes F :: "'a::complete_lattice_with_dual upset \<Rightarrow> 'b::complete_lattice_with_dual upset"
   shows "mono F \<Longrightarrow> mono (map_IInf F)"
   unfolding mono_def map_IInf_def comp_def us_def IInf_def
   oops 
 
 lemma surj_map_us: "surj (map_us::('a::complete_lattice_with_dual \<Rightarrow> 'b::complete_lattice_with_dual) \<Rightarrow> ('a upset \<Rightarrow> 'b upset))"
   by (simp add: map_us_map_IInf_iff surj_def)
 
 lemma surj_map_IInf: "surj (map_IInf::('a::complete_lattice_with_dual upset \<Rightarrow> 'b::complete_lattice_with_dual upset) \<Rightarrow> ('a \<Rightarrow> 'b))"
   by (metis map_us_map_IInf_iff surjI)
 
 text \<open>Hence we have again an isomorphism --- or rather equivalence --- between categories. Here, however, duality is not consistently picked up.\<close>
 
 
 subsection \<open>Stone's Theorem in the Presence of Atoms\<close>
 
 text \<open>Atom-map is a boolean algebra morphism.\<close>
 
-context Lattices.boolean_algebra
+context boolean_algebra
 begin
 
 lemma atom_map_compl_pres: "atom_map (-x) = Collect atom - atom_map x"
 proof-
   {fix y
   have "(y \<in> atom_map (-x)) = (atom y \<and> y \<le> -x)"
     by (simp add: atom_map_def)
   also have "... = (atom y \<and> \<not>(y \<le> x))"
-    by (metis atom_sup_iff inf.orderE meet_shunt sup_compl_top top.ordering_top_axioms ordering_top.extremum)
+    by (metis atom_sup_iff inf.orderE inf_shunt sup_compl_top top.ordering_top_axioms ordering_top.extremum)
    also have "... = (y \<in> Collect atom - atom_map x)"
      using atom_map_def by auto
    finally have "(y \<in> atom_map (-x)) = (y \<in> Collect atom - atom_map x)".}
   thus ?thesis
     by blast
 qed
 
 lemma atom_map_sup_pres: "atom_map (x \<squnion> y) = atom_map x \<union> atom_map y"
 proof-
   {fix z
   have "(z \<in> atom_map (x \<squnion> y)) = (atom z \<and> z \<le> x \<squnion> y)"
     by (simp add: atom_map_def)
   also have "... = (atom z \<and> (z \<le> x \<or> z \<le> y))"
     using atom_sup_iff by auto
   also have "... = (z \<in> atom_map x \<union> atom_map y)"
     using atom_map_def by auto
   finally have "(z \<in> atom_map (x \<squnion> y)) = (z \<in> atom_map x \<union> atom_map y)"
     by blast}
   thus ?thesis
     by blast
 qed
 
 lemma atom_map_inf_pres: "atom_map (x \<sqinter> y) = atom_map x \<inter> atom_map y"
   by (smt Diff_Un atom_map_compl_pres atom_map_sup_pres compl_inf double_compl)
 
 lemma atom_map_minus_pres: "atom_map (x - y) = atom_map x - atom_map y"
   using atom_map_compl_pres atom_map_def diff_eq by auto
 
 end
 
 text \<open>The homomorphic images of boolean algebras under atom-map are boolean algebras 
 --- in fact powerset boolean algebras.\<close>
 
-instantiation atoms :: (Lattices.boolean_algebra) Lattices.boolean_algebra
+instantiation atoms :: (boolean_algebra) boolean_algebra
 begin
 
 lift_definition minus_atoms :: "'a atoms \<Rightarrow> 'a atoms \<Rightarrow> 'a atoms" is "\<lambda>x y. Abs_atoms (Rep_atoms x - Rep_atoms y)".
 
 lift_definition uminus_atoms :: "'a atoms \<Rightarrow> 'a atoms" is  "\<lambda>x. Abs_atoms (Collect atom - Rep_atoms x)".
 
 lift_definition bot_atoms :: "'a atoms" is "Abs_atoms {}".
 
 lift_definition sup_atoms ::  "'a atoms \<Rightarrow> 'a atoms \<Rightarrow> 'a atoms" is "\<lambda>x y. Abs_atoms (Rep_atoms x \<union> Rep_atoms y)".
 
 lift_definition top_atoms :: "'a atoms" is "Abs_atoms (Collect atom)".
 
 lift_definition inf_atoms ::  "'a atoms \<Rightarrow> 'a atoms \<Rightarrow> 'a atoms" is "\<lambda>x y. Abs_atoms (Rep_atoms x \<inter> Rep_atoms y)".
 
 lift_definition less_eq_atoms :: "'a atoms \<Rightarrow> 'a atoms \<Rightarrow> bool" is "(\<lambda>x y. Rep_atoms x \<subseteq> Rep_atoms y)".
 
 lift_definition less_atoms :: "'a atoms \<Rightarrow> 'a atoms \<Rightarrow> bool" is "(\<lambda>x y. Rep_atoms x \<subset> Rep_atoms y)".
 
 instance
   apply intro_classes
                  apply (transfer, simp add: less_le_not_le)
                 apply (transfer, simp)
                apply (transfer, blast)
               apply (simp add: Rep_atoms_inject less_eq_atoms.abs_eq)
              apply (transfer, smt Abs_atoms_inverse Rep_atoms atom_map_inf_pres image_iff inf_le1 rangeI)
             apply (transfer, smt Abs_atoms_inverse Rep_atoms atom_map_inf_pres image_iff inf_le2 rangeI)
            apply (transfer, smt Abs_atoms_inverse Rep_atoms atom_map_inf_pres image_iff le_iff_sup rangeI sup_inf_distrib1)
           apply (transfer, smt Abs_atoms_inverse Rep_atoms atom_map_sup_pres image_iff image_iff inf.orderE inf_sup_aci(6) le_iff_sup order_refl rangeI rangeI)
          apply (transfer, smt Abs_atoms_inverse Rep_atoms atom_map_sup_pres image_iff inf_sup_aci(6) le_iff_sup rangeI sup.left_commute sup.right_idem)
         apply (transfer, subst Abs_atoms_inverse, metis (no_types, lifting) Rep_atoms atom_map_sup_pres image_iff rangeI, simp)
        apply transfer using Abs_atoms_inverse atom_map_bot_pres apply blast
       apply (transfer, metis Abs_atoms_inverse Rep_atoms atom_map_compl_pres atom_map_top_pres diff_eq double_compl inf_le1 rangeE rangeI)
      apply (transfer, smt Abs_atoms_inverse Rep_atoms atom_map_inf_pres atom_map_sup_pres image_iff rangeI sup_inf_distrib1)
     apply (transfer, metis (no_types, opaque_lifting) Abs_atoms_inverse Diff_disjoint Rep_atoms atom_map_compl_pres rangeE rangeI)
    apply (transfer, smt Abs_atoms_inverse uminus_atoms.abs_eq Rep_atoms Un_Diff_cancel atom_map_compl_pres atom_map_inf_pres atom_map_minus_pres atom_map_sup_pres atom_map_top_pres diff_eq double_compl inf_compl_bot_right rangeE rangeI sup_commute sup_compl_top)
   by transfer (smt Abs_atoms_inverse Rep_atoms atom_map_compl_pres atom_map_inf_pres atom_map_minus_pres diff_eq rangeE rangeI)
 
 end
 
 text \<open>The homomorphism atom-map can then be restricted in its output type to the powerset boolean algebra.\<close>
 
 lemma at_map_bot_pres: "at_map \<bottom> = \<bottom>"
   by (simp add: at_map_def atom_map_bot_pres bot_atoms.transfer)
 
 lemma at_map_top_pres: "at_map \<top> = \<top>"
   by (simp add: at_map_def atom_map_top_pres top_atoms.transfer)
 
 lemma at_map_compl_pres: "at_map \<circ> uminus = uminus \<circ> at_map"
   unfolding fun_eq_iff by (simp add: Abs_atoms_inverse at_map_def atom_map_compl_pres uminus_atoms.abs_eq)
 
 lemma at_map_sup_pres: "at_map (x \<squnion> y) = at_map x \<squnion> at_map y"
   unfolding at_map_def comp_def by (metis (mono_tags, lifting) Abs_atoms_inverse atom_map_sup_pres rangeI sup_atoms.transfer)
 
 lemma at_map_inf_pres: "at_map (x \<sqinter> y) = at_map x \<sqinter> at_map y"
   unfolding at_map_def comp_def by (metis (mono_tags, lifting) Abs_atoms_inverse atom_map_inf_pres inf_atoms.transfer rangeI)
 
 lemma at_map_minus_pres: "at_map (x - y) = at_map x - at_map y"
   unfolding at_map_def comp_def by (simp add: Abs_atoms_inverse atom_map_minus_pres minus_atoms.abs_eq)
 
 
 context atomic_boolean_algebra
 begin
 
 text \<open>In atomic boolean algebras, atom-map is an embedding that maps atoms of the boolean algebra to 
 those of the powerset boolean algebra. Analogous properties hold for at-map.\<close>
 
 lemma inj_atom_map: "inj atom_map"
 proof-
   {fix x y ::'a
     assume "x \<noteq> y"
   hence "x \<sqinter> -y \<noteq> \<bottom> \<or> -x \<sqinter> y \<noteq> \<bottom>"
-    by (auto simp: meet_shunt) 
+    by (auto simp: inf_shunt) 
   hence "\<exists>z. atom z \<and> (z \<le> x \<sqinter> -y \<or> z \<le> -x \<sqinter> y)"
     using atomicity by blast
   hence "\<exists>z. atom z \<and> ((z \<in> atom_map x \<and> \<not>(z \<in> atom_map y)) \<or> (\<not>(z \<in> atom_map x) \<and> z \<in> atom_map y))"
-    unfolding atom_def atom_map_def by (clarsimp, metis diff_eq inf.orderE meet_shunt_var)
+    unfolding atom_def atom_map_def by (clarsimp, metis diff_eq inf.orderE diff_shunt_var)
   hence "atom_map x \<noteq> atom_map y"
     by blast}
   thus ?thesis
     by (meson injI)
 qed
 
 lemma atom_map_atom_pres: "atom x \<Longrightarrow> atom_map x = {x}"
   unfolding atom_def atom_map_def by (auto simp: bot_less dual_order.order_iff_strict)
 
 lemma atom_map_atom_pres2: "atom x \<Longrightarrow> atom (atom_map x)"
 proof-
   assume "atom x"
   hence "atom_map x = {x}"
     by (simp add: atom_map_atom_pres)
   thus "atom (atom_map x)"
     using bounded_lattice_class.atom_def by auto
 qed
 
 end
 
 lemma inj_at_map: "inj (at_map::'a::atomic_boolean_algebra \<Rightarrow> 'a atoms)"
   unfolding at_map_def comp_def by (metis (no_types, lifting) Abs_atoms_inverse inj_atom_map inj_def rangeI)
 
 lemma at_map_atom_pres: "atom (x::'a::atomic_boolean_algebra) \<Longrightarrow> at_map x = Abs_atoms {x}"
   unfolding at_map_def comp_def by (simp add: atom_map_atom_pres)
 
 lemma at_map_atom_pres2: "atom (x::'a::atomic_boolean_algebra) \<Longrightarrow> atom (at_map x)"
   unfolding at_map_def comp_def
   by (metis Abs_atoms_inverse atom_def atom_map_atom_pres2 atom_map_bot_pres bot_atoms.abs_eq less_atoms.abs_eq rangeI)
 
 text \<open>Homomorphic images of atomic boolean algebras under atom-map are therefore atomic (rather obviously).\<close>
 
 instance atoms :: (atomic_boolean_algebra) atomic_boolean_algebra
 proof intro_classes
   fix x::"'a atoms"
   assume "x \<noteq> \<bottom>"
   hence "\<exists>y. x = at_map y \<and> x \<noteq> \<bottom>"
     unfolding at_map_def comp_def by (metis Abs_atoms_cases rangeE)
   hence "\<exists>y. x = at_map y \<and> (\<exists>z. atom z \<and> z \<le> y)"
     using at_map_bot_pres atomicity by force
   hence "\<exists>y. x = at_map y \<and> (\<exists>z. atom (at_map z) \<and> at_map z \<le> at_map y)"
     by (metis at_map_atom_pres2 at_map_sup_pres sup.orderE sup_ge2)
   thus "\<exists>y. atom y \<and> y \<le> x"
     by fastforce
 qed
 
 context complete_boolean_algebra_alt
 begin
 
 text \<open>In complete boolean algebras, atom-map is surjective; more precisely it is the left inverse
 of Sup, at least for sets of atoms. Below, this statement is made more explicit for at-map.\<close>
 
 lemma surj_atom_map: "Y \<subseteq> Collect atom \<Longrightarrow> Y = atom_map (\<Squnion>Y)"
 proof
   assume "Y \<subseteq> Collect atom"
   thus "Y \<subseteq> atom_map (\<Squnion>Y)"
     using Sup_upper atom_map_def by force
 next
   assume "Y \<subseteq> Collect atom"
   hence a: "\<forall>y. y \<in> Y \<longrightarrow> atom y"
     by blast
   {fix z
   assume h: "z \<in> Collect atom - Y"
   hence "\<forall>y \<in> Y. y \<sqinter> z = \<bottom>"
-    by (metis DiffE a h atom_def dual_order.not_eq_order_implies_strict inf.absorb_iff2 inf_le2 meet_shunt mem_Collect_eq)
+    by (metis DiffE a h atom_def dual_order.not_eq_order_implies_strict inf.absorb_iff2 inf_le2 inf_shunt mem_Collect_eq)
   hence "\<Squnion>Y \<sqinter> z = \<bottom>"
-    using Sup_least meet_shunt by simp
+    using Sup_least inf_shunt by simp
   hence "z \<notin> atom_map (\<Squnion>Y)"
     using atom_map_bot_pres atom_map_def by force}
   thus  "atom_map (\<Squnion>Y) \<subseteq> Y"
     using atom_map_def by force
 qed
 
 text \<open>In this setting, atom-map is a complete boolean algebra morphism.\<close>
 
 lemma atom_map_Sup_pres: "atom_map (\<Squnion>X) = (\<Union>x \<in> X. atom_map x)"
 proof-
   {fix z
   have "(z \<in> atom_map (\<Squnion>X)) = (atom z \<and> z \<le> \<Squnion>X)"
     by (simp add: atom_map_def)
   also have "... = (atom z \<and> (\<exists>x \<in> X. z \<le> x))"
     using atom_Sup_iff by auto
   also have "... = (z \<in> (\<Union>x \<in> X. atom_map x))"
     using atom_map_def by auto
   finally have "(z \<in> atom_map (\<Squnion>X)) = (z \<in> (\<Union>x \<in> X. atom_map x))"
     by blast}
   thus ?thesis
     by blast
 qed
 
 lemma atom_map_Sup_pres_var: "atom_map \<circ> Sup = Sup \<circ> (`) atom_map"
   unfolding fun_eq_iff comp_def by (simp add: atom_map_Sup_pres) 
 
 text \<open>For Inf-preservation, it is important that Infs are restricted to homomorphic images; 
 hence they need to be pushed into the set of all atoms.\<close>
 
 lemma atom_map_Inf_pres: "atom_map (\<Sqinter>X) = Collect atom \<inter> (\<Inter>x \<in> X. atom_map x)"
 proof-
   have "atom_map (\<Sqinter>X) = atom_map (-(\<Squnion>x \<in> X. -x))"
     by (smt Collect_cong SUP_le_iff atom_map_def compl_le_compl_iff compl_le_swap1 le_Inf_iff)
   also have "... = Collect atom - atom_map (\<Squnion>x \<in> X. -x)"
     using atom_map_compl_pres by blast
   also have "... = Collect atom - (\<Union>x \<in> X. atom_map (-x))"  
     by (simp add: atom_map_Sup_pres)
   also have "... = Collect atom - (\<Union>x \<in> X. Collect atom - atom_map (x))" 
     using atom_map_compl_pres by blast
   also have "... = Collect atom \<inter> (\<Inter>x \<in> X. atom_map x)"
     by blast
   finally show ?thesis.
 qed
 
 end
 
 text \<open>It follows that homomorphic images of complete boolean algebras under atom-map form
 complete boolean algebras.\<close>
 
 instantiation atoms :: (complete_boolean_algebra_alt) complete_boolean_algebra_alt
 begin
 
 lift_definition Inf_atoms :: "'a::complete_boolean_algebra_alt atoms set \<Rightarrow> 'a::complete_boolean_algebra_alt atoms" is "\<lambda>X. Abs_atoms (Collect atom \<inter> Inter ((`) Rep_atoms X))".
 
 lift_definition  Sup_atoms :: "'a::complete_boolean_algebra_alt atoms set \<Rightarrow> 'a::complete_boolean_algebra_alt atoms" is "\<lambda>X. Abs_atoms (Union ((`) Rep_atoms X))".
 
 instance
   apply (intro_classes; transfer)
        apply (metis (no_types, opaque_lifting) Abs_atoms_inverse image_iff inf_le1 le_Inf_iff le_infI2 order_refl rangeI surj_atom_map)
       apply (metis (no_types, lifting) Abs_atoms_inverse Int_subset_iff Rep_atoms Sup_upper atom_map_atoms inf_le1 le_INF_iff rangeI surj_atom_map)
      apply (metis Abs_atoms_inverse Rep_atoms SUP_least SUP_upper Sup_upper atom_map_atoms rangeI surj_atom_map)
     apply (metis Abs_atoms_inverse Rep_atoms SUP_least Sup_upper atom_map_atoms rangeI surj_atom_map)
   by simp_all
 
 end
 
 text \<open>Once more, properties proved above can now be restricted to at-map.\<close>
 
 lemma  surj_at_map_var: "at_map \<circ> Sup \<circ> Rep_atoms = (id::'a::complete_boolean_algebra_alt atoms \<Rightarrow> 'a atoms)"
   unfolding at_map_def comp_def fun_eq_iff id_def by (metis Rep_atoms Rep_atoms_inverse Sup_upper atom_map_atoms surj_atom_map)
 
 lemma surj_at_map: "surj (at_map::'a::complete_boolean_algebra_alt \<Rightarrow> 'a atoms)"
   unfolding surj_def at_map_def comp_def by (metis Rep_atoms Rep_atoms_inverse image_iff)
 
 lemma at_map_Sup_pres: "at_map \<circ> Sup = Sup \<circ> (`) (at_map::'a::complete_boolean_algebra_alt \<Rightarrow> 'a atoms)"
   unfolding fun_eq_iff at_map_def comp_def atom_map_Sup_pres by (smt Abs_atoms_inverse Sup.SUP_cong Sup_atoms.transfer UN_extend_simps(10) rangeI)
 
 lemma at_map_Sup_pres_var: "at_map (\<Squnion>X) = (\<Squnion>(x::'a::complete_boolean_algebra_alt) \<in> X. (at_map x))"
   using at_map_Sup_pres comp_eq_elim by blast
 
 lemma at_map_Inf_pres: "at_map (\<Sqinter>X) = Abs_atoms (Collect atom \<sqinter> (\<Sqinter>x \<in> X. (Rep_atoms (at_map (x::'a::complete_boolean_algebra_alt)))))"
   unfolding at_map_def comp_def by (metis (no_types, lifting) Abs_atoms_inverse Sup.SUP_cong atom_map_Inf_pres rangeI)
 
 lemma at_map_Inf_pres_var: "at_map \<circ> Inf = Inf \<circ> (`) (at_map::'a::complete_boolean_algebra_alt \<Rightarrow> 'a atoms)"
   unfolding fun_eq_iff comp_def by (metis Inf_atoms.abs_eq at_map_Inf_pres image_image)
 
 text \<open>Finally, on complete atomic boolean algebras (CABAs), at-map is an isomorphism, that is, a bijection 
 that preserves the complete boolean algebra operations. Thus every CABA is isomorphic to a powerset boolean algebra
 and every powerset boolean algebra is a CABA. The bijective pair is given by at-map and Sup (defined on the powerset algebra).
 This theorem is a little version of Stone's theorem. In the general case, ultrafilters play the role of atoms.\<close>
 
 lemma "Sup \<circ> atom_map = (id::'a::complete_atomic_boolean_algebra \<Rightarrow> 'a)"
   unfolding fun_eq_iff comp_def id_def
   by (metis Union_upper atom_map_atoms inj_atom_map inj_def rangeI surj_atom_map)
 
 lemma inj_at_map_var: "Sup \<circ> Rep_atoms \<circ> at_map  = (id ::'a::complete_atomic_boolean_algebra \<Rightarrow> 'a)"
 
   unfolding at_map_def comp_def fun_eq_iff id_def
   by (metis Abs_atoms_inverse Union_upper atom_map_atoms inj_atom_map inj_def rangeI surj_atom_map)
 
 lemma bij_at_map: "bij (at_map::'a::complete_atomic_boolean_algebra \<Rightarrow> 'a atoms)"
   unfolding bij_def by (simp add: inj_at_map surj_at_map)
 
 instance atoms :: (complete_atomic_boolean_algebra) complete_atomic_boolean_algebra..
 
 text \<open>A full consideration of Stone duality is left for future work.\<close>
 
 (* Failed attempt to prove Tarski's fixpoint theorem: The problem is that we want to use mono, but this has two type parameters. It doesn't work inside of the one-type-parameter typedef.
 Yet isotonicity is needed to prove inhabitance of the type. I could develop a theory of isotone endos and prove the existence of 
 lfps and gfps, duplicating the more general facts for mono. But that's not the point. Because of this I see no direct way of proving
 Tarski's fixpoint theorem. Any way out?
 
 class complete_lattice_with_iso = complete_lattice +
   fixes f :: "'a \<Rightarrow> 'a"
 (*  assumes isof: "x \<le> y \<Longrightarrow> f x \<le> f y"*)
 
 typedef (overloaded) 'a Fix = "Fix (f::'a::complete_lattice_with_iso \<Rightarrow> 'a)" 
 
 
 setup_lifting type_definition_Fix
 
 *)
 
 end
diff --git a/thys/PSemigroupsConvolution/Binary_Modalities.thy b/thys/PSemigroupsConvolution/Binary_Modalities.thy
--- a/thys/PSemigroupsConvolution/Binary_Modalities.thy
+++ b/thys/PSemigroupsConvolution/Binary_Modalities.thy
@@ -1,438 +1,434 @@
 (* Title: Binary Modalities
    Author: Brijesh Dongol, Victor Gomes, Ian J Hayes, Georg Struth
    Maintainer: Victor Gomes <victor.gomes@cl.cam.ac.uk>
                Georg Struth <g.struth@sheffield.ac.uk> 
 *)
 
 section \<open>Binary Modalities and Relational Convolution\<close>
 
 theory Binary_Modalities
   imports Quantales
 
 begin
  
 subsection \<open>Auxiliary Properties\<close>
   
 lemma SUP_is_Sup: "(SUP f\<in>F. f y) = \<Squnion>{(f::'a \<Rightarrow> 'b::proto_near_quantale) y |f. f \<in> F}"
 proof (rule antisym)
   fix f::"'a \<Rightarrow> 'b::proto_near_quantale"
   have "f \<in> F \<Longrightarrow> f y \<in> {f y |f. f \<in> F}"
     by (simp add: Setcompr_eq_image)
   hence "f \<in> F \<Longrightarrow> f y \<le> \<Squnion>{f y |f. f \<in> F}"
     by (simp add: Sup_upper)
   thus "(SUP f\<in>F. f y) \<le> \<Squnion>{(f::'a \<Rightarrow> 'b::proto_near_quantale) y |f. f \<in> F}"
     by (simp add: Setcompr_eq_image)
 next 
   fix x
   have "x \<in> {f y |f. f \<in> F} \<Longrightarrow> x \<le> (SUP f\<in>F. f y) "
     using mk_disjoint_insert by force
   thus "Sup {(f::'a \<Rightarrow> 'b::proto_near_quantale) y |f. f \<in> F} \<le> (SUP f\<in>F. f y)"
     by (simp add: Setcompr_eq_image)
 qed
 
 lemma bmod_auxl: "{x \<cdot> g z |x. \<exists>f. x = f y \<and> f \<in> F} = {f y \<cdot> g z |f. f \<in> F}"
   by force
 
 lemma bmod_auxr: "{f y \<cdot> x |x. \<exists>g. x = g z \<and> g \<in> G} = {f y \<cdot> g z |g. g \<in> G}"
   by force
 
 lemma bmod_assoc_aux1: 
   "\<Squnion>{\<Squnion>{(f :: 'a \<Rightarrow> 'b::proto_near_quantale) u \<cdot> g v \<cdot> h w |u v. R y u v} |y w. R x y w} 
      = \<Squnion>{(f u \<cdot> g v) \<cdot> h w |u v y w. R y u v \<and> R x y w}"
   apply (rule antisym)
   apply (rule Sup_least, safe)
   apply (intro Sup_least Sup_upper, force)
   apply (rule Sup_least, safe)
   by (rule Sup_upper2, auto)+
   
 lemma bmod_assoc_aux2:   
   "\<Squnion>{\<Squnion>{(f::'a \<Rightarrow> 'b::proto_near_quantale) u \<cdot> g v \<cdot> h w |v w. R y v w} |u y. R x u y} 
      = \<Squnion>{f u \<cdot> g v \<cdot> h w |u v w y. R y v w \<and> R x u y}" 
   apply (rule antisym)
   apply (rule Sup_least, safe)
   apply (intro Sup_least Sup_upper, force)
   apply (rule Sup_least, safe)
   by (rule Sup_upper2, auto)+
     
 
 subsection \<open>Binary Modalities\<close>
   
 text \<open>Most of the development in the papers mentioned in the introduction generalises to proto-near-quantales. Binary modalities 
 are interesting for various substructural logics over ternary Kripke frames. They also arise, e.g., 
 as chop modalities in interval logics or as separation conjunction in separation logic. Binary modalities can be understood as a convolution
 operation parametrised by a ternary operation. Our development yields a 
 unifying framework.\<close>
   
 text \<open>We would prefer a notation that is more similar to our articles, that is, $f\ast_R g$, but we don' know how we could 
 index an infix operator by a variable in Isabelle.\<close>
 
 definition bmod_comp :: "('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'd::proto_near_quantale) \<Rightarrow> ('c \<Rightarrow> 'd) \<Rightarrow> 'a \<Rightarrow> 'd" ("\<otimes>") where 
   "\<otimes> R f g x = \<Squnion>{f y \<cdot> g z |y z. R x y z}"
 
 definition bmod_bres :: "('c \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'd::proto_near_quantale) \<Rightarrow> ('c \<Rightarrow> 'd) \<Rightarrow> 'a \<Rightarrow> 'd" ("\<lhd>") where 
   "\<lhd> R f g x = \<Sqinter>{(f y) \<rightarrow> (g z) |y z. R z y x}"
 
 definition bmod_fres :: "('b \<Rightarrow> 'a \<Rightarrow> 'c \<Rightarrow> bool)  \<Rightarrow> ('b \<Rightarrow> 'd::proto_near_quantale) \<Rightarrow> ('c \<Rightarrow> 'd) \<Rightarrow> 'a \<Rightarrow> 'd" ("\<rhd>")where 
   "\<rhd> R f g x = \<Sqinter>{(f y) \<leftarrow> (g z) |y z. R y x z}"
 
 lemma bmod_un_rel: "\<otimes> (R \<squnion> S) = \<otimes> R \<squnion> \<otimes> S"
   apply  (clarsimp simp: fun_eq_iff bmod_comp_def Sup_union_distrib[symmetric] Collect_disj_eq[symmetric])
   by (metis (no_types, lifting))
 
 lemma bmod_Un_rel: "\<otimes> (\<Squnion>\<R>) f g x = \<Squnion>{\<otimes> R f g x |R. R \<in> \<R>}"
   apply (simp add: bmod_comp_def)
   apply (rule antisym)
   apply (rule Sup_least, safe)
   apply (rule Sup_upper2, force)
   apply (rule Sup_upper, force)
   apply (rule Sup_least, safe)+
   by (metis (mono_tags, lifting) Sup_upper mem_Collect_eq)
     
 lemma bmod_sup_fun1: "\<otimes> R (f \<squnion> g) = \<otimes> R f \<squnion> \<otimes> R g"
   apply (clarsimp simp add: fun_eq_iff bmod_comp_def sup_distr)
   apply (rule antisym)
   apply (intro Sup_least, safe)
   apply (rule sup_least)
   apply (intro le_supI1 Sup_upper, force)
   apply (intro le_supI2 Sup_upper, force)
   apply (rule sup_least)
   by (intro Sup_least, safe, rule Sup_upper2, force, simp)+
 
 lemma bmod_Sup_fun1: "\<otimes> R (\<Squnion>\<F>) g x = \<Squnion>{\<otimes> R f g x |f. f \<in> \<F>}"
 proof -
   have "\<otimes> R (\<Squnion>{f. f \<in> \<F>}) g x = \<Squnion>{\<Squnion>{f y |f. f \<in> \<F>} \<cdot> g z |y z. R x y z}"
     by (simp add: bmod_comp_def SUP_is_Sup)
   also have "... = \<Squnion>{\<Squnion>{f y \<cdot> g z |f. f \<in> \<F>} |y z. R x y z}"
     by (simp add: Sup_distr bmod_auxl)
   also have "... = \<Squnion>{\<Squnion>{f y \<cdot> g z |y z. R x y z} |f. f \<in> \<F>}"
     apply (rule antisym)
     by ((rule Sup_least, safe)+ , (rule Sup_upper2, force, rule Sup_upper, force))+
   finally show ?thesis
     by (simp add: bmod_comp_def)
 qed
 
 lemma bmod_sup_fun2: "\<otimes> R (f::'a \<Rightarrow> 'b::weak_proto_quantale) (g \<squnion> h) = \<otimes> R f g \<squnion> \<otimes> R f h"
   apply (clarsimp simp add: fun_eq_iff bmod_comp_def sup_distl)
   apply (rule antisym)
   apply (intro Sup_least, safe)
   apply (rule sup_least)
   apply (intro le_supI1 Sup_upper, force)
   apply (intro le_supI2 Sup_upper, force)
   apply (rule sup_least)
   by (intro Sup_least, safe, rule Sup_upper2, force, simp)+
  
 lemma bmod_Sup_fun2_weak:
   assumes "\<G> \<noteq> {}"
   shows "\<otimes> R f (\<Squnion>\<G>) x = \<Squnion>{\<otimes> R f (g::'a \<Rightarrow> 'b::weak_proto_quantale) x |g. g \<in> \<G>}"
 proof -
   have set: "\<And>z. {g z |g::'a \<Rightarrow> 'b. g \<in> \<G>} \<noteq> {}"
     using assms by blast
   have "\<otimes> R f (\<Squnion>{g. g \<in> \<G>}) x = \<Squnion>{f y \<cdot> \<Squnion>{g z |g. g \<in> \<G>} |y z. R x y z}"
     by (simp add: bmod_comp_def SUP_is_Sup)
   also have "... = \<Squnion>{\<Squnion>{f y \<cdot> g z |g. g \<in> \<G>} |y z. R x y z}"
     by (simp add: weak_Sup_distl[OF set] bmod_auxr)           
   also have "... = \<Squnion>{\<Squnion>{f y \<cdot> g z |y z. R x y z} |g. g \<in> \<G>}"
     apply (rule antisym)
     by ((rule Sup_least, safe)+, (rule Sup_upper2, force, rule Sup_upper, force))+
   finally show ?thesis
     by (auto simp: bmod_comp_def)
 qed
   
 lemma bmod_Sup_fun2: "\<otimes> R f (\<Squnion>\<G>) x = \<Squnion>{\<otimes> R f (g::'a \<Rightarrow> 'b::proto_quantale) x |g. g \<in> \<G>}"
 proof -
   have "\<otimes> R f (\<Squnion>{g. g \<in> \<G>}) x = \<Squnion>{f y \<cdot> \<Squnion>{g z |g. g \<in> \<G>} |y z. R x y z}"
     by (simp add:  bmod_comp_def SUP_is_Sup)
   also have "... = \<Squnion>{\<Squnion>{f y \<cdot> g z |g. g \<in> \<G>} |y z. R x y z}"
     by (simp add: Sup_distl bmod_auxr)
   also have "... =  \<Squnion>{\<Squnion>{f y \<cdot> g z |y z. R x y z} |g. g \<in> \<G>}"
     apply (rule antisym)
     by ((rule Sup_least, safe)+, (rule Sup_upper2, force, rule Sup_upper, force))+
   finally show ?thesis
     by (auto simp: bmod_comp_def)
 qed
 
 lemma bmod_comp_bres_galois: "(\<forall>x. \<otimes> R f g x \<le> h x) \<longleftrightarrow> (\<forall>x. g x \<le> \<lhd> R f h x)" (* nitpick[expect=genuine] *)
   oops
     
 text \<open>The following Galois connection requires functions into proto-quantales.\<close>
     
 lemma bmod_comp_bres_galois: "(\<forall>x. \<otimes> R (f::'a \<Rightarrow> 'b::proto_quantale) g x \<le> h x) \<longleftrightarrow> (\<forall>x. g x \<le> \<lhd> R f h x)"
 proof -
   have "(\<forall>x. \<otimes> R f g x \<le> h x) \<longleftrightarrow> (\<forall>x y z. R x y z \<longrightarrow> (f y) \<cdot> (g z) \<le> h x)"
     apply (simp add: bmod_comp_def, standard, safe)
     apply (metis (mono_tags, lifting) CollectI Sup_le_iff)
     by (rule Sup_least, force)
   also have "... \<longleftrightarrow>  (\<forall>x y z. R x y z \<longrightarrow> g z \<le> (f y) \<rightarrow> (h x))"
     by (simp add: bres_galois)
   finally show ?thesis
     apply (simp add: fun_eq_iff bmod_bres_def)
     apply standard
     using le_Inf_iff apply fastforce
     by (metis (mono_tags, lifting) CollectI le_Inf_iff)
 qed 
 
 lemma bmod_comp_fres_galois: "(\<forall>x. \<otimes> R f g x \<le> h x) \<longleftrightarrow> (\<forall>x. f x \<le> \<rhd> R h g x)"
 proof -
   have "(\<forall>x. \<otimes> R f g x \<le> h x) \<longleftrightarrow> (\<forall>x y z. R x y z \<longrightarrow> (f y) \<cdot> (g z) \<le> h x)"
     apply (simp add: bmod_comp_def, standard, safe)
     apply (metis (mono_tags, lifting) CollectI Sup_le_iff)
     by (rule Sup_least, force)
   also have "... \<longleftrightarrow>  (\<forall>x y z. R x y z \<longrightarrow> f y \<le> (h x) \<leftarrow> (g z))"
     by (simp add: fres_galois)
   finally show ?thesis
     apply (simp add: bmod_fres_def fun_eq_iff)
     apply standard
     using le_Inf_iff apply fastforce
     by (metis (mono_tags, lifting) CollectI le_Inf_iff)
 qed 
   
 
 subsection \<open>Relational Convolution and Correspondence Theory\<close>
 
 text\<open>We now fix a ternary relation $\rho$ and can then hide the parameter in a convolution-style notation.\<close>
   
 class rel_magma = 
   fixes \<rho> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
 
 begin
   
 definition times_rel_fun :: "('a \<Rightarrow> 'b::proto_near_quantale) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" (infix "\<star>" 70) where
   "f \<star> g = \<otimes> \<rho> f g"
   
 lemma rel_fun_Sup_distl_weak: 
   "G \<noteq> {} \<Longrightarrow> (f::'a \<Rightarrow> 'b::weak_proto_quantale) \<star> \<Squnion>G = \<Squnion>{f \<star> g |g. g \<in> G}"
 proof- 
   fix f :: "'a \<Rightarrow> 'b" and G :: "('a \<Rightarrow> 'b) set" 
   assume a: "G \<noteq> {}"
   show "f \<star> \<Squnion>G = \<Squnion>{f \<star> g |g. g \<in> G}"
     apply (clarsimp simp: fun_eq_iff times_rel_fun_def bmod_Sup_fun2_weak[OF a])
     apply (rule antisym)
     apply (rule Sup_least, safe)
     apply (rule SUP_upper2, force+)
     apply (rule SUP_least, safe)
     by (rule Sup_upper2, force+)
 qed
     
 lemma rel_fun_Sup_distl: "(f::'a \<Rightarrow> 'b::proto_quantale) \<star> \<Squnion>G = \<Squnion>{f \<star> g |g. g \<in> G}"
   apply (clarsimp simp: fun_eq_iff times_rel_fun_def bmod_Sup_fun2)
   apply (rule antisym)
   apply (rule Sup_least, safe)
   apply (rule SUP_upper2, force+)
   apply (rule SUP_least, safe)
   by (rule Sup_upper2, force+)
 
 lemma rel_fun_Sup_distr: "\<Squnion>G \<star> (f::'a \<Rightarrow> 'b::proto_near_quantale) = \<Squnion>{g \<star> f |g. g \<in> G}"
   apply (clarsimp simp: fun_eq_iff times_rel_fun_def bmod_Sup_fun1)
   apply (rule antisym)
   apply (rule Sup_least, safe)
   apply (rule SUP_upper2, force+)
   apply (rule SUP_least, safe)
   by (rule Sup_upper2, force+)
 
 end
 
 class rel_semigroup = rel_magma +
   assumes rel_assoc: "(\<exists>y. \<rho> y u v \<and> \<rho> x y w) \<longleftrightarrow> (\<exists>z. \<rho> z v w \<and> \<rho> x u z)"
 
 begin
   
 text \<open>Nitpick produces counterexamples even for weak quantales. 
 Hence one cannot generally lift functions into weak quantales to weak quantales.\<close>
   
 lemma bmod_assoc: "\<otimes> \<rho> (\<otimes> \<rho> (f::'a \<Rightarrow> 'b::weak_quantale) g) h x = \<otimes> \<rho> f (\<otimes> \<rho> g h) x"
   (*nitpick[show_all,expect=genuine]*)
     oops
 
 lemma bmod_assoc: "\<otimes> \<rho> (\<otimes> \<rho> (f::'a \<Rightarrow> 'b::quantale) g) h x = \<otimes> \<rho> f (\<otimes> \<rho> g h) x"
 proof -
   have "\<otimes> \<rho> (\<otimes> \<rho> f g) h x = \<Squnion>{\<Squnion>{f u \<cdot> g v \<cdot> h z |u v. \<rho> y u v} |y z. \<rho> x y z}" 
     apply (simp add: bmod_comp_def Sup_distr)
     apply (rule antisym) 
     by (intro Sup_least Sup_upper, safe, intro exI conjI, simp_all, rule_tac f = Sup and g = Sup in cong, auto)+
   also have "... = \<Squnion>{f u \<cdot> g v \<cdot> h z |u v y z. \<rho> y u v \<and> \<rho> x y z}"
     by (simp add: bmod_assoc_aux1)
   also have "... = \<Squnion>{f u \<cdot> g v \<cdot> h z |u v z y. \<rho> y v z \<and> \<rho> x u y}" 
     apply (rule antisym)
     apply (rule Sup_least, rule Sup_upper, safe)
     using rel_assoc apply force
     apply (rule Sup_least, rule Sup_upper, safe)
     using rel_assoc by blast 
   also have "... = \<Squnion>{\<Squnion>{f u \<cdot> g v \<cdot> h z |v z. \<rho> y v z} |u y. \<rho> x u y}" 
     by (simp add: bmod_assoc_aux2)
   also have "... = \<Squnion>{f u \<cdot> \<Squnion>{g v \<cdot> h z |v z. \<rho> y v z} |u y. \<rho> x u y}" 
     apply (simp add: Sup_distl mult.assoc)
     apply (rule antisym)
     by (intro Sup_least Sup_upper, safe, intro exI conjI, simp_all, rule_tac f = Sup and g = Sup in cong, auto)+
   finally show ?thesis
     by (auto simp: bmod_comp_def)
 qed
 
 lemma rel_fun_assoc: "((f :: 'a \<Rightarrow> 'b::quantale) \<star> g) \<star> h = f \<star> (g \<star> h)"
   by (simp add: times_rel_fun_def fun_eq_iff bmod_assoc[symmetric])
 
 end
 
 lemma "\<otimes> R (\<otimes> R f f) f x = \<otimes> R f (\<otimes> R f f) x"
 (*apply (simp add: bmod_comp_def) nitpick[expect=genuine] *)
 oops
 
 class rel_monoid = rel_semigroup + 
   fixes \<xi> :: "'a set"
   assumes unitl_ex: "\<exists>e \<in> \<xi>. \<rho> x e x" 
   and unitr_ex: "\<exists>e \<in> \<xi>. \<rho> x x e"
   and unitl_eq: "e \<in> \<xi> \<Longrightarrow> \<rho> x e y \<Longrightarrow> x = y"
   and unitr_eq: "e \<in> \<xi> \<Longrightarrow> \<rho> x y e \<Longrightarrow> x = y"
 
 begin
 
 lemma xi_prop: "e1 \<in> \<xi> \<Longrightarrow> e2 \<in> \<xi> \<Longrightarrow> e1 \<noteq> e2 \<Longrightarrow> \<not> \<rho> x e1 e2 \<and> \<not> \<rho> x e2 e1"
   using unitl_eq unitr_eq by blast
 
 definition pid :: "'a  \<Rightarrow> 'b::unital_weak_quantale" ("\<delta>") where
   "\<delta> x = (if x \<in> \<xi> then 1 else \<bottom>)"
   
 text \<open>Due to the absence of right annihilation, the right unit law fails for functions into weak quantales.\<close>
   
 lemma bmod_onel: "\<otimes> \<rho> f (\<delta>::'a \<Rightarrow> 'b::unital_weak_quantale) x = f x" 
 (*nitpick[expect=genuine]*)
   oops
   
 text \<open>A unital quantale is required for this lifting.\<close>
     
 lemma bmod_onel: "\<otimes> \<rho> f (\<delta>::'a \<Rightarrow> 'b::unital_quantale) x = f x"
   apply (simp add: bmod_comp_def pid_def)
   apply (rule antisym)
   apply (rule Sup_least, safe)
   apply (simp add: bres_galois)
   using unitr_eq apply fastforce
   apply (metis bot.extremum)
   by (metis (mono_tags, lifting) Sup_upper mem_Collect_eq unitr_ex)
 
 lemma  bmod_oner: "\<otimes> \<rho> \<delta> f x = f x"
   apply (simp add: bmod_comp_def pid_def)
   apply (rule antisym)
   apply (rule Sup_least, safe)
   apply (simp add: fres_galois)
   using unitl_eq apply fastforce
   apply (metis bot.extremum)
   by (metis (mono_tags, lifting) Sup_upper mem_Collect_eq unitl_ex)
 
 lemma pid_unitl [simp]: "\<delta> \<star> f = f"
   by (simp add: fun_eq_iff times_rel_fun_def bmod_oner)
 
 lemma pid_unitr [simp]: "f \<star> (\<delta>::'a \<Rightarrow> 'b::unital_quantale) = f"
   by (simp add: fun_eq_iff times_rel_fun_def bmod_onel)
     
 lemma bmod_assoc_weak_aux: 
   "f u \<cdot> \<Squnion>{g v \<cdot> h z |v z. \<rho> y v z} = \<Squnion>{(f::'a \<Rightarrow> 'b::weak_quantale) u \<cdot> g v \<cdot> h z |v z. \<rho> y v z}"
   apply (subst weak_Sup_distl)
   using unitl_ex apply force
   apply simp
   by (metis (no_types, lifting) mult.assoc)
     
 lemma bmod_assoc_weak: "\<otimes> \<rho> (\<otimes> \<rho> (f::'a \<Rightarrow> 'b::weak_quantale) g) h x = \<otimes> \<rho> f (\<otimes> \<rho> g h) x"
 proof -
   have "\<otimes> \<rho> (\<otimes> \<rho> f g) h x = \<Squnion>{\<Squnion>{f u \<cdot> g v \<cdot> h z |u v. \<rho> y u v} |y z. \<rho> x y z}" 
     apply (simp add: bmod_comp_def Sup_distr)
     apply (rule antisym) 
     by (intro Sup_least Sup_upper, safe, intro exI conjI, simp_all, rule_tac f = Sup and g = Sup in cong, auto)+
   also have "... = \<Squnion>{f u \<cdot> g v \<cdot> h z |u v y z. \<rho> y u v \<and> \<rho> x y z}"
     by (simp add: bmod_assoc_aux1)
   also have "... = \<Squnion>{f u \<cdot> g v \<cdot> h z |u v z y. \<rho> y v z \<and> \<rho> x u y}" 
     apply (rule antisym)
     apply (rule Sup_least, rule Sup_upper, safe)
     using rel_assoc apply force
     apply (rule Sup_least, rule Sup_upper, safe)
     using rel_assoc by blast 
   also have "... = \<Squnion>{\<Squnion>{f u \<cdot> g v \<cdot> h z |v z. \<rho> y v z} |u y. \<rho> x u y}" 
     by (simp add: bmod_assoc_aux2)
   also have "... = \<Squnion>{f u \<cdot> \<Squnion>{g v \<cdot> h z |v z. \<rho> y v z} |u y. \<rho> x u y}"
     by (simp add: bmod_assoc_weak_aux) 
   finally show ?thesis
     by (auto simp: bmod_comp_def)
 qed
   
 lemma rel_fun_assoc_weak: "((f :: 'a \<Rightarrow> 'b::weak_quantale) \<star> g) \<star> h = f \<star> (g \<star> h)"
   by (simp add: times_rel_fun_def fun_eq_iff bmod_assoc_weak[symmetric])
 
 end
 
 lemma (in rel_semigroup) "\<exists>id. \<forall>f x. (\<otimes> \<rho> f id x = f x \<and> \<otimes> \<rho> id f x = f x)"
 (* apply (simp add: bmod_comp_def) nitpick [expect=genuine] *)
   oops
 
 class rel_ab_semigroup = rel_semigroup +
   assumes rel_comm: "\<rho> x y z \<Longrightarrow>  \<rho> x z y" 
 
 begin 
 
 lemma bmod_comm: "\<otimes> \<rho> (f::'a \<Rightarrow> 'b::ab_quantale) g = \<otimes> \<rho> g f"
   by (simp add: fun_eq_iff bmod_comp_def mult.commute, meson rel_comm)
 
 lemma "\<otimes> \<rho> f g = \<otimes> \<rho> g f" (* nitpick [expect=genuine] *)
 oops
 
 lemma bmod_bres_fres_eq: "\<lhd> \<rho> (f::'a \<Rightarrow> 'b::ab_quantale) g = \<rhd> \<rho> g f"
   by (simp add: fun_eq_iff bmod_bres_def bmod_fres_def bres_fres_eq, meson rel_comm)
 
 lemma rel_fun_comm: "(f :: 'a \<Rightarrow> 'b::ab_quantale) \<star> g = g \<star> f"
   by (simp add: times_rel_fun_def bmod_comm)
 
 end
 
 class rel_ab_monoid = rel_ab_semigroup + rel_monoid
   
 subsection \<open>Lifting to Function Spaces\<close>
 
 text \<open>We lift by interpretation, since we need sort instantiations to be
      used for functions from PAM's to Quantales. Both instantiations cannot be
      used in Isabelle at the same time.\<close>
   
 interpretation rel_fun: weak_proto_quantale Inf Sup inf less_eq less sup bot "top :: 'a::rel_magma \<Rightarrow> 'b::weak_proto_quantale" times_rel_fun
   by standard (simp_all add: rel_fun_Sup_distr rel_fun_Sup_distl_weak)
   
 interpretation rel_fun: proto_quantale Inf Sup inf less_eq less sup bot "top :: 'a::rel_magma \<Rightarrow> 'b::proto_quantale" times_rel_fun
   by standard (simp add: rel_fun_Sup_distl)
     
 text \<open>Nitpick shows that the lifting of weak quantales to weak quantales does not work for relational semigroups, because associativity fails.\<close>
   
 interpretation rel_fun: weak_quantale times_rel_fun Inf Sup inf less_eq less sup bot "top::'a::rel_semigroup \<Rightarrow> 'b::weak_quantale"
   (*apply standard  nitpick[expect=genuine]*)
   oops
     
 text \<open>Associativity is obtained when lifting from relational monoids, but the right unit law doesn't hold
  in the quantale on the function space, according to our above results. Hence the lifting results into a
 non-unital quantale, in which only the left unit law holds, as shown above. We don't provide a special class for 
 such quantales. Hence we lift only to non-unital quantales.\<close>
     
 interpretation rel_fun: weak_quantale times_rel_fun Inf Sup inf less_eq less sup bot "top::'a::rel_monoid \<Rightarrow> 'b::unital_weak_quantale"
   by standard (simp_all add: rel_fun_assoc_weak) 
 
 interpretation rel_fun2: quantale times_rel_fun Inf Sup inf less_eq less sup bot "top::'a::rel_semigroup \<Rightarrow> 'b::quantale" 
   by standard (simp add: rel_fun_assoc)
     
 interpretation rel_fun2: distrib_quantale Inf Sup inf less_eq less sup bot "top::'a::rel_semigroup \<Rightarrow> 'b::distrib_quantale" times_rel_fun ..
 
-interpretation rel_fun2: bool_quantale Inf Sup inf less_eq less sup bot "top::'a::rel_semigroup \<Rightarrow> 'b::bool_quantale" minus uminus times_rel_fun ..
+interpretation rel_fun2: bool_quantale minus uminus inf less_eq less sup bot \<open>top::'a::rel_semigroup \<Rightarrow> 'b::bool_quantale\<close> Inf Sup times_rel_fun ..
 
 interpretation rel_fun2: unital_quantale pid times_rel_fun Inf Sup inf less_eq less sup bot "top::'a::rel_monoid \<Rightarrow> 'b::unital_quantale" 
   by (standard; simp)
     
 interpretation rel_fun2: distrib_unital_quantale Inf Sup inf less_eq less sup bot "top::'a::rel_monoid \<Rightarrow> 'b::distrib_unital_quantale" pid times_rel_fun ..
 
-interpretation rel_fun2: bool_unital_quantale Inf Sup inf less_eq less sup bot "top::'a::rel_monoid \<Rightarrow> 'b::bool_unital_quantale" minus uminus pid times_rel_fun ..
+interpretation rel_fun2: bool_unital_quantale minus uminus inf less_eq less sup bot \<open>top::'a::rel_monoid \<Rightarrow> 'b::bool_unital_quantale\<close> Inf Sup pid times_rel_fun ..
 
 interpretation rel_fun: ab_quantale times_rel_fun Inf Sup inf less_eq less sup bot "top::'a::rel_ab_semigroup \<Rightarrow> 'b::ab_quantale"
   by standard (simp add: rel_fun_comm)
 
 interpretation rel_fun: ab_unital_quantale times_rel_fun Inf Sup inf less_eq less sup bot "top::'a::rel_ab_monoid \<Rightarrow> 'b::ab_unital_quantale" pid ..
 
 interpretation rel_fun2: distrib_ab_unital_quantale Inf Sup inf less_eq less sup bot "top::'a::rel_ab_monoid \<Rightarrow> 'b::distrib_ab_unital_quantale" times_rel_fun pid ..
 
 interpretation rel_fun2: bool_ab_unital_quantale times_rel_fun Inf Sup inf less_eq less sup bot "top::'a::rel_ab_monoid \<Rightarrow> 'b::bool_ab_unital_quantale" minus uminus pid ..
     
 end
-
-  
-  
-  
diff --git a/thys/Relation_Algebra/More_Boolean_Algebra.thy b/thys/Relation_Algebra/More_Boolean_Algebra.thy
--- a/thys/Relation_Algebra/More_Boolean_Algebra.thy
+++ b/thys/Relation_Algebra/More_Boolean_Algebra.thy
@@ -1,293 +1,293 @@
 (* Title:      Relation Algebra
    Author:     Alasdair Armstrong, Simon Foster, Georg Struth, Tjark Weber
    Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
                Tjark Weber <tjark.weber at it.uu.se>
 *)
 
 section \<open>(More) Boolean Algebra\<close>
 
 theory More_Boolean_Algebra
   imports Main
 begin
 
 subsection \<open>Laws of Boolean Algebra\<close>
 
 text \<open>The following laws of Boolean algebra support relational proofs. We
 might add laws for the binary minus since that would make certain theorems look
 more nicely. These are currently not so well supported.\<close>
 
-context Lattices.boolean_algebra
+context boolean_algebra
 begin
 
 no_notation
   times (infixl "\<cdot>" 70)
   and plus (infixl "+" 65)
   and Groups.zero_class.zero ("0")
   and Groups.one_class.one ("1")
 
 notation
   inf (infixl "\<cdot>" 70)
   and sup (infixl "+" 65)
   and bot ("0")
   and top ("1")
 
 lemma meet_assoc: "x \<cdot> (y \<cdot> z) = (x \<cdot> y) \<cdot> z"
 by (metis inf_assoc)
 
 lemma aux4 [simp]: "x \<cdot> y + x \<cdot> -y = x"
 by (metis inf_sup_distrib1 inf_top_right sup_compl_top)
 
 lemma aux4_comm [simp]: "x \<cdot> -y + x \<cdot> y = x"
 by (metis aux4 sup.commute)
 
 lemma aux6 [simp]: "(x + y) \<cdot> -x = y \<cdot> -x"
 by (metis inf_compl_bot inf_sup_distrib2 sup_bot_left)
 
 lemma aux6_var [simp]: "(-x + y) \<cdot> x = x \<cdot> y"
 by (metis compl_inf_bot inf_commute inf_sup_distrib2 sup_bot_left)
 
 lemma aux9 [simp]: "x + -x \<cdot> y = x + y"
 by (metis aux4 aux6 inf.commute inf_sup_absorb)
 
 lemma join_iso: "x \<le> y \<Longrightarrow> x + z \<le> y + z"
 by (metis eq_refl sup_mono)
 
 lemma join_isol: "x \<le> y \<Longrightarrow> z + x \<le> z + y"
 by (metis join_iso sup.commute)
 
 lemma join_double_iso: "x \<le> y \<Longrightarrow> w + x + z \<le> w + y + z"
 by (metis le_iff_inf sup_inf_distrib1 sup_inf_distrib2)
 
 lemma comp_anti: "x \<le> y \<longleftrightarrow> -y \<le> -x"
 by (metis compl_le_swap2 double_compl)
 
 lemma meet_iso: "x \<le> y \<Longrightarrow> x \<cdot> z \<le> y \<cdot> z"
 by (metis eq_refl inf_mono)
 
 lemma meet_isor: "x \<le> y \<Longrightarrow> z \<cdot> x \<le> z \<cdot> y"
 by (metis inf.commute meet_iso)
 
 lemma meet_double_iso: "x \<le> y \<Longrightarrow> w \<cdot> x \<cdot> z \<le> w \<cdot> y \<cdot> z"
 by (metis meet_iso meet_isor)
 
 lemma de_morgan_3 [simp]: "-(-x \<cdot> -y) = x + y"
 by (metis compl_sup double_compl)
 
 lemma subdist_2_var: "x + y \<cdot> z \<le> x + y"
 by (metis eq_refl inf_le1 sup_mono)
 
 lemma dist_alt: "\<lbrakk>x + z = y + z; x \<cdot> z = y \<cdot> z\<rbrakk> \<Longrightarrow> x = y"
 by (metis aux4 aux6 sup.commute)
 
 text \<open>Finally we prove the Galois connections for complementation.\<close>
 
 lemma galois_aux: "x \<cdot> y = 0 \<longleftrightarrow> x \<le> -y"
 by (metis aux6 compl_sup double_compl inf.commute le_iff_inf sup_bot_right sup_compl_top)
 
 lemma galois_aux2: "x \<cdot> -y = 0 \<longleftrightarrow> x \<le> y"
 by (metis double_compl galois_aux)
 
 lemma galois_1: "x \<cdot> -y \<le> z \<longleftrightarrow> x \<le> y + z"
 apply (rule iffI)
  apply (metis inf_le2 join_iso le_iff_sup le_supE join_isol aux4)
 apply (metis meet_iso aux6 le_infE)
 done
 
 lemma galois_2: "x \<le> y + -z \<longleftrightarrow> x \<cdot> z \<le> y"
 apply (rule iffI)
  apply (metis compl_sup double_compl galois_1 inf.commute)
 apply (metis inf.commute order_trans subdist_2_var aux4 join_iso)
 done
 
 lemma galois_aux3: "x + y = 1 \<longleftrightarrow> -x \<le> y"
 by (metis galois_1 inf_top_left top_unique)
 
 lemma galois_aux4: "-x + y = 1 \<longleftrightarrow> x \<le> y"
 by (metis double_compl galois_aux3)
 
 subsection \<open>Boolean Algebras with Operators\<close>
 
 text \<open>We follow J\'onsson and Tarski to define pairs of conjugate functions
 on Boolean algebras. We also consider material from Maddux's article. This
 gives rise to a Galois connection and the notion of Boolean algebras with
 operators.
 
 We do not explicitly define families of functions over Boolean algebras as a
 type class.
 
 This development should certainly be expanded do deal with complete Boolean
 algebras one the one hand and other lattices on the other hand.
 
 Boolean algebras with operators and their variants can be applied in various
 ways. The prime example are relation algebras. The modular laws, for instance,
 can be derived by instantiation. Other applications are antidomain semirings
 where modal operators satisfy conjugations and Galois connections, and algebras
 of predicate transformers.\<close>
 
 text\<open>We define conjugation as a predicate which holds if a pair of functions
 are conjugates.\<close>
 
 definition is_conjugation :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool"
   where "is_conjugation f g \<equiv> (\<forall>x y . f x \<cdot> y = 0 \<longleftrightarrow> x \<cdot> g y = 0)"
 
 text \<open>We now prove the standard lemmas. First we show that conjugation is
 symmetric and that conjugates are uniqely defined.\<close>
 
 lemma is_conjugation_sym: "is_conjugation f g \<longleftrightarrow> is_conjugation g f"
 by (metis inf.commute is_conjugation_def)
 
 lemma is_conjugation_unique: "\<lbrakk>is_conjugation f g; is_conjugation f h\<rbrakk> \<Longrightarrow> g = h"
 by (metis galois_aux inf.commute double_compl order.eq_iff ext is_conjugation_def)
 
 text \<open>Next we show that conjugates give rise to adjoints in a Galois
 connection.\<close>
 
 lemma conj_galois_1:
   assumes "is_conjugation f g"
   shows "f x \<le> y \<longleftrightarrow> x \<le> -g (-y)"
 by (metis assms is_conjugation_def double_compl galois_aux)
 
 lemma conj_galois_2:
   assumes "is_conjugation f g"
   shows "g x \<le> y \<longleftrightarrow> x \<le> -f (-y)"
 by (metis assms is_conjugation_sym conj_galois_1)
 
 text \<open>Now we prove some of the standard properties of adjoints and
 conjugates. In fact, conjugate functions even distribute over all existing
 suprema. We display the next proof in detail because it is elegant.\<close>
 
 lemma f_pre_additive:
   assumes "is_conjugation f g"
   shows "f (x + y) \<le> z \<longleftrightarrow> f x + f y \<le> z"
 proof -
   have "f (x + y) \<le> z \<longleftrightarrow> x + y \<le> -g (-z)"
     by (metis assms conj_galois_1)
   also have "... \<longleftrightarrow> x \<le> -g (-z) \<and> y \<le> -g (-z)"
     by (metis le_sup_iff)
   also have "... \<longleftrightarrow> f x \<le> z \<and> f y \<le> z"
     by (metis assms conj_galois_1)
   thus ?thesis
     by (metis le_sup_iff calculation)
 qed
 
 lemma f_additive:
   assumes "is_conjugation f g"
   shows "f (sup x y) = sup (f x) (f y)"
 by (metis assms order.eq_iff f_pre_additive)
 
 lemma g_pre_additive:
   assumes "is_conjugation f g"
   shows "g (sup x y) \<le> z \<longleftrightarrow> sup (g x) (g y) \<le> z"
 by (metis assms is_conjugation_sym f_pre_additive)
 
 lemma g_additive:
   assumes "is_conjugation f g"
   shows "g (sup x y) = sup (g x) (g y)"
 by (metis assms is_conjugation_sym f_additive)
 
 text \<open>Additivity of adjoints obviously implies their isotonicity.\<close>
 
 lemma f_iso:
   assumes "is_conjugation f g"
   shows "x \<le> y \<longrightarrow> f x \<le> f y"
 by (metis assms f_additive le_iff_sup)
 
 lemma g_iso:
   assumes "is_conjugation f g"
   shows "x \<le> y \<longrightarrow> g x \<le> g y"
 by (metis assms is_conjugation_sym f_iso)
 
 lemma f_subdist:
   assumes "is_conjugation f g"
   shows "f (x \<cdot> y) \<le> f x"
 by (metis assms f_iso inf_le1)
 
 lemma g_subdist:
   assumes "is_conjugation f g"
   shows "g (x \<cdot> y) \<le> g x"
 by (metis assms g_iso inf_le1)
 
 text \<open>Next we prove cancellation and strictness laws.\<close>
 
 lemma cancellation_1:
   assumes "is_conjugation f g"
   shows "f (-g x) \<le> -x"
 by (metis assms conj_galois_1 double_compl eq_refl)
 
 lemma cancellation_2:
   assumes "is_conjugation f g"
   shows "g (-f x) \<le> -x"
 by (metis assms is_conjugation_sym cancellation_1)
 
 lemma f_strict:
   assumes "is_conjugation f g"
   shows "f 0 = 0"
 by (metis assms inf.idem inf_bot_left is_conjugation_def)
 
 lemma g_strict:
   assumes "is_conjugation f g"
   shows "g 0 = 0"
 by (metis assms is_conjugation_sym f_strict)
 
 text \<open>The following variants of modular laws have more concrete counterparts
 in relation algebra.\<close>
 
 lemma modular_1_aux:
   assumes "is_conjugation f g"
   shows "f (x \<cdot> -g y) \<cdot> y = 0"
 by (metis assms galois_aux inf_le2 is_conjugation_def)
 
 lemma modular_2_aux:
   assumes "is_conjugation f g"
   shows "g (x \<cdot> -f y) \<cdot> y = 0"
 by (metis assms is_conjugation_sym modular_1_aux)
 
 lemma modular_1:
   assumes "is_conjugation f g"
   shows "f x \<cdot> y = f (x \<cdot> g y) \<cdot> y"
 proof -
   have "f x \<cdot> y = f (x \<cdot> g y + x \<cdot> -g y) \<cdot> y"
     by (metis aux4)
   hence "f x \<cdot> y = (f (x \<cdot> g y) + f (x \<cdot> -g y)) \<cdot> y"
     by (metis assms f_additive)
   hence "f x \<cdot> y = f (x \<cdot> g y) \<cdot> y + f (x \<cdot> -g y) \<cdot> y"
     by (metis inf.commute inf_sup_distrib1)
   thus ?thesis
     by (metis assms modular_1_aux sup_bot_right)
 qed
 
 lemma modular_2:
   assumes "is_conjugation f g"
   shows "g x \<cdot> y = g (x \<cdot> f y) \<cdot> y"
 by (metis assms is_conjugation_sym modular_1)
 
 lemma conjugate_eq_aux:
   "is_conjugation f g \<Longrightarrow> f (x \<cdot> -g y) \<le> f x \<cdot> -y"
   by (metis f_subdist galois_aux le_inf_iff modular_1_aux)
 
 lemma conjugate_eq:
   "is_conjugation f g \<longleftrightarrow> (\<forall>x y. f (x \<cdot> -g y) \<le> f x \<cdot> -y \<and> g (y \<cdot> -f x) \<le> g y \<cdot> -x)"
     (is "?l \<longleftrightarrow> ?r")
 proof
   assume ?l thus ?r
     by (metis is_conjugation_sym conjugate_eq_aux)
 next
   assume r: ?r
   have "\<forall>x y. f x \<cdot> y = 0 \<longrightarrow> x \<cdot> g y = 0"
     by (metis aux4 inf.left_commute inf_absorb1 inf_compl_bot inf_left_idem sup_bot_left r)
   hence "\<forall>x y. x \<cdot> g y = 0 \<longleftrightarrow> f x \<cdot> y = 0"
     by (metis aux4 inf.commute inf.left_commute inf_absorb1 inf_compl_bot sup_commute sup_inf_absorb r)
   thus "is_conjugation f g"
     by (metis is_conjugation_def)
 qed
 
 lemma conjugation_prop1: "is_conjugation f g \<Longrightarrow> f y \<cdot> z \<le> f (y \<cdot> g z)"
 by (metis le_infE modular_1 order_refl)
 
 lemma conjugation_prop2: "is_conjugation f g \<Longrightarrow> g z \<cdot> y \<le> g (z \<cdot> f y)"
 by (metis is_conjugation_sym conjugation_prop1)
 
 end (* boolean_algebra *)
 
 end
 
diff --git a/thys/Relation_Algebra/Relation_Algebra_Models.thy b/thys/Relation_Algebra/Relation_Algebra_Models.thy
--- a/thys/Relation_Algebra/Relation_Algebra_Models.thy
+++ b/thys/Relation_Algebra/Relation_Algebra_Models.thy
@@ -1,149 +1,149 @@
 (* Title:      Relation Algebra
    Author:     Alasdair Armstrong, Simon Foster, Georg Struth, Tjark Weber
    Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
                Tjark Weber <tjark.weber at it.uu.se>
 *)
 
 section \<open>Models of Relation Algebra\<close>
 
 theory Relation_Algebra_Models
   imports Relation_Algebra Kleene_Algebra.Inf_Matrix
 begin
 
 text \<open>We formalise two models. First we show the obvious: binary relations
 form a relation algebra. Then we show that infinite matrices (which we
 formalised originally for Kleene algebras) form models of relation algebra if
 we restrict their element type to @{typ bool}.\<close>
 
 subsection \<open>Binary Relations\<close>
 
 text \<open>Since Isabelle's libraries for binary relations are very well
 developed, the proof for this model is entirely trivial.\<close>
 
 interpretation rel_relation_algebra: relation_algebra "(-)" uminus "(\<inter>)" "(\<subseteq>)" "(\<subset>)" "(\<union>)" "{}" UNIV "(O)" Relation.converse Id
 by unfold_locales auto
 
 subsection \<open>Infinite Boolean Matrices\<close>
 
 text \<open>Next we consider infinite Boolean matrices. We define the maximal
 Boolean matrix (all of its entries are @{const True}), the converse or
 transpose of a matrix, the intersection of two Boolean matrices and the
 complement of a Boolean matrix.\<close>
 
 definition mat_top :: "('a, 'b, bool) matrix" ("\<tau>")
   where "\<tau> i j \<equiv> True"
 
 definition mat_transpose :: "('a, 'b, 'c) matrix \<Rightarrow> ('b, 'a, 'c) matrix" ("_\<^sup>\<dagger>" [101] 100)
   where "f\<^sup>\<dagger> \<equiv> (\<lambda>i j. f j i)"
 
 definition mat_inter :: "('a, 'b, bool) matrix \<Rightarrow> ('a, 'b, bool) matrix \<Rightarrow> ('a, 'b, bool) matrix" (infixl "\<sqinter>" 70)
   where "f \<sqinter> g \<equiv> (\<lambda>i j. f i j \<cdot> g i j)"
 
 definition mat_complement :: "('a, 'b, bool) matrix \<Rightarrow> ('a, 'b, bool) matrix" ("_\<^sup>c" [101] 100)
   where "f\<^sup>c = (\<lambda>i j. - f i j)"
 
 text \<open>Next we show that the Booleans form a dioid. We state this as an
 \emph{instantiation} result. The Kleene algebra files contain an
 \emph{interpretation} proof, which is not sufficient for our purposes.\<close>
 
 instantiation bool :: dioid_one_zero
 begin
 
   definition zero_bool_def:
     "zero_bool \<equiv> False"
 
   definition one_bool_def:
     "one_bool \<equiv> True"
 
   definition times_bool_def:
     "times_bool \<equiv> (\<and>)"
 
   definition plus_bool_def:
     "plus_bool \<equiv> (\<or>)"
 
   instance
   by standard (auto simp: plus_bool_def times_bool_def one_bool_def zero_bool_def)
 
 end
 
 text \<open>We now show that infinite Boolean matrices form a Boolean algebra.\<close>
 
 lemma le_funI2: "(\<And>i j. f i j \<le> g i j) \<Longrightarrow> f \<le> g"
 by (metis le_funI)
 
-interpretation matrix_ba: Lattices.boolean_algebra "\<lambda>f g. f \<sqinter> g\<^sup>c" mat_complement "(\<sqinter>)" "(\<le>)" "(<)" mat_add mat_zero mat_top
+interpretation matrix_ba: boolean_algebra "\<lambda>f g. f \<sqinter> g\<^sup>c" mat_complement "(\<sqinter>)" "(\<le>)" "(<)" mat_add mat_zero mat_top
 by standard (force intro!: le_funI simp: mat_inter_def plus_bool_def mat_add_def mat_zero_def zero_bool_def mat_top_def mat_complement_def)+
 
 text \<open>We continue working towards the main result of this section, that
 infinite Boolean matrices form a relation algebra.\<close>
 
 lemma mat_mult_var: "(f \<otimes> g) = (\<lambda>i j. \<Sum> {(f i k) * (g k j) | k. k \<in> UNIV})"
 by (rule ext)+ (simp add: mat_mult_def)
 
 text \<open>The following fact is related to proving the last relation algebra
 axiom in the matrix model. It is more complicated than necessary since finite
 infima are not well developed in Isabelle. Instead we translate properties of
 finite infima into properties of finite suprema by using Boolean algebra. For
 finite suprema we have developed special-purpose theorems in the Kleene algebra
 files.\<close>
 
 lemma mat_res_pointwise:
   fixes i j :: "'a::finite"
     and x :: "('a, 'a, bool) matrix"
   shows "(x\<^sup>\<dagger> \<otimes> (x \<otimes> y)\<^sup>c) i j \<le> (y\<^sup>c) i j"
 proof -
   have "\<Sum>{(x\<^sup>\<dagger>) i k \<and> ((x \<otimes> y)\<^sup>c) k j |k. k \<in> UNIV} \<le> (y\<^sup>c) i j \<longleftrightarrow> (\<forall>k. ((x\<^sup>\<dagger>) i k \<and> ((x \<otimes> y)\<^sup>c) k j) \<le> (y\<^sup>c) i j)"
     by (subst sum_sup) auto
   also have "\<dots> \<longleftrightarrow> (\<forall>k. ((x\<^sup>\<dagger>) i k \<and> - (x \<otimes> y) k j) \<le> (y\<^sup>c) i j)"
     by (simp only: mat_complement_def)
   also have "\<dots> \<longleftrightarrow> (\<forall>k. (x\<^sup>\<dagger>) i k \<le> ((y\<^sup>c) i j \<or> (x \<otimes> y) k j))"
     by auto
   also have "\<dots> \<longleftrightarrow> (\<forall>k. (x\<^sup>\<dagger>) i k \<le> (- y i j \<or> (x \<otimes> y) k j))"
     by (simp only: mat_complement_def)
   also have "\<dots> \<longleftrightarrow> (\<forall>k. ((x\<^sup>\<dagger>) i k \<and> y i j) \<le> (x \<otimes> y) k j)"
     by auto
   also have "\<dots> \<longleftrightarrow> (\<forall>k. (x k i \<and> y i j) \<le> (x \<otimes> y) k j)"
     by (simp add: mat_transpose_def)
   also have "\<dots> \<longleftrightarrow> (\<forall>k. (x k i \<and> y i j) \<le> \<Sum>{x k l \<and> y l j |l. l \<in> UNIV})"
     by (simp add: mat_mult_def times_bool_def)
   also have "\<dots> \<longleftrightarrow> (\<forall>k. \<Sum>{x k i \<and> y i j} \<le> \<Sum>{x k l \<and> y l j |l. l \<in> UNIV})"
     by simp
   also have "\<dots> \<longleftrightarrow> True"
     by (intro iffI TrueI allI sum_intro[rule_format]) auto
   moreover have "(x\<^sup>\<dagger> \<otimes> (x \<otimes> y)\<^sup>c) i j = \<Sum>{(x\<^sup>\<dagger>) i k \<and> ((x \<otimes> y)\<^sup>c) k j |k. k \<in> UNIV}"
     by (subst mat_mult_def) (simp add: times_bool_def)
   ultimately show ?thesis
     by auto
 qed
 
 text \<open>Finally the main result of this section.\<close>
 
 interpretation matrix_ra: relation_algebra "\<lambda>f g. f \<sqinter> g\<^sup>c" mat_complement "(\<sqinter>)" "(\<le>)" "(<)" "(\<oplus>)" "\<lambda>i j. False" \<tau> "(\<otimes>)" mat_transpose \<epsilon>
 proof
   fix x y z :: "'a::finite \<Rightarrow> 'a \<Rightarrow> bool"
   show "(\<lambda>(i::'a) j::'a. False) \<le> x"
     by (metis predicate2I)
   show "x \<sqinter> x\<^sup>c = (\<lambda>i j. False)"
     by (metis matrix_ba.bot.extremum matrix_ba.inf_compl_bot rev_predicate2D)
   show "x \<oplus> x\<^sup>c = \<tau>"
     by (fact matrix_ba.sup_compl_top)
   show "x \<sqinter> y\<^sup>c = x \<sqinter> y\<^sup>c"
     by (fact refl)
   show "x \<otimes> y \<otimes> z = x \<otimes> (y \<otimes> z)"
     by (metis mat_mult_assoc)
   show "x \<otimes> \<epsilon> = x"
     by (fact mat_oner)
   show "x \<oplus> y \<otimes> z = (x \<otimes> z) \<oplus> (y \<otimes> z)"
     by (fact mat_distr)
   show "(x\<^sup>\<dagger>)\<^sup>\<dagger> = x"
     by (simp add: mat_transpose_def)
   show "(x \<oplus> y)\<^sup>\<dagger> = x\<^sup>\<dagger> \<oplus> y\<^sup>\<dagger>"
     by (simp add: mat_transpose_def mat_add_def)
   show "(x \<otimes> y)\<^sup>\<dagger> = y\<^sup>\<dagger> \<otimes> x\<^sup>\<dagger>"
     by (simp add: mat_transpose_def mat_mult_var times_bool_def conj_commute)
   show "x\<^sup>\<dagger> \<otimes> (x \<otimes> y)\<^sup>c \<le> y\<^sup>c"
     by (metis le_funI2 mat_res_pointwise)
 qed
 
 end
 
diff --git a/thys/Residuated_Lattices/Residuated_Boolean_Algebras.thy b/thys/Residuated_Lattices/Residuated_Boolean_Algebras.thy
--- a/thys/Residuated_Lattices/Residuated_Boolean_Algebras.thy
+++ b/thys/Residuated_Lattices/Residuated_Boolean_Algebras.thy
@@ -1,665 +1,665 @@
 (* Title:      Residuated Boolean Algebras
    Author:     Victor Gomes <vborgesferreiragomes1 at sheffield.ac.uk>
    Maintainer: Georg Struth <g.struth@sheffield.ac.uk> 
 *)
 
 section \<open>Residuated Boolean Algebras\<close>
 
 theory Residuated_Boolean_Algebras
   imports Residuated_Lattices
 begin
 
 subsection \<open>Conjugation on Boolean Algebras\<close>
 
 text \<open>
   Similarly, as in the previous section, we define the conjugation for
   arbitrary residuated functions on boolean algebras.
 \<close>
 
-context Lattices.boolean_algebra
+context boolean_algebra
 begin
 
 lemma inf_bot_iff_le: "x \<sqinter> y = \<bottom> \<longleftrightarrow> x \<le> -y"
   by (metis le_iff_inf inf_sup_distrib1 inf_top_right sup_bot.left_neutral sup_compl_top compl_inf_bot inf.assoc inf_bot_right)
 
 lemma le_iff_inf_bot: "x \<le> y \<longleftrightarrow> x \<sqinter> -y = \<bottom>"
   by (metis inf_bot_iff_le compl_le_compl_iff inf_commute)
   
 lemma indirect_eq: "(\<And>z. x \<le> z \<longleftrightarrow> y \<le> z) \<Longrightarrow> x = y"
   by (metis order.eq_iff)
 
 text \<open>
   Let $B$ be a boolean algebra. The maps $f$ and $g$ on $B$ are
   a pair of conjugates if and only if for all $x, y \in B$,
   $f(x) \sqcap y = \bot \Leftrightarrow x \sqcap g(t) = \bot$.
 \<close>
   
 definition conjugation_pair :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool" where
   "conjugation_pair f g \<equiv> \<forall>x y. f(x) \<sqinter> y = \<bottom> \<longleftrightarrow> x \<sqinter> g(y) = \<bottom>"
 
 lemma conjugation_pair_commute: "conjugation_pair f g \<Longrightarrow> conjugation_pair g f"
   by (auto simp: conjugation_pair_def inf_commute)
   
 lemma conjugate_iff_residuated: "conjugation_pair f g = residuated_pair f (\<lambda>x. -g(-x))"
   apply (clarsimp simp: conjugation_pair_def residuated_pair_def inf_bot_iff_le)
   by (metis double_compl)
 
 lemma conjugate_residuated: "conjugation_pair f g \<Longrightarrow> residuated_pair f (\<lambda>x. -g(-x))"
   by (metis conjugate_iff_residuated)
   
 lemma residuated_iff_conjugate: "residuated_pair f g = conjugation_pair f (\<lambda>x. -g(-x))"
   apply (clarsimp simp: conjugation_pair_def residuated_pair_def inf_bot_iff_le)
   by (metis double_compl)
 
 text \<open>
   A map $f$ has a conjugate pair if and only if it is residuated.
 \<close>
   
 lemma conj_residuatedI1: "\<exists>g. conjugation_pair f g \<Longrightarrow> residuated f"
   by (metis conjugate_iff_residuated residuated_def)
   
 lemma conj_residuatedI2: "\<exists>g. conjugation_pair g f \<Longrightarrow> residuated f"
   by (metis conj_residuatedI1 conjugation_pair_commute)
   
 lemma exist_conjugateI[intro]: "residuated f \<Longrightarrow> \<exists>g. conjugation_pair f g"
   by (metis residuated_def residuated_iff_conjugate)
   
 lemma exist_conjugateI2[intro]: "residuated f \<Longrightarrow> \<exists>g. conjugation_pair g f"
   by (metis exist_conjugateI conjugation_pair_commute)
 
 text \<open>
   The conjugate of a residuated function $f$ is unique.
 \<close>
 
 lemma unique_conjugate[intro]: "residuated f \<Longrightarrow> \<exists>!g. conjugation_pair f g"
 proof - 
   {
     fix g h x assume "conjugation_pair f g" and "conjugation_pair f h"
     hence "g = h"
       apply (unfold conjugation_pair_def)
       apply (rule ext)
       apply (rule order.antisym)
       by (metis le_iff_inf_bot inf_commute inf_compl_bot)+
   } 
   moreover assume "residuated f"
   ultimately show ?thesis by force
 qed
   
 lemma unique_conjugate2[intro]: "residuated f \<Longrightarrow> \<exists>!g. conjugation_pair g f"
   by (metis unique_conjugate conjugation_pair_commute)
 
 text \<open>
   Since the conjugate of a residuated map is unique, we define a
   conjugate operation.
 \<close>
   
 definition conjugate :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)" where
   "conjugate f \<equiv> THE g. conjugation_pair g f"
 
 lemma conjugate_iff_def: "residuated f \<Longrightarrow> f(x) \<sqinter> y = \<bottom> \<longleftrightarrow> x \<sqinter> conjugate f y = \<bottom>"
   apply (clarsimp simp: conjugate_def dest!: unique_conjugate)
   apply (subgoal_tac "(THE g. conjugation_pair g f) = g")
   apply (clarsimp simp add: conjugation_pair_def)
   apply (rule the1_equality)
   by (auto intro: conjugation_pair_commute)
     
 lemma conjugateI1: "residuated f \<Longrightarrow> f(x) \<sqinter> y = \<bottom> \<Longrightarrow> x \<sqinter> conjugate f y = \<bottom>"
   by (metis conjugate_iff_def)
   
 lemma conjugateI2: "residuated f \<Longrightarrow> x \<sqinter> conjugate f y = \<bottom> \<Longrightarrow> f(x) \<sqinter> y = \<bottom>"
   by (metis conjugate_iff_def)
 
 text \<open>
   Few more lemmas about conjugation follow.
 \<close>
   
 lemma residuated_conj1: "residuated f \<Longrightarrow> conjugation_pair f (conjugate f)"
   using conjugateI1 conjugateI2 conjugation_pair_def by auto
   
 lemma residuated_conj2: "residuated f \<Longrightarrow> conjugation_pair (conjugate f) f"
   using conjugateI1 conjugateI2 conjugation_pair_def inf_commute by auto
   
 lemma conj_residuated: "residuated f \<Longrightarrow> residuated (conjugate f)"
   by (force dest!: residuated_conj2 intro: conj_residuatedI1)
   
 lemma conj_involution: "residuated f \<Longrightarrow> conjugate (conjugate f) = f"
   by (metis conj_residuated residuated_conj1 residuated_conj2 unique_conjugate)
   
 lemma residual_conj_eq: "residuated f \<Longrightarrow> residual (conjugate f) = (\<lambda>x. -f(-x))"
   apply (unfold residual_def)
   apply (rule the1_equality)
   apply (rule residual_unique)
   apply (auto intro: conj_residuated conjugate_residuated residuated_conj2)
 done
   
 lemma residual_conj_eq_ext: "residuated f \<Longrightarrow> residual (conjugate f) x = -f(-x)"
   by (metis residual_conj_eq)
   
 lemma conj_iso: "residuated f \<Longrightarrow> x \<le> y \<Longrightarrow> conjugate f x \<le> conjugate f y"
   by (metis conj_residuated res_iso)
   
 lemma conjugate_strict: "residuated f \<Longrightarrow> conjugate f \<bottom> = \<bottom>"
   by (metis conj_residuated residuated_strict)
 
 lemma conjugate_sup: "residuated f \<Longrightarrow> conjugate f (x \<squnion> y) = conjugate f x \<squnion> conjugate f y"
   by (metis conj_residuated residuated_sup)
 
 lemma conjugate_subinf: "residuated f \<Longrightarrow> conjugate f (x \<sqinter> y) \<le> conjugate f x \<sqinter> conjugate f y"
   by (auto simp: conj_iso)
  
 text \<open>
   Next we prove some lemmas from Maddux's article. Similar lemmas have been proved in AFP entry
   for relation algebras. They should be consolidated in the future.
 \<close>
 
 lemma maddux1: "residuated f \<Longrightarrow> f(x \<sqinter> - conjugate f(y)) \<le> f(x) \<sqinter> -y"
 proof -
   assume assm: "residuated f"
   hence "f(x \<sqinter> - conjugate f(y)) \<le> f x"
     by (metis inf_le1 res_iso)
   moreover have "f(x \<sqinter> - conjugate f (y)) \<sqinter> y = \<bottom>"
     by (metis assm conjugateI2 inf_bot_iff_le inf_le2)
   ultimately show ?thesis
     by (metis inf_bot_iff_le le_inf_iff)
 qed
 
 lemma maddux1': "residuated f \<Longrightarrow> conjugate f(x \<sqinter> -f(y)) \<le> conjugate f(x) \<sqinter> -y"
   by (metis conj_involution conj_residuated maddux1)
   
 lemma maddux2: "residuated f \<Longrightarrow> f(x) \<sqinter> y \<le> f(x \<sqinter> conjugate f y)"
 proof -
   assume resf: "residuated f"
   obtain z where z_def: "z = f(x \<sqinter> conjugate f y)" by auto
   hence "f(x \<sqinter> conjugate f y) \<sqinter> -z = \<bottom>"
     by (metis inf_compl_bot)
   hence "x \<sqinter> conjugate f y \<sqinter> conjugate f (-z) = \<bottom>"
     by (metis conjugate_iff_def resf)
   hence "x \<sqinter> conjugate f (y \<sqinter> -z) = \<bottom>"
     apply (subgoal_tac "conjugate f (y \<sqinter> -z) \<le> conjugate f y \<sqinter> conjugate f (-z)")
     apply (metis (no_types, opaque_lifting) dual_order.trans inf.commute inf_bot_iff_le inf_left_commute)
     by (metis conj_iso inf_le2 inf_top.left_neutral le_inf_iff resf)
   hence "f(x) \<sqinter> y \<sqinter> -z = \<bottom>"
     by (metis conjugateI2 inf.assoc resf)
   thus ?thesis
     by (metis double_compl inf_bot_iff_le z_def)
 qed
 
 lemma maddux2': "residuated f \<Longrightarrow> conjugate f(x) \<sqinter> y \<le> conjugate f(x \<sqinter> f y)"
   by (metis conj_involution conj_residuated maddux2)
   
 lemma residuated_conjugate_ineq: "residuated f \<Longrightarrow> conjugate f x \<le> y \<longleftrightarrow> x \<le> -f(-y)"
   by (metis conj_residuated residual_galois residual_conj_eq)
 
 lemma residuated_comp_closed: "residuated f \<Longrightarrow> residuated g \<Longrightarrow> residuated (f o g)"
   by (auto simp add: residuated_def residuated_pair_def)
   
 lemma conjugate_comp: "residuated f \<Longrightarrow> residuated g \<Longrightarrow> conjugate (f o g) = conjugate g o conjugate f"
 proof (rule ext, rule indirect_eq)
   fix x y
   assume assms: "residuated f" "residuated g" 
   have "conjugate (f o g) x \<le> y \<longleftrightarrow> x \<le> -f(g(-y))"
     apply (subst residuated_conjugate_ineq)
     using assms by (auto intro!: residuated_comp_closed)
   also have "... \<longleftrightarrow> conjugate g (conjugate f x) \<le> y"
     using assms by (simp add: residuated_conjugate_ineq)
   finally show "(conjugate (f \<circ> g) x \<le> y) = ((conjugate g \<circ> conjugate f) x \<le> y)"   
     by auto
 qed 
 
 lemma conjugate_comp_ext: "residuated f \<Longrightarrow> residuated g \<Longrightarrow> conjugate (\<lambda>x. f (g x)) x = conjugate g (conjugate f x)"
   using conjugate_comp by (simp add: comp_def)
   
 end (* boolean_algebra *)
 
 context complete_boolean_algebra begin
 
 text \<open>
   On a complete boolean algebra, it is possible to give an explicit
   definition of conjugation.
 \<close>
 
 lemma conjugate_eq: "residuated f \<Longrightarrow> conjugate f y = \<Sqinter>{x. y \<le> -f(-x)}"
 proof -
   assume assm: "residuated f" obtain g where g_def: "g = conjugate f" by auto
   have "g y = \<Sqinter>{x. x \<ge> g y}"
     by (auto intro!: order.antisym Inf_lower Inf_greatest)
   also have "... = \<Sqinter>{x. -x \<sqinter> g y = \<bottom>}"
     by (simp add: inf_bot_iff_le)
   also have "... = \<Sqinter>{x. f(-x) \<sqinter> y = \<bottom>}"
     by (metis conjugate_iff_def assm g_def)
   finally show ?thesis
     by (simp add: g_def le_iff_inf_bot inf_commute)
 qed
 
 end (* complete_boolean_algebra *)
 
 subsection \<open>Residuated Boolean Structures\<close>
 
 text \<open>
   In this section, we present various residuated structures based on
   boolean algebras.
   The left and right conjugation of the multiplicative operation is
   defined, and a number of facts is derived.
 \<close>
 
 class residuated_boolean_algebra = boolean_algebra + residuated_pogroupoid
 begin
 
 subclass residuated_lgroupoid ..
 
 definition conjugate_l :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<lhd>" 60) where
   "x \<lhd> y \<equiv> -(-x \<leftarrow> y)"
 
 definition conjugate_r :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<rhd>" 60) where
   "x \<rhd> y \<equiv> -(x \<rightarrow> -y)"
   
 lemma residual_conjugate_r: "x \<rightarrow> y = -(x \<rhd> -y)"
   by (metis conjugate_r_def double_compl)
   
 lemma residual_conjugate_l: "x \<leftarrow> y = -(-x \<lhd> y)"
   by (metis conjugate_l_def double_compl)
   
 lemma conjugation_multl: "x\<cdot>y \<sqinter> z = \<bottom> \<longleftrightarrow> x \<sqinter> (z \<lhd> y) = \<bottom>"
   by (metis conjugate_l_def double_compl le_iff_inf_bot resl_galois)
 
 lemma conjugation_multr: "x\<cdot>y \<sqinter> z = \<bottom> \<longleftrightarrow> y \<sqinter> (x \<rhd> z) = \<bottom>"
   by (metis conjugate_r_def inf_bot_iff_le le_iff_inf_bot resr_galois)
   
 lemma conjugation_conj: "(x \<lhd> y) \<sqinter> z = \<bottom> \<longleftrightarrow> y \<sqinter> (z \<rhd> x) = \<bottom>"
   by (metis inf_commute conjugation_multr conjugation_multl)
 
 lemma conjugation_pair_multl [simp]: "conjugation_pair (\<lambda>x. x\<cdot>y) (\<lambda>x. x \<lhd> y)"
   by (simp add: conjugation_pair_def conjugation_multl)
   
 lemma conjugation_pair_multr [simp]: "conjugation_pair (\<lambda>x. y\<cdot>x) (\<lambda>x. y \<rhd> x)"
   by (simp add: conjugation_pair_def conjugation_multr)
   
 lemma conjugation_pair_conj [simp]: "conjugation_pair (\<lambda>x. y \<lhd> x) (\<lambda>x. x \<rhd> y)"
   by (simp add: conjugation_pair_def conjugation_conj)
   
 lemma residuated_conjl1 [simp]: "residuated (\<lambda>x. x \<lhd> y)" 
   by (metis conj_residuatedI2 conjugation_pair_multl)
   
 lemma residuated_conjl2 [simp]: "residuated (\<lambda>x. y \<lhd> x)" 
   by (metis conj_residuatedI1 conjugation_pair_conj)
   
 lemma residuated_conjr1 [simp]: "residuated (\<lambda>x. y \<rhd> x)" 
   by (metis conj_residuatedI2 conjugation_pair_multr)
   
 lemma residuated_conjr2 [simp]: "residuated (\<lambda>x. x \<rhd> y)" 
   by (metis conj_residuatedI2 conjugation_pair_conj)
   
 lemma conjugate_multr [simp]: "conjugate (\<lambda>x. y\<cdot>x) = (\<lambda>x. y \<rhd> x)"
   by (metis conjugation_pair_multr residuated_conj1 residuated_multr unique_conjugate)
   
 lemma conjugate_conjr1 [simp]: "conjugate (\<lambda>x. y \<rhd> x) = (\<lambda>x. y\<cdot>x)"
   by (metis conjugate_multr conj_involution residuated_multr)
   
 lemma conjugate_multl [simp]: "conjugate (\<lambda>x. x\<cdot>y) = (\<lambda>x. x \<lhd> y)"
   by (metis conjugation_pair_multl residuated_conj1 residuated_multl unique_conjugate)
  
 lemma conjugate_conjl1 [simp]: "conjugate (\<lambda>x. x \<lhd> y) = (\<lambda>x. x\<cdot>y)"
 proof -
   have "conjugate (conjugate (\<lambda>x. x\<cdot>y)) = conjugate (\<lambda>x. x \<lhd> y)" by simp
   thus ?thesis
     by (metis conj_involution[OF residuated_multl])
 qed
 
 lemma conjugate_conjl2[simp]: "conjugate (\<lambda>x. y \<lhd> x) = (\<lambda>x. x \<rhd> y)"
   by (metis conjugation_pair_conj unique_conjugate residuated_conj1 residuated_conjl2)
 
 lemma conjugate_conjr2[simp]: "conjugate (\<lambda>x. x \<rhd> y) = (\<lambda>x. y \<lhd> x)"
 proof -
   have "conjugate (conjugate (\<lambda>x. y \<lhd> x)) = conjugate (\<lambda>x. x \<rhd> y)" by simp
   thus ?thesis
     by (metis conj_involution[OF residuated_conjl2])
 qed
 
 lemma conjl1_iso: "x \<le> y \<Longrightarrow> x \<lhd> z \<le> y \<lhd> z"
   by (metis conjugate_l_def compl_mono resl_iso)
 
 lemma conjl2_iso: "x \<le> y \<Longrightarrow> z \<lhd> x \<le> z \<lhd> y"
   by (metis res_iso residuated_conjl2)
 
 lemma conjr1_iso: "x \<le> y \<Longrightarrow> z \<rhd> x \<le> z \<rhd> y"
   by (metis res_iso residuated_conjr1)
 
 lemma conjr2_iso: "x \<le> y \<Longrightarrow> x \<rhd> z \<le> y \<rhd> z"
   by (metis conjugate_r_def compl_mono resr_antitonel)
 
 lemma conjl1_sup: "z \<lhd> (x \<squnion> y) = (z \<lhd> x) \<squnion> (z \<lhd> y)"
   by (metis conjugate_l_def compl_inf resl_distr)
 
 lemma conjl2_sup: "(x \<squnion> y) \<lhd> z = (x \<lhd> z) \<squnion> (y \<lhd> z)"
   by (metis (poly_guards_query) residuated_sup residuated_conjl1)
 
 lemma conjr1_sup: "z \<rhd> (x \<squnion> y) = (z \<rhd> x) \<squnion> (z \<rhd> y)"
   by (metis residuated_sup residuated_conjr1)
 
 lemma conjr2_sup: "(x \<squnion> y) \<rhd> z = (x \<rhd> z) \<squnion> (y \<rhd> z)"
   by (metis conjugate_r_def compl_inf resr_distl)
 
 lemma conjl1_strict: "\<bottom> \<lhd> x = \<bottom>"
   by (metis residuated_strict residuated_conjl1)
 
 lemma conjl2_strict: "x \<lhd> \<bottom> = \<bottom>"
   by (metis residuated_strict residuated_conjl2)
 
 lemma conjr1_strict: "\<bottom> \<rhd> x = \<bottom>"
   by (metis residuated_strict residuated_conjr2)
 
 lemma conjr2_strict: "x \<rhd> \<bottom> = \<bottom>"
   by (metis residuated_strict residuated_conjr1)
 
 lemma conjl1_iff: "x \<lhd> y \<le> z \<longleftrightarrow> x \<le> -(-z\<cdot>y)"
   by (metis conjugate_l_def compl_le_swap1 compl_le_swap2 resl_galois)
 
 lemma conjl2_iff: "x \<lhd> y \<le> z \<longleftrightarrow> y \<le> -(-z \<rhd> x)"
   by (metis conjl1_iff conjugate_r_def compl_le_swap2 double_compl resr_galois)
 
 lemma conjr1_iff: "x \<rhd> y \<le> z \<longleftrightarrow> y \<le> -(x\<cdot>-z)"
   by (metis conjugate_r_def compl_le_swap1 double_compl resr_galois)
 
 lemma conjr2_iff: "x \<rhd> y \<le> z \<longleftrightarrow> x \<le> -(y \<lhd> -z)"
   by (metis conjugation_conj double_compl inf.commute le_iff_inf_bot)
 
 text \<open>
   We apply Maddux's lemmas regarding conjugation of an arbitrary residuated function 
   for each of the 6 functions.
 \<close>
   
 lemma maddux1a: "a\<cdot>(x \<sqinter> -(a \<rhd> y)) \<le> a\<cdot>x"
   by (insert maddux1 [of "\<lambda>x. a\<cdot>x"]) simp
   
 lemma maddux1a': "a\<cdot>(x \<sqinter> -(a \<rhd> y)) \<le> -y"
   by (insert maddux1 [of "\<lambda>x. a\<cdot>x"]) simp
   
 lemma maddux1b: "(x \<sqinter> -(y \<lhd> a))\<cdot>a \<le> x\<cdot>a"
   by (insert maddux1 [of "\<lambda>x. x\<cdot>a"]) simp
   
 lemma maddux1b': "(x \<sqinter> -(y \<lhd> a))\<cdot>a \<le> -y"
   by (insert maddux1 [of "\<lambda>x. x\<cdot>a"]) simp
   
 lemma maddux1c: " a \<lhd> x \<sqinter> -(y \<rhd> a) \<le> a \<lhd> x"
   by (insert maddux1 [of "\<lambda>x. a \<lhd> x"]) simp
   
 lemma maddux1c': "a \<lhd> x \<sqinter> -(y \<rhd> a) \<le> -y"
   by (insert maddux1 [of "\<lambda>x. a \<lhd> x"]) simp
   
 lemma maddux1d: "a \<rhd> x \<sqinter> -(a\<cdot>y) \<le> a \<rhd> x"
   by (insert maddux1 [of "\<lambda>x. a \<rhd> x"]) simp
   
 lemma maddux1d': "a \<rhd> x \<sqinter> -(a\<cdot>y) \<le> -y"
   by (insert maddux1 [of "\<lambda>x. a \<rhd> x"]) simp
 
 lemma maddux1e: "x \<sqinter> -(y\<cdot>a) \<lhd> a \<le> x \<lhd> a"
   by (insert maddux1 [of "\<lambda>x. x \<lhd> a"]) simp
   
 lemma maddux1e': "x \<sqinter> -(y\<cdot>a) \<lhd> a \<le> -y"
   by (insert maddux1 [of "\<lambda>x. x \<lhd> a"]) simp
   
 lemma maddux1f: "x \<sqinter> -(a \<lhd> y) \<rhd> a \<le> x \<rhd> a"
   by (insert maddux1 [of "\<lambda>x. x \<rhd> a"]) simp
   
 lemma maddux1f': "x \<sqinter> -(a \<lhd> y) \<rhd> a \<le> -y"
   by (insert maddux1 [of "\<lambda>x. x \<rhd> a"]) simp
 
 lemma maddux2a: "a\<cdot>x \<sqinter> y \<le> a\<cdot>(x \<sqinter> (a \<rhd> y))"
   by (insert maddux2 [of "\<lambda>x. a\<cdot>x"]) simp
   
 lemma maddux2b: "x\<cdot>a \<sqinter> y \<le> (x \<sqinter> (y \<lhd> a))\<cdot>a"
   by (insert maddux2 [of "\<lambda>x. x\<cdot>a"]) simp
   
 lemma maddux2c: "(a \<lhd> x) \<sqinter> y \<le> a \<lhd> (x \<sqinter> (y \<rhd> a))"
   by (insert maddux2 [of "\<lambda>x. a \<lhd> x"]) simp
   
 lemma maddux2d: "(a \<rhd> x) \<sqinter> y \<le> a \<rhd> (x \<sqinter> a\<cdot>y)"
   by (insert maddux2 [of "\<lambda>x. a \<rhd> x"]) simp
 
 lemma maddux2e: "(x \<lhd> a) \<sqinter> y \<le> (x \<sqinter> y\<cdot>a) \<lhd> a"
   by (insert maddux2 [of "\<lambda>x. x \<lhd> a"]) simp
   
 lemma maddux2f: "(x \<rhd> a) \<sqinter> y \<le> (x \<sqinter> (a \<lhd> y)) \<rhd> a"
   by (insert maddux2 [of "\<lambda>x. x \<rhd> a"]) simp
   
 text \<open>
   The multiplicative operation $\cdot$ on a residuated boolean algebra is generally not
   associative. We prove some equivalences related to associativity.
 \<close>
 
 lemma res_assoc_iff1: "(\<forall>x y z. x\<cdot>(y\<cdot>z) = (x\<cdot>y)\<cdot>z) \<longleftrightarrow> (\<forall>x y z. x \<rhd> (y \<rhd> z) = y\<cdot>x \<rhd> z)"
 proof safe
   fix x y z assume "\<forall>x y z. x\<cdot>(y\<cdot>z) = (x\<cdot>y)\<cdot>z"
   thus "x \<rhd> (y \<rhd> z) = y \<cdot> x \<rhd> z"
     using conjugate_comp_ext[of "\<lambda>z. y\<cdot>z" "\<lambda>z. x\<cdot>z"] by auto
 next
   fix x y z assume "\<forall>x y z. x \<rhd> (y \<rhd> z) = y\<cdot>x \<rhd> z"
   thus "x\<cdot>(y\<cdot>z) = (x\<cdot>y)\<cdot>z"
     using conjugate_comp_ext[of "\<lambda>z. y \<rhd> z" "\<lambda>z. x \<rhd> z"] by auto
 qed
 
 lemma res_assoc_iff2: "(\<forall>x y z. x\<cdot>(y\<cdot>z) = (x\<cdot>y)\<cdot>z) \<longleftrightarrow> (\<forall>x y z. x \<lhd> (y \<cdot> z) = (x \<lhd> z) \<lhd> y)"
 proof safe
   fix x y z assume "\<forall>x y z. x\<cdot>(y\<cdot>z) = (x\<cdot>y)\<cdot>z"
   hence "\<forall>x y z. (x\<cdot>y)\<cdot>z = x\<cdot>(y\<cdot>z)" by simp
   thus "x \<lhd> (y \<cdot> z) = (x \<lhd> z) \<lhd> y"
     using conjugate_comp_ext[of "\<lambda>x. x\<cdot>z" "\<lambda>x. x\<cdot>y"] by auto
 next
   fix x y z assume "\<forall>x y z. x \<lhd> (y \<cdot> z) = (x \<lhd> z) \<lhd> y"
   hence "\<forall>x y z. (x \<lhd> z) \<lhd> y = x \<lhd> (y \<cdot> z)" by simp
   thus "x\<cdot>(y\<cdot>z) = (x\<cdot>y)\<cdot>z" 
     using conjugate_comp_ext[of "\<lambda>z. z \<lhd> y" "\<lambda>x. x \<lhd> z"] by auto
 qed
   
 lemma res_assoc_iff3: "(\<forall>x y z. x\<cdot>(y\<cdot>z) = (x\<cdot>y)\<cdot>z) \<longleftrightarrow> (\<forall>x y z. (x \<rhd> y) \<lhd> z = x \<rhd> (y \<lhd> z))"
 proof safe
   fix x y z assume "\<forall>x y z. x\<cdot>(y\<cdot>z) = (x\<cdot>y)\<cdot>z"
   thus "(x \<rhd> y) \<lhd> z = x \<rhd> (y \<lhd> z)"
     using conjugate_comp_ext[of "\<lambda>u. x\<cdot>u" "\<lambda>u. u\<cdot>z"] and
     conjugate_comp_ext[of "\<lambda>u. u\<cdot>z" "\<lambda>u. x\<cdot>u", symmetric]
     by auto
 next
   fix x y z assume "\<forall>x y z. (x \<rhd> y) \<lhd> z = x \<rhd> (y \<lhd> z)"
   thus "x\<cdot>(y\<cdot>z) = (x\<cdot>y)\<cdot>z"
     using conjugate_comp_ext[of "\<lambda>u. x \<rhd> u" "\<lambda>u. u \<lhd> z"] and
     conjugate_comp_ext[of "\<lambda>u. u \<lhd> z" "\<lambda>u. x \<rhd> u", symmetric]
     by auto
 qed
 
 end (* residuated_boolean_algebra *)
 
 class unital_residuated_boolean = residuated_boolean_algebra + one +
   assumes mult_onel [simp]: "x\<cdot>1 = x"
   and mult_oner [simp]: "1\<cdot>x = x"
 begin
 
 text \<open>
   The following equivalences are taken from J{\'o}sson and Tsinakis.
 \<close>
 
 lemma jonsson1a: "(\<exists>f. \<forall>x y. x \<rhd> y = f(x)\<cdot>y) \<longleftrightarrow> (\<forall>x y. x \<rhd> y = (x \<rhd> 1)\<cdot>y)"
   apply standard
   apply force
   apply (rule_tac x="\<lambda>x. x \<rhd> 1" in exI)
   apply force
   done
   
 lemma jonsson1b: "(\<forall>x y. x \<rhd> y = (x \<rhd> 1)\<cdot>y) \<longleftrightarrow> (\<forall>x y. x\<cdot>y = (x \<rhd> 1) \<rhd> y)"
 proof safe
   fix x y
   assume "\<forall>x y. x \<rhd> y = (x \<rhd> 1)\<cdot>y"
   hence "conjugate (\<lambda>y. x \<rhd> y) = conjugate (\<lambda>y. (x \<rhd> 1)\<cdot>y)" by metis
   thus "x\<cdot>y = (x \<rhd> 1) \<rhd> y" by simp
 next
   fix x y
   assume "\<forall>x y. x \<cdot> y = x \<rhd> 1 \<rhd> y"
   thus "x \<rhd> y = (x \<rhd> 1) \<cdot> y"
     by (metis mult_onel)
 qed
 
 lemma jonsson1c: "(\<forall>x y. x \<rhd> y = (x \<rhd> 1)\<cdot>y) \<longleftrightarrow> (\<forall>x y. y \<lhd> x = 1 \<lhd> (x \<lhd> y))"
 proof safe
   fix x y
   assume "\<forall>x y. x \<rhd> y = (x \<rhd> 1)\<cdot>y"
   hence "(\<lambda>x. x \<rhd> y) = (\<lambda>x. (x \<rhd> 1)\<cdot>y)" by metis
   hence "(\<lambda>x. x \<rhd> y) = (\<lambda>x. x\<cdot>y) o (\<lambda>x. x \<rhd> 1)" by force
   hence "conjugate (\<lambda>x. y \<lhd> x) = (\<lambda>x. x\<cdot>y) o conjugate (\<lambda>x. 1 \<lhd> x)" by simp
   hence "conjugate (conjugate (\<lambda>x. y \<lhd> x)) = conjugate ((\<lambda>x. x\<cdot>y) o conjugate (\<lambda>x. 1 \<lhd> x))" by simp
   hence "(\<lambda>x. y \<lhd> x) = conjugate ((\<lambda>x. x\<cdot>y) o conjugate (\<lambda>x. 1 \<lhd> x))" by simp
   also have "... = conjugate (conjugate (\<lambda>x. 1 \<lhd> x)) o conjugate (\<lambda>x. x\<cdot>y)"
     by (subst conjugate_comp[symmetric]) simp_all
   finally show "y \<lhd> x = 1 \<lhd> (x \<lhd> y)" by simp
 next
   fix x y
   assume "\<forall>x y. y \<lhd> x = 1 \<lhd> (x \<lhd> y)"
   hence "(\<lambda>x. y \<lhd> x) = (\<lambda>x. 1 \<lhd> (x \<lhd> y))" by metis
   hence "(\<lambda>x. y \<lhd> x) = (\<lambda>x. 1 \<lhd> x) o conjugate (\<lambda>x. x\<cdot>y)" by force
   hence "conjugate (\<lambda>x. y \<lhd> x) = conjugate ((\<lambda>x. 1 \<lhd> x) o conjugate (\<lambda>x. x\<cdot>y))" by metis
   also have "... = conjugate (conjugate (\<lambda>x. x\<cdot>y)) o conjugate (\<lambda>x. 1 \<lhd> x)"
     by (subst conjugate_comp[symmetric]) simp_all
   finally have "(\<lambda>x. x \<rhd> y) = (\<lambda>x. x\<cdot>y) o (\<lambda>x. x \<rhd> 1)" by simp
   hence "(\<lambda>x. x \<rhd> y) = (\<lambda>x. (x \<rhd> 1) \<cdot> y)" by (simp add: comp_def)
   thus "x \<rhd> y = (x \<rhd> 1) \<cdot> y" by metis
 qed
 
 lemma jonsson2a: "(\<exists>g. \<forall>x y. x \<lhd> y = x\<cdot>g(y)) \<longleftrightarrow> (\<forall>x y. x \<lhd> y = x\<cdot>(1 \<lhd> y))"
   apply standard
   apply force
   apply (rule_tac x="\<lambda>x. 1 \<lhd> x" in exI)
   apply force
   done
   
 lemma jonsson2b: "(\<forall>x y. x \<lhd> y = x\<cdot>(1 \<lhd> y)) \<longleftrightarrow> (\<forall>x y. x\<cdot>y = x \<lhd> (1 \<lhd> y))"
 proof safe
   fix x y
   assume "\<forall>x y. x \<lhd> y = x\<cdot>(1 \<lhd> y)"
   hence "conjugate (\<lambda>x. x \<lhd> y) = conjugate (\<lambda>x. x\<cdot>(1 \<lhd> y))" by metis
   thus "x\<cdot>y = x \<lhd> (1 \<lhd> y)" by simp metis
 next
   fix x y
   assume "\<forall>x y. x\<cdot>y = x \<lhd> (1 \<lhd> y)"
   hence "(\<lambda>x. x\<cdot>y) = (\<lambda>x. x \<lhd> (1 \<lhd> y))" by metis
   hence "conjugate (\<lambda>x. x\<cdot>y) = conjugate (\<lambda>x. x \<lhd> (1 \<lhd> y))" by metis
   thus "x \<lhd> y = x \<cdot> (1 \<lhd> y)" by simp metis
 qed
 
 lemma jonsson2c: "(\<forall>x y. x \<lhd> y = x\<cdot>(1 \<lhd> y)) \<longleftrightarrow> (\<forall>x y. y \<rhd> x = (x \<rhd> y) \<rhd> 1)"
 proof safe
   fix x y
   assume "\<forall>x y. x \<lhd> y = x\<cdot>(1 \<lhd> y)"
   hence "(\<lambda>y. x \<lhd> y) = (\<lambda>y. x\<cdot>(1 \<lhd> y))" by metis
   hence "(\<lambda>y. x \<lhd> y) = (\<lambda>y. x\<cdot>y) o (\<lambda>y. 1 \<lhd> y)" by force
   hence "conjugate (\<lambda>y. y \<rhd> x) = (\<lambda>y. x\<cdot>y) o conjugate (\<lambda>y. y \<rhd> 1)" by force
   hence "conjugate (conjugate (\<lambda>y. y \<rhd> x)) = conjugate ((\<lambda>y. x\<cdot>y) o conjugate (\<lambda>y. y \<rhd> 1))" by metis
   hence "(\<lambda>y. y \<rhd> x) = conjugate ((\<lambda>y. x\<cdot>y) o conjugate (\<lambda>y. y \<rhd> 1))" by simp
   also have "... = conjugate (conjugate (\<lambda>y. y \<rhd> 1)) o conjugate (\<lambda>y. x\<cdot>y)"
     by (subst conjugate_comp[symmetric]) simp_all
   finally have "(\<lambda>y. y \<rhd> x) = (\<lambda>y. x \<rhd> y \<rhd> 1)" by (simp add: comp_def)
   thus "y \<rhd> x = x \<rhd> y \<rhd> 1" by metis 
 next
   fix x y
   assume "\<forall>x y. y \<rhd> x = x \<rhd> y \<rhd> 1"
   hence "(\<lambda>y. y \<rhd> x) = (\<lambda>y. x \<rhd> y \<rhd> 1)" by force
   hence "(\<lambda>y. y \<rhd> x) = (\<lambda>y. y \<rhd> 1) o conjugate (\<lambda>y. x\<cdot>y)" by force
   hence "conjugate (\<lambda>y. y \<rhd> x) = conjugate ((\<lambda>y. y \<rhd> 1) o conjugate (\<lambda>y. x\<cdot>y))" by metis
   also have "... = conjugate (conjugate (\<lambda>y. x\<cdot>y)) o conjugate (\<lambda>y. y \<rhd> 1)"
     by (subst conjugate_comp[symmetric]) simp_all
   finally have "(\<lambda>y. x \<lhd> y) = (\<lambda>y. x\<cdot>y) o (\<lambda>y. 1 \<lhd> y)"
     by (metis conjugate_conjr1 conjugate_conjr2 conjugate_multr)
   thus "x \<lhd> y = x \<cdot> (1 \<lhd> y)" by (simp add: comp_def)
 qed
 
 lemma jonsson3a: "(\<forall>x. (x \<rhd> 1) \<rhd> 1 = x) \<longleftrightarrow> (\<forall>x. 1 \<lhd> (1 \<lhd> x) = x)"
 proof safe
   fix x assume "\<forall>x. x \<rhd> 1 \<rhd> 1 = x"
   thus "1 \<lhd> (1 \<lhd> x) = x"
     by (metis compl_le_swap1 compl_le_swap2 conjr2_iff order.eq_iff)
 next
   fix x assume "\<forall>x. 1 \<lhd> (1 \<lhd> x) = x"
   thus "x \<rhd> 1 \<rhd> 1 = x"
     by (metis conjugate_l_def conjugate_r_def double_compl jipsen2r)
 qed
 
 lemma jonsson3b: "(\<forall>x. (x \<rhd> 1) \<rhd> 1 = x) \<Longrightarrow> (x \<sqinter> y) \<rhd> 1 = (x \<rhd> 1) \<sqinter> (y \<rhd> 1)"
 proof (rule order.antisym, auto simp: conjr2_iso)
   assume assm: "\<forall>x. (x \<rhd> 1) \<rhd> 1 = x"
   hence "(x \<rhd> 1) \<sqinter> (y \<rhd> 1) \<rhd> 1 = x \<sqinter> (((x \<rhd> 1) \<sqinter> (y \<rhd> 1) \<rhd> 1) \<sqinter> y)"
     by (metis (no_types) conjr2_iso inf.cobounded2 inf.commute inf.orderE)
   hence "(x \<rhd> 1) \<sqinter> (y \<rhd> 1) \<rhd> 1 \<le> x \<sqinter> y" 
     using inf.orderI inf_left_commute by presburger
   thus "(x \<rhd> 1) \<sqinter> (y \<rhd> 1) \<le> x \<sqinter> y \<rhd> 1" 
     using assm by (metis (no_types) conjr2_iso)
 qed
 
 lemma jonsson3c: "\<forall>x. (x \<rhd> 1) \<rhd> 1 = x \<Longrightarrow> x \<rhd> 1 = 1 \<lhd> x"
 proof (rule indirect_eq)
   fix z
   assume assms: "\<forall>x. (x \<rhd> 1) \<rhd> 1 = x"
   hence "(x \<rhd> 1) \<sqinter> -z = \<bottom> \<longleftrightarrow> ((x \<rhd> 1) \<sqinter> -z) \<rhd> 1 = \<bottom>"
     by (metis compl_sup conjugation_conj double_compl inf_bot_right sup_bot.left_neutral)
   also have "... \<longleftrightarrow> -z\<cdot>x \<sqinter> 1 = \<bottom>"
     by (metis assms jonsson3b conjugation_multr)
   finally have "(x \<rhd> 1) \<sqinter> -z = \<bottom> \<longleftrightarrow> (1 \<lhd> x) \<sqinter> -z = \<bottom>"
     by (metis conjugation_multl inf.commute)
   thus "(x \<rhd> 1 \<le> z) \<longleftrightarrow> (1 \<lhd> x \<le> z)"
     by (metis le_iff_inf_bot)
 qed 
 
 end (* unital_residuated_boolean *)
 
 class residuated_boolean_semigroup = residuated_boolean_algebra + semigroup_mult
 begin
 
 subclass residuated_boolean_algebra ..
 
 text \<open>
   The following lemmas hold trivially, since they are equivalent to associativity.
 \<close>
 
 lemma res_assoc1: "x \<rhd> (y \<rhd> z) = y\<cdot>x \<rhd> z"
   by (metis res_assoc_iff1 mult_assoc)
 
 lemma res_assoc2: "x \<lhd> (y \<cdot> z) = (x \<lhd> z) \<lhd> y"
   by (metis res_assoc_iff2 mult_assoc)
 
 lemma res_assoc3: "(x \<rhd> y) \<lhd> z = x \<rhd> (y \<lhd> z)"
   by (metis res_assoc_iff3 mult_assoc)
 
 end (*residuated_boolean_semigroup *)
 
 class residuated_boolean_monoid = residuated_boolean_algebra + monoid_mult
 begin
 
 subclass unital_residuated_boolean
   by standard auto
 
 subclass residuated_lmonoid ..
 
 lemma jonsson4: "(\<forall>x y. x \<lhd> y = x\<cdot>(1 \<lhd> y)) \<longleftrightarrow> (\<forall>x y. x \<rhd> y = (x \<rhd> 1)\<cdot>y)"
 proof safe
   fix x y assume assms: "\<forall>x y. x \<lhd> y = x\<cdot>(1 \<lhd> y)"
   have "x \<rhd> y = (y \<rhd> x) \<rhd> 1"
     by (metis assms jonsson2c)
   also have "... = (y \<rhd> ((x \<rhd> 1) \<rhd> 1)) \<rhd> 1"
     by (metis assms jonsson2b jonsson3a mult_oner)
   also have "... = (((x \<rhd> 1)\<cdot>y) \<rhd> 1) \<rhd> 1"
     by (metis conjugate_r_def double_compl resr3)
   also have "... = (x \<rhd> 1)\<cdot>y"
     by (metis assms jonsson2b jonsson3a mult_oner)
   finally show "x \<rhd> y = (x \<rhd> 1)\<cdot>y" .
 next
   fix x y assume assms: "\<forall>x y. x \<rhd> y = (x \<rhd> 1)\<cdot>y"
   have "y \<lhd> x = 1 \<lhd> (x \<lhd> y)"
     by (metis assms jonsson1c)
   also have "... = 1 \<lhd> ((1 \<lhd> (1 \<lhd> x)) \<lhd> y)"
     by (metis assms conjugate_l_def double_compl jonsson1c mult_1_right resl3)
   also have "... = 1 \<lhd> (1 \<lhd> (y\<cdot>(1 \<lhd> x)))"
     by (metis conjugate_l_def double_compl resl3)
   also have "... = y\<cdot>(1 \<lhd> x)"
     by (metis assms jonsson1b jonsson1c jonsson3c mult_onel)
   finally show "y \<lhd> x = y\<cdot>(1 \<lhd> x)".
 qed
 
 end (* residuated_boolean_monoid *)
 
 end
diff --git a/thys/Residuated_Lattices/Residuated_Relation_Algebra.thy b/thys/Residuated_Lattices/Residuated_Relation_Algebra.thy
--- a/thys/Residuated_Lattices/Residuated_Relation_Algebra.thy
+++ b/thys/Residuated_Lattices/Residuated_Relation_Algebra.thy
@@ -1,118 +1,118 @@
 (* Title:      Residuated Relation Algebras
    Author:     Victor Gomes <vborgesferreiragomes1 at sheffield.ac.uk>
    Maintainer: Georg Struth <g.struth@sheffield.ac.uk> 
 *)
 
 section \<open>Residuated Relation Algebras\<close>
 
 theory Residuated_Relation_Algebra
   imports Residuated_Boolean_Algebras Relation_Algebra.Relation_Algebra
 begin
 
-context Lattices.boolean_algebra begin
+context boolean_algebra begin
 
 text \<open>
   The notation used in the relation algebra AFP entry differs a little from ours.
 \<close>
 
 notation
   times (infixl "\<cdot>" 70)
   and plus (infixl "+" 65)
   and Groups.zero_class.zero ("0")
   and Groups.one_class.one ("1")
 
 no_notation
   inf (infixl "\<cdot>" 70)
   and sup (infixl "+" 65)
   and bot ("0")
   and top ("1")
 
 end
 
 text \<open>
   We prove that a unital residuated boolean algebra enriched with two simple
   equalities form a non-associative relation algebra, that is, a relation
   algebra where the associativity law does not hold.
 \<close>
 
 class nra = unital_residuated_boolean +
   assumes conv1: "x \<rhd> y = (x \<rhd> 1)\<cdot>y"
   and conv2: "x \<lhd> y = x\<cdot>(1 \<lhd> y)"
 begin
 
 text \<open>
   When the converse operation is set to be $\lambda x.\  x \rhd 1$,
   a unital residuated boolean algebra forms a non associative relation algebra.
 \<close>
   
 lemma conv_invol: "x \<rhd> 1 \<rhd> 1 = x"
   by (metis local.conv1 local.jonsson1b local.mult_onel)
 
 lemma conv_add: "x \<squnion> y \<rhd> 1 = (x \<rhd> 1) \<squnion> (y \<rhd> 1)"
   by (metis local.conjr2_sup)
 
 lemma conv_contrav: "x\<cdot>y \<rhd> 1 = (y \<rhd> 1)\<cdot>(x \<rhd> 1)"
   by (metis local.conv1 local.conv2 local.jonsson1b local.jonsson2c)
 
 lemma conv_res: "(x \<rhd> 1)\<cdot>- (x\<cdot>y) \<le> - y"
   by (metis local.comp_anti local.conjugate_r_def local.conv1 local.double_compl local.res_rc1)
 
 text \<open>
   Similarly, for $x^\smile = 1 \lhd x$, since $x \rhd 1 = 1 \lhd x$ when
   $x \rhd 1 \rhd 1 = x$ holds.
 \<close>
 
 lemma conv_invol': "1 \<lhd> (1 \<lhd> x) = x"
   by (metis local.conv_invol local.jonsson3c)
 
 lemma conv_add': "1 \<lhd> (x \<squnion> y) = (1 \<lhd> x) \<squnion> (1 \<lhd> y)"
   by (metis local.conjl1_sup)
 
 lemma conv_contrav': "1 \<lhd> x\<cdot>y = (1 \<lhd> y)\<cdot>(1 \<lhd> x)"
   by (metis local.conv_contrav local.conv_invol local.jonsson3c)
 
 lemma conv_res': "(1 \<lhd> x)\<cdot>- (x\<cdot>y) \<le> - y"
   by (metis conv_res local.conv_invol local.jonsson3c)
   
 end (* nra *)
 
 text \<open>
   Since the previous axioms are equivalent when multiplication is associative
   in a residuated boolean monoid, one of them are sufficient to
   derive a relation algebra.
 \<close>
 
 class residuated_ra = residuated_boolean_monoid +
   assumes conv: "x \<rhd> y = (x \<rhd> 1)\<cdot>y"
 begin
 
 subclass nra
 proof (standard, fact conv)
   fix x y show "x \<lhd> y = x\<cdot>(1 \<lhd> y)"
     by (metis conv jonsson4)
 qed
 
 sublocale relation_algebra where
   composition = "(\<cdot>)" and unit = 1 and
   converse = "\<lambda>x. x \<rhd> 1"
 proof
   fix x y z
   show "x\<cdot>y\<cdot>z = x\<cdot>(y\<cdot>z)"
     by (metis local.mult_assoc)
   show "x\<cdot>1 = x"
     by (metis local.mult_onel)
   show "(x \<squnion> y)\<cdot>z = x\<cdot>z \<squnion> y\<cdot>z"
     by (metis local.distr)
   show "x \<rhd> 1 \<rhd> 1 = x"
     by (metis local.conv_invol)
   show "x \<squnion> y \<rhd> 1 = (x \<rhd> 1) \<squnion> (y \<rhd> 1)"
     by (metis local.conv_add)
   show "x\<cdot>y \<rhd> 1 = (y \<rhd> 1)\<cdot>(x \<rhd> 1)"
     by (metis local.conv_contrav)
   show "(x \<rhd> 1)\<cdot>- (x\<cdot>y) \<le> - y"
     by (metis local.conv_res)
 qed
 
 end (* residuated_ra *)
 
 end
diff --git a/thys/Robbins-Conjecture/Robbins_Conjecture.thy b/thys/Robbins-Conjecture/Robbins_Conjecture.thy
--- a/thys/Robbins-Conjecture/Robbins_Conjecture.thy
+++ b/thys/Robbins-Conjecture/Robbins_Conjecture.thy
@@ -1,985 +1,985 @@
 section \<open>Robbins Conjecture\<close>
 
 theory Robbins_Conjecture
 imports Main
 begin
 
 text \<open>The document gives a formalization of the proof of the Robbins 
         conjecture, following A. Mann, \emph{A Complete Proof of the 
         Robbins Conjecture}, 2003, DOI 10.1.1.6.7838\<close>
 
 section \<open>Axiom Systems\<close>
 
 text \<open>The following presents several axiom systems that shall be under study.
 
         The first axiom sets common systems that underly all of 
         the systems we shall be looking at.
 
         The second system is a reformulation of Boolean algebra.  We shall 
         follow pages 7--8 in S. Koppelberg. \emph{General Theory of Boolean 
         Algebras}, Volume 1 of \emph{Handbook of Boolean Algebras}. North 
         Holland, 1989. Note that our formulation deviates slightly from this, 
         as we only provide one distribution axiom, as the dual is redundant.
 
         The third system is Huntington's algebra and the fourth system is 
         Robbins' algebra.
 
         Apart from the common system, all of these systems are demonstrated 
         to be equivalent to the library formulation of Boolean algebra, under 
         appropriate interpretation.\<close>
 
 subsection \<open>Common Algebras\<close>
 
 class common_algebra = uminus +
   fixes inf :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<sqinter>" 70)
   fixes sup :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<squnion>" 65)
   fixes bot :: "'a" ("\<bottom>")
   fixes top :: "'a" ("\<top>")
   assumes sup_assoc: "x \<squnion> (y \<squnion> z) = (x \<squnion> y) \<squnion> z"
   assumes sup_comm: "x \<squnion> y = y \<squnion> x" 
 
 context common_algebra begin
 
 definition less_eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubseteq>" 50) where
    "x \<sqsubseteq> y = (x \<squnion> y = y)"
 definition less :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubset>" 50) where
    "x \<sqsubset> y = (x \<sqsubseteq> y \<and> \<not> y \<sqsubseteq> x)"
 definition minus :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"  (infixl "-" 65) where 
    "minus x y = (x \<sqinter> - y)"
 
 (* We shall need some object in order to define falsum and verum *)
 definition secret_object1 :: "'a" ("\<iota>") where
   "\<iota> = (SOME x. True)"
 
 end
 
 class ext_common_algebra = common_algebra +
   assumes inf_eq: "x \<sqinter> y = -(- x \<squnion> - y)"
   assumes top_eq: "\<top> = \<iota> \<squnion> - \<iota>"
   assumes bot_eq: "\<bottom> = -(\<iota> \<squnion> - \<iota>)"
 
 subsection \<open>Boolean Algebra\<close>
 
 class boolean_algebra_II = 
   common_algebra +
   assumes inf_comm: "x \<sqinter> y = y \<sqinter> x"
   assumes inf_assoc: "x \<sqinter> (y \<sqinter> z) = (x \<sqinter> y) \<sqinter> z"
   assumes sup_absorb: "x \<squnion> (x \<sqinter> y) = x"
   assumes inf_absorb: "x \<sqinter> (x \<squnion> y) = x"
   assumes sup_inf_distrib1: "x \<squnion> y \<sqinter> z = (x \<squnion> y) \<sqinter> (x \<squnion> z)"
   assumes sup_compl: "x \<squnion> - x = \<top>"
   assumes inf_compl: "x \<sqinter> - x = \<bottom>"
 
 subsection \<open>Huntington's Algebra\<close>
 
 class huntington_algebra = ext_common_algebra +
   assumes huntington: "- (-x \<squnion> -y) \<squnion> - (-x \<squnion>  y) = x"
 
 subsection \<open>Robbins' Algebra\<close>
 
 class robbins_algebra = ext_common_algebra +
   assumes robbins: "- (- (x \<squnion> y) \<squnion> - (x \<squnion> -y)) = x"
 
 section \<open>Equivalence\<close>
 
 text \<open>With our axiom systems defined, we turn to providing equivalence 
         results between them.  
         
         We shall begin by illustrating equivalence for our formulation and 
         the library formulation of Boolean algebra.\<close>
 
 subsection \<open>Boolean Algebra\<close>
 
 text \<open>The following provides the canonical definitions for order and 
         relative complementation for Boolean algebras.  These are necessary 
         since the Boolean algebras presented in the Isabelle/HOL library have 
         a lot of structure, while our formulation is considerably simpler.
      
        Since our formulation of Boolean algebras is considerably simple, it is 
        easy to show that the library instantiates our axioms.\<close>
 
 context boolean_algebra_II begin
 
 lemma boolean_II_is_boolean:
    "class.boolean_algebra minus uminus (\<sqinter>) (\<sqsubseteq>) (\<sqsubset>) (\<squnion>) \<bottom> \<top>"
 apply unfold_locales
 apply (metis inf_absorb inf_assoc inf_comm inf_compl
              less_def less_eq_def minus_def 
              sup_absorb sup_assoc sup_comm
              sup_compl sup_inf_distrib1
              sup_absorb inf_comm)+
 done
 
 end
 
-context Lattices.boolean_algebra begin
+context boolean_algebra begin
 
 lemma boolean_is_boolean_II:
   "class.boolean_algebra_II uminus inf sup bot top"
 apply unfold_locales
 apply (metis sup_assoc sup_commute sup_inf_absorb sup_compl_top
              inf_assoc inf_commute inf_sup_absorb inf_compl_bot
              sup_inf_distrib1)+
 done
 
 end
 
 subsection \<open>Huntington Algebra\<close>
 
 text \<open>We shall illustrate here that all Boolean algebra using our 
         formulation are Huntington algebras, and illustrate that every 
         Huntington algebra may be interpreted as a Boolean algebra.
 
         Since the Isabelle/HOL library has good automation, it is convenient 
         to first show that the library instances Huntington algebras to exploit 
         previous results, and then use our previously derived correspondence.\<close>
 
-context Lattices.boolean_algebra begin
+context boolean_algebra begin
 lemma boolean_is_huntington:
   "class.huntington_algebra uminus inf sup bot top"
 apply unfold_locales
 apply (metis double_compl inf_sup_distrib1 inf_top_right
              compl_inf inf_commute inf_compl_bot  
              compl_sup sup_commute sup_compl_top 
              sup_compl_top sup_assoc)+
 done
 
 end
 
 context boolean_algebra_II begin
 
 lemma boolean_II_is_huntington:
   "class.huntington_algebra uminus (\<sqinter>) (\<squnion>) \<bottom> \<top>"
 proof -
   interpret boolean: 
-    Lattices.boolean_algebra minus uminus "(\<sqinter>)" "(\<sqsubseteq>)" "(\<sqsubset>)" "(\<squnion>)" \<bottom> \<top>
+    boolean_algebra minus uminus "(\<sqinter>)" "(\<sqsubseteq>)" "(\<sqsubset>)" "(\<squnion>)" \<bottom> \<top>
       by (fact boolean_II_is_boolean)
   show ?thesis by (simp add: boolean.boolean_is_huntington)
 qed
 
 end
 
 context huntington_algebra begin
 
 lemma huntington_id: "x \<squnion> -x = -x \<squnion> -(-x)"
 proof -
   from huntington have 
   "x \<squnion> -x = -(-x \<squnion> -(-(-x))) \<squnion> -(-x \<squnion> -(-x)) \<squnion> 
              (-(-(-x) \<squnion> -(-(-x))) \<squnion> -(-(-x) \<squnion> -(-x)))"
     by simp
   also from sup_comm have 
   "\<dots> = -(-(-x) \<squnion> -(-x)) \<squnion> -(-(-x) \<squnion> -(-(-x))) \<squnion> 
         (-(-(-x) \<squnion> -x) \<squnion> -(-(-(-x)) \<squnion> -x))"  
     by simp
   also from sup_assoc have 
   "\<dots> = -(-(-x) \<squnion> -(-x)) \<squnion> 
         (-(-(-x) \<squnion> -(-(-x))) \<squnion> -(-(-x) \<squnion> -x)) \<squnion> 
        -(-(-(-x)) \<squnion> -x)"  
     by simp
   also from sup_comm have 
   "\<dots> = -(-(-x) \<squnion> -(-x)) \<squnion> 
         (-(-(-x) \<squnion> -x) \<squnion> -(-(-x) \<squnion> -(-(-x)))) \<squnion> 
        -(-(-(-x)) \<squnion> -x)"  
     by simp
   also from sup_assoc have 
   "\<dots> = -(-(-x) \<squnion> -(-x)) \<squnion> -(-(-x) \<squnion> -x) \<squnion> 
         (-(-(-x) \<squnion> -(-(-x))) \<squnion> -(-(-(-x)) \<squnion> -x))"  
     by simp
   also from sup_comm have 
   "\<dots> = -(-(-x) \<squnion> -(-x)) \<squnion> -(-(-x) \<squnion> -x) \<squnion> 
         (-(-(-(-x)) \<squnion> -(-x)) \<squnion> -(-(-(-x)) \<squnion> -x))"
     by simp
   also from huntington have 
   "\<dots> = -x \<squnion> -(-x)"
     by simp
   finally show ?thesis by simp
 qed
 
 lemma dbl_neg: "- (-x) = x"
 apply (metis huntington huntington_id sup_comm)
 done
 
 lemma towards_sup_compl: "x \<squnion> -x = y \<squnion> -y"
 proof -
    from huntington have 
   "x \<squnion> -x = -(-x \<squnion> -(-y)) \<squnion> -(-x \<squnion> -y) \<squnion> (-(-(-x) \<squnion> -(-y)) \<squnion> -(-(-x) \<squnion> -y))"
      by simp
    also from sup_comm have 
   "\<dots> = -(-(-y) \<squnion> -x) \<squnion> -(-y \<squnion> -x) \<squnion> (-(-y \<squnion> -(-x)) \<squnion> -(-(-y) \<squnion> -(-x)))"
      by simp
    also from sup_assoc have 
   "\<dots> = -(-(-y) \<squnion> -x) \<squnion> (-(-y \<squnion> -x) \<squnion> -(-y \<squnion> -(-x))) \<squnion> -(-(-y) \<squnion> -(-x))"
      by simp
    also from sup_comm have
   "\<dots> = -(-y \<squnion> -(-x)) \<squnion> -(-y \<squnion> -x) \<squnion> -(-(-y) \<squnion> -x) \<squnion> -(-(-y) \<squnion> -(-x))"
      by simp
    also from sup_assoc have 
   "\<dots> = -(-y \<squnion> -(-x)) \<squnion> -(-y \<squnion> -x) \<squnion> (-(-(-y) \<squnion> -x) \<squnion> -(-(-y) \<squnion> -(-x)))"
      by simp
    also from sup_comm have 
   "\<dots> = -(-y \<squnion> -(-x)) \<squnion> -(-y \<squnion> -x) \<squnion> (-(-(-y) \<squnion> -(-x)) \<squnion> -(-(-y) \<squnion> -x))"
      by simp
    also from huntington have 
   "y \<squnion> -y = \<dots>" by simp
    finally show ?thesis by simp
 qed
 
 lemma sup_compl: "x \<squnion> -x = \<top>"
 by (simp add: top_eq towards_sup_compl)
 
 lemma towards_inf_compl: "x \<sqinter> -x = y \<sqinter> -y"
 by (metis dbl_neg inf_eq sup_comm sup_compl)
 
 lemma inf_compl: "x \<sqinter> -x = \<bottom>"
 by (metis dbl_neg sup_comm bot_eq towards_inf_compl inf_eq)
 
 lemma towards_idem: "\<bottom> = \<bottom> \<squnion> \<bottom>"
 by (metis dbl_neg huntington inf_compl inf_eq sup_assoc sup_comm sup_compl)
 
 lemma sup_ident: "x \<squnion> \<bottom> = x"
 by (metis dbl_neg huntington inf_compl inf_eq sup_assoc 
           sup_comm sup_compl towards_idem)
 
 lemma inf_ident: "x \<sqinter> \<top> = x"
 by (metis dbl_neg inf_compl inf_eq sup_ident sup_comm sup_compl)
 
 lemma sup_idem: "x \<squnion> x = x"
 by (metis dbl_neg huntington inf_compl inf_eq sup_ident sup_comm sup_compl)
 
 lemma inf_idem: "x \<sqinter> x = x"
 by (metis dbl_neg inf_eq sup_idem)
 
 lemma sup_nil: "x \<squnion> \<top> = \<top>"
 by (metis sup_idem sup_assoc sup_comm sup_compl)
 
 lemma inf_nil: "x \<sqinter> \<bottom> = \<bottom>"
 by (metis dbl_neg inf_compl inf_eq sup_nil sup_comm sup_compl)
 
 lemma sup_absorb: "x \<squnion> x \<sqinter> y = x"
 by (metis huntington inf_eq sup_idem sup_assoc sup_comm)
 
 lemma inf_absorb: "x \<sqinter> (x \<squnion> y) = x"
 by (metis dbl_neg inf_eq sup_absorb)
 
 lemma partition: "x \<sqinter> y \<squnion> x \<sqinter> -y = x"
 by (metis dbl_neg huntington inf_eq sup_comm)
 
 lemma demorgans1: "-(x \<sqinter> y) = -x \<squnion> -y"
 by (metis dbl_neg inf_eq)
 
 lemma demorgans2: "-(x \<squnion> y) = -x \<sqinter> -y"
 by (metis dbl_neg inf_eq)
 
 lemma inf_comm: "x \<sqinter> y = y \<sqinter> x"
 by (metis inf_eq sup_comm)
 
 lemma inf_assoc: "x \<sqinter> (y \<sqinter> z) = x \<sqinter> y \<sqinter> z"
 by (metis dbl_neg inf_eq sup_assoc)
 
 lemma inf_sup_distrib1: "x \<sqinter> (y \<squnion> z) = (x \<sqinter> y) \<squnion> (x \<sqinter> z)"
 proof -
   from partition have 
   "x \<sqinter> (y \<squnion> z) = x \<sqinter> (y \<squnion> z) \<sqinter> y \<squnion> x \<sqinter> (y \<squnion> z) \<sqinter> -y" ..
   also from inf_assoc have
   "\<dots> = x \<sqinter> ((y \<squnion> z) \<sqinter> y) \<squnion> x \<sqinter> (y \<squnion> z) \<sqinter> -y" by simp
   also from inf_comm have
   "\<dots> = x \<sqinter> (y \<sqinter> (y \<squnion> z)) \<squnion> x \<sqinter> (y \<squnion> z) \<sqinter> -y" by simp
   also from inf_absorb have
   "\<dots> = (x \<sqinter> y) \<squnion> (x \<sqinter> (y \<squnion> z) \<sqinter> -y)" by simp
   also from partition have
   "\<dots> = ((x \<sqinter> y \<sqinter> z) \<squnion> (x \<sqinter> y \<sqinter> -z)) \<squnion> 
        ((x \<sqinter> (y \<squnion> z) \<sqinter> -y \<sqinter> z) \<squnion> (x \<sqinter> (y \<squnion> z) \<sqinter> -y \<sqinter> -z))" by simp
   also from inf_assoc have
   "\<dots> = ((x \<sqinter> y \<sqinter> z) \<squnion> (x \<sqinter> y \<sqinter> -z)) \<squnion> 
        ((x \<sqinter> ((y \<squnion> z) \<sqinter> (-y \<sqinter> z))) \<squnion> (x \<sqinter> ((y \<squnion> z) \<sqinter> (-y \<sqinter> -z))))" by simp
   also from demorgans2 have
   "\<dots> = ((x \<sqinter> y \<sqinter> z) \<squnion> (x \<sqinter> y \<sqinter> -z)) \<squnion> 
        ((x \<sqinter> ((y \<squnion> z) \<sqinter> (-y \<sqinter> z))) \<squnion> (x \<sqinter> ((y \<squnion> z) \<sqinter> -(y \<squnion> z))))" by simp
   also from inf_compl have
   "\<dots> = ((x \<sqinter> y \<sqinter> z) \<squnion> (x \<sqinter> y \<sqinter> -z)) \<squnion> 
        ((x \<sqinter> ((y \<squnion> z) \<sqinter> (-y \<sqinter> z))) \<squnion> (x \<sqinter> \<bottom>))" by simp
   also from inf_nil have
   "\<dots> = ((x \<sqinter> y \<sqinter> z) \<squnion> (x \<sqinter> y \<sqinter> -z)) \<squnion> 
        ((x \<sqinter> ((y \<squnion> z) \<sqinter> (-y \<sqinter> z))) \<squnion> \<bottom>)" by simp
   also from sup_idem have
   "\<dots> = ((x \<sqinter> y \<sqinter> z) \<squnion> (x \<sqinter> y \<sqinter> z) \<squnion> (x \<sqinter> y \<sqinter> -z)) \<squnion> 
        ((x \<sqinter> ((y \<squnion> z) \<sqinter> (-y \<sqinter> z))) \<squnion> \<bottom>)" by simp
   also from sup_ident have
   "\<dots> = ((x \<sqinter> y \<sqinter> z) \<squnion> (x \<sqinter> y \<sqinter> z) \<squnion> (x \<sqinter> y \<sqinter> -z)) \<squnion> 
        (x \<sqinter> ((y \<squnion> z) \<sqinter> (-y \<sqinter> z)))" by simp
   also from inf_comm have
   "\<dots> = ((x \<sqinter> y \<sqinter> z) \<squnion> (x \<sqinter> y \<sqinter> z) \<squnion> (x \<sqinter> y \<sqinter> -z)) \<squnion> 
        (x \<sqinter> ((-y \<sqinter> z) \<sqinter> (y \<squnion> z)))" by simp
   also from sup_comm have
   "\<dots> = ((x \<sqinter> y \<sqinter> z) \<squnion> (x \<sqinter> y \<sqinter> z) \<squnion> (x \<sqinter> y \<sqinter> -z)) \<squnion> 
        (x \<sqinter> ((-y \<sqinter> z) \<sqinter> (z \<squnion> y)))" by simp
   also from inf_assoc have
   "\<dots> = ((x \<sqinter> y \<sqinter> z) \<squnion> (x \<sqinter> (y \<sqinter> z)) \<squnion> (x \<sqinter> y \<sqinter> -z)) \<squnion> 
        (x \<sqinter> (-y \<sqinter> (z \<sqinter> (z \<squnion> y))))" by simp
   also from inf_absorb have
   "\<dots> = ((x \<sqinter> y \<sqinter> z) \<squnion> (x \<sqinter> (y \<sqinter> z)) \<squnion> (x \<sqinter> y \<sqinter> -z)) \<squnion> (x \<sqinter> (-y \<sqinter> z))" 
      by simp
   also from inf_comm have
   "\<dots> = ((x \<sqinter> y \<sqinter> z) \<squnion> (x \<sqinter> (z \<sqinter> y)) \<squnion> (x \<sqinter> y \<sqinter> -z)) \<squnion> (x \<sqinter> (z \<sqinter> -y))" 
      by simp
   also from sup_assoc have
   "\<dots> = ((x \<sqinter> y \<sqinter> z) \<squnion> ((x \<sqinter> (z \<sqinter> y)) \<squnion> (x \<sqinter> y \<sqinter> -z))) \<squnion> (x \<sqinter> (z \<sqinter> -y))" 
      by simp
   also from sup_comm have
   "\<dots> = ((x \<sqinter> y \<sqinter> z) \<squnion> ((x \<sqinter> y \<sqinter> -z) \<squnion> (x \<sqinter> (z \<sqinter> y)))) \<squnion> (x \<sqinter> (z \<sqinter> -y))" 
      by simp
   also from sup_assoc have
   "\<dots> = ((x \<sqinter> y \<sqinter> z) \<squnion> (x \<sqinter> y \<sqinter> -z)) \<squnion> ((x \<sqinter> (z \<sqinter> y)) \<squnion> (x \<sqinter> (z \<sqinter> -y)))" 
      by simp
   also from inf_assoc have
   "\<dots> = ((x \<sqinter> y \<sqinter> z) \<squnion> (x \<sqinter> y \<sqinter> -z)) \<squnion> ((x \<sqinter> z \<sqinter> y) \<squnion> (x \<sqinter> z \<sqinter> -y))" by simp
   also from partition have "\<dots> = (x \<sqinter> y) \<squnion> (x \<sqinter> z)" by simp
   finally show ?thesis by simp
 qed
 
 lemma sup_inf_distrib1:
   "x \<squnion> (y \<sqinter> z) = (x \<squnion> y) \<sqinter> (x \<squnion> z)"
 proof -
   from dbl_neg have
   "x \<squnion> (y \<sqinter> z) = -(-(-(-x) \<squnion> (y \<sqinter> z)))" by simp
   also from inf_eq have
   "\<dots> = -(-x \<sqinter> (-y \<squnion> -z))" by simp
   also from inf_sup_distrib1 have
   "\<dots> = -((-x \<sqinter> -y) \<squnion> (-x \<sqinter> -z))" by simp
   also from demorgans2 have
   "\<dots> = -(-x \<sqinter> -y) \<sqinter> -(-x \<sqinter> -z)" by simp
   also from demorgans1 have
   "\<dots> = (-(-x) \<squnion> -(-y)) \<sqinter> (-(-x) \<squnion> -(-z))" by simp
   also from dbl_neg have
   "\<dots> = (x \<squnion> y) \<sqinter> (x \<squnion> z)" by simp
   finally show ?thesis by simp
 qed
 
 lemma huntington_is_boolean_II:
    "class.boolean_algebra_II uminus (\<sqinter>) (\<squnion>) \<bottom> \<top>"
 apply unfold_locales
 apply (metis inf_comm inf_assoc sup_absorb 
              inf_absorb sup_inf_distrib1 
              sup_compl inf_compl)+
 done
 
 lemma huntington_is_boolean:
    "class.boolean_algebra minus uminus (\<sqinter>) (\<sqsubseteq>) (\<sqsubset>) (\<squnion>) \<bottom> \<top>"
 proof -
   interpret boolean_II: 
     boolean_algebra_II uminus "(\<sqinter>)" "(\<squnion>)" \<bottom> \<top>
       by (fact huntington_is_boolean_II)
   show ?thesis by (simp add: boolean_II.boolean_II_is_boolean)
 qed
 end
 
 subsection \<open>Robbins' Algebra\<close>
 
-context Lattices.boolean_algebra begin
+context boolean_algebra begin
 lemma boolean_is_robbins:
   "class.robbins_algebra uminus inf sup bot top"
 apply unfold_locales
 apply (metis sup_assoc sup_commute compl_inf double_compl sup_compl_top 
              inf_compl_bot diff_eq sup_bot_right sup_inf_distrib1)+
 done
 end
 
 context boolean_algebra_II begin
 lemma boolean_II_is_robbins:
   "class.robbins_algebra uminus inf sup bot top"
 proof -
   interpret boolean: 
-    Lattices.boolean_algebra minus uminus "(\<sqinter>)" "(\<sqsubseteq>)" "(\<sqsubset>)" "(\<squnion>)" \<bottom> \<top>
+    boolean_algebra minus uminus "(\<sqinter>)" "(\<sqsubseteq>)" "(\<sqsubset>)" "(\<squnion>)" \<bottom> \<top>
       by (fact boolean_II_is_boolean)
   show ?thesis by (simp add: boolean.boolean_is_robbins)
 qed
 end
 
 context huntington_algebra begin
 lemma huntington_is_robbins:
   "class.robbins_algebra uminus inf sup bot top"
 proof -
   interpret boolean: 
-    Lattices.boolean_algebra minus uminus "(\<sqinter>)" "(\<sqsubseteq>)" "(\<sqsubset>)" "(\<squnion>)" \<bottom> \<top>
+    boolean_algebra minus uminus "(\<sqinter>)" "(\<sqsubseteq>)" "(\<sqsubset>)" "(\<squnion>)" \<bottom> \<top>
       by (fact huntington_is_boolean)
   show ?thesis by (simp add: boolean.boolean_is_robbins)
 qed
 end
 
 text \<open>Before diving into the proof that the Robbins algebra is Boolean,
         we shall present some shorthand machinery\<close>
 
 context common_algebra begin
 
 (* Iteration Machinery/Shorthand *)
 
 primrec copyp :: "nat \<Rightarrow> 'a \<Rightarrow> 'a" (infix "\<otimes>" 80)
 where 
   copyp_0:   "0 \<otimes> x = x"
 | copyp_Suc: "(Suc k) \<otimes> x = (k \<otimes> x) \<squnion> x"
 
 no_notation 
   Product_Type.Times (infixr "\<times>" 80)
 
 primrec copy :: "nat \<Rightarrow> 'a \<Rightarrow> 'a" (infix "\<times>" 85)
 where
   "0 \<times> x = x"
 | "(Suc k) \<times> x = k \<otimes> x"
 
 (* Theorems for translating shorthand into syntax *)
 
 lemma one:  "1 \<times> x = x"
 proof -
   have       "1 = Suc(0)" by arith 
   hence      "1 \<times> x = Suc(0) \<times> x" by metis
   also have  "\<dots> = x" by simp
   finally show ?thesis by simp
 qed
 
 lemma two:  "2 \<times> x = x \<squnion> x"
 proof -
   have       "2 = Suc(Suc(0))" by arith 
   hence      "2 \<times> x = Suc(Suc(0)) \<times> x" by metis
   also have  "\<dots> = x \<squnion> x" by simp
   finally show ?thesis by simp
 qed
 
 lemma three:  "3 \<times> x = x \<squnion> x \<squnion> x"
 proof -
    have       "3 = Suc(Suc(Suc(0)))" by arith 
    hence      "3 \<times> x = Suc(Suc(Suc(0))) \<times> x" by metis
    also have  "\<dots> = x \<squnion> x \<squnion> x" by simp
    finally show ?thesis by simp
 qed
 
 lemma four:  "4 \<times> x = x \<squnion> x \<squnion> x \<squnion> x"
 proof -
   have       "4 = Suc(Suc(Suc(Suc(0))))" by arith 
   hence      "4 \<times> x = Suc(Suc(Suc(Suc(0)))) \<times> x" by metis
   also have  "\<dots> = x \<squnion> x \<squnion> x \<squnion> x" by simp
   finally show ?thesis by simp
 qed
 
 lemma five:  "5 \<times> x = x \<squnion> x \<squnion> x \<squnion> x \<squnion> x"
 proof -
   have       "5 = Suc(Suc(Suc(Suc(Suc(0)))))" by arith 
   hence      "5 \<times> x = Suc(Suc(Suc(Suc(Suc(0))))) \<times> x" by metis
   also have  "\<dots> = x \<squnion> x \<squnion> x \<squnion> x \<squnion> x" by simp
   finally show ?thesis by simp
 qed
 
 lemma six:  "6 \<times> x = x \<squnion> x \<squnion> x \<squnion> x \<squnion> x \<squnion> x"
 proof -
   have       "6 = Suc(Suc(Suc(Suc(Suc(Suc(0))))))" by arith 
   hence      "6 \<times> x = Suc(Suc(Suc(Suc(Suc(Suc(0)))))) \<times> x" by metis
   also have  "\<dots> = x \<squnion> x \<squnion> x \<squnion> x \<squnion> x \<squnion> x" by simp
   finally show ?thesis by simp
 qed
 
 (* Distribution Laws *)
 
 lemma copyp_distrib: "k \<otimes> (x \<squnion> y) = (k \<otimes> x) \<squnion> (k \<otimes> y)"
 proof (induct k)
   case 0 show ?case by simp
   case Suc thus ?case by (simp, metis sup_assoc sup_comm)
 qed
 
 corollary copy_distrib: "k \<times> (x \<squnion> y) = (k \<times> x) \<squnion> (k \<times> y)"
 by (induct k, (simp add: sup_assoc sup_comm copyp_distrib)+)
 
 lemma copyp_arith: "(k + l + 1) \<otimes> x = (k \<otimes> x) \<squnion> (l \<otimes> x)"
 proof (induct l)
   case 0 have "k + 0 + 1 = Suc(k)" by arith
     thus ?case by simp
   case (Suc l) note ind_hyp = this
     have "k + Suc(l) + 1 = Suc(k + l + 1)" by arith+
     hence "(k + Suc(l) + 1) \<otimes> x = (k + l + 1) \<otimes> x \<squnion> x" by (simp add: ind_hyp)
     also from ind_hyp have 
           "\<dots> = (k \<otimes> x) \<squnion> (l \<otimes> x) \<squnion> x" by simp
     also note sup_assoc
     finally show ?case by simp
 qed
 
 lemma copy_arith: 
    assumes "k \<noteq> 0" and "l \<noteq> 0"
      shows "(k + l) \<times> x = (k \<times> x) \<squnion> (l \<times> x)"
 using assms
 proof -
   from assms have "\<exists> k'. Suc(k') = k" 
               and "\<exists> l'. Suc(l') = l" by arith+
   from this obtain k' l' where A: "Suc(k') = k"
                            and B: "Suc(l') = l" by fast+
   from this have A1: "k \<times> x = k' \<otimes> x"
              and B1: "l \<times> x = l' \<otimes> x" by fastforce+
   from A B have "k + l = Suc(k' + l' + 1)" by arith
   hence "(k + l) \<times> x = (k' + l' + 1) \<otimes> x" by simp
   also from copyp_arith have  
         "\<dots> = k' \<otimes> x \<squnion> l' \<otimes> x" by fast
   also from A1 B1 have
         "\<dots> = k \<times> x \<squnion> l \<times> x" by fastforce
   finally show ?thesis by simp
 qed
 
 end
 
 text \<open>The theorem asserting all Robbins algebras are Boolean  
        comes in 6 movements.
        
        First: The Winker identity is proved.
 
        Second: Idempotence for a particular object is proved.  
        Note that falsum is defined in terms of this object.
 
        Third: An identity law for falsum is derived.
 
        Fourth: Idempotence for supremum is derived.
 
        Fifth: The double negation law is proven
 
        Sixth: Robbin's algebras are proven to be Huntington Algebras.\<close>
 
 context robbins_algebra begin
 
 definition secret_object2 :: "'a" ("\<alpha>") where
   "\<alpha> = -(-(\<iota> \<squnion> \<iota> \<squnion> \<iota>) \<squnion> \<iota>)"
 definition secret_object3 :: "'a" ("\<beta>") where
   "\<beta> = \<iota> \<squnion> \<iota>"
 definition secret_object4 :: "'a" ("\<delta>") where
   "\<delta> = \<beta> \<squnion> (-(\<alpha> \<squnion> -\<beta>) \<squnion> -(\<alpha> \<squnion> -\<beta>))"
 definition secret_object5 :: "'a" ("\<gamma>") where
   "\<gamma> = \<delta> \<squnion> -(\<delta> \<squnion> -\<delta>)"
 definition winker_object :: "'a" ("\<rho>") where
   "\<rho> = \<gamma> \<squnion> \<gamma> \<squnion> \<gamma>"
 definition fake_bot :: "'a" ("\<bottom>\<bottom>") where
   "\<bottom>\<bottom> = -(\<rho> \<squnion> -\<rho>)"
 
 (* Towards Winker's Identity *)
 
 (* These lemmas are due to Alan Mann *)
 
 lemma robbins2: "y = -(-(-x \<squnion> y) \<squnion> -(x \<squnion> y))"
   by (metis robbins sup_comm)
 
 lemma mann0: "-(x \<squnion> y) = -(-(-(x \<squnion> y) \<squnion> -x \<squnion> y) \<squnion> y)"
   by (metis robbins sup_comm sup_assoc)
 
 lemma mann1: "-(-x \<squnion> y) = -(-(-(-x \<squnion> y) \<squnion> x \<squnion> y) \<squnion> y)"
   by (metis robbins sup_comm sup_assoc)
 
 lemma mann2: "y = -(-(-(-x \<squnion> y) \<squnion> x \<squnion> y \<squnion> y) \<squnion> -(-x \<squnion> y))"
   by (metis mann1 robbins sup_comm sup_assoc)
 
 lemma mann3: "z = -(-(-(-(-x \<squnion> y) \<squnion> x \<squnion> y \<squnion> y) \<squnion> -(-x \<squnion> y) \<squnion> z) \<squnion> -(y \<squnion> z))"
 proof -
   let ?w = "-(-(-x \<squnion> y) \<squnion> x \<squnion> y \<squnion> y) \<squnion> -(-x \<squnion> y)"
   from robbins[where x="z" and y="?w"] sup_comm mann2 
   have "z = -(-(y \<squnion> z) \<squnion> -(?w \<squnion> z))" by metis
   thus ?thesis by (metis sup_comm)
 qed
 
 lemma mann4: "-(y \<squnion> z) = 
   -(-(-(-(-x \<squnion> y) \<squnion> x \<squnion> y \<squnion> y) \<squnion> -(-x \<squnion> y) \<squnion> -(y \<squnion> z) \<squnion> z) \<squnion> z)"
 proof -
  from robbins2[where x="-(-(-x \<squnion> y) \<squnion> x \<squnion> y \<squnion> y) \<squnion> -(-x \<squnion> y) \<squnion> z" 
                  and y="-(y \<squnion> z)"]
       mann3[where x="x" and y="y" and z="z"]
  have "-(y \<squnion> z) = 
        -(z \<squnion> -(-(-(-x \<squnion> y) \<squnion> x \<squnion> y \<squnion> y) \<squnion> -(-x \<squnion> y) \<squnion> z \<squnion> -(y \<squnion> z)))" 
    by metis
  with sup_comm sup_assoc show ?thesis by metis
 qed
 
 lemma mann5: "u = 
 -(-(-(-(-(-x \<squnion> y) \<squnion> x \<squnion> y \<squnion> y) \<squnion> 
       -(-x \<squnion> y) \<squnion> - (y \<squnion> z) \<squnion> z) \<squnion> z \<squnion> u) \<squnion> 
   -(-(y \<squnion> z) \<squnion> u))"
 using robbins2[where x="-(-(-(-x \<squnion> y) \<squnion> x \<squnion> y \<squnion> y) \<squnion> 
                           -(-x \<squnion> y) \<squnion> -(y \<squnion> z) \<squnion> z) \<squnion> z"
                  and y="u"]
       mann4[where x=x and y=y and z=z] 
       sup_comm
 by metis
 
 lemma mann6: 
 "-(- 3\<times>x \<squnion> x) = -(-(-(- 3\<times>x \<squnion> x) \<squnion> - 3\<times>x) \<squnion> -(-(- 3\<times>x \<squnion> x) \<squnion> 5\<times>x))"
 proof -
   have "3+2=(5::nat)" and "3\<noteq>(0::nat)" and "2\<noteq>(0::nat)" by arith+
   with copy_arith have \<heartsuit>: "3\<times>x \<squnion> 2\<times>x = 5\<times>x" by metis
   let ?p = "-(- 3\<times>x \<squnion> x)"
   { fix q
     from sup_comm have
     "-(q \<squnion> 5\<times>x) = -(5\<times>x \<squnion> q)" by metis
     also from \<heartsuit> mann0[where x="3\<times>x" and y="q \<squnion> 2\<times>x"] sup_assoc sup_comm have
     "\<dots> = -(-(-(3\<times>x \<squnion> (q \<squnion> 2\<times>x)) \<squnion> - 3\<times>x \<squnion> (q \<squnion> 2\<times>x)) \<squnion> (q \<squnion> 2\<times>x))"
       by metis
     also from sup_assoc have
     "\<dots> = -(-(-((3\<times>x \<squnion> q) \<squnion> 2\<times>x) \<squnion> - 3\<times>x \<squnion> (q \<squnion> 2\<times>x)) \<squnion> (q \<squnion> 2\<times>x))" by metis
     also from sup_comm have
     "\<dots> = -(-(-((q \<squnion> 3\<times>x) \<squnion> 2\<times>x) \<squnion> - 3\<times>x \<squnion> (q \<squnion> 2\<times>x)) \<squnion> (q \<squnion> 2\<times>x))" by metis
     also from sup_assoc have
     "\<dots> = -(-(-(q \<squnion> (3\<times>x \<squnion> 2\<times>x)) \<squnion> - 3\<times>x \<squnion> (q \<squnion> 2\<times>x)) \<squnion> (q \<squnion> 2\<times>x))" by metis
     also from \<heartsuit> have
     "\<dots> = -(-(-(q \<squnion> 5\<times>x) \<squnion> - 3\<times>x \<squnion> (q \<squnion> 2\<times>x)) \<squnion> (q \<squnion> 2\<times>x))" by metis
     also from sup_assoc have
     "\<dots> = -(-(-(q \<squnion> 5\<times>x) \<squnion> (- 3\<times>x \<squnion> q) \<squnion> 2\<times>x) \<squnion> (q \<squnion> 2\<times>x))" by metis
     also from sup_comm have
     "\<dots> = -(-(-(q \<squnion> 5\<times>x) \<squnion> (q \<squnion> - 3\<times>x) \<squnion> 2\<times>x) \<squnion> (2\<times>x \<squnion> q))" by metis
     also from sup_assoc have
     "\<dots> = -(-(-(q \<squnion> 5\<times>x) \<squnion> q \<squnion> - 3\<times>x \<squnion> 2\<times>x) \<squnion> 2\<times>x \<squnion> q)" by metis
     finally have 
     "-(q \<squnion> 5\<times>x) = -(-(-(q \<squnion> 5\<times>x) \<squnion> q \<squnion> - 3\<times>x \<squnion> 2\<times>x) \<squnion> 2\<times>x \<squnion> q)" by simp
   } hence \<spadesuit>: 
     "-(?p \<squnion> 5\<times>x) = -(-(-(?p \<squnion> 5\<times>x) \<squnion> ?p \<squnion> - 3\<times>x \<squnion> 2\<times>x) \<squnion> 2\<times>x \<squnion> ?p)"
     by simp
 
   from mann5[where x="3\<times>x" and y="x" and z="2\<times>x" and u="?p"] 
        sup_assoc three[where x=x] five[where x=x] have
   "?p = 
    -(-(-(-(?p \<squnion> 5\<times>x) \<squnion> ?p \<squnion> -(x \<squnion> 2\<times>x) \<squnion> 2\<times>x) \<squnion> 2\<times>x \<squnion> ?p) \<squnion>
      -(-(x \<squnion> 2\<times>x) \<squnion> ?p))" by metis
   also from sup_comm have
   "\<dots> = 
    -(-(-(-(?p \<squnion> 5\<times>x) \<squnion> ?p \<squnion> -(2\<times>x \<squnion> x) \<squnion> 2\<times>x) \<squnion> 2\<times>x \<squnion> ?p) \<squnion>
      -(-(2\<times>x \<squnion> x) \<squnion> ?p))" by metis
   also from two[where x=x] three[where x=x] have
   "\<dots> = 
    -(-(-(-(?p \<squnion> 5\<times>x) \<squnion> ?p \<squnion> - 3\<times>x \<squnion> 2\<times>x) \<squnion> 2\<times>x \<squnion> ?p) \<squnion>
      -(- 3\<times>x \<squnion> ?p))" by metis
   also from \<spadesuit> have "\<dots> = -(-(?p \<squnion> 5\<times>x) \<squnion> -(- 3\<times>x \<squnion> ?p))" by simp
   also from sup_comm have "\<dots> = -(-(?p \<squnion> 5\<times>x) \<squnion> -(?p \<squnion> - 3\<times>x))" by simp
   also from sup_comm have "\<dots> = -(-(?p \<squnion> - 3\<times>x) \<squnion> -(?p \<squnion> 5\<times>x))" by simp
   finally show ?thesis .
 qed
 
 lemma mann7:
 "- 3\<times>x = -(-(- 3\<times>x \<squnion> x) \<squnion> 5\<times>x)"
 proof -
   let ?p = "-(- 3\<times>x \<squnion> x)"
   let ?q = "?p \<squnion> - 3\<times>x"
   let ?r = "-(?p \<squnion> 5\<times>x)"
   from robbins2[where x="?q"
                   and y="?r"]
        mann6[where x=x]
   have "?r = - (?p \<squnion> - (?q \<squnion> ?r))" by simp
   also from sup_comm have "\<dots> = - (- (?q \<squnion> ?r) \<squnion> ?p)" by simp
   also from sup_comm have "\<dots> = - (- (?r \<squnion> ?q) \<squnion> ?p)" by simp
   finally have \<spadesuit>: "?r = - (- (?r \<squnion> ?q) \<squnion> ?p)" .
   from mann3[where x="3\<times>x" and y="x" and z="- 3\<times>x"]
        sup_comm have
        "- 3\<times>x = -(-(-(?p \<squnion> 3\<times>x \<squnion> x \<squnion> x) \<squnion> ?p \<squnion> - 3\<times>x) \<squnion> ?p)" by metis
   also from sup_assoc have
        "\<dots> = -(-(-(?p \<squnion> (3\<times>x \<squnion> x \<squnion> x)) \<squnion> ?q) \<squnion> ?p)" by metis
   also from three[where x=x] five[where x=x] have
        "\<dots> = -(-(?r \<squnion> ?q) \<squnion> ?p)" by metis
   finally have "- 3\<times>x = -(-(?r \<squnion> ?q) \<squnion> ?p)" by metis
   with \<spadesuit> show ?thesis by simp
 qed
 
 lemma mann8:
 "-(- 3\<times>x \<squnion> x) \<squnion> 2\<times>x = -(-(-(- 3\<times>x \<squnion> x) \<squnion> - 3\<times>x \<squnion> 2\<times>x) \<squnion> - 3\<times>x)"
 (is "?lhs = ?rhs")
 proof -
   let ?p = "-(- 3\<times>x \<squnion> x)"
   let ?q = "?p \<squnion> 2\<times>x"
   let ?r = "3\<times>x"
   have "3+2=(5::nat)" and "3\<noteq>(0::nat)" and "2\<noteq>(0::nat)" by arith+
   with copy_arith have \<heartsuit>: "3\<times>x \<squnion> 2\<times>x = 5\<times>x" by metis
   from robbins2[where x="?r" and y="?q"] and sup_assoc
   have "?q = -(-(- 3\<times>x \<squnion> ?q) \<squnion> -(3\<times>x \<squnion> ?p \<squnion> 2\<times>x))" by metis
   also from sup_comm have 
        "\<dots> = -(-(?q \<squnion> - 3\<times>x) \<squnion> -(?p \<squnion> 3\<times>x \<squnion> 2\<times>x))" by metis
   also from \<heartsuit> sup_assoc have
        "\<dots> = -(-(?q \<squnion> - 3\<times>x) \<squnion> -(?p \<squnion> 5\<times>x))" by metis
   also from mann7[where x=x] have 
        "\<dots> = -(-(?q \<squnion> - 3\<times>x) \<squnion> - 3\<times>x)" by metis
   also from sup_assoc have
        "\<dots> = -(-(?p \<squnion> (2\<times>x  \<squnion> - 3\<times>x)) \<squnion> - 3\<times>x)" by metis
   also from sup_comm have
        "\<dots> = -(-(?p \<squnion> (- 3\<times>x  \<squnion> 2\<times>x)) \<squnion> - 3\<times>x)" by metis
   also from sup_assoc have
        "\<dots> = ?rhs" by metis
   finally show ?thesis by simp
 qed
 
 lemma mann9: "x = -(-(- 3\<times>x \<squnion> x) \<squnion> - 3\<times>x )"
 proof -
   let ?p = "-(- 3\<times>x \<squnion> x)"
   let ?q = "?p \<squnion> 4\<times>x"
   have "4+1=(5::nat)" and "1\<noteq>(0::nat)" and "4\<noteq>(0::nat)" by arith+
   with copy_arith one have \<heartsuit>: "4\<times>x \<squnion> x = 5\<times>x" by metis
   with sup_assoc robbins2[where y=x and x="?q"]
   have "x = -(-(-?q \<squnion> x) \<squnion> -(?p \<squnion> 5\<times>x))" by metis
   with mann7 have "x = -(-(-?q \<squnion> x) \<squnion> - 3\<times>x)" by metis
   moreover
   have "3+1=(4::nat)" and "1\<noteq>(0::nat)" and "3\<noteq>(0::nat)" by arith+
   with copy_arith one have \<spadesuit>: "3\<times>x \<squnion> x = 4\<times>x" by metis
   with mann1[where x="3\<times>x" and y="x"] sup_assoc have
   "-(-?q \<squnion> x) = ?p" by metis
   ultimately show ?thesis by simp
 qed
 
 lemma mann10: "y = -(-(-(- 3\<times>x \<squnion> x) \<squnion> - 3\<times>x \<squnion> y) \<squnion> -(x \<squnion> y))"
 using robbins2[where x="-(- 3\<times>x \<squnion> x) \<squnion> - 3\<times>x" and y=y]
       mann9[where x=x]
       sup_comm 
 by metis
 
 theorem mann: "2\<times>x = -(- 3\<times>x \<squnion> x) \<squnion> 2\<times>x"
 using mann10[where x=x and y="2\<times>x"]
       mann8[where x=x]
       two[where x=x] three[where x=x] sup_comm 
 by metis
 
 corollary winkerr: "\<alpha> \<squnion> \<beta> = \<beta>"
 using mann secret_object2_def secret_object3_def two three
 by metis
 
 corollary winker: "\<beta> \<squnion> \<alpha> = \<beta>"
   by (metis winkerr sup_comm)
 
 corollary multi_winkerp: "\<beta> \<squnion> k \<otimes> \<alpha> = \<beta>"
   by (induct k, (simp add: winker sup_comm sup_assoc)+)
 
 corollary multi_winker: "\<beta> \<squnion> k \<times> \<alpha> = \<beta>"
   by (induct k, (simp add: multi_winkerp winker sup_comm sup_assoc)+)
 
 (* Towards Idempotence *)
 
 lemma less_eq_introp: 
 "-(x \<squnion> -(y \<squnion> z)) = -(x \<squnion> y \<squnion> -z) \<Longrightarrow> y \<sqsubseteq> x"
   by (metis robbins sup_assoc less_eq_def
             sup_comm[where x=x and y=y])
 
 corollary less_eq_intro:
 "-(x \<squnion> -(y \<squnion> z)) = -(x \<squnion> y \<squnion> -z) \<Longrightarrow> x \<squnion> y = x"
   by (metis less_eq_introp less_eq_def sup_comm)
 
 lemma eq_intro: 
 "-(x \<squnion> -(y \<squnion> z)) = -(y \<squnion> -(x \<squnion> z)) \<Longrightarrow> x = y"
   by (metis robbins sup_assoc sup_comm)
 
 lemma copyp0:
    assumes "-(x \<squnion> -y) = z"
      shows "-(x \<squnion> -(y \<squnion> k \<otimes> (x \<squnion> z))) = z"
 using assms
 proof (induct k)
   case 0 show ?case
      by (simp, metis assms robbins sup_assoc sup_comm)
   case Suc note ind_hyp = this
   show ?case
      by (simp, metis ind_hyp robbins sup_assoc sup_comm)
 qed
 
 lemma copyp1:
    assumes "-(-(x \<squnion> -y) \<squnion> -y) = x"
      shows "-(y \<squnion> k \<otimes> (x \<squnion> -(x \<squnion> -y))) = -y"
 using assms
 proof -
   let ?z = "-(x \<squnion> - y)"
   let ?ky = "y \<squnion> k \<otimes> (x \<squnion> ?z)"
   have "-(x \<squnion> -?ky) = ?z" by (simp add: copyp0)
   hence "-(-?ky \<squnion> -(-y \<squnion> ?z)) = ?z" by (metis assms sup_comm)
   also have "-(?z \<squnion> -?ky) = x" by (metis assms copyp0 sup_comm)
   hence "?z = -(-y \<squnion> -(-?ky \<squnion> ?z))" by (metis sup_comm)
   finally show ?thesis by (metis eq_intro)
 qed
 
 corollary copyp2: 
    assumes "-(x \<squnion> y) = -y"
      shows "-(y \<squnion> k \<otimes> (x \<squnion> -(x \<squnion> -y))) = -y"
    by (metis assms robbins sup_comm copyp1)
 
 lemma two_threep:
    assumes "-(2 \<times> x \<squnion> y) = -y"
        and "-(3 \<times> x \<squnion> y) = -y" 
      shows "2 \<times> x \<squnion> y = 3 \<times> x \<squnion> y"
 using assms
 proof -
   from assms two three have 
      A: "-(x \<squnion> x \<squnion> y) = -y" and
      B: "-(x \<squnion> x \<squnion> x \<squnion> y) = -y"  by simp+
   with sup_assoc
        copyp2[where x="x" and y="x \<squnion> x \<squnion> y" and k="0"]
   have "-(x \<squnion> x \<squnion> y \<squnion> x \<squnion> -(x \<squnion> -y)) = -y" by simp
   moreover 
   from sup_comm sup_assoc A B
        copyp2[where x="x \<squnion> x" and y="y" and k="0"] 
   have "-(y \<squnion> x \<squnion> x \<squnion> -(x \<squnion> x \<squnion> -y)) = -y" by fastforce
   with sup_comm sup_assoc 
   have "-(x \<squnion> x \<squnion> y \<squnion> -(x \<squnion> (x \<squnion> -y))) = -y" by metis
   ultimately have 
     "-(x \<squnion> x \<squnion> y \<squnion> -(x \<squnion> (x \<squnion> -y))) = -(x \<squnion> x \<squnion> y \<squnion> x \<squnion> -(x \<squnion> -y))" by simp
   with less_eq_intro have "x \<squnion> x \<squnion> y = x \<squnion> x \<squnion> y \<squnion> x" by metis
   with sup_comm sup_assoc two three show ?thesis by metis
 qed
 
 lemma two_three:
    assumes "-(x \<squnion> y) = -y \<or> -(-(x \<squnion> -y) \<squnion> -y) = x"
      shows "y \<squnion> 2 \<times> (x \<squnion> -(x \<squnion> -y)) = y \<squnion> 3 \<times> (x \<squnion> -(x \<squnion> -y))"
            (is "y \<squnion> ?z2 = y \<squnion> ?z3")
 using assms
 proof
     assume "-(x \<squnion> y) = -y"
       with copyp2[where k="Suc(0)"] 
            copyp2[where k="Suc(Suc(0))"]
            two three
       have "-(y \<squnion> ?z2) = -y" and "-(y \<squnion> ?z3) = -y" by simp+
       with two_threep sup_comm show ?thesis by metis
   next 
     assume "-(-(x \<squnion> -y) \<squnion> -y) = x"
       with copyp1[where k="Suc(0)"] 
            copyp1[where k="Suc(Suc(0))"]
            two three
       have "-(y \<squnion> ?z2) = -y" and "-(y \<squnion> ?z3) = -y" by simp+
       with two_threep sup_comm show ?thesis by metis
 qed
 
 lemma sup_idem: "\<rho> \<squnion> \<rho> = \<rho>"
 proof -
     from winkerr two 
          copyp2[where x="\<alpha>" and y="\<beta>" and k="Suc(0)"] have
     "-\<beta> = -(\<beta> \<squnion> 2 \<times> (\<alpha> \<squnion> -(\<alpha> \<squnion> -\<beta>)))" by simp
     also from copy_distrib sup_assoc have
     "\<dots> = -(\<beta> \<squnion> 2 \<times> \<alpha> \<squnion> 2 \<times> (-(\<alpha> \<squnion> -\<beta>)))" by simp
     also from sup_assoc secret_object4_def two
               multi_winker[where k="2"] have
     "\<dots> = -\<delta>" by metis
     finally have "-\<beta> = -\<delta>" by simp
     with secret_object4_def sup_assoc three have
     "\<delta> \<squnion> -(\<alpha> \<squnion> -\<delta>) = \<beta> \<squnion> 3 \<times> (-(\<alpha> \<squnion> -\<beta>))" by simp
     also from copy_distrib[where k="3"] 
               multi_winker[where k="3"] 
               sup_assoc have 
     "\<dots> = \<beta> \<squnion> 3 \<times> (\<alpha> \<squnion> -(\<alpha> \<squnion> -\<beta>))" by metis
     also from winker sup_comm two_three[where x="\<alpha>" and y="\<beta>"] have 
     "\<dots> = \<beta> \<squnion> 2 \<times> (\<alpha> \<squnion> -(\<alpha> \<squnion> -\<beta>))" by fastforce
     also from copy_distrib[where k="2"] 
               multi_winker[where k="2"] 
               sup_assoc two secret_object4_def have 
     "\<dots> = \<delta>" by metis
     finally have \<heartsuit>: "\<delta> \<squnion> -(\<alpha> \<squnion> -\<delta>) = \<delta>" by simp
     from secret_object4_def winkerr sup_assoc have 
           "\<alpha> \<squnion> \<delta> = \<delta>" by metis
     hence "\<delta> \<squnion> \<alpha> = \<delta>" by (metis sup_comm)
     hence "-(-(\<delta> \<squnion> -\<delta>) \<squnion> -\<delta>) = -(-(\<delta> \<squnion> (\<alpha> \<squnion> -\<delta>)) \<squnion> -\<delta>)" by (metis sup_assoc)
     also from \<heartsuit> have
           "\<dots> = -(-(\<delta> \<squnion> (\<alpha> \<squnion> -\<delta>)) \<squnion> -(\<delta> \<squnion> -(\<alpha> \<squnion> -\<delta>)))" by metis
     also from robbins have
           "\<dots> = \<delta>" by metis
     finally have "-(-(\<delta> \<squnion> -\<delta>) \<squnion> -\<delta>) = \<delta>" by simp
     with two_three[where x="\<delta>" and y="\<delta>"] 
          secret_object5_def sup_comm
     have "3 \<times> \<gamma> \<squnion> \<delta> = 2 \<times> \<gamma> \<squnion> \<delta>" by fastforce
     with secret_object5_def sup_assoc sup_comm have  
          "3 \<times> \<gamma> \<squnion> \<gamma> = 2 \<times> \<gamma> \<squnion> \<gamma>" by fastforce
     with two three four five six have
          "6 \<times> \<gamma> = 3 \<times> \<gamma>" by simp
     moreover have "3 + 3 = (6::nat)" and "3 \<noteq> (0::nat)" by arith+
     moreover note copy_arith[where k="3" and l="3" and x="\<gamma>"]
                   winker_object_def three
     ultimately show ?thesis by simp
 qed
 
 (* Idempotence implies the identity law *)
 
 lemma sup_ident: "x \<squnion> \<bottom>\<bottom> = x"
 proof -
   have I: "\<rho> = -(-\<rho> \<squnion> \<bottom>\<bottom>)"
     by (metis fake_bot_def inf_eq robbins sup_comm sup_idem)
 
   { fix x have "x = -(-(x \<squnion> -\<rho> \<squnion> \<bottom>\<bottom>) \<squnion> -(x \<squnion> \<rho>))"
     by (metis I robbins sup_assoc) }
   note II = this
 
   have III: "-\<rho> = -(-(\<rho> \<squnion> -\<rho> \<squnion> -\<rho>) \<squnion> \<rho>)"
     by (metis robbins[where x="-\<rho>" and y="\<rho> \<squnion> -\<rho>"]
               I sup_comm fake_bot_def)
   hence "\<rho> = -(-(\<rho> \<squnion> -\<rho> \<squnion> -\<rho>) \<squnion> -\<rho>)"
     by (metis robbins[where x="\<rho>" and y="\<rho> \<squnion> -\<rho> \<squnion> -\<rho>"]
               sup_comm[where x="\<rho>" and y="-(\<rho> \<squnion> -\<rho> \<squnion> -\<rho>)"]
               sup_assoc sup_idem)
   hence "-(\<rho> \<squnion> -\<rho> \<squnion> -\<rho>) = \<bottom>\<bottom>"
     by (metis robbins[where x="-(\<rho> \<squnion> -\<rho> \<squnion> -\<rho>)" and y="\<rho>"] 
               III sup_comm fake_bot_def)
   hence "-\<rho> = -(\<rho> \<squnion> \<bottom>\<bottom>)"
     by (metis III sup_comm)
   hence "\<rho> = -(-(\<rho> \<squnion> \<bottom>\<bottom>) \<squnion> -(\<rho> \<squnion> \<bottom>\<bottom> \<squnion> -\<rho>))"
     by (metis II sup_idem sup_comm sup_assoc)
   moreover have "\<rho> \<squnion> \<bottom>\<bottom> = -(-(\<rho> \<squnion> \<bottom>\<bottom>) \<squnion> -(\<rho> \<squnion> \<bottom>\<bottom> \<squnion> -\<rho>))"
     by (metis robbins[where x="\<rho> \<squnion> \<bottom>\<bottom>" and y="\<rho>"] 
               sup_comm[where y="\<rho>"] 
               sup_assoc sup_idem)
   ultimately have "\<rho> = \<rho> \<squnion> \<bottom>\<bottom>" by auto
   hence "x \<squnion> \<bottom>\<bottom> = -(-(x \<squnion> \<rho>) \<squnion> -(x \<squnion> \<bottom>\<bottom> \<squnion> -\<rho>))"
     by (metis robbins[where x="x \<squnion> \<bottom>\<bottom>" and y=\<rho>]
               sup_comm[where x="\<bottom>\<bottom>" and y=\<rho>]
               sup_assoc)
   thus ?thesis by (metis sup_assoc sup_comm II)
 qed
 
 (* The identity law implies double negation *)
 
 lemma dbl_neg: "- (-x) = x"
 proof -
   { fix x have "\<bottom>\<bottom> = -(-x \<squnion> -(-x))"
       by (metis robbins sup_comm sup_ident) 
   } note I = this
 
   { fix x have "-x = -(-(-x \<squnion> -(-(-x))))"
     by (metis I robbins sup_comm sup_ident)
   } note II = this
 
   { fix x have "-(-(-x)) = -(-(-x \<squnion> -(-(-x))))"
     by (metis I II robbins sup_assoc sup_comm sup_ident) 
   } note III = this
 
   show ?thesis by (metis II III robbins)
 qed
 
 (* Double negation implies Huntington's axiom, hence Boolean*)
 
 theorem robbins_is_huntington:
   "class.huntington_algebra uminus (\<sqinter>) (\<squnion>) \<bottom> \<top>"
 apply unfold_locales
 apply (metis dbl_neg robbins sup_comm)
 done
 
 theorem robbins_is_boolean_II:
   "class.boolean_algebra_II uminus (\<sqinter>) (\<squnion>) \<bottom> \<top>"
 proof -
   interpret huntington: 
     huntington_algebra uminus "(\<sqinter>)" "(\<squnion>)" \<bottom> \<top>
       by (fact robbins_is_huntington)
   show ?thesis by (simp add: huntington.huntington_is_boolean_II)
 qed
 
 theorem robbins_is_boolean:
   "class.boolean_algebra minus uminus (\<sqinter>) (\<sqsubseteq>) (\<sqsubset>) (\<squnion>) \<bottom> \<top>"
 proof -
   interpret huntington: 
     huntington_algebra uminus "(\<sqinter>)" "(\<squnion>)" \<bottom> \<top>
       by (fact robbins_is_huntington)
   show ?thesis by (simp add: huntington.huntington_is_boolean)
 qed
 
 end
 
 no_notation secret_object1 ("\<iota>")
    and secret_object2 ("\<alpha>") 
    and secret_object3 ("\<beta>")
    and secret_object4 ("\<delta>")
    and secret_object5 ("\<gamma>")
    and winker_object ("\<rho>")
    and less_eq  (infix "\<sqsubseteq>" 50) 
    and less (infix "\<sqsubset>" 50)
    and inf (infixl "\<sqinter>" 70) 
    and sup (infixl "\<squnion>" 65) 
    and top ("\<top>")
    and bot ("\<bottom>")
    and copyp (infix "\<otimes>" 80)
    and copy (infix "\<times>" 85)
 
 notation
   Product_Type.Times  (infixr "\<times>" 80)
 
 end
diff --git a/thys/Stone_Algebras/Lattice_Basics.thy b/thys/Stone_Algebras/Lattice_Basics.thy
--- a/thys/Stone_Algebras/Lattice_Basics.thy
+++ b/thys/Stone_Algebras/Lattice_Basics.thy
@@ -1,561 +1,561 @@
 (* Title:      Lattice Basics
    Author:     Walter Guttmann
    Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
 *)
 
 section \<open>Lattice Basics\<close>
 
 text \<open>
 This theory provides notations, basic definitions and facts of lattice-related structures used throughout the subsequent development.
 \<close>
 
 theory Lattice_Basics
 
 imports Main
 
 begin
 
 subsection \<open>General Facts and Notations\<close>
 
 text \<open>
 The following results extend basic Isabelle/HOL facts.
 \<close>
 
 lemma imp_as_conj:
   assumes "P x \<Longrightarrow> Q x"
   shows "P x \<and> Q x \<longleftrightarrow> P x"
   using assms by auto
 
 lemma if_distrib_2:
   "f (if c then x else y) (if c then z else w) = (if c then f x z else f y w)"
   by simp
 
 lemma left_invertible_inj:
   "(\<forall>x . g (f x) = x) \<Longrightarrow> inj f"
   by (metis injI)
 
 lemma invertible_bij:
   assumes "\<forall>x . g (f x) = x"
       and "\<forall>y . f (g y) = y"
     shows "bij f"
   by (metis assms bijI')
 
 lemma finite_ne_subset_induct [consumes 3, case_names singleton insert]:
   assumes "finite F"
       and "F \<noteq> {}"
       and "F \<subseteq> S"
       and singleton: "\<And>x . P {x}"
       and insert: "\<And>x F . finite F \<Longrightarrow> F \<noteq> {} \<Longrightarrow> F \<subseteq> S \<Longrightarrow> x \<in> S \<Longrightarrow> x \<notin> F \<Longrightarrow> P F \<Longrightarrow> P (insert x F)"
     shows "P F"
   using assms(1-3)
   apply (induct rule: finite_ne_induct)
   apply (simp add: singleton)
   by (simp add: insert)
 
 lemma finite_set_of_finite_funs_pred:
   assumes "finite { x::'a . True }"
       and "finite { y::'b . P y }"
     shows "finite { f . (\<forall>x::'a . P (f x)) }"
   using assms finite_set_of_finite_funs by force
 
 text \<open>
 We use the following notations for the join, meet and complement operations.
 Changing the precedence of the unary complement allows us to write terms like \<open>--x\<close> instead of \<open>-(-x)\<close>.
 \<close>
 
 context sup
 begin
 
 notation sup (infixl "\<squnion>" 65)
 
 definition additive :: "('a \<Rightarrow> 'a) \<Rightarrow> bool"
   where "additive f \<equiv> \<forall>x y . f (x \<squnion> y) = f x \<squnion> f y"
 
 end
 
 context inf
 begin
 
 notation inf (infixl "\<sqinter>" 67)
 
 end
 
 context uminus
 begin
 
 no_notation uminus ("- _" [81] 80)
 
 notation uminus ("- _" [80] 80)
 
 end
 
 subsection \<open>Orders\<close>
 
 text \<open>
 We use the following definition of monotonicity for operations defined in classes.
 The standard \<open>mono\<close> places a sort constraint on the target type.
 We also give basic properties of Galois connections and lift orders to functions.
 \<close>
 
 context ord
 begin
 
 definition isotone :: "('a \<Rightarrow> 'a) \<Rightarrow> bool"
   where "isotone f \<equiv> \<forall>x y . x \<le> y \<longrightarrow> f x \<le> f y"
 
 definition galois :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool"
   where "galois l u \<equiv> \<forall>x y . l x \<le> y \<longleftrightarrow> x \<le> u y"
 
 definition lifted_less_eq :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool" ("(_ \<le>\<le> _)" [51, 51] 50)
   where "f \<le>\<le> g \<equiv> \<forall>x . f x \<le> g x"
 
 end
 
 context order
 begin
 
 lemma order_lesseq_imp:
   "(\<forall>z . x \<le> z \<longrightarrow> y \<le> z) \<longleftrightarrow> y \<le> x"
   using order_trans by blast
 
 lemma galois_char:
   "galois l u \<longleftrightarrow> (\<forall>x . x \<le> u (l x)) \<and> (\<forall>x . l (u x) \<le> x) \<and> isotone l \<and> isotone u"
   apply (rule iffI)
   apply (metis (full_types) galois_def isotone_def order_refl order_trans)
   using galois_def isotone_def order_trans by blast
 
 lemma galois_closure:
   "galois l u \<Longrightarrow> l x = l (u (l x)) \<and> u x = u (l (u x))"
   by (simp add: galois_char isotone_def order.antisym)
 
 lemma lifted_reflexive:
   "f = g \<Longrightarrow> f \<le>\<le> g"
   by (simp add: lifted_less_eq_def)
 
 lemma lifted_transitive:
   "f \<le>\<le> g \<Longrightarrow> g \<le>\<le> h \<Longrightarrow> f \<le>\<le> h"
   using lifted_less_eq_def order_trans by blast
 
 lemma lifted_antisymmetric:
   "f \<le>\<le> g \<Longrightarrow> g \<le>\<le> f \<Longrightarrow> f = g"
   by (rule ext, rule order.antisym) (simp_all add: lifted_less_eq_def)
 
 text \<open>
 If the image of a finite non-empty set under \<open>f\<close> is a totally ordered, there is an element that minimises the value of \<open>f\<close>.
 \<close>
 
 lemma finite_set_minimal:
   assumes "finite s"
       and "s \<noteq> {}"
       and "\<forall>x\<in>s . \<forall>y\<in>s . f x \<le> f y \<or> f y \<le> f x"
     shows "\<exists>m\<in>s . \<forall>z\<in>s . f m \<le> f z"
   apply (rule finite_ne_subset_induct[where S=s])
   apply (rule assms(1))
   apply (rule assms(2))
   apply simp
   apply simp
   by (metis assms(3) insert_iff order_trans subsetD)
 
 end
 
 subsection \<open>Semilattices\<close>
 
 text \<open>
 The following are basic facts in semilattices.
 \<close>
 
 context semilattice_sup
 begin
 
 lemma sup_left_isotone:
   "x \<le> y \<Longrightarrow> x \<squnion> z \<le> y \<squnion> z"
   using sup.mono by blast
 
 lemma sup_right_isotone:
   "x \<le> y \<Longrightarrow> z \<squnion> x \<le> z \<squnion> y"
   using sup.mono by blast
 
 lemma sup_left_divisibility:
   "x \<le> y \<longleftrightarrow> (\<exists>z . x \<squnion> z = y)"
   using sup.absorb2 sup.cobounded1 by blast
 
 lemma sup_right_divisibility:
   "x \<le> y \<longleftrightarrow> (\<exists>z . z \<squnion> x = y)"
   by (metis sup.cobounded2 sup.orderE)
 
 lemma sup_same_context:
   "x \<le> y \<squnion> z \<Longrightarrow> y \<le> x \<squnion> z \<Longrightarrow> x \<squnion> z = y \<squnion> z"
   by (simp add: le_iff_sup sup_left_commute)
 
 lemma sup_relative_same_increasing:
   "x \<le> y \<Longrightarrow> x \<squnion> z = x \<squnion> w \<Longrightarrow> y \<squnion> z = y \<squnion> w"
   using sup.assoc sup_right_divisibility by auto
 
 end
 
 text \<open>
 Every bounded semilattice is a commutative monoid.
 Finite sums defined in commutative monoids are available via the following sublocale.
 \<close>
 
 context bounded_semilattice_sup_bot
 begin
 
 sublocale sup_monoid: comm_monoid_add where plus = sup and zero = bot
   apply unfold_locales
   apply (simp add: sup_assoc)
   apply (simp add: sup_commute)
   by simp
 
 end
 
 context semilattice_inf
 begin
 
 lemma inf_same_context:
   "x \<le> y \<sqinter> z \<Longrightarrow> y \<le> x \<sqinter> z \<Longrightarrow> x \<sqinter> z = y \<sqinter> z"
   using order.antisym by auto
 
 end
 
 text \<open>
 The following class requires only the existence of upper bounds, which is a property common to bounded semilattices and (not necessarily bounded) lattices.
 We use it in our development of filters.
 \<close>
 
 class directed_semilattice_inf = semilattice_inf +
   assumes ub: "\<exists>z . x \<le> z \<and> y \<le> z"
 
 text \<open>
 We extend the \<open>inf\<close> sublocale, which dualises the order in semilattices, to bounded semilattices.
 \<close>
 
 context bounded_semilattice_inf_top
 begin
 
 subclass directed_semilattice_inf
   apply unfold_locales
   using top_greatest by blast
 
 sublocale inf: bounded_semilattice_sup_bot where sup = inf and less_eq = greater_eq and less = greater and bot = top
   by unfold_locales (simp_all add: less_le_not_le)
 
 end
 
 subsection \<open>Lattices\<close>
 
 context lattice
 begin
 
 subclass directed_semilattice_inf
   apply unfold_locales
   using sup_ge1 sup_ge2 by blast
 
 definition dual_additive :: "('a \<Rightarrow> 'a) \<Rightarrow> bool"
   where "dual_additive f \<equiv> \<forall>x y . f (x \<squnion> y) = f x \<sqinter> f y"
 
 end
 
 text \<open>
 Not every bounded lattice has complements, but two elements might still be complements of each other as captured in the following definition.
 In this situation we can apply, for example, the shunting property shown below.
 We introduce most definitions using the \<open>abbreviation\<close> command.
 \<close>
 
 context bounded_lattice
 begin
 
 abbreviation "complement x y \<equiv> x \<squnion> y = top \<and> x \<sqinter> y = bot"
 
 lemma complement_symmetric:
   "complement x y \<Longrightarrow> complement y x"
   by (simp add: inf.commute sup.commute)
 
 definition conjugate :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool"
   where "conjugate f g \<equiv> \<forall>x y . f x \<sqinter> y = bot \<longleftrightarrow> x \<sqinter> g y = bot"
 
 end
 
 class dense_lattice = bounded_lattice +
   assumes bot_meet_irreducible: "x \<sqinter> y = bot \<longrightarrow> x = bot \<or> y = bot"
 
 context distrib_lattice
 begin
 
 lemma relative_equality:
   "x \<squnion> z = y \<squnion> z \<Longrightarrow> x \<sqinter> z = y \<sqinter> z \<Longrightarrow> x = y"
   by (metis inf.commute inf_sup_absorb inf_sup_distrib2)
 
 end
 
 text \<open>
 Distributive lattices with a greatest element are widely used in the construction theorem for Stone algebras.
 \<close>
 
 class distrib_lattice_bot = bounded_lattice_bot + distrib_lattice
 
 class distrib_lattice_top = bounded_lattice_top + distrib_lattice
 
 class bounded_distrib_lattice = bounded_lattice + distrib_lattice
 begin
 
 subclass distrib_lattice_bot ..
 
 subclass distrib_lattice_top ..
 
 lemma complement_shunting:
   assumes "complement z w"
     shows "z \<sqinter> x \<le> y \<longleftrightarrow> x \<le> w \<squnion> y"
 proof
   assume 1: "z \<sqinter> x \<le> y"
   have "x = (z \<squnion> w) \<sqinter> x"
     by (simp add: assms)
   also have "... \<le> y \<squnion> (w \<sqinter> x)"
     using 1 sup.commute sup.left_commute inf_sup_distrib2 sup_right_divisibility by fastforce
   also have "... \<le> w \<squnion> y"
     by (simp add: inf.coboundedI1)
   finally show "x \<le> w \<squnion> y"
     .
 next
   assume "x \<le> w \<squnion> y"
   hence "z \<sqinter> x \<le> z \<sqinter> (w \<squnion> y)"
     using inf.sup_right_isotone by auto
   also have "... = z \<sqinter> y"
     by (simp add: assms inf_sup_distrib1)
   also have "... \<le> y"
     by simp
   finally show "z \<sqinter> x \<le> y"
     .
 qed
 
 end
 
 subsection \<open>Linear Orders\<close>
 
 text \<open>
 We next consider lattices with a linear order structure.
 In such lattices, join and meet are selective operations, which give the maximum and the minimum of two elements, respectively.
 Moreover, the lattice is automatically distributive.
 \<close>
 
 class bounded_linorder = linorder + order_bot + order_top
 
 class linear_lattice = lattice + linorder
 begin
 
 lemma max_sup:
   "max x y = x \<squnion> y"
   by (metis max.boundedI max.cobounded1 max.cobounded2 sup_unique)
 
 lemma min_inf:
   "min x y = x \<sqinter> y"
   by (simp add: inf.absorb1 inf.absorb2 min_def)
 
 lemma sup_inf_selective:
   "(x \<squnion> y = x \<and> x \<sqinter> y = y) \<or> (x \<squnion> y = y \<and> x \<sqinter> y = x)"
   by (meson inf.absorb1 inf.absorb2 le_cases sup.absorb1 sup.absorb2)
 
 lemma sup_selective:
   "x \<squnion> y = x \<or> x \<squnion> y = y"
   using sup_inf_selective by blast
 
 lemma inf_selective:
   "x \<sqinter> y = x \<or> x \<sqinter> y = y"
   using sup_inf_selective by blast
 
 subclass distrib_lattice
   apply standard
   apply (rule order.antisym)
    apply (auto simp add: le_supI2)
   apply (metis inf_selective inf.coboundedI1 inf.coboundedI2 order.eq_iff)
   done
 
 lemma sup_less_eq:
   "x \<le> y \<squnion> z \<longleftrightarrow> x \<le> y \<or> x \<le> z"
   by (metis le_supI1 le_supI2 sup_selective)
 
 lemma inf_less_eq:
   "x \<sqinter> y \<le> z \<longleftrightarrow> x \<le> z \<or> y \<le> z"
   by (metis inf.coboundedI1 inf.coboundedI2 inf_selective)
 
 lemma sup_inf_sup:
   "x \<squnion> y = (x \<squnion> y) \<squnion> (x \<sqinter> y)"
   by (metis sup_commute sup_inf_absorb sup_left_commute)
 
 end
 
 text \<open>
 The following class derives additional properties if the linear order of the lattice has a least and a greatest element.
 \<close>
 
 class linear_bounded_lattice = bounded_lattice + linorder
 begin
 
 subclass linear_lattice ..
 
 subclass bounded_linorder ..
 
 subclass bounded_distrib_lattice ..
 
 lemma sup_dense:
   "x \<noteq> top \<Longrightarrow> y \<noteq> top \<Longrightarrow> x \<squnion> y \<noteq> top"
   by (metis sup_selective)
 
 lemma inf_dense:
   "x \<noteq> bot \<Longrightarrow> y \<noteq> bot \<Longrightarrow> x \<sqinter> y \<noteq> bot"
   by (metis inf_selective)
 
 lemma sup_not_bot:
   "x \<noteq> bot \<Longrightarrow> x \<squnion> y \<noteq> bot"
   by simp
 
 lemma inf_not_top:
   "x \<noteq> top \<Longrightarrow> x \<sqinter> y \<noteq> top"
   by simp
 
 subclass dense_lattice
   apply unfold_locales
   using inf_dense by blast
 
 end
 
 text \<open>
 Every bounded linear order can be expanded to a bounded lattice.
 Join and meet are maximum and minimum, respectively.
 \<close>
 
 class linorder_lattice_expansion = bounded_linorder + sup + inf +
   assumes sup_def [simp]: "x \<squnion> y = max x y"
   assumes inf_def [simp]: "x \<sqinter> y = min x y"
 begin
 
 subclass linear_bounded_lattice
   apply unfold_locales
   by auto
 
 end
 
 subsection \<open>Non-trivial Algebras\<close>
 
 text \<open>
 Some results, such as the existence of certain filters, require that the algebras are not trivial.
 This is not an assumption of the order and lattice classes that come with Isabelle/HOL; for example, \<open>bot = top\<close> may hold in bounded lattices.
 \<close>
 
 class non_trivial =
   assumes consistent: "\<exists>x y . x \<noteq> y"
 
 class non_trivial_order = non_trivial + order
 
 class non_trivial_order_bot = non_trivial_order + order_bot
 
 class non_trivial_bounded_order = non_trivial_order_bot + order_top
 begin
 
 lemma bot_not_top:
   "bot \<noteq> top"
 proof -
   from consistent obtain x y :: 'a where "x \<noteq> y"
     by auto
   thus ?thesis
     by (metis bot_less top.extremum_strict)
 qed
 
 end
 
 subsection \<open>Homomorphisms\<close>
 
 text \<open>
 This section gives definitions of lattice homomorphisms and isomorphisms and basic properties.
 \<close>
 
 class sup_inf_top_bot_uminus = sup + inf + top + bot + uminus
 class sup_inf_top_bot_uminus_ord = sup_inf_top_bot_uminus + ord
 
-context Lattices.boolean_algebra
+context boolean_algebra
 begin
 
 subclass sup_inf_top_bot_uminus_ord .
 
 end
 
 abbreviation sup_homomorphism :: "('a::sup \<Rightarrow> 'b::sup) \<Rightarrow> bool"
   where "sup_homomorphism f \<equiv> \<forall>x y . f (x \<squnion> y) = f x \<squnion> f y"
 
 abbreviation inf_homomorphism :: "('a::inf \<Rightarrow> 'b::inf) \<Rightarrow> bool"
   where "inf_homomorphism f \<equiv> \<forall>x y . f (x \<sqinter> y) = f x \<sqinter> f y"
 
 abbreviation bot_homomorphism :: "('a::bot \<Rightarrow> 'b::bot) \<Rightarrow> bool"
   where "bot_homomorphism f \<equiv> f bot = bot"
 
 abbreviation top_homomorphism :: "('a::top \<Rightarrow> 'b::top) \<Rightarrow> bool"
   where "top_homomorphism f \<equiv> f top = top"
 
 abbreviation minus_homomorphism :: "('a::minus \<Rightarrow> 'b::minus) \<Rightarrow> bool"
   where "minus_homomorphism f \<equiv> \<forall>x y . f (x - y) = f x - f y"
 
 abbreviation uminus_homomorphism :: "('a::uminus \<Rightarrow> 'b::uminus) \<Rightarrow> bool"
   where "uminus_homomorphism f \<equiv> \<forall>x . f (-x) = -f x"
 
 abbreviation sup_inf_homomorphism :: "('a::{sup,inf} \<Rightarrow> 'b::{sup,inf}) \<Rightarrow> bool"
   where "sup_inf_homomorphism f \<equiv> sup_homomorphism f \<and> inf_homomorphism f"
 
 abbreviation sup_inf_top_homomorphism :: "('a::{sup,inf,top} \<Rightarrow> 'b::{sup,inf,top}) \<Rightarrow> bool"
   where "sup_inf_top_homomorphism f \<equiv> sup_inf_homomorphism f \<and> top_homomorphism f"
 
 abbreviation sup_inf_top_bot_homomorphism :: "('a::{sup,inf,top,bot} \<Rightarrow> 'b::{sup,inf,top,bot}) \<Rightarrow> bool"
   where "sup_inf_top_bot_homomorphism f \<equiv> sup_inf_top_homomorphism f \<and> bot_homomorphism f"
 
 abbreviation bounded_lattice_homomorphism :: "('a::bounded_lattice \<Rightarrow> 'b::bounded_lattice) \<Rightarrow> bool"
   where "bounded_lattice_homomorphism f \<equiv> sup_inf_top_bot_homomorphism f"
 
 abbreviation sup_inf_top_bot_uminus_homomorphism :: "('a::sup_inf_top_bot_uminus \<Rightarrow> 'b::sup_inf_top_bot_uminus) \<Rightarrow> bool"
   where "sup_inf_top_bot_uminus_homomorphism f \<equiv> sup_inf_top_bot_homomorphism f \<and> uminus_homomorphism f"
 
 abbreviation sup_inf_top_bot_uminus_ord_homomorphism :: "('a::sup_inf_top_bot_uminus_ord \<Rightarrow> 'b::sup_inf_top_bot_uminus_ord) \<Rightarrow> bool"
   where "sup_inf_top_bot_uminus_ord_homomorphism f \<equiv> sup_inf_top_bot_uminus_homomorphism f \<and> (\<forall>x y . x \<le> y \<longrightarrow> f x \<le> f y)"
 
 abbreviation sup_inf_top_isomorphism :: "('a::{sup,inf,top} \<Rightarrow> 'b::{sup,inf,top}) \<Rightarrow> bool"
   where "sup_inf_top_isomorphism f \<equiv> sup_inf_top_homomorphism f \<and> bij f"
 
 abbreviation bounded_lattice_top_isomorphism :: "('a::bounded_lattice_top \<Rightarrow> 'b::bounded_lattice_top) \<Rightarrow> bool"
   where "bounded_lattice_top_isomorphism f \<equiv> sup_inf_top_isomorphism f"
 
 abbreviation sup_inf_top_bot_uminus_isomorphism :: "('a::sup_inf_top_bot_uminus \<Rightarrow> 'b::sup_inf_top_bot_uminus) \<Rightarrow> bool"
   where "sup_inf_top_bot_uminus_isomorphism f \<equiv> sup_inf_top_bot_uminus_homomorphism f \<and> bij f"
 
 abbreviation boolean_algebra_isomorphism :: "('a::boolean_algebra \<Rightarrow> 'b::boolean_algebra) \<Rightarrow> bool"
   where "boolean_algebra_isomorphism f \<equiv> sup_inf_top_bot_uminus_isomorphism f \<and> minus_homomorphism f"
 
 lemma sup_homomorphism_mono:
   "sup_homomorphism (f::'a::semilattice_sup \<Rightarrow> 'b::semilattice_sup) \<Longrightarrow> mono f"
   by (metis le_iff_sup monoI)
 
 lemma sup_isomorphism_ord_isomorphism:
   assumes "sup_homomorphism (f::'a::semilattice_sup \<Rightarrow> 'b::semilattice_sup)"
       and "bij f"
     shows "x \<le> y \<longleftrightarrow> f x \<le> f y"
 proof
   assume "x \<le> y"
   thus "f x \<le> f y"
     by (metis assms(1) le_iff_sup)
 next
   assume "f x \<le> f y"
   hence "f (x \<squnion> y) = f y"
     by (simp add: assms(1) le_iff_sup)
   hence "x \<squnion> y = y"
     by (metis injD bij_is_inj assms(2))
   thus "x \<le> y"
     by (simp add: le_iff_sup)
 qed
 
 lemma minus_homomorphism_default:
   assumes "\<forall>x y::'a::{inf,minus,uminus} . x - y = x \<sqinter> -y"
       and "\<forall>x y::'b::{inf,minus,uminus} . x - y = x \<sqinter> -y"
       and "inf_homomorphism (f::'a \<Rightarrow> 'b)"
       and "uminus_homomorphism f"
     shows "minus_homomorphism f"
   by (simp add: assms)
 
 end
 
diff --git a/thys/Stone_Algebras/P_Algebras.thy b/thys/Stone_Algebras/P_Algebras.thy
--- a/thys/Stone_Algebras/P_Algebras.thy
+++ b/thys/Stone_Algebras/P_Algebras.thy
@@ -1,1328 +1,1328 @@
 (* Title:      Pseudocomplemented Algebras
    Author:     Walter Guttmann
    Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
 *)
 
 section \<open>Pseudocomplemented Algebras\<close>
 
 text \<open>
 This theory expands lattices with a pseudocomplement operation.
 In particular, we consider the following algebraic structures:
 \begin{itemize}
 \item pseudocomplemented lattices (p-algebras)
 \item pseudocomplemented distributive lattices (distributive p-algebras)
 \item Stone algebras
 \item Heyting semilattices
 \item Heyting lattices
 \item Heyting algebras
 \item Heyting-Stone algebras
 \item Brouwer algebras
 \item Boolean algebras
 \end{itemize}
 Most of these structures and many results in this theory are discussed in \cite{BalbesDwinger1974,Birkhoff1967,Blyth2005,Curry1977,Graetzer1971,Maddux1996}.
 \<close>
 
 theory P_Algebras
 
 imports Lattice_Basics
 
 begin
 
 subsection \<open>P-Algebras\<close>
 
 text \<open>
 In this section we add a pseudocomplement operation to lattices and to distributive lattices.
 \<close>
 
 subsubsection \<open>Pseudocomplemented Lattices\<close>
 
 text \<open>
 The pseudocomplement of an element \<open>y\<close> is the greatest element whose meet with \<open>y\<close> is the least element of the lattice.
 \<close>
 
 class p_algebra = bounded_lattice + uminus +
   assumes pseudo_complement: "x \<sqinter> y = bot \<longleftrightarrow> x \<le> -y"
 begin
 
 subclass sup_inf_top_bot_uminus_ord .
 
 text \<open>
 Regular elements and dense elements are frequently used in pseudocomplemented algebras.
 \<close>
 
 abbreviation "regular x \<equiv> x = --x"
 abbreviation "dense x \<equiv> -x = bot"
 abbreviation "complemented x \<equiv> \<exists>y . x \<sqinter> y = bot \<and> x \<squnion> y = top"
 abbreviation "in_p_image x \<equiv> \<exists>y . x = -y"
 abbreviation "selection s x \<equiv> s = --s \<sqinter> x"
 
 abbreviation "dense_elements \<equiv> { x . dense x }"
 abbreviation "regular_elements \<equiv> { x . in_p_image x }"
 
 lemma p_bot [simp]:
   "-bot = top"
   using inf_top.left_neutral pseudo_complement top_unique by blast
 
 lemma p_top [simp]:
   "-top = bot"
   by (metis eq_refl inf_top.comm_neutral pseudo_complement)
 
 text \<open>
 The pseudocomplement satisfies the following half of the requirements of a complement.
 \<close>
 
 lemma inf_p [simp]:
   "x \<sqinter> -x = bot"
   using inf.commute pseudo_complement by fastforce
 
 lemma p_inf [simp]:
   "-x \<sqinter> x = bot"
   by (simp add: inf_commute)
 
 lemma pp_inf_p:
   "--x \<sqinter> -x = bot"
   by simp
 
 text \<open>
 The double complement is a closure operation.
 \<close>
 
 lemma pp_increasing:
   "x \<le> --x"
   using inf_p pseudo_complement by blast
 
 lemma ppp [simp]:
   "---x = -x"
   by (metis order.antisym inf.commute order_trans pseudo_complement pp_increasing)
 
 lemma pp_idempotent:
   "----x = --x"
   by simp
 
 lemma regular_in_p_image_iff:
   "regular x \<longleftrightarrow> in_p_image x"
   by auto
 
 lemma pseudo_complement_pp:
   "x \<sqinter> y = bot \<longleftrightarrow> --x \<le> -y"
   by (metis inf_commute pseudo_complement ppp)
 
 lemma p_antitone:
   "x \<le> y \<Longrightarrow> -y \<le> -x"
   by (metis inf_commute order_trans pseudo_complement pp_increasing)
 
 lemma p_antitone_sup:
   "-(x \<squnion> y) \<le> -x"
   by (simp add: p_antitone)
 
 lemma p_antitone_inf:
   "-x \<le> -(x \<sqinter> y)"
   by (simp add: p_antitone)
 
 lemma p_antitone_iff:
   "x \<le> -y \<longleftrightarrow> y \<le> -x"
   using order_lesseq_imp p_antitone pp_increasing by blast
 
 lemma pp_isotone:
   "x \<le> y \<Longrightarrow> --x \<le> --y"
   by (simp add: p_antitone)
 
 lemma pp_isotone_sup:
   "--x \<le> --(x \<squnion> y)"
   by (simp add: p_antitone)
 
 lemma pp_isotone_inf:
   "--(x \<sqinter> y) \<le> --x"
   by (simp add: p_antitone)
 
 text \<open>
 One of De Morgan's laws holds in pseudocomplemented lattices.
 \<close>
 
 lemma p_dist_sup [simp]:
   "-(x \<squnion> y) = -x \<sqinter> -y"
   apply (rule order.antisym)
   apply (simp add: p_antitone)
   using inf_le1 inf_le2 le_sup_iff p_antitone_iff by blast
 
 lemma p_supdist_inf:
   "-x \<squnion> -y \<le> -(x \<sqinter> y)"
   by (simp add: p_antitone)
 
 lemma pp_dist_pp_sup [simp]:
   "--(--x \<squnion> --y) = --(x \<squnion> y)"
   by simp
 
 lemma p_sup_p [simp]:
   "-(x \<squnion> -x) = bot"
   by simp
 
 lemma pp_sup_p [simp]:
   "--(x \<squnion> -x) = top"
   by simp
 
 lemma dense_pp:
   "dense x \<longleftrightarrow> --x = top"
   by (metis p_bot p_top ppp)
 
 lemma dense_sup_p:
   "dense (x \<squnion> -x)"
   by simp
 
 lemma regular_char:
   "regular x \<longleftrightarrow> (\<exists>y . x = -y)"
   by auto
 
 lemma pp_inf_bot_iff:
   "x \<sqinter> y = bot \<longleftrightarrow> --x \<sqinter> y = bot"
   by (simp add: pseudo_complement_pp)
 
 text \<open>
 Weak forms of the shunting property hold.
 Most require a pseudocomplemented element on the right-hand side.
 \<close>
 
 lemma p_shunting_swap:
   "x \<sqinter> y \<le> -z \<longleftrightarrow> x \<sqinter> z \<le> -y"
   by (metis inf_assoc inf_commute pseudo_complement)
 
 lemma pp_inf_below_iff:
   "x \<sqinter> y \<le> -z \<longleftrightarrow> --x \<sqinter> y \<le> -z"
   by (simp add: inf_commute p_shunting_swap)
 
 lemma p_inf_pp [simp]:
   "-(x \<sqinter> --y) = -(x \<sqinter> y)"
   apply (rule order.antisym)
   apply (simp add: inf.coboundedI2 p_antitone pp_increasing)
   using inf_commute p_antitone_iff pp_inf_below_iff by auto
 
 lemma p_inf_pp_pp [simp]:
   "-(--x \<sqinter> --y) = -(x \<sqinter> y)"
   by (simp add: inf_commute)
 
 lemma regular_closed_inf:
   "regular x \<Longrightarrow> regular y \<Longrightarrow> regular (x \<sqinter> y)"
   by (metis p_dist_sup ppp)
 
 lemma regular_closed_p:
   "regular (-x)"
   by simp
 
 lemma regular_closed_pp:
   "regular (--x)"
   by simp
 
 lemma regular_closed_bot:
   "regular bot"
   by simp
 
 lemma regular_closed_top:
   "regular top"
   by simp
 
 lemma pp_dist_inf [simp]:
   "--(x \<sqinter> y) = --x \<sqinter> --y"
   by (metis p_dist_sup p_inf_pp_pp ppp)
 
 lemma inf_import_p [simp]:
   "x \<sqinter> -(x \<sqinter> y) = x \<sqinter> -y"
   apply (rule order.antisym)
   using p_shunting_swap apply fastforce
   using inf.sup_right_isotone p_antitone by auto
 
 text \<open>
 Pseudocomplements are unique.
 \<close>
 
 lemma p_unique:
   "(\<forall>x . x \<sqinter> y = bot \<longleftrightarrow> x \<le> z) \<Longrightarrow> z = -y"
   using inf.order_eq_iff pseudo_complement by auto
 
 lemma maddux_3_5:
   "x \<squnion> x = x \<squnion> -(y \<squnion> -y)"
   by simp
 
 lemma shunting_1_pp:
   "x \<le> --y \<longleftrightarrow> x \<sqinter> -y = bot"
   by (simp add: pseudo_complement)
 
 lemma pp_pp_inf_bot_iff:
   "x \<sqinter> y = bot \<longleftrightarrow> --x \<sqinter> --y = bot"
   by (simp add: pseudo_complement_pp)
 
 lemma inf_pp_semi_commute:
   "x \<sqinter> --y \<le> --(x \<sqinter> y)"
   using inf.eq_refl p_antitone_iff p_inf_pp by presburger
 
 lemma inf_pp_commute:
   "--(--x \<sqinter> y) = --x \<sqinter> --y"
   by simp
 
 lemma sup_pp_semi_commute:
   "x \<squnion> --y \<le> --(x \<squnion> y)"
   by (simp add: p_antitone_iff)
 
 lemma regular_sup:
   "regular z \<Longrightarrow> (x \<le> z \<and> y \<le> z \<longleftrightarrow> --(x \<squnion> y) \<le> z)"
   apply (rule iffI)
   apply (metis le_supI pp_isotone)
   using dual_order.trans sup_ge2 pp_increasing pp_isotone_sup by blast
 
 lemma dense_closed_inf:
   "dense x \<Longrightarrow> dense y \<Longrightarrow> dense (x \<sqinter> y)"
   by (simp add: dense_pp)
 
 lemma dense_closed_sup:
   "dense x \<Longrightarrow> dense y \<Longrightarrow> dense (x \<squnion> y)"
   by simp
 
 lemma dense_closed_pp:
   "dense x \<Longrightarrow> dense (--x)"
   by simp
 
 lemma dense_closed_top:
   "dense top"
   by simp
 
 lemma dense_up_closed:
   "dense x \<Longrightarrow> x \<le> y \<Longrightarrow> dense y"
   using dense_pp top_le pp_isotone by auto
 
 lemma regular_dense_top:
   "regular x \<Longrightarrow> dense x \<Longrightarrow> x = top"
   using p_bot by blast
 
 lemma selection_char:
   "selection s x \<longleftrightarrow> (\<exists>y . s = -y \<sqinter> x)"
   by (metis inf_import_p inf_commute regular_closed_p)
 
 lemma selection_closed_inf:
   "selection s x \<Longrightarrow> selection t x \<Longrightarrow> selection (s \<sqinter> t) x"
   by (metis inf_assoc inf_commute inf_idem pp_dist_inf)
 
 lemma selection_closed_pp:
   "regular x \<Longrightarrow> selection s x \<Longrightarrow> selection (--s) x"
   by (metis pp_dist_inf)
 
 lemma selection_closed_bot:
   "selection bot x"
   by simp
 
 lemma selection_closed_id:
   "selection x x"
   using inf.le_iff_sup pp_increasing by auto
 
 text \<open>
 Conjugates are usually studied for Boolean algebras, however, some of their properties generalise to pseudocomplemented algebras.
 \<close>
 
 lemma conjugate_unique_p:
   assumes "conjugate f g"
       and "conjugate f h"
     shows "uminus \<circ> g = uminus \<circ> h"
 proof -
   have "\<forall>x y . x \<sqinter> g y = bot \<longleftrightarrow> x \<sqinter> h y = bot"
     using assms conjugate_def inf.commute by simp
   hence "\<forall>x y . x \<le> -(g y) \<longleftrightarrow> x \<le> -(h y)"
     using inf.commute pseudo_complement by simp
   hence "\<forall>y . -(g y) = -(h y)"
     using order.eq_iff by blast
   thus ?thesis
     by auto
 qed
 
 lemma conjugate_symmetric:
   "conjugate f g \<Longrightarrow> conjugate g f"
   by (simp add: conjugate_def inf_commute)
 
 lemma additive_isotone:
   "additive f \<Longrightarrow> isotone f"
   by (metis additive_def isotone_def le_iff_sup)
 
 lemma dual_additive_antitone:
   assumes "dual_additive f"
     shows "isotone (uminus \<circ> f)"
 proof -
   have "\<forall>x y . f (x \<squnion> y) \<le> f x"
     using assms dual_additive_def by simp
   hence "\<forall>x y . x \<le> y \<longrightarrow> f y \<le> f x"
     by (metis sup_absorb2)
   hence "\<forall>x y . x \<le> y \<longrightarrow> -(f x) \<le> -(f y)"
     by (simp add: p_antitone)
   thus ?thesis
     by (simp add: isotone_def)
 qed
 
 lemma conjugate_dual_additive:
   assumes "conjugate f g"
     shows "dual_additive (uminus \<circ> f)"
 proof -
   have 1: "\<forall>x y z . -z \<le> -(f (x \<squnion> y)) \<longleftrightarrow> -z \<le> -(f x) \<and> -z \<le> -(f y)"
   proof (intro allI)
     fix x y z
     have "(-z \<le> -(f (x \<squnion> y))) = (f (x \<squnion> y) \<sqinter> -z = bot)"
       by (simp add: p_antitone_iff pseudo_complement)
     also have "... = ((x \<squnion> y) \<sqinter> g(-z) = bot)"
       using assms conjugate_def by auto
     also have "... = (x \<squnion> y \<le> -(g(-z)))"
       by (simp add: pseudo_complement)
     also have "... = (x \<le> -(g(-z)) \<and> y \<le> -(g(-z)))"
       by (simp add: le_sup_iff)
     also have "... = (x \<sqinter> g(-z) = bot \<and> y \<sqinter> g(-z) = bot)"
       by (simp add: pseudo_complement)
     also have "... = (f x \<sqinter> -z = bot \<and> f y \<sqinter> -z = bot)"
       using assms conjugate_def by auto
     also have "... = (-z \<le> -(f x) \<and> -z \<le> -(f y))"
       by (simp add: p_antitone_iff pseudo_complement)
     finally show "-z \<le> -(f (x \<squnion> y)) \<longleftrightarrow> -z \<le> -(f x) \<and> -z \<le> -(f y)"
       by simp
   qed
   have "\<forall>x y . -(f (x \<squnion> y)) = -(f x) \<sqinter> -(f y)"
   proof (intro allI)
     fix x y
     have "-(f x) \<sqinter> -(f y) = --(-(f x) \<sqinter> -(f y))"
       by simp
     hence "-(f x) \<sqinter> -(f y) \<le> -(f (x \<squnion> y))"
       using 1 by (metis inf_le1 inf_le2)
     thus "-(f (x \<squnion> y)) = -(f x) \<sqinter> -(f y)"
       using 1 order.antisym by fastforce
   qed
   thus ?thesis
     using dual_additive_def by simp
 qed
 
 lemma conjugate_isotone_pp:
   "conjugate f g \<Longrightarrow> isotone (uminus \<circ> uminus \<circ> f)"
   by (simp add: comp_assoc conjugate_dual_additive dual_additive_antitone)
 
 lemma conjugate_char_1_pp:
   "conjugate f g \<longleftrightarrow> (\<forall>x y . f(x \<sqinter> -(g y)) \<le> --f x \<sqinter> -y \<and> g(y \<sqinter> -(f x)) \<le> --g y \<sqinter> -x)"
 proof
   assume 1: "conjugate f g"
   show "\<forall>x y . f(x \<sqinter> -(g y)) \<le> --f x \<sqinter> -y \<and> g(y \<sqinter> -(f x)) \<le> --g y \<sqinter> -x"
   proof (intro allI)
     fix x y
     have 2: "f(x \<sqinter> -(g y)) \<le> -y"
       using 1 by (simp add: conjugate_def pseudo_complement)
     have "f(x \<sqinter> -(g y)) \<le> --f(x \<sqinter> -(g y))"
       by (simp add: pp_increasing)
     also have "... \<le> --f x"
       using 1 conjugate_isotone_pp isotone_def by simp
     finally have 3: "f(x \<sqinter> -(g y)) \<le> --f x \<sqinter> -y"
       using 2 by simp
     have 4: "isotone (uminus \<circ> uminus \<circ> g)"
       using 1 conjugate_isotone_pp conjugate_symmetric by auto
     have 5: "g(y \<sqinter> -(f x)) \<le> -x"
       using 1 by (metis conjugate_def inf.cobounded2 inf_commute pseudo_complement)
     have "g(y \<sqinter> -(f x)) \<le> --g(y \<sqinter> -(f x))"
       by (simp add: pp_increasing)
     also have "... \<le> --g y"
       using 4 isotone_def by auto
     finally have "g(y \<sqinter> -(f x)) \<le> --g y \<sqinter> -x"
       using 5 by simp
     thus "f(x \<sqinter> -(g y)) \<le> --f x \<sqinter> -y \<and> g(y \<sqinter> -(f x)) \<le> --g y \<sqinter> -x"
       using 3 by simp
   qed
 next
   assume 6: "\<forall>x y . f(x \<sqinter> -(g y)) \<le> --f x \<sqinter> -y \<and> g(y \<sqinter> -(f x)) \<le> --g y \<sqinter> -x"
   hence 7: "\<forall>x y . f x \<sqinter> y = bot \<longrightarrow> x \<sqinter> g y = bot"
     by (metis inf.le_iff_sup inf.le_sup_iff inf_commute pseudo_complement)
   have "\<forall>x y . x \<sqinter> g y = bot \<longrightarrow> f x \<sqinter> y = bot"
     using 6 by (metis inf.le_iff_sup inf.le_sup_iff inf_commute pseudo_complement)
   thus "conjugate f g"
     using 7 conjugate_def by auto
 qed
 
 lemma conjugate_char_1_isotone:
   "conjugate f g \<Longrightarrow> isotone f \<Longrightarrow> isotone g \<Longrightarrow> f(x \<sqinter> -(g y)) \<le> f x \<sqinter> -y \<and> g(y \<sqinter> -(f x)) \<le> g y \<sqinter> -x"
   by (simp add: conjugate_char_1_pp ord.isotone_def)
 
 lemma dense_lattice_char_1:
   "(\<forall>x y . x \<sqinter> y = bot \<longrightarrow> x = bot \<or> y = bot) \<longleftrightarrow> (\<forall>x . x \<noteq> bot \<longrightarrow> dense x)"
   by (metis inf_top.left_neutral p_bot p_inf pp_inf_bot_iff)
 
 lemma dense_lattice_char_2:
   "(\<forall>x y . x \<sqinter> y = bot \<longrightarrow> x = bot \<or> y = bot) \<longleftrightarrow> (\<forall>x . regular x \<longrightarrow> x = bot \<or> x = top)"
   by (metis dense_lattice_char_1 inf_top.left_neutral p_inf regular_closed_p regular_closed_top)
 
 lemma restrict_below_Rep_eq:
   "x \<sqinter> --y \<le> z \<Longrightarrow> x \<sqinter> y = x \<sqinter> z \<sqinter> y"
   by (metis inf.absorb2 inf.commute inf.left_commute pp_increasing)
 
 (*
 lemma p_inf_sup_below: "-x \<sqinter> (x \<squnion> y) \<le> y" nitpick [expect=genuine] oops
 lemma complement_p: "x \<sqinter> y = bot \<and> x \<squnion> y = top \<longrightarrow> -x = y" nitpick [expect=genuine] oops
 lemma complemented_regular: "complemented x \<longrightarrow> regular x" nitpick [expect=genuine] oops
 *)
 
 end
 
 text \<open>
 The following class gives equational axioms for the pseudocomplement operation.
 \<close>
 
 class p_algebra_eq = bounded_lattice + uminus +
   assumes p_bot_eq: "-bot = top"
       and p_top_eq: "-top = bot"
       and inf_import_p_eq: "x \<sqinter> -(x \<sqinter> y) = x \<sqinter> -y"
 begin
 
 lemma inf_p_eq:
   "x \<sqinter> -x = bot"
   by (metis inf_bot_right inf_import_p_eq inf_top_right p_top_eq)
 
 subclass p_algebra
   apply unfold_locales
   apply (rule iffI)
   apply (metis inf.orderI inf_import_p_eq inf_top.right_neutral p_bot_eq)
   by (metis (full_types) inf.left_commute inf.orderE inf_bot_right inf_commute inf_p_eq)
 
 end
 
 subsubsection \<open>Pseudocomplemented Distributive Lattices\<close>
 
 text \<open>
 We obtain further properties if we assume that the lattice operations are distributive.
 \<close>
 
 class pd_algebra = p_algebra + bounded_distrib_lattice
 begin
 
 lemma p_inf_sup_below:
   "-x \<sqinter> (x \<squnion> y) \<le> y"
   by (simp add: inf_sup_distrib1)
 
 lemma pp_inf_sup_p [simp]:
   "--x \<sqinter> (x \<squnion> -x) = x"
   using inf.absorb2 inf_sup_distrib1 pp_increasing by auto
 
 lemma complement_p:
   "x \<sqinter> y = bot \<Longrightarrow> x \<squnion> y = top \<Longrightarrow> -x = y"
   by (metis pseudo_complement inf.commute inf_top.left_neutral sup.absorb_iff1 sup.commute sup_bot.right_neutral sup_inf_distrib2 p_inf)
 
 lemma complemented_regular:
   "complemented x \<Longrightarrow> regular x"
   using complement_p inf.commute sup.commute by fastforce
 
 lemma regular_inf_dense:
   "\<exists>y z . regular y \<and> dense z \<and> x = y \<sqinter> z"
   by (metis pp_inf_sup_p dense_sup_p ppp)
 
 lemma maddux_3_12 [simp]:
   "(x \<squnion> -y) \<sqinter> (x \<squnion> y) = x"
   by (metis p_inf sup_bot_right sup_inf_distrib1)
 
 lemma maddux_3_13 [simp]:
   "(x \<squnion> y) \<sqinter> -x = y \<sqinter> -x"
   by (simp add: inf_sup_distrib2)
 
 lemma maddux_3_20:
   "((v \<sqinter> w) \<squnion> (-v \<sqinter> x)) \<sqinter> -((v \<sqinter> y) \<squnion> (-v \<sqinter> z)) = (v \<sqinter> w \<sqinter> -y) \<squnion> (-v \<sqinter> x \<sqinter> -z)"
 proof -
   have "v \<sqinter> w \<sqinter> -(v \<sqinter> y) \<sqinter> -(-v \<sqinter> z) = v \<sqinter> w \<sqinter> -(v \<sqinter> y)"
     by (meson inf.cobounded1 inf_absorb1 le_infI1 p_antitone_iff)
   also have "... = v \<sqinter> w \<sqinter> -y"
     using inf.sup_relative_same_increasing inf_import_p inf_le1 by blast
   finally have 1: "v \<sqinter> w \<sqinter> -(v \<sqinter> y) \<sqinter> -(-v \<sqinter> z) = v \<sqinter> w \<sqinter> -y"
     .
   have "-v \<sqinter> x \<sqinter> -(v \<sqinter> y) \<sqinter> -(-v \<sqinter> z) = -v \<sqinter> x \<sqinter> -(-v \<sqinter> z)"
     by (simp add: inf.absorb1 le_infI1 p_antitone_inf)
   also have "... = -v \<sqinter> x \<sqinter> -z"
     by (simp add: inf.assoc inf_left_commute)
   finally have 2: "-v \<sqinter> x \<sqinter> -(v \<sqinter> y) \<sqinter> -(-v \<sqinter> z) = -v \<sqinter> x \<sqinter> -z"
     .
   have "((v \<sqinter> w) \<squnion> (-v \<sqinter> x)) \<sqinter> -((v \<sqinter> y) \<squnion> (-v \<sqinter> z)) = (v \<sqinter> w \<sqinter> -(v \<sqinter> y) \<sqinter> -(-v \<sqinter> z)) \<squnion> (-v \<sqinter> x \<sqinter> -(v \<sqinter> y) \<sqinter> -(-v \<sqinter> z))"
     by (simp add: inf_assoc inf_sup_distrib2)
   also have "... = (v \<sqinter> w \<sqinter> -y) \<squnion> (-v \<sqinter> x \<sqinter> -z)"
     using 1 2 by simp
   finally show ?thesis
     .
 qed
 
 lemma order_char_1:
   "x \<le> y \<longleftrightarrow> x \<le> y \<squnion> -x"
   by (metis inf.sup_left_isotone inf_sup_absorb le_supI1 maddux_3_12 sup_commute)
 
 lemma order_char_2:
   "x \<le> y \<longleftrightarrow> x \<squnion> -x \<le> y \<squnion> -x"
   using order_char_1 by auto
 
 lemma half_shunting:
   "x \<le> y \<squnion> z \<Longrightarrow> x \<sqinter> -z \<le> y"
   by (metis inf.sup_right_isotone inf_commute inf_sup_distrib1 sup.boundedE maddux_3_12)
 
 (*
 lemma pp_dist_sup [simp]: "--(x \<squnion> y) = --x \<squnion> --y" nitpick [expect=genuine] oops
 lemma regular_closed_sup: "regular x \<and> regular y \<longrightarrow> regular (x \<squnion> y)" nitpick [expect=genuine] oops
 lemma regular_complemented_iff: "regular x \<longleftrightarrow> complemented x" nitpick [expect=genuine] oops
 lemma selection_closed_sup: "selection s x \<and> selection t x \<longrightarrow> selection (s \<squnion> t) x" nitpick [expect=genuine] oops
 lemma stone [simp]: "-x \<squnion> --x = top" nitpick [expect=genuine] oops
 *)
 
 end
 
 subsection \<open>Stone Algebras\<close>
 
 text \<open>
 A Stone algebra is a distributive lattice with a pseudocomplement that satisfies the following equation.
 We thus obtain the other half of the requirements of a complement at least for the regular elements.
 \<close>
 
 class stone_algebra = pd_algebra +
   assumes stone [simp]: "-x \<squnion> --x = top"
 begin
 
 text \<open>
 As a consequence, we obtain both De Morgan's laws for all elements.
 \<close>
 
 lemma p_dist_inf [simp]:
   "-(x \<sqinter> y) = -x \<squnion> -y"
 proof (rule p_unique[THEN sym], rule allI, rule iffI)
   fix w
   assume "w \<sqinter> (x \<sqinter> y) = bot"
   hence "w \<sqinter> --x \<sqinter> y = bot"
     using inf_commute inf_left_commute pseudo_complement by auto
   hence 1: "w \<sqinter> --x \<le> -y"
     by (simp add: pseudo_complement)
   have "w = (w \<sqinter> -x) \<squnion> (w \<sqinter> --x)"
     using distrib_imp2 sup_inf_distrib1 by auto
   thus "w \<le> -x \<squnion> -y"
     using 1 by (metis inf_le2 sup.mono)
 next
   fix w
   assume "w \<le> -x \<squnion> -y"
   thus "w \<sqinter> (x \<sqinter> y) = bot"
     using order_trans p_supdist_inf pseudo_complement by blast
 qed
 
 lemma pp_dist_sup [simp]:
   "--(x \<squnion> y) = --x \<squnion> --y"
   by simp
 
 lemma regular_closed_sup:
   "regular x \<Longrightarrow> regular y \<Longrightarrow> regular (x \<squnion> y)"
   by simp
 
 text \<open>
 The regular elements are precisely the ones having a complement.
 \<close>
 
 lemma regular_complemented_iff:
   "regular x \<longleftrightarrow> complemented x"
   by (metis inf_p stone complemented_regular)
 
 lemma selection_closed_sup:
   "selection s x \<Longrightarrow> selection t x \<Longrightarrow> selection (s \<squnion> t) x"
   by (simp add: inf_sup_distrib2)
 
 lemma huntington_3_pp [simp]:
   "-(-x \<squnion> -y) \<squnion> -(-x \<squnion> y) = --x"
   by (metis p_dist_inf p_inf sup.commute sup_bot_left sup_inf_distrib1)
 
 lemma maddux_3_3 [simp]:
   "-(x \<squnion> y) \<squnion> -(x \<squnion> -y) = -x"
   by (simp add: sup_commute sup_inf_distrib1)
 
 lemma maddux_3_11_pp:
   "(x \<sqinter> -y) \<squnion> (x \<sqinter> --y) = x"
   by (metis inf_sup_distrib1 inf_top_right stone)
 
 lemma maddux_3_19_pp:
   "(-x \<sqinter> y) \<squnion> (--x \<sqinter> z) = (--x \<squnion> y) \<sqinter> (-x \<squnion> z)"
 proof -
   have "(--x \<squnion> y) \<sqinter> (-x \<squnion> z) = (--x \<sqinter> z) \<squnion> (y \<sqinter> -x) \<squnion> (y \<sqinter> z)"
     by (simp add: inf.commute inf_sup_distrib1 sup.assoc)
   also have "... = (--x \<sqinter> z) \<squnion> (y \<sqinter> -x) \<squnion> (y \<sqinter> z \<sqinter> (-x \<squnion> --x))"
     by simp
   also have "... = (--x \<sqinter> z) \<squnion> ((y \<sqinter> -x) \<squnion> (y \<sqinter> -x \<sqinter> z)) \<squnion> (y \<sqinter> z \<sqinter> --x)"
     using inf_sup_distrib1 sup_assoc inf_commute inf_assoc by presburger
   also have "... = (--x \<sqinter> z) \<squnion> (y \<sqinter> -x) \<squnion> (y \<sqinter> z \<sqinter> --x)"
     by simp
   also have "... = ((--x \<sqinter> z) \<squnion> (--x \<sqinter> z \<sqinter> y)) \<squnion> (y \<sqinter> -x)"
     by (simp add: inf_assoc inf_commute sup.left_commute sup_commute)
   also have "... = (--x \<sqinter> z) \<squnion> (y \<sqinter> -x)"
     by simp
   finally show ?thesis
     by (simp add: inf_commute sup_commute)
 qed
 
 lemma compl_inter_eq_pp:
   "--x \<sqinter> y = --x \<sqinter> z \<Longrightarrow> -x \<sqinter> y = -x \<sqinter> z \<Longrightarrow> y = z"
   by (metis inf_commute inf_p inf_sup_distrib1 inf_top.right_neutral p_bot p_dist_inf)
 
 lemma maddux_3_21_pp [simp]:
   "--x \<squnion> (-x \<sqinter> y) = --x \<squnion> y"
   by (simp add: sup.commute sup_inf_distrib1)
 
 lemma shunting_2_pp:
   "x \<le> --y \<longleftrightarrow> -x \<squnion> --y = top"
   by (metis inf_top_left p_bot p_dist_inf pseudo_complement)
 
 lemma shunting_p:
   "x \<sqinter> y \<le> -z \<longleftrightarrow> x \<le> -z \<squnion> -y"
   by (metis inf.assoc p_dist_inf p_shunting_swap pseudo_complement)
 
 text \<open>
 The following weak shunting property is interesting as it does not require the element \<open>z\<close> on the right-hand side to be regular.
 \<close>
 
 lemma shunting_var_p:
   "x \<sqinter> -y \<le> z \<longleftrightarrow> x \<le> z \<squnion> --y"
 proof
   assume "x \<sqinter> -y \<le> z"
   hence "z \<squnion> --y = --y \<squnion> (z \<squnion> x \<sqinter> -y)"
     by (simp add: sup.absorb1 sup.commute)
   thus "x \<le> z \<squnion> --y"
     by (metis inf_commute maddux_3_21_pp sup.commute sup.left_commute sup_left_divisibility)
 next
   assume "x \<le> z \<squnion> --y"
   thus "x \<sqinter> -y \<le> z"
     by (metis inf.mono maddux_3_12 sup_ge2)
 qed
 
 (* Whether conjugate_char_2_pp can be proved in pd_algebra or in p_algebra is unknown. *)
 lemma conjugate_char_2_pp:
   "conjugate f g \<longleftrightarrow> f bot = bot \<and> g bot = bot \<and> (\<forall>x y . f x \<sqinter> y \<le> --(f(x \<sqinter> --(g y))) \<and> g y \<sqinter> x \<le> --(g(y \<sqinter> --(f x))))"
 proof
   assume 1: "conjugate f g"
   hence 2: "dual_additive (uminus \<circ> g)"
     using conjugate_symmetric conjugate_dual_additive by auto
   show "f bot = bot \<and> g bot = bot \<and> (\<forall>x y . f x \<sqinter> y \<le> --(f(x \<sqinter> --(g y))) \<and> g y \<sqinter> x \<le> --(g(y \<sqinter> --(f x))))"
   proof (intro conjI)
     show "f bot = bot"
       using 1 by (metis conjugate_def inf_idem inf_bot_left)
   next
     show "g bot = bot"
       using 1 by (metis conjugate_def inf_idem inf_bot_right)
   next
     show "\<forall>x y . f x \<sqinter> y \<le> --(f(x \<sqinter> --(g y))) \<and> g y \<sqinter> x \<le> --(g(y \<sqinter> --(f x)))"
     proof (intro allI)
       fix x y
       have 3: "y \<le> -(f(x \<sqinter> -(g y)))"
         using 1 by (simp add: conjugate_def pseudo_complement inf_commute)
       have 4: "x \<le> -(g(y \<sqinter> -(f x)))"
         using 1 conjugate_def inf.commute pseudo_complement by fastforce
       have "y \<sqinter> -(f(x \<sqinter> --(g y))) = y \<sqinter> -(f(x \<sqinter> -(g y))) \<sqinter> -(f(x \<sqinter> --(g y)))"
         using 3 by (simp add: inf.le_iff_sup inf_commute)
       also have "... = y \<sqinter> -(f((x \<sqinter> -(g y)) \<squnion> (x \<sqinter> --(g y))))"
         using 1 conjugate_dual_additive dual_additive_def inf_assoc by auto
       also have "... = y \<sqinter> -(f x)"
         by (simp add: maddux_3_11_pp)
       also have "... \<le> -(f x)"
         by simp
       finally have 5: "f x \<sqinter> y \<le> --(f(x \<sqinter> --(g y)))"
         by (simp add: inf_commute p_shunting_swap)
       have "x \<sqinter> -(g(y \<sqinter> --(f x))) = x \<sqinter> -(g(y \<sqinter> -(f x))) \<sqinter> -(g(y \<sqinter> --(f x)))"
         using 4 by (simp add: inf.le_iff_sup inf_commute)
       also have "... = x \<sqinter> -(g((y \<sqinter> -(f x)) \<squnion> (y \<sqinter> --(f x))))"
         using 2 by (simp add: dual_additive_def inf_assoc)
       also have "... = x \<sqinter> -(g y)"
         by (simp add: maddux_3_11_pp)
       also have "... \<le> -(g y)"
         by simp
       finally have "g y \<sqinter> x \<le> --(g(y \<sqinter> --(f x)))"
         by (simp add: inf_commute p_shunting_swap)
       thus "f x \<sqinter> y \<le> --(f(x \<sqinter> --(g y))) \<and> g y \<sqinter> x \<le> --(g(y \<sqinter> --(f x)))"
         using 5 by simp
     qed
   qed
 next
   assume "f bot = bot \<and> g bot = bot \<and> (\<forall>x y . f x \<sqinter> y \<le> --(f(x \<sqinter> --(g y))) \<and> g y \<sqinter> x \<le> --(g(y \<sqinter> --(f x))))"
   thus "conjugate f g"
     by (unfold conjugate_def, metis inf_commute le_bot pp_inf_bot_iff regular_closed_bot)
 qed
 
 lemma conjugate_char_2_pp_additive:
   assumes "conjugate f g"
       and "additive f"
       and "additive g"
     shows "f x \<sqinter> y \<le> f(x \<sqinter> --(g y)) \<and> g y \<sqinter> x \<le> g(y \<sqinter> --(f x))"
 proof -
   have "f x \<sqinter> y = f ((x \<sqinter> --g y) \<squnion> (x \<sqinter> -g y)) \<sqinter> y"
     by (simp add: sup.commute sup_inf_distrib1)
   also have "... = (f (x \<sqinter> --g y) \<sqinter> y) \<squnion> (f (x \<sqinter> -g y) \<sqinter> y)"
     using assms(2) additive_def inf_sup_distrib2 by auto
   also have "... = f (x \<sqinter> --g y) \<sqinter> y"
     by (metis assms(1) conjugate_def inf_le2 pseudo_complement sup_bot.right_neutral)
   finally have 2: "f x \<sqinter> y \<le> f (x \<sqinter> --g y)"
     by simp
   have "g y \<sqinter> x = g ((y \<sqinter> --f x) \<squnion> (y \<sqinter> -f x)) \<sqinter> x"
     by (simp add: sup.commute sup_inf_distrib1)
   also have "... = (g (y \<sqinter> --f x) \<sqinter> x) \<squnion> (g (y \<sqinter> -f x) \<sqinter> x)"
     using assms(3) additive_def inf_sup_distrib2 by auto
   also have "... = g (y \<sqinter> --f x) \<sqinter> x"
     by (metis assms(1) conjugate_def inf.cobounded2 pseudo_complement sup_bot.right_neutral inf_commute)
   finally have "g y \<sqinter> x \<le> g (y \<sqinter> --f x)"
     by simp
   thus ?thesis
     using 2 by simp
 qed
 
 (*
 lemma compl_le_swap2_iff: "-x \<le> y \<longleftrightarrow> -y \<le> x" nitpick [expect=genuine] oops
 lemma huntington_3: "x = -(-x \<squnion> -y) \<squnion> -(-x \<squnion> y)" nitpick [expect=genuine] oops
 lemma maddux_3_1: "x \<squnion> -x = y \<squnion> -y" nitpick [expect=genuine] oops
 lemma maddux_3_4: "x \<squnion> (y \<squnion> -y) = z \<squnion> -z" nitpick [expect=genuine] oops
 lemma maddux_3_11: "x = (x \<sqinter> y) \<squnion> (x \<sqinter> -y)" nitpick [expect=genuine] oops
 lemma maddux_3_19: "(-x \<sqinter> y) \<squnion> (x \<sqinter> z) = (x \<squnion> y) \<sqinter> (-x \<squnion> z)" nitpick [expect=genuine] oops
 lemma compl_inter_eq: "x \<sqinter> y = x \<sqinter> z \<and> -x \<sqinter> y = -x \<sqinter> z \<longrightarrow> y = z" nitpick [expect=genuine] oops
 lemma maddux_3_21: "x \<squnion> y = x \<squnion> (-x \<sqinter> y)" nitpick [expect=genuine] oops
 lemma shunting_1: "x \<le> y \<longleftrightarrow> x \<sqinter> -y = bot" nitpick [expect=genuine] oops
 lemma shunting_2: "x \<le> y \<longleftrightarrow> -x \<squnion> y = top" nitpick [expect=genuine] oops
 lemma conjugate_unique: "conjugate f g \<and> conjugate f h \<longrightarrow> g = h" nitpick [expect=genuine] oops
 lemma conjugate_isotone_pp: "conjugate f g \<longrightarrow> isotone f" nitpick [expect=genuine] oops
 lemma conjugate_char_1: "conjugate f g \<longleftrightarrow> (\<forall>x y . f(x \<sqinter> -(g y)) \<le> f x \<sqinter> -y \<and> g(y \<sqinter> -(f x)) \<le> g y \<sqinter> -x)" nitpick [expect=genuine] oops
 lemma conjugate_char_2: "conjugate f g \<longleftrightarrow> f bot = bot \<and> g bot = bot \<and> (\<forall>x y . f x \<sqinter> y \<le> f(x \<sqinter> g y) \<and> g y \<sqinter> x \<le> g(y \<sqinter> f x))" nitpick [expect=genuine] oops
 lemma shunting: "x \<sqinter> y \<le> z \<longleftrightarrow> x \<le> z \<squnion> -y" nitpick [expect=genuine] oops
 lemma shunting_var: "x \<sqinter> -y \<le> z \<longleftrightarrow> x \<le> z \<squnion> y" nitpick [expect=genuine] oops
 lemma sup_compl_top: "x \<squnion> -x = top" nitpick [expect=genuine] oops
 lemma selection_closed_p: "selection s x \<longrightarrow> selection (-s) x" nitpick [expect=genuine] oops
 lemma selection_closed_pp: "selection s x \<longrightarrow> selection (--s) x" nitpick [expect=genuine] oops
 *)
 
 end
 
 abbreviation stone_algebra_isomorphism :: "('a::stone_algebra \<Rightarrow> 'b::stone_algebra) \<Rightarrow> bool"
   where "stone_algebra_isomorphism f \<equiv> sup_inf_top_bot_uminus_isomorphism f"
 
 text \<open>
 Every bounded linear order can be expanded to a Stone algebra.
 The pseudocomplement takes \<open>bot\<close> to the \<open>top\<close> and every other element to \<open>bot\<close>.
 \<close>
 
 class linorder_stone_algebra_expansion = linorder_lattice_expansion + uminus +
   assumes uminus_def [simp]: "-x = (if x = bot then top else bot)"
 begin
 
 subclass stone_algebra
   apply unfold_locales
   using bot_unique min_def top_le by auto
 
 text \<open>
 The regular elements are the least and greatest elements.
 All elements except the least element are dense.
 \<close>
 
 lemma regular_bot_top:
   "regular x \<longleftrightarrow> x = bot \<or> x = top"
   by simp
 
 lemma not_bot_dense:
   "x \<noteq> bot \<Longrightarrow> --x = top"
   by simp
 
 end
 
 subsection \<open>Heyting Algebras\<close>
 
 text \<open>
 In this section we add a relative pseudocomplement operation to semilattices and to lattices.
 \<close>
 
 subsubsection \<open>Heyting Semilattices\<close>
 
 text \<open>
 The pseudocomplement of an element \<open>y\<close> relative to an element \<open>z\<close> is the least element whose meet with \<open>y\<close> is below \<open>z\<close>.
 This can be stated as a Galois connection.
 Specialising \<open>z = bot\<close> gives (non-relative) pseudocomplements.
 Many properties can already be shown if the underlying structure is just a semilattice.
 \<close>
 
 class implies =
   fixes implies :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<leadsto>" 65)
 
 class heyting_semilattice = semilattice_inf + implies +
   assumes implies_galois: "x \<sqinter> y \<le> z \<longleftrightarrow> x \<le> y \<leadsto> z"
 begin
 
 lemma implies_below_eq [simp]:
   "y \<sqinter> (x \<leadsto> y) = y"
   using implies_galois inf.absorb_iff1 inf.cobounded1 by blast
 
 lemma implies_increasing:
   "x \<le> y \<leadsto> x"
   by (simp add: inf.orderI)
 
 lemma implies_galois_swap:
   "x \<le> y \<leadsto> z \<longleftrightarrow> y \<le> x \<leadsto> z"
   by (metis implies_galois inf_commute)
 
 lemma implies_galois_var:
   "x \<sqinter> y \<le> z \<longleftrightarrow> y \<le> x \<leadsto> z"
   by (simp add: implies_galois_swap implies_galois)
 
 lemma implies_galois_increasing:
   "x \<le> y \<leadsto> (x \<sqinter> y)"
   using implies_galois by blast
 
 lemma implies_galois_decreasing:
   "(y \<leadsto> x) \<sqinter> y \<le> x"
   using implies_galois by blast
 
 lemma implies_mp_below:
   "x \<sqinter> (x \<leadsto> y) \<le> y"
   using implies_galois_decreasing inf_commute by auto
 
 lemma implies_isotone:
   "x \<le> y \<Longrightarrow> z \<leadsto> x \<le> z \<leadsto> y"
   using implies_galois order_trans by blast
 
 lemma implies_antitone:
   "x \<le> y \<Longrightarrow> y \<leadsto> z \<le> x \<leadsto> z"
   by (meson implies_galois_swap order_lesseq_imp)
 
 lemma implies_isotone_inf:
   "x \<leadsto> (y \<sqinter> z) \<le> x \<leadsto> y"
   by (simp add: implies_isotone)
 
 lemma implies_antitone_inf:
   "x \<leadsto> z \<le> (x \<sqinter> y) \<leadsto> z"
   by (simp add: implies_antitone)
 
 lemma implies_curry:
   "x \<leadsto> (y \<leadsto> z) = (x \<sqinter> y) \<leadsto> z"
   by (metis implies_galois_decreasing implies_galois inf_assoc order.antisym)
 
 lemma implies_curry_flip:
   "x \<leadsto> (y \<leadsto> z) = y \<leadsto> (x \<leadsto> z)"
   by (simp add: implies_curry inf_commute)
 
 lemma triple_implies [simp]:
   "((x \<leadsto> y) \<leadsto> y) \<leadsto> y = x \<leadsto> y"
   using implies_antitone implies_galois_swap order.eq_iff by auto
 
 lemma implies_mp_eq [simp]:
   "x \<sqinter> (x \<leadsto> y) = x \<sqinter> y"
   by (metis implies_below_eq implies_mp_below inf_left_commute inf.absorb2)
 
 lemma implies_dist_implies:
   "x \<leadsto> (y \<leadsto> z) \<le> (x \<leadsto> y) \<leadsto> (x \<leadsto> z)"
   using implies_curry implies_curry_flip by auto
 
 lemma implies_import_inf [simp]:
   "x \<sqinter> ((x \<sqinter> y) \<leadsto> (x \<leadsto> z)) = x \<sqinter> (y \<leadsto> z)"
   by (metis implies_curry implies_mp_eq inf_commute)
 
 lemma implies_dist_inf:
   "x \<leadsto> (y \<sqinter> z) = (x \<leadsto> y) \<sqinter> (x \<leadsto> z)"
 proof -
   have "(x \<leadsto> y) \<sqinter> (x \<leadsto> z) \<sqinter> x \<le> y \<sqinter> z"
     by (simp add: implies_galois)
   hence "(x \<leadsto> y) \<sqinter> (x \<leadsto> z) \<le> x \<leadsto> (y \<sqinter> z)"
     using implies_galois by blast
   thus ?thesis
     by (simp add: implies_isotone order.eq_iff)
 qed
 
 lemma implies_itself_top:
   "y \<le> x \<leadsto> x"
   by (simp add: implies_galois_swap implies_increasing)
 
 lemma inf_implies_top:
   "z \<le> (x \<sqinter> y) \<leadsto> x"
   using implies_galois_var le_infI1 by blast
 
 lemma inf_inf_implies [simp]:
   "z \<sqinter> ((x \<sqinter> y) \<leadsto> x) = z"
   by (simp add: inf_implies_top inf_absorb1)
 
 lemma le_implies_top:
   "x \<le> y \<Longrightarrow> z \<le> x \<leadsto> y"
   using implies_antitone implies_itself_top order.trans by blast
 
 lemma le_iff_le_implies:
   "x \<le> y \<longleftrightarrow> x \<le> x \<leadsto> y"
   using implies_galois inf_idem by force
 
 lemma implies_inf_isotone:
   "x \<leadsto> y \<le> (x \<sqinter> z) \<leadsto> (y \<sqinter> z)"
   by (metis implies_curry implies_galois_increasing implies_isotone)
 
 lemma implies_transitive:
   "(x \<leadsto> y) \<sqinter> (y \<leadsto> z) \<le> x \<leadsto> z"
   using implies_dist_implies implies_galois_var implies_increasing order_lesseq_imp by blast
 
 lemma implies_inf_absorb [simp]:
   "x \<leadsto> (x \<sqinter> y) = x \<leadsto> y"
   using implies_dist_inf implies_itself_top inf.absorb_iff2 by auto
 
 lemma implies_implies_absorb [simp]:
   "x \<leadsto> (x \<leadsto> y) = x \<leadsto> y"
   by (simp add: implies_curry)
 
 lemma implies_inf_identity:
   "(x \<leadsto> y) \<sqinter> y = y"
   by (simp add: inf_commute)
 
 lemma implies_itself_same:
   "x \<leadsto> x = y \<leadsto> y"
   by (simp add: le_implies_top order.eq_iff)
 
 end
 
 text \<open>
 The following class gives equational axioms for the relative pseudocomplement operation (inequalities can be written as equations).
 \<close>
 
 class heyting_semilattice_eq = semilattice_inf + implies +
   assumes implies_mp_below: "x \<sqinter> (x \<leadsto> y) \<le> y"
       and implies_galois_increasing: "x \<le> y \<leadsto> (x \<sqinter> y)"
       and implies_isotone_inf: "x \<leadsto> (y \<sqinter> z) \<le> x \<leadsto> y"
 begin
 
 subclass heyting_semilattice
   apply unfold_locales
   apply (rule iffI)
   apply (metis implies_galois_increasing implies_isotone_inf inf.absorb2 order_lesseq_imp)
   by (metis implies_mp_below inf_commute order_trans inf_mono order_refl)
 
 end
 
 text \<open>
 The following class allows us to explicitly give the pseudocomplement of an element relative to itself.
 \<close>
 
 class bounded_heyting_semilattice = bounded_semilattice_inf_top + heyting_semilattice
 begin
 
 lemma implies_itself [simp]:
   "x \<leadsto> x = top"
   using implies_galois inf_le2 top_le by blast
 
 lemma implies_order:
   "x \<le> y \<longleftrightarrow> x \<leadsto> y = top"
   by (metis implies_galois inf_top.left_neutral top_unique)
 
 lemma inf_implies [simp]:
   "(x \<sqinter> y) \<leadsto> x = top"
   using implies_order inf_le1 by blast
 
 lemma top_implies [simp]:
   "top \<leadsto> x = x"
   by (metis implies_mp_eq inf_top.left_neutral)
 
 end
 
 subsubsection \<open>Heyting Lattices\<close>
 
 text \<open>
 We obtain further properties if the underlying structure is a lattice.
 In particular, the lattice operations are automatically distributive in this case.
 \<close>
 
 class heyting_lattice = lattice + heyting_semilattice
 begin
 
 lemma sup_distrib_inf_le:
   "(x \<squnion> y) \<sqinter> (x \<squnion> z) \<le> x \<squnion> (y \<sqinter> z)"
 proof -
   have "x \<squnion> z \<le> y \<leadsto> (x \<squnion> (y \<sqinter> z))"
     using implies_galois_var implies_increasing sup.bounded_iff sup.cobounded2 by blast
   hence "x \<squnion> y \<le> (x \<squnion> z) \<leadsto> (x \<squnion> (y \<sqinter> z))"
     using implies_galois_swap implies_increasing le_sup_iff by blast
   thus ?thesis
     by (simp add: implies_galois)
 qed
 
 subclass distrib_lattice
   apply unfold_locales
   using distrib_sup_le order.eq_iff sup_distrib_inf_le by auto
 
 lemma implies_isotone_sup:
   "x \<leadsto> y \<le> x \<leadsto> (y \<squnion> z)"
   by (simp add: implies_isotone)
 
 lemma implies_antitone_sup:
   "(x \<squnion> y) \<leadsto> z \<le> x \<leadsto> z"
   by (simp add: implies_antitone)
 
 lemma implies_sup:
   "x \<leadsto> z \<le> (y \<leadsto> z) \<leadsto> ((x \<squnion> y) \<leadsto> z)"
 proof -
   have "(x \<leadsto> z) \<sqinter> (y \<leadsto> z) \<sqinter> y \<le> z"
     by (simp add: implies_galois)
   hence "(x \<leadsto> z) \<sqinter> (y \<leadsto> z) \<sqinter> (x \<squnion> y) \<le> z"
     using implies_galois_swap implies_galois_var by fastforce
   thus ?thesis
     by (simp add: implies_galois)
 qed
 
 lemma implies_dist_sup:
   "(x \<squnion> y) \<leadsto> z = (x \<leadsto> z) \<sqinter> (y \<leadsto> z)"
   apply (rule order.antisym)
   apply (simp add: implies_antitone)
   by (simp add: implies_sup implies_galois)
 
 lemma implies_antitone_isotone:
   "(x \<squnion> y) \<leadsto> (x \<sqinter> y) \<le> x \<leadsto> y"
   by (simp add: implies_antitone_sup implies_dist_inf le_infI2)
 
 lemma implies_antisymmetry:
   "(x \<leadsto> y) \<sqinter> (y \<leadsto> x) = (x \<squnion> y) \<leadsto> (x \<sqinter> y)"
   by (metis implies_dist_sup implies_inf_absorb inf.commute)
 
 lemma sup_inf_implies [simp]:
   "(x \<squnion> y) \<sqinter> (x \<leadsto> y) = y"
   by (simp add: inf_sup_distrib2 sup.absorb2)
 
 lemma implies_subdist_sup:
   "(x \<leadsto> y) \<squnion> (x \<leadsto> z) \<le> x \<leadsto> (y \<squnion> z)"
   by (simp add: implies_isotone)
 
 lemma implies_subdist_inf:
   "(x \<leadsto> z) \<squnion> (y \<leadsto> z) \<le> (x \<sqinter> y) \<leadsto> z"
   by (simp add: implies_antitone)
 
 lemma implies_sup_absorb:
   "(x \<leadsto> y) \<squnion> z \<le> (x \<squnion> z) \<leadsto> (y \<squnion> z)"
   by (metis implies_dist_sup implies_isotone_sup implies_increasing inf_inf_implies le_sup_iff sup_inf_implies)
 
 lemma sup_below_implies_implies:
   "x \<squnion> y \<le> (x \<leadsto> y) \<leadsto> y"
   by (simp add: implies_dist_sup implies_galois_swap implies_increasing)
 
 end
 
 class bounded_heyting_lattice = bounded_lattice + heyting_lattice
 begin
 
 subclass bounded_heyting_semilattice ..
 
 lemma implies_bot [simp]:
   "bot \<leadsto> x = top"
   using implies_galois top_unique by fastforce
 
 end
 
 subsubsection \<open>Heyting Algebras\<close>
 
 text \<open>
 The pseudocomplement operation can be defined in Heyting algebras, but it is typically not part of their signature.
 We add the definition as an axiom so that we can use the class hierarchy, for example, to inherit results from the class \<open>pd_algebra\<close>.
 \<close>
 
 class heyting_algebra = bounded_heyting_lattice + uminus +
   assumes uminus_eq: "-x = x \<leadsto> bot"
 begin
 
 subclass pd_algebra
   apply unfold_locales
   using bot_unique implies_galois uminus_eq by auto
 
 lemma boolean_implies_below:
   "-x \<squnion> y \<le> x \<leadsto> y"
   by (simp add: implies_increasing implies_isotone uminus_eq)
 
 lemma negation_implies:
   "-(x \<leadsto> y) = --x \<sqinter> -y"
 proof (rule order.antisym)
   show "-(x \<leadsto> y) \<le> --x \<sqinter> -y"
     using boolean_implies_below p_antitone by auto
 next
   have "x \<sqinter> -y \<sqinter> (x \<leadsto> y) = bot"
     by (metis implies_mp_eq inf_p inf_bot_left inf_commute inf_left_commute)
   hence "--x \<sqinter> -y \<sqinter> (x \<leadsto> y) = bot"
     using pp_inf_bot_iff inf_assoc by auto
   thus "--x \<sqinter> -y \<le> -(x \<leadsto> y)"
     by (simp add: pseudo_complement)
 qed
 
 lemma double_negation_dist_implies:
   "--(x \<leadsto> y) = --x \<leadsto> --y"
   apply (rule order.antisym)
   apply (metis pp_inf_below_iff implies_galois_decreasing implies_galois negation_implies ppp)
   by (simp add: p_antitone_iff negation_implies)
 
 (*
 lemma stone: "-x \<squnion> --x = top" nitpick [expect=genuine] oops
 *)
 
 end
 
 text \<open>
 The following class gives equational axioms for Heyting algebras.
 \<close>
 
 class heyting_algebra_eq = bounded_lattice + implies + uminus +
   assumes implies_mp_eq: "x \<sqinter> (x \<leadsto> y) = x \<sqinter> y"
       and implies_import_inf: "x \<sqinter> ((x \<sqinter> y) \<leadsto> (x \<leadsto> z)) = x \<sqinter> (y \<leadsto> z)"
       and inf_inf_implies: "z \<sqinter> ((x \<sqinter> y) \<leadsto> x) = z"
       and uminus_eq_eq: "-x = x \<leadsto> bot"
 begin
 
 subclass heyting_algebra
   apply unfold_locales
   apply (rule iffI)
   apply (metis implies_import_inf inf.sup_left_divisibility inf_inf_implies le_iff_inf)
   apply (metis implies_mp_eq inf.commute inf.le_sup_iff inf.sup_right_isotone)
   by (simp add: uminus_eq_eq)
 
 end
 
 text \<open>
 A relative pseudocomplement is not enough to obtain the Stone equation, so we add it in the following class.
 \<close>
 
 class heyting_stone_algebra = heyting_algebra +
   assumes heyting_stone: "-x \<squnion> --x = top"
 begin
 
 subclass stone_algebra
   by unfold_locales (simp add: heyting_stone)
 
 (*
 lemma pre_linear: "(x \<leadsto> y) \<squnion> (y \<leadsto> x) = top" nitpick [expect=genuine] oops
 *)
 
 end
 
 subsubsection \<open>Brouwer Algebras\<close>
 
 text \<open>
 Brouwer algebras are dual to Heyting algebras.
 The dual pseudocomplement of an element \<open>y\<close> relative to an element \<open>x\<close> is the least element whose join with \<open>y\<close> is above \<open>x\<close>.
 We can now use the binary operation provided by Boolean algebras in Isabelle/HOL because it is compatible with dual relative pseudocomplements (not relative pseudocomplements).
 \<close>
 
 class brouwer_algebra = bounded_lattice + minus + uminus +
   assumes minus_galois: "x \<le> y \<squnion> z \<longleftrightarrow> x - y \<le> z"
       and uminus_eq_minus: "-x = top - x"
 begin
 
 sublocale brouwer: heyting_algebra where inf = sup and less_eq = greater_eq and less = greater and sup = inf and bot = top and top = bot and implies = "\<lambda>x y . y - x"
   apply unfold_locales
   apply simp
   apply simp
   apply simp
   apply simp
   apply (metis minus_galois sup_commute)
   by (simp add: uminus_eq_minus)
 
 lemma curry_minus:
   "x - (y \<squnion> z) = (x - y) - z"
   by (simp add: brouwer.implies_curry sup_commute)
 
 lemma minus_subdist_sup:
   "(x - z) \<squnion> (y - z) \<le> (x \<squnion> y) - z"
   by (simp add: brouwer.implies_dist_inf)
 
 lemma inf_sup_minus:
   "(x \<sqinter> y) \<squnion> (x - y) = x"
   by (simp add: inf.absorb1 brouwer.inf_sup_distrib2)
 
 end
 
 subsection \<open>Boolean Algebras\<close>
 
 text \<open>
 This section integrates Boolean algebras in the above hierarchy.
 In particular, we strengthen several results shown above.
 \<close>
 
-context Lattices.boolean_algebra
+context boolean_algebra
 begin
 
 text \<open>
 Every Boolean algebra is a Stone algebra, a Heyting algebra and a Brouwer algebra.
 \<close>
 
 subclass stone_algebra
   apply unfold_locales
   apply (rule iffI)
   apply (metis compl_sup_top inf.orderI inf_bot_right inf_sup_distrib1 inf_top_right sup_inf_absorb)
   using inf.commute inf.sup_right_divisibility apply fastforce
   by simp
 
 sublocale heyting: heyting_algebra where implies = "\<lambda>x y . -x \<squnion> y"
   apply unfold_locales
   apply (rule iffI)
   using shunting_var_p sup_commute apply fastforce
   using shunting_var_p sup_commute apply force
   by simp
 
 subclass brouwer_algebra
   apply unfold_locales
   apply (simp add: diff_eq shunting_var_p sup.commute)
   by (simp add: diff_eq)
 
 lemma huntington_3 [simp]:
   "-(-x \<squnion> -y) \<squnion> -(-x \<squnion> y) = x"
   using huntington_3_pp by auto
 
 lemma maddux_3_1:
   "x \<squnion> -x = y \<squnion> -y"
   by simp
 
 lemma maddux_3_4:
   "x \<squnion> (y \<squnion> -y) = z \<squnion> -z"
   by simp
 
 lemma maddux_3_11 [simp]:
   "(x \<sqinter> y) \<squnion> (x \<sqinter> -y) = x"
   using brouwer.maddux_3_12 sup.commute by auto
 
 lemma maddux_3_19:
   "(-x \<sqinter> y) \<squnion> (x \<sqinter> z) = (x \<squnion> y) \<sqinter> (-x \<squnion> z)"
   using maddux_3_19_pp by auto
 
 lemma compl_inter_eq:
   "x \<sqinter> y = x \<sqinter> z \<Longrightarrow> -x \<sqinter> y = -x \<sqinter> z \<Longrightarrow> y = z"
   by (metis inf_commute maddux_3_11)
 
 lemma maddux_3_21 [simp]:
   "x \<squnion> (-x \<sqinter> y) = x \<squnion> y"
   by (simp add: sup_inf_distrib1)
 
 lemma shunting_1:
   "x \<le> y \<longleftrightarrow> x \<sqinter> -y = bot"
   by (simp add: pseudo_complement)
 
 lemma uminus_involutive:
   "uminus \<circ> uminus = id"
   by auto
 
 lemma uminus_injective:
   "uminus \<circ> f = uminus \<circ> g \<Longrightarrow> f = g"
   by (metis comp_assoc id_o minus_comp_minus)
 
 lemma conjugate_unique:
   "conjugate f g \<Longrightarrow> conjugate f h \<Longrightarrow> g = h"
   using conjugate_unique_p uminus_injective by blast
 
 lemma dual_additive_additive:
   "dual_additive (uminus \<circ> f) \<Longrightarrow> additive f"
   by (metis additive_def compl_eq_compl_iff dual_additive_def p_dist_sup o_def)
 
 lemma conjugate_additive:
   "conjugate f g \<Longrightarrow> additive f"
   by (simp add: conjugate_dual_additive dual_additive_additive)
 
 lemma conjugate_isotone:
   "conjugate f g \<Longrightarrow> isotone f"
   by (simp add: conjugate_additive additive_isotone)
 
 lemma conjugate_char_1:
   "conjugate f g \<longleftrightarrow> (\<forall>x y . f(x \<sqinter> -(g y)) \<le> f x \<sqinter> -y \<and> g(y \<sqinter> -(f x)) \<le> g y \<sqinter> -x)"
   by (simp add: conjugate_char_1_pp)
 
 lemma conjugate_char_2:
   "conjugate f g \<longleftrightarrow> f bot = bot \<and> g bot = bot \<and> (\<forall>x y . f x \<sqinter> y \<le> f(x \<sqinter> g y) \<and> g y \<sqinter> x \<le> g(y \<sqinter> f x))"
   by (simp add: conjugate_char_2_pp)
 
 lemma shunting:
   "x \<sqinter> y \<le> z \<longleftrightarrow> x \<le> z \<squnion> -y"
   by (simp add: heyting.implies_galois sup.commute)
 
 lemma shunting_var:
   "x \<sqinter> -y \<le> z \<longleftrightarrow> x \<le> z \<squnion> y"
   by (simp add: shunting)
 
 end
 
 class non_trivial_stone_algebra = non_trivial_bounded_order + stone_algebra
 
 class non_trivial_boolean_algebra = non_trivial_stone_algebra + boolean_algebra
 
 end
 
diff --git a/thys/Stone_Relation_Algebras/Matrix_Relation_Algebras.thy b/thys/Stone_Relation_Algebras/Matrix_Relation_Algebras.thy
--- a/thys/Stone_Relation_Algebras/Matrix_Relation_Algebras.thy
+++ b/thys/Stone_Relation_Algebras/Matrix_Relation_Algebras.thy
@@ -1,613 +1,613 @@
 (* Title:      Matrix Relation Algebras
    Author:     Walter Guttmann
    Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
 *)
 
 section \<open>Matrix Relation Algebras\<close>
 
 text \<open>
 This theory gives matrix models of Stone relation algebras and more general structures.
 We consider only square matrices.
 The main result is that matrices over Stone relation algebras form a Stone relation algebra.
 
 We use the monoid structure underlying semilattices to provide finite sums, which are necessary for defining the composition of two matrices.
 See \cite{ArmstrongFosterStruthWeber2016,ArmstrongGomesStruthWeber2016} for similar liftings to matrices for semirings and relation algebras.
 A technical difference is that those theories are mostly based on semirings whereas our hierarchy is mostly based on lattices (and our semirings directly inherit from semilattices).
 
 Relation algebras have both a semiring and a lattice structure such that semiring addition and lattice join coincide.
 In particular, finite sums and finite suprema coincide.
 Isabelle/HOL has separate theories for semirings and lattices, based on separate addition and join operations and different operations for finite sums and finite suprema.
 Reusing results from both theories is beneficial for relation algebras, but not always easy to realise.
 \<close>
 
 theory Matrix_Relation_Algebras
 
 imports Relation_Algebras
 
 begin
 
 subsection \<open>Finite Suprema\<close>
 
 text \<open>
 We consider finite suprema in idempotent semirings and Stone relation algebras.
 We mostly use the first of the following notations, which denotes the supremum of expressions \<open>t(x)\<close> over all \<open>x\<close> from the type of \<open>x\<close>.
 For finite types, this is implemented in Isabelle/HOL as the repeated application of binary suprema.
 \<close>
 
 syntax
   "_sum_sup_monoid" :: "idt \<Rightarrow> 'a::bounded_semilattice_sup_bot \<Rightarrow> 'a" ("(\<Squnion>\<^sub>_ _)" [0,10] 10)
   "_sum_sup_monoid_bounded" :: "idt \<Rightarrow> 'b set \<Rightarrow> 'a::bounded_semilattice_sup_bot \<Rightarrow> 'a" ("(\<Squnion>\<^bsub>_\<in>_\<^esub> _)" [0,51,10] 10)
 translations
   "\<Squnion>\<^sub>x t" => "XCONST sup_monoid.sum (\<lambda>x . t) { x . CONST True }"
   "\<Squnion>\<^bsub>x\<in>X\<^esub> t" => "XCONST sup_monoid.sum (\<lambda>x . t) X"
 
 context idempotent_semiring
 begin
 
 text \<open>
 The following induction principles are useful for comparing two suprema.
 The first principle works because types are not empty.
 \<close>
 
 lemma one_sup_induct [case_names one sup]:
   fixes f g :: "'b::finite \<Rightarrow> 'a"
   assumes one: "\<And>i . P (f i) (g i)"
       and sup: "\<And>j I . j \<notin> I \<Longrightarrow> P (\<Squnion>\<^bsub>i\<in>I\<^esub> f i) (\<Squnion>\<^bsub>i\<in>I\<^esub> g i) \<Longrightarrow> P (f j \<squnion> (\<Squnion>\<^bsub>i\<in>I\<^esub> f i)) (g j \<squnion> (\<Squnion>\<^bsub>i\<in>I\<^esub> g i))"
     shows "P (\<Squnion>\<^sub>k f k) (\<Squnion>\<^sub>k g k)"
 proof -
   let ?X = "{ k::'b . True }"
   have "finite ?X" and "?X \<noteq> {}"
     by auto
   thus ?thesis
   proof (induct rule: finite_ne_induct)
     case (singleton i) thus ?case
       using one by simp
   next
     case (insert j I) thus ?case
       using sup by simp
   qed
 qed
 
 lemma bot_sup_induct [case_names bot sup]:
   fixes f g :: "'b::finite \<Rightarrow> 'a"
   assumes bot: "P bot bot"
       and sup: "\<And>j I . j \<notin> I \<Longrightarrow> P (\<Squnion>\<^bsub>i\<in>I\<^esub> f i) (\<Squnion>\<^bsub>i\<in>I\<^esub> g i) \<Longrightarrow> P (f j \<squnion> (\<Squnion>\<^bsub>i\<in>I\<^esub> f i)) (g j \<squnion> (\<Squnion>\<^bsub>i\<in>I\<^esub> g i))"
     shows "P (\<Squnion>\<^sub>k f k) (\<Squnion>\<^sub>k g k)"
   apply (induct rule: one_sup_induct)
   using bot sup apply fastforce
   using sup by blast
 
 text \<open>
 Now many properties of finite suprema follow by simple applications of the above induction rules.
 In particular, we show distributivity of composition, isotonicity and the upper-bound property.
 \<close>
 
 lemma comp_right_dist_sum:
   fixes f :: "'b::finite \<Rightarrow> 'a"
   shows "(\<Squnion>\<^sub>k f k * x) = (\<Squnion>\<^sub>k f k) * x"
 proof (induct rule: one_sup_induct)
   case one show ?case
     by simp
 next
   case (sup j I) thus ?case
     using mult_right_dist_sup by auto
 qed
 
 lemma comp_left_dist_sum:
   fixes f :: "'b::finite \<Rightarrow> 'a"
   shows "(\<Squnion>\<^sub>k x * f k) = x * (\<Squnion>\<^sub>k f k)"
 proof (induct rule: one_sup_induct)
   case one show ?case
     by simp
 next
   case (sup j I) thus ?case
     by (simp add: mult_left_dist_sup)
 qed
 
 lemma leq_sum:
   fixes f g :: "'b::finite \<Rightarrow> 'a"
   shows "(\<forall>k . f k \<le> g k) \<Longrightarrow> (\<Squnion>\<^sub>k f k) \<le> (\<Squnion>\<^sub>k g k)"
 proof (induct rule: one_sup_induct)
   case one thus ?case
     by simp
 next
   case (sup j I) thus ?case
     using sup_mono by blast
 qed
 
 lemma ub_sum:
   fixes f :: "'b::finite \<Rightarrow> 'a"
   shows "f i \<le> (\<Squnion>\<^sub>k f k)"
 proof -
   have "i \<in> { k . True }"
     by simp
   thus "f i \<le> (\<Squnion>\<^sub>k f (k::'b))"
     by (metis finite_code sup_monoid.sum.insert sup_ge1 mk_disjoint_insert)
 qed
 
 lemma lub_sum:
   fixes f :: "'b::finite \<Rightarrow> 'a"
   assumes "\<forall>k . f k \<le> x"
     shows "(\<Squnion>\<^sub>k f k) \<le> x"
 proof (induct rule: one_sup_induct)
   case one show ?case
     by (simp add: assms)
 next
   case (sup j I) thus ?case
     using assms le_supI by blast
 qed
 
 lemma lub_sum_iff:
   fixes f :: "'b::finite \<Rightarrow> 'a"
   shows "(\<forall>k . f k \<le> x) \<longleftrightarrow> (\<Squnion>\<^sub>k f k) \<le> x"
   using order.trans ub_sum lub_sum by blast
 
 end
 
 context stone_relation_algebra
 begin
 
 text \<open>
 In Stone relation algebras, we can also show that converse,  double complement and meet distribute over finite suprema.
 \<close>
 
 lemma conv_dist_sum:
   fixes f :: "'b::finite \<Rightarrow> 'a"
   shows "(\<Squnion>\<^sub>k (f k)\<^sup>T) = (\<Squnion>\<^sub>k f k)\<^sup>T"
 proof (induct rule: one_sup_induct)
   case one show ?case
     by simp
 next
   case (sup j I) thus ?case
     by (simp add: conv_dist_sup)
 qed
 
 lemma pp_dist_sum:
   fixes f :: "'b::finite \<Rightarrow> 'a"
   shows "(\<Squnion>\<^sub>k --f k) = --(\<Squnion>\<^sub>k f k)"
 proof (induct rule: one_sup_induct)
   case one show ?case
     by simp
 next
   case (sup j I) thus ?case
     by simp
 qed
 
 lemma inf_right_dist_sum:
   fixes f :: "'b::finite \<Rightarrow> 'a"
   shows "(\<Squnion>\<^sub>k f k \<sqinter> x) = (\<Squnion>\<^sub>k f k) \<sqinter> x"
   by (rule comp_inf.comp_right_dist_sum)
 
 end
 
 subsection \<open>Square Matrices\<close>
 
 text \<open>
 Because our semiring and relation algebra type classes only work for homogeneous relations, we only look at square matrices.
 \<close>
 
 type_synonym ('a,'b) square = "'a \<times> 'a \<Rightarrow> 'b"
 
 text \<open>
 We use standard matrix operations.
 The Stone algebra structure is lifted componentwise.
 Composition is matrix multiplication using given composition and supremum operations.
 Its unit lifts given zero and one elements into an identity matrix.
 Converse is matrix transpose with an additional componentwise transpose.
 \<close>
 
 definition less_eq_matrix :: "('a,'b::ord) square \<Rightarrow> ('a,'b) square \<Rightarrow> bool"                                           (infix "\<preceq>" 50)   where "f \<preceq> g = (\<forall>e . f e \<le> g e)"
 definition less_matrix    :: "('a,'b::ord) square \<Rightarrow> ('a,'b) square \<Rightarrow> bool"                                           (infix "\<prec>" 50)   where "f \<prec> g = (f \<preceq> g \<and> \<not> g \<preceq> f)"
 definition sup_matrix     :: "('a,'b::sup) square \<Rightarrow> ('a,'b) square \<Rightarrow> ('a,'b) square"                                 (infixl "\<oplus>" 65)  where "f \<oplus> g = (\<lambda>e . f e \<squnion> g e)"
 definition inf_matrix     :: "('a,'b::inf) square \<Rightarrow> ('a,'b) square \<Rightarrow> ('a,'b) square"                                 (infixl "\<otimes>" 67)  where "f \<otimes> g = (\<lambda>e . f e \<sqinter> g e)"
 definition minus_matrix   :: "('a,'b::{uminus,inf}) square \<Rightarrow> ('a,'b) square \<Rightarrow> ('a,'b) square"                        (infixl "\<ominus>" 65)  where "f \<ominus> g = (\<lambda>e . f e \<sqinter> -g e)"
 definition implies_matrix :: "('a,'b::implies) square \<Rightarrow> ('a,'b) square \<Rightarrow> ('a,'b) square"                             (infixl "\<oslash>" 65)  where "f \<oslash> g = (\<lambda>e . f e \<leadsto> g e)"
 definition times_matrix   :: "('a,'b::{times,bounded_semilattice_sup_bot}) square \<Rightarrow> ('a,'b) square \<Rightarrow> ('a,'b) square" (infixl "\<odot>" 70)  where "f \<odot> g = (\<lambda>(i,j) . \<Squnion>\<^sub>k f (i,k) * g (k,j))"
 definition uminus_matrix  :: "('a,'b::uminus) square \<Rightarrow> ('a,'b) square"                                                ("\<ominus> _" [80] 80)  where "\<ominus>f    = (\<lambda>e . -f e)"
 definition conv_matrix    :: "('a,'b::conv) square \<Rightarrow> ('a,'b) square"                                                  ("_\<^sup>t" [100] 100) where "f\<^sup>t      = (\<lambda>(i,j) . (f (j,i))\<^sup>T)"
 definition bot_matrix     :: "('a,'b::bot) square"                                                                     ("mbot")         where "mbot   = (\<lambda>e . bot)"
 definition top_matrix     :: "('a,'b::top) square"                                                                     ("mtop")         where "mtop   = (\<lambda>e . top)"
 definition one_matrix     :: "('a,'b::{one,bot}) square"                                                               ("mone")         where "mone   = (\<lambda>(i,j) . if i = j then 1 else bot)"
 
 subsection \<open>Stone Algebras\<close>
 
 text \<open>
 We first lift the Stone algebra structure.
 Because all operations are componentwise, this also works for infinite matrices.
 \<close>
 
 interpretation matrix_order: order where less_eq = less_eq_matrix and less = "less_matrix :: ('a,'b::order) square \<Rightarrow> ('a,'b) square \<Rightarrow> bool"
   apply unfold_locales
   apply (simp add: less_matrix_def)
   apply (simp add: less_eq_matrix_def)
   apply (meson less_eq_matrix_def order_trans)
   by (meson less_eq_matrix_def antisym ext)
 
 interpretation matrix_semilattice_sup: semilattice_sup where sup = sup_matrix and less_eq = less_eq_matrix and less = "less_matrix :: ('a,'b::semilattice_sup) square \<Rightarrow> ('a,'b) square \<Rightarrow> bool"
   apply unfold_locales
   apply (simp add: sup_matrix_def less_eq_matrix_def)
   apply (simp add: sup_matrix_def less_eq_matrix_def)
   by (simp add: sup_matrix_def less_eq_matrix_def)
 
 interpretation matrix_semilattice_inf: semilattice_inf where inf = inf_matrix and less_eq = less_eq_matrix and less = "less_matrix :: ('a,'b::semilattice_inf) square \<Rightarrow> ('a,'b) square \<Rightarrow> bool"
   apply unfold_locales
   apply (simp add: inf_matrix_def less_eq_matrix_def)
   apply (simp add: inf_matrix_def less_eq_matrix_def)
   by (simp add: inf_matrix_def less_eq_matrix_def)
 
 interpretation matrix_bounded_semilattice_sup_bot: bounded_semilattice_sup_bot where sup = sup_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a,'b::bounded_semilattice_sup_bot) square"
   apply unfold_locales
   by (simp add: bot_matrix_def less_eq_matrix_def)
 
 interpretation matrix_bounded_semilattice_inf_top: bounded_semilattice_inf_top where inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and top = "top_matrix :: ('a,'b::bounded_semilattice_inf_top) square"
   apply unfold_locales
   by (simp add: less_eq_matrix_def top_matrix_def)
 
 interpretation matrix_lattice: lattice where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = "less_matrix :: ('a,'b::lattice) square \<Rightarrow> ('a,'b) square \<Rightarrow> bool" ..
 
 interpretation matrix_distrib_lattice: distrib_lattice where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = "less_matrix :: ('a,'b::distrib_lattice) square \<Rightarrow> ('a,'b) square \<Rightarrow> bool"
   apply unfold_locales
   by (simp add: sup_inf_distrib1 sup_matrix_def inf_matrix_def)
 
 interpretation matrix_bounded_lattice: bounded_lattice where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a,'b::bounded_lattice) square" and top = top_matrix ..
 
 interpretation matrix_bounded_distrib_lattice: bounded_distrib_lattice where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a,'b::bounded_distrib_lattice) square" and top = top_matrix ..
 
 interpretation matrix_p_algebra: p_algebra where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a,'b::p_algebra) square" and top = top_matrix and uminus = uminus_matrix
   apply unfold_locales
   apply (unfold inf_matrix_def bot_matrix_def less_eq_matrix_def uminus_matrix_def)
   by (meson pseudo_complement)
 
 interpretation matrix_pd_algebra: pd_algebra where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a,'b::pd_algebra) square" and top = top_matrix and uminus = uminus_matrix ..
 
 text \<open>
 In particular, matrices over Stone algebras form a Stone algebra.
 \<close>
 
 interpretation matrix_stone_algebra: stone_algebra where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a,'b::stone_algebra) square" and top = top_matrix and uminus = uminus_matrix
   by unfold_locales (simp add: sup_matrix_def uminus_matrix_def top_matrix_def)
 
 interpretation matrix_heyting_stone_algebra: heyting_stone_algebra where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a,'b::heyting_stone_algebra) square" and top = top_matrix and uminus = uminus_matrix and implies = implies_matrix
   apply unfold_locales
   apply (unfold inf_matrix_def sup_matrix_def bot_matrix_def top_matrix_def less_eq_matrix_def uminus_matrix_def implies_matrix_def)
   apply (simp add: implies_galois)
   apply (simp add: uminus_eq)
   by simp
 
-interpretation matrix_boolean_algebra: Lattices.boolean_algebra where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a,'b::boolean_algebra) square" and top = top_matrix and uminus = uminus_matrix and minus = minus_matrix
+interpretation matrix_boolean_algebra: boolean_algebra where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a,'b::boolean_algebra) square" and top = top_matrix and uminus = uminus_matrix and minus = minus_matrix
   apply unfold_locales
   apply simp
   apply (simp add: sup_matrix_def uminus_matrix_def top_matrix_def)
   by (simp add: inf_matrix_def uminus_matrix_def minus_matrix_def)
 
 subsection \<open>Semirings\<close>
 
 text \<open>
 Next, we lift the semiring structure.
 Because of composition, this requires a restriction to finite matrices.
 \<close>
 
 interpretation matrix_monoid: monoid_mult where times = times_matrix and one = "one_matrix :: ('a::finite,'b::idempotent_semiring) square"
 proof
   fix f g h :: "('a,'b) square"
   show "(f \<odot> g) \<odot> h = f \<odot> (g \<odot> h)"
   proof (rule ext, rule prod_cases)
     fix i j
     have "((f \<odot> g) \<odot> h) (i,j) = (\<Squnion>\<^sub>l (f \<odot> g) (i,l) * h (l,j))"
       by (simp add: times_matrix_def)
     also have "... = (\<Squnion>\<^sub>l (\<Squnion>\<^sub>k f (i,k) * g (k,l)) * h (l,j))"
       by (simp add: times_matrix_def)
     also have "... = (\<Squnion>\<^sub>l \<Squnion>\<^sub>k (f (i,k) * g (k,l)) * h (l,j))"
       by (metis (no_types) comp_right_dist_sum)
     also have "... = (\<Squnion>\<^sub>l \<Squnion>\<^sub>k f (i,k) * (g (k,l) * h (l,j)))"
       by (simp add: mult.assoc)
     also have "... = (\<Squnion>\<^sub>k \<Squnion>\<^sub>l f (i,k) * (g (k,l) * h (l,j)))"
       using sup_monoid.sum.swap by auto
     also have "... = (\<Squnion>\<^sub>k f (i,k) * (\<Squnion>\<^sub>l g (k,l) * h (l,j)))"
       by (metis (no_types) comp_left_dist_sum)
     also have "... = (\<Squnion>\<^sub>k f (i,k) * (g \<odot> h) (k,j))"
       by (simp add: times_matrix_def)
     also have "... = (f \<odot> (g \<odot> h)) (i,j)"
       by (simp add: times_matrix_def)
     finally show "((f \<odot> g) \<odot> h) (i,j) = (f \<odot> (g \<odot> h)) (i,j)"
       .
   qed
 next
   fix f :: "('a,'b) square"
   show "mone \<odot> f = f"
   proof (rule ext, rule prod_cases)
     fix i j
     have "(mone \<odot> f) (i,j) = (\<Squnion>\<^sub>k mone (i,k) * f (k,j))"
       by (simp add: times_matrix_def)
     also have "... = (\<Squnion>\<^sub>k (if i = k then 1 else bot) * f (k,j))"
       by (simp add: one_matrix_def)
     also have "... = (\<Squnion>\<^sub>k if i = k then 1 * f (k,j) else bot * f (k,j))"
       by (metis (full_types, opaque_lifting))
     also have "... = (\<Squnion>\<^sub>k if i = k then f (k,j) else bot)"
       by (meson mult_left_one mult_left_zero)
     also have "... = f (i,j)"
       by simp
     finally show "(mone \<odot> f) (i,j) = f (i,j)"
       .
   qed
 next
   fix f :: "('a,'b) square"
   show "f \<odot> mone = f"
   proof (rule ext, rule prod_cases)
     fix i j
     have "(f \<odot> mone) (i,j) = (\<Squnion>\<^sub>k f (i,k) * mone (k,j))"
       by (simp add: times_matrix_def)
     also have "... = (\<Squnion>\<^sub>k f (i,k) * (if k = j then 1 else bot))"
       by (simp add: one_matrix_def)
     also have "... = (\<Squnion>\<^sub>k if k = j then f (i,k) * 1 else f (i,k) * bot)"
       by (metis (full_types, opaque_lifting))
     also have "... = (\<Squnion>\<^sub>k if k = j then f (i,k) else bot)"
       by (meson mult.right_neutral semiring.mult_zero_right)
     also have "... = f (i,j)"
       by simp
     finally show "(f \<odot> mone) (i,j) = f (i,j)"
       .
   qed
 qed
 
 interpretation matrix_idempotent_semiring: idempotent_semiring where sup = sup_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a::finite,'b::idempotent_semiring) square" and one = one_matrix and times = times_matrix
 proof
   fix f g h :: "('a,'b) square"
   show "f \<odot> g \<oplus> f \<odot> h \<preceq> f \<odot> (g \<oplus> h)"
   proof (unfold less_eq_matrix_def, rule allI, rule prod_cases)
     fix i j
     have "(f \<odot> g \<oplus> f \<odot> h) (i,j) = (f \<odot> g) (i,j) \<squnion> (f \<odot> h) (i,j)"
       by (simp add: sup_matrix_def)
     also have "... = (\<Squnion>\<^sub>k f (i,k) * g (k,j)) \<squnion> (\<Squnion>\<^sub>k f (i,k) * h (k,j))"
       by (simp add: times_matrix_def)
     also have "... = (\<Squnion>\<^sub>k f (i,k) * g (k,j) \<squnion> f (i,k) * h (k,j))"
       by (simp add: sup_monoid.sum.distrib)
     also have "... = (\<Squnion>\<^sub>k f (i,k) * (g (k,j) \<squnion> h (k,j)))"
       by (simp add: mult_left_dist_sup)
     also have "... = (\<Squnion>\<^sub>k f (i,k) * (g \<oplus> h) (k,j))"
       by (simp add: sup_matrix_def)
     also have "... = (f \<odot> (g \<oplus> h)) (i,j)"
       by (simp add: times_matrix_def)
     finally show "(f \<odot> g \<oplus> f \<odot> h) (i,j) \<le> (f \<odot> (g \<oplus> h)) (i,j)"
       by simp
   qed
 next
   fix f g h :: "('a,'b) square"
   show "(f \<oplus> g) \<odot> h = f \<odot> h \<oplus> g \<odot> h"
   proof (rule ext, rule prod_cases)
     fix i j
     have "((f \<oplus> g) \<odot> h) (i,j) = (\<Squnion>\<^sub>k (f \<oplus> g) (i,k) * h (k,j))"
       by (simp add: times_matrix_def)
     also have "... = (\<Squnion>\<^sub>k (f (i,k) \<squnion> g (i,k)) * h (k,j))"
       by (simp add: sup_matrix_def)
     also have "... = (\<Squnion>\<^sub>k f (i,k) * h (k,j) \<squnion> g (i,k) * h (k,j))"
       by (meson mult_right_dist_sup)
     also have "... = (\<Squnion>\<^sub>k f (i,k) * h (k,j)) \<squnion> (\<Squnion>\<^sub>k g (i,k) * h (k,j))"
       by (simp add: sup_monoid.sum.distrib)
     also have "... = (f \<odot> h) (i,j) \<squnion> (g \<odot> h) (i,j)"
       by (simp add: times_matrix_def)
     also have "... = (f \<odot> h \<oplus> g \<odot> h) (i,j)"
       by (simp add: sup_matrix_def)
     finally show "((f \<oplus> g) \<odot> h) (i,j) = (f \<odot> h \<oplus> g \<odot> h) (i,j)"
       .
   qed
 next
   fix f :: "('a,'b) square"
   show "mbot \<odot> f = mbot"
   proof (rule ext, rule prod_cases)
     fix i j
     have "(mbot \<odot> f) (i,j) = (\<Squnion>\<^sub>k mbot (i,k) * f (k,j))"
       by (simp add: times_matrix_def)
     also have "... = (\<Squnion>\<^sub>k bot * f (k,j))"
       by (simp add: bot_matrix_def)
     also have "... = bot"
       by simp
     also have "... = mbot (i,j)"
       by (simp add: bot_matrix_def)
     finally show "(mbot \<odot> f) (i,j) = mbot (i,j)"
       .
   qed
 next
   fix f :: "('a,'b) square"
   show "mone \<odot> f = f"
     by simp
 next
   fix f :: "('a,'b) square"
   show "f \<preceq> f \<odot> mone"
     by simp
 next
   fix f g h :: "('a,'b) square"
   show "f \<odot> (g \<oplus> h) = f \<odot> g \<oplus> f \<odot> h"
   proof (rule ext, rule prod_cases)
     fix i j
     have "(f \<odot> (g \<oplus> h)) (i,j) = (\<Squnion>\<^sub>k f (i,k) * (g \<oplus> h) (k,j))"
       by (simp add: times_matrix_def)
     also have "... = (\<Squnion>\<^sub>k f (i,k) * (g (k,j) \<squnion> h (k,j)))"
       by (simp add: sup_matrix_def)
     also have "... = (\<Squnion>\<^sub>k f (i,k) * g (k,j) \<squnion> f (i,k) * h (k,j))"
       by (meson mult_left_dist_sup)
     also have "... = (\<Squnion>\<^sub>k f (i,k) * g (k,j)) \<squnion> (\<Squnion>\<^sub>k f (i,k) * h (k,j))"
       by (simp add: sup_monoid.sum.distrib)
     also have "... = (f \<odot> g) (i,j) \<squnion> (f \<odot> h) (i,j)"
       by (simp add: times_matrix_def)
     also have "... = (f \<odot> g \<oplus> f \<odot> h) (i,j)"
       by (simp add: sup_matrix_def)
     finally show "(f \<odot> (g \<oplus> h)) (i,j) = (f \<odot> g \<oplus> f \<odot> h) (i,j)"
       .
   qed
 next
   fix f :: "('a,'b) square"
   show "f \<odot> mbot = mbot"
   proof (rule ext, rule prod_cases)
     fix i j
     have "(f \<odot> mbot) (i,j) = (\<Squnion>\<^sub>k f (i,k) * mbot (k,j))"
       by (simp add: times_matrix_def)
     also have "... = (\<Squnion>\<^sub>k f (i,k) * bot)"
       by (simp add: bot_matrix_def)
     also have "... = bot"
       by simp
     also have "... = mbot (i,j)"
       by (simp add: bot_matrix_def)
     finally show "(f \<odot> mbot) (i,j) = mbot (i,j)"
       .
   qed
 qed
 
 interpretation matrix_bounded_idempotent_semiring: bounded_idempotent_semiring where sup = sup_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a::finite,'b::bounded_idempotent_semiring) square" and top = top_matrix and one = one_matrix and times = times_matrix
 proof
   fix f :: "('a,'b) square"
   show "f \<oplus> mtop = mtop"
   proof
     fix e
     have "(f \<oplus> mtop) e = f e \<squnion> mtop e"
       by (simp add: sup_matrix_def)
     also have "... = f e \<squnion> top"
       by (simp add: top_matrix_def)
     also have "... = top"
       by simp
     also have "... = mtop e"
       by (simp add: top_matrix_def)
     finally show "(f \<oplus> mtop) e = mtop e"
       .
   qed
 qed
 
 subsection \<open>Stone Relation Algebras\<close>
 
 text \<open>
 Finally, we show that matrices over Stone relation algebras form a Stone relation algebra.
 \<close>
 
 interpretation matrix_stone_relation_algebra: stone_relation_algebra where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a::finite,'b::stone_relation_algebra) square" and top = top_matrix and uminus = uminus_matrix and one = one_matrix and times = times_matrix and conv = conv_matrix
 proof
   fix f g h :: "('a,'b) square"
   show "(f \<odot> g) \<odot> h = f \<odot> (g \<odot> h)"
     by (simp add: matrix_monoid.mult_assoc)
 next
   fix f g h :: "('a,'b) square"
   show "(f \<oplus> g) \<odot> h = f \<odot> h \<oplus> g \<odot> h"
     by (simp add: matrix_idempotent_semiring.mult_right_dist_sup)
 next
   fix f :: "('a,'b) square"
   show "mbot \<odot> f = mbot"
     by simp
 next
   fix f :: "('a,'b) square"
   show "mone \<odot> f = f"
     by simp
 next
   fix f :: "('a,'b) square"
   show "f\<^sup>t\<^sup>t = f"
   proof (rule ext, rule prod_cases)
     fix i j
     have "(f\<^sup>t\<^sup>t) (i,j) = ((f\<^sup>t) (j,i))\<^sup>T"
       by (simp add: conv_matrix_def)
     also have "... = f (i,j)"
       by (simp add: conv_matrix_def)
     finally show "(f\<^sup>t\<^sup>t) (i,j) = f (i,j)"
       .
   qed
 next
   fix f g :: "('a,'b) square"
   show "(f \<oplus> g)\<^sup>t = f\<^sup>t \<oplus> g\<^sup>t"
   proof (rule ext, rule prod_cases)
     fix i j
     have "((f \<oplus> g)\<^sup>t) (i,j) = ((f \<oplus> g) (j,i))\<^sup>T"
       by (simp add: conv_matrix_def)
     also have "... = (f (j,i) \<squnion> g (j,i))\<^sup>T"
       by (simp add: sup_matrix_def)
     also have "... = (f\<^sup>t) (i,j) \<squnion> (g\<^sup>t) (i,j)"
       by (simp add: conv_matrix_def conv_dist_sup)
     also have "... = (f\<^sup>t \<oplus> g\<^sup>t) (i,j)"
       by (simp add: sup_matrix_def)
     finally show "((f \<oplus> g)\<^sup>t) (i,j) = (f\<^sup>t \<oplus> g\<^sup>t) (i,j)"
       .
   qed
 next
   fix f g :: "('a,'b) square"
   show "(f \<odot> g)\<^sup>t = g\<^sup>t \<odot> f\<^sup>t"
   proof (rule ext, rule prod_cases)
     fix i j
     have "((f \<odot> g)\<^sup>t) (i,j) = ((f \<odot> g) (j,i))\<^sup>T"
       by (simp add: conv_matrix_def)
     also have "... = (\<Squnion>\<^sub>k f (j,k) * g (k,i))\<^sup>T"
       by (simp add: times_matrix_def)
     also have "... = (\<Squnion>\<^sub>k (f (j,k) * g (k,i))\<^sup>T)"
       by (metis (no_types) conv_dist_sum)
     also have "... = (\<Squnion>\<^sub>k (g (k,i))\<^sup>T * (f (j,k))\<^sup>T)"
       by (simp add: conv_dist_comp)
     also have "... = (\<Squnion>\<^sub>k (g\<^sup>t) (i,k) * (f\<^sup>t) (k,j))"
       by (simp add: conv_matrix_def)
     also have "... = (g\<^sup>t \<odot> f\<^sup>t) (i,j)"
       by (simp add: times_matrix_def)
     finally show "((f \<odot> g)\<^sup>t) (i,j) = (g\<^sup>t \<odot> f\<^sup>t) (i,j)"
       .
   qed
 next
   fix f g h :: "('a,'b) square"
   show "(f \<odot> g) \<otimes> h \<preceq> f \<odot> (g \<otimes> (f\<^sup>t \<odot> h))"
   proof (unfold less_eq_matrix_def, rule allI, rule prod_cases)
     fix i j
     have "((f \<odot> g) \<otimes> h) (i,j) = (f \<odot> g) (i,j) \<sqinter> h (i,j)"
       by (simp add: inf_matrix_def)
     also have "... = (\<Squnion>\<^sub>k f (i,k) * g (k,j)) \<sqinter> h (i,j)"
       by (simp add: times_matrix_def)
     also have "... = (\<Squnion>\<^sub>k f (i,k) * g (k,j) \<sqinter> h (i,j))"
       by (metis (no_types) inf_right_dist_sum)
     also have "... \<le> (\<Squnion>\<^sub>k f (i,k) * (g (k,j) \<sqinter> (f (i,k))\<^sup>T * h (i,j)))"
       by (rule leq_sum, meson dedekind_1)
     also have "... = (\<Squnion>\<^sub>k f (i,k) * (g (k,j) \<sqinter> (f\<^sup>t) (k,i) * h (i,j)))"
       by (simp add: conv_matrix_def)
     also have "... \<le> (\<Squnion>\<^sub>k f (i,k) * (g (k,j) \<sqinter> (\<Squnion>\<^sub>l (f\<^sup>t) (k,l) * h (l,j))))"
       by (rule leq_sum, rule allI, rule comp_right_isotone, rule inf.sup_right_isotone, rule ub_sum)
     also have "... = (\<Squnion>\<^sub>k f (i,k) * (g (k,j) \<sqinter> (f\<^sup>t \<odot> h) (k,j)))"
       by (simp add: times_matrix_def)
     also have "... = (\<Squnion>\<^sub>k f (i,k) * (g \<otimes> (f\<^sup>t \<odot> h)) (k,j))"
       by (simp add: inf_matrix_def)
     also have "... = (f \<odot> (g \<otimes> (f\<^sup>t \<odot> h))) (i,j)"
       by (simp add: times_matrix_def)
     finally show "((f \<odot> g) \<otimes> h) (i,j) \<le> (f \<odot> (g \<otimes> (f\<^sup>t \<odot> h))) (i,j)"
       .
   qed
 next
   fix f g :: "('a,'b) square"
   show "\<ominus>\<ominus>(f \<odot> g) = \<ominus>\<ominus>f \<odot> \<ominus>\<ominus>g"
   proof (rule ext, rule prod_cases)
     fix i j
     have "(\<ominus>\<ominus>(f \<odot> g)) (i,j) = --((f \<odot> g) (i,j))"
       by (simp add: uminus_matrix_def)
     also have "... = --(\<Squnion>\<^sub>k f (i,k) * g (k,j))"
       by (simp add: times_matrix_def)
     also have "... = (\<Squnion>\<^sub>k --(f (i,k) * g (k,j)))"
       by (metis (no_types) pp_dist_sum)
     also have "... = (\<Squnion>\<^sub>k --(f (i,k)) * --(g (k,j)))"
       by (meson pp_dist_comp)
     also have "... = (\<Squnion>\<^sub>k (\<ominus>\<ominus>f) (i,k) * (\<ominus>\<ominus>g) (k,j))"
       by (simp add: uminus_matrix_def)
     also have "... = (\<ominus>\<ominus>f \<odot> \<ominus>\<ominus>g) (i,j)"
       by (simp add: times_matrix_def)
     finally show "(\<ominus>\<ominus>(f \<odot> g)) (i,j) = (\<ominus>\<ominus>f \<odot> \<ominus>\<ominus>g) (i,j)"
       .
   qed
 next
   let ?o = "mone :: ('a,'b) square"
   show "\<ominus>\<ominus>?o = ?o"
   proof (rule ext, rule prod_cases)
     fix i j
     have "(\<ominus>\<ominus>?o) (i,j) = --(?o (i,j))"
       by (simp add: uminus_matrix_def)
     also have "... = --(if i = j then 1 else bot)"
       by (simp add: one_matrix_def)
     also have "... = (if i = j then --1 else --bot)"
       by simp
     also have "... = (if i = j then 1 else bot)"
       by auto
     also have "... = ?o (i,j)"
       by (simp add: one_matrix_def)
     finally show "(\<ominus>\<ominus>?o) (i,j) = ?o (i,j)"
       .
   qed
 qed
 
 end
 
diff --git a/thys/Subset_Boolean_Algebras/Subset_Boolean_Algebras.thy b/thys/Subset_Boolean_Algebras/Subset_Boolean_Algebras.thy
--- a/thys/Subset_Boolean_Algebras/Subset_Boolean_Algebras.thy
+++ b/thys/Subset_Boolean_Algebras/Subset_Boolean_Algebras.thy
@@ -1,3608 +1,3608 @@
 (* Title:      Subset Boolean Algebras
    Authors:    Walter Guttmann, Bernhard Möller
    Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
 *)
 
 theory Subset_Boolean_Algebras
 
 imports Stone_Algebras.P_Algebras
 
 begin
 
 section \<open>Boolean Algebras\<close>
 
 text \<open>
 We show that Isabelle/HOL's \<open>boolean_algebra\<close> class is equivalent to Huntington's axioms \cite{Huntington1933}.
 See \cite{WamplerDoty2016} for related results.
 \<close>
 
 subsection \<open>Huntington's Axioms\<close>
 
 text \<open>Definition 1\<close>
 
 class huntington = sup + uminus +
   assumes associative: "x \<squnion> (y \<squnion> z) = (x \<squnion> y) \<squnion> z"
   assumes commutative: "x \<squnion> y = y \<squnion> x"
   assumes huntington: "x = -(-x \<squnion> y) \<squnion> -(-x \<squnion> -y)"
 begin
 
 lemma top_unique:
   "x \<squnion> -x = y \<squnion> -y"
 proof -
   have "x \<squnion> -x = y \<squnion> -(--y \<squnion> -x) \<squnion> -(--y \<squnion> --x)"
     by (smt associative commutative huntington)
   thus ?thesis
     by (metis associative huntington)
 qed
 
 end
 
 subsection \<open>Equivalence to \<open>boolean_algebra\<close> Class\<close>
 
 text \<open>Definition 2\<close>
 
 class extended = sup + inf + minus + uminus + bot + top + ord +
   assumes top_def: "top = (THE x . \<forall>y . x = y \<squnion> -y)" (* define without imposing uniqueness *)
   assumes bot_def: "bot = -(THE x . \<forall>y . x = y \<squnion> -y)"
   assumes inf_def: "x \<sqinter> y = -(-x \<squnion> -y)"
   assumes minus_def: "x - y = -(-x \<squnion> y)"
   assumes less_eq_def: "x \<le> y \<longleftrightarrow> x \<squnion> y = y"
   assumes less_def: "x < y \<longleftrightarrow> x \<squnion> y = y \<and> \<not> (y \<squnion> x = x)"
 
 class huntington_extended = huntington + extended
 begin
 
 lemma top_char:
   "top = x \<squnion> -x"
   using top_def top_unique by auto
 
 lemma bot_char:
   "bot = -top"
   by (simp add: bot_def top_def)
 
 subclass boolean_algebra
 proof
   show 1: "\<And>x y. (x < y) = (x \<le> y \<and> \<not> y \<le> x)"
     by (simp add: less_def less_eq_def)
   show 2: "\<And>x. x \<le> x"
   proof -
     fix x
     have "x \<squnion> top = top \<squnion> --x"
       by (metis (full_types) associative top_char)
     thus "x \<le> x"
       by (metis (no_types) associative huntington less_eq_def top_char)
   qed
   show 3: "\<And>x y z. x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
     by (metis associative less_eq_def)
   show 4: "\<And>x y. x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
     by (simp add: commutative less_eq_def)
   show 5: "\<And>x y. x \<sqinter> y \<le> x"
     using 2 by (metis associative huntington inf_def less_eq_def)
   show 6: "\<And>x y. x \<sqinter> y \<le> y"
     using 5 commutative inf_def by fastforce
   show 8: "\<And>x y. x \<le> x \<squnion> y"
     using 2 associative less_eq_def by auto
   show 9: "\<And>y x. y \<le> x \<squnion> y"
     using 8 commutative by fastforce
   show 10: "\<And>y x z. y \<le> x \<Longrightarrow> z \<le> x \<Longrightarrow> y \<squnion> z \<le> x"
     by (metis associative less_eq_def)
   show 11: "\<And>x. bot \<le> x"
     using 8 by (metis bot_char huntington top_char)
   show 12: "\<And>x. x \<le> top"
     using 6 11 by (metis huntington bot_def inf_def less_eq_def top_def)
   show 13: "\<And>x y z. x \<squnion> y \<sqinter> z = (x \<squnion> y) \<sqinter> (x \<squnion> z)"
   proof -
     have 2: "\<And>x y z . x \<squnion> (y \<squnion> z) = (x \<squnion> y) \<squnion> z"
       by (simp add: associative)
     have 3: "\<And>x y z . (x \<squnion> y) \<squnion> z = x \<squnion> (y \<squnion> z)"
       using 2 by metis
     have 4: "\<And>x y . x \<squnion> y = y \<squnion> x"
       by (simp add: commutative)
     have 5: "\<And>x y . x = - (- x \<squnion> y) \<squnion> - (- x \<squnion> - y)"
       by (simp add: huntington)
     have 6: "\<And>x y . - (- x \<squnion> y) \<squnion> - (- x \<squnion> - y) = x"
       using 5 by metis
     have 7: "\<And>x y . x \<sqinter> y = - (- x \<squnion> - y)"
       by (simp add: inf_def)
     have 10: "\<And>x y z . x \<squnion> (y \<squnion> z) = y \<squnion> (x \<squnion> z)"
       using 3 4 by metis
     have 11: "\<And>x y z . - (- x \<squnion> y) \<squnion> (- (- x \<squnion> - y) \<squnion> z) = x \<squnion> z"
       using 3 6 by metis
     have 12: "\<And>x y . - (x \<squnion> - y) \<squnion> - (- y \<squnion> - x) = y"
       using 4 6 by metis
     have 13: "\<And>x y . - (- x \<squnion> y) \<squnion> - (- y \<squnion> - x) = x"
       using 4 6 by metis
     have 14: "\<And>x y . - x \<squnion> - (- (- x \<squnion> y) \<squnion> - - (- x \<squnion> - y)) = - x \<squnion> y"
       using 6 by metis
     have 18: "\<And>x y z . - (x \<squnion> - y) \<squnion> (- (- y \<squnion> - x) \<squnion> z) = y \<squnion> z"
       using 3 12 by metis
     have 20: "\<And>x y . - (- x \<squnion> - y) \<squnion> - (y \<squnion> - x) = x"
       using 4 12 by metis
     have 21: "\<And>x y . - (x \<squnion> - y) \<squnion> - (- x \<squnion> - y) = y"
       using 4 12 by metis
     have 22: "\<And>x y . - x \<squnion> - (- (y \<squnion> - x) \<squnion> - - (- x \<squnion> - y)) = y \<squnion> - x"
       using 6 12 by metis
     have 23: "\<And>x y . - x \<squnion> - (- x \<squnion> (- y \<squnion> - (y \<squnion> - x))) = y \<squnion> - x"
       using 3 4 6 12 by metis
     have 24: "\<And>x y . - x \<squnion> - (- (- x \<squnion> - y) \<squnion> - - (- x \<squnion> y)) = - x \<squnion> - y"
       using 6 12 by metis
     have 28: "\<And>x y . - (- x \<squnion> - y) \<squnion> - (- y \<squnion> x) = y"
       using 4 13 by metis
     have 30: "\<And>x y . - x \<squnion> - (- y \<squnion> (- x \<squnion> - (- x \<squnion> y))) = - x \<squnion> y"
       using 3 4 6 13 by metis
     have 32: "\<And>x y z . - (- x \<squnion> y) \<squnion> (z \<squnion> - (- y \<squnion> - x)) = z \<squnion> x"
       using 10 13 by metis
     have 37: "\<And>x y z . - (- x \<squnion> - y) \<squnion> (- (y \<squnion> - x) \<squnion> z) = x \<squnion> z"
       using 3 20 by metis
     have 39: "\<And>x y z . - (- x \<squnion> - y) \<squnion> (z \<squnion> - (y \<squnion> - x)) = z \<squnion> x"
       using 10 20 by metis
     have 40: "\<And>x y z . - (x \<squnion> - y) \<squnion> (- (- x \<squnion> - y) \<squnion> z) = y \<squnion> z"
       using 3 21 by metis
     have 43: "\<And>x y . - x \<squnion> - (- y \<squnion> (- x \<squnion> - (y \<squnion> - x))) = y \<squnion> - x"
       using 3 4 6 21 by metis
     have 47: "\<And>x y z . - (x \<squnion> y) \<squnion> - (- (- x \<squnion> z) \<squnion> - (- (- x \<squnion> - z) \<squnion> y)) = - x \<squnion> z"
       using 6 11 by metis
     have 55: "\<And>x y . x \<squnion> - (- y \<squnion> - - x) = y \<squnion> - (- x \<squnion> y)"
       using 4 11 12 by metis
     have 58: "\<And>x y . x \<squnion> - (- - y \<squnion> - x) = x \<squnion> - (- x \<squnion> y)"
       using 4 11 13 by metis
     have 63: "\<And>x y . x \<squnion> - (- - x \<squnion> - y) = y \<squnion> - (- x \<squnion> y)"
       using 4 11 21 by metis
     have 71: "\<And>x y . x \<squnion> - (- y \<squnion> x) = y \<squnion> - (- x \<squnion> y)"
       using 4 11 28 by metis
     have 75: "\<And>x y . x \<squnion> - (- y \<squnion> x) = y \<squnion> - (y \<squnion> - x)"
       using 4 71 by metis
     have 78: "\<And>x y . - x \<squnion> (y \<squnion> - (- x \<squnion> (y \<squnion> - - (- x \<squnion> - y)))) = - x \<squnion> - (- x \<squnion> - y)"
       using 3 4 6 71 by metis
     have 86: "\<And>x y . - (- x \<squnion> - (- y \<squnion> x)) \<squnion> - (y \<squnion> - (- x \<squnion> y)) = - y \<squnion> x"
       using 4 20 71 by metis
     have 172: "\<And>x y . - x \<squnion> - (- x \<squnion> - y) = y \<squnion> - (- - x \<squnion> y)"
       using 14 75 by metis
     have 201: "\<And>x y . x \<squnion> - (- y \<squnion> - - x) = y \<squnion> - (y \<squnion> - x)"
       using 4 55 by metis
     have 236: "\<And>x y . x \<squnion> - (- - y \<squnion> - x) = x \<squnion> - (y \<squnion> - x)"
       using 4 58 by metis
     have 266: "\<And>x y . - x \<squnion> - (- (- x \<squnion> - (y \<squnion> - - x)) \<squnion> - - (- x \<squnion> - - (- - x \<squnion> y))) = - x \<squnion> - (- - x \<squnion> y)"
       using 14 58 236 by metis
     have 678: "\<And>x y z . - (- x \<squnion> - (- y \<squnion> x)) \<squnion> (- (y \<squnion> - (- x \<squnion> y)) \<squnion> z) = - y \<squnion> (x \<squnion> z)"
       using 3 4 37 71 by smt
     have 745: "\<And>x y z . - (- x \<squnion> - (- y \<squnion> x)) \<squnion> (z \<squnion> - (y \<squnion> - (- x \<squnion> y))) = z \<squnion> (- y \<squnion> x)"
       using 4 39 71 by metis
     have 800: "\<And>x y . - - x \<squnion> (- y \<squnion> (- (y \<squnion> - - x) \<squnion> - (- x \<squnion> (- - x \<squnion> (- y \<squnion> - (y \<squnion> - - x)))))) = x \<squnion> - (y \<squnion> - - x)"
       using 3 23 63 by metis
     have 944: "\<And>x y . x \<squnion> - (x \<squnion> - - (- (- x \<squnion> - y) \<squnion> - - (- x \<squnion> y))) = - (- x \<squnion> - y) \<squnion> - (- (- x \<squnion> - y) \<squnion> - - (- x \<squnion> y))"
       using 4 24 71 by metis
     have 948: "\<And>x y . - x \<squnion> - (- (y \<squnion> - (y \<squnion> - - x)) \<squnion> - - (- x \<squnion> (- y \<squnion> - x))) = - x \<squnion> - (- y \<squnion> - x)"
       using 24 75 by metis
     have 950: "\<And>x y . - x \<squnion> - (- (y \<squnion> - (- - x \<squnion> y)) \<squnion> - - (- x \<squnion> (- x \<squnion> - y))) = - x \<squnion> - (- x \<squnion> - y)"
       using 24 75 by metis
     have 961: "\<And>x y . - x \<squnion> - (- (y \<squnion> - (- - x \<squnion> y)) \<squnion> - - (- x \<squnion> (- - - x \<squnion> - y))) = y \<squnion> - (- - x \<squnion> y)"
       using 24 63 by metis
     have 966: "\<And>x y . - x \<squnion> - (- (y \<squnion> - (y \<squnion> - - x)) \<squnion> - - (- x \<squnion> (- y \<squnion> - - - x))) = y \<squnion> - (y \<squnion> - - x)"
       using 24 201 by metis
     have 969: "\<And>x y . - x \<squnion> - (- (- x \<squnion> - (y \<squnion> - - x)) \<squnion> - - (- x \<squnion> (- - y \<squnion> - - x))) = - x \<squnion> - (y \<squnion> - - x)"
       using 24 236 by metis
     have 1096: "\<And>x y z . - x \<squnion> (- (- x \<squnion> - y) \<squnion> z) = y \<squnion> (- (- - x \<squnion> y) \<squnion> z)"
       using 3 172 by metis
     have 1098: "\<And>x y z . - x \<squnion> (y \<squnion> - (- x \<squnion> - z)) = y \<squnion> (z \<squnion> - (- - x \<squnion> z))"
       using 10 172 by metis
     have 1105: "\<And>x y . x \<squnion> - x = y \<squnion> - y"
       using 4 10 12 32 172 by metis
     have 1109: "\<And>x y z . x \<squnion> (- x \<squnion> y) = z \<squnion> (- z \<squnion> y)"
       using 3 1105 by metis
     have 1110: "\<And>x y z . x \<squnion> - x = y \<squnion> (z \<squnion> - (y \<squnion> z))"
       using 3 1105 by metis
     have 1114: "\<And>x y . - (- x \<squnion> - - x) = - (y \<squnion> - y)"
       using 7 1105 by metis
     have 1115: "\<And>x y z . x \<squnion> (y \<squnion> - y) = z \<squnion> (x \<squnion> - z)"
       using 10 1105 by metis
     have 1117: "\<And>x y . - (x \<squnion> - - x) \<squnion> - (y \<squnion> - y) = - x"
       using 4 13 1105 by metis
     have 1121: "\<And>x y . - (x \<squnion> - x) \<squnion> - (y \<squnion> - - y) = - y"
       using 4 28 1105 by metis
     have 1122: "\<And>x . - - x = x"
       using 4 28 1105 1117 by metis
     have 1134: "\<And>x y z . - (x \<squnion> - y) \<squnion> (z \<squnion> - z) = y \<squnion> (- y \<squnion> - x)"
       using 18 1105 1122 by metis
     have 1140: "\<And>x . - x \<squnion> - (x \<squnion> (x \<squnion> - x)) = - x \<squnion> - x"
       using 4 22 1105 1122 1134 by metis
     have 1143: "\<And>x y . x \<squnion> (- x \<squnion> y) = y \<squnion> (x \<squnion> - y)"
       using 37 1105 1122 1134 by metis
     have 1155: "\<And>x y . - (x \<squnion> - x) \<squnion> - (y \<squnion> y) = - y"
       using 1121 1122 by metis
     have 1156: "\<And>x y . - (x \<squnion> x) \<squnion> - (y \<squnion> - y) = - x"
       using 1117 1122 by metis
     have 1157: "\<And>x y . - (x \<squnion> - x) = - (y \<squnion> - y)"
       using 4 1114 1122 by metis
     have 1167: "\<And>x y z . - x \<squnion> (y \<squnion> - (- x \<squnion> - z)) = y \<squnion> (z \<squnion> - (x \<squnion> z))"
       using 1098 1122 by metis
     have 1169: "\<And>x y z . - x \<squnion> (- (- x \<squnion> - y) \<squnion> z) = y \<squnion> (- (x \<squnion> y) \<squnion> z)"
       using 1096 1122 by metis
     have 1227: "\<And>x y . - x \<squnion> - (- x \<squnion> (y \<squnion> (x \<squnion> - (- x \<squnion> - (y \<squnion> x))))) = - x \<squnion> - (y \<squnion> x)"
       using 3 4 969 1122 by smt
     have 1230: "\<And>x y . - x \<squnion> - (- x \<squnion> (- y \<squnion> (- x \<squnion> - (y \<squnion> - (y \<squnion> x))))) = y \<squnion> - (y \<squnion> x)"
       using 3 4 966 1122 by smt
     have 1234: "\<And>x y . - x \<squnion> - (- x \<squnion> (- x \<squnion> (- y \<squnion> - (y \<squnion> - (x \<squnion> y))))) = y \<squnion> - (x \<squnion> y)"
       using 3 4 961 1122 by metis
     have 1239: "\<And>x y . - x \<squnion> - (- x \<squnion> - y) = y \<squnion> - (x \<squnion> y)"
       using 3 4 950 1122 1234 by metis
     have 1240: "\<And>x y . - x \<squnion> - (- y \<squnion> - x) = y \<squnion> - (y \<squnion> x)"
       using 3 4 948 1122 1230 by metis
     have 1244: "\<And>x y . x \<squnion> - (x \<squnion> (y \<squnion> (y \<squnion> - (x \<squnion> y)))) = - (- x \<squnion> - y) \<squnion> - (y \<squnion> (y \<squnion> - (x \<squnion> y)))"
       using 3 4 944 1122 1167 by metis
     have 1275: "\<And>x y . x \<squnion> (- y \<squnion> (- (y \<squnion> x) \<squnion> - (x \<squnion> (- x \<squnion> (- y \<squnion> - (y \<squnion> x)))))) = x \<squnion> - (y \<squnion> x)"
       using 10 800 1122 by metis
     have 1346: "\<And>x y . - x \<squnion> - (x \<squnion> (y \<squnion> (y \<squnion> (x \<squnion> - (x \<squnion> (y \<squnion> x)))))) = - x \<squnion> - (x \<squnion> y)"
       using 3 4 10 266 1122 1167 by smt
     have 1377: "\<And>x y . - x \<squnion> (y \<squnion> - (- x \<squnion> (y \<squnion> (- x \<squnion> - y)))) = y \<squnion> - (x \<squnion> y)"
       using 78 1122 1239 by metis
     have 1394: "\<And>x y . - (- x \<squnion> - y) \<squnion> - (y \<squnion> (y \<squnion> (- x \<squnion> - (x \<squnion> y)))) = x"
       using 3 4 10 20 30 1122 1239 by smt
     have 1427: "\<And>x y . - (- x \<squnion> - y) \<squnion> - (y \<squnion> - (x \<squnion> (x \<squnion> - (x \<squnion> y)))) = x \<squnion> (x \<squnion> - (x \<squnion> y))"
       using 3 4 30 40 1240 by smt
     have 1436: "\<And>x . - x \<squnion> - (x \<squnion> (x \<squnion> (- x \<squnion> - x))) = - x \<squnion> (- x \<squnion> - (x \<squnion> - x))"
       using 3 4 30 1140 1239 by smt
     have 1437: "\<And>x y . - (x \<squnion> y) \<squnion> - (x \<squnion> - y) = - x"
       using 6 1122 by metis
     have 1438: "\<And>x y . - (x \<squnion> y) \<squnion> - (y \<squnion> - x) = - y"
       using 12 1122 by metis
     have 1439: "\<And>x y . - (x \<squnion> y) \<squnion> - (- y \<squnion> x) = - x"
       using 13 1122 by metis
     have 1440: "\<And>x y . - (x \<squnion> - y) \<squnion> - (y \<squnion> x) = - x"
       using 20 1122 by metis
     have 1441: "\<And>x y . - (x \<squnion> y) \<squnion> - (- x \<squnion> y) = - y"
       using 21 1122 by metis
     have 1568: "\<And>x y . x \<squnion> (- y \<squnion> - x) = y \<squnion> (- y \<squnion> x)"
       using 10 1122 1143 by metis
     have 1598: "\<And>x . - x \<squnion> - (x \<squnion> (x \<squnion> (x \<squnion> - x))) = - x \<squnion> (- x \<squnion> - (x \<squnion> - x))"
       using 4 1436 1568 by metis
     have 1599: "\<And>x y . - x \<squnion> (y \<squnion> - (x \<squnion> (- x \<squnion> (- x \<squnion> y)))) = y \<squnion> - (x \<squnion> y)"
       using 10 1377 1568 by smt
     have 1617: "\<And>x . x \<squnion> (- x \<squnion> (- x \<squnion> - (x \<squnion> - x))) = x \<squnion> - x"
       using 3 4 10 71 1122 1155 1568 1598 by metis
     have 1632: "\<And>x y z . - (x \<squnion> - x) \<squnion> - (- y \<squnion> (- (z \<squnion> - z) \<squnion> - (y \<squnion> - (x \<squnion> - x)))) = y \<squnion> - (x \<squnion> - x)"
       using 43 1157 by metis
     have 1633: "\<And>x y z . - (x \<squnion> - x) \<squnion> - (- y \<squnion> (- (x \<squnion> - x) \<squnion> - (y \<squnion> - (z \<squnion> - z)))) = y \<squnion> - (x \<squnion> - x)"
       using 43 1157 by metis
     have 1636: "\<And>x y . x \<squnion> - (y \<squnion> (- y \<squnion> - (x \<squnion> x))) = x \<squnion> x"
       using 43 1109 1122 by metis
     have 1645: "\<And>x y . x \<squnion> - x = y \<squnion> (y \<squnion> - y)"
       using 3 1110 1156 by metis
     have 1648: "\<And>x y z . - (x \<squnion> (y \<squnion> (- y \<squnion> - x))) \<squnion> - (z \<squnion> - z) = - (y \<squnion> - y)"
       using 3 1115 1156 by metis
     have 1657: "\<And>x y z . x \<squnion> - x = y \<squnion> (z \<squnion> - z)"
       using 1105 1645 by metis
     have 1664: "\<And>x y z . x \<squnion> - x = y \<squnion> (z \<squnion> - y)"
       using 1115 1645 by metis
     have 1672: "\<And>x y z . x \<squnion> - x = y \<squnion> (- y \<squnion> z)"
       using 3 4 1657 by metis
     have 1697: "\<And>x y z . - x \<squnion> (y \<squnion> x) = z \<squnion> - z"
       using 1122 1664 by metis
     have 1733: "\<And>x y z . - (x \<squnion> y) \<squnion> - (- (z \<squnion> - z) \<squnion> - (- (- x \<squnion> - x) \<squnion> y)) = x \<squnion> - x"
       using 4 47 1105 1122 by metis
     have 1791: "\<And>x y z . x \<squnion> - (y \<squnion> (- y \<squnion> z)) = x \<squnion> - (x \<squnion> - x)"
       using 4 71 1122 1672 by metis
     have 1818: "\<And>x y z . x \<squnion> - (- y \<squnion> (z \<squnion> y)) = x \<squnion> - (x \<squnion> - x)"
       using 4 71 1122 1697 by metis
     have 1861: "\<And>x y z . - (x \<squnion> - x) \<squnion> - (y \<squnion> - (z \<squnion> - z)) = - y"
       using 1437 1657 by metis
     have 1867: "\<And>x y z . - (x \<squnion> - x) \<squnion> - (- y \<squnion> - (z \<squnion> y)) = y"
       using 1122 1437 1697 by metis
     have 1868: "\<And>x y . x \<squnion> - (y \<squnion> - y) = x"
       using 1122 1155 1633 1861 by metis
     have 1869: "\<And>x y z . - (x \<squnion> - x) \<squnion> - (- y \<squnion> (- (z \<squnion> - z) \<squnion> - y)) = y"
       using 1632 1868 by metis
     have 1870: "\<And>x y . - (x \<squnion> - x) \<squnion> - y = - y"
       using 1861 1868 by metis
     have 1872: "\<And>x y z . x \<squnion> - (- y \<squnion> (z \<squnion> y)) = x"
       using 1818 1868 by metis
     have 1875: "\<And>x y z . x \<squnion> - (y \<squnion> (- y \<squnion> z)) = x"
       using 1791 1868 by metis
     have 1883: "\<And>x y . - (x \<squnion> (y \<squnion> (- y \<squnion> - x))) = - (y \<squnion> - y)"
       using 1648 1868 by metis
     have 1885: "\<And>x . x \<squnion> (x \<squnion> - x) = x \<squnion> - x"
       using 4 1568 1617 1868 by metis
     have 1886: "\<And>x . - x \<squnion> - x = - x"
       using 1598 1868 1885 by metis
     have 1890: "\<And>x . - (x \<squnion> x) = - x"
       using 1156 1868 by metis
     have 1892: "\<And>x y . - (x \<squnion> - x) \<squnion> y = y"
       using 1122 1869 1870 1886 by metis
     have 1893: "\<And>x y . - (- x \<squnion> - (y \<squnion> x)) = x"
       using 1867 1892 by metis
     have 1902: "\<And>x y . x \<squnion> (y \<squnion> - (x \<squnion> y)) = x \<squnion> - x"
       using 3 4 1122 1733 1886 1892 by metis
     have 1908: "\<And>x . x \<squnion> x = x"
       using 1636 1875 1890 by metis
     have 1910: "\<And>x y . x \<squnion> - (y \<squnion> x) = - y \<squnion> x"
       using 1599 1875 by metis
     have 1921: "\<And>x y . x \<squnion> (- y \<squnion> - (y \<squnion> x)) = - y \<squnion> x"
       using 1275 1875 1910 by metis
     have 1951: "\<And>x y . - x \<squnion> - (y \<squnion> x) = - x"
       using 1227 1872 1893 1908 by metis
     have 1954: "\<And>x y z . x \<squnion> (y \<squnion> - (x \<squnion> z)) = y \<squnion> (- z \<squnion> x)"
       using 745 1122 1910 1951 by metis
     have 1956: "\<And>x y z . x \<squnion> (- (x \<squnion> y) \<squnion> z) = - y \<squnion> (x \<squnion> z)"
       using 678 1122 1910 1951 by metis
     have 1959: "\<And>x y . x \<squnion> - (x \<squnion> y) = - y \<squnion> x"
       using 86 1122 1910 1951 by metis
     have 1972: "\<And>x y . x \<squnion> (- x \<squnion> y) = x \<squnion> - x"
       using 1902 1910 by metis
     have 2000: "\<And>x y . - (- x \<squnion> - y) \<squnion> - (y \<squnion> (- x \<squnion> y)) = x \<squnion> - (y \<squnion> (- x \<squnion> y))"
       using 4 1244 1910 1959 by metis
     have 2054: "\<And>x y . x \<squnion> - (y \<squnion> (- x \<squnion> y)) = x"
       using 1394 1921 2000 by metis
     have 2057: "\<And>x y . - (x \<squnion> (y \<squnion> - y)) = - (y \<squnion> - y)"
       using 1883 1972 by metis
     have 2061: "\<And>x y . x \<squnion> (- y \<squnion> x) = x \<squnion> - y"
       using 4 1122 1427 1910 1959 2054 by metis
     have 2090: "\<And>x y z . x \<squnion> (- (y \<squnion> x) \<squnion> z) = x \<squnion> (- y \<squnion> z)"
       using 1122 1169 1956 by metis
     have 2100: "\<And>x y . - x \<squnion> - (x \<squnion> y) = - x"
       using 4 1346 1868 1885 1910 1959 1972 2057 by metis
     have 2144: "\<And>x y . x \<squnion> - (y \<squnion> - x) = x"
       using 1122 1440 2000 2061 by metis
     have 2199: "\<And>x y . x \<squnion> (x \<squnion> y) = x \<squnion> y"
       using 3 1908 by metis
     have 2208: "\<And>x y z . x \<squnion> (- (y \<squnion> - x) \<squnion> z) = x \<squnion> z"
       using 3 2144 by metis
     have 2349: "\<And>x y z . - (x \<squnion> y) \<squnion> - (x \<squnion> (y \<squnion> z)) = - (x \<squnion> y)"
       using 3 2100 by metis
     have 2432: "\<And>x y z . - (x \<squnion> (y \<squnion> z)) \<squnion> - (y \<squnion> (z \<squnion> - x)) = - (y \<squnion> z)"
       using 3 1438 by metis
     have 2530: "\<And>x y z . - (- (x \<squnion> y) \<squnion> z) = - (y \<squnion> (- x \<squnion> z)) \<squnion> - (- y \<squnion> z)"
       using 4 1122 1439 2090 2208 by smt
     have 3364: "\<And>x y z . - (- x \<squnion> y) \<squnion> (z \<squnion> - (x \<squnion> y)) = z \<squnion> - y"
       using 3 4 1122 1441 1910 1954 2199 by metis
     have 5763: "\<And>x y z . - (x \<squnion> y) \<squnion> - (- x \<squnion> (y \<squnion> z)) = - (x \<squnion> y) \<squnion> - (y \<squnion> z)"
       using 4 2349 3364 by metis
     have 6113: "\<And>x y z . - (x \<squnion> (y \<squnion> z)) \<squnion> - (z \<squnion> - x) = - (y \<squnion> z) \<squnion> - (z \<squnion> - x)"
       using 4 2432 3364 5763 by metis
     show "\<And>x y z. x \<squnion> y \<sqinter> z = (x \<squnion> y) \<sqinter> (x \<squnion> z)"
     proof -
       fix x y z
       have "- (y \<sqinter> z \<squnion> x) = - (- (- y \<squnion> z) \<squnion> - (- y \<squnion> - z) \<squnion> x) \<squnion> - (x \<squnion> - - z)"
         using 1437 2530 6113 by (smt commutative inf_def)
       thus "x \<squnion> y \<sqinter> z = (x \<squnion> y) \<sqinter> (x \<squnion> z)"
         using 12 1122 by (metis commutative inf_def)
     qed
   qed
   show 14: "\<And>x. x \<sqinter> - x = bot"
   proof -
     fix x
     have "(bot \<squnion> x) \<sqinter> (bot \<squnion> -x) = bot"
       using huntington bot_def inf_def by auto
     thus "x \<sqinter> -x = bot"
       using 11 less_eq_def by force
   qed
   show 15: "\<And>x. x \<squnion> - x = top"
     using 5 14 by (metis (no_types, lifting) huntington bot_def less_eq_def top_def)
   show 16: "\<And>x y. x - y = x \<sqinter> - y"
     using 15 by (metis commutative huntington inf_def minus_def)
   show 7: "\<And>x y z. x \<le> y \<Longrightarrow> x \<le> z \<Longrightarrow> x \<le> y \<sqinter> z"
     by (simp add: 13 less_eq_def)
 qed
 
 end
 
-context Lattices.boolean_algebra
+context boolean_algebra
 begin
 
 sublocale ba_he: huntington_extended
 proof
   show "\<And>x y z. x \<squnion> (y \<squnion> z) = x \<squnion> y \<squnion> z"
     by (simp add: sup_assoc)
   show "\<And>x y. x \<squnion> y = y \<squnion> x"
     by (simp add: sup_commute)
   show "\<And>x y. x = - (- x \<squnion> y) \<squnion> - (- x \<squnion> - y)"
     by simp
   show "top = (THE x. \<forall>y. x = y \<squnion> - y)"
     by auto
   show "bot = - (THE x. \<forall>y. x = y \<squnion> - y)"
     by auto
   show "\<And>x y. x \<sqinter> y = - (- x \<squnion> - y)"
     by simp
   show "\<And>x y. x - y = - (- x \<squnion> y)"
     by (simp add: diff_eq)
   show "\<And>x y. (x \<le> y) = (x \<squnion> y = y)"
     by (simp add: le_iff_sup)
   show "\<And>x y. (x < y) = (x \<squnion> y = y \<and> y \<squnion> x \<noteq> x)"
     using sup.strict_order_iff sup_commute by auto
 qed
 
 end
 
 subsection \<open>Stone Algebras\<close>
 
 text \<open>
 We relate Stone algebras to Boolean algebras.
 \<close>
 
 class stone_algebra_extended = stone_algebra + minus +
   assumes stone_minus_def[simp]: "x - y = x \<sqinter> -y"
 
 class regular_stone_algebra = stone_algebra_extended +
   assumes double_complement[simp]: "--x = x"
 begin
 
 subclass boolean_algebra
 proof
   show "\<And>x. x \<sqinter> - x = bot"
     by simp
   show "\<And>x. x \<squnion> - x = top"
     using regular_dense_top by fastforce
   show "\<And>x y. x - y = x \<sqinter> - y"
     by simp
 qed
 
 end
 
-context Lattices.boolean_algebra
+context boolean_algebra
 begin
 
 sublocale ba_rsa: regular_stone_algebra
 proof
   show "\<And>x y. x - y = x \<sqinter> - y"
     by (simp add: diff_eq)
   show "\<And>x. - - x = x"
     by simp
 qed
 
 end
 
 section \<open>Alternative Axiomatisations of Boolean Algebras\<close>
 
 text \<open>
 We consider four axiomatisations of Boolean algebras based only on join and complement.
 The first three are from the literature and the fourth, a version using equational axioms, is new.
 The motivation for Byrne's and the new axiomatisation is that the axioms are easier to understand than Huntington's third axiom.
 We also include Meredith's axiomatisation.
 \<close>
 
 subsection \<open>Lee Byrne's Formulation A\<close>
 
 text \<open>
 The following axiomatisation is from \cite[Formulation A]{Byrne1946}; see also \cite{Frink1941}.
 \<close>
 
 text \<open>Theorem 3\<close>
 
 class boolean_algebra_1 = sup + uminus +
   assumes ba1_associative: "x \<squnion> (y \<squnion> z) = (x \<squnion> y) \<squnion> z"
   assumes ba1_commutative: "x \<squnion> y = y \<squnion> x"
   assumes ba1_complement: "x \<squnion> -y = z \<squnion> -z \<longleftrightarrow> x \<squnion> y = x"
 begin
 
 subclass huntington
 proof
   show 1: "\<And>x y z. x \<squnion> (y \<squnion> z) = x \<squnion> y \<squnion> z"
     by (simp add: ba1_associative)
   show "\<And>x y. x \<squnion> y = y \<squnion> x"
     by (simp add: ba1_commutative)
   show "\<And>x y. x = - (- x \<squnion> y) \<squnion> - (- x \<squnion> - y)"
   proof -
     have 2: "\<forall>x y. y \<squnion> (y \<squnion> x) = y \<squnion> x"
       using 1 by (metis ba1_complement)
     hence "\<forall>x. --x = x"
       by (smt ba1_associative ba1_commutative ba1_complement)
     hence "\<forall>x y. y \<squnion> -(y \<squnion> -x) = y \<squnion> x"
       by (smt ba1_associative ba1_commutative ba1_complement)
     thus "\<And>x y. x = -(-x \<squnion> y) \<squnion> -(-x \<squnion> - y)"
       using 2 by (smt ba1_commutative ba1_complement)
   qed
 qed
 
 end
 
 context huntington
 begin
 
 sublocale h_ba1: boolean_algebra_1
 proof
   show "\<And>x y z. x \<squnion> (y \<squnion> z) = x \<squnion> y \<squnion> z"
     by (simp add: associative)
   show "\<And>x y. x \<squnion> y = y \<squnion> x"
     by (simp add: commutative)
   show "\<And>x y z. (x \<squnion> - y = z \<squnion> - z) = (x \<squnion> y = x)"
   proof
     fix x y z
     have 1: "\<And>x y z. -(-x \<squnion> y) \<squnion> (-(-x \<squnion> -y) \<squnion> z) = x \<squnion> z"
       using associative huntington by force
     have 2: "\<And>x y. -(x \<squnion> -y) \<squnion> -(-y \<squnion> -x) = y"
       by (metis commutative huntington)
     show "x \<squnion> - y = z \<squnion> - z \<Longrightarrow> x \<squnion> y = x"
       by (metis 1 2 associative commutative top_unique)
     show "x \<squnion> y = x \<Longrightarrow> x \<squnion> - y = z \<squnion> - z"
       by (metis associative huntington commutative top_unique)
   qed
 qed
 
 end
 
 subsection \<open>Lee Byrne's Formulation B\<close>
 
 text \<open>
 The following axiomatisation is from \cite[Formulation B]{Byrne1946}.
 \<close>
 
 text \<open>Theorem 4\<close>
 
 class boolean_algebra_2 = sup + uminus +
   assumes ba2_associative_commutative: "(x \<squnion> y) \<squnion> z = (y \<squnion> z) \<squnion> x"
   assumes ba2_complement: "x \<squnion> -y = z \<squnion> -z \<longleftrightarrow> x \<squnion> y = x"
 begin
 
 subclass boolean_algebra_1
 proof
   show "\<And>x y z. x \<squnion> (y \<squnion> z) = x \<squnion> y \<squnion> z"
     by (smt ba2_associative_commutative ba2_complement)
   show "\<And>x y. x \<squnion> y = y \<squnion> x"
     by (metis ba2_associative_commutative ba2_complement)
   show "\<And>x y z. (x \<squnion> - y = z \<squnion> - z) = (x \<squnion> y = x)"
     by (simp add: ba2_complement)
 qed
 
 end
 
 context boolean_algebra_1
 begin
 
 sublocale ba1_ba2: boolean_algebra_2
 proof
   show "\<And>x y z. x \<squnion> y \<squnion> z = y \<squnion> z \<squnion> x"
     using ba1_associative commutative by force
   show "\<And>x y z. (x \<squnion> - y = z \<squnion> - z) = (x \<squnion> y = x)"
     by (simp add: ba1_complement)
 qed
 
 end
 
 subsection \<open>Meredith's Equational Axioms\<close>
 
 text \<open>
 The following axiomatisation is from \cite[page 221 (1) \{A,N\}]{MeredithPrior1968}.
 \<close>
 
 class boolean_algebra_mp = sup + uminus +
   assumes ba_mp_1: "-(-x \<squnion> y) \<squnion> x = x"
   assumes ba_mp_2: "-(-x \<squnion> y) \<squnion> (z \<squnion> y) = y \<squnion> (z \<squnion> x)"
 begin
 
 subclass huntington
 proof
   show "\<And>x y z. x \<squnion> (y \<squnion> z) = x \<squnion> y \<squnion> z"
     by (metis ba_mp_1 ba_mp_2)
   show "\<And>x y. x \<squnion> y = y \<squnion> x"
     by (metis ba_mp_1 ba_mp_2)
   show "\<And>x y. x = - (- x \<squnion> y) \<squnion> - (- x \<squnion> - y)"
     by (metis ba_mp_1 ba_mp_2)
 qed
 
 end
 
 context huntington
 begin
 
 sublocale mp_h: boolean_algebra_mp
 proof
   show 1: "\<And>x y. - (- x \<squnion> y) \<squnion> x = x"
     by (metis h_ba1.ba1_associative h_ba1.ba1_complement huntington)
   show "\<And>x y z. - (- x \<squnion> y) \<squnion> (z \<squnion> y) = y \<squnion> (z \<squnion> x)"
   proof -
     fix x y z
     have "y = -(-x \<squnion> -y) \<squnion> y"
       using 1 h_ba1.ba1_commutative by auto
     thus "-(-x \<squnion> y) \<squnion> (z \<squnion> y) = y \<squnion> (z \<squnion> x)"
       by (metis h_ba1.ba1_associative h_ba1.ba1_commutative huntington)
   qed
 qed
 
 end
 
 subsection \<open>An Equational Axiomatisation based on Semilattices\<close>
 
 text \<open>
 The following version is an equational axiomatisation based on semilattices.
 We add the double complement rule and that \<open>top\<close> is unique.
 The final axiom \<open>ba3_export\<close> encodes the logical statement $P \vee Q = P \vee (\neg P \wedge Q)$.
 Its dual appears in \cite{BalbesHorn1970}.
 \<close>
 
 text \<open>Theorem 5\<close>
 
 class boolean_algebra_3 = sup + uminus +
   assumes ba3_associative: "x \<squnion> (y \<squnion> z) = (x \<squnion> y) \<squnion> z"
   assumes ba3_commutative: "x \<squnion> y = y \<squnion> x"
   assumes ba3_idempotent[simp]: "x \<squnion> x = x"
   assumes ba3_double_complement[simp]: "--x = x"
   assumes ba3_top_unique: "x \<squnion> -x = y \<squnion> -y"
   assumes ba3_export: "x \<squnion> -(x \<squnion> y) = x \<squnion> -y"
 begin
 
 subclass huntington
 proof
   show "\<And>x y z. x \<squnion> (y \<squnion> z) = x \<squnion> y \<squnion> z"
     by (simp add: ba3_associative)
   show "\<And>x y. x \<squnion> y = y \<squnion> x"
     by (simp add: ba3_commutative)
   show "\<And>x y. x = - (- x \<squnion> y) \<squnion> - (- x \<squnion> - y)"
     by (metis ba3_commutative ba3_double_complement ba3_export ba3_idempotent ba3_top_unique)
 qed
 
 end
 
 context huntington
 begin
 
 sublocale h_ba3: boolean_algebra_3
 proof
   show "\<And>x y z. x \<squnion> (y \<squnion> z) = x \<squnion> y \<squnion> z"
     by (simp add: h_ba1.ba1_associative)
   show "\<And>x y. x \<squnion> y = y \<squnion> x"
     by (simp add: h_ba1.ba1_commutative)
   show 3: "\<And>x. x \<squnion> x = x"
     using h_ba1.ba1_complement by blast
   show 4: "\<And>x. - - x = x"
     by (metis h_ba1.ba1_commutative huntington top_unique)
   show "\<And>x y. x \<squnion> - x = y \<squnion> - y"
     by (simp add: top_unique)
   show "\<And>x y. x \<squnion> - (x \<squnion> y) = x \<squnion> - y"
     using 3 4 by (smt h_ba1.ba1_ba2.ba2_associative_commutative h_ba1.ba1_complement)
 qed
 
 end
 
 section \<open>Subset Boolean Algebras\<close>
 
 text \<open>
 We apply Huntington's axioms to the range of a unary operation, which serves as complement on the range.
 This gives a Boolean algebra structure on the range without imposing any further constraints on the set.
 The obtained structure is used as a reference in the subsequent development and to inherit the results proved here.
 This is taken from \cite{Guttmann2012c,GuttmannStruthWeber2011b} and follows the development of Boolean algebras in \cite{Maddux1996}.
 \<close>
 
 text \<open>Definition 6\<close>
 
 class subset_boolean_algebra = sup + uminus +
   assumes sub_associative: "-x \<squnion> (-y \<squnion> -z) = (-x \<squnion> -y) \<squnion> -z"
   assumes sub_commutative: "-x \<squnion> -y = -y \<squnion> -x"
   assumes sub_complement: "-x = -(--x \<squnion> -y) \<squnion> -(--x \<squnion> --y)"
   assumes sub_sup_closed: "-x \<squnion> -y = --(-x \<squnion> -y)"
 begin
 
 text \<open>uniqueness of \<open>top\<close>, resulting in the lemma \<open>top_def\<close> to replace the assumption \<open>sub_top_def\<close>\<close>
 
 lemma top_unique:
   "-x \<squnion> --x = -y \<squnion> --y"
   by (metis sub_associative sub_commutative sub_complement)
 
 text \<open>consequences for join and complement\<close>
 
 lemma double_negation[simp]:
   "---x = -x"
   by (metis sub_complement sub_sup_closed)
 
 lemma complement_1:
   "--x = -(-x \<squnion> -y) \<squnion> -(-x \<squnion> --y)"
   by (metis double_negation sub_complement)
 
 lemma sup_right_zero_var:
   "-x \<squnion> (-y \<squnion> --y) = -z \<squnion> --z"
   by (smt complement_1 sub_associative sub_sup_closed top_unique)
 
 lemma sup_right_unit_idempotent:
   "-x \<squnion> -x = -x \<squnion> -(-y \<squnion> --y)"
   by (metis complement_1 double_negation sub_sup_closed sup_right_zero_var)
 
 lemma sup_idempotent[simp]:
   "-x \<squnion> -x = -x"
   by (smt complement_1 double_negation sub_associative sup_right_unit_idempotent)
 
 lemma complement_2:
   "-x = -(-(-x \<squnion> -y) \<squnion> -(-x \<squnion> --y))"
   using complement_1 by auto
 
 lemma sup_eq_cases:
   "-x \<squnion> -y = -x \<squnion> -z \<Longrightarrow> --x \<squnion> -y = --x \<squnion> -z \<Longrightarrow> -y = -z"
   by (metis complement_2 sub_commutative)
 
 lemma sup_eq_cases_2:
   "-y \<squnion> -x = -z \<squnion> -x \<Longrightarrow> -y \<squnion> --x = -z \<squnion> --x \<Longrightarrow> -y = -z"
   using sub_commutative sup_eq_cases by auto
 
 end
 
 text \<open>Definition 7\<close>
 
 class subset_extended = sup + inf + minus + uminus + bot + top + ord +
   assumes sub_top_def: "top = (THE x . \<forall>y . x = -y \<squnion> --y)" (* define without imposing uniqueness *)
   assumes sub_bot_def: "bot = -(THE x . \<forall>y . x = -y \<squnion> --y)"
   assumes sub_inf_def: "-x \<sqinter> -y = -(--x \<squnion> --y)"
   assumes sub_minus_def: "-x - -y = -(--x \<squnion> -y)"
   assumes sub_less_eq_def: "-x \<le> -y \<longleftrightarrow> -x \<squnion> -y = -y"
   assumes sub_less_def: "-x < -y \<longleftrightarrow> -x \<squnion> -y = -y \<and> \<not> (-y \<squnion> -x = -x)"
 
 class subset_boolean_algebra_extended = subset_boolean_algebra + subset_extended
 begin
 
 lemma top_def:
   "top = -x \<squnion> --x"
   using sub_top_def top_unique by blast
 
 text \<open>consequences for meet\<close>
 
 lemma inf_closed:
   "-x \<sqinter> -y = --(-x \<sqinter> -y)"
   by (simp add: sub_inf_def)
 
 lemma inf_associative:
   "-x \<sqinter> (-y \<sqinter> -z) = (-x \<sqinter> -y) \<sqinter> -z"
   using sub_associative sub_inf_def sub_sup_closed by auto
 
 lemma inf_commutative:
   "-x \<sqinter> -y = -y \<sqinter> -x"
   by (simp add: sub_commutative sub_inf_def)
 
 lemma inf_idempotent[simp]:
   "-x \<sqinter> -x = -x"
   by (simp add: sub_inf_def)
 
 lemma inf_absorb[simp]:
   "(-x \<squnion> -y) \<sqinter> -x = -x"
   by (metis complement_1 sup_idempotent sub_inf_def sub_associative sub_sup_closed)
 
 lemma sup_absorb[simp]:
   "-x \<squnion> (-x \<sqinter> -y) = -x"
   by (metis sub_associative sub_complement sub_inf_def sup_idempotent)
 
 lemma inf_demorgan:
   "-(-x \<sqinter> -y) = --x \<squnion> --y"
   using sub_inf_def sub_sup_closed by auto
 
 lemma sub_sup_demorgan:
   "-(-x \<squnion> -y) = --x \<sqinter> --y"
   by (simp add: sub_inf_def)
 
 lemma sup_cases:
   "-x = (-x \<sqinter> -y) \<squnion> (-x \<sqinter> --y)"
   by (metis inf_closed inf_demorgan sub_complement)
 
 lemma inf_cases:
   "-x = (-x \<squnion> -y) \<sqinter> (-x \<squnion> --y)"
   by (metis complement_2 sub_sup_closed sub_sup_demorgan)
 
 lemma inf_complement_intro:
   "(-x \<squnion> -y) \<sqinter> --x = -y \<sqinter> --x"
 proof -
   have "(-x \<squnion> -y) \<sqinter> --x = (-x \<squnion> -y) \<sqinter> (--x \<squnion> -y) \<sqinter> --x"
     by (metis inf_absorb inf_associative sub_sup_closed)
   also have "... = -y \<sqinter> --x"
     by (metis inf_cases sub_commutative)
   finally show ?thesis
     .
 qed
 
 lemma sup_complement_intro:
   "-x \<squnion> -y = -x \<squnion> (--x \<sqinter> -y)"
   by (metis inf_absorb inf_commutative inf_complement_intro sub_sup_closed sup_cases)
 
 lemma inf_left_dist_sup:
   "-x \<sqinter> (-y \<squnion> -z) = (-x \<sqinter> -y) \<squnion> (-x \<sqinter> -z)"
 proof -
   have "-x \<sqinter> (-y \<squnion> -z) = (-x \<sqinter> (-y \<squnion> -z) \<sqinter> -y) \<squnion> (-x \<sqinter> (-y \<squnion> -z) \<sqinter> --y)"
     by (metis sub_inf_def sub_sup_closed sup_cases)
   also have "... = (-x \<sqinter> -y) \<squnion> (-x \<sqinter> -z \<sqinter> --y)"
     by (metis inf_absorb inf_associative inf_complement_intro sub_sup_closed)
   also have "... = (-x \<sqinter> -y) \<squnion> ((-x \<sqinter> -y \<sqinter> -z) \<squnion> (-x \<sqinter> -z \<sqinter> --y))"
     using sub_associative sub_inf_def sup_absorb by auto
   also have "... = (-x \<sqinter> -y) \<squnion> ((-x \<sqinter> -z \<sqinter> -y) \<squnion> (-x \<sqinter> -z \<sqinter> --y))"
     by (metis inf_associative inf_commutative)
   also have "... = (-x \<sqinter> -y) \<squnion> (-x \<sqinter> -z)"
     by (metis sub_inf_def sup_cases)
   finally show ?thesis
     .
 qed
 
 lemma sup_left_dist_inf:
   "-x \<squnion> (-y \<sqinter> -z) = (-x \<squnion> -y) \<sqinter> (-x \<squnion> -z)"
 proof -
   have "-x \<squnion> (-y \<sqinter> -z) = -(--x \<sqinter> (--y \<squnion> --z))"
     by (metis sub_inf_def sub_sup_closed sub_sup_demorgan)
   also have "... = (-x \<squnion> -y) \<sqinter> (-x \<squnion> -z)"
     by (metis inf_left_dist_sup sub_sup_closed sub_sup_demorgan)
   finally show ?thesis
     .
 qed
 
 lemma sup_right_dist_inf:
   "(-y \<sqinter> -z) \<squnion> -x = (-y \<squnion> -x) \<sqinter> (-z \<squnion> -x)"
   using sub_commutative sub_inf_def sup_left_dist_inf by auto
 
 lemma inf_right_dist_sup:
   "(-y \<squnion> -z) \<sqinter> -x = (-y \<sqinter> -x) \<squnion> (-z \<sqinter> -x)"
   by (metis inf_commutative inf_left_dist_sup sub_sup_closed)
 
 lemma case_duality:
   "(--x \<sqinter> -y) \<squnion> (-x \<sqinter> -z) = (-x \<squnion> -y) \<sqinter> (--x \<squnion> -z)"
 proof -
   have 1: "-(--x \<sqinter> --y) \<sqinter> ----x = --x \<sqinter> -y"
     using inf_commutative inf_complement_intro sub_sup_closed sub_sup_demorgan by auto
   have 2: "-(----x \<squnion> -(--x \<squnion> -z)) = -----x \<sqinter> ---z"
     by (metis (no_types) double_negation sup_complement_intro sub_sup_demorgan)
   have 3: "-(--x \<sqinter> --y) \<sqinter> -x = -x"
     using inf_commutative inf_left_dist_sup sub_sup_closed sub_sup_demorgan by auto
   hence "-(--x \<sqinter> --y) = -x \<squnion> -y"
     using sub_sup_closed sub_sup_demorgan by auto
   thus ?thesis
     by (metis double_negation 1 2 3 inf_associative inf_left_dist_sup sup_complement_intro)
 qed
 
 lemma case_duality_2:
   "(-x \<sqinter> -y) \<squnion> (--x \<sqinter> -z) = (-x \<squnion> -z) \<sqinter> (--x \<squnion> -y)"
   using case_duality sub_commutative sub_inf_def by auto
 
 lemma complement_cases:
   "((-v \<sqinter> -w) \<squnion> (--v \<sqinter> -x)) \<sqinter> -((-v \<sqinter> -y) \<squnion> (--v \<sqinter> -z)) = (-v \<sqinter> -w \<sqinter> --y) \<squnion> (--v \<sqinter> -x \<sqinter> --z)"
 proof -
   have 1: "(--v \<squnion> -w) = --(--v \<squnion> -w) \<and> (-v \<squnion> -x) = --(-v \<squnion> -x) \<and> (--v \<squnion> --y) = --(--v \<squnion> --y) \<and> (-v \<squnion> --z) = --(-v \<squnion> --z)"
     using sub_inf_def sub_sup_closed by auto
   have 2: "(-v \<squnion> (-x \<sqinter> --z)) = --(-v \<squnion> (-x \<sqinter> --z))"
     using sub_inf_def sub_sup_closed by auto
   have "((-v \<sqinter> -w) \<squnion> (--v \<sqinter> -x)) \<sqinter> -((-v \<sqinter> -y) \<squnion> (--v \<sqinter> -z)) = ((-v \<sqinter> -w) \<squnion> (--v \<sqinter> -x)) \<sqinter> (-(-v \<sqinter> -y) \<sqinter> -(--v \<sqinter> -z))"
     using sub_inf_def by auto
   also have "... = ((-v \<sqinter> -w) \<squnion> (--v \<sqinter> -x)) \<sqinter> ((--v \<squnion> --y) \<sqinter> (-v \<squnion> --z))"
     using inf_demorgan by auto
   also have "... = (--v \<squnion> -w) \<sqinter> (-v \<squnion> -x) \<sqinter> ((--v \<squnion> --y) \<sqinter> (-v \<squnion> --z))"
     by (metis case_duality double_negation)
   also have "... = (--v \<squnion> -w) \<sqinter> ((-v \<squnion> -x) \<sqinter> ((--v \<squnion> --y) \<sqinter> (-v \<squnion> --z)))"
     by (metis 1 inf_associative sub_inf_def)
   also have "... = (--v \<squnion> -w) \<sqinter> ((-v \<squnion> -x) \<sqinter> (--v \<squnion> --y) \<sqinter> (-v \<squnion> --z))"
     by (metis 1 inf_associative)
   also have "... = (--v \<squnion> -w) \<sqinter> ((--v \<squnion> --y) \<sqinter> (-v \<squnion> -x) \<sqinter> (-v \<squnion> --z))"
     by (metis 1 inf_commutative)
   also have "... = (--v \<squnion> -w) \<sqinter> ((--v \<squnion> --y) \<sqinter> ((-v \<squnion> -x) \<sqinter> (-v \<squnion> --z)))"
     by (metis 1 inf_associative)
   also have "... = (--v \<squnion> -w) \<sqinter> ((--v \<squnion> --y) \<sqinter> (-v \<squnion> (-x \<sqinter> --z)))"
     by (simp add: sup_left_dist_inf)
   also have "... = (--v \<squnion> -w) \<sqinter> (--v \<squnion> --y) \<sqinter> (-v \<squnion> (-x \<sqinter> --z))"
     using 1 2 by (metis inf_associative)
   also have "... = (--v \<squnion> (-w \<sqinter> --y)) \<sqinter> (-v \<squnion> (-x \<sqinter> --z))"
     by (simp add: sup_left_dist_inf)
   also have "... = (-v \<sqinter> (-w \<sqinter> --y)) \<squnion> (--v \<sqinter> (-x \<sqinter> --z))"
     by (metis case_duality complement_1 complement_2 sub_inf_def)
   also have "... = (-v \<sqinter> -w \<sqinter> --y) \<squnion> (--v \<sqinter> -x \<sqinter> --z)"
     by (simp add: inf_associative)
   finally show ?thesis
     .
 qed
 
 lemma inf_cases_2: "--x = -(-x \<sqinter> -y) \<sqinter> -(-x \<sqinter> --y)"
   using sub_inf_def sup_cases by auto
 
 text \<open>consequences for \<open>top\<close> and \<open>bot\<close>\<close>
 
 lemma sup_complement[simp]:
   "-x \<squnion> --x = top"
   using top_def by auto
 
 lemma inf_complement[simp]:
   "-x \<sqinter> --x = bot"
   by (metis sub_bot_def sub_inf_def sub_top_def top_def)
 
 lemma complement_bot[simp]:
   "-bot = top"
   using inf_complement inf_demorgan sup_complement by fastforce
 
 lemma complement_top[simp]:
   "-top = bot"
   using sub_bot_def sub_top_def by blast
 
 lemma sup_right_zero[simp]:
   "-x \<squnion> top = top"
   using sup_right_zero_var by auto
 
 lemma sup_left_zero[simp]:
   "top \<squnion> -x = top"
   by (metis complement_bot sub_commutative sup_right_zero)
 
 lemma inf_right_unit[simp]:
   "-x \<sqinter> bot = bot"
   by (metis complement_bot complement_top double_negation sub_sup_demorgan sup_right_zero)
 
 lemma inf_left_unit[simp]:
   "bot \<sqinter> -x = bot"
   by (metis complement_top inf_commutative inf_right_unit)
 
 lemma sup_right_unit[simp]:
   "-x \<squnion> bot = -x"
   using sup_right_unit_idempotent by auto
 
 lemma sup_left_unit[simp]:
   "bot \<squnion> -x = -x"
   by (metis complement_top sub_commutative sup_right_unit)
 
 lemma inf_right_zero[simp]:
   "-x \<sqinter> top = -x"
   by (metis inf_left_dist_sup sup_cases top_def)
 
 lemma sub_inf_left_zero[simp]:
   "top \<sqinter> -x = -x"
   using inf_absorb top_def by fastforce
 
 lemma bot_double_complement[simp]:
   "--bot = bot"
   by simp
 
 lemma top_double_complement[simp]:
   "--top = top"
   by simp
 
 text \<open>consequences for the order\<close>
 
 lemma reflexive:
   "-x \<le> -x"
   by (simp add: sub_less_eq_def)
 
 lemma transitive:
   "-x \<le> -y \<Longrightarrow> -y \<le> -z \<Longrightarrow> -x \<le> -z"
   by (metis sub_associative sub_less_eq_def)
 
 lemma antisymmetric:
   "-x \<le> -y \<Longrightarrow> -y \<le> -x \<Longrightarrow> -x = -y"
   by (simp add: sub_commutative sub_less_eq_def)
 
 lemma sub_bot_least:
   "bot \<le> -x"
   using sup_left_unit complement_top sub_less_eq_def by blast
 
 lemma top_greatest:
   "-x \<le> top"
   using complement_bot sub_less_eq_def sup_right_zero by blast
 
 lemma upper_bound_left:
   "-x \<le> -x \<squnion> -y"
   by (metis sub_associative sub_less_eq_def sub_sup_closed sup_idempotent)
 
 lemma upper_bound_right:
   "-y \<le> -x \<squnion> -y"
   using sub_commutative upper_bound_left by fastforce
 
 lemma sub_sup_left_isotone:
   assumes "-x \<le> -y"
     shows "-x \<squnion> -z \<le> -y \<squnion> -z"
 proof -
   have "-x \<squnion> -y = -y"
     by (meson assms sub_less_eq_def)
   thus ?thesis
     by (metis (full_types) sub_associative sub_commutative sub_sup_closed upper_bound_left)
 qed
 
 lemma sub_sup_right_isotone:
   "-x \<le> -y \<Longrightarrow> -z \<squnion> -x \<le> -z \<squnion> -y"
   by (simp add: sub_commutative sub_sup_left_isotone)
 
 lemma sup_isotone:
   assumes "-p \<le> -q"
       and "-r \<le> -s"
     shows "-p \<squnion> -r \<le> -q \<squnion> -s"
 proof -
   have "\<And>x y. \<not> -x \<le> -y \<squnion> -r \<or> -x \<le> -y \<squnion> -s"
     by (metis (full_types) assms(2) sub_sup_closed sub_sup_right_isotone transitive)
   thus ?thesis
     by (metis (no_types) assms(1) sub_sup_closed sub_sup_left_isotone)
 qed
 
 lemma sub_complement_antitone:
   "-x \<le> -y \<Longrightarrow> --y \<le> --x"
   by (metis inf_absorb inf_demorgan sub_less_eq_def)
 
 lemma less_eq_inf:
   "-x \<le> -y \<longleftrightarrow> -x \<sqinter> -y = -x"
   by (metis inf_absorb inf_commutative sub_less_eq_def upper_bound_right sup_absorb)
 
 lemma inf_complement_left_antitone:
   "-x \<le> -y \<Longrightarrow> -(-y \<sqinter> -z) \<le> -(-x \<sqinter> -z)"
   by (simp add: sub_complement_antitone inf_demorgan sub_sup_left_isotone)
 
 lemma sub_inf_left_isotone:
   "-x \<le> -y \<Longrightarrow> -x \<sqinter> -z \<le> -y \<sqinter> -z"
   using sub_complement_antitone inf_closed inf_complement_left_antitone by fastforce
 
 lemma sub_inf_right_isotone:
   "-x \<le> -y \<Longrightarrow> -z \<sqinter> -x \<le> -z \<sqinter> -y"
   by (simp add: inf_commutative sub_inf_left_isotone)
 
 lemma inf_isotone:
   assumes "-p \<le> -q"
       and "-r \<le> -s"
     shows "-p \<sqinter> -r \<le> -q \<sqinter> -s"
 proof -
   have "\<forall>w x y z. (-w \<le> -x \<sqinter> -y \<or> \<not> -w \<le> -x \<sqinter> -z) \<or> \<not> -z \<le> -y"
     by (metis (no_types) inf_closed sub_inf_right_isotone transitive)
   thus ?thesis
     by (metis (no_types) assms inf_closed sub_inf_left_isotone)
 qed
 
 lemma least_upper_bound:
   "-x \<le> -z \<and> -y \<le> -z \<longleftrightarrow> -x \<squnion> -y \<le> -z"
   by (metis sub_sup_closed transitive upper_bound_right sup_idempotent sup_isotone upper_bound_left)
 
 lemma lower_bound_left:
   "-x \<sqinter> -y \<le> -x"
   by (metis sub_inf_def upper_bound_right sup_absorb)
 
 lemma lower_bound_right:
   "-x \<sqinter> -y \<le> -y"
   using inf_commutative lower_bound_left by fastforce
 
 lemma greatest_lower_bound:
   "-x \<le> -y \<and> -x \<le> -z \<longleftrightarrow> -x \<le> -y \<sqinter> -z"
   by (metis inf_closed sub_inf_left_isotone less_eq_inf transitive lower_bound_left lower_bound_right)
 
 lemma less_eq_sup_top:
   "-x \<le> -y \<longleftrightarrow> --x \<squnion> -y = top"
   by (metis complement_1 inf_commutative inf_complement_intro sub_inf_left_zero less_eq_inf sub_complement sup_complement_intro top_def)
 
 lemma less_eq_inf_bot:
   "-x \<le> -y \<longleftrightarrow> -x \<sqinter> --y = bot"
   by (metis complement_bot complement_top double_negation inf_demorgan less_eq_sup_top sub_inf_def)
 
 lemma shunting:
   "-x \<sqinter> -y \<le> -z \<longleftrightarrow> -y \<le> --x \<squnion> -z"
 proof (cases "--x \<squnion> (-z \<squnion> --y) = top")
   case True
   have "\<forall>v w. -v \<le> -w \<or> -w \<squnion> --v \<noteq> top"
     using less_eq_sup_top sub_commutative by blast
   thus ?thesis
     by (metis True sub_associative sub_commutative sub_inf_def sub_sup_closed)
 next
   case False
   hence "--x \<squnion> (-z \<squnion> --y) \<noteq> top \<and> \<not> -y \<le> -z \<squnion> --x"
     by (metis (no_types) less_eq_sup_top sub_associative sub_commutative sub_sup_closed)
   thus ?thesis
     using less_eq_sup_top sub_associative sub_commutative sub_inf_def sub_sup_closed by auto
 qed
 
 lemma shunting_right:
   "-x \<sqinter> -y \<le> -z \<longleftrightarrow> -x \<le> -z \<squnion> --y"
   by (metis inf_commutative sub_commutative shunting)
 
 lemma sup_less_eq_cases:
   assumes "-z \<le> -x \<squnion> -y"
       and "-z \<le> --x \<squnion> -y"
     shows "-z \<le> -y"
 proof -
   have "-z \<le> (-x \<squnion> -y) \<sqinter> (--x \<squnion> -y)"
     by (metis assms greatest_lower_bound sub_sup_closed)
   also have "... = -y"
     by (metis inf_cases sub_commutative)
   finally show ?thesis
     .
 qed
 
 lemma sup_less_eq_cases_2:
   "-x \<squnion> -y \<le> -x \<squnion> -z \<Longrightarrow> --x \<squnion> -y \<le> --x \<squnion> -z \<Longrightarrow> -y \<le> -z"
   by (metis least_upper_bound sup_less_eq_cases sub_sup_closed)
 
 lemma sup_less_eq_cases_3:
   "-y \<squnion> -x \<le> -z \<squnion> -x \<Longrightarrow> -y \<squnion> --x \<le> -z \<squnion> --x \<Longrightarrow> -y \<le> -z"
   by (simp add: sup_less_eq_cases_2 sub_commutative)
 
 lemma inf_less_eq_cases:
   "-x \<sqinter> -y \<le> -z \<Longrightarrow> --x \<sqinter> -y \<le> -z \<Longrightarrow> -y \<le> -z"
   by (simp add: shunting sup_less_eq_cases)
 
 lemma inf_less_eq_cases_2:
   "-x \<sqinter> -y \<le> -x \<sqinter> -z \<Longrightarrow> --x \<sqinter> -y \<le> --x \<sqinter> -z \<Longrightarrow> -y \<le> -z"
   by (metis greatest_lower_bound inf_closed inf_less_eq_cases)
 
 lemma inf_less_eq_cases_3:
   "-y \<sqinter> -x \<le> -z \<sqinter> -x \<Longrightarrow> -y \<sqinter> --x \<le> -z \<sqinter> --x \<Longrightarrow> -y \<le> -z"
   by (simp add: inf_commutative inf_less_eq_cases_2)
 
 lemma inf_eq_cases:
   "-x \<sqinter> -y = -x \<sqinter> -z \<Longrightarrow> --x \<sqinter> -y = --x \<sqinter> -z \<Longrightarrow> -y = -z"
   by (metis inf_commutative sup_cases)
 
 lemma inf_eq_cases_2:
   "-y \<sqinter> -x = -z \<sqinter> -x \<Longrightarrow> -y \<sqinter> --x = -z \<sqinter> --x \<Longrightarrow> -y = -z"
   using inf_commutative inf_eq_cases by auto
 
 lemma wnf_lemma_1:
   "((-x \<squnion> -y) \<sqinter> (--x \<squnion> -z)) \<squnion> -x = -x \<squnion> -y"
 proof -
   have "\<forall>u v w. (-u \<sqinter> (-v \<squnion> --w)) \<squnion> -w = -u \<squnion> -w"
     by (metis inf_right_zero sub_associative sub_sup_closed sup_complement sup_idempotent sup_right_dist_inf)
   thus ?thesis
     by (metis (no_types) sub_associative sub_commutative sub_sup_closed sup_idempotent)
 qed
 
 lemma wnf_lemma_2:
   "((-x \<squnion> -y) \<sqinter> (-z \<squnion> --y)) \<squnion> -y = -x \<squnion> -y"
   using sub_commutative wnf_lemma_1 by fastforce
 
 lemma wnf_lemma_3:
   "((-x \<squnion> -z) \<sqinter> (--x \<squnion> -y)) \<squnion> --x = --x \<squnion> -y"
   by (metis case_duality case_duality_2 double_negation sub_commutative wnf_lemma_2)
 
 lemma wnf_lemma_4:
   "((-z \<squnion> -y) \<sqinter> (-x \<squnion> --y)) \<squnion> --y = -x \<squnion> --y"
   using sub_commutative wnf_lemma_3 by auto
 
 end
 
 class subset_boolean_algebra' = sup + uminus +
   assumes sub_associative': "-x \<squnion> (-y \<squnion> -z) = (-x \<squnion> -y) \<squnion> -z"
   assumes sub_commutative': "-x \<squnion> -y = -y \<squnion> -x"
   assumes sub_complement': "-x = -(--x \<squnion> -y) \<squnion> -(--x \<squnion> --y)"
   assumes sub_sup_closed': "\<exists>z . -x \<squnion> -y = -z"
 begin
 
 subclass subset_boolean_algebra
 proof
   show "\<And>x y z. - x \<squnion> (- y \<squnion> - z) = - x \<squnion> - y \<squnion> - z"
     by (simp add: sub_associative')
   show "\<And>x y. - x \<squnion> - y = - y \<squnion> - x"
     by (simp add: sub_commutative')
   show "\<And>x y. - x = - (- - x \<squnion> - y) \<squnion> - (- - x \<squnion> - - y)"
     by (simp add: sub_complement')
   show "\<And>x y. - x \<squnion> - y = - - (- x \<squnion> - y)"
   proof -
     fix x y
     have "\<forall>x y. -y \<squnion> (-(--y \<squnion> -x) \<squnion> -(---x \<squnion> -y)) = -y \<squnion> --x"
       by (metis (no_types) sub_associative' sub_commutative' sub_complement')
     hence "\<forall>x. ---x = -x"
       by (metis (no_types) sub_commutative' sub_complement')
     thus "-x \<squnion> -y = --(-x \<squnion> -y)"
       by (metis sub_sup_closed')
   qed
 qed
 
 end
 
 text \<open>
 We introduce a type for the range of complement and show that it is an instance of \<open>boolean_algebra\<close>.
 \<close>
 
 typedef (overloaded) 'a boolean_subset = "{ x::'a::uminus . \<exists>y . x = -y }"
   by auto
 
 lemma simp_boolean_subset[simp]:
   "\<exists>y . Rep_boolean_subset x = -y"
   using Rep_boolean_subset by simp
 
 setup_lifting type_definition_boolean_subset
 
 text \<open>Theorem 8.1\<close>
 
 instantiation boolean_subset :: (subset_boolean_algebra) huntington
 begin
 
 lift_definition sup_boolean_subset :: "'a boolean_subset \<Rightarrow> 'a boolean_subset \<Rightarrow> 'a boolean_subset" is sup
   using sub_sup_closed by auto
 
 lift_definition uminus_boolean_subset :: "'a boolean_subset \<Rightarrow> 'a boolean_subset" is uminus
   by auto
 
 instance
 proof
   show "\<And>x y z::'a boolean_subset. x \<squnion> (y \<squnion> z) = x \<squnion> y \<squnion> z"
     apply transfer
     using sub_associative by blast
   show "\<And>x y::'a boolean_subset. x \<squnion> y = y \<squnion> x"
     apply transfer
     using sub_commutative by blast
   show "\<And>x y::'a boolean_subset. x = - (- x \<squnion> y) \<squnion> - (- x \<squnion> - y)"
     apply transfer
     using sub_complement by blast
 qed
 
 end
 
 text \<open>Theorem 8.2\<close>
 
 instantiation boolean_subset :: (subset_boolean_algebra_extended) huntington_extended
 begin
 
 lift_definition inf_boolean_subset :: "'a boolean_subset \<Rightarrow> 'a boolean_subset \<Rightarrow> 'a boolean_subset" is inf
   using inf_closed by auto
 
 lift_definition minus_boolean_subset :: "'a boolean_subset \<Rightarrow> 'a boolean_subset \<Rightarrow> 'a boolean_subset" is minus
   using sub_minus_def by auto
 
 lift_definition bot_boolean_subset :: "'a boolean_subset" is bot
   by (metis complement_top)
 
 lift_definition top_boolean_subset :: "'a boolean_subset" is top
   by (metis complement_bot)
 
 lift_definition less_eq_boolean_subset :: "'a boolean_subset \<Rightarrow> 'a boolean_subset \<Rightarrow> bool" is less_eq .
 
 lift_definition less_boolean_subset :: "'a boolean_subset \<Rightarrow> 'a boolean_subset \<Rightarrow> bool" is less .
 
 instance
 proof
   show 1: "top = (THE x. \<forall>y::'a boolean_subset. x = y \<squnion> - y)"
   proof (rule the_equality[symmetric])
     show "\<forall>y::'a boolean_subset. top = y \<squnion> - y"
       apply transfer
       by auto
     show "\<And>x::'a boolean_subset. \<forall>y. x = y \<squnion> - y \<Longrightarrow> x = top"
       apply transfer
       by force
   qed
   have "(bot::'a boolean_subset) = - top"
     apply transfer
     by simp
   thus "bot = - (THE x. \<forall>y::'a boolean_subset. x = y \<squnion> - y)"
     using 1 by simp
   show "\<And>x y::'a boolean_subset. x \<sqinter> y = - (- x \<squnion> - y)"
     apply transfer
     using sub_inf_def by blast
   show "\<And>x y::'a boolean_subset. x - y = - (- x \<squnion> y)"
     apply transfer
     using sub_minus_def by blast
   show "\<And>x y::'a boolean_subset. (x \<le> y) = (x \<squnion> y = y)"
     apply transfer
     using sub_less_eq_def by blast
   show "\<And>x y::'a boolean_subset. (x < y) = (x \<squnion> y = y \<and> y \<squnion> x \<noteq> x)"
     apply transfer
     using sub_less_def by blast
 qed
 
 end
 
 section \<open>Subset Boolean algebras with Additional Structure\<close>
 
 text \<open>
 We now discuss axioms that make the range of a unary operation a Boolean algebra, but add further properties that are common to the intended models.
 In the intended models, the unary operation can be a complement, a pseudocomplement or the antidomain operation.
 For simplicity, we mostly call the unary operation `complement'.
 
 We first look at structures based only on join and complement, and then add axioms for the remaining operations of Boolean algebras.
 In the intended models, the operation that is meet on the range of the complement can be a meet in the whole algebra or composition.
 \<close>
 
 subsection \<open>Axioms Derived from the New Axiomatisation\<close>
 
 text \<open>
 The axioms of the first algebra are based on \<open>boolean_algebra_3\<close>.
 \<close>
 
 text \<open>Definition 9\<close>
 
 class subset_boolean_algebra_1 = sup + uminus +
   assumes sba1_associative: "x \<squnion> (y \<squnion> z) = (x \<squnion> y) \<squnion> z"
   assumes sba1_commutative: "x \<squnion> y = y \<squnion> x"
   assumes sba1_idempotent[simp]: "x \<squnion> x = x"
   assumes sba1_double_complement[simp]: "---x = -x"
   assumes sba1_bot_unique: "-(x \<squnion> -x) = -(y \<squnion> -y)"
   assumes sba1_export: "-x \<squnion> -(-x \<squnion> y) = -x \<squnion> -y"
 begin
 
 text \<open>Theorem 11.1\<close>
 
 subclass subset_boolean_algebra
 proof
   show "\<And>x y z. - x \<squnion> (- y \<squnion> - z) = - x \<squnion> - y \<squnion> - z"
     by (simp add: sba1_associative)
   show "\<And>x y. - x \<squnion> - y = - y \<squnion> - x"
     by (simp add: sba1_commutative)
   show "\<And>x y. - x = - (- - x \<squnion> - y) \<squnion> - (- - x \<squnion> - - y)"
     by (smt sba1_bot_unique sba1_commutative sba1_double_complement sba1_export sba1_idempotent)
   thus "\<And>x y. - x \<squnion> - y = - - (- x \<squnion> - y)"
     by (metis sba1_double_complement sba1_export)
 qed
 
 definition "sba1_bot \<equiv> THE x . \<forall>z . x = -(z \<squnion> -z)"
 
 lemma sba1_bot:
   "sba1_bot = -(z \<squnion> -z)"
   using sba1_bot_def sba1_bot_unique by auto
 
 end
 
 text \<open>Boolean algebra operations based on join and complement\<close>
 
 text \<open>Definition 10\<close>
 
 class subset_extended_1 = sup + inf + minus + uminus + bot + top + ord +
   assumes ba_bot: "bot = (THE x . \<forall>z . x = -(z \<squnion> -z))"
   assumes ba_top: "top = -(THE x . \<forall>z . x = -(z \<squnion> -z))"
   assumes ba_inf: "-x \<sqinter> -y = -(--x \<squnion> --y)"
   assumes ba_minus: "-x - -y = -(--x \<squnion> -y)"
   assumes ba_less_eq: "x \<le> y \<longleftrightarrow> x \<squnion> y = y"
   assumes ba_less: "x < y \<longleftrightarrow> x \<squnion> y = y \<and> \<not> (y \<squnion> x = x)"
 
 class subset_extended_2 = subset_extended_1 +
   assumes ba_bot_unique: "-(x \<squnion> -x) = -(y \<squnion> -y)"
 begin
 
 lemma ba_bot_def:
   "bot = -(z \<squnion> -z)"
   using ba_bot ba_bot_unique by auto
 
 lemma ba_top_def:
   "top = --(z \<squnion> -z)"
   using ba_bot_def ba_top by simp
 
 end
 
 text \<open>Subset forms Boolean Algebra, extended by Boolean algebra operations\<close>
 
 class subset_boolean_algebra_1_extended = subset_boolean_algebra_1 + subset_extended_1
 begin
 
 subclass subset_extended_2
 proof
   show "\<And>x y. - (x \<squnion> - x) = - (y \<squnion> - y)"
     by (simp add: sba1_bot_unique)
 qed
 
 subclass semilattice_sup
 proof
   show "\<And>x y. (x < y) = (x \<le> y \<and> \<not> y \<le> x)"
     by (simp add: ba_less ba_less_eq)
   show "\<And>x. x \<le> x"
     by (simp add: ba_less_eq)
   show "\<And>x y z. x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
     by (metis sba1_associative ba_less_eq)
   show "\<And>x y. x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
     by (simp add: sba1_commutative ba_less_eq)
   show "\<And>x y. x \<le> x \<squnion> y"
     by (simp add: sba1_associative ba_less_eq)
   thus "\<And>y x. y \<le> x \<squnion> y"
     by (simp add: sba1_commutative)
   show "\<And>y x z. y \<le> x \<Longrightarrow> z \<le> x \<Longrightarrow> y \<squnion> z \<le> x"
     by (metis sba1_associative ba_less_eq)
 qed
 
 text \<open>Theorem 11.2\<close>
 
 subclass subset_boolean_algebra_extended
 proof
   show "top = (THE x. \<forall>y. x = - y \<squnion> - - y)"
     by (smt ba_bot ba_bot_def ba_top sub_sup_closed the_equality)
   thus "bot = - (THE x. \<forall>y. x = - y \<squnion> - - y)"
     using ba_bot_def ba_top_def by force
   show "\<And>x y. - x \<sqinter> - y = - (- - x \<squnion> - - y)"
     by (simp add: ba_inf)
   show "\<And>x y. - x - - y = - (- - x \<squnion> - y)"
     by (simp add: ba_minus)
   show "\<And>x y. (- x \<le> - y) = (- x \<squnion> - y = - y)"
     using le_iff_sup by auto
   show "\<And>x y. (- x < - y) = (- x \<squnion> - y = - y \<and> - y \<squnion> - x \<noteq> - x)"
     by (simp add: ba_less)
 qed
 
 end
 
 subsection \<open>Stronger Assumptions based on Join and Complement\<close>
 
 text \<open>
 We add further axioms covering properties common to the antidomain and (pseudo)complement instances.
 \<close>
 
 text \<open>Definition 12\<close>
 
 class subset_boolean_algebra_2 = sup + uminus +
   assumes sba2_associative: "x \<squnion> (y \<squnion> z) = (x \<squnion> y) \<squnion> z"
   assumes sba2_commutative: "x \<squnion> y = y \<squnion> x"
   assumes sba2_idempotent[simp]: "x \<squnion> x = x"
   assumes sba2_bot_unit: "x \<squnion> -(y \<squnion> -y) = x"
   assumes sba2_sub_sup_demorgan: "-(x \<squnion> y) = -(--x \<squnion> --y)"
   assumes sba2_export: "-x \<squnion> -(-x \<squnion> y) = -x \<squnion> -y"
 begin
 
 text \<open>Theorem 13.1\<close>
 
 subclass subset_boolean_algebra_1
 proof
   show "\<And>x y z. x \<squnion> (y \<squnion> z) = x \<squnion> y \<squnion> z"
     by (simp add: sba2_associative)
   show "\<And>x y. x \<squnion> y = y \<squnion> x"
     by (simp add: sba2_commutative)
   show "\<And>x. x \<squnion> x = x"
     by simp
   show "\<And>x. - - - x = - x"
     by (metis sba2_idempotent sba2_sub_sup_demorgan)
   show "\<And>x y. - (x \<squnion> - x) = - (y \<squnion> - y)"
     by (metis sba2_bot_unit sba2_commutative)
   show "\<And>x y. - x \<squnion> - (- x \<squnion> y) = - x \<squnion> - y"
     by (simp add: sba2_export)
 qed
 
 text \<open>Theorem 13.2\<close>
 
 lemma double_complement_dist_sup:
   "--(x \<squnion> y) = --x \<squnion> --y"
   by (metis sba2_commutative sba2_export sba2_idempotent sba2_sub_sup_demorgan)
 
 lemma maddux_3_3[simp]:
   "-(x \<squnion> y) \<squnion> -(x \<squnion> -y) = -x"
   by (metis double_complement_dist_sup sba1_double_complement sba2_commutative sub_complement)
 
 lemma huntington_3_pp[simp]:
   "-(-x \<squnion> -y) \<squnion> -(-x \<squnion> y) = --x"
   using sba2_commutative maddux_3_3 by fastforce
 
 end
 
 class subset_boolean_algebra_2_extended = subset_boolean_algebra_2 + subset_extended_1
 begin
 
 subclass subset_boolean_algebra_1_extended ..
 
 subclass bounded_semilattice_sup_bot
 proof
   show "\<And>x. bot \<le> x"
     using sba2_bot_unit ba_bot_def sup_right_divisibility by auto
 qed
 
 text \<open>Theorem 13.3\<close>
 
 lemma complement_antitone:
   "x \<le> y \<Longrightarrow> -y \<le> -x"
   by (metis le_iff_sup maddux_3_3 sba2_export sup_monoid.add_commute)
 
 lemma double_complement_isotone:
   "x \<le> y \<Longrightarrow> --x \<le> --y"
   by (simp add: complement_antitone)
 
 lemma sup_demorgan:
   "-(x \<squnion> y) = -x \<sqinter> -y"
   using sba2_sub_sup_demorgan ba_inf by auto
 
 end
 
 subsection \<open>Axioms for Meet\<close>
 
 text \<open>
 We add further axioms of \<open>inf\<close> covering properties common to the antidomain and pseudocomplement instances.
 We omit the left distributivity rule and the right zero rule as they do not hold in some models.
 In particular, the operation \<open>inf\<close> does not have to be commutative.
 \<close>
 
 text \<open>Definition 14\<close>
 
 class subset_boolean_algebra_3_extended = subset_boolean_algebra_2_extended +
   assumes sba3_inf_associative: "x \<sqinter> (y \<sqinter> z) = (x \<sqinter> y) \<sqinter> z"
   assumes sba3_inf_right_dist_sup: "(x \<squnion> y) \<sqinter> z = (x \<sqinter> z) \<squnion> (y \<sqinter> z)"
   assumes sba3_inf_complement_bot: "-x \<sqinter> x = bot"
   assumes sba3_inf_left_unit[simp]: "top \<sqinter> x = x"
   assumes sba3_complement_inf_double_complement: "-(x \<sqinter> --y) = -(x \<sqinter> y)"
 begin
 
 text \<open>Theorem 15\<close>
 
 lemma inf_left_zero:
   "bot \<sqinter> x = bot"
   by (metis inf_right_unit sba3_inf_associative sba3_inf_complement_bot)
 
 lemma inf_double_complement_export:
   "--(--x \<sqinter> y) = --x \<sqinter> --y"
   by (metis inf_closed sba3_complement_inf_double_complement)
 
 lemma inf_left_isotone:
   "x \<le> y \<Longrightarrow> x \<sqinter> z \<le> y \<sqinter> z"
   using sba3_inf_right_dist_sup sup_right_divisibility by auto
 
 lemma inf_complement_export:
   "--(-x \<sqinter> y) = -x \<sqinter> --y"
   by (metis inf_double_complement_export sba1_double_complement)
 
 lemma double_complement_above:
   "--x \<sqinter> x = x"
   by (metis sup_monoid.add_0_right complement_bot inf_demorgan sba1_double_complement sba3_inf_complement_bot sba3_inf_right_dist_sup sba3_inf_left_unit)
 
 lemma "x \<le> y \<Longrightarrow> z \<sqinter> x \<le> z \<sqinter> y" nitpick [expect=genuine] oops
 lemma "x \<sqinter> top = x" nitpick [expect=genuine] oops
 lemma "x \<sqinter> y = y \<sqinter> x" nitpick [expect=genuine] oops
 
 end
 
 subsection \<open>Stronger Assumptions for Meet\<close>
 
 text \<open>
 The following axioms also hold in both models, but follow from the axioms of \<open>subset_boolean_algebra_5_operations\<close>.
 \<close>
 
 text \<open>Definition 16\<close>
 
 class subset_boolean_algebra_4_extended = subset_boolean_algebra_3_extended +
   assumes sba4_inf_right_unit[simp]: "x \<sqinter> top = x"
   assumes inf_right_isotone: "x \<le> y \<Longrightarrow> z \<sqinter> x \<le> z \<sqinter> y"
 begin
 
 lemma "x \<squnion> top = top" nitpick [expect=genuine] oops
 lemma "x \<sqinter> bot = bot" nitpick [expect=genuine] oops
 lemma "x \<sqinter> (y \<squnion> z) = (x \<sqinter> y) \<squnion> (x \<sqinter> z)" nitpick [expect=genuine] oops
 lemma "(x \<sqinter> y = bot) = (x \<le> - y)" nitpick [expect=genuine] oops
 
 end
 
 section \<open>Boolean Algebras in Stone Algebras\<close>
 
 text \<open>
 We specialise \<open>inf\<close> to meet and complement to pseudocomplement.
 This puts Stone algebras into the picture; for these it is well known that regular elements form a Boolean subalgebra \cite{Graetzer1971}.
 \<close>
 
 text \<open>Definition 17\<close>
 
 class subset_boolean_algebra_5_extended = subset_boolean_algebra_3_extended +
   assumes sba5_inf_commutative: "x \<sqinter> y = y \<sqinter> x"
   assumes sba5_inf_absorb: "x \<sqinter> (x \<squnion> y) = x"
 begin
 
 subclass distrib_lattice_bot
 proof
   show "\<And>x y. x \<sqinter> y \<le> x"
     by (metis sba5_inf_commutative sba3_inf_right_dist_sup sba5_inf_absorb sup_right_divisibility)
   show "\<And>x y. x \<sqinter> y \<le> y"
     by (metis inf_left_isotone sba5_inf_absorb sba5_inf_commutative sup_ge2)
   show "\<And>x y z. x \<le> y \<Longrightarrow> x \<le> z \<Longrightarrow> x \<le> y \<sqinter> z"
     by (metis inf_left_isotone sba5_inf_absorb sup.orderE sup_monoid.add_commute)
   show "\<And>x y z. x \<squnion> y \<sqinter> z = (x \<squnion> y) \<sqinter> (x \<squnion> z) "
     by (metis sba3_inf_right_dist_sup sba5_inf_absorb sba5_inf_commutative sup_assoc)
 qed
 
 lemma inf_demorgan_2:
   "-(x \<sqinter> y) = -x \<squnion> -y"
   using sba3_complement_inf_double_complement sba5_inf_commutative sub_sup_closed sub_sup_demorgan by auto
 
 lemma inf_export:
   "x \<sqinter> -(x \<sqinter> y) = x \<sqinter> -y"
   using inf_demorgan_2 sba3_inf_complement_bot sba3_inf_right_dist_sup sba5_inf_commutative by auto
 
 lemma complement_inf[simp]:
   "x \<sqinter> -x = bot"
   using sba3_inf_complement_bot sba5_inf_commutative by auto
 
 text \<open>Theorem 18.2\<close>
 
 subclass stone_algebra
 proof
   show "\<And>x. x \<le> top"
     by (simp add: inf.absorb_iff2)
   show "\<And>x y. (x \<sqinter> y = bot) = (x \<le> - y)"
     by (metis (full_types) complement_bot complement_inf inf.cobounded1 inf.order_iff inf_export sba3_complement_inf_double_complement sba3_inf_left_unit)
   show "\<And>x. - x \<squnion> - - x = top"
     by simp
 qed
 
 text \<open>Theorem 18.1\<close>
 
 subclass subset_boolean_algebra_4_extended
 proof
   show "\<And>x. x \<sqinter> top = x"
     by simp
   show "\<And>x y z. x \<le> y \<Longrightarrow> z \<sqinter> x \<le> z \<sqinter> y"
     using inf.sup_right_isotone by blast
 qed
 
 end
 
 context stone_algebra_extended
 begin
 
 text \<open>Theorem 18.3\<close>
 
 subclass subset_boolean_algebra_5_extended
 proof
   show "\<And>x y z. x \<squnion> (y \<squnion> z) = x \<squnion> y \<squnion> z"
     using sup_assoc by auto
   show "\<And>x y. x \<squnion> y = y \<squnion> x"
     by (simp add: sup_commute)
   show "\<And>x. x \<squnion> x = x"
     by simp
   show "\<And>x y. x \<squnion> - (y \<squnion> - y) = x"
     by simp
   show "\<And>x y. - (x \<squnion> y) = - (- - x \<squnion> - - y)"
     by auto
   show "\<And>x y. - x \<squnion> - (- x \<squnion> y) = - x \<squnion> - y"
     by (metis maddux_3_21_pp p_dist_sup regular_closed_p)
   show "bot = (THE x. \<forall>z. x = - (z \<squnion> - z))"
     by simp
   thus "top = - (THE x. \<forall>z. x = - (z \<squnion> - z))"
     using p_bot by blast
   show "\<And>x y. - x \<sqinter> - y = - (- - x \<squnion> - - y)"
     by simp
   show "\<And>x y. - x - - y = - (- - x \<squnion> - y)"
     by auto
   show "\<And>x y. (x \<le> y) = (x \<squnion> y = y)"
     by (simp add: le_iff_sup)
   thus "\<And>x y. (x < y) = (x \<squnion> y = y \<and> y \<squnion> x \<noteq> x)"
     by (simp add: less_le_not_le)
   show "\<And>x y z. x \<sqinter> (y \<sqinter> z) = x \<sqinter> y \<sqinter> z"
     by (simp add: inf.sup_monoid.add_assoc)
   show "\<And>x y z. (x \<squnion> y) \<sqinter> z = x \<sqinter> z \<squnion> y \<sqinter> z"
     by (simp add: inf_sup_distrib2)
   show "\<And>x. - x \<sqinter> x = bot"
     by simp
   show "\<And>x. top \<sqinter> x = x"
     by simp
   show "\<And>x y. - (x \<sqinter> - - y) = - (x \<sqinter> y)"
     by simp
   show "\<And>x y. x \<sqinter> y = y \<sqinter> x"
     by (simp add: inf_commute)
   show "\<And>x y. x \<sqinter> (x \<squnion> y) = x"
     by simp
 qed
 
 end
 
 section \<open>Domain Semirings\<close>
 
 text \<open>
 The following development of tests in IL-semirings, prepredomain semirings, predomain semirings and domain semirings is mostly based on \cite{MoellerDesharnais2019}; see also \cite{DesharnaisMoeller2014}.
 See \cite{DesharnaisMoellerStruth2006b} for domain axioms in idempotent semirings.
 See \cite{DesharnaisJipsenStruth2009,JacksonStokes2004} for domain axioms in semigroups and monoids.
 Some variants have been implemented in \cite{GomesGuttmannHoefnerStruthWeber2016}.
 \<close>
 
 subsection \<open>Idempotent Left Semirings\<close>
 
 text \<open>Definition 19\<close>
 
 class il_semiring = sup + inf + bot + top + ord +
   assumes il_associative: "x \<squnion> (y \<squnion> z) = (x \<squnion> y) \<squnion> z"
   assumes il_commutative: "x \<squnion> y = y \<squnion> x"
   assumes il_idempotent[simp]: "x \<squnion> x = x"
   assumes il_bot_unit: "x \<squnion> bot = x"
   assumes il_inf_associative: "x \<sqinter> (y \<sqinter> z) = (x \<sqinter> y) \<sqinter> z"
   assumes il_inf_right_dist_sup: "(x \<squnion> y) \<sqinter> z = (x \<sqinter> z) \<squnion> (y \<sqinter> z)"
   assumes il_inf_left_unit[simp]: "top \<sqinter> x = x"
   assumes il_inf_right_unit[simp]: "x \<sqinter> top = x"
   assumes il_sub_inf_left_zero[simp]: "bot \<sqinter> x = bot"
   assumes il_sub_inf_right_isotone: "x \<le> y \<Longrightarrow> z \<sqinter> x \<le> z \<sqinter> y"
   assumes il_less_eq: "x \<le> y \<longleftrightarrow> x \<squnion> y = y"
   assumes il_less_def: "x < y \<longleftrightarrow> x \<le> y \<and> \<not>(y \<le> x)"
 begin
 
 lemma il_unit_bot: "bot \<squnion> x = x"
   using il_bot_unit il_commutative by fastforce
 
 subclass order
 proof
   show "\<And>x y. (x < y) = (x \<le> y \<and> \<not> y \<le> x)"
     by (simp add: il_less_def)
   show "\<And>x. x \<le> x"
     by (simp add: il_less_eq)
   show "\<And>x y z. x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
     by (metis il_associative il_less_eq)
   show "\<And>x y. x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
     by (simp add: il_commutative il_less_eq)
 qed
 
 lemma il_sub_inf_right_isotone_var:
   "(x \<sqinter> y) \<squnion> (x \<sqinter> z) \<le> x \<sqinter> (y \<squnion> z)"
   by (smt il_associative il_commutative il_idempotent il_less_eq il_sub_inf_right_isotone)
 
 lemma il_sub_inf_left_isotone:
   "x \<le> y \<Longrightarrow> x \<sqinter> z \<le> y \<sqinter> z"
   by (metis il_inf_right_dist_sup il_less_eq)
 
 lemma il_sub_inf_left_isotone_var:
   "(y \<sqinter> x) \<squnion> (z \<sqinter> x) \<le> (y \<squnion> z) \<sqinter> x"
   by (simp add: il_inf_right_dist_sup)
 
 lemma sup_left_isotone:
   "x \<le> y \<Longrightarrow> x \<squnion> z \<le> y \<squnion> z"
   by (smt il_associative il_commutative il_idempotent il_less_eq)
 
 lemma sup_right_isotone:
   "x \<le> y \<Longrightarrow> z \<squnion> x \<le> z \<squnion> y"
   by (simp add: il_commutative sup_left_isotone)
 
 lemma bot_least:
   "bot \<le> x"
   by (simp add: il_less_eq il_unit_bot)
 
 lemma less_eq_bot:
   "x \<le> bot \<longleftrightarrow> x = bot"
   by (simp add: il_bot_unit il_less_eq)
 
 abbreviation are_complementary :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
   where "are_complementary x y \<equiv> x \<squnion> y = top \<and> x \<sqinter> y = bot \<and> y \<sqinter> x = bot"
 
 abbreviation test :: "'a \<Rightarrow> bool"
   where "test x \<equiv> \<exists>y . are_complementary x y"
 
 definition tests :: "'a set"
   where "tests = { x . test x }"
 
 lemma bot_test:
   "test bot"
   by (simp add: il_unit_bot)
 
 lemma top_test:
   "test top"
   by (simp add: il_bot_unit)
 
 lemma test_sub_identity:
   "test x \<Longrightarrow> x \<le> top"
   using il_associative il_less_eq by auto
 
 lemma neg_unique:
   "are_complementary x y \<Longrightarrow> are_complementary x z \<Longrightarrow> y = z"
   by (metis order.antisym il_inf_left_unit il_inf_right_dist_sup il_inf_right_unit il_sub_inf_right_isotone_var)
 
 definition neg :: "'a \<Rightarrow> 'a" ("!")
   where "!x \<equiv> THE y . are_complementary x y"
 
 lemma neg_char:
   assumes "test x"
     shows "are_complementary x (!x)"
 proof (unfold neg_def)
   from assms obtain y where 1: "are_complementary x y"
     by auto
   show "are_complementary x (THE y. are_complementary x y)"
   proof (rule theI)
     show "are_complementary x y"
       using 1 by simp
     show "\<And>z. are_complementary x z \<Longrightarrow> z = y"
       using 1 neg_unique by blast
   qed
 qed
 
 lemma are_complementary_symmetric:
   "are_complementary x y \<longleftrightarrow> are_complementary y x"
   using il_commutative by auto
 
 lemma neg_test:
   "test x \<Longrightarrow> test (!x)"
   using are_complementary_symmetric neg_char by blast
 
 lemma are_complementary_test:
   "test x \<Longrightarrow> are_complementary x y \<Longrightarrow> test y"
   using il_commutative by auto
 
 lemma neg_involutive:
   "test x \<Longrightarrow> !(!x) = x"
   using are_complementary_symmetric neg_char neg_unique by blast
 
 lemma test_inf_left_below:
   "test x \<Longrightarrow> x \<sqinter> y \<le> y"
   by (metis il_associative il_idempotent il_inf_left_unit il_inf_right_dist_sup il_less_eq)
 
 lemma test_inf_right_below:
   "test x \<Longrightarrow> y \<sqinter> x \<le> y"
   by (metis il_inf_right_unit il_sub_inf_right_isotone test_sub_identity)
 
 lemma neg_bot:
   "!bot = top"
   using il_unit_bot neg_char by fastforce
 
 lemma neg_top:
   "!top = bot"
   using bot_test neg_bot neg_involutive by fastforce
 
 lemma test_inf_idempotent:
   "test x \<Longrightarrow> x \<sqinter> x = x"
   by (metis il_bot_unit il_inf_left_unit il_inf_right_dist_sup)
 
 lemma test_inf_semicommutative:
   assumes "test x"
       and "test y"
   shows "x \<sqinter> y \<le> y \<sqinter> x"
 proof -
   have "x \<sqinter> y = (y \<sqinter> x \<sqinter> y) \<squnion> (!y \<sqinter> x \<sqinter> y)"
     by (metis assms(2) il_inf_left_unit il_inf_right_dist_sup neg_char)
   also have "... \<le> (y \<sqinter> x \<sqinter> y) \<squnion> (!y \<sqinter> y)"
   proof -
     obtain z where "are_complementary y z"
       using assms(2) by blast
     hence "y \<sqinter> (x \<sqinter> y) \<squnion> !y \<sqinter> (x \<sqinter> y) \<le> y \<sqinter> (x \<sqinter> y)"
       by (metis assms(1) calculation il_sub_inf_left_isotone il_bot_unit il_idempotent il_inf_associative il_less_eq neg_char test_inf_right_below)
     thus ?thesis
       by (simp add: il_associative il_inf_associative il_less_eq)
   qed
   also have "... \<le> (y \<sqinter> x) \<squnion> (!y \<sqinter> y)"
     by (metis assms(2) il_bot_unit il_inf_right_unit il_sub_inf_right_isotone neg_char test_sub_identity)
   also have "... = y \<sqinter> x"
     by (simp add: assms(2) il_bot_unit neg_char)
   finally show ?thesis
     .
 qed
 
 lemma test_inf_commutative:
   "test x \<Longrightarrow> test y \<Longrightarrow> x \<sqinter> y = y \<sqinter> x"
   by (simp add: order.antisym test_inf_semicommutative)
 
 lemma test_inf_bot:
   "test x \<Longrightarrow> x \<sqinter> bot = bot"
   using il_inf_associative test_inf_idempotent by fastforce
 
 lemma test_absorb_1:
   "test x \<Longrightarrow> test y \<Longrightarrow> x \<squnion> (x \<sqinter> y) = x"
   using il_commutative il_less_eq test_inf_right_below by auto
 
 lemma test_absorb_2:
   "test x \<Longrightarrow> test y \<Longrightarrow> x \<squnion> (y \<sqinter> x) = x"
   by (metis test_absorb_1 test_inf_commutative)
 
 lemma test_absorb_3:
   "test x \<Longrightarrow> test y \<Longrightarrow> x \<sqinter> (x \<squnion> y) = x"
   apply (rule order.antisym)
   apply (metis il_associative il_inf_right_unit il_less_eq il_sub_inf_right_isotone test_sub_identity)
   by (metis il_sub_inf_right_isotone_var test_absorb_1 test_inf_idempotent)
 
 lemma test_absorb_4:
   "test x \<Longrightarrow> test y \<Longrightarrow> (x \<squnion> y) \<sqinter> x = x"
   by (smt il_inf_right_dist_sup test_inf_idempotent il_commutative il_less_eq test_inf_left_below)
 
 lemma test_import_1:
   assumes "test x"
       and "test y"
     shows "x \<squnion> (!x \<sqinter> y) = x \<squnion> y"
 proof -
   have "x \<squnion> (!x \<sqinter> y) = x \<squnion> ((y \<squnion> !y) \<sqinter> x) \<squnion> (!x \<sqinter> y)"
     by (simp add: assms(2) neg_char)
   also have "... = x \<squnion> (!y \<sqinter> x) \<squnion> (x \<sqinter> y) \<squnion> (!x \<sqinter> y)"
     by (smt assms il_associative il_commutative il_inf_right_dist_sup test_inf_commutative)
   also have "... = x \<squnion> ((x \<squnion> !x) \<sqinter> y)"
     by (smt calculation il_associative il_commutative il_idempotent il_inf_right_dist_sup)
   also have "... = x \<squnion> y"
     by (simp add: assms(1) neg_char)
   finally show ?thesis
     .
 qed
 
 lemma test_import_2:
   assumes "test x"
       and "test y"
     shows "x \<squnion> (y \<sqinter> !x) = x \<squnion> y"
 proof -
   obtain z where 1: "are_complementary y z"
     using assms(2) by moura
   obtain w where 2: "are_complementary x w"
     using assms(1) by auto
   hence "x \<sqinter> !x = bot"
     using neg_char by blast
   hence "!x \<sqinter> y = y \<sqinter> !x"
     using 1 2 by (metis il_commutative neg_char test_inf_commutative)
   thus ?thesis
     using 1 2 by (metis test_import_1)
 qed
 
 lemma test_import_3:
   assumes "test x"
     shows "(!x \<squnion> y) \<sqinter> x = y \<sqinter> x"
   by (simp add: assms(1) il_inf_right_dist_sup il_unit_bot neg_char)
 
 lemma test_import_4:
   assumes "test x"
       and "test y"
     shows "(!x \<squnion> y) \<sqinter> x = x \<sqinter> y"
   by (metis assms test_import_3 test_inf_commutative)
 
 lemma test_inf:
   "test x \<Longrightarrow> test y \<Longrightarrow> test z \<Longrightarrow> z \<le> x \<sqinter> y \<longleftrightarrow> z \<le> x \<and> z \<le> y"
   apply (rule iffI)
   using dual_order.trans test_inf_left_below test_inf_right_below apply blast
   by (smt il_less_eq il_sub_inf_right_isotone test_absorb_4)
 
 lemma test_shunting:
   assumes "test x"
       and "test y"
     shows "x \<sqinter> y \<le> z \<longleftrightarrow> x \<le> !y \<squnion> z"
 proof
   assume 1: "x \<sqinter> y \<le> z"
   have "x = (!y \<sqinter> x) \<squnion> (y \<sqinter> x)"
     by (metis assms(2) il_commutative il_inf_left_unit il_inf_right_dist_sup neg_char)
   also have "... \<le> !y \<squnion> (y \<sqinter> x)"
     by (simp add: assms(1) sup_left_isotone test_inf_right_below)
   also have "... \<le> !y \<squnion> z"
     using 1 by (simp add: assms sup_right_isotone test_inf_commutative)
   finally show "x \<le> !y \<squnion> z"
     .
 next
   assume "x \<le> !y \<squnion> z"
   hence "x \<sqinter> y \<le> (!y \<squnion> z) \<sqinter> y"
     using il_sub_inf_left_isotone by blast
   also have "... = z \<sqinter> y"
     by (simp add: assms(2) test_import_3)
   also have "... \<le> z"
     by (simp add: assms(2) test_inf_right_below)
   finally show "x \<sqinter> y \<le> z"
     .
 qed
 
 lemma test_shunting_bot:
   assumes "test x"
       and "test y"
     shows "x \<le> y \<longleftrightarrow> x \<sqinter> !y \<le> bot"
   by (simp add: assms il_bot_unit neg_involutive neg_test test_shunting)
 
 lemma test_shunting_bot_eq:
   assumes "test x"
       and "test y"
     shows "x \<le> y \<longleftrightarrow> x \<sqinter> !y = bot"
   by (simp add: assms test_shunting_bot less_eq_bot)
 
 lemma neg_antitone:
   assumes "test x"
       and "test y"
       and "x \<le> y"
     shows "!y \<le> !x"
 proof -
   have 1: "x \<sqinter> !y = bot"
     using assms test_shunting_bot_eq by blast
   have 2: "x \<squnion> !x = top"
     by (simp add: assms(1) neg_char)
   have "are_complementary y (!y)"
     by (simp add: assms(2) neg_char)
   thus ?thesis
     using 1 2 by (metis il_unit_bot il_commutative il_inf_left_unit il_inf_right_dist_sup il_inf_right_unit il_sub_inf_right_isotone test_sub_identity)
 qed
 
 lemma test_sup_neg_1:
   assumes "test x"
       and "test y"
     shows "(x \<squnion> y) \<squnion> (!x \<sqinter> !y) = top"
 proof -
   have "x \<squnion> !x = top"
     by (simp add: assms(1) neg_char)
   hence "x \<squnion> (y \<squnion> !x) = top"
     by (metis assms(2) il_associative il_commutative il_idempotent)
   hence "x \<squnion> (y \<squnion> !x \<sqinter> !y) = top"
     by (simp add: assms neg_test test_import_2)
   thus ?thesis
     by (simp add: il_associative)
 qed
 
 lemma test_sup_neg_2:
   assumes "test x"
       and "test y"
     shows "(x \<squnion> y) \<sqinter> (!x \<sqinter> !y) = bot"
 proof -
   have 1: "are_complementary y (!y)"
     by (simp add: assms(2) neg_char)
   obtain z where 2: "are_complementary x z"
     using assms(1) by auto
   hence "!x = z"
     using neg_char neg_unique by blast
   thus ?thesis
     using 1 2 by (metis are_complementary_symmetric il_inf_associative neg_involutive test_import_3 test_inf_bot test_inf_commutative)
 qed
 
 lemma de_morgan_1:
   assumes "test x"
       and "test y"
       and "test (x \<sqinter> y)"
     shows "!(x \<sqinter> y) = !x \<squnion> !y"
 proof (rule order.antisym)
   have 1: "test (!(x \<sqinter> y))"
     by (simp add: assms neg_test)
   have "x \<le> (x \<sqinter> y) \<squnion> !y"
     by (metis (full_types) assms il_commutative neg_char test_shunting test_shunting_bot_eq)
   hence "x \<sqinter> !(x \<sqinter> y) \<le> !y"
     using 1 by (simp add: assms(1,3) neg_involutive test_shunting)
   hence "!(x \<sqinter> y) \<sqinter> x \<le> !y"
     using 1 by (metis assms(1) test_inf_commutative)
   thus "!(x \<sqinter> y) \<le> !x \<squnion> !y"
     using 1 assms(1) test_shunting by blast
   have 2: "!x \<le> !(x \<sqinter> y)"
     by (simp add: assms neg_antitone test_inf_right_below)
   have "!y \<le> !(x \<sqinter> y)"
     by (simp add: assms neg_antitone test_inf_left_below)
   thus "!x \<squnion> !y \<le> !(x \<sqinter> y)"
     using 2 by (metis il_associative il_less_eq)
 qed
 
 lemma de_morgan_2:
   assumes "test x"
       and "test y"
       and "test (x \<squnion> y)"
     shows "!(x \<squnion> y) = !x \<sqinter> !y"
 proof (rule order.antisym)
   have 1: "!(x \<squnion> y) \<le> !x"
     by (metis assms il_inf_left_unit il_sub_inf_left_isotone neg_antitone test_absorb_3 test_sub_identity)
   have "!(x \<squnion> y) \<le> !y"
     by (metis assms il_commutative il_inf_left_unit il_sub_inf_left_isotone neg_antitone test_absorb_3 test_sub_identity)
   thus "!(x \<squnion> y) \<le> !x \<sqinter> !y"
     using 1 by (simp add: assms neg_test test_inf)
   have "top \<le> x \<squnion> y \<squnion> !(x \<squnion> y)"
     by (simp add: assms(3) neg_char)
   hence "top \<sqinter> !x \<le> y \<squnion> !(x \<squnion> y)"
     by (smt assms(1) assms(3) il_commutative il_inf_right_dist_sup il_inf_right_unit il_sub_inf_right_isotone il_unit_bot neg_char test_sub_identity)
   thus "!x \<sqinter> !y \<le> !(x \<squnion> y)"
     by (simp add: assms(1) assms(2) neg_involutive neg_test test_shunting)
 qed
 
 lemma test_inf_closed_sup_complement:
   assumes "test x"
       and "test y"
       and "\<forall>u v . test u \<and> test v \<longrightarrow> test (u \<sqinter> v)"
     shows "!x \<sqinter> !y \<sqinter> (x \<squnion> y) = bot"
 proof -
   have 1: "!(!x \<sqinter> !y) = x \<squnion> y"
     by (simp add: assms de_morgan_1 neg_involutive neg_test)
   have "test (!(!x \<sqinter> !y))"
     by (metis assms neg_test)
   thus ?thesis
     using 1 by (metis assms(1,2) de_morgan_2 neg_char)
 qed
 
 lemma test_sup_complement_sup_closed:
   assumes "test x"
       and "test y"
       and "\<forall>u v . test u \<and> test v \<longrightarrow> !u \<sqinter> !v \<sqinter> (u \<squnion> v) = bot"
     shows "test (x \<squnion> y)"
   by (meson assms test_sup_neg_1 test_sup_neg_2)
 
 lemma test_inf_closed_sup_closed:
   assumes "test x"
       and "test y"
       and "\<forall>u v . test u \<and> test v \<longrightarrow> test (u \<sqinter> v)"
     shows "test (x \<squnion> y)"
   using assms test_inf_closed_sup_complement test_sup_complement_sup_closed by simp
 
 end
 
 subsection \<open>Prepredomain Semirings\<close>
 
 class dom =
   fixes d :: "'a \<Rightarrow> 'a"
 
 class ppd_semiring = il_semiring + dom +
   assumes d_closed: "test (d x)"
   assumes d1: "x \<le> d x \<sqinter> x"
 begin
 
 lemma d_sub_identity:
   "d x \<le> top"
   using d_closed test_sub_identity by blast
 
 lemma d1_eq:
   "x = d x \<sqinter> x"
 proof -
   have "x = (d x \<squnion> top) \<sqinter> x"
     using d_sub_identity il_less_eq by auto
   thus ?thesis
     using d1 il_commutative il_inf_right_dist_sup il_less_eq by force
 qed
 
 lemma d_increasing_sub_identity:
   "x \<le> top \<Longrightarrow> x \<le> d x"
   by (metis d1_eq il_inf_right_unit il_sub_inf_right_isotone)
 
 lemma d_top:
   "d top = top"
   by (simp add: d_increasing_sub_identity d_sub_identity dual_order.antisym)
 
 lemma d_bot_only:
   "d x = bot \<Longrightarrow> x = bot"
   by (metis d1_eq il_sub_inf_left_zero)
 
 lemma d_strict: "d bot \<le> bot" nitpick [expect=genuine] oops
 lemma d_isotone_var: "d x \<le> d (x \<squnion> y)" nitpick [expect=genuine] oops
 lemma d_fully_strict: "d x = bot \<longleftrightarrow> x = bot" nitpick [expect=genuine] oops
 lemma test_d_fixpoint: "test x \<Longrightarrow> d x = x" nitpick [expect=genuine] oops
 
 end
 
 subsection \<open>Predomain Semirings\<close>
 
 class pd_semiring = ppd_semiring +
   assumes d2: "test p \<Longrightarrow> d (p \<sqinter> x) \<le> p"
 begin
 
 lemma d_strict:
   "d bot \<le> bot"
   using bot_test d2 by fastforce
 
 lemma d_strict_eq:
   "d bot = bot"
   using d_strict il_bot_unit il_less_eq by auto
 
 lemma test_d_fixpoint:
   "test x \<Longrightarrow> d x = x"
   by (metis order.antisym d1_eq d2 test_inf_idempotent test_inf_right_below)
 
 lemma d_surjective:
   "test x \<Longrightarrow> \<exists>y . d y = x"
   using test_d_fixpoint by blast
 
 lemma test_d_fixpoint_iff:
   "test x \<longleftrightarrow> d x = x"
   by (metis d_closed test_d_fixpoint)
 
 lemma d_surjective_iff:
   "test x \<longleftrightarrow> (\<exists>y . d y = x)"
   using d_surjective d_closed by blast
 
 lemma tests_d_range:
   "tests = range d"
   using tests_def image_def d_surjective_iff by auto
 
 lemma llp:
   assumes "test y"
     shows "d x \<le> y \<longleftrightarrow> x \<le> y \<sqinter> x"
   by (metis assms d1_eq d2 order.eq_iff il_sub_inf_left_isotone test_inf_left_below)
 
 lemma gla:
   assumes "test y"
     shows "y \<le> !(d x) \<longleftrightarrow> y \<sqinter> x \<le> bot"
 proof -
   obtain ad where 1: "\<forall>x. are_complementary (d x) (ad x)"
     using d_closed by moura
   hence 2: "\<forall>x y. d (d y \<sqinter> x) \<le> d y"
     using d2 by blast
   have 3: "\<forall>x. ad x \<sqinter> x = bot"
     using 1 by (metis d1_eq il_inf_associative il_sub_inf_left_zero)
   have 4: "\<forall>x y. d y \<sqinter> x \<squnion> ad y \<sqinter> x = top \<sqinter> x"
     using 1 by (metis il_inf_right_dist_sup)
   have 5: "\<forall>x y z. z \<sqinter> y \<le> x \<sqinter> y \<or> (z \<squnion> x) \<sqinter> y \<noteq> x \<sqinter> y"
     by (simp add: il_inf_right_dist_sup il_less_eq)
   have 6: "\<forall>x. !(d x) = ad x"
     using 1 neg_char neg_unique by blast
   have 7: "\<forall>x. top \<sqinter> x = x"
     by auto
   hence "\<forall>x. y \<sqinter> x \<squnion> !y \<sqinter> x = x"
     by (metis assms il_inf_right_dist_sup neg_char)
   thus ?thesis
     using 1 2 3 4 5 6 7 by (metis assms d1_eq il_commutative il_less_eq test_d_fixpoint)
 qed
 
 lemma gla_var:
   "test y \<Longrightarrow> y \<sqinter> d x \<le> bot \<longleftrightarrow> y \<sqinter> x \<le> bot"
   using gla d_closed il_bot_unit test_shunting by auto
 
 lemma llp_var:
   assumes "test y"
     shows "y \<le> !(d x) \<longleftrightarrow> x \<le> !y \<sqinter> x"
   apply (rule iffI)
   apply (metis (no_types, opaque_lifting) assms gla Least_equality il_inf_left_unit il_inf_right_dist_sup il_less_eq il_unit_bot order.refl neg_char)
   by (metis assms gla gla_var llp il_commutative il_sub_inf_right_isotone neg_char)
 
 lemma d_idempotent:
   "d (d x) = d x"
   using d_closed test_d_fixpoint_iff by auto
 
 lemma d_neg:
   "test x \<Longrightarrow> d (!x) = !x"
   using il_commutative neg_char test_d_fixpoint_iff by fastforce
 
 lemma d_fully_strict:
   "d x = bot \<longleftrightarrow> x = bot"
   using d_strict_eq d_bot_only by blast
 
 lemma d_ad_comp:
   "!(d x) \<sqinter> x = bot"
 proof -
   have "\<forall>x. !(d x) \<sqinter> d x = bot"
     by (simp add: d_closed neg_char)
   thus ?thesis
     by (metis d1_eq il_inf_associative il_sub_inf_left_zero)
 qed
 
 lemma d_isotone:
   assumes "x \<le> y"
     shows "d x \<le> d y"
 proof -
   obtain ad where 1: "\<forall>x. are_complementary (d x) (ad x)"
     using d_closed by moura
   hence "ad y \<sqinter> x \<le> bot"
     by (metis assms d1_eq il_inf_associative il_sub_inf_left_zero il_sub_inf_right_isotone)
   thus ?thesis
     using 1 by (metis d2 il_bot_unit il_inf_left_unit il_inf_right_dist_sup il_less_eq)
 qed
 
 lemma d_isotone_var:
   "d x \<le> d (x \<squnion> y)"
   using d_isotone il_associative il_less_eq by auto
 
 lemma d3_conv:
   "d (x \<sqinter> y) \<le> d (x \<sqinter> d y)"
   by (metis (mono_tags, opaque_lifting) d1_eq d2 d_closed il_inf_associative)
 
 lemma d_test_inf_idempotent:
   "d x \<sqinter> d x = d x"
   by (metis d_idempotent d1_eq)
 
 lemma d_test_inf_closed:
   assumes "test x"
       and "test y"
     shows "d (x \<sqinter> y) = x \<sqinter> y"
 proof (rule order.antisym)
   have "d (x \<sqinter> y) = d (x \<sqinter> y) \<sqinter> d (x \<sqinter> y)"
     by (simp add: d_test_inf_idempotent)
   also have "... \<le> x \<sqinter> d (x \<sqinter> y)"
     by (simp add: assms(1) d2 il_sub_inf_left_isotone)
   also have "... \<le> x \<sqinter> y"
     by (metis assms d_isotone il_sub_inf_right_isotone test_inf_left_below test_d_fixpoint)
   finally show "d (x \<sqinter> y) \<le> x \<sqinter> y"
     .
   show "x \<sqinter> y \<le> d (x \<sqinter> y)"
     using assms d_increasing_sub_identity dual_order.trans test_inf_left_below test_sub_identity by blast
 qed
 
 lemma test_inf_closed:
   "test x \<Longrightarrow> test y \<Longrightarrow> test (x \<sqinter> y)"
   using d_test_inf_closed test_d_fixpoint_iff by simp
 
 lemma test_sup_closed:
   "test x \<Longrightarrow> test y \<Longrightarrow> test (x \<squnion> y)"
   using test_inf_closed test_inf_closed_sup_closed by simp
 
 lemma d_export:
   assumes "test x"
     shows "d (x \<sqinter> y) = x \<sqinter> d y"
 proof (rule order.antisym)
   have 1: "d (x \<sqinter> y) \<le> x"
     by (simp add: assms d2)
   have "d (x \<sqinter> y) \<le> d y"
     by (metis assms d_isotone_var il_inf_left_unit il_inf_right_dist_sup)
   thus "d (x \<sqinter> y) \<le> x \<sqinter> d y"
     using 1 by (metis assms d_idempotent llp dual_order.trans il_sub_inf_right_isotone)
   have "y = (!x \<sqinter> y) \<squnion> (x \<sqinter> y)"
     by (metis assms il_commutative il_inf_left_unit il_inf_right_dist_sup neg_char)
   also have "... = (!x \<sqinter> y) \<squnion> (d (x \<sqinter> y) \<sqinter> x \<sqinter> y)"
     by (metis d1_eq il_inf_associative)
   also have "... = (!x \<sqinter> y) \<squnion> (d (x \<sqinter> y) \<sqinter> y)"
     using 1 by (smt calculation d1_eq il_associative il_commutative il_inf_associative il_inf_right_dist_sup il_less_eq il_sub_inf_right_isotone_var)
   also have "... = (!x \<squnion> d (x \<sqinter> y)) \<sqinter> y"
     by (simp add: il_inf_right_dist_sup)
   finally have "y \<le> (!x \<squnion> d (x \<sqinter> y)) \<sqinter> y"
     by simp
   hence "d y \<le> !x \<squnion> d (x \<sqinter> y)"
     using assms llp test_sup_closed neg_test d_closed by simp
   hence "d y \<sqinter> x \<le> d (x \<sqinter> y)"
     by (simp add: assms d_closed test_shunting)
   thus "x \<sqinter> d y \<le> d (x \<sqinter> y)"
     by (metis assms d_closed test_inf_commutative)
 qed
 
 lemma test_inf_left_dist_sup:
   assumes "test x"
       and "test y"
       and "test z"
     shows "x \<sqinter> (y \<squnion> z) = (x \<sqinter> y) \<squnion> (x \<sqinter> z)"
 proof -
   have "x \<sqinter> (y \<squnion> z) = (y \<squnion> z) \<sqinter> x"
     using assms test_sup_closed test_inf_commutative by smt
   also have "... = (y \<sqinter> x) \<squnion> (z \<sqinter> x)"
     using il_inf_right_dist_sup by simp
   also have "... = (x \<sqinter> y) \<squnion> (x \<sqinter> z)"
     using assms test_sup_closed test_inf_commutative by smt
   finally show ?thesis
     .
 qed
 
 lemma "!x \<squnion> !y = !(!(!x \<squnion> !y))" nitpick [expect=genuine] oops
 lemma "d x = !(!x)" nitpick [expect=genuine] oops
 
 sublocale subset_boolean_algebra where uminus = "\<lambda> x . !(d x)"
 proof
   show "\<And>x y z. !(d x) \<squnion> (!(d y) \<squnion> !(d z)) = !(d x) \<squnion> !(d y) \<squnion> !(d z)"
     using il_associative by blast
   show "\<And>x y. !(d x) \<squnion> !(d y) = !(d y) \<squnion> !(d x)"
     by (simp add: il_commutative)
   show "\<And>x y. !(d x) \<squnion> !(d y) = !(d (!(d (!(d x) \<squnion> !(d y)))))"
   proof -
     fix x y
     have "test (!(d x)) \<and> test (!(d y))"
       by (simp add: d_closed neg_test)
     hence "test (!(d x) \<squnion> !(d y))"
       by (simp add: test_sup_closed)
     thus "!(d x) \<squnion> !(d y) = !(d (!(d (!(d x) \<squnion> !(d y)))))"
       by (simp add: d_neg neg_involutive test_d_fixpoint)
   qed
   show "\<And>x y. !(d x) = !(d (!(d (!(d x))) \<squnion> !(d y))) \<squnion> !(d (!(d (!(d x))) \<squnion> !(d (!(d y)))))"
   proof -
     fix x y
     have "!(d (!(d (!(d x))) \<squnion> !(d y))) \<squnion> !(d (!(d (!(d x))) \<squnion> !(d (!(d y))))) = !(d x \<squnion> !(d y)) \<squnion> !(d x \<squnion> d y)"
       using d_closed neg_test test_sup_closed neg_involutive test_d_fixpoint by auto
     also have "... = (!(d x) \<sqinter> d y) \<squnion> (!(d x) \<sqinter> !(d y))"
       using d_closed neg_test test_sup_closed neg_involutive de_morgan_2 by auto
     also have "... = !(d x) \<sqinter> (d y \<squnion> !(d y))"
       using d_closed neg_test test_inf_left_dist_sup by auto
     also have "... = !(d x) \<sqinter> top"
       by (simp add: neg_char d_closed)
     finally show "!(d x) = !(d (!(d (!(d x))) \<squnion> !(d y))) \<squnion> !(d (!(d (!(d x))) \<squnion> !(d (!(d y)))))"
       by simp
   qed
 qed
 
 lemma d_dist_sup:
   "d (x \<squnion> y) = d x \<squnion> d y"
 proof (rule order.antisym)
   have "x \<le> d x \<sqinter> x"
     by (simp add: d1)
   also have "... \<le> (d x \<squnion> d y) \<sqinter> (x \<squnion> y)"
     using il_associative il_inf_right_dist_sup il_less_eq il_sub_inf_right_isotone by auto
   finally have 1: "x \<le> (d x \<squnion> d y) \<sqinter> (x \<squnion> y)"
     .
   have "y \<le> d y \<sqinter> y"
     by (simp add: d1)
   also have "... \<le> (d y \<squnion> d x) \<sqinter> (y \<squnion> x)"
     using il_associative il_idempotent il_inf_right_dist_sup il_less_eq il_sub_inf_right_isotone by simp
   finally have "y \<le> (d x \<squnion> d y) \<sqinter> (x \<squnion> y)"
     using il_commutative by auto
   hence "x \<squnion> y \<le> (d x \<squnion> d y) \<sqinter> (x \<squnion> y)"
     using 1 by (metis il_associative il_less_eq)
   thus "d (x \<squnion> y) \<le> d x \<squnion> d y"
     using llp test_sup_closed neg_test d_closed by simp
   show "d x \<squnion> d y \<le> d (x \<squnion> y)"
     using d_isotone_var il_associative il_commutative il_less_eq by fastforce
 qed
 
 end
 
 class pd_semiring_extended = pd_semiring + uminus +
   assumes uminus_def: "-x = !(d x)"
 begin
 
 subclass subset_boolean_algebra
   by (metis subset_boolean_algebra_axioms uminus_def ext)
 
 end
 
 subsection \<open>Domain Semirings\<close>
 
 class d_semiring = pd_semiring +
   assumes d3: "d (x \<sqinter> d y) \<le> d (x \<sqinter> y)"
 begin
 
 lemma d3_eq: "d (x \<sqinter> d y) = d (x \<sqinter> y)"
   by (simp add: order.antisym d3 d3_conv)
 
 end
 
 text \<open>
 Axioms (d1), (d2) and (d3) are independent in IL-semirings.
 \<close>
 
 context il_semiring
 begin
 
 context
   fixes d :: "'a \<Rightarrow> 'a"
   assumes d_closed: "test (d x)"
 begin
 
 context
   assumes d1: "x \<le> d x \<sqinter> x"
   assumes d2: "test p \<Longrightarrow> d (p \<sqinter> x) \<le> p"
 begin
 
 lemma d3: "d (x \<sqinter> d y) \<le> d (x \<sqinter> y)" nitpick [expect=genuine] oops
 
 end
 
 context
   assumes d1: "x \<le> d x \<sqinter> x"
   assumes d3: "d (x \<sqinter> d y) \<le> d (x \<sqinter> y)"
 begin
 
 lemma d2: "test p \<Longrightarrow> d (p \<sqinter> x) \<le> p" nitpick [expect=genuine] oops
 
 end
 
 context
   assumes d2: "test p \<Longrightarrow> d (p \<sqinter> x) \<le> p"
   assumes d3: "d (x \<sqinter> d y) \<le> d (x \<sqinter> y)"
 begin
 
 lemma d1: "x \<le> d x \<sqinter> x" nitpick [expect=genuine] oops
 
 end
 
 end
 
 end
 
 class d_semiring_var = ppd_semiring +
   assumes d3_var: "d (x \<sqinter> d y) \<le> d (x \<sqinter> y)"
   assumes d_strict_eq_var: "d bot = bot"
 begin
 
 lemma d2_var:
   assumes "test p"
     shows "d (p \<sqinter> x) \<le> p"
 proof -
   have "!p \<sqinter> p \<sqinter> x = bot"
     by (simp add: assms neg_char)
   hence "d (!p \<sqinter> p \<sqinter> x) = bot"
     by (simp add: d_strict_eq_var)
   hence "d (!p \<sqinter> d (p \<sqinter> x)) = bot"
     by (metis d3_var il_inf_associative less_eq_bot)
   hence "!p \<sqinter> d (p \<sqinter> x) = bot"
     using d_bot_only by blast
   thus ?thesis
     by (metis (no_types, opaque_lifting) assms d_sub_identity il_bot_unit il_inf_left_unit il_inf_right_dist_sup il_inf_right_unit il_sub_inf_right_isotone neg_char)
 qed
 
 subclass d_semiring
 proof
   show "\<And>p x. test p \<Longrightarrow> d (p \<sqinter> x) \<le> p"
     by (simp add: d2_var)
   show "\<And>x y. d (x \<sqinter> d y) \<le> d (x \<sqinter> y)"
     by (simp add: d3_var)
 qed
 
 end
 
 section \<open>Antidomain Semirings\<close>
 
 text \<open>
 We now develop prepreantidomain semirings, preantidomain semirings and antidomain semirings.
 See \cite{DesharnaisStruth2008b,DesharnaisStruth2008a,DesharnaisStruth2011} for related work on internal axioms for antidomain.
 \<close>
 
 subsection \<open>Prepreantidomain Semirings\<close>
 
 text \<open>Definition 20\<close>
 
 class ppa_semiring = il_semiring + uminus +
   assumes a_inf_complement_bot: "-x \<sqinter> x = bot"
   assumes a_stone[simp]: "-x \<squnion> --x = top"
 begin
 
 text \<open>Theorem 21\<close>
 
 lemma l1:
   "-top = bot"
   by (metis a_inf_complement_bot il_inf_right_unit)
 
 lemma l2:
   "-bot = top"
   by (metis l1 a_stone il_unit_bot)
 
 lemma l3:
   "-x \<le> -y \<Longrightarrow> -x \<sqinter> y = bot"
   by (metis a_inf_complement_bot il_bot_unit il_inf_right_dist_sup il_less_eq)
 
 lemma l5:
   "--x \<le> --y \<Longrightarrow> -y \<le> -x"
   by (metis (mono_tags, opaque_lifting) l3 a_stone bot_least il_bot_unit il_inf_left_unit il_inf_right_dist_sup il_inf_right_unit il_sub_inf_right_isotone sup_right_isotone)
 
 lemma l4:
   "---x = -x"
   by (metis l5 a_inf_complement_bot a_stone order.antisym bot_least il_inf_left_unit il_inf_right_dist_sup il_inf_right_unit il_sub_inf_right_isotone il_unit_bot)
 
 lemma l6:
   "-x \<sqinter> --x = bot"
   by (metis l3 l5 a_inf_complement_bot a_stone il_inf_left_unit il_inf_right_dist_sup il_inf_right_unit il_less_eq il_sub_inf_right_isotone il_unit_bot)
 
 lemma l7:
   "-x \<sqinter> -y = -y \<sqinter> -x"
   using l6 a_inf_complement_bot a_stone test_inf_commutative by blast
 
 lemma l8:
   "x \<le> --x \<sqinter> x"
   by (metis a_inf_complement_bot a_stone il_idempotent il_inf_left_unit il_inf_right_dist_sup il_less_eq il_unit_bot)
 
 sublocale ppa_ppd: ppd_semiring where d = "\<lambda>x . --x"
 proof
   show "\<And>x. test (- - x)"
     using l4 l6 by force
   show "\<And>x. x \<le> - - x \<sqinter> x"
     by (simp add: l8)
 qed
 
 (*
 The following statements have counterexamples, but they take a while to find.
 
 lemma "- x = - (- - x \<squnion> - y) \<squnion> - (- - x \<squnion> - - y)" nitpick [card=8, expect=genuine] oops
 lemma "- x \<squnion> - y = - - (- x \<squnion> - y)" nitpick [card=8, expect=genuine] oops
 *)
 
 end
 
 subsection \<open>Preantidomain Semirings\<close>
 
 text \<open>Definition 22\<close>
 
 class pa_semiring = ppa_semiring +
   assumes pad2: "--x \<le> -(-x \<sqinter> y)"
 begin
 
 text \<open>Theorem 23\<close>
 
 lemma l10:
   "-x \<sqinter> y = bot \<Longrightarrow> -x \<le> -y"
   by (metis a_stone il_inf_left_unit il_inf_right_dist_sup il_unit_bot l4 pad2)
 
 lemma l10_iff:
   "-x \<sqinter> y = bot \<longleftrightarrow> -x \<le> -y"
   using l10 l3 by blast
 
 lemma l13:
   "--(--x \<sqinter> y) \<le> --x"
   by (metis l4 l5 pad2)
 
 lemma l14:
   "-(x \<sqinter> --y) \<le> -(x \<sqinter> y)"
   by (metis il_inf_associative l4 pad2 ppa_ppd.d1_eq)
 
 lemma l9:
   "x \<le> y \<Longrightarrow> -y \<le> -x"
   by (metis l10 a_inf_complement_bot il_commutative il_less_eq il_sub_inf_right_isotone il_unit_bot)
 
 lemma l11:
   "- x \<squnion> - y = - (- - x \<sqinter> - - y)"
 proof -
   have 1: "\<And>x y . x \<le> y \<longleftrightarrow> x \<squnion> y = y"
     by (simp add: il_less_eq)
   have 4: "\<And>x y . \<not>(x \<le> y) \<or> x \<squnion> y = y"
     using 1 by metis
   have 5: "\<And>x y z . (x \<sqinter> y) \<squnion> (x \<sqinter> z) \<le> x \<sqinter> (y \<squnion> z)"
     by (simp add: il_sub_inf_right_isotone_var)
   have 6: "\<And>x y . - - x \<le> - (- x \<sqinter> y)"
     by (simp add: pad2)
   have 7: "\<And>x y z . x \<squnion> (y \<squnion> z) = (x \<squnion> y) \<squnion> z"
     by (simp add: il_associative)
   have 8: "\<And>x y z . (x \<squnion> y) \<squnion> z = x \<squnion> (y \<squnion> z)"
     using 7 by metis
   have 9: "\<And>x y . x \<squnion> y = y \<squnion> x"
     by (simp add: il_commutative)
   have 10: "\<And>x . x \<squnion> bot = x"
     by (simp add: il_bot_unit)
   have 11: "\<And>x . x \<squnion> x = x"
     by simp
   have 12: "\<And>x y z . x \<sqinter> (y \<sqinter> z) = (x \<sqinter> y) \<sqinter> z"
     by (simp add: il_inf_associative)
   have 13: "\<And>x y z . (x \<sqinter> y) \<sqinter> z = x \<sqinter> (y \<sqinter> z)"
     using 12 by metis
   have 14: "\<And>x . top \<sqinter> x = x"
     by simp
   have 15: "\<And>x . x \<sqinter> top = x"
     by simp
   have 16: "\<And>x y z . (x \<squnion> y) \<sqinter> z = (x \<sqinter> z) \<squnion> (y \<sqinter> z)"
     by (simp add: il_inf_right_dist_sup)
   have 17: "\<And>x y z . (x \<sqinter> y) \<squnion> (z \<sqinter> y) = (x \<squnion> z) \<sqinter> y"
     using 16 by metis
   have 18: "\<And>x . bot \<sqinter> x = bot"
     by simp
   have 19: "\<And>x . - x \<squnion> - - x = top"
     by simp
   have 20: "\<And>x . - x \<sqinter> x = bot"
     by (simp add: a_inf_complement_bot)
   have 23: "\<And>x y z . ((x \<sqinter> y) \<squnion> (x \<sqinter> z)) \<squnion> (x \<sqinter> (y \<squnion> z)) = x \<sqinter> (y \<squnion> z)"
     using 4 5 by metis
   have 24: "\<And>x y z . (x \<sqinter> (y \<squnion> z)) \<squnion> ((x \<sqinter> y) \<squnion> (x \<sqinter> z)) = x \<sqinter> (y \<squnion> z)"
     using 9 23 by metis
   have 25: "\<And>x y . - - x \<squnion> - (- x \<sqinter> y) = - (- x \<sqinter> y)"
     using 4 6 by metis
   have 26: "\<And>x y z . x \<squnion> (y \<squnion> z) = y \<squnion> (x \<squnion> z)"
     using 8 9 by metis
   have 27: "\<And>x y z . (x \<sqinter> y) \<squnion> ((x \<sqinter> z) \<squnion> (x \<sqinter> (y \<squnion> z))) = x \<sqinter> (y \<squnion> z)"
     using 9 24 26 by metis
   have 30: "\<And>x . bot \<squnion> x = x"
     using 9 10 by metis
   have 31: "\<And>x y . x \<squnion> (x \<squnion> y) = x \<squnion> y"
     using 8 11 by metis
   have 34: "\<And>u x y z . ((x \<squnion> y) \<sqinter> z) \<squnion> u = (x \<sqinter> z) \<squnion> ((y \<sqinter> z) \<squnion> u)"
     using 8 17 by metis
   have 35: "\<And>u x y z . (x \<sqinter> (y \<sqinter> z)) \<squnion> (u \<sqinter> z) = ((x \<sqinter> y) \<squnion> u) \<sqinter> z"
     using 13 17 by metis
   have 36: "\<And>u x y z . (x \<sqinter> y) \<squnion> (z \<sqinter> (u \<sqinter> y)) = (x \<squnion> (z \<sqinter> u)) \<sqinter> y"
     using 13 17 by metis
   have 39: "\<And>x y . - x \<squnion> (- - x \<squnion> y) = top \<squnion> y"
     using 8 19 by metis
   have 41: "\<And>x y . - x \<sqinter> (x \<sqinter> y) = bot"
     using 13 18 20 by metis
   have 42: "- top = bot"
     using 15 20 by metis
   have 43: "\<And>x y . (- x \<squnion> y) \<sqinter> x = y \<sqinter> x"
     using 17 20 30 by metis
   have 44: "\<And>x y . (x \<squnion> - y) \<sqinter> y = x \<sqinter> y"
     using 9 17 20 30 by metis
   have 46: "\<And>x . - bot \<squnion> - - x = - bot"
     using 9 20 25 by metis
   have 50: "- bot = top"
     using 19 30 42 by metis
   have 51: "\<And>x . top \<squnion> - - x = top"
     using 46 50 by metis
   have 63: "\<And>x y . x \<squnion> ((x \<sqinter> - y) \<squnion> (x \<sqinter> - - y)) = x"
     using 9 15 19 26 27 by metis
   have 66: "\<And>x y . (- (x \<squnion> y) \<sqinter> x) \<squnion> (- (x \<squnion> y) \<sqinter> y) = bot"
     using 9 20 27 30 by metis
   have 67: "\<And>x y z . (x \<sqinter> - - y) \<squnion> (x \<sqinter> - (- y \<sqinter> z)) = x \<sqinter> - (- y \<sqinter> z)"
     using 11 25 27 by metis
   have 70: "\<And>x y . x \<squnion> (x \<sqinter> - - y) = x"
     using 9 15 27 31 51 by metis
   have 82: "\<And>x . top \<squnion> - x = top"
     using 9 19 31 by metis
   have 89: "\<And>x y . x \<squnion> (- y \<sqinter> x) = x"
     using 14 17 82 by metis
   have 102: "\<And>x y z . x \<squnion> (y \<squnion> (x \<sqinter> - - z)) = y \<squnion> x"
     using 26 70 by metis
   have 104: "\<And>x y . x \<squnion> (x \<sqinter> - y) = x"
     using 9 63 102 by metis
   have 112: "\<And>x y z . (- x \<sqinter> y) \<squnion> ((- - x \<sqinter> y) \<squnion> z) = y \<squnion> z"
     using 14 19 34 by metis
   have 117: "\<And>x y z . x \<squnion> ((x \<sqinter> - y) \<squnion> z) = x \<squnion> z"
     using 8 104 by metis
   have 120: "\<And>x y z . x \<squnion> (y \<squnion> (x \<sqinter> - z)) = y \<squnion> x"
     using 26 104 by metis
   have 124: "\<And>x . - - x \<sqinter> x = x"
     using 14 19 43 by metis
   have 128: "\<And>x y . - - x \<sqinter> (x \<sqinter> y) = x \<sqinter> y"
     using 13 124 by metis
   have 131: "\<And>x . - x \<squnion> - - - x = - x"
     using 9 25 124 by metis
   have 133: "\<And>x . - - - x = - x"
     using 9 104 124 131 by metis
   have 135: "\<And>x y . - x \<squnion> - (- - x \<sqinter> y) = - (- - x \<sqinter> y)"
     using 25 133 by metis
   have 137: "\<And>x y . (- x \<squnion> y) \<sqinter> - - x = y \<sqinter> - - x"
     using 43 133 by metis
   have 145: "\<And>x y z . ((- (x \<sqinter> y) \<sqinter> x) \<squnion> z) \<sqinter> y = z \<sqinter> y"
     using 20 30 35 by metis
   have 183: "\<And>x y z . (x \<squnion> (- - (y \<sqinter> z) \<sqinter> y)) \<sqinter> z = (x \<squnion> y) \<sqinter> z"
     using 17 36 124 by metis
   have 289: "\<And>x y . - x \<squnion> - (- x \<sqinter> y) = top"
     using 25 39 82 by metis
   have 316: "\<And>x y . - (- x \<sqinter> y) \<sqinter> x = x"
     using 14 43 289 by metis
   have 317: "\<And>x y z . - (- x \<sqinter> y) \<sqinter> (x \<sqinter> z) = x \<sqinter> z"
     using 13 316 by metis
   have 320: "\<And>x y . - x \<squnion> - - (- x \<sqinter> y) = - x"
     using 9 25 316 by metis
   have 321: "\<And>x y . - - (- x \<sqinter> y) \<sqinter> x = bot"
     using 41 316 by metis
   have 374: "\<And>x y . - x \<squnion> - (x \<sqinter> y) = - (x \<sqinter> y)"
     using 25 128 133 by metis
   have 388: "\<And>x y . - (x \<sqinter> y) \<sqinter> - x = - x"
     using 128 316 by metis
   have 389: "\<And>x y . - - (x \<sqinter> y) \<sqinter> - x = bot"
     using 128 321 by metis
   have 405: "\<And>x y z . - (x \<sqinter> y) \<sqinter> (- x \<sqinter> z) = - x \<sqinter> z"
     using 13 388 by metis
   have 406: "\<And>x y z . - (x \<sqinter> (y \<sqinter> z)) \<sqinter> - (x \<sqinter> y) = - (x \<sqinter> y)"
     using 13 388 by metis
   have 420: "\<And>x y . - x \<sqinter> - - (- x \<sqinter> y) = - - (- x \<sqinter> y)"
     using 316 388 by metis
   have 422: "\<And>x y z . - - (x \<sqinter> y) \<sqinter> (- x \<sqinter> z) = bot"
     using 13 18 389 by metis
   have 758: "\<And>x y z . x \<squnion> (x \<sqinter> (- y \<sqinter> - z)) = x"
     using 13 104 117 by metis
   have 1092: "\<And>x y . - (x \<squnion> y) \<sqinter> x = bot"
     using 9 30 31 66 by metis
   have 1130: "\<And>x y z . (- (x \<squnion> y) \<squnion> z) \<sqinter> x = z \<sqinter> x"
     using 17 30 1092 by metis
   have 1156: "\<And>x y . - - x \<sqinter> - (- x \<sqinter> y) = - - x"
     using 67 104 124 133 by metis
   have 2098: "\<And>x y . - - (x \<squnion> y) \<sqinter> x = x"
     using 14 19 1130 by metis
   have 2125: "\<And>x y . - - (x \<squnion> y) \<sqinter> y = y"
     using 9 2098 by metis
   have 2138: "\<And>x y . - x \<squnion> - - (x \<squnion> y) = top"
     using 9 289 2098 by metis
   have 2139: "\<And>x y . - x \<sqinter> - (x \<squnion> y) = - (x \<squnion> y)"
     using 316 2098 by metis
   have 2192: "\<And>x y . - - x \<sqinter> (- y \<sqinter> x) = - y \<sqinter> x"
     using 89 2125 by metis
   have 2202: "\<And>x y . - x \<squnion> - - (y \<squnion> x) = top"
     using 9 289 2125 by metis
   have 2344: "\<And>x y . - (- x \<sqinter> y) \<squnion> - - y = top"
     using 89 2202 by metis
   have 2547: "\<And>x y z . - x \<squnion> ((- - x \<sqinter> - y) \<squnion> z) = - x \<squnion> (- y \<squnion> z)"
     using 112 117 by metis
   have 3023: "\<And>x y . - x \<squnion> - (- y \<sqinter> - x) = top"
     using 9 133 2344 by metis
   have 3134: "\<And>x y . - (- x \<sqinter> - y) \<sqinter> y = y"
     using 14 43 3023 by metis
   have 3135: "\<And>x y . - x \<sqinter> (- y \<sqinter> - x) = - y \<sqinter> - x"
     using 14 44 3023 by metis
   have 3962: "\<And>x y . - - (x \<squnion> y) \<sqinter> - - x = - - x"
     using 14 137 2138 by metis
   have 5496: "\<And>x y z . - - (x \<sqinter> y) \<sqinter> - (x \<squnion> z) = bot"
     using 422 2139 by metis
   have 9414: "\<And>x y . - - (- x \<sqinter> y) \<sqinter> y = - x \<sqinter> y"
     using 9 104 183 320 by metis
   have 9520: "\<And>x y z . - - (- x \<sqinter> y) \<sqinter> - - (x \<sqinter> z) = bot"
     using 374 5496 by metis
   have 11070: "\<And>x y z . - (- - x \<sqinter> y) \<squnion> (- x \<sqinter> - z) = - (- - x \<sqinter> y)"
     using 317 758 by metis
   have 12371: "\<And>x y . - x \<sqinter> - (- - x \<sqinter> y) = - x"
     using 133 1156 by metis
   have 12377: "\<And>x y . - x \<sqinter> - (x \<sqinter> y) = - x"
     using 128 133 1156 by metis
   have 12384: "\<And>x y . - (x \<squnion> y) \<sqinter> - y = - (x \<squnion> y)"
     using 133 1156 2125 by metis
   have 12394: "\<And>x y . - - (- x \<sqinter> - y) = - x \<sqinter> - y"
     using 1156 3134 9414 by metis
   have 12640: "\<And>x y . - x \<sqinter> - (- y \<sqinter> x) = - x"
     using 89 12384 by metis
   have 24648: "\<And>x y . (- x \<sqinter> - y) \<squnion> - (- x \<sqinter> - y) = top"
     using 19 12394 by metis
   have 28270: "\<And>x y z . - - (x \<sqinter> y) \<squnion> - (- x \<sqinter> z) = - (- x \<sqinter> z)"
     using 374 405 by metis
   have 28339: "\<And>x y . - (- - (x \<sqinter> y) \<sqinter> x) = - (x \<sqinter> y)"
     using 124 406 12371 by metis
   have 28423: "\<And>x y . - (- x \<sqinter> - y) = - (- y \<sqinter> - x)"
     using 13 3135 12394 28339 by metis
   have 28487: "\<And>x y . - x \<sqinter> - y = - y \<sqinter> - x"
     using 2098 3962 12394 28423 by metis
   have 52423: "\<And>x y . - (- x \<sqinter> - (- x \<sqinter> y)) \<sqinter> y = y"
     using 14 145 24648 28487 by metis
   have 52522: "\<And>x y . - x \<sqinter> - (- x \<sqinter> y) = - x \<sqinter> - y"
     using 13 12377 12394 12640 28487 52423 by metis
   have 61103: "\<And>x y z . - (- - x \<sqinter> y) \<squnion> z = - x \<squnion> (- y \<squnion> z)"
     using 112 2547 12371 52522 by metis
   have 61158: "\<And>x y . - - (- x \<sqinter> y) = - x \<sqinter> - - y"
     using 420 52522 by metis
   have 61231: "\<And>x y z . - x \<sqinter> (- - y \<sqinter> - (x \<sqinter> z)) = - x \<sqinter> - - y"
     using 13 15 50 133 9520 52522 61158 by metis
   have 61313: "\<And>x y . - x \<squnion> - y = - (- - y \<sqinter> x)"
     using 120 11070 61103 by metis
   have 61393: "\<And>x y . - (- x \<sqinter> - - y) = - (- x \<sqinter> y)"
     using 13 28270 61158 61231 61313 by metis
   have 61422: "\<And>x y . - (- - x \<sqinter> y) = - (- - y \<sqinter> x)"
     using 13 135 2192 61158 61313 by metis
   show ?thesis
     using 61313 61393 61422 by metis
 qed
 
 lemma l12:
   "- x \<sqinter> - y = - (x \<squnion> y)"
 proof -
   have 1: "\<And>x y . x \<le> y \<longleftrightarrow> x \<squnion> y = y"
     by (simp add: il_less_eq)
   have 4: "\<And>x y . \<not>(x \<le> y) \<or> x \<squnion> y = y"
     using 1 by metis
   have 5: "\<And>x y z . (x \<sqinter> y) \<squnion> (x \<sqinter> z) \<le> x \<sqinter> (y \<squnion> z)"
     by (simp add: il_sub_inf_right_isotone_var)
   have 6: "\<And>x y . - - x \<le> - (- x \<sqinter> y)"
     by (simp add: pad2)
   have 7: "\<And>x y z . x \<squnion> (y \<squnion> z) = (x \<squnion> y) \<squnion> z"
     by (simp add: il_associative)
   have 8: "\<And>x y z . (x \<squnion> y) \<squnion> z = x \<squnion> (y \<squnion> z)"
     using 7 by metis
   have 9: "\<And>x y . x \<squnion> y = y \<squnion> x"
     by (simp add: il_commutative)
   have 10: "\<And>x . x \<squnion> bot = x"
     by (simp add: il_bot_unit)
   have 11: "\<And>x . x \<squnion> x = x"
     by simp
   have 12: "\<And>x y z . x \<sqinter> (y \<sqinter> z) = (x \<sqinter> y) \<sqinter> z"
     by (simp add: il_inf_associative)
   have 13: "\<And>x y z . (x \<sqinter> y) \<sqinter> z = x \<sqinter> (y \<sqinter> z)"
     using 12 by metis
   have 14: "\<And>x . top \<sqinter> x = x"
     by simp
   have 15: "\<And>x . x \<sqinter> top = x"
     by simp
   have 16: "\<And>x y z . (x \<squnion> y) \<sqinter> z = (x \<sqinter> z) \<squnion> (y \<sqinter> z)"
     by (simp add: il_inf_right_dist_sup)
   have 17: "\<And>x y z . (x \<sqinter> y) \<squnion> (z \<sqinter> y) = (x \<squnion> z) \<sqinter> y"
     using 16 by metis
   have 18: "\<And>x . bot \<sqinter> x = bot"
     by simp
   have 19: "\<And>x . - x \<squnion> - - x = top"
     by simp
   have 20: "\<And>x . - x \<sqinter> x = bot"
     by (simp add: a_inf_complement_bot)
   have 22: "\<And>x y z . ((x \<sqinter> y) \<squnion> (x \<sqinter> z)) \<squnion> (x \<sqinter> (y \<squnion> z)) = x \<sqinter> (y \<squnion> z)"
     using 4 5 by metis
   have 23: "\<And>x y z . (x \<sqinter> (y \<squnion> z)) \<squnion> ((x \<sqinter> y) \<squnion> (x \<sqinter> z)) = x \<sqinter> (y \<squnion> z)"
     using 9 22 by metis
   have 24: "\<And>x y . - - x \<squnion> - (- x \<sqinter> y) = - (- x \<sqinter> y)"
     using 4 6 by metis
   have 25: "\<And>x y z . x \<squnion> (y \<squnion> z) = y \<squnion> (x \<squnion> z)"
     using 8 9 by metis
   have 26: "\<And>x y z . (x \<sqinter> y) \<squnion> ((x \<sqinter> z) \<squnion> (x \<sqinter> (y \<squnion> z))) = x \<sqinter> (y \<squnion> z)"
     using 9 23 25 by metis
   have 29: "\<And>x . bot \<squnion> x = x"
     using 9 10 by metis
   have 30: "\<And>x y . x \<squnion> (x \<squnion> y) = x \<squnion> y"
     using 8 11 by metis
   have 32: "\<And>x y . x \<squnion> (y \<squnion> x) = y \<squnion> x"
     using 8 9 11 by metis
   have 33: "\<And>u x y z . ((x \<squnion> y) \<sqinter> z) \<squnion> u = (x \<sqinter> z) \<squnion> ((y \<sqinter> z) \<squnion> u)"
     using 8 17 by metis
   have 34: "\<And>u x y z . (x \<sqinter> (y \<sqinter> z)) \<squnion> (u \<sqinter> z) = ((x \<sqinter> y) \<squnion> u) \<sqinter> z"
     using 13 17 by metis
   have 35: "\<And>u x y z . (x \<sqinter> y) \<squnion> (z \<sqinter> (u \<sqinter> y)) = (x \<squnion> (z \<sqinter> u)) \<sqinter> y"
     using 13 17 by metis
   have 36: "\<And>x y . (top \<squnion> x) \<sqinter> y = y \<squnion> (x \<sqinter> y)"
     using 14 17 by metis
   have 37: "\<And>x y . (x \<squnion> top) \<sqinter> y = y \<squnion> (x \<sqinter> y)"
     using 9 14 17 by metis
   have 38: "\<And>x y . - x \<squnion> (- - x \<squnion> y) = top \<squnion> y"
     using 8 19 by metis
   have 40: "\<And>x y . - x \<sqinter> (x \<sqinter> y) = bot"
     using 13 18 20 by metis
   have 41: "- top = bot"
     using 15 20 by metis
   have 42: "\<And>x y . (- x \<squnion> y) \<sqinter> x = y \<sqinter> x"
     using 17 20 29 by metis
   have 43: "\<And>x y . (x \<squnion> - y) \<sqinter> y = x \<sqinter> y"
     using 9 17 20 29 by metis
   have 45: "\<And>x . - bot \<squnion> - - x = - bot"
     using 9 20 24 by metis
   have 46: "\<And>u x y z . (x \<sqinter> y) \<squnion> (z \<squnion> (u \<sqinter> y)) = z \<squnion> ((x \<squnion> u) \<sqinter> y)"
     using 17 25 by metis
   have 47: "\<And>x y . - x \<squnion> (y \<squnion> - - x) = y \<squnion> top"
     using 19 25 by metis
   have 49: "- bot = top"
     using 19 29 41 by metis
   have 50: "\<And>x . top \<squnion> - - x = top"
     using 45 49 by metis
   have 54: "\<And>u x y z . (x \<sqinter> y) \<squnion> ((x \<sqinter> z) \<squnion> ((x \<sqinter> (y \<squnion> z)) \<squnion> u)) = (x \<sqinter> (y \<squnion> z)) \<squnion> u"
     using 8 26 by metis
   have 58: "\<And>u x y z . (x \<sqinter> (y \<sqinter> z)) \<squnion> ((x \<sqinter> (y \<sqinter> u)) \<squnion> (x \<sqinter> (y \<sqinter> (z \<squnion> u)))) = x \<sqinter> (y \<sqinter> (z \<squnion> u))"
     using 13 26 by metis
   have 60: "\<And>x y . x \<squnion> ((x \<sqinter> y) \<squnion> (x \<sqinter> (y \<squnion> top))) = x \<sqinter> (y \<squnion> top)"
     using 15 25 26 by metis
   have 62: "\<And>x y . x \<squnion> ((x \<sqinter> - y) \<squnion> (x \<sqinter> - - y)) = x"
     using 9 15 19 25 26 by metis
   have 65: "\<And>x y . (- (x \<squnion> y) \<sqinter> x) \<squnion> (- (x \<squnion> y) \<sqinter> y) = bot"
     using 9 20 26 29 by metis
   have 66: "\<And>x y z . (x \<sqinter> - - y) \<squnion> (x \<sqinter> - (- y \<sqinter> z)) = x \<sqinter> - (- y \<sqinter> z)"
     using 11 24 26 by metis
   have 69: "\<And>x y . x \<squnion> (x \<sqinter> - - y) = x"
     using 9 15 26 30 50 by metis
   have 81: "\<And>x . top \<squnion> - x = top"
     using 9 19 30 by metis
   have 82: "\<And>x y z . (x \<sqinter> y) \<squnion> (x \<sqinter> (y \<squnion> z)) = x \<sqinter> (y \<squnion> z)"
     using 11 26 30 by metis
   have 83: "\<And>x y . x \<squnion> (x \<sqinter> (y \<squnion> top)) = x \<sqinter> (y \<squnion> top)"
     using 60 82 by metis
   have 88: "\<And>x y . x \<squnion> (- y \<sqinter> x) = x"
     using 14 17 81 by metis
   have 89: "\<And>x y . top \<squnion> (x \<squnion> - y) = x \<squnion> top"
     using 25 81 by metis
   have 91: "\<And>x y z . x \<squnion> (y \<squnion> (z \<squnion> x)) = y \<squnion> (z \<squnion> x)"
     using 8 32 by metis
   have 94: "\<And>x y z . x \<squnion> (y \<squnion> (- z \<sqinter> x)) = y \<squnion> x"
     using 25 88 by metis
   have 101: "\<And>x y z . x \<squnion> (y \<squnion> (x \<sqinter> - - z)) = y \<squnion> x"
     using 25 69 by metis
   have 102: "\<And>x . x \<squnion> (x \<sqinter> bot) = x"
     using 41 49 69 by metis
   have 103: "\<And>x y . x \<squnion> (x \<sqinter> - y) = x"
     using 9 62 101 by metis
   have 109: "\<And>x y . x \<squnion> (y \<squnion> (x \<sqinter> bot)) = y \<squnion> x"
     using 25 102 by metis
   have 111: "\<And>x y z . (- x \<sqinter> y) \<squnion> ((- - x \<sqinter> y) \<squnion> z) = y \<squnion> z"
     using 14 19 33 by metis
   have 116: "\<And>x y z . x \<squnion> ((x \<sqinter> - y) \<squnion> z) = x \<squnion> z"
     using 8 103 by metis
   have 119: "\<And>x y z . x \<squnion> (y \<squnion> (x \<sqinter> - z)) = y \<squnion> x"
     using 25 103 by metis
   have 123: "\<And>x . - - x \<sqinter> x = x"
     using 14 19 42 by metis
   have 127: "\<And>x y . - - x \<sqinter> (x \<sqinter> y) = x \<sqinter> y"
     using 13 123 by metis
   have 130: "\<And>x . - x \<squnion> - - - x = - x"
     using 9 24 123 by metis
   have 132: "\<And>x . - - - x = - x"
     using 9 103 123 130 by metis
   have 134: "\<And>x y . - x \<squnion> - (- - x \<sqinter> y) = - (- - x \<sqinter> y)"
     using 24 132 by metis
   have 136: "\<And>x y . (- x \<squnion> y) \<sqinter> - - x = y \<sqinter> - - x"
     using 42 132 by metis
   have 138: "\<And>x . - x \<sqinter> - x = - x"
     using 123 132 by metis
   have 144: "\<And>x y z . ((- (x \<sqinter> y) \<sqinter> x) \<squnion> z) \<sqinter> y = z \<sqinter> y"
     using 20 29 34 by metis
   have 157: "\<And>x y . (- x \<squnion> y) \<sqinter> - x = (top \<squnion> y) \<sqinter> - x"
     using 17 36 138 by metis
   have 182: "\<And>x y z . (x \<squnion> (- - (y \<sqinter> z) \<sqinter> y)) \<sqinter> z = (x \<squnion> y) \<sqinter> z"
     using 17 35 123 by metis
   have 288: "\<And>x y . - x \<squnion> - (- x \<sqinter> y) = top"
     using 24 38 81 by metis
   have 315: "\<And>x y . - (- x \<sqinter> y) \<sqinter> x = x"
     using 14 42 288 by metis
   have 316: "\<And>x y z . - (- x \<sqinter> y) \<sqinter> (x \<sqinter> z) = x \<sqinter> z"
     using 13 315 by metis
   have 319: "\<And>x y . - x \<squnion> - - (- x \<sqinter> y) = - x"
     using 9 24 315 by metis
   have 320: "\<And>x y . - - (- x \<sqinter> y) \<sqinter> x = bot"
     using 40 315 by metis
   have 373: "\<And>x y . - x \<squnion> - (x \<sqinter> y) = - (x \<sqinter> y)"
     using 24 127 132 by metis
   have 387: "\<And>x y . - (x \<sqinter> y) \<sqinter> - x = - x"
     using 127 315 by metis
   have 388: "\<And>x y . - - (x \<sqinter> y) \<sqinter> - x = bot"
     using 127 320 by metis
   have 404: "\<And>x y z . - (x \<sqinter> y) \<sqinter> (- x \<sqinter> z) = - x \<sqinter> z"
     using 13 387 by metis
   have 405: "\<And>x y z . - (x \<sqinter> (y \<sqinter> z)) \<sqinter> - (x \<sqinter> y) = - (x \<sqinter> y)"
     using 13 387 by metis
   have 419: "\<And>x y . - x \<sqinter> - - (- x \<sqinter> y) = - - (- x \<sqinter> y)"
     using 315 387 by metis
   have 420: "\<And>x y . - - x \<sqinter> - - (x \<sqinter> y) = - - (x \<sqinter> y)"
     using 387 by metis
   have 421: "\<And>x y z . - - (x \<sqinter> y) \<sqinter> (- x \<sqinter> z) = bot"
     using 13 18 388 by metis
   have 536: "\<And>x y . (x \<squnion> - - y) \<sqinter> y = (x \<squnion> top) \<sqinter> y"
     using 42 47 by metis
   have 662: "\<And>u x y z . (x \<sqinter> y) \<squnion> ((x \<sqinter> (z \<squnion> y)) \<squnion> u) = (x \<sqinter> (z \<squnion> y)) \<squnion> u"
     using 9 32 54 by metis
   have 705: "\<And>u x y z . (x \<sqinter> (y \<squnion> z)) \<squnion> ((x \<sqinter> (y \<squnion> (z \<sqinter> bot))) \<squnion> u) = (x \<sqinter> (y \<squnion> z)) \<squnion> u"
     using 25 54 109 662 by metis
   have 755: "\<And>x y z . (x \<sqinter> - y) \<squnion> (z \<squnion> x) = z \<squnion> x"
     using 32 91 116 by metis
   have 757: "\<And>x y z . x \<squnion> (x \<sqinter> (- y \<sqinter> - z)) = x"
     using 13 103 116 by metis
   have 930: "\<And>x y z . (- (x \<sqinter> (y \<squnion> z)) \<sqinter> (x \<sqinter> y)) \<squnion> (- (x \<sqinter> (y \<squnion> z)) \<sqinter> (x \<sqinter> z)) = bot"
     using 9 20 29 58 by metis
   have 1091: "\<And>x y . - (x \<squnion> y) \<sqinter> x = bot"
     using 9 29 30 65 by metis
   have 1092: "\<And>x y . - (x \<squnion> y) \<sqinter> y = bot"
     using 29 30 65 1091 by metis
   have 1113: "\<And>u x y z . - (x \<squnion> ((y \<squnion> z) \<sqinter> u)) \<sqinter> (x \<squnion> (z \<sqinter> u)) = bot"
     using 29 46 65 1091 by metis
   have 1117: "\<And>x y z . - (x \<squnion> y) \<sqinter> (x \<squnion> (- z \<sqinter> y)) = bot"
     using 29 65 94 1092 by metis
   have 1128: "\<And>x y z . - (x \<squnion> (y \<squnion> z)) \<sqinter> (x \<squnion> y) = bot"
     using 8 1091 by metis
   have 1129: "\<And>x y z . (- (x \<squnion> y) \<squnion> z) \<sqinter> x = z \<sqinter> x"
     using 17 29 1091 by metis
   have 1155: "\<And>x y . - - x \<sqinter> - (- x \<sqinter> y) = - - x"
     using 66 103 123 132 by metis
   have 1578: "\<And>x y z . - (x \<sqinter> (y \<squnion> z)) \<sqinter> (x \<sqinter> y) = bot"
     using 82 1091 by metis
   have 1594: "\<And>x y z . - (x \<sqinter> (y \<squnion> z)) \<sqinter> (x \<sqinter> z) = bot"
     using 29 930 1578 by metis
   have 2094: "\<And>x y z . - (x \<squnion> (y \<sqinter> (z \<squnion> top))) \<sqinter> (x \<squnion> y) = bot"
     using 83 1128 by metis
   have 2097: "\<And>x y . - - (x \<squnion> y) \<sqinter> x = x"
     using 14 19 1129 by metis
   have 2124: "\<And>x y . - - (x \<squnion> y) \<sqinter> y = y"
     using 9 2097 by metis
   have 2135: "\<And>x y . - - ((top \<squnion> x) \<sqinter> y) \<sqinter> y = y"
     using 36 2097 by metis
   have 2136: "\<And>x y . - - ((x \<squnion> top) \<sqinter> y) \<sqinter> y = y"
     using 37 2097 by metis
   have 2137: "\<And>x y . - x \<squnion> - - (x \<squnion> y) = top"
     using 9 288 2097 by metis
   have 2138: "\<And>x y . - x \<sqinter> - (x \<squnion> y) = - (x \<squnion> y)"
     using 315 2097 by metis
   have 2151: "\<And>x y . - x \<squnion> - (x \<squnion> y) = - x"
     using 9 132 373 2097 by metis
   have 2191: "\<And>x y . - - x \<sqinter> (- y \<sqinter> x) = - y \<sqinter> x"
     using 88 2124 by metis
   have 2201: "\<And>x y . - x \<squnion> - - (y \<squnion> x) = top"
     using 9 288 2124 by metis
   have 2202: "\<And>x y . - x \<sqinter> - (y \<squnion> x) = - (y \<squnion> x)"
     using 315 2124 by metis
   have 2320: "\<And>x y . - (x \<sqinter> (y \<squnion> top)) = - x"
     using 83 373 2151 by metis
   have 2343: "\<And>x y . - (- x \<sqinter> y) \<squnion> - - y = top"
     using 88 2201 by metis
   have 2546: "\<And>x y z . - x \<squnion> ((- - x \<sqinter> - y) \<squnion> z) = - x \<squnion> (- y \<squnion> z)"
     using 111 116 by metis
   have 2706: "\<And>x y z . - x \<squnion> (y \<squnion> - - ((top \<squnion> z) \<sqinter> - x)) = y \<squnion> - - ((top \<squnion> z) \<sqinter> - x)"
     using 755 2135 by metis
   have 2810: "\<And>x y . - x \<sqinter> - ((y \<squnion> top) \<sqinter> x) = - ((y \<squnion> top) \<sqinter> x)"
     using 315 2136 by metis
   have 3022: "\<And>x y . - x \<squnion> - (- y \<sqinter> - x) = top"
     using 9 132 2343 by metis
   have 3133: "\<And>x y . - (- x \<sqinter> - y) \<sqinter> y = y"
     using 14 42 3022 by metis
   have 3134: "\<And>x y . - x \<sqinter> (- y \<sqinter> - x) = - y \<sqinter> - x"
     using 14 43 3022 by metis
   have 3961: "\<And>x y . - - (x \<squnion> y) \<sqinter> - - x = - - x"
     using 14 136 2137 by metis
   have 4644: "\<And>x y z . - (x \<sqinter> - y) \<sqinter> (x \<sqinter> - (y \<squnion> z)) = bot"
     using 1594 2151 by metis
   have 5495: "\<And>x y z . - - (x \<sqinter> y) \<sqinter> - (x \<squnion> z) = bot"
     using 421 2138 by metis
   have 9413: "\<And>x y . - - (- x \<sqinter> y) \<sqinter> y = - x \<sqinter> y"
     using 9 103 182 319 by metis
   have 9519: "\<And>x y z . - - (- x \<sqinter> y) \<sqinter> - - (x \<sqinter> z) = bot"
     using 373 5495 by metis
   have 11069: "\<And>x y z . - (- - x \<sqinter> y) \<squnion> (- x \<sqinter> - z) = - (- - x \<sqinter> y)"
     using 316 757 by metis
   have 12370: "\<And>x y . - x \<sqinter> - (- - x \<sqinter> y) = - x"
     using 132 1155 by metis
   have 12376: "\<And>x y . - x \<sqinter> - (x \<sqinter> y) = - x"
     using 127 132 1155 by metis
   have 12383: "\<And>x y . - (x \<squnion> y) \<sqinter> - y = - (x \<squnion> y)"
     using 132 1155 2124 by metis
   have 12393: "\<And>x y . - - (- x \<sqinter> - y) = - x \<sqinter> - y"
     using 1155 3133 9413 by metis
   have 12407: "\<And>x y . - - x \<sqinter> - - (x \<squnion> y) = - - x"
     using 1155 2138 by metis
   have 12639: "\<And>x y . - x \<sqinter> - (- y \<sqinter> x) = - x"
     using 88 12383 by metis
   have 24647: "\<And>x y . (- x \<sqinter> - y) \<squnion> - (- x \<sqinter> - y) = top"
     using 19 12393 by metis
   have 28269: "\<And>x y z . - - (x \<sqinter> y) \<squnion> - (- x \<sqinter> z) = - (- x \<sqinter> z)"
     using 373 404 by metis
   have 28338: "\<And>x y . - (- - (x \<sqinter> y) \<sqinter> x) = - (x \<sqinter> y)"
     using 123 405 12370 by metis
   have 28422: "\<And>x y . - (- x \<sqinter> - y) = - (- y \<sqinter> - x)"
     using 13 3134 12393 28338 by metis
   have 28485: "\<And>x y . - x \<sqinter> - y = - y \<sqinter> - x"
     using 2097 3961 12393 28422 by metis
   have 30411: "\<And>x y . - x \<sqinter> (x \<squnion> (x \<sqinter> y)) = bot"
     using 9 82 2094 2320 by metis
   have 30469: "\<And>x . - x \<sqinter> (x \<squnion> - - x) = bot"
     using 9 123 132 30411 by metis
   have 37513: "\<And>x y . - (- x \<sqinter> - y) \<sqinter> - (y \<squnion> x) = bot"
     using 2202 4644 by metis
   have 52421: "\<And>x y . - (- x \<sqinter> - (- x \<sqinter> y)) \<sqinter> y = y"
     using 14 144 24647 28485 by metis
   have 52520: "\<And>x y . - x \<sqinter> - (- x \<sqinter> y) = - x \<sqinter> - y"
     using 13 12376 12393 12639 28485 52421 by metis
   have 52533: "\<And>x y z . - - (x \<squnion> (y \<sqinter> (z \<squnion> top))) \<sqinter> (x \<squnion> y) = x \<squnion> y"
     using 15 49 2094 52421 by metis
   have 61101: "\<And>x y z . - (- - x \<sqinter> y) \<squnion> z = - x \<squnion> (- y \<squnion> z)"
     using 111 2546 12370 52520 by metis
   have 61156: "\<And>x y . - - (- x \<sqinter> y) = - x \<sqinter> - - y"
     using 419 52520 by metis
   have 61162: "\<And>x y . - (x \<squnion> (x \<sqinter> y)) = - x"
     using 15 49 2138 30411 52520 by metis
   have 61163: "\<And>x . - (x \<squnion> - - x) = - x"
     using 15 49 2138 30469 52520 by metis
   have 61229: "\<And>x y z . - x \<sqinter> (- - y \<sqinter> - (x \<sqinter> z)) = - x \<sqinter> - - y"
     using 13 15 49 132 9519 52520 61156 by metis
   have 61311: "\<And>x y . - x \<squnion> - y = - (- - y \<sqinter> x)"
     using 119 11069 61101 by metis
   have 61391: "\<And>x y . - (- x \<sqinter> - - y) = - (- x \<sqinter> y)"
     using 13 28269 61156 61229 61311 by metis
   have 61420: "\<And>x y . - (- - x \<sqinter> y) = - (- - y \<sqinter> x)"
     using 13 134 2191 61156 61311 by metis
   have 61454: "\<And>x y . - (x \<squnion> - (- y \<sqinter> - x)) = - y \<sqinter> - x"
     using 9 132 3133 61156 61162 by metis
   have 61648: "\<And>x y . - x \<sqinter> (x \<squnion> (- y \<sqinter> - - x)) = bot"
     using 1117 61163 by metis
   have 62434: "\<And>x y . - (- - x \<sqinter> y) \<sqinter> x = - y \<sqinter> x"
     using 43 61311 by metis
   have 63947: "\<And>x y . - (- x \<sqinter> y) \<sqinter> - (- y \<squnion> x) = bot"
     using 37513 61391 by metis
   have 64227: "\<And>x y . - (x \<squnion> (- y \<sqinter> - - x)) = - x"
     using 15 49 2138 52520 61648 by metis
   have 64239: "\<And>x y . - (x \<squnion> (- - x \<squnion> y)) = - (x \<squnion> y)"
     using 9 25 12407 64227 by metis
   have 64241: "\<And>x y . - (x \<squnion> (- - x \<sqinter> - y)) = - x"
     using 28485 64227 by metis
   have 64260: "\<And>x y . - (x \<squnion> - - (x \<sqinter> y)) = - x"
     using 420 64241 by metis
   have 64271: "\<And>x y . - (- x \<squnion> (y \<squnion> - - (y \<sqinter> x))) = - (- x \<squnion> y)"
     using 9 25 42 64260 by metis
   have 64281: "\<And>x y . - (- x \<squnion> y) = - (y \<squnion> - - ((top \<squnion> y) \<sqinter> - x))"
     using 9 25 157 2706 64260 by metis
   have 64282: "\<And>x y . - (x \<squnion> - - ((x \<squnion> top) \<sqinter> y)) = - (x \<squnion> - - y)"
     using 9 25 132 536 2810 28485 61311 64260 by metis
   have 65110: "\<And>x y . - ((- x \<sqinter> y) \<squnion> (- y \<squnion> x)) = bot"
     using 9 14 49 37513 63947 by metis
   have 65231: "\<And>x y . - (x \<squnion> ((- x \<sqinter> y) \<squnion> - y)) = bot"
     using 9 25 65110 by metis
   have 65585: "\<And>x y . - (x \<squnion> - y) = - - y \<sqinter> - x"
     using 61311 61454 64239 by metis
   have 65615: "\<And>x y . - x \<sqinter> - ((x \<squnion> top) \<sqinter> y) = - y \<sqinter> - x"
     using 132 28485 64282 65585 by metis
   have 65616: "\<And>x y . - (- x \<squnion> y) = - y \<sqinter> - ((top \<squnion> y) \<sqinter> - x)"
     using 132 28485 64281 65585 by metis
   have 65791: "\<And>x y . - x \<sqinter> - ((top \<squnion> x) \<sqinter> - y) = - - y \<sqinter> - x"
     using 89 132 12376 28485 64271 65585 65615 65616 by metis
   have 65933: "\<And>x y . - (- x \<squnion> y) = - - x \<sqinter> - y"
     using 65616 65791 by metis
   have 66082: "\<And>x y z . - (x \<squnion> (y \<squnion> - z)) = - - z \<sqinter> - (x \<squnion> y)"
     using 8 65585 by metis
   have 66204: "\<And>x y . - - x \<sqinter> - (y \<squnion> (- y \<sqinter> x)) = bot"
     using 65231 66082 by metis
   have 66281: "\<And>x y z . - (x \<squnion> (- y \<squnion> z)) = - - y \<sqinter> - (x \<squnion> z)"
     using 25 65933 by metis
   have 67527: "\<And>x y . - - (x \<squnion> (- x \<sqinter> y)) \<sqinter> y = y"
     using 14 49 62434 66204 by metis
   have 67762: "\<And>x y . - (- - x \<sqinter> (y \<squnion> (- y \<sqinter> x))) = - x"
     using 61420 67527 by metis
   have 68018: "\<And>x y z . - (x \<squnion> y) \<sqinter> (x \<squnion> (y \<sqinter> (z \<squnion> top))) = bot"
     using 8 83 1113 2320 by metis
   have 71989: "\<And>x y z . - (x \<squnion> (y \<sqinter> (z \<squnion> top))) = - (x \<squnion> y)"
     using 9 29 52533 67762 68018 by metis
   have 71997: "\<And>x y z . - ((x \<sqinter> (y \<squnion> top)) \<squnion> z) = - (x \<squnion> z)"
     using 17 2320 71989 by metis
   have 72090: "\<And>x y z . - (x \<squnion> ((x \<sqinter> y) \<squnion> z)) = - (x \<squnion> z)"
     using 10 14 705 71997 by metis
   have 72139: "\<And>x y . - (x \<squnion> y) = - x \<sqinter> - y"
     using 25 123 132 2138 65933 66281 72090 by metis
   show ?thesis
     using 72139 by metis
 qed
 
 lemma l15:
   "--(x \<squnion> y) = --x \<squnion> --y"
   by (simp add: l11 l12 l4)
 
 lemma l13_var:
   "- - (- x \<sqinter> y) = - x \<sqinter> - - y"
 proof -
   have 1: "\<And>x y . x \<le> y \<longleftrightarrow> x \<squnion> y = y"
     by (simp add: il_less_eq)
   have 4: "\<And>x y . \<not>(x \<le> y) \<or> x \<squnion> y = y"
     using 1 by metis
   have 5: "\<And>x y z . (x \<sqinter> y) \<squnion> (x \<sqinter> z) \<le> x \<sqinter> (y \<squnion> z)"
     by (simp add: il_sub_inf_right_isotone_var)
   have 6: "\<And>x y . - - x \<le> - (- x \<sqinter> y)"
     by (simp add: pad2)
   have 7: "\<And>x y z . x \<squnion> (y \<squnion> z) = (x \<squnion> y) \<squnion> z"
     by (simp add: il_associative)
   have 8: "\<And>x y z . (x \<squnion> y) \<squnion> z = x \<squnion> (y \<squnion> z)"
     using 7 by metis
   have 9: "\<And>x y . x \<squnion> y = y \<squnion> x"
     by (simp add: il_commutative)
   have 10: "\<And>x . x \<squnion> bot = x"
     by (simp add: il_bot_unit)
   have 11: "\<And>x . x \<squnion> x = x"
     by simp
   have 12: "\<And>x y z . x \<sqinter> (y \<sqinter> z) = (x \<sqinter> y) \<sqinter> z"
     by (simp add: il_inf_associative)
   have 13: "\<And>x y z . (x \<sqinter> y) \<sqinter> z = x \<sqinter> (y \<sqinter> z)"
     using 12 by metis
   have 14: "\<And>x . top \<sqinter> x = x"
     by simp
   have 15: "\<And>x . x \<sqinter> top = x"
     by simp
   have 16: "\<And>x y z . (x \<squnion> y) \<sqinter> z = (x \<sqinter> z) \<squnion> (y \<sqinter> z)"
     by (simp add: il_inf_right_dist_sup)
   have 17: "\<And>x y z . (x \<sqinter> y) \<squnion> (z \<sqinter> y) = (x \<squnion> z) \<sqinter> y"
     using 16 by metis
   have 19: "\<And>x . - x \<squnion> - - x = top"
     by simp
   have 20: "\<And>x . - x \<sqinter> x = bot"
     by (simp add: a_inf_complement_bot)
   have 22: "\<And>x y z . ((x \<sqinter> y) \<squnion> (x \<sqinter> z)) \<squnion> (x \<sqinter> (y \<squnion> z)) = x \<sqinter> (y \<squnion> z)"
     using 4 5 by metis
   have 23: "\<And>x y z . (x \<sqinter> (y \<squnion> z)) \<squnion> ((x \<sqinter> y) \<squnion> (x \<sqinter> z)) = x \<sqinter> (y \<squnion> z)"
     using 9 22 by metis
   have 24: "\<And>x y . - - x \<squnion> - (- x \<sqinter> y) = - (- x \<sqinter> y)"
     using 4 6 by metis
   have 25: "\<And>x y z . x \<squnion> (y \<squnion> z) = y \<squnion> (x \<squnion> z)"
     using 8 9 by metis
   have 26: "\<And>x y z . (x \<sqinter> y) \<squnion> ((x \<sqinter> z) \<squnion> (x \<sqinter> (y \<squnion> z))) = x \<sqinter> (y \<squnion> z)"
     using 9 23 25 by metis
   have 29: "\<And>x . bot \<squnion> x = x"
     using 9 10 by metis
   have 30: "\<And>x y . x \<squnion> (x \<squnion> y) = x \<squnion> y"
     using 8 11 by metis
   have 34: "\<And>u x y z . (x \<sqinter> (y \<sqinter> z)) \<squnion> (u \<sqinter> z) = ((x \<sqinter> y) \<squnion> u) \<sqinter> z"
     using 13 17 by metis
   have 35: "\<And>u x y z . (x \<sqinter> y) \<squnion> (z \<sqinter> (u \<sqinter> y)) = (x \<squnion> (z \<sqinter> u)) \<sqinter> y"
     using 13 17 by metis
   have 38: "\<And>x y . - x \<squnion> (- - x \<squnion> y) = top \<squnion> y"
     using 8 19 by metis
   have 41: "- top = bot"
     using 15 20 by metis
   have 42: "\<And>x y . (- x \<squnion> y) \<sqinter> x = y \<sqinter> x"
     using 17 20 29 by metis
   have 43: "\<And>x y . (x \<squnion> - y) \<sqinter> y = x \<sqinter> y"
     using 9 17 20 29 by metis
   have 45: "\<And>x . - bot \<squnion> - - x = - bot"
     using 9 20 24 by metis
   have 49: "- bot = top"
     using 19 29 41 by metis
   have 50: "\<And>x . top \<squnion> - - x = top"
     using 45 49 by metis
   have 62: "\<And>x y . x \<squnion> ((x \<sqinter> - y) \<squnion> (x \<sqinter> - - y)) = x"
     using 9 15 19 25 26 by metis
   have 65: "\<And>x y . (- (x \<squnion> y) \<sqinter> x) \<squnion> (- (x \<squnion> y) \<sqinter> y) = bot"
     using 9 20 26 29 by metis
   have 66: "\<And>x y z . (x \<sqinter> - - y) \<squnion> (x \<sqinter> - (- y \<sqinter> z)) = x \<sqinter> - (- y \<sqinter> z)"
     using 11 24 26 by metis
   have 69: "\<And>x y . x \<squnion> (x \<sqinter> - - y) = x"
     using 9 15 26 30 50 by metis
   have 81: "\<And>x . top \<squnion> - x = top"
     using 9 19 30 by metis
   have 88: "\<And>x y . x \<squnion> (- y \<sqinter> x) = x"
     using 14 17 81 by metis
   have 101: "\<And>x y z . x \<squnion> (y \<squnion> (x \<sqinter> - - z)) = y \<squnion> x"
     using 25 69 by metis
   have 103: "\<And>x y . x \<squnion> (x \<sqinter> - y) = x"
     using 9 62 101 by metis
   have 123: "\<And>x . - - x \<sqinter> x = x"
     using 14 19 42 by metis
   have 127: "\<And>x y . - - x \<sqinter> (x \<sqinter> y) = x \<sqinter> y"
     using 13 123 by metis
   have 130: "\<And>x . - x \<squnion> - - - x = - x"
     using 9 24 123 by metis
   have 132: "\<And>x . - - - x = - x"
     using 9 103 123 130 by metis
   have 136: "\<And>x y . (- x \<squnion> y) \<sqinter> - - x = y \<sqinter> - - x"
     using 42 132 by metis
   have 144: "\<And>x y z . ((- (x \<sqinter> y) \<sqinter> x) \<squnion> z) \<sqinter> y = z \<sqinter> y"
     using 20 29 34 by metis
   have 182: "\<And>x y z . (x \<squnion> (- - (y \<sqinter> z) \<sqinter> y)) \<sqinter> z = (x \<squnion> y) \<sqinter> z"
     using 17 35 123 by metis
   have 288: "\<And>x y . - x \<squnion> - (- x \<sqinter> y) = top"
     using 24 38 81 by metis
   have 315: "\<And>x y . - (- x \<sqinter> y) \<sqinter> x = x"
     using 14 42 288 by metis
   have 319: "\<And>x y . - x \<squnion> - - (- x \<sqinter> y) = - x"
     using 9 24 315 by metis
   have 387: "\<And>x y . - (x \<sqinter> y) \<sqinter> - x = - x"
     using 127 315 by metis
   have 405: "\<And>x y z . - (x \<sqinter> (y \<sqinter> z)) \<sqinter> - (x \<sqinter> y) = - (x \<sqinter> y)"
     using 13 387 by metis
   have 419: "\<And>x y . - x \<sqinter> - - (- x \<sqinter> y) = - - (- x \<sqinter> y)"
     using 315 387 by metis
   have 1091: "\<And>x y . - (x \<squnion> y) \<sqinter> x = bot"
     using 9 29 30 65 by metis
   have 1129: "\<And>x y z . (- (x \<squnion> y) \<squnion> z) \<sqinter> x = z \<sqinter> x"
     using 17 29 1091 by metis
   have 1155: "\<And>x y . - - x \<sqinter> - (- x \<sqinter> y) = - - x"
     using 66 103 123 132 by metis
   have 2097: "\<And>x y . - - (x \<squnion> y) \<sqinter> x = x"
     using 14 19 1129 by metis
   have 2124: "\<And>x y . - - (x \<squnion> y) \<sqinter> y = y"
     using 9 2097 by metis
   have 2137: "\<And>x y . - x \<squnion> - - (x \<squnion> y) = top"
     using 9 288 2097 by metis
   have 2201: "\<And>x y . - x \<squnion> - - (y \<squnion> x) = top"
     using 9 288 2124 by metis
   have 2343: "\<And>x y . - (- x \<sqinter> y) \<squnion> - - y = top"
     using 88 2201 by metis
   have 3022: "\<And>x y . - x \<squnion> - (- y \<sqinter> - x) = top"
     using 9 132 2343 by metis
   have 3133: "\<And>x y . - (- x \<sqinter> - y) \<sqinter> y = y"
     using 14 42 3022 by metis
   have 3134: "\<And>x y . - x \<sqinter> (- y \<sqinter> - x) = - y \<sqinter> - x"
     using 14 43 3022 by metis
   have 3961: "\<And>x y . - - (x \<squnion> y) \<sqinter> - - x = - - x"
     using 14 136 2137 by metis
   have 9413: "\<And>x y . - - (- x \<sqinter> y) \<sqinter> y = - x \<sqinter> y"
     using 9 103 182 319 by metis
   have 12370: "\<And>x y . - x \<sqinter> - (- - x \<sqinter> y) = - x"
     using 132 1155 by metis
   have 12376: "\<And>x y . - x \<sqinter> - (x \<sqinter> y) = - x"
     using 127 132 1155 by metis
   have 12383: "\<And>x y . - (x \<squnion> y) \<sqinter> - y = - (x \<squnion> y)"
     using 132 1155 2124 by metis
   have 12393: "\<And>x y . - - (- x \<sqinter> - y) = - x \<sqinter> - y"
     using 1155 3133 9413 by metis
   have 12639: "\<And>x y . - x \<sqinter> - (- y \<sqinter> x) = - x"
     using 88 12383 by metis
   have 24647: "\<And>x y . (- x \<sqinter> - y) \<squnion> - (- x \<sqinter> - y) = top"
     using 19 12393 by metis
   have 28338: "\<And>x y . - (- - (x \<sqinter> y) \<sqinter> x) = - (x \<sqinter> y)"
     using 123 405 12370 by metis
   have 28422: "\<And>x y . - (- x \<sqinter> - y) = - (- y \<sqinter> - x)"
     using 13 3134 12393 28338 by metis
   have 28485: "\<And>x y . - x \<sqinter> - y = - y \<sqinter> - x"
     using 2097 3961 12393 28422 by metis
   have 52421: "\<And>x y . - (- x \<sqinter> - (- x \<sqinter> y)) \<sqinter> y = y"
     using 14 144 24647 28485 by metis
   have 52520: "\<And>x y . - x \<sqinter> - (- x \<sqinter> y) = - x \<sqinter> - y"
     using 13 12376 12393 12639 28485 52421 by metis
   have 61156: "\<And>x y . - - (- x \<sqinter> y) = - x \<sqinter> - - y"
     using 419 52520 by metis
   show ?thesis
     using 61156 by metis
 qed
 
 text \<open>Theorem 25.1\<close>
 
 subclass subset_boolean_algebra_2
 proof
   show "\<And>x y z. x \<squnion> (y \<squnion> z) = x \<squnion> y \<squnion> z"
     by (simp add: il_associative)
   show "\<And>x y. x \<squnion> y = y \<squnion> x"
     by (simp add: il_commutative)
   show "\<And>x. x \<squnion> x = x"
     by simp
   show "\<And>x y. x \<squnion> - (y \<squnion> - y) = x"
     using il_bot_unit l12 l6 by auto
   show "\<And>x y. - (x \<squnion> y) = - (- - x \<squnion> - - y)"
     by (metis l15 l4)
   show "\<And>x y. - x \<squnion> - (- x \<squnion> y) = - x \<squnion> - y"
     by (smt l11 l15 il_inf_right_dist_sup il_unit_bot l6 l7)
 qed
 
 lemma aa_test:
   "p = --p \<Longrightarrow> test p"
   by (metis ppa_ppd.d_closed)
 
 lemma test_aa_increasing:
   "test p \<Longrightarrow> p \<le> --p"
   by (simp add: ppa_ppd.d_increasing_sub_identity test_sub_identity)
 
 lemma "test p \<Longrightarrow> - - (p \<sqinter> x) \<le> p" nitpick [expect=genuine] oops
 lemma "test p \<Longrightarrow> --p \<le> p" nitpick [expect=genuine] oops
 
 end
 
 class pa_algebra = pa_semiring + minus +
   assumes pa_minus_def: "-x - -y = -(--x \<squnion> -y)"
 begin
 
 subclass subset_boolean_algebra_2_extended
 proof
   show "bot = (THE x. \<forall>z. x = - (z \<squnion> - z))"
     using l12 l6 by auto
   thus "top = - (THE x. \<forall>z. x = - (z \<squnion> - z))"
     using l2 by blast
   show "\<And>x y. - x \<sqinter> - y = - (- - x \<squnion> - - y)"
     by (metis l12 l4)
   show "\<And>x y. - x - - y = - (- - x \<squnion> - y)"
     by (simp add: pa_minus_def)
   show "\<And>x y. (x \<le> y) = (x \<squnion> y = y)"
     by (simp add: il_less_eq)
   show "\<And>x y. (x < y) = (x \<squnion> y = y \<and> y \<squnion> x \<noteq> x)"
     by (simp add: il_less_eq less_le_not_le)
 qed
 
 lemma "\<And>x y. - (x \<sqinter> - - y) = - (x \<sqinter> y)" nitpick [expect=genuine] oops
 
 end
 
 subsection \<open>Antidomain Semirings\<close>
 
 text \<open>Definition 24\<close>
 
 class a_semiring = ppa_semiring +
   assumes ad3: "-(x \<sqinter> y) \<le> -(x \<sqinter> --y)"
 begin
 
 lemma l16:
   "- - x \<le> - (- x \<sqinter> y)"
 proof -
   have 1: "\<And>x y . x \<le> y \<longleftrightarrow> x \<squnion> y = y"
     by (simp add: il_less_eq)
   have 3: "\<And>x y z . x \<squnion> (y \<squnion> z) = (x \<squnion> y) \<squnion> z"
     by (simp add: il_associative)
   have 4: "\<And>x y z . (x \<squnion> y) \<squnion> z = x \<squnion> (y \<squnion> z)"
     using 3 by metis
   have 5: "\<And>x y . x \<squnion> y = y \<squnion> x"
     by (simp add: il_commutative)
   have 6: "\<And>x . x \<squnion> bot = x"
     by (simp add: il_bot_unit)
   have 7: "\<And>x . x \<squnion> x = x"
     by simp
   have 8: "\<And>x y . \<not>(x \<le> y) \<or> x \<squnion> y = y"
     using 1 by metis
   have 9: "\<And>x y . x \<le> y \<or> x \<squnion> y \<noteq> y"
     using 1 by metis
   have 10: "\<And>x y z . x \<sqinter> (y \<sqinter> z) = (x \<sqinter> y) \<sqinter> z"
     by (simp add: il_inf_associative)
   have 11: "\<And>x y z . (x \<sqinter> y) \<sqinter> z = x \<sqinter> (y \<sqinter> z)"
     using 10 by metis
   have 12: "\<And>x . top \<sqinter> x = x"
     by simp
   have 13: "\<And>x . x \<sqinter> top = x"
     by simp
   have 14: "\<And>x y z . (x \<sqinter> y) \<squnion> (x \<sqinter> z) \<le> x \<sqinter> (y \<squnion> z)"
     by (simp add: il_sub_inf_right_isotone_var)
   have 15: "\<And>x y z . (x \<squnion> y) \<sqinter> z = (x \<sqinter> z) \<squnion> (y \<sqinter> z)"
     by (simp add: il_inf_right_dist_sup)
   have 16: "\<And>x y z . (x \<sqinter> y) \<squnion> (z \<sqinter> y) = (x \<squnion> z) \<sqinter> y"
     using 15 by metis
   have 17: "\<And>x . bot \<sqinter> x = bot"
     by simp
   have 18: "\<And>x . - x \<squnion> - - x = top"
     by simp
   have 19: "\<And>x . - x \<sqinter> x = bot"
     by (simp add: a_inf_complement_bot)
   have 20: "\<And>x y . - (x \<sqinter> y) \<le> - (x \<sqinter> - - y)"
     by (simp add: ad3)
   have 22: "\<And>x y z . x \<squnion> (y \<squnion> z) = y \<squnion> (x \<squnion> z)"
     using 4 5 by metis
   have 25: "\<And>x . bot \<squnion> x = x"
     using 5 6 by metis
   have 26: "\<And>x y . x \<squnion> (x \<squnion> y) = x \<squnion> y"
     using 4 7 by metis
   have 33: "\<And>x y z . (x \<sqinter> y) \<squnion> ((x \<sqinter> z) \<squnion> (x \<sqinter> (y \<squnion> z))) = x \<sqinter> (y \<squnion> z)"
     using 5 8 14 22 by metis
   have 47: "\<And>x y . - x \<squnion> (- - x \<squnion> y) = top \<squnion> y"
     using 4 18 by metis
   have 48: "\<And>x y . - - x \<squnion> (y \<squnion> - x) = y \<squnion> top"
     using 4 5 18 by metis
   have 51: "\<And>x y . - x \<sqinter> (x \<sqinter> y) = bot"
     using 11 17 19 by metis
   have 52: "- top = bot"
     using 13 19 by metis
   have 56: "\<And>x y . (- x \<squnion> y) \<sqinter> x = y \<sqinter> x"
     using 16 19 25 by metis
   have 57: "\<And>x y . (x \<squnion> - y) \<sqinter> y = x \<sqinter> y"
     using 5 16 19 25 by metis
   have 58: "\<And>x y . - (x \<sqinter> y) \<squnion> - (x \<sqinter> - - y) = - (x \<sqinter> - - y)"
     using 8 20 by metis
   have 60: "\<And>x . - x \<le> - - - x"
     using 12 20 by metis
   have 69: "- bot = top"
     using 18 25 52 by metis
   have 74: "\<And>x y . x \<le> x \<squnion> y"
     using 9 26 by metis
   have 78: "\<And>x . top \<squnion> - x = top"
     using 5 18 26 by metis
   have 80: "\<And>x y . x \<le> y \<squnion> x"
     using 5 74 by metis
   have 86: "\<And>x y z . x \<squnion> y \<le> x \<squnion> (z \<squnion> y)"
     using 22 80 by metis
   have 95: "\<And>x . - x \<squnion> - - - x = - - - x"
     using 8 60 by metis
   have 143: "\<And>x y . x \<squnion> (x \<sqinter> - y) = x"
     using 5 13 26 33 78 by metis
   have 370: "\<And>x y z . x \<squnion> (y \<sqinter> - z) \<le> x \<squnion> y"
     using 86 143 by metis
   have 907: "\<And>x . - x \<sqinter> - x = - x"
     using 12 18 57 by metis
   have 928: "\<And>x y . - x \<sqinter> (- x \<sqinter> y) = - x \<sqinter> y"
     using 11 907 by metis
   have 966: "\<And>x y . - (- x \<sqinter> - - (x \<sqinter> y)) = top"
     using 51 58 69 78 by metis
   have 1535: "\<And>x . - x \<squnion> - - - - x = top"
     using 47 78 95 by metis
   have 1630: "\<And>x y z . (x \<squnion> y) \<sqinter> - z \<le> (x \<sqinter> - z) \<squnion> y"
     using 16 370 by metis
   have 2422: "\<And>x . - x \<sqinter> - - - x = - - - x"
     using 12 57 1535 by metis
   have 6567: "\<And>x y . - x \<sqinter> - - (x \<sqinter> y) = bot"
     using 12 19 966 by metis
   have 18123: "\<And>x . - - - x = - x"
     using 95 143 2422 by metis
   have 26264: "\<And>x y . - x \<le> (- y \<sqinter> - x) \<squnion> - - y"
     using 12 18 1630 by metis
   have 26279: "\<And>x y . - - (x \<sqinter> y) \<le> - - x"
     using 25 6567 26264 by metis
   have 26307: "\<And>x y . - - (- x \<sqinter> y) \<le> - x"
     using 928 18123 26279 by metis
   have 26339: "\<And>x y . - x \<squnion> - - (- x \<sqinter> y) = - x"
     using 5 8 26307 by metis
   have 26564: "\<And>x y . - x \<squnion> - (- x \<sqinter> y) = top"
     using 5 48 78 18123 26339 by metis
   have 26682: "\<And>x y . - (- x \<sqinter> y) \<sqinter> x = x"
     using 12 56 26564 by metis
   have 26864: "\<And>x y . - - x \<le> - (- x \<sqinter> y)"
     using 18123 26279 26682 by metis
   show ?thesis
     using 26864 by metis
 qed
 
 text \<open>Theorem 25.2\<close>
 
 subclass pa_semiring
 proof
   show "\<And>x y. - - x \<le> - (- x \<sqinter> y)"
     by (rule l16)
 qed
 
 lemma l17:
   "-(x \<sqinter> y) = -(x \<sqinter> --y)"
   by (simp add: ad3 order.antisym l14)
 
 lemma a_complement_inf_double_complement:
   "-(x \<sqinter> --y) = -(x \<sqinter> y)"
   using l17 by auto
 
 sublocale a_d: d_semiring_var where d = "\<lambda>x . --x"
 proof
   show "\<And>x y. - - (x \<sqinter> - - y) \<le> - - (x \<sqinter> y)"
     using l17 by auto
   show "- - bot = bot"
     by (simp add: l1 l2)
 qed
 
 lemma "test p \<Longrightarrow> - - (p \<sqinter> x) \<le> p"
   by (fact a_d.d2)
 
 end
 
 class a_algebra = a_semiring + minus +
   assumes a_minus_def: "-x - -y = -(--x \<squnion> -y)"
 begin
 
 subclass pa_algebra
 proof
   show "\<And>x y. - x - - y = - (- - x \<squnion> - y)"
     by (simp add: a_minus_def)
 qed
 
 text \<open>Theorem 25.4\<close>
 
 subclass subset_boolean_algebra_4_extended
 proof
   show "\<And>x y z. x \<sqinter> (y \<sqinter> z) = x \<sqinter> y \<sqinter> z"
     by (simp add: il_inf_associative)
   show "\<And>x y z. (x \<squnion> y) \<sqinter> z = x \<sqinter> z \<squnion> y \<sqinter> z"
     by (simp add: il_inf_right_dist_sup)
   show "\<And>x. - x \<sqinter> x = bot"
     by (simp add: a_inf_complement_bot)
   show "\<And>x. top \<sqinter> x = x"
     by simp
   show "\<And>x y. - (x \<sqinter> - - y) = - (x \<sqinter> y)"
     using l17 by auto
   show "\<And>x. x \<sqinter> top = x"
     by simp
   show "\<And>x y z. x \<le> y \<Longrightarrow> z \<sqinter> x \<le> z \<sqinter> y"
     by (simp add: il_sub_inf_right_isotone)
 qed
 
 end
 
 context subset_boolean_algebra_4_extended
 begin
 
 subclass il_semiring
 proof
   show "\<And>x y z. x \<squnion> (y \<squnion> z) = x \<squnion> y \<squnion> z"
     by (simp add: sup_assoc)
   show "\<And>x y. x \<squnion> y = y \<squnion> x"
     by (simp add: sup_commute)
   show "\<And>x. x \<squnion> x = x"
     by simp
   show "\<And>x. x \<squnion> bot = x"
     by simp
   show "\<And>x y z. x \<sqinter> (y \<sqinter> z) = x \<sqinter> y \<sqinter> z"
     by (simp add: sba3_inf_associative)
   show "\<And>x y z. (x \<squnion> y) \<sqinter> z = x \<sqinter> z \<squnion> y \<sqinter> z"
     by (simp add: sba3_inf_right_dist_sup)
   show "\<And>x. top \<sqinter> x = x"
     by simp
   show "\<And>x. x \<sqinter> top = x"
     by simp
   show "\<And>x. bot \<sqinter> x = bot"
     by (simp add: inf_left_zero)
   show "\<And>x y z. x \<le> y \<Longrightarrow> z \<sqinter> x \<le> z \<sqinter> y"
     by (simp add: inf_right_isotone)
   show "\<And>x y. (x \<le> y) = (x \<squnion> y = y)"
     by (simp add: le_iff_sup)
   show "\<And>x y. (x < y) = (x \<le> y \<and> \<not> y \<le> x)"
     by (simp add: less_le_not_le)
 qed
 
 subclass a_semiring
 proof
   show "\<And>x. - x \<sqinter> x = bot"
     by (simp add: sba3_inf_complement_bot)
   show "\<And>x. - x \<squnion> - - x = top"
     by simp
   show "\<And>x y. - (x \<sqinter> y) \<le> - (x \<sqinter> - - y)"
     by (simp add: sba3_complement_inf_double_complement)
 qed
 
 sublocale sba4_a: a_algebra
 proof
   show "\<And>x y. - x - - y = - (- - x \<squnion> - y)"
     by (simp add: sub_minus_def)
 qed
 
 end
 
 context stone_algebra
 begin
 
 text \<open>Theorem 25.3\<close>
 
 subclass il_semiring
 proof
   show "\<And>x y z. x \<squnion> (y \<squnion> z) = x \<squnion> y \<squnion> z"
     by (simp add: sup_assoc)
   show "\<And>x y. x \<squnion> y = y \<squnion> x"
     by (simp add: sup_commute)
   show "\<And>x. x \<squnion> x = x"
     by simp
   show "\<And>x. x \<squnion> bot = x"
     by simp
   show "\<And>x y z. x \<sqinter> (y \<sqinter> z) = x \<sqinter> y \<sqinter> z"
     by (simp add: inf.sup_monoid.add_assoc)
   show "\<And>x y z. (x \<squnion> y) \<sqinter> z = x \<sqinter> z \<squnion> y \<sqinter> z"
     by (simp add: inf_sup_distrib2)
   show "\<And>x. top \<sqinter> x = x"
     by simp
   show "\<And>x. x \<sqinter> top = x"
     by simp
   show "\<And>x. bot \<sqinter> x = bot"
     by simp
   show "\<And>x y z. x \<le> y \<Longrightarrow> z \<sqinter> x \<le> z \<sqinter> y"
     using inf.sup_right_isotone by blast
   show "\<And>x y. (x \<le> y) = (x \<squnion> y = y)"
     by (simp add: le_iff_sup)
   show "\<And>x y. (x < y) = (x \<le> y \<and> \<not> y \<le> x)"
     by (simp add: less_le_not_le)
 qed
 
 subclass a_semiring
 proof
   show "\<And>x. - x \<sqinter> x = bot"
     by simp
   show "\<And>x. - x \<squnion> - - x = top"
     by simp
   show "\<And>x y. - (x \<sqinter> y) \<le> - (x \<sqinter> - - y)"
     by simp
 qed
 
 end
 
 end
 
diff --git a/thys/Transformer_Semantics/Kleisli_Transformers.thy b/thys/Transformer_Semantics/Kleisli_Transformers.thy
--- a/thys/Transformer_Semantics/Kleisli_Transformers.thy
+++ b/thys/Transformer_Semantics/Kleisli_Transformers.thy
@@ -1,859 +1,859 @@
 (* 
   Title: State Transformers and Predicate Transformers Based on the Powerset Monad
   Author: Georg Struth 
   Maintainer: Georg Struth <g.struth@sheffield.ac.uk> 
 *)
 
 section \<open>State Transformers and Predicate Transformers Based on the Powerset Monad\<close>
 
 theory Kleisli_Transformers
 
 imports Powerset_Monad 
         Sup_Inf_Preserving_Transformers
 begin          
 
 
 subsection \<open>Backward Diamonds from Kleisli Arrows\<close>
 
 text \<open>First I verify the embedding of the Kleisli category of the powerset functor into its Eilenberg-Moore category. 
 This functor maps sets to their mus and functions to their Kleisli liftings. But this is just functoriality of dagger!. 
 I model it as a backward diamond operator in the sense of dynamic logic. It corresponds to a strongest postcondition 
 operator. In the parlance of program semantics, this is an embedding of state into prediate transformers.\<close>
 
 notation klift ("bd\<^sub>\<F>")
 
 text \<open>bd stands for backward diamond, the index indicates the setting of Kleisli arrows or nondeterministic 
 functions. ifbd is its inverse.\<close>
 
 abbreviation ifbd :: "('a set \<Rightarrow> 'b set) \<Rightarrow> 'a \<Rightarrow> 'b set" ("bd\<^sup>-\<^sub>\<F>") where 
   "bd\<^sup>-\<^sub>\<F> \<equiv> (\<lambda>\<phi>. \<phi> \<circ> \<eta>)"
 
 lemma fbd_set: "bd\<^sub>\<F> f X = {y. \<exists>x. y \<in> f x \<and> x \<in> X}"
   by (force simp: klift_prop) 
  
 lemma ifbd_set: "bd\<^sup>-\<^sub>\<F> \<phi> x = {y. y \<in> \<phi> {x}}"
   by simp
 
 text \<open>The two functors form a bijective pair.\<close>
 
 lemma fbd_ifbd_inv2: "Sup_pres \<phi> \<Longrightarrow> (bd\<^sub>\<F> \<circ> bd\<^sup>-\<^sub>\<F>) \<phi> = \<phi>" 
 proof -
   assume h: "Sup_pres \<phi>"
   have "(bd\<^sub>\<F> \<circ> bd\<^sup>-\<^sub>\<F>) \<phi> = Sup \<circ> \<P> (\<phi> \<circ> \<eta>)"
     unfolding klift_def by simp
   also have "... = Sup \<circ> \<P> \<phi> \<circ> \<P> \<eta>"
     by (simp add: comp_assoc P_func1)
   also have "... = \<phi> \<circ> Sup \<circ> \<P> \<eta>"
     by (simp add: h)
   also have "... = \<phi> \<circ> id"
     by force
   finally show ?thesis
     by simp
 qed
 
 lemma fbd_ifbd_inv2_inv: "(bd\<^sub>\<F> \<circ> bd\<^sup>-\<^sub>\<F>) \<phi> = \<phi> \<Longrightarrow> Sup_pres \<phi>" 
   unfolding fun_eq_iff comp_def by (metis (no_types, lifting) Inf.INF_cong UN_extend_simps(8) klift_prop)
 
 lemma fbd_ifbd_inv2_iff: "((bd\<^sub>\<F> \<circ> bd\<^sup>-\<^sub>\<F>) \<phi> = \<phi>) = (Sup_pres \<phi>)"
   using fbd_ifbd_inv2 fbd_ifbd_inv2_inv by force
 
 lemma fbd_inj: "inj bd\<^sub>\<F>"
   by (meson inj_on_inverseI klift_eta_inv1)
 
 lemma fbd_inj_iff: "(bd\<^sub>\<F> f = bd\<^sub>\<F> g) = (f = g)"
   by (meson injD fbd_inj)
 
 lemma ifbd_inj: "Sup_pres \<phi> \<Longrightarrow> Sup_pres \<psi> \<Longrightarrow> bd\<^sup>-\<^sub>\<F> \<phi> = bd\<^sup>-\<^sub>\<F> \<psi> \<Longrightarrow> \<phi> = \<psi>"
 proof-
   assume h1: "Sup_pres \<phi>"
   and h2: "Sup_pres \<psi>" 
   and "bd\<^sup>-\<^sub>\<F> \<phi> = bd\<^sup>-\<^sub>\<F> \<psi>"
   hence "(bd\<^sub>\<F> \<circ> bd\<^sup>-\<^sub>\<F>) \<phi> = (bd\<^sub>\<F> \<circ> bd\<^sup>-\<^sub>\<F>) \<psi>"
     by simp
   thus ?thesis
     by (metis h1 h2 fbd_ifbd_inv2)
 qed
 
 lemma ifbd_inj_iff: "Sup_pres \<phi> \<Longrightarrow> Sup_pres \<psi> \<Longrightarrow> (bd\<^sup>-\<^sub>\<F> \<phi> = bd\<^sup>-\<^sub>\<F> \<psi>) = (\<phi> = \<psi>)"
   using ifbd_inj by force
 
 lemma fbd_ifbd_galois: "Sup_pres \<phi> \<Longrightarrow> (bd\<^sup>-\<^sub>\<F> \<phi> = f) = (bd\<^sub>\<F> f = \<phi>)"
   using fbd_ifbd_inv2 by force
 
 lemma fbd_surj: "Sup_pres \<phi> \<Longrightarrow> (\<exists>f. bd\<^sub>\<F> f = \<phi>)"
   using fbd_ifbd_inv2 by auto 
 
 lemma ifbd_surj: "surj bd\<^sup>-\<^sub>\<F>"
   unfolding surj_def by (metis klift_eta_inv1)
 
 text \<open>In addition they preserve the Sup-quantale structure of the powerset algebra. This means that
 morphisms preserve compositions, units and Sups, but not Infs, hence also bottom but not top.\<close>
 
 lemma fbd_comp_pres: "bd\<^sub>\<F> (f \<circ>\<^sub>K g) = bd\<^sub>\<F> g \<circ> bd\<^sub>\<F> f"
   unfolding kcomp_klift klift_prop1 by simp
 
 lemma fbd_Sup_pres: "Sup_pres bd\<^sub>\<F>"
   by (force simp: fun_eq_iff klift_def)
 
 lemma fbd_sup_pres: "sup_pres bd\<^sub>\<F>"
   using Sup_sup_pres fbd_Sup_pres by blast
 
 lemma fbd_Disj: "Sup_pres (bd\<^sub>\<F> f)"
   by (simp add: fbd_ifbd_inv2_inv)
 
 lemma fbd_disj: "sup_pres (bd\<^sub>\<F> f)"
   by (simp add: klift_prop)
 
 lemma fbd_bot_pres: "bot_pres bd\<^sub>\<F>"
   unfolding klift_def by fastforce
 
 lemma fbd_zero_pres2 [simp]: "bd\<^sub>\<F> f {} = {}"
   by (simp add: klift_prop)
 
 lemma fbd_iso: "X \<subseteq> Y \<longrightarrow> bd\<^sub>\<F> f X \<subseteq> bd\<^sub>\<F> f Y"
   by (metis fbd_disj le_iff_sup)
 
 text \<open>The following counterexamples show that Infs are not preserved.\<close>
 
 lemma "top_pres bd\<^sub>\<F>" (*nitpick*)
   oops
 
 lemma "inf_pres bd\<^sub>\<F>" (*nitpick*)
   oops
 
 text \<open>Dual preservation statements hold for ifbd ... and even Inf-preservation.\<close>
 
 lemma ifbd_comp_pres: "Sup_pres \<phi> \<Longrightarrow> bd\<^sup>-\<^sub>\<F> (\<phi> \<circ> \<psi>) = bd\<^sup>-\<^sub>\<F> \<psi> \<circ>\<^sub>K bd\<^sup>-\<^sub>\<F> \<phi>"
   by (smt fbd_ifbd_galois fun.map_comp kcomp_def klift_def)
 
 lemma ifbd_Sup_pres: "Sup_pres bd\<^sup>-\<^sub>\<F>"   
   by (simp add: fun_eq_iff)
 
 lemma ifbd_sup_pres: "sup_pres bd\<^sup>-\<^sub>\<F>"
   by force
 
 lemma ifbd_Inf_pres: "Inf_pres bd\<^sup>-\<^sub>\<F>"
   by (simp add: fun_eq_iff)
 
 lemma ifbd_inf_pres: "inf_pres bd\<^sup>-\<^sub>\<F>"
   by force
 
 lemma ifbd_bot_pres: "bot_pres bd\<^sup>-\<^sub>\<F>"
   by auto
 
 lemma ifbd_top_pres: "top_pres bd\<^sup>-\<^sub>\<F>"
   by auto
 
 text \<open>Preservation of units by the Kleisli lifting has been proved in klift-prop3.\<close>
 
 text \<open>These results estabilish the isomorphism between state and predicate transformers given by backward diamonds.
 The isomorphism preserves the Sup-quantale structure, but not Infs.\<close>
  
 
 
 subsection \<open>Backward Diamonds from Relations\<close>
 
 text \<open>Using the isomorphism between binary relations and Kleisli arrows (or state transformers), it is straightforward
 to define backward diamonds from relations, by composing isomorphisms. It follows that Sup-quantales of binary relations 
 (under relational composition, the identity relation and Sups) are isomorphic to the Sup-quantales of predicate transformers.
 Once again, Infs are not preserved.\<close>
 
 definition rbd :: "('a \<times> 'b) set \<Rightarrow> 'a set \<Rightarrow> 'b set"  ("bd\<^sub>\<R>") where
   "bd\<^sub>\<R> = bd\<^sub>\<F> \<circ> \<F>"
 
 definition irbd :: "('a set \<Rightarrow> 'b set) \<Rightarrow> ('a \<times> 'b) set"  ("bd\<^sup>-\<^sub>\<R>") where
   "bd\<^sup>-\<^sub>\<R> = \<R> \<circ> bd\<^sup>-\<^sub>\<F>"
 
 lemma rbd_Im: "bd\<^sub>\<R> = (``)"
   unfolding rbd_def klift_def r2f_def fun_eq_iff by force
 
 lemma rbd_set: "bd\<^sub>\<R> R X = {y. \<exists>x \<in> X. (x,y) \<in> R}"
   by (force simp: rbd_Im Image_def)
   
 lemma irbd_set: "bd\<^sup>-\<^sub>\<R> \<phi> = {(x,y). y \<in> (\<phi> \<circ> \<eta>) x}"
   by (simp add: irbd_def f2r_def o_def)
 
 lemma irbd_set_var: "bd\<^sup>-\<^sub>\<R> \<phi> = {(x,y). y \<in> \<phi> {x}}"
   by (simp add: irbd_def f2r_def o_def)
 
 lemma rbd_irbd_inv1 [simp]: "bd\<^sup>-\<^sub>\<R> \<circ> bd\<^sub>\<R> = id"
   by (metis (no_types, lifting) comp_eq_dest_lhs eq_id_iff fbd_Disj fbd_ifbd_galois irbd_def r2f_f2r_galois rbd_def)
 
 lemma irbd_rbd_inv2: "Sup_pres \<phi> \<Longrightarrow> (bd\<^sub>\<R> \<circ> bd\<^sup>-\<^sub>\<R>) \<phi> = \<phi>"
   by (metis comp_apply fbd_ifbd_galois irbd_def r2f_f2r_galois rbd_def)
 
 lemma irbd_rbd_inv2_inv: "(bd\<^sub>\<R> \<circ> bd\<^sup>-\<^sub>\<R>) \<phi> = \<phi> \<Longrightarrow> Sup_pres \<phi>"
   by (simp add: rbd_def irbd_def, metis fbd_Disj)
 
 lemma irbd_rbd_inv2_iff: "((bd\<^sub>\<R> \<circ> bd\<^sup>-\<^sub>\<R>) \<phi> = \<phi>) = (Sup_pres \<phi>)"
   using irbd_rbd_inv2 irbd_rbd_inv2_inv by blast
 
 lemma rbd_inj: "inj bd\<^sub>\<R>"
   by (simp add: fbd_inj inj_compose r2f_inj rbd_def)
 
 lemma rbd_translate: "(bd\<^sub>\<R> R = bd\<^sub>\<R> S) = (R = S)"
   by (simp add: rbd_inj inj_eq)
 
 lemma irbd_inj: "Sup_pres \<phi> \<Longrightarrow> Sup_pres \<psi> \<Longrightarrow> bd\<^sup>-\<^sub>\<R> \<phi> = bd\<^sup>-\<^sub>\<R> \<psi> \<Longrightarrow> \<phi> = \<psi>"
   by (metis rbd_Im comp_eq_dest_lhs irbd_rbd_inv2)
 
 lemma irbd_inj_iff: "Sup_pres \<phi> \<Longrightarrow> Sup_pres \<psi> \<Longrightarrow> (bd\<^sup>-\<^sub>\<R> \<phi> = bd\<^sup>-\<^sub>\<R> \<psi>) = (\<phi> = \<psi>)"
   using irbd_inj by force
 
 lemma rbd_surj: "Sup_pres \<phi> \<Longrightarrow> (\<exists>R. bd\<^sub>\<R> R = \<phi>)"
   using irbd_rbd_inv2 by force
 
 lemma irbd_surj: "surj bd\<^sup>-\<^sub>\<R>"
   by (metis UNIV_I fun.set_map imageE rbd_irbd_inv1 surj_def surj_id)
 
 lemma rbd_irbd_galois: "Sup_pres \<phi> \<Longrightarrow> (\<phi> = bd\<^sub>\<R> R) = (R = bd\<^sup>-\<^sub>\<R> \<phi>)"
   by (smt comp_apply fbd_ifbd_galois irbd_def r2f_f2r_galois rbd_def)
 
 lemma rbd_comp_pres: "bd\<^sub>\<R> (R ; S) = bd\<^sub>\<R> S \<circ> bd\<^sub>\<R> R"
   by (simp add: rbd_def r2f_comp_pres fbd_comp_pres)
 
 lemma rbd_Id_pres: "bd\<^sub>\<R> Id = id"
   unfolding rbd_def by simp
 
 lemma rbd_Un_pres: "Sup_pres bd\<^sub>\<R>"
   by (simp add: rbd_def Sup_pres_comp fbd_Sup_pres r2f_Sup_pres)
 
 lemma rbd_un_pres: "sup_pres bd\<^sub>\<R>"
   by (simp add: rbd_def fbd_sup_pres r2f_sup_pres)
 
 lemma "inf_pres bd\<^sub>\<R>" (*nitpick*)
   oops
 
 lemma rbd_disj: "Sup_pres (bd\<^sub>\<R> R)"
   by (simp add: rbd_def fbd_Disj)
 
 lemma rbd_disj2: "sup_pres (bd\<^sub>\<R> R)"
   by (simp add: Image_Un rbd_Im)
 
 lemma rbd_bot_pres: "bot_pres bd\<^sub>\<R>"
   by (simp add: fbd_bot_pres r2f_bot_pres rbd_def)
 
 lemma rbd_zero_pres2 [simp]: "bd\<^sub>\<R> R {} = {}"
   by (simp add: rbd_Im)
 
 lemma rbd_univ: "bd\<^sub>\<R> R UNIV = Range R"
   unfolding rbd_def fun_eq_iff klift_def r2f_def by force
 
 lemma rbd_iso: "X \<subseteq> Y \<Longrightarrow> bd\<^sub>\<R> R X \<subseteq> bd\<^sub>\<R> R Y"
   by (metis le_iff_sup rbd_disj2)
 
 lemma irbd_comp_pres: "Sup_pres \<phi> \<Longrightarrow> bd\<^sup>-\<^sub>\<R> (\<phi> \<circ> \<psi>) = bd\<^sup>-\<^sub>\<R> \<psi> ; bd\<^sup>-\<^sub>\<R> \<phi>"
   by (simp add: ifbd_comp_pres f2r_kcomp_pres irbd_def)
 
 lemma irbd_id_pres [simp]: "bd\<^sup>-\<^sub>\<R> id = Id"
   unfolding irbd_def by simp
 
 lemma irbd_Sup_pres: "Sup_pres bd\<^sup>-\<^sub>\<R>"
   by (simp add: irbd_def Sup_pres_comp ifbd_Sup_pres f2r_Sup_pres)
 
 lemma irbd_sup_pres: "sup_pres bd\<^sup>-\<^sub>\<R>"
   by (simp add: irbd_def ifbd_sup_pres f2r_sup_pres)  
 
 lemma irbd_Inf_pres: "Inf_pres bd\<^sup>-\<^sub>\<R>"
   by (auto simp: fun_eq_iff irbd_def f2r_def)
 
 lemma irbd_inf_pres: "inf_pres bd\<^sup>-\<^sub>\<R>"
   by (auto simp: fun_eq_iff irbd_def f2r_def)
 
 lemma irbd_bot_pres: "bot_pres bd\<^sup>-\<^sub>\<R>"
   by (metis comp_def ifbd_bot_pres f2r_bot_pres irbd_def)
 
 text \<open>This shows that relations are isomorphic to disjunctive forward predicate transformers. In many cases Isabelle picks up
 the composition of morphisms in proofs.\<close>
 
 
 subsection \<open>Forward Boxes on Kleisli Arrows\<close>
 
 text \<open>Forward box operators correspond to weakest liberal preconditions in program semantics. Here, 
 Kleisli arrows are mapped to the opposite of the Eilenberg-Moore category, that is, Inf-lattices. 
 It follows that the Inf-quantale structure is preserved. Modelling opposition is based on the fact 
 that Kleisli arrows can be swapped by going through relations.\<close>
 
 definition ffb :: "('a \<Rightarrow> 'b set) \<Rightarrow> 'b set \<Rightarrow> 'a set" ("fb\<^sub>\<F>") where
   "fb\<^sub>\<F> = \<partial>\<^sub>F \<circ> bd\<^sub>\<F> \<circ> op\<^sub>K" 
 
 text \<open>Here, $\partial_F$ is map-dual, which amounts to De Morgan duality. Hence the forward box operator is
 obtained from the backward diamond by taking the opposite Kleisli arrow, applying the backward diamond, and then De Morgan
 duality.\<close>
 
 lemma ffb_prop: "fb\<^sub>\<F> f = \<partial> \<circ> bd\<^sub>\<F> (op\<^sub>K f) \<circ> \<partial>"
   by (simp add: ffb_def map_dual_def)
 
 lemma ffb_prop_var: "fb\<^sub>\<F> f = uminus \<circ> bd\<^sub>\<F> (op\<^sub>K f) \<circ> uminus"
   by (simp add: dual_set_def ffb_prop)
  
 lemma ffb_fbd_dual: "\<partial> \<circ> fb\<^sub>\<F> f = bd\<^sub>\<F> (op\<^sub>K f) \<circ> \<partial>"
   by (simp add: ffb_prop o_assoc)
 
 text \<open>I give a set-theoretic definition of iffb, because the algebraic one below depends on Inf-preservation.\<close>
 
 definition iffb :: "('b set \<Rightarrow> 'a set) \<Rightarrow> 'a \<Rightarrow> 'b set" ("fb\<^sup>-\<^sub>\<F>") where
   "fb\<^sup>-\<^sub>\<F> \<phi> = (\<lambda>x. \<Inter>{X. x \<in> \<phi> X})"
 
 lemma ffb_set: "fb\<^sub>\<F> f = (\<lambda>Y. {x. f x \<subseteq> Y})" 
   by (force simp: fun_eq_iff ffb_prop_var kop_def klift_def f2r_def r2f_def)
 
 text \<open>Forward boxes and backward diamonds are adjoints.\<close>
 
 lemma ffb_fbd_galois: "(bd\<^sub>\<F> f) \<stileturn> (fb\<^sub>\<F> f)"
   unfolding adj_def ffb_set klift_prop by blast
 
 lemma iffb_inv1: "fb\<^sup>-\<^sub>\<F> \<circ> fb\<^sub>\<F> = id"
   unfolding fun_eq_iff ffb_set iffb_def by force
 
 lemma iffb_inv2_aux: "Inf_pres \<phi> \<Longrightarrow> \<Sqinter>{X. x \<in> \<phi> X} \<subseteq> Y \<Longrightarrow> x \<in> \<phi> Y"
 proof-
   assume "Inf_pres \<phi>"
     and h1: "\<Sqinter>{X. x \<in> \<phi> X} \<subseteq> Y"
   hence h2: "\<forall>X. \<phi> (\<Sqinter>X) = (\<Inter>x \<in> X. \<phi> x)"
     by (metis comp_eq_dest)
   hence "\<phi> (\<Sqinter>{X. x \<in> \<phi> X}) \<subseteq> \<phi> Y"
     by (metis h1 INF_lower2 cInf_eq_minimum mem_Collect_eq order_refl)
   hence "(\<Sqinter>{\<phi> X |X. x \<in> \<phi> X}) \<subseteq> \<phi> Y" 
     by (metis h2 setcompr_eq_image)
   thus ?thesis
     by (force simp add: subset_iff)
 qed
 
 lemma iffb_inv2: "Inf_pres \<phi> \<Longrightarrow> (fb\<^sub>\<F> \<circ> fb\<^sup>-\<^sub>\<F>) \<phi> = \<phi>"
 proof-
   assume h: "Inf_pres \<phi>"
   {fix Y
   have "(fb\<^sub>\<F> \<circ> fb\<^sup>-\<^sub>\<F>) \<phi> Y = {x. \<Sqinter>{X. x \<in> \<phi> X} \<subseteq> Y}"
     by (simp add: ffb_set iffb_def)
   hence "\<And>x. x \<in> (fb\<^sub>\<F> \<circ> fb\<^sup>-\<^sub>\<F>) \<phi> Y \<longleftrightarrow> \<Sqinter>{X. x \<in> \<phi> X} \<subseteq> Y"
     by auto
   hence "\<And>x. x \<in> (fb\<^sub>\<F> \<circ> fb\<^sup>-\<^sub>\<F>) \<phi> Y \<longleftrightarrow> x \<in> \<phi> Y" 
     by (auto simp: h iffb_inv2_aux)
   hence  "(fb\<^sub>\<F> \<circ> fb\<^sup>-\<^sub>\<F>) \<phi> Y = \<phi> Y"
     by (simp add: fun_eq_iff set_eq_iff)}
   thus ?thesis
     unfolding fun_eq_iff by simp
 qed
 
 lemma iffb_inv2_inv: "(fb\<^sub>\<F> \<circ> fb\<^sup>-\<^sub>\<F>) \<phi> = \<phi> \<Longrightarrow> Inf_pres \<phi>"
   by (auto simp: fun_eq_iff ffb_set iffb_def)
 
 lemma iffb_inv2_iff: "((fb\<^sub>\<F> \<circ> fb\<^sup>-\<^sub>\<F>) \<phi> = \<phi>) = (Inf_pres \<phi>)"
   using iffb_inv2 iffb_inv2_inv by blast
 
 lemma ffb_inj: "inj fb\<^sub>\<F>"
   unfolding inj_def by (metis iffb_inv1 pointfree_idE)
 
 lemma ffb_inj_iff: "(fb\<^sub>\<F> f = fb\<^sub>\<F> g) = (f = g)"
   by (simp add: ffb_inj inj_eq)
 
 lemma ffb_iffb_galois: "Inf_pres \<phi> \<Longrightarrow> (fb\<^sup>-\<^sub>\<F> \<phi> = f) = (fb\<^sub>\<F> f = \<phi>)"
   using ffb_inj_iff iffb_inv2 by force
 
 lemma iffb_inj: "Inf_pres \<phi> \<Longrightarrow> Inf_pres \<psi> \<Longrightarrow> fb\<^sup>-\<^sub>\<F> \<phi> = fb\<^sup>-\<^sub>\<F> \<psi>  \<Longrightarrow> \<phi> = \<psi>"
   by (metis ffb_iffb_galois)
 
 lemma iffb_inj_iff: "Inf_pres \<phi> \<Longrightarrow> Inf_pres \<psi> \<Longrightarrow> (fb\<^sup>-\<^sub>\<F> \<phi> = fb\<^sup>-\<^sub>\<F> \<psi>) = (\<phi> = \<psi>)"
   using iffb_inj by blast
 
 lemma ffb_surj: "Inf_pres \<phi>  \<Longrightarrow> (\<exists>f. fb\<^sub>\<F> f = \<phi>)"
   using iffb_inv2 by auto
 
 lemma iffb_surj: "surj fb\<^sup>-\<^sub>\<F>" 
   using surj_def by (metis comp_apply iffb_inv1 surj_id) 
 
 text \<open>This is now the explicit "definition" of iffb, for Inf-preserving transformers.\<close>
 
 lemma iffb_ifbd_dual: "Inf_pres \<phi> \<Longrightarrow> fb\<^sup>-\<^sub>\<F> \<phi> = (op\<^sub>K \<circ> bd\<^sup>-\<^sub>\<F> \<circ> \<partial>\<^sub>F) \<phi>" 
 proof-
   assume h: "Inf_pres \<phi>"
   {fix f
     have "(fb\<^sup>-\<^sub>\<F> \<phi> = f) = ((\<partial>\<^sub>F \<circ> bd\<^sub>\<F> \<circ> op\<^sub>K) f = \<phi>)"
       by (simp add: ffb_def ffb_iffb_galois h)
     also have "... = (op\<^sub>K f = (bd\<^sup>-\<^sub>\<F> \<circ> \<partial>\<^sub>F) \<phi>)"
       by (metis (mono_tags, lifting) comp_apply map_dual_dual ffb_def ffb_surj h klift_eta_inv1 map_dual_dual)
     finally have "(fb\<^sup>-\<^sub>\<F> \<phi> = f) = (f = (op\<^sub>K \<circ> bd\<^sup>-\<^sub>\<F> \<circ> \<partial>\<^sub>F) \<phi>)"
       using kop_galois by auto}
   thus ?thesis
     by blast
 qed
 
 lemma fbd_ffb_dual: "\<partial>\<^sub>F \<circ> fb\<^sub>\<F> \<circ> op\<^sub>K = bd\<^sub>\<F>"
 proof-
   have "\<partial>\<^sub>F \<circ> fb\<^sub>\<F> \<circ> op\<^sub>K = \<partial>\<^sub>F \<circ> \<partial>\<^sub>F \<circ> bd\<^sub>\<F> \<circ> (op\<^sub>K \<circ> op\<^sub>K)"
     by (simp add: comp_def ffb_def)
   thus ?thesis
     by simp
 qed
 
 lemma ffbd_ffb_dual_var: "\<partial> \<circ> bd\<^sub>\<F> f = fb\<^sub>\<F> (op\<^sub>K f) \<circ> \<partial>"
   by (metis ffb_prop fun_dual1 kop_galois)
 
 lemma ifbd_iffb_dual: "Sup_pres \<phi> \<Longrightarrow> bd\<^sup>-\<^sub>\<F> \<phi> = (op\<^sub>K \<circ> fb\<^sup>-\<^sub>\<F> \<circ> \<partial>\<^sub>F) \<phi>" 
 proof-
   assume h: "Sup_pres \<phi>"
   hence "Inf_pres (\<partial>\<^sub>F \<phi>)"
     using Sup_pres_Inf_pres by blast
   hence "(op\<^sub>K \<circ> fb\<^sup>-\<^sub>\<F> \<circ> \<partial>\<^sub>F) \<phi> = (op\<^sub>K \<circ> (op\<^sub>K \<circ> bd\<^sup>-\<^sub>\<F> \<circ> \<partial>\<^sub>F) \<circ> \<partial>\<^sub>F) \<phi>"
     by (simp add: iffb_ifbd_dual)
   thus ?thesis
     by (metis comp_def kop_galois map_dual_dual)
 qed
 
 lemma ffb_kcomp_pres: "fb\<^sub>\<F> (f \<circ>\<^sub>K g) = fb\<^sub>\<F> f \<circ> fb\<^sub>\<F> g"
 proof-
   have "fb\<^sub>\<F> (f \<circ>\<^sub>K g) = \<partial>\<^sub>F (bd\<^sub>\<F> (op\<^sub>K (f \<circ>\<^sub>K g)))"
     by (simp add: ffb_def)
   also have "... = \<partial>\<^sub>F (bd\<^sub>\<F> (op\<^sub>K g \<circ>\<^sub>K op\<^sub>K f))"
     by (simp add: kop_contrav)
   also have "... = \<partial>\<^sub>F (bd\<^sub>\<F> (op\<^sub>K f) \<circ> bd\<^sub>\<F> (op\<^sub>K g))"
     by (simp add: fbd_comp_pres)
   also have "... = \<partial>\<^sub>F (bd\<^sub>\<F> (op\<^sub>K f)) \<circ> \<partial>\<^sub>F (bd\<^sub>\<F> (op\<^sub>K g))"
     by (simp add: map_dual_func1)
   finally show ?thesis
     by (simp add: ffb_def)
 qed
 
 lemma ffb_eta_pres: "fb\<^sub>\<F> \<eta> = id"
   unfolding ffb_def by simp
 
 lemma ffb_Sup_dual: "Sup_dual fb\<^sub>\<F>"
   unfolding ffb_prop_var comp_def fun_eq_iff klift_prop kop_def f2r_def r2f_def converse_def by fastforce
 
 lemma ffb_Sup_dual_var: "fb\<^sub>\<F> (\<Squnion>F) = (\<Sqinter>f \<in> F. fb\<^sub>\<F> f)"
   unfolding ffb_prop_var comp_def fun_eq_iff klift_prop kop_def f2r_def r2f_def converse_def by fastforce
 
 lemma ffb_sup_dual: "sup_dual fb\<^sub>\<F>"
   using ffb_Sup_dual Sup_sup_dual by force
 
 lemma ffb_zero_dual: "fb\<^sub>\<F> \<zeta> = (\<lambda>X. UNIV)" 
   unfolding ffb_prop_var kop_def klift_prop fun_eq_iff f2r_def r2f_def by simp
 
 lemma "inf_dual ffb" (*nitpick*)
   oops
 
 text \<open>Once again, only the Sup-quantale structure is preserved.\<close>
 
 lemma iffb_comp_pres:
   assumes "Inf_pres \<phi>"
   assumes "Inf_pres \<psi>"
   shows "fb\<^sup>-\<^sub>\<F> (\<phi> \<circ> \<psi>) = fb\<^sup>-\<^sub>\<F> \<phi> \<circ>\<^sub>K fb\<^sup>-\<^sub>\<F> \<psi>"
     by (metis assms Inf_pres_comp ffb_iffb_galois ffb_kcomp_pres)
 
 lemma iffb_id_pres: "fb\<^sup>-\<^sub>\<F> id = \<eta>"
   unfolding iffb_def by force
 
 lemma iffb_Inf_dual: 
   assumes "\<forall>\<phi> \<in> \<Phi>. Inf_pres \<phi>"
   shows "(fb\<^sup>-\<^sub>\<F> \<circ> Inf) \<Phi> = (Sup \<circ> \<P> fb\<^sup>-\<^sub>\<F>) \<Phi>" 
 proof-
   have "Inf_pres (\<Sqinter>\<Phi>)"
     using Inf_pres_Inf assms by blast
   hence "(fb\<^sub>\<F> \<circ> fb\<^sup>-\<^sub>\<F>) (\<Sqinter>\<Phi>) = \<Sqinter>(\<P> (fb\<^sub>\<F> \<circ> fb\<^sup>-\<^sub>\<F>) \<Phi>)"
     by (metis (mono_tags, lifting) INF_cong INF_identity_eq assms iffb_inv2)
   hence "(fb\<^sub>\<F> \<circ> fb\<^sup>-\<^sub>\<F>) (\<Sqinter>\<Phi>) = fb\<^sub>\<F> (\<Squnion>(\<P> fb\<^sup>-\<^sub>\<F> \<Phi>))"
     by (simp add: Setcompr_eq_image ffb_Sup_dual_var image_comp)
   thus ?thesis
     by (simp add: ffb_inj_iff)
 qed  
 
 lemma iffb_Sup_dual: "Sup_dual fb\<^sup>-\<^sub>\<F>"
   by (auto simp: iffb_def fun_eq_iff)
  
 lemma iffb_inf_dual: 
   assumes "Inf_pres \<phi>" 
   and "Inf_pres \<psi>"
 shows "fb\<^sup>-\<^sub>\<F> (\<phi> \<sqinter> \<psi>) = fb\<^sup>-\<^sub>\<F> \<phi> \<squnion> fb\<^sup>-\<^sub>\<F> \<psi>"
 proof -
   have f1: "\<phi> \<sqinter> \<psi> = fb\<^sub>\<F> (fb\<^sup>-\<^sub>\<F> \<phi>) \<sqinter> fb\<^sub>\<F> (fb\<^sup>-\<^sub>\<F> \<psi>)"
     using assms iffb_inv2 by fastforce
   have "\<phi> \<sqinter> \<psi> \<circ> Inter = Inter \<circ> \<P> (\<phi> \<sqinter> \<psi>)"
     using assms Inf_pres_inf by blast
   thus ?thesis
     by (simp add: f1 ffb_iffb_galois ffb_sup_dual)
 qed 
 
 lemma  iffb_sup_dual: "fb\<^sup>-\<^sub>\<F> (\<phi> \<squnion> \<psi>) = fb\<^sup>-\<^sub>\<F> \<phi> \<sqinter> fb\<^sup>-\<^sub>\<F> \<psi>"
   unfolding iffb_def by fastforce
 
 lemma iffb_top_pres [simp]: "fb\<^sup>-\<^sub>\<F> \<top> = \<zeta>"
   unfolding iffb_def by simp
 
 text \<open>This establishes the duality between state transformers and weakest liberal preconditions.\<close>
 
 
 subsection \<open>Forward Box Operators from Relations\<close>
 
 text \<open>Once again one can compose isomorphisms, linking weakest liberal preconditions with relational semantics.
 The isomorphism obtained should by now be obvious.\<close>
 
 definition rfb :: "('a \<times> 'b) set \<Rightarrow> 'b set \<Rightarrow> 'a set"  ("fb\<^sub>\<R>") where
   "fb\<^sub>\<R> = fb\<^sub>\<F> \<circ> \<F>"
 
 definition irfb :: "('b set \<Rightarrow> 'a set) \<Rightarrow> ('a \<times> 'b) set" ("fb\<^sup>-\<^sub>\<R>") where
   "fb\<^sup>-\<^sub>\<R> = \<R> \<circ> fb\<^sup>-\<^sub>\<F>"
 
 lemma rfb_rbd_dual: "fb\<^sub>\<R> R = \<partial>\<^sub>F (bd\<^sub>\<R> (R\<inverse>))" 
   by (simp add: rfb_def rbd_def kop_def ffb_def, metis r2f_f2r_galois)
 
 lemma rbd_rfb_dual: "bd\<^sub>\<R> R = \<partial>\<^sub>F (fb\<^sub>\<R> (R\<inverse>))"
   by (simp add: rfb_def rbd_def kop_def ffb_def, metis converse_converse map_dual_dual r2f_f2r_galois)
   
 lemma irfb_irbd_dual: "Inf_pres \<phi> \<Longrightarrow> fb\<^sup>-\<^sub>\<R> \<phi> = ((\<smile>) \<circ> bd\<^sup>-\<^sub>\<R>  \<circ> \<partial>\<^sub>F) \<phi>"
   by (simp add: irfb_def irbd_def iffb_ifbd_dual kop_def r2f_f2r_galois)
 
 lemma irbd_irfb_dual: "Sup_pres \<phi> \<Longrightarrow> bd\<^sup>-\<^sub>\<R> \<phi> = ((\<smile>) \<circ> fb\<^sup>-\<^sub>\<R> \<circ> \<partial>\<^sub>F) \<phi>"
   by (simp add: irfb_def irbd_def ifbd_iffb_dual kop_def r2f_f2r_galois)
 
 lemma rfb_set: "fb\<^sub>\<R> R Y = {x. \<forall>y. (x,y) \<in> R \<longrightarrow> y \<in> Y}"
   unfolding rfb_def ffb_prop_var comp_def klift_def f2r_def r2f_def kop_def by force
 
 lemma rfb_rbd_galois: "(bd\<^sub>\<R> R) \<stileturn> (fb\<^sub>\<R> R)"
   by (simp add: ffb_fbd_galois rbd_def rfb_def)
 
 lemma irfb_set: "fb\<^sup>-\<^sub>\<R> \<phi> = {(x, y). \<forall>Y. x \<in> \<phi> Y \<longrightarrow> y \<in> Y}"
   by (simp add: irfb_def iffb_def f2r_def)
 
 lemma irfb_inv1 [simp]: "fb\<^sup>-\<^sub>\<R> \<circ> fb\<^sub>\<R> = id"
   by (simp add: fun_eq_iff rfb_def irfb_def iffb_inv1 pointfree_idE)
 
 lemma irfb_inv2: "Inf_pres \<phi> \<Longrightarrow> (fb\<^sub>\<R> \<circ> fb\<^sup>-\<^sub>\<R>) \<phi> = \<phi>"
   by (simp add: rfb_def irfb_def, metis ffb_iffb_galois r2f_f2r_galois)
 
 lemma rfb_inj: "inj fb\<^sub>\<R>"
   by (simp add: rfb_def ffb_inj inj_compose r2f_inj)
 
 lemma rfb_inj_iff: "(fb\<^sub>\<R> R = fb\<^sub>\<R> S) = (R = S)"
   by (simp add: rfb_inj inj_eq)
 
 lemma irfb_inj: "Inf_pres \<phi> \<Longrightarrow> Inf_pres \<psi> \<Longrightarrow> fb\<^sup>-\<^sub>\<R> \<phi> = fb\<^sup>-\<^sub>\<R> \<psi> \<Longrightarrow> \<phi> = \<psi>"
   unfolding irfb_def using iffb_inj r2f_inj_iff by fastforce
 
 lemma irfb_inf_iff: "Inf_pres \<phi> \<Longrightarrow> Inf_pres \<psi> \<Longrightarrow> (fb\<^sup>-\<^sub>\<R> \<phi> = fb\<^sup>-\<^sub>\<R> \<psi>) = (\<phi> = \<psi>)"
   using irfb_inj by auto
 
 lemma rfb_surj: "Inf_pres \<phi> \<Longrightarrow> (\<exists>R. fb\<^sub>\<R> R = \<phi>)"
   using irfb_inv2 by fastforce
 
 lemma irfb_surj: "surj fb\<^sup>-\<^sub>\<R>" 
   by (simp add: irfb_def comp_surj f2r_surj iffb_surj cong del: image_cong_simp)
 
 lemma rfb_irfb_galois: "Inf_pres \<phi> \<Longrightarrow> (fb\<^sup>-\<^sub>\<R> \<phi> = R) = (fb\<^sub>\<R> R = \<phi>)"
   by (simp add: irfb_def rfb_def, metis ffb_iffb_galois r2f_f2r_galois)
 
 lemma rfb_comp_pres: "fb\<^sub>\<R> (R ; S) = fb\<^sub>\<R> R \<circ> fb\<^sub>\<R> S"
   by (simp add: ffb_kcomp_pres r2f_comp_pres rfb_def)
 
 lemma rfb_Id_pres [simp]: "fb\<^sub>\<R> Id = id"
   unfolding rfb_def ffb_prop by force
 
 lemma rfb_Sup_dual: "Sup_dual fb\<^sub>\<R>"
 proof- 
   have "fb\<^sub>\<R> \<circ> \<mu> = fb\<^sub>\<F> \<circ> \<F> \<circ> Sup"
     by (simp add: rfb_def)
   also have "... = fb\<^sub>\<F> \<circ> Sup \<circ> \<P> \<F>"
     by (metis fun.map_comp r2f_Sup_pres)
   also have "... = Inf \<circ> \<P> fb\<^sub>\<F> \<circ> \<P> \<F>"
     by (simp add: ffb_Sup_dual)
   also have "... = Inf \<circ> \<P> (fb\<^sub>\<F> \<circ> \<F>)"
     by (simp add: P_func1 comp_assoc)
   finally show ?thesis
     by (simp add: rfb_def)
 qed
 
 lemma rfb_Sup_dual_var: "fb\<^sub>\<R> (\<Squnion>\<phi>) = \<Sqinter>(\<P> fb\<^sub>\<R>) \<phi>"
   by (meson comp_eq_dest rfb_Sup_dual)
 
 lemma rfb_sup_dual: "sup_dual fb\<^sub>\<R>"
   by (simp add: rfb_def ffb_sup_dual r2f_sup_pres)
 
 lemma "inf_dual fb\<^sub>\<R>" (*nitpick*)
   oops
 
 lemma rfb_Inf_pres: "Inf_pres (fb\<^sub>\<R> R)"
   unfolding rfb_def ffb_prop_var comp_def fun_eq_iff klift_def kop_def f2r_def r2f_def converse_def by auto
 
 lemma rfb_inf_pres: "inf_pres (fb\<^sub>\<R> R)"
   unfolding rfb_def ffb_prop_var comp_def fun_eq_iff klift_def kop_def f2r_def r2f_def converse_def by auto
 
 lemma rfb_zero_pres [simp]: "fb\<^sub>\<R> {} X = UNIV"
  unfolding rfb_def ffb_prop_var comp_def fun_eq_iff klift_def kop_def f2r_def r2f_def converse_def by auto
 
 lemma rfb_zero_pres2 [simp]: "fb\<^sub>\<R> R {} = - Domain R"
  unfolding rfb_def ffb_prop_var comp_def fun_eq_iff klift_def kop_def f2r_def r2f_def converse_def by auto
 
 lemma rfb_univ [simp]: "fb\<^sub>\<R> R UNIV = UNIV"
   unfolding rfb_def ffb_prop_var comp_def fun_eq_iff klift_def kop_def f2r_def r2f_def converse_def by auto
 
 lemma rfb_iso: "X \<subseteq> Y \<Longrightarrow> fb\<^sub>\<R> R X \<subseteq> fb\<^sub>\<R> R Y"
   unfolding rfb_def ffb_prop_var comp_def fun_eq_iff klift_def kop_def f2r_def r2f_def converse_def by auto
 
 lemma irfb_comp_pres: 
   assumes "Inf_pres \<phi>"
   assumes "Inf_pres \<psi>"
   shows "fb\<^sup>-\<^sub>\<R> (\<phi> \<circ> \<psi>) = fb\<^sup>-\<^sub>\<R> \<phi> ; fb\<^sup>-\<^sub>\<R> \<psi>"
   by (metis assms rfb_Inf_pres rfb_comp_pres rfb_irfb_galois)
 
 lemma irfb_id_pres [simp]: "fb\<^sup>-\<^sub>\<R> id = Id"
   by (simp add: rfb_irfb_galois)
 
 lemma irfb_Sup_dual: "Sup_dual fb\<^sup>-\<^sub>\<R>"
   by (auto simp: fun_eq_iff irfb_def iffb_def f2r_def)
 
 lemma irfb_Inf_dual: 
   assumes "\<forall>\<phi> \<in> \<Phi>. Inf_pres \<phi>"
   shows "(fb\<^sup>-\<^sub>\<R> \<circ> Inf) \<Phi> = (Sup \<circ> \<P> fb\<^sup>-\<^sub>\<R>) \<Phi>" 
 proof-
   have "Inf_pres (\<Sqinter>\<Phi>)"
     using Inf_pres_Inf assms by blast
   hence  "(fb\<^sub>\<R> \<circ> fb\<^sup>-\<^sub>\<R>) (\<Sqinter>\<Phi>) = \<Sqinter>(\<P> (fb\<^sub>\<R> \<circ> fb\<^sup>-\<^sub>\<R>) \<Phi>)"
     by (smt INF_identity_eq Sup.SUP_cong assms irfb_inv2)
   also have "... = \<Sqinter>(\<P> fb\<^sub>\<R> (\<P> fb\<^sup>-\<^sub>\<R> \<Phi>))"
     by (simp add: image_comp)
   also have "... = fb\<^sub>\<R> (\<Squnion>(\<P> fb\<^sup>-\<^sub>\<R> \<Phi>))"
     by (simp add: rfb_Sup_dual_var)
   finally have "(fb\<^sub>\<R> \<circ> fb\<^sup>-\<^sub>\<R>) (\<Sqinter>\<Phi>) = fb\<^sub>\<R> (\<Squnion>(\<P> fb\<^sup>-\<^sub>\<R> \<Phi>))".
   thus ?thesis
     by (simp add: rfb_inj_iff)
 qed  
 
 lemma irfb_sup_dual: "sup_dual fb\<^sup>-\<^sub>\<R>"
   by (force simp: fun_eq_iff irfb_def iffb_def f2r_def)
 
 lemma irfb_inf_dual: 
   assumes "Inf_pres \<phi>" 
   and "Inf_pres \<psi>"
   shows "fb\<^sup>-\<^sub>\<R> (\<phi> \<sqinter> \<psi>) = fb\<^sup>-\<^sub>\<R> \<phi> \<squnion> fb\<^sup>-\<^sub>\<R> \<psi>"
   by (metis assms rfb_Inf_pres rfb_irfb_galois rfb_sup_dual)
 
 lemma irfb_top_pres [simp]: "bd\<^sup>-\<^sub>\<R> \<top> = UNIV"
   unfolding irbd_def f2r_def by auto
 
 text \<open>Finally, the adjunctions between the predicate transformers considered so far are revisited.\<close>
 
 lemma ffb_fbd_galois_var: "(bd\<^sub>\<F> f X \<subseteq> Y) = (X \<subseteq> fb\<^sub>\<F> f Y)"
   by (meson adj_def ffb_fbd_galois)
 
 lemma rfb_rbd_galois_var: "(bd\<^sub>\<R> R X \<subseteq> Y) = (X \<subseteq> fb\<^sub>\<R> R Y)"
   by (meson adj_def rfb_rbd_galois)
 
 lemma ffb_fbd: "fb\<^sub>\<F> f Y = \<Union>{X. bd\<^sub>\<F> f X \<subseteq> Y}"
   using ffb_fbd_galois_var by fastforce
 
 lemma rfb_rbd: "fb\<^sub>\<R> R Y = \<Union>{X. bd\<^sub>\<R> R X \<subseteq> Y}"
   using rfb_rbd_galois_var by fastforce 
 
 lemma fbd_ffb: "bd\<^sub>\<F> f X = \<Inter>{Y. X \<subseteq> fb\<^sub>\<F> f Y}"
   using ffb_fbd_galois_var by fastforce 
 
 lemma rbd_rfb: "bd\<^sub>\<R> R X = \<Inter>{Y. X \<subseteq> fb\<^sub>\<R> R Y}"
   using rfb_rbd_galois_var by fastforce 
 
 
 subsection \<open>The Remaining Modalities\<close>
 
 text \<open>Finally I set up the remaining dual transformers: forward diamonds and backward boxes. 
 Most properties are not repeated, only some symmetries and dualities are spelled out.\<close>
 
 text \<open>First, forward diamond operators are introduced, from state transformers and relations; together
 with their inverses.\<close>
 
 definition ffd :: "('a \<Rightarrow> 'b set) \<Rightarrow> 'b set \<Rightarrow> 'a set" ("fd\<^sub>\<F>") where 
   "fd\<^sub>\<F> = bd\<^sub>\<F> \<circ> op\<^sub>K"
 
 definition iffd :: "('b set \<Rightarrow> 'a set) \<Rightarrow> 'a \<Rightarrow> 'b set" ("fd\<^sup>-\<^sub>\<F>") where 
   "fd\<^sup>-\<^sub>\<F> = op\<^sub>K \<circ> bd\<^sup>-\<^sub>\<F>"
 
 definition rfd :: "('a \<times> 'b) set \<Rightarrow> 'b set \<Rightarrow> 'a set" ("fd\<^sub>\<R>") where 
   "fd\<^sub>\<R> = fd\<^sub>\<F> \<circ> \<F>"
 
 definition irfd :: "('b set \<Rightarrow> 'a set) \<Rightarrow> ('a \<times> 'b) set" ("fd\<^sup>-\<^sub>\<R>") where 
   "fd\<^sup>-\<^sub>\<R> = \<R> \<circ> fd\<^sup>-\<^sub>\<F>"
 
 text \<open>Second, I introduce forward boxes and their inverses.\<close>
 
 definition fbb :: "('a \<Rightarrow> 'b set) \<Rightarrow> 'a set \<Rightarrow> 'b set" ("bb\<^sub>\<F>") where 
   "bb\<^sub>\<F> = fb\<^sub>\<F> \<circ> op\<^sub>K"
 
 definition ifbb :: "('a  set \<Rightarrow> 'b set) \<Rightarrow> 'a \<Rightarrow> 'b set" ("bb\<^sup>-\<^sub>\<F>") where 
  "bb\<^sup>-\<^sub>\<F> = op\<^sub>K \<circ> fb\<^sup>-\<^sub>\<F>"
 
 definition rbb :: "('a \<times> 'b) set \<Rightarrow> 'a set \<Rightarrow> 'b set" ("bb\<^sub>\<R>") where 
   "bb\<^sub>\<R> = bb\<^sub>\<F> \<circ> \<F>"
 
 definition irbb :: "('a  set \<Rightarrow> 'b set) \<Rightarrow> ('a \<times> 'b) set" ("bb\<^sup>-\<^sub>\<R>") where 
   "bb\<^sup>-\<^sub>\<R> = \<R> \<circ> bb\<^sup>-\<^sub>\<F>"
 
 text \<open>Forward and backward operators of the same type (box or diamond) are related by opposition.\<close>
 
 lemma rfd_rbd: "fd\<^sub>\<R> = bd\<^sub>\<R> \<circ> (\<smile>)"
   by (simp add: rfd_def rbd_def ffd_def kop_def comp_assoc)
 
 lemma irfd_irbd: "fd\<^sup>-\<^sub>\<R> = (\<smile>) \<circ> bd\<^sup>-\<^sub>\<R>"
   by (simp add: irfd_def iffd_def kop_def irbd_def comp_assoc[symmetric])
 
 lemma fbd_ffd: "bd\<^sub>\<F> = fd\<^sub>\<F> \<circ> op\<^sub>K"
   by (simp add: ffd_def kop_def converse_def f2r_def r2f_def klift_def fun_eq_iff)
 
 lemma rbb_rfb: "bb\<^sub>\<R> = fb\<^sub>\<R> \<circ> (\<smile>)"
   by (simp add: rfb_def rbb_def, metis fbb_def kop_def r2f_f2r_galois_var2 rewriteR_comp_comp2)
 
 lemma irbb_irfb: "bb\<^sup>-\<^sub>\<R> = (\<smile>) \<circ> fb\<^sup>-\<^sub>\<R>"
 proof-
   have "bb\<^sup>-\<^sub>\<R> = \<R> \<circ> op\<^sub>K \<circ> fb\<^sup>-\<^sub>\<F>"
     by (simp add: irbb_def ifbb_def o_assoc)
   also have "... = \<R> \<circ> \<F> \<circ> (\<smile>) \<circ> \<R> \<circ> fb\<^sup>-\<^sub>\<F>"
     by (simp add: kop_def o_assoc)
   also have "... = (\<smile>) \<circ> fb\<^sup>-\<^sub>\<R>"
     by (simp add: comp_assoc irfb_def)
   finally show ?thesis.
 qed
 
 text \<open>Complementation is a natural isomorphism between forwards and backward operators of different type.\<close>
 
 lemma ffd_ffb_demorgan: "\<partial> \<circ> fd\<^sub>\<F> f = fb\<^sub>\<F> f \<circ> \<partial>"
   by (simp add: comp_assoc ffb_prop ffd_def)
 
 lemma iffd_iffb_demorgan: "Sup_pres \<phi> \<Longrightarrow> fd\<^sup>-\<^sub>\<F> \<phi> = (fb\<^sup>-\<^sub>\<F> \<circ> \<partial>\<^sub>F) \<phi>"
   by (smt Sup_pres_Inf_pres comp_apply iffb_ifbd_dual iffd_def map_dual_dual)
 
 lemma ffb_ffd_demorgan: "\<partial> \<circ> fb\<^sub>\<F> f = fd\<^sub>\<F> f \<circ> \<partial>"
   by (simp add: ffb_prop ffd_def rewriteL_comp_comp)
 
 lemma iffb_iffd_demorgan: "Inf_pres \<phi> \<Longrightarrow> fb\<^sup>-\<^sub>\<F> \<phi> = (fd\<^sup>-\<^sub>\<F> \<circ> \<partial>\<^sub>F) \<phi>"
   by (simp add: iffb_ifbd_dual iffd_def)
 
 lemma rfd_rfb_demorgan: "\<partial> \<circ> fd\<^sub>\<R> R = fb\<^sub>\<R> R \<circ> \<partial>"
   by (simp add: rfb_def rfd_def ffd_ffb_demorgan)
 
 lemma irfd_irfb_demorgan: "Sup_pres \<phi> \<Longrightarrow> fd\<^sup>-\<^sub>\<R> \<phi> = (fb\<^sup>-\<^sub>\<R> \<circ> \<partial>\<^sub>F) \<phi>"
   by (simp add: irfb_def irfd_def iffd_iffb_demorgan)
 
 lemma rfb_rfd_demorgan: "\<partial> \<circ> fb\<^sub>\<R> R = fd\<^sub>\<R> R \<circ> \<partial>"
   by (simp add: ffb_ffd_demorgan rfb_def rfd_def)
 
 lemma irfb_irfd_demorgan: "Inf_pres \<phi> \<Longrightarrow> fb\<^sup>-\<^sub>\<R> \<phi>  = (fd\<^sup>-\<^sub>\<R> \<circ> \<partial>\<^sub>F) \<phi>"
   by (simp add: irfb_irbd_dual irfd_irbd)
 
 lemma fbd_fbb_demorgan: "\<partial> \<circ> bd\<^sub>\<F> f = bb\<^sub>\<F> f \<circ> \<partial>"   
   by (simp add: fbb_def fbd_ffd ffd_ffb_demorgan)
 
 lemma ifbd_ifbb_demorgan: "Sup_pres \<phi> \<Longrightarrow> bd\<^sup>-\<^sub>\<F> \<phi> = (bb\<^sup>-\<^sub>\<F> \<circ> \<partial>\<^sub>F) \<phi>"
   by (simp add: ifbd_iffb_dual ifbb_def)  
 
 lemma fbb_fbd_demorgan: "\<partial> \<circ> bb\<^sub>\<F> R = bd\<^sub>\<F> R \<circ> \<partial>"
   by (simp add: fbb_def fbd_ffd ffb_ffd_demorgan)
 
 lemma ifbb_ifbd_demorgan: "Inf_pres \<phi> \<Longrightarrow> bb\<^sup>-\<^sub>\<F> \<phi> = (bd\<^sup>-\<^sub>\<F> \<circ> \<partial>\<^sub>F) \<phi>"
 proof-
   assume h: "Inf_pres \<phi>"
   have "bb\<^sup>-\<^sub>\<F> \<phi> = (op\<^sub>K \<circ> fb\<^sup>-\<^sub>\<F>) \<phi>"
     by (simp add: ifbb_def)
   also have "... = (op\<^sub>K \<circ> op\<^sub>K \<circ> bd\<^sup>-\<^sub>\<F>) (\<partial>\<^sub>F \<phi>)"
     by (metis comp_apply h iffb_ifbd_dual) 
   also have "... = (bd\<^sup>-\<^sub>\<F> \<circ> \<partial>\<^sub>F) \<phi>"
     by auto
   finally show ?thesis.
 qed
 
 lemma rbd_rbb_demorgan: "\<partial> \<circ> bd\<^sub>\<R> R = bb\<^sub>\<R> R \<circ> \<partial>"
   by (simp add: rbb_def rbd_def fbd_fbb_demorgan)
 
 lemma irbd_irbb_demorgan: "Sup_pres \<phi> \<Longrightarrow> bd\<^sup>-\<^sub>\<R> \<phi> = (bb\<^sup>-\<^sub>\<R> \<circ> \<partial>\<^sub>F) \<phi>"
   by (simp add: irbb_irfb irbd_irfb_dual)
 
 lemma rbb_rbd_demorgan: "\<partial> \<circ> bb\<^sub>\<R> R = bd\<^sub>\<R> R \<circ> \<partial>"
   by (simp add: rbb_def rbd_def fbb_fbd_demorgan)
 
 lemma irbb_irbd_demorgan: "Inf_pres \<phi> \<Longrightarrow> bb\<^sup>-\<^sub>\<R> \<phi> = (bd\<^sup>-\<^sub>\<R> \<circ> \<partial>\<^sub>F) \<phi>"
   by (simp add: irbb_def irbd_def ifbb_ifbd_demorgan)
 
 text \<open>Further symmetries arise by combination.\<close>
 
 lemma ffd_fbb_dual: "\<partial> \<circ> fd\<^sub>\<F> f = bb\<^sub>\<F> (op\<^sub>K f) \<circ> \<partial>"
   by (simp add: fbd_fbb_demorgan ffd_def)
 
 lemma iffd_ifbb_dual: "Sup_pres \<phi> \<Longrightarrow> fd\<^sup>-\<^sub>\<F> \<phi> = (op\<^sub>K \<circ> bb\<^sup>-\<^sub>\<F> \<circ> \<partial>\<^sub>F) \<phi>"
   by (simp add: ifbd_ifbb_demorgan iffd_def)  
 
 lemma fbb_ffd_dual: "\<partial> \<circ> bb\<^sub>\<F> f = fd\<^sub>\<F> (op\<^sub>K f) \<circ> \<partial>"
   by (simp add: fbd_ffd fbb_fbd_demorgan) 
 
 lemma ifbb_iffd_dual: "Inf_pres \<phi> \<Longrightarrow> bb\<^sup>-\<^sub>\<F> \<phi> = (op\<^sub>K \<circ> fd\<^sup>-\<^sub>\<F> \<circ> \<partial>\<^sub>F) \<phi>"
   by (simp add: ifbb_def iffb_iffd_demorgan)
 
 lemma rfd_rbb_dual: "\<partial> \<circ> fd\<^sub>\<R> R = bb\<^sub>\<R> (R\<inverse>) \<circ> \<partial>"
   by (metis fun_dual1 map_dual_def rbd_rbb_demorgan rfb_rbd_dual rfd_rfb_demorgan)
 
 lemma ifd_ibb_dual: "Sup_pres \<phi> \<Longrightarrow> fd\<^sup>-\<^sub>\<R> \<phi> = ((\<smile>) \<circ> bb\<^sup>-\<^sub>\<R> \<circ> \<partial>\<^sub>F) \<phi>"
   by (simp add: irbb_irfb irbd_irfb_dual irfd_irbd)
  
 lemma rbb_rfd_dual: "\<partial> \<circ> bb\<^sub>\<R> R = fd\<^sub>\<R> (R\<inverse>) \<circ> \<partial>"
   by (simp add: rbb_rfb rfb_rfd_demorgan)
 
 lemma irbb_irfd_dual: "Inf_pres \<phi> \<Longrightarrow> bb\<^sup>-\<^sub>\<R> \<phi> = ((\<smile>) \<circ> fd\<^sup>-\<^sub>\<R> \<circ> \<partial>\<^sub>F) \<phi>"
   by (simp add: irbb_irfb irfb_irbd_dual irfd_irbd)
 
 lemma ffd_iffd_galois: "Sup_pres \<phi> \<Longrightarrow> (\<phi> = fd\<^sub>\<F> f) = (f = fd\<^sup>-\<^sub>\<F> \<phi>)"
   unfolding ffd_def iffd_def by (metis comp_apply fbd_surj klift_eta_inv1 kop_galois)
 
 lemma rfd_irfd_galois: "Sup_pres \<phi> \<Longrightarrow> (\<phi> = fd\<^sub>\<R> R) = (R = fd\<^sup>-\<^sub>\<R> \<phi>)"
   unfolding irfd_def rfd_def by (metis comp_apply ffd_iffd_galois r2f_f2r_galois)
 
 lemma fbb_ifbb_galois: "Inf_pres \<phi> \<Longrightarrow> (\<phi> = bb\<^sub>\<F> f) = (f = bb\<^sup>-\<^sub>\<F> \<phi>)"
   unfolding fbb_def iffb_def by (metis (no_types, lifting) comp_apply ffb_iffb_galois ifbb_ifbd_demorgan iffb_ifbd_dual kop_galois)
 
 lemma rbb_irbb_galois: "Inf_pres \<phi> \<Longrightarrow> (\<phi> = bb\<^sub>\<R> R) = (R = bb\<^sup>-\<^sub>\<R> \<phi>)"
   apply (simp add: rbb_def irbb_def) using fbb_ifbb_galois r2f_f2r_galois by blast
 
 text \<open>Next I spell out the missing adjunctions.\<close>
 
 lemma ffd_ffb_adj: "fd\<^sub>\<F> f \<stileturn> bb\<^sub>\<F> f"
   by (simp add: fbb_def ffb_fbd_galois ffd_def)
 
 lemma ffd_fbb_galois: "(fd\<^sub>\<F> f X \<subseteq> Y) = (X \<subseteq> bb\<^sub>\<F> f Y)"
   by (simp add: fbb_def ffb_fbd_galois_var ffd_def)
 
 lemma rfd_rfb_adj: "fd\<^sub>\<R> f \<stileturn> bb\<^sub>\<R> f"
   by (simp add: ffd_ffb_adj rbb_def rfd_def)
 
 lemma rfd_rbb_galois: "(fd\<^sub>\<R> R X \<subseteq> Y) = (X \<subseteq> bb\<^sub>\<R> R Y)"
   by (simp add: ffd_fbb_galois rbb_def rfd_def)
 
 text \<open>Finally, forward and backward operators of the same type are linked by conjugation.\<close>
 
 lemma ffd_fbd_conjugation: "(fd\<^sub>\<F> f X \<inter> Y = {}) = (X \<inter> bd\<^sub>\<F> f Y = {})"
 proof-
   have "(fd\<^sub>\<F> f X \<inter> Y = {}) = (fd\<^sub>\<F> f X \<subseteq> -Y)"
     by (simp add: disjoint_eq_subset_Compl)
   also have "... = (X \<subseteq> bb\<^sub>\<F> f (-Y))"
     by (simp add: ffd_fbb_galois)
   also have "... = (X \<inter> - bb\<^sub>\<F> f (-Y) = {})"
     by (simp add: disjoint_eq_subset_Compl)
   also have "... = (X \<inter> \<partial> (bb\<^sub>\<F> f (\<partial> Y)) = {})"
     by (simp add: dual_set_def)
   finally show ?thesis
     by (metis (no_types, opaque_lifting) comp_apply fbb_fbd_demorgan invol_dual_var)
 qed
 
 lemma rfd_rbd_conjugation: "((fd\<^sub>\<R> R X) \<inter> Y = {}) = (X \<inter> (bd\<^sub>\<R> R Y) = {})"
   by (simp add: rbd_def rfd_def ffd_fbd_conjugation) 
 
 lemma ffb_fbb_conjugation: "((fb\<^sub>\<F> f X) \<union> Y = UNIV) = (X \<union> (bb\<^sub>\<F> f Y) = UNIV)" 
 proof-
   have "((fb\<^sub>\<F> f X) \<union> Y = UNIV) = (-Y \<subseteq> fb\<^sub>\<F> f X)"
     by blast
   also have "... = (bd\<^sub>\<F> f (\<partial> Y) \<subseteq> X)"
     by (simp add: ffb_fbd_galois_var dual_set_def)
   also have "... = (\<partial> (bb\<^sub>\<F> f Y) \<subseteq> X)"
     by (metis comp_def fbb_fbd_demorgan)
   also have "... = (X \<union> (bb\<^sub>\<F> f Y) = UNIV)"
-    by (metis compl_le_swap2 dual_set_def join_shunt)
+    by (metis compl_le_swap2 dual_set_def sup_shunt)
     finally show ?thesis.
 qed
 
 lemma rfb_rbb_conjugation: "((fb\<^sub>\<R> R X) \<union> Y = UNIV) = (X \<union> (bb\<^sub>\<R> R Y) = UNIV)" 
   by (simp add: rfb_def rbb_def ffb_fbb_conjugation) 
 
 end
\ No newline at end of file
diff --git a/thys/UTP/utp/utp_pred_laws.thy b/thys/UTP/utp/utp_pred_laws.thy
--- a/thys/UTP/utp/utp_pred_laws.thy
+++ b/thys/UTP/utp/utp_pred_laws.thy
@@ -1,963 +1,963 @@
 section \<open> Predicate Calculus Laws \<close>
 
 theory utp_pred_laws
   imports utp_pred
 begin
   
 subsection \<open> Propositional Logic \<close>
   
 text \<open> Showing that predicates form a Boolean Algebra (under the predicate operators as opposed to
   the lattice operators) gives us many useful laws. \<close>
 
-interpretation Lattices.boolean_algebra diff_upred not_upred conj_upred "(\<le>)" "(<)"
+interpretation boolean_algebra diff_upred not_upred conj_upred "(\<le>)" "(<)"
   disj_upred false_upred true_upred
   by (unfold_locales; pred_auto)
 
 lemma taut_true [simp]: "`true`"
   by (pred_auto)
 
 lemma taut_false [simp]: "`false` = False"
   by (pred_auto)
 
 lemma taut_conj: "`A \<and> B` = (`A` \<and> `B`)"
   by (rel_auto)
 
 lemma taut_conj_elim [elim!]:
   "\<lbrakk> `A \<and> B`; \<lbrakk> `A`; `B` \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
   by (rel_auto)
 
 lemma taut_refine_impl: "\<lbrakk> Q \<sqsubseteq> P; `P` \<rbrakk> \<Longrightarrow> `Q`"
   by (rel_auto)
 
 lemma taut_shEx_elim: 
   "\<lbrakk> `(\<^bold>\<exists> x \<bullet> P x)`; \<And> x. \<Sigma> \<sharp> P x; \<And> x. `P x` \<Longrightarrow> Q  \<rbrakk> \<Longrightarrow> Q"
   by (rel_blast)
 
 text \<open> Linking refinement and HOL implication \<close>
 
 lemma refine_prop_intro:
   assumes "\<Sigma> \<sharp> P" "\<Sigma> \<sharp> Q" "`Q` \<Longrightarrow> `P`"
   shows "P \<sqsubseteq> Q"
   using assms
   by (pred_auto)
 
 lemma taut_not: "\<Sigma> \<sharp> P \<Longrightarrow> (\<not> `P`) = `\<not> P`"
   by (rel_auto)
 
 lemma taut_shAll_intro:
   "\<forall> x. `P x` \<Longrightarrow> `\<^bold>\<forall> x \<bullet> P x`"
   by (rel_auto)
 
 lemma taut_shAll_intro_2:
   "\<forall> x y. `P x y` \<Longrightarrow> `\<^bold>\<forall> (x, y) \<bullet> P x y`"
   by (rel_auto)
 
 lemma taut_impl_intro:
   "\<lbrakk> \<Sigma> \<sharp> P; `P` \<Longrightarrow> `Q` \<rbrakk> \<Longrightarrow> `P \<Rightarrow> Q`"
   by (rel_auto)
 
 lemma upred_eval_taut:
   "`P\<lbrakk>\<guillemotleft>b\<guillemotright>/&\<^bold>v\<rbrakk>` = \<lbrakk>P\<rbrakk>\<^sub>eb"
   by (pred_auto)
     
 lemma refBy_order: "P \<sqsubseteq> Q = `Q \<Rightarrow> P`"
   by (pred_auto)
 
 lemma conj_idem [simp]: "((P::'\<alpha> upred) \<and> P) = P"
   by (pred_auto)
 
 lemma disj_idem [simp]: "((P::'\<alpha> upred) \<or> P) = P"
   by (pred_auto)
 
 lemma conj_comm: "((P::'\<alpha> upred) \<and> Q) = (Q \<and> P)"
   by (pred_auto)
 
 lemma disj_comm: "((P::'\<alpha> upred) \<or> Q) = (Q \<or> P)"
   by (pred_auto)
 
 lemma conj_subst: "P = R \<Longrightarrow> ((P::'\<alpha> upred) \<and> Q) = (R \<and> Q)"
   by (pred_auto)
 
 lemma disj_subst: "P = R \<Longrightarrow> ((P::'\<alpha> upred) \<or> Q) = (R \<or> Q)"
   by (pred_auto)
 
 lemma conj_assoc:"(((P::'\<alpha> upred) \<and> Q) \<and> S) = (P \<and> (Q \<and> S))"
   by (pred_auto)
 
 lemma disj_assoc:"(((P::'\<alpha> upred) \<or> Q) \<or> S) = (P \<or> (Q \<or> S))"
   by (pred_auto)
 
 lemma conj_disj_abs:"((P::'\<alpha> upred) \<and> (P \<or> Q)) = P"
   by (pred_auto)
 
 lemma disj_conj_abs:"((P::'\<alpha> upred) \<or> (P \<and> Q)) = P"
   by (pred_auto)
 
 lemma conj_disj_distr:"((P::'\<alpha> upred) \<and> (Q \<or> R)) = ((P \<and> Q) \<or> (P \<and> R))"
   by (pred_auto)
 
 lemma disj_conj_distr:"((P::'\<alpha> upred) \<or> (Q \<and> R)) = ((P \<or> Q) \<and> (P \<or> R))"
   by (pred_auto)
 
 lemma true_disj_zero [simp]:
   "(P \<or> true) = true" "(true \<or> P) = true"
   by (pred_auto)+
 
 lemma true_conj_zero [simp]:
   "(P \<and> false) = false" "(false \<and> P) = false"
   by (pred_auto)+
 
 lemma false_sup [simp]: "false \<sqinter> P = P" "P \<sqinter> false = P"
   by (pred_auto)+
 
 lemma true_inf [simp]: "true \<squnion> P = P" "P \<squnion> true = P"
   by (pred_auto)+
 
 lemma imp_vacuous [simp]: "(false \<Rightarrow> u) = true"
   by (pred_auto)
 
 lemma imp_true [simp]: "(p \<Rightarrow> true) = true"
   by (pred_auto)
 
 lemma true_imp [simp]: "(true \<Rightarrow> p) = p"
   by (pred_auto)
 
 lemma impl_mp1 [simp]: "(P \<and> (P \<Rightarrow> Q)) = (P \<and> Q)"
   by (pred_auto)
 
 lemma impl_mp2 [simp]: "((P \<Rightarrow> Q) \<and> P) = (Q \<and> P)"
   by (pred_auto)
 
 lemma impl_adjoin: "((P \<Rightarrow> Q) \<and> R) = ((P \<and> R \<Rightarrow> Q \<and> R) \<and> R)"
   by (pred_auto)
 
 lemma impl_refine_intro:
   "\<lbrakk> Q\<^sub>1 \<sqsubseteq> P\<^sub>1; P\<^sub>2 \<sqsubseteq> (P\<^sub>1 \<and> Q\<^sub>2) \<rbrakk> \<Longrightarrow> (P\<^sub>1 \<Rightarrow> P\<^sub>2) \<sqsubseteq> (Q\<^sub>1 \<Rightarrow> Q\<^sub>2)"
   by (pred_auto)
 
 lemma spec_refine:
   "Q \<sqsubseteq> (P \<and> R) \<Longrightarrow> (P \<Rightarrow> Q) \<sqsubseteq> R"
   by (rel_auto)
     
 lemma impl_disjI: "\<lbrakk> `P \<Rightarrow> R`; `Q \<Rightarrow> R` \<rbrakk> \<Longrightarrow> `(P \<or> Q) \<Rightarrow> R`"
   by (rel_auto)
 
 lemma conditional_iff:
   "(P \<Rightarrow> Q) = (P \<Rightarrow> R) \<longleftrightarrow> `P \<Rightarrow> (Q \<Leftrightarrow> R)`"
   by (pred_auto)
 
 lemma p_and_not_p [simp]: "(P \<and> \<not> P) = false"
   by (pred_auto)
 
 lemma p_or_not_p [simp]: "(P \<or> \<not> P) = true"
   by (pred_auto)
 
 lemma p_imp_p [simp]: "(P \<Rightarrow> P) = true"
   by (pred_auto)
 
 lemma p_iff_p [simp]: "(P \<Leftrightarrow> P) = true"
   by (pred_auto)
 
 lemma p_imp_false [simp]: "(P \<Rightarrow> false) = (\<not> P)"
   by (pred_auto)
 
 lemma not_conj_deMorgans [simp]: "(\<not> ((P::'\<alpha> upred) \<and> Q)) = ((\<not> P) \<or> (\<not> Q))"
   by (pred_auto)
 
 lemma not_disj_deMorgans [simp]: "(\<not> ((P::'\<alpha> upred) \<or> Q)) = ((\<not> P) \<and> (\<not> Q))"
   by (pred_auto)
 
 lemma conj_disj_not_abs [simp]: "((P::'\<alpha> upred) \<and> ((\<not>P) \<or> Q)) = (P \<and> Q)"
   by (pred_auto)
 
 lemma subsumption1:
   "`P \<Rightarrow> Q` \<Longrightarrow> (P \<or> Q) = Q"
   by (pred_auto)
 
 lemma subsumption2:
   "`Q \<Rightarrow> P` \<Longrightarrow> (P \<or> Q) = P"
   by (pred_auto)
 
 lemma neg_conj_cancel1: "(\<not> P \<and> (P \<or> Q)) = (\<not> P \<and> Q :: '\<alpha> upred)"
   by (pred_auto)
 
 lemma neg_conj_cancel2: "(\<not> Q \<and> (P \<or> Q)) = (\<not> Q \<and> P :: '\<alpha> upred)"
   by (pred_auto)
 
 lemma double_negation [simp]: "(\<not> \<not> (P::'\<alpha> upred)) = P"
   by (pred_auto)
 
 lemma true_not_false [simp]: "true \<noteq> false" "false \<noteq> true"
   by (pred_auto)+
 
 lemma closure_conj_distr: "([P]\<^sub>u \<and> [Q]\<^sub>u) = [P \<and> Q]\<^sub>u"
   by (pred_auto)
 
 lemma closure_imp_distr: "`[P \<Rightarrow> Q]\<^sub>u \<Rightarrow> [P]\<^sub>u \<Rightarrow> [Q]\<^sub>u`"
   by (pred_auto)
 
 lemma true_iff [simp]: "(P \<Leftrightarrow> true) = P"
   by (pred_auto)
 
 lemma taut_iff_eq:
   "`P \<Leftrightarrow> Q` \<longleftrightarrow> (P = Q)"
   by (pred_auto)
     
 lemma impl_alt_def: "(P \<Rightarrow> Q) = (\<not> P \<or> Q)"
   by (pred_auto)
     
 subsection \<open> Lattice laws \<close>
     
 lemma uinf_or:
   fixes P Q :: "'\<alpha> upred"
   shows "(P \<sqinter> Q) = (P \<or> Q)"
   by (pred_auto)
 
 lemma usup_and:
   fixes P Q :: "'\<alpha> upred"
   shows "(P \<squnion> Q) = (P \<and> Q)"
   by (pred_auto)
 
 lemma UINF_alt_def:
   "(\<Sqinter> i | A(i) \<bullet> P(i)) = (\<Sqinter> i \<bullet> A(i) \<and> P(i))"
   by (rel_auto)
     
 lemma USUP_true [simp]: "(\<Squnion> P | F(P) \<bullet> true) = true"
   by (pred_auto)
 
 lemma UINF_mem_UNIV [simp]: "(\<Sqinter> x\<in>UNIV \<bullet> P(x)) = (\<Sqinter> x \<bullet> P(x))"
   by (pred_auto)
 
 lemma USUP_mem_UNIV [simp]: "(\<Squnion> x\<in>UNIV \<bullet> P(x)) = (\<Squnion> x \<bullet> P(x))"
   by (pred_auto)
 
 lemma USUP_false [simp]: "(\<Squnion> i \<bullet> false) = false"
   by (pred_simp)
 
 lemma USUP_mem_false [simp]: "I \<noteq> {} \<Longrightarrow> (\<Squnion> i\<in>I \<bullet> false) = false"
   by (rel_simp)
 
 lemma USUP_where_false [simp]: "(\<Squnion> i | false \<bullet> P(i)) = true"
   by (rel_auto)
 
 lemma UINF_true [simp]: "(\<Sqinter> i \<bullet> true) = true"
   by (pred_simp)
 
 lemma UINF_ind_const [simp]: 
   "(\<Sqinter> i \<bullet> P) = P"
   by (rel_auto)
     
 lemma UINF_mem_true [simp]: "A \<noteq> {} \<Longrightarrow> (\<Sqinter> i\<in>A \<bullet> true) = true"
   by (pred_auto)
 
 lemma UINF_false [simp]: "(\<Sqinter> i | P(i) \<bullet> false) = false"
   by (pred_auto)
 
 lemma UINF_where_false [simp]: "(\<Sqinter> i | false \<bullet> P(i)) = false"
   by (rel_auto)
 
 lemma UINF_cong_eq:
   "\<lbrakk> \<And> x. P\<^sub>1(x) = P\<^sub>2(x); \<And> x. `P\<^sub>1(x) \<Rightarrow> Q\<^sub>1(x) =\<^sub>u Q\<^sub>2(x)` \<rbrakk> \<Longrightarrow>
         (\<Sqinter> x | P\<^sub>1(x) \<bullet> Q\<^sub>1(x)) = (\<Sqinter> x | P\<^sub>2(x) \<bullet> Q\<^sub>2(x))"
  by (unfold UINF_def, pred_simp, metis)
 
 lemma UINF_as_Sup: "(\<Sqinter> P \<in> \<P> \<bullet> P) = \<Sqinter> \<P>"
   apply (simp add: upred_defs bop.rep_eq lit.rep_eq Sup_uexpr_def)
   apply (pred_simp)
   apply (rule cong[of "Sup"])
    apply (auto)
   done
 
 lemma UINF_as_Sup_collect: "(\<Sqinter>P\<in>A \<bullet> f(P)) = (\<Sqinter>P\<in>A. f(P))"
   apply (simp add: upred_defs bop.rep_eq lit.rep_eq Sup_uexpr_def)
   apply (pred_simp)
   apply (simp add: Setcompr_eq_image)
   done
 
 lemma UINF_as_Sup_collect': "(\<Sqinter>P \<bullet> f(P)) = (\<Sqinter>P. f(P))"
   apply (simp add: upred_defs bop.rep_eq lit.rep_eq Sup_uexpr_def)
   apply (pred_simp)
   apply (simp add: full_SetCompr_eq)
   done
 
 lemma UINF_as_Sup_image: "(\<Sqinter> P | \<guillemotleft>P\<guillemotright> \<in>\<^sub>u \<guillemotleft>A\<guillemotright> \<bullet> f(P)) = \<Sqinter> (f ` A)"
   apply (simp add: upred_defs bop.rep_eq lit.rep_eq Sup_uexpr_def)
   apply (pred_simp)
   apply (rule cong[of "Sup"])
    apply (auto)
   done
 
 lemma USUP_as_Inf: "(\<Squnion> P \<in> \<P> \<bullet> P) = \<Squnion> \<P>"
   apply (simp add: upred_defs bop.rep_eq lit.rep_eq Inf_uexpr_def)
   apply (pred_simp)
   apply (rule cong[of "Inf"])
    apply (auto)
   done
 
 lemma USUP_as_Inf_collect: "(\<Squnion>P\<in>A \<bullet> f(P)) = (\<Squnion>P\<in>A. f(P))"
   apply (pred_simp)
   apply (simp add: Setcompr_eq_image)
   done
 
 lemma USUP_as_Inf_collect': "(\<Squnion>P \<bullet> f(P)) = (\<Squnion>P. f(P))"
   apply (simp add: upred_defs bop.rep_eq lit.rep_eq Sup_uexpr_def)
   apply (pred_simp)
   apply (simp add: full_SetCompr_eq)
   done
 
 lemma USUP_as_Inf_image: "(\<Squnion> P \<in> \<P> \<bullet> f(P)) = \<Squnion> (f ` \<P>)"
   apply (simp add: upred_defs bop.rep_eq lit.rep_eq Inf_uexpr_def)
   apply (pred_simp)
   apply (rule cong[of "Inf"])
    apply (auto)
   done
 
 lemma USUP_image_eq [simp]: "USUP (\<lambda>i. \<guillemotleft>i\<guillemotright> \<in>\<^sub>u \<guillemotleft>f ` A\<guillemotright>) g = (\<Squnion> i\<in>A \<bullet> g(f(i)))"
   by (pred_simp, rule_tac cong[of Inf Inf], auto)
 
 lemma UINF_image_eq [simp]: "UINF (\<lambda>i. \<guillemotleft>i\<guillemotright> \<in>\<^sub>u \<guillemotleft>f ` A\<guillemotright>) g = (\<Sqinter> i\<in>A \<bullet> g(f(i)))"
   by (pred_simp, rule_tac cong[of Sup Sup], auto)
 
 lemma subst_continuous [usubst]: "\<sigma> \<dagger> (\<Sqinter> A) = (\<Sqinter> {\<sigma> \<dagger> P | P. P \<in> A})"
   by (simp add: UINF_as_Sup[THEN sym] usubst setcompr_eq_image)
 
 lemma not_UINF: "(\<not> (\<Sqinter> i\<in>A\<bullet> P(i))) = (\<Squnion> i\<in>A\<bullet> \<not> P(i))"
   by (pred_auto)
 
 lemma not_USUP: "(\<not> (\<Squnion> i\<in>A\<bullet> P(i))) = (\<Sqinter> i\<in>A\<bullet> \<not> P(i))"
   by (pred_auto)
 
 lemma not_UINF_ind: "(\<not> (\<Sqinter> i \<bullet> P(i))) = (\<Squnion> i \<bullet> \<not> P(i))"
   by (pred_auto)
 
 lemma not_USUP_ind: "(\<not> (\<Squnion> i \<bullet> P(i))) = (\<Sqinter> i \<bullet> \<not> P(i))"
   by (pred_auto)
 
 lemma UINF_empty [simp]: "(\<Sqinter> i \<in> {} \<bullet> P(i)) = false"
   by (pred_auto)
 
 lemma UINF_insert [simp]: "(\<Sqinter> i\<in>insert x xs \<bullet> P(i)) = (P(x) \<sqinter> (\<Sqinter> i\<in>xs \<bullet> P(i)))"
   apply (pred_simp)
   apply (subst Sup_insert[THEN sym])
   apply (rule_tac cong[of Sup Sup])
    apply (auto)
   done
     
 lemma UINF_atLeast_first:
   "P(n) \<sqinter> (\<Sqinter> i \<in> {Suc n..} \<bullet> P(i)) = (\<Sqinter> i \<in> {n..} \<bullet> P(i))"
 proof -
   have "insert n {Suc n..} = {n..}"
     by (auto)
   thus ?thesis
     by (metis UINF_insert)
 qed  
 
 lemma UINF_atLeast_Suc:
   "(\<Sqinter> i \<in> {Suc m..} \<bullet> P(i)) = (\<Sqinter> i \<in> {m..} \<bullet> P(Suc i))"
   by (rel_simp, metis (full_types) Suc_le_D not_less_eq_eq)
 
 lemma USUP_empty [simp]: "(\<Squnion> i \<in> {} \<bullet> P(i)) = true"
   by (pred_auto)
 
 lemma USUP_insert [simp]: "(\<Squnion> i\<in>insert x xs \<bullet> P(i)) = (P(x) \<squnion> (\<Squnion> i\<in>xs \<bullet> P(i)))"
   apply (pred_simp)
   apply (subst Inf_insert[THEN sym])
   apply (rule_tac cong[of Inf Inf])
    apply (auto)
   done
 
 lemma USUP_atLeast_first:
   "(P(n) \<and> (\<Squnion> i \<in> {Suc n..} \<bullet> P(i))) = (\<Squnion> i \<in> {n..} \<bullet> P(i))"
 proof -
   have "insert n {Suc n..} = {n..}"
     by (auto)
   thus ?thesis
     by (metis USUP_insert conj_upred_def)
 qed
 
 lemma USUP_atLeast_Suc:
   "(\<Squnion> i \<in> {Suc m..} \<bullet> P(i)) = (\<Squnion> i \<in> {m..} \<bullet> P(Suc i))"
   by (rel_simp, metis (full_types) Suc_le_D not_less_eq_eq)
 
 lemma conj_UINF_dist:
   "(P \<and> (\<Sqinter> Q\<in>S \<bullet> F(Q))) = (\<Sqinter> Q\<in>S \<bullet> P \<and> F(Q))"
   by (simp add: upred_defs bop.rep_eq lit.rep_eq, pred_auto)
 
 lemma conj_UINF_ind_dist:
   "(P \<and> (\<Sqinter> Q \<bullet> F(Q))) = (\<Sqinter> Q \<bullet> P \<and> F(Q))"
   by pred_auto
 
 lemma disj_UINF_dist:
   "S \<noteq> {} \<Longrightarrow> (P \<or> (\<Sqinter> Q\<in>S \<bullet> F(Q))) = (\<Sqinter> Q\<in>S \<bullet> P \<or> F(Q))"
   by (simp add: upred_defs bop.rep_eq lit.rep_eq, pred_auto)
 
 lemma UINF_conj_UINF [simp]: 
   "((\<Sqinter> i\<in>I \<bullet> P(i)) \<or> (\<Sqinter> i\<in>I \<bullet> Q(i))) = (\<Sqinter> i\<in>I \<bullet> P(i) \<or> Q(i))"
   by (rel_auto)
 
 lemma conj_USUP_dist:
   "S \<noteq> {} \<Longrightarrow> (P \<and> (\<Squnion> Q\<in>S \<bullet> F(Q))) = (\<Squnion> Q\<in>S \<bullet> P \<and> F(Q))"
   by (subst uexpr_eq_iff, auto simp add: conj_upred_def USUP.rep_eq inf_uexpr.rep_eq bop.rep_eq lit.rep_eq)
 
 lemma USUP_conj_USUP [simp]: "((\<Squnion> P \<in> A \<bullet> F(P)) \<and> (\<Squnion> P \<in> A \<bullet> G(P))) = (\<Squnion> P \<in> A \<bullet> F(P) \<and> G(P))"
   by (simp add: upred_defs bop.rep_eq lit.rep_eq, pred_auto)
 
 lemma UINF_all_cong [cong]:
   assumes "\<And> P. F(P) = G(P)"
   shows "(\<Sqinter> P \<bullet> F(P)) = (\<Sqinter> P \<bullet> G(P))"
   by (simp add: UINF_as_Sup_collect assms)
 
 lemma UINF_cong:
   assumes "\<And> P. P \<in> A \<Longrightarrow> F(P) = G(P)"
   shows "(\<Sqinter> P\<in>A \<bullet> F(P)) = (\<Sqinter> P\<in>A \<bullet> G(P))"
   by (simp add: UINF_as_Sup_collect assms)
 
 lemma USUP_all_cong:
   assumes "\<And> P. F(P) = G(P)"
   shows "(\<Squnion> P \<bullet> F(P)) = (\<Squnion> P \<bullet> G(P))"
   by (simp add: assms)
     
 lemma USUP_cong:
   assumes "\<And> P. P \<in> A \<Longrightarrow> F(P) = G(P)"
   shows "(\<Squnion> P\<in>A \<bullet> F(P)) = (\<Squnion> P\<in>A \<bullet> G(P))"
   by (simp add: USUP_as_Inf_collect assms)
 
 lemma UINF_subset_mono: "A \<subseteq> B \<Longrightarrow> (\<Sqinter> P\<in>B \<bullet> F(P)) \<sqsubseteq> (\<Sqinter> P\<in>A \<bullet> F(P))"
   by (simp add: SUP_subset_mono UINF_as_Sup_collect)
 
 lemma USUP_subset_mono: "A \<subseteq> B \<Longrightarrow> (\<Squnion> P\<in>A \<bullet> F(P)) \<sqsubseteq> (\<Squnion> P\<in>B \<bullet> F(P))"
   by (simp add: INF_superset_mono USUP_as_Inf_collect)
 
 lemma UINF_impl: "(\<Sqinter> P\<in>A \<bullet> F(P) \<Rightarrow> G(P)) = ((\<Squnion> P\<in>A \<bullet> F(P)) \<Rightarrow> (\<Sqinter> P\<in>A \<bullet> G(P)))"
   by (pred_auto)
 
 lemma USUP_is_forall: "(\<Squnion> x \<bullet> P(x)) = (\<^bold>\<forall> x \<bullet> P(x))"
   by (pred_simp)
 
 lemma USUP_ind_is_forall: "(\<Squnion> x\<in>A \<bullet> P(x)) = (\<^bold>\<forall> x\<in>\<guillemotleft>A\<guillemotright> \<bullet> P(x))"
   by (pred_auto)
 
 lemma UINF_is_exists: "(\<Sqinter> x \<bullet> P(x)) = (\<^bold>\<exists> x \<bullet> P(x))"
   by (pred_simp)
 
 lemma UINF_all_nats [simp]:
   fixes P :: "nat \<Rightarrow> '\<alpha> upred"
   shows "(\<Sqinter> n \<bullet> \<Sqinter> i\<in>{0..n} \<bullet> P(i)) = (\<Sqinter> n \<bullet> P(n))"
   by (pred_auto)
 
 lemma USUP_all_nats [simp]:
   fixes P :: "nat \<Rightarrow> '\<alpha> upred"
   shows "(\<Squnion> n \<bullet> \<Squnion> i\<in>{0..n} \<bullet> P(i)) = (\<Squnion> n \<bullet> P(n))"
   by (pred_auto)
 
 lemma UINF_upto_expand_first:
   "m < n \<Longrightarrow> (\<Sqinter> i \<in> {m..<n} \<bullet> P(i)) = ((P(m) :: '\<alpha> upred) \<or> (\<Sqinter> i \<in> {Suc m..<n} \<bullet> P(i)))"
   apply (rel_auto) using Suc_leI le_eq_less_or_eq by auto
 
 lemma UINF_upto_expand_last:
   "(\<Sqinter> i \<in> {0..<Suc(n)} \<bullet> P(i)) = ((\<Sqinter> i \<in> {0..<n} \<bullet> P(i)) \<or> P(n))"
   apply (rel_auto)
   using less_SucE by blast
     
 lemma UINF_Suc_shift: "(\<Sqinter> i \<in> {Suc 0..<Suc n} \<bullet> P(i)) = (\<Sqinter> i \<in> {0..<n} \<bullet> P(Suc i))"
   apply (rel_simp)
   apply (rule cong[of Sup], auto)
   using less_Suc_eq_0_disj by auto
 
 lemma USUP_upto_expand_first:
   "(\<Squnion> i \<in> {0..<Suc(n)} \<bullet> P(i)) = (P(0) \<and> (\<Squnion> i \<in> {1..<Suc(n)} \<bullet> P(i)))"
   apply (rel_auto)
   using not_less by auto
 
 lemma USUP_Suc_shift: "(\<Squnion> i \<in> {Suc 0..<Suc n} \<bullet> P(i)) = (\<Squnion> i \<in> {0..<n} \<bullet> P(Suc i))"
   apply (rel_simp)
   apply (rule cong[of Inf], auto)
   using less_Suc_eq_0_disj by auto
     
 lemma UINF_list_conv:
   "(\<Sqinter> i \<in> {0..<length(xs)} \<bullet> f (xs ! i)) = foldr (\<or>) (map f xs) false"    
   apply (induct xs)
    apply (rel_auto)
   apply (simp add: UINF_upto_expand_first UINF_Suc_shift)
   done
 
 lemma USUP_list_conv:
   "(\<Squnion> i \<in> {0..<length(xs)} \<bullet> f (xs ! i)) = foldr (\<and>) (map f xs) true"    
   apply (induct xs)
    apply (rel_auto)
   apply (simp_all add: USUP_upto_expand_first USUP_Suc_shift)
   done
 
 lemma UINF_refines:
   "\<lbrakk> \<And> i. i\<in>I \<Longrightarrow> P \<sqsubseteq> Q i \<rbrakk> \<Longrightarrow> P \<sqsubseteq> (\<Sqinter> i\<in>I \<bullet> Q i)"
   by (simp add: UINF_as_Sup_collect, metis SUP_least)
 
 lemma UINF_refines':
   assumes "\<And> i. P \<sqsubseteq> Q(i)" 
   shows "P \<sqsubseteq> (\<Sqinter> i \<bullet> Q(i))"
   using assms
   apply (rel_auto) using Sup_le_iff by fastforce
 
 lemma UINF_pred_ueq [simp]: 
   "(\<Sqinter> x | \<guillemotleft>x\<guillemotright> =\<^sub>u v \<bullet> P(x)) = (P x)\<lbrakk>x\<rightarrow>v\<rbrakk>"
   by (pred_auto)
 
 lemma UINF_pred_lit_eq [simp]: 
   "(\<Sqinter> x | \<guillemotleft>x = v\<guillemotright> \<bullet> P(x)) = (P v)"
   by (pred_auto)
 
 subsection \<open> Equality laws \<close>
 
 lemma eq_upred_refl [simp]: "(x =\<^sub>u x) = true"
   by (pred_auto)
 
 lemma eq_upred_sym: "(x =\<^sub>u y) = (y =\<^sub>u x)"
   by (pred_auto)
 
 lemma eq_cong_left:
   assumes "vwb_lens x" "$x \<sharp> Q" "$x\<acute> \<sharp> Q" "$x \<sharp> R" "$x\<acute> \<sharp> R"
   shows "(($x\<acute> =\<^sub>u $x \<and> Q) = ($x\<acute> =\<^sub>u $x \<and> R)) \<longleftrightarrow> (Q = R)"
   using assms
   by (pred_simp, (meson mwb_lens_def vwb_lens_mwb weak_lens_def)+)
 
 lemma conj_eq_in_var_subst:
   fixes x :: "('a \<Longrightarrow> '\<alpha>)"
   assumes "vwb_lens x"
   shows "(P \<and> $x =\<^sub>u v) = (P\<lbrakk>v/$x\<rbrakk> \<and> $x =\<^sub>u v)"
   using assms
   by (pred_simp, (metis vwb_lens_wb wb_lens.get_put)+)
 
 lemma conj_eq_out_var_subst:
   fixes x :: "('a \<Longrightarrow> '\<alpha>)"
   assumes "vwb_lens x"
   shows "(P \<and> $x\<acute> =\<^sub>u v) = (P\<lbrakk>v/$x\<acute>\<rbrakk> \<and> $x\<acute> =\<^sub>u v)"
   using assms
   by (pred_simp, (metis vwb_lens_wb wb_lens.get_put)+)
 
 lemma conj_pos_var_subst:
   assumes "vwb_lens x"
   shows "($x \<and> Q) = ($x \<and> Q\<lbrakk>true/$x\<rbrakk>)"
   using assms
   by (pred_auto, metis (full_types) vwb_lens_wb wb_lens.get_put, metis (full_types) vwb_lens_wb wb_lens.get_put)
 
 lemma conj_neg_var_subst:
   assumes "vwb_lens x"
   shows "(\<not> $x \<and> Q) = (\<not> $x \<and> Q\<lbrakk>false/$x\<rbrakk>)"
   using assms
   by (pred_auto, metis (full_types) vwb_lens_wb wb_lens.get_put, metis (full_types) vwb_lens_wb wb_lens.get_put)
 
 lemma upred_eq_true [simp]: "(p =\<^sub>u true) = p"
   by (pred_auto)
 
 lemma upred_eq_false [simp]: "(p =\<^sub>u false) = (\<not> p)"
   by (pred_auto)
 
 lemma upred_true_eq [simp]: "(true =\<^sub>u p) = p"
   by (pred_auto)
 
 lemma upred_false_eq [simp]: "(false =\<^sub>u p) = (\<not> p)"
   by (pred_auto)
 
 lemma conj_var_subst:
   assumes "vwb_lens x"
   shows "(P \<and> var x =\<^sub>u v) = (P\<lbrakk>v/x\<rbrakk> \<and> var x =\<^sub>u v)"
   using assms
   by (pred_simp, (metis (full_types) vwb_lens_def wb_lens.get_put)+)
 
 subsection \<open> HOL Variable Quantifiers \<close>
     
 lemma shEx_unbound [simp]: "(\<^bold>\<exists> x \<bullet> P) = P"
   by (pred_auto)
 
 lemma shEx_bool [simp]: "shEx P = (P True \<or> P False)"
   by (pred_simp, metis (full_types))
 
 lemma shEx_commute: "(\<^bold>\<exists> x \<bullet> \<^bold>\<exists> y \<bullet> P x y) = (\<^bold>\<exists> y \<bullet> \<^bold>\<exists> x \<bullet> P x y)"
   by (pred_auto)
 
 lemma shEx_cong: "\<lbrakk> \<And> x. P x = Q x \<rbrakk> \<Longrightarrow> shEx P = shEx Q"
   by (pred_auto)
 
 lemma shEx_insert: "(\<^bold>\<exists> x \<in> insert\<^sub>u y A \<bullet> P(x)) = (P(x)\<lbrakk>x\<rightarrow>y\<rbrakk> \<or> (\<^bold>\<exists> x \<in> A \<bullet> P(x)))"
   by (pred_auto)
 
 lemma shEx_one_point: "(\<^bold>\<exists> x \<bullet> \<guillemotleft>x\<guillemotright> =\<^sub>u v \<and> P(x)) = P(x)\<lbrakk>x\<rightarrow>v\<rbrakk>"
   by (rel_auto)
 
 lemma shAll_unbound [simp]: "(\<^bold>\<forall> x \<bullet> P) = P"
   by (pred_auto)
 
 lemma shAll_bool [simp]: "shAll P = (P True \<and> P False)"
   by (pred_simp, metis (full_types))
 
 lemma shAll_cong: "\<lbrakk> \<And> x. P x = Q x \<rbrakk> \<Longrightarrow> shAll P = shAll Q"
   by (pred_auto)
     
 text \<open> Quantifier lifting \<close>
 
 named_theorems uquant_lift
 
 lemma shEx_lift_conj_1 [uquant_lift]:
   "((\<^bold>\<exists> x \<bullet> P(x)) \<and> Q) = (\<^bold>\<exists> x \<bullet> P(x) \<and> Q)"
   by (pred_auto)
 
 lemma shEx_lift_conj_2 [uquant_lift]:
   "(P \<and> (\<^bold>\<exists> x \<bullet> Q(x))) = (\<^bold>\<exists> x \<bullet> P \<and> Q(x))"
   by (pred_auto)
 
 subsection \<open> Case Splitting \<close>
   
 lemma eq_split_subst:
   assumes "vwb_lens x"
   shows "(P = Q) \<longleftrightarrow> (\<forall> v. P\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<rbrakk> = Q\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<rbrakk>)"
   using assms
   by (pred_auto, metis vwb_lens_wb wb_lens.source_stability)
 
 lemma eq_split_substI:
   assumes "vwb_lens x" "\<And> v. P\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<rbrakk> = Q\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<rbrakk>"
   shows "P = Q"
   using assms(1) assms(2) eq_split_subst by blast
 
 lemma taut_split_subst:
   assumes "vwb_lens x"
   shows "`P` \<longleftrightarrow> (\<forall> v. `P\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<rbrakk>`)"
   using assms
   by (pred_auto, metis vwb_lens_wb wb_lens.source_stability)
 
 lemma eq_split:
   assumes "`P \<Rightarrow> Q`" "`Q \<Rightarrow> P`"
   shows "P = Q"
   using assms
   by (pred_auto)
 
 lemma bool_eq_splitI:
   assumes "vwb_lens x" "P\<lbrakk>true/x\<rbrakk> = Q\<lbrakk>true/x\<rbrakk>" "P\<lbrakk>false/x\<rbrakk> = Q\<lbrakk>false/x\<rbrakk>"
   shows "P = Q"
   by (metis (full_types) assms eq_split_subst false_alt_def true_alt_def)
 
 lemma subst_bool_split:
   assumes "vwb_lens x"
   shows "`P` = `(P\<lbrakk>false/x\<rbrakk> \<and> P\<lbrakk>true/x\<rbrakk>)`"
 proof -
   from assms have "`P` = (\<forall> v. `P\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<rbrakk>`)"
     by (subst taut_split_subst[of x], auto)
   also have "... = (`P\<lbrakk>\<guillemotleft>True\<guillemotright>/x\<rbrakk>` \<and> `P\<lbrakk>\<guillemotleft>False\<guillemotright>/x\<rbrakk>`)"
     by (metis (mono_tags, lifting))
   also have "... = `(P\<lbrakk>false/x\<rbrakk> \<and> P\<lbrakk>true/x\<rbrakk>)`"
     by (pred_auto)
   finally show ?thesis .
 qed
 
 lemma subst_eq_replace:
   fixes x :: "('a \<Longrightarrow> '\<alpha>)"
   shows "(p\<lbrakk>u/x\<rbrakk> \<and> u =\<^sub>u v) = (p\<lbrakk>v/x\<rbrakk> \<and> u =\<^sub>u v)"
   by (pred_auto)
 
 subsection \<open> UTP Quantifiers \<close>
     
 lemma one_point:
   assumes "mwb_lens x" "x \<sharp> v"
   shows "(\<exists> x \<bullet> P \<and> var x =\<^sub>u v) = P\<lbrakk>v/x\<rbrakk>"
   using assms
   by (pred_auto)
 
 lemma exists_twice: "mwb_lens x \<Longrightarrow> (\<exists> x \<bullet> \<exists> x \<bullet> P) = (\<exists> x \<bullet> P)"
   by (pred_auto)
 
 lemma all_twice: "mwb_lens x \<Longrightarrow> (\<forall> x \<bullet> \<forall> x \<bullet> P) = (\<forall> x \<bullet> P)"
   by (pred_auto)
 
 lemma exists_sub: "\<lbrakk> mwb_lens y; x \<subseteq>\<^sub>L y \<rbrakk> \<Longrightarrow> (\<exists> x \<bullet> \<exists> y \<bullet> P) = (\<exists> y \<bullet> P)"
   by (pred_auto)
 
 lemma all_sub: "\<lbrakk> mwb_lens y; x \<subseteq>\<^sub>L y \<rbrakk> \<Longrightarrow> (\<forall> x \<bullet> \<forall> y \<bullet> P) = (\<forall> y \<bullet> P)"
   by (pred_auto)
 
 lemma ex_commute:
   assumes "x \<bowtie> y"
   shows "(\<exists> x \<bullet> \<exists> y \<bullet> P) = (\<exists> y \<bullet> \<exists> x \<bullet> P)"
   using assms
   apply (pred_auto)
   using lens_indep_comm apply fastforce+
   done
 
 lemma all_commute:
   assumes "x \<bowtie> y"
   shows "(\<forall> x \<bullet> \<forall> y \<bullet> P) = (\<forall> y \<bullet> \<forall> x \<bullet> P)"
   using assms
   apply (pred_auto)
   using lens_indep_comm apply fastforce+
   done
 
 lemma ex_equiv:
   assumes "x \<approx>\<^sub>L y"
   shows "(\<exists> x \<bullet> P) = (\<exists> y \<bullet> P)"
   using assms
   by (pred_simp, metis (no_types, lifting) lens.select_convs(2))
 
 lemma all_equiv:
   assumes "x \<approx>\<^sub>L y"
   shows "(\<forall> x \<bullet> P) = (\<forall> y \<bullet> P)"
   using assms
   by (pred_simp, metis (no_types, lifting) lens.select_convs(2))
 
 lemma ex_zero:
   "(\<exists> \<emptyset> \<bullet> P) = P"
   by (pred_auto)
 
 lemma all_zero:
   "(\<forall> \<emptyset> \<bullet> P) = P"
   by (pred_auto)
 
 lemma ex_plus:
   "(\<exists> y;x \<bullet> P) = (\<exists> x \<bullet> \<exists> y \<bullet> P)"
   by (pred_auto)
 
 lemma all_plus:
   "(\<forall> y;x \<bullet> P) = (\<forall> x \<bullet> \<forall> y \<bullet> P)"
   by (pred_auto)
 
 lemma closure_all:
   "[P]\<^sub>u = (\<forall> \<Sigma> \<bullet> P)"
   by (pred_auto)
 
 lemma unrest_as_exists:
   "vwb_lens x \<Longrightarrow> (x \<sharp> P) \<longleftrightarrow> ((\<exists> x \<bullet> P) = P)"
   by (pred_simp, metis vwb_lens.put_eq)
 
 lemma ex_mono: "P \<sqsubseteq> Q \<Longrightarrow> (\<exists> x \<bullet> P) \<sqsubseteq> (\<exists> x \<bullet> Q)"
   by (pred_auto)
 
 lemma ex_weakens: "wb_lens x \<Longrightarrow> (\<exists> x \<bullet> P) \<sqsubseteq> P"
   by (pred_simp, metis wb_lens.get_put)
 
 lemma all_mono: "P \<sqsubseteq> Q \<Longrightarrow> (\<forall> x \<bullet> P) \<sqsubseteq> (\<forall> x \<bullet> Q)"
   by (pred_auto)
 
 lemma all_strengthens: "wb_lens x \<Longrightarrow> P \<sqsubseteq> (\<forall> x \<bullet> P)"
   by (pred_simp, metis wb_lens.get_put)
 
 lemma ex_unrest: "x \<sharp> P \<Longrightarrow> (\<exists> x \<bullet> P) = P"
   by (pred_auto)
 
 lemma all_unrest: "x \<sharp> P \<Longrightarrow> (\<forall> x \<bullet> P) = P"
   by (pred_auto)
 
 lemma not_ex_not: "\<not> (\<exists> x \<bullet> \<not> P) = (\<forall> x \<bullet> P)"
   by (pred_auto)
 
 lemma not_all_not: "\<not> (\<forall> x \<bullet> \<not> P) = (\<exists> x \<bullet> P)"
   by (pred_auto)
 
 lemma ex_conj_contr_left: "x \<sharp> P \<Longrightarrow> (\<exists> x \<bullet> P \<and> Q) = (P \<and> (\<exists> x \<bullet> Q))"
   by (pred_auto)
 
 lemma ex_conj_contr_right: "x \<sharp> Q \<Longrightarrow> (\<exists> x \<bullet> P \<and> Q) = ((\<exists> x \<bullet> P) \<and> Q)"
   by (pred_auto)
 
 subsection \<open> Variable Restriction \<close>    
   
 lemma var_res_all: 
   "P \<restriction>\<^sub>v \<Sigma> = P"
   by (rel_auto)
   
 lemma var_res_twice: 
   "mwb_lens x \<Longrightarrow> P \<restriction>\<^sub>v x \<restriction>\<^sub>v x = P \<restriction>\<^sub>v x"
   by (pred_auto)
     
 subsection \<open> Conditional laws \<close>
 
 lemma cond_def:
   "(P \<triangleleft> b \<triangleright> Q) = ((b \<and> P) \<or> ((\<not> b) \<and> Q))"
   by (pred_auto)
     
 lemma cond_idem [simp]:"(P \<triangleleft> b \<triangleright> P) = P" by (pred_auto)
 
 lemma cond_true_false [simp]: "true \<triangleleft> b \<triangleright> false = b" by (pred_auto)
     
 lemma cond_symm:"(P \<triangleleft> b \<triangleright> Q) = (Q \<triangleleft> \<not> b \<triangleright> P)" by (pred_auto)
 
 lemma cond_assoc: "((P \<triangleleft> b \<triangleright> Q) \<triangleleft> c \<triangleright> R) = (P \<triangleleft> b \<and> c \<triangleright> (Q \<triangleleft> c \<triangleright> R))" by (pred_auto)
 
 lemma cond_distr: "(P \<triangleleft> b \<triangleright> (Q \<triangleleft> c \<triangleright> R)) = ((P \<triangleleft> b \<triangleright> Q) \<triangleleft> c \<triangleright> (P \<triangleleft> b \<triangleright> R))" by (pred_auto)
 
 lemma cond_unit_T [simp]:"(P \<triangleleft> true \<triangleright> Q) = P" by (pred_auto)
 
 lemma cond_unit_F [simp]:"(P \<triangleleft> false \<triangleright> Q) = Q" by (pred_auto)
 
 lemma cond_conj_not: "((P \<triangleleft> b \<triangleright> Q) \<and> (\<not> b)) = (Q \<and> (\<not> b))"
   by (rel_auto)
     
 lemma cond_and_T_integrate:
   "((P \<and> b) \<or> (Q \<triangleleft> b \<triangleright> R)) = ((P \<or> Q) \<triangleleft> b \<triangleright> R)"
   by (pred_auto)
 
 lemma cond_L6: "(P \<triangleleft> b \<triangleright> (Q \<triangleleft> b \<triangleright> R)) = (P \<triangleleft> b \<triangleright> R)" by (pred_auto)
 
 lemma cond_L7: "(P \<triangleleft> b \<triangleright> (P \<triangleleft> c \<triangleright> Q)) = (P \<triangleleft> b \<or> c \<triangleright> Q)" by (pred_auto)
 
 lemma cond_and_distr: "((P \<and> Q) \<triangleleft> b \<triangleright> (R \<and> S)) = ((P \<triangleleft> b \<triangleright> R) \<and> (Q \<triangleleft> b \<triangleright> S))" by (pred_auto)
 
 lemma cond_or_distr: "((P \<or> Q) \<triangleleft> b \<triangleright> (R \<or> S)) = ((P \<triangleleft> b \<triangleright> R) \<or> (Q \<triangleleft> b \<triangleright> S))" by (pred_auto)
 
 lemma cond_imp_distr:
 "((P \<Rightarrow> Q) \<triangleleft> b \<triangleright> (R \<Rightarrow> S)) = ((P \<triangleleft> b \<triangleright> R) \<Rightarrow> (Q \<triangleleft> b \<triangleright> S))" by (pred_auto)
 
 lemma cond_eq_distr:
 "((P \<Leftrightarrow> Q) \<triangleleft> b \<triangleright> (R \<Leftrightarrow> S)) = ((P \<triangleleft> b \<triangleright> R) \<Leftrightarrow> (Q \<triangleleft> b \<triangleright> S))" by (pred_auto)
 
 lemma cond_conj_distr:"(P \<and> (Q \<triangleleft> b \<triangleright> S)) = ((P \<and> Q) \<triangleleft> b \<triangleright> (P \<and> S))" by (pred_auto)
 
 lemma cond_disj_distr:"(P \<or> (Q \<triangleleft> b \<triangleright> S)) = ((P \<or> Q) \<triangleleft> b \<triangleright> (P \<or> S))" by (pred_auto)
 
 lemma cond_neg: "\<not> (P \<triangleleft> b \<triangleright> Q) = ((\<not> P) \<triangleleft> b \<triangleright> (\<not> Q))" by (pred_auto)
 
 lemma cond_conj: "P \<triangleleft> b \<and> c \<triangleright> Q = (P \<triangleleft> c \<triangleright> Q) \<triangleleft> b \<triangleright> Q"
   by (pred_auto)
 
 lemma spec_cond_dist: "(P \<Rightarrow> (Q \<triangleleft> b \<triangleright> R)) = ((P \<Rightarrow> Q) \<triangleleft> b \<triangleright> (P \<Rightarrow> R))"
   by (pred_auto)
 
 lemma cond_USUP_dist: "(\<Squnion> P\<in>S \<bullet> F(P)) \<triangleleft> b \<triangleright> (\<Squnion> P\<in>S \<bullet> G(P)) = (\<Squnion> P\<in>S \<bullet> F(P) \<triangleleft> b \<triangleright> G(P))"
   by (pred_auto)
 
 lemma cond_UINF_dist: "(\<Sqinter> P\<in>S \<bullet> F(P)) \<triangleleft> b \<triangleright> (\<Sqinter> P\<in>S \<bullet> G(P)) = (\<Sqinter> P\<in>S \<bullet> F(P) \<triangleleft> b \<triangleright> G(P))"
   by (pred_auto)
 
 lemma cond_var_subst_left:
   assumes "vwb_lens x"
   shows "(P\<lbrakk>true/x\<rbrakk> \<triangleleft> var x \<triangleright> Q) = (P \<triangleleft> var x \<triangleright> Q)"
   using assms by (pred_auto, metis (full_types) vwb_lens_wb wb_lens.get_put)
 
 lemma cond_var_subst_right:
   assumes "vwb_lens x"
   shows "(P \<triangleleft> var x \<triangleright> Q\<lbrakk>false/x\<rbrakk>) = (P \<triangleleft> var x \<triangleright> Q)"
   using assms by (pred_auto, metis (full_types) vwb_lens.put_eq)
 
 lemma cond_var_split:
   "vwb_lens x \<Longrightarrow> (P\<lbrakk>true/x\<rbrakk> \<triangleleft> var x \<triangleright> P\<lbrakk>false/x\<rbrakk>) = P"
   by (rel_simp, (metis (full_types) vwb_lens.put_eq)+)
 
 lemma cond_assign_subst:
   "vwb_lens x \<Longrightarrow> (P \<triangleleft> utp_expr.var x =\<^sub>u v \<triangleright> Q) = (P\<lbrakk>v/x\<rbrakk> \<triangleleft> utp_expr.var x =\<^sub>u v \<triangleright> Q)"
   apply (rel_simp) using vwb_lens.put_eq by force
     
 lemma conj_conds: 
   "(P1 \<triangleleft> b \<triangleright> Q1 \<and> P2 \<triangleleft> b \<triangleright> Q2) = (P1 \<and> P2) \<triangleleft> b \<triangleright> (Q1 \<and> Q2)"
   by pred_auto
 
 lemma disj_conds:
   "(P1 \<triangleleft> b \<triangleright> Q1 \<or> P2 \<triangleleft> b \<triangleright> Q2) = (P1 \<or> P2) \<triangleleft> b \<triangleright> (Q1 \<or> Q2)"
   by pred_auto
 
 lemma cond_mono:
   "\<lbrakk> P\<^sub>1 \<sqsubseteq> P\<^sub>2; Q\<^sub>1 \<sqsubseteq> Q\<^sub>2 \<rbrakk> \<Longrightarrow> (P\<^sub>1 \<triangleleft> b \<triangleright> Q\<^sub>1) \<sqsubseteq> (P\<^sub>2 \<triangleleft> b \<triangleright> Q\<^sub>2)"
   by (rel_auto)
 
 lemma cond_monotonic:
   "\<lbrakk> mono P; mono Q \<rbrakk> \<Longrightarrow> mono (\<lambda> X. P X \<triangleleft> b \<triangleright> Q X)"
   by (simp add: mono_def, rel_blast)
 
 subsection \<open> Additional Expression Laws \<close>
 
 lemma le_pred_refl [simp]:
   fixes x :: "('a::preorder, '\<alpha>) uexpr"
   shows "(x \<le>\<^sub>u x) = true"
   by (pred_auto)
 
 lemma uzero_le_laws [simp]:
   "(0 :: ('a::{linordered_semidom}, '\<alpha>) uexpr) \<le>\<^sub>u numeral x = true"
   "(1 :: ('a::{linordered_semidom}, '\<alpha>) uexpr) \<le>\<^sub>u numeral x = true"
   "(0 :: ('a::{linordered_semidom}, '\<alpha>) uexpr) \<le>\<^sub>u 1 = true"
   by (pred_simp)+
   
 lemma unumeral_le_1 [simp]:
   assumes "(numeral i :: 'a::{numeral,ord}) \<le> numeral j"
   shows "(numeral i :: ('a, '\<alpha>) uexpr) \<le>\<^sub>u numeral j = true"
   using assms by (pred_auto)
 
 lemma unumeral_le_2 [simp]:
   assumes "(numeral i :: 'a::{numeral,linorder}) > numeral j"
   shows "(numeral i :: ('a, '\<alpha>) uexpr) \<le>\<^sub>u numeral j = false"
   using assms by (pred_auto)
     
 lemma uset_laws [simp]:
   "x \<in>\<^sub>u {}\<^sub>u = false"
   "x \<in>\<^sub>u {m..n}\<^sub>u = (m \<le>\<^sub>u x \<and> x \<le>\<^sub>u n)"
   by (pred_auto)+
   
 lemma ulit_eq [simp]: "x = y \<Longrightarrow> (\<guillemotleft>x\<guillemotright> =\<^sub>u \<guillemotleft>y\<guillemotright>) = true"
   by (rel_auto)
     
 lemma ulit_neq [simp]: "x \<noteq> y \<Longrightarrow> (\<guillemotleft>x\<guillemotright> =\<^sub>u \<guillemotleft>y\<guillemotright>) = false"
   by (rel_auto)
     
 lemma uset_mems [simp]:
   "x \<in>\<^sub>u {y}\<^sub>u = (x =\<^sub>u y)"
   "x \<in>\<^sub>u A \<union>\<^sub>u B = (x \<in>\<^sub>u A \<or> x \<in>\<^sub>u B)"
   "x \<in>\<^sub>u A \<inter>\<^sub>u B = (x \<in>\<^sub>u A \<and> x \<in>\<^sub>u B)"
   by (rel_auto)+
     
 subsection \<open> Refinement By Observation \<close>
     
 text \<open> Function to obtain the set of observations of a predicate \<close>
     
 definition obs_upred :: "'\<alpha> upred \<Rightarrow> '\<alpha> set" ("\<lbrakk>_\<rbrakk>\<^sub>o")
 where [upred_defs]: "\<lbrakk>P\<rbrakk>\<^sub>o = {b. \<lbrakk>P\<rbrakk>\<^sub>eb}"
     
 lemma obs_upred_refine_iff: 
   "P \<sqsubseteq> Q \<longleftrightarrow> \<lbrakk>Q\<rbrakk>\<^sub>o \<subseteq> \<lbrakk>P\<rbrakk>\<^sub>o"
   by (pred_auto)
     
 text \<open> A refinement can be demonstrated by considering only the observations of the predicates
   which are relevant, i.e. not unrestricted, for them. In other words, if the alphabet can
   be split into two disjoint segments, $x$ and $y$, and neither predicate refers to $y$ then
   only $x$ need be considered when checking for observations. \<close>
     
 lemma refine_by_obs:
   assumes "x \<bowtie> y" "bij_lens (x +\<^sub>L y)" "y \<sharp> P" "y \<sharp> Q" "{v. `P\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<rbrakk>`} \<subseteq> {v. `Q\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<rbrakk>`}"
   shows "Q \<sqsubseteq> P"
   using assms(3-5)
   apply (simp add: obs_upred_refine_iff subset_eq)
   apply (pred_simp)
   apply (rename_tac b)
   apply (drule_tac x="get\<^bsub>x\<^esub>b" in spec)
   apply (auto simp add: assms)
    apply (metis assms(1) assms(2) bij_lens.axioms(2) bij_lens_axioms_def lens_override_def lens_override_plus)+
   done
     
 subsection \<open> Cylindric Algebra \<close>
 
 lemma C1: "(\<exists> x \<bullet> false) = false"
   by (pred_auto)
 
 lemma C2: "wb_lens x \<Longrightarrow> `P \<Rightarrow> (\<exists> x \<bullet> P)`"
   by (pred_simp, metis wb_lens.get_put)
 
 lemma C3: "mwb_lens x \<Longrightarrow> (\<exists> x \<bullet> (P \<and> (\<exists> x \<bullet> Q))) = ((\<exists> x \<bullet> P) \<and> (\<exists> x \<bullet> Q))"
   by (pred_auto)
 
 lemma C4a: "x \<approx>\<^sub>L y \<Longrightarrow> (\<exists> x \<bullet> \<exists> y \<bullet> P) = (\<exists> y \<bullet> \<exists> x \<bullet> P)"
   by (pred_simp, metis (no_types, lifting) lens.select_convs(2))+
 
 lemma C4b: "x \<bowtie> y \<Longrightarrow> (\<exists> x \<bullet> \<exists> y \<bullet> P) = (\<exists> y \<bullet> \<exists> x \<bullet> P)"
   using ex_commute by blast
 
 lemma C5:
   fixes x :: "('a \<Longrightarrow> '\<alpha>)"
   shows "(&x =\<^sub>u &x) = true"
   by (pred_auto)
 
 lemma C6:
   assumes "wb_lens x" "x \<bowtie> y" "x \<bowtie> z"
   shows "(&y =\<^sub>u &z) = (\<exists> x \<bullet> &y =\<^sub>u &x \<and> &x =\<^sub>u &z)"
   using assms
   by (pred_simp, (metis lens_indep_def)+)
 
 lemma C7:
   assumes "weak_lens x" "x \<bowtie> y"
   shows "((\<exists> x \<bullet> &x =\<^sub>u &y \<and> P) \<and> (\<exists> x \<bullet> &x =\<^sub>u &y \<and> \<not> P)) = false"
   using assms
   by (pred_simp, simp add: lens_indep_sym)
 
 end
\ No newline at end of file
diff --git a/thys/Word_Lib/Bits_Int.thy b/thys/Word_Lib/Bits_Int.thy
--- a/thys/Word_Lib/Bits_Int.thy
+++ b/thys/Word_Lib/Bits_Int.thy
@@ -1,1573 +1,1573 @@
 (*
  * Copyright Brian Huffman, PSU; Jeremy Dawson and Gerwin Klein, NICTA
  *
  * SPDX-License-Identifier: BSD-2-Clause
  *)
 
 section \<open>Bitwise Operations on integers\<close>
 
 theory Bits_Int
   imports
     "Word_Lib.Most_significant_bit"
     "Word_Lib.Least_significant_bit"
     "Word_Lib.Generic_set_bit"
     "Word_Lib.Bit_Comprehension"
 begin
 
 subsection \<open>Implicit bit representation of \<^typ>\<open>int\<close>\<close>
 
 lemma bin_last_def:
   "(odd :: int \<Rightarrow> bool) w \<longleftrightarrow> w mod 2 = 1"
   by (fact odd_iff_mod_2_eq_one)
 
 lemma bin_last_numeral_simps [simp]:
   "\<not> odd (0 :: int)"
   "odd (1 :: int)"
   "odd (- 1 :: int)"
   "odd (Numeral1 :: int)"
   "\<not> odd (numeral (Num.Bit0 w) :: int)"
   "odd (numeral (Num.Bit1 w) :: int)"
   "\<not> odd (- numeral (Num.Bit0 w) :: int)"
   "odd (- numeral (Num.Bit1 w) :: int)"
   by simp_all
 
 lemma bin_rest_numeral_simps [simp]:
   "(\<lambda>k::int. k div 2) 0 = 0"
   "(\<lambda>k::int. k div 2) 1 = 0"
   "(\<lambda>k::int. k div 2) (- 1) = - 1"
   "(\<lambda>k::int. k div 2) Numeral1 = 0"
   "(\<lambda>k::int. k div 2) (numeral (Num.Bit0 w)) = numeral w"
   "(\<lambda>k::int. k div 2) (numeral (Num.Bit1 w)) = numeral w"
   "(\<lambda>k::int. k div 2) (- numeral (Num.Bit0 w)) = - numeral w"
   "(\<lambda>k::int. k div 2) (- numeral (Num.Bit1 w)) = - numeral (w + Num.One)"
   by simp_all
 
 lemma bin_rl_eqI: "\<lbrakk>(\<lambda>k::int. k div 2) x = (\<lambda>k::int. k div 2) y; odd x = odd y\<rbrakk> \<Longrightarrow> x = y"
   by (auto elim: oddE)
 
 lemma [simp]:
   shows bin_rest_lt0: "(\<lambda>k::int. k div 2) i < 0 \<longleftrightarrow> i < 0"
   and  bin_rest_ge_0: "(\<lambda>k::int. k div 2) i \<ge> 0 \<longleftrightarrow> i \<ge> 0"
   by auto
 
 lemma bin_rest_gt_0 [simp]: "(\<lambda>k::int. k div 2) x > 0 \<longleftrightarrow> x > 1"
   by auto
 
 
 subsection \<open>Bit projection\<close>
 
 lemma bin_nth_eq_iff: "(bit :: int \<Rightarrow> nat \<Rightarrow> bool) x = (bit :: int \<Rightarrow> nat \<Rightarrow> bool) y \<longleftrightarrow> x = y"
   by (simp add: bit_eq_iff fun_eq_iff)
 
 lemma bin_eqI:
   "x = y" if "\<And>n. (bit :: int \<Rightarrow> nat \<Rightarrow> bool) x n \<longleftrightarrow> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) y n"
   using that by (rule bit_eqI)
 
 lemma bin_eq_iff: "x = y \<longleftrightarrow> (\<forall>n. (bit :: int \<Rightarrow> nat \<Rightarrow> bool) x n = (bit :: int \<Rightarrow> nat \<Rightarrow> bool) y n)"
   by (fact bit_eq_iff)
 
 lemma bin_nth_zero [simp]: "\<not> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) 0 n"
   by simp
 
 lemma bin_nth_1 [simp]: "(bit :: int \<Rightarrow> nat \<Rightarrow> bool) 1 n \<longleftrightarrow> n = 0"
   by (cases n) (simp_all add: bit_Suc)
 
 lemma bin_nth_minus1 [simp]: "(bit :: int \<Rightarrow> nat \<Rightarrow> bool) (- 1) n"
   by simp
 
 lemma bin_nth_numeral: "(\<lambda>k::int. k div 2) x = y \<Longrightarrow> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) x (numeral n) = (bit :: int \<Rightarrow> nat \<Rightarrow> bool) y (pred_numeral n)"
   by (simp add: numeral_eq_Suc bit_Suc)
 
 lemmas bin_nth_numeral_simps [simp] =
   bin_nth_numeral [OF bin_rest_numeral_simps(8)]
 
 lemmas bin_nth_simps =
   bit_0 bit_Suc bin_nth_zero bin_nth_minus1
   bin_nth_numeral_simps
 
 lemma nth_2p_bin: "(bit :: int \<Rightarrow> nat \<Rightarrow> bool) (2 ^ n) m = (m = n)" \<comment> \<open>for use when simplifying with \<open>bin_nth_Bit\<close>\<close>
   by (auto simp add: bit_exp_iff)
 
 lemma nth_rest_power_bin: "(bit :: int \<Rightarrow> nat \<Rightarrow> bool) (((\<lambda>k::int. k div 2) ^^ k) w) n = (bit :: int \<Rightarrow> nat \<Rightarrow> bool) w (n + k)"
   apply (induct k arbitrary: n)
    apply clarsimp
   apply clarsimp
   apply (simp only: bit_Suc [symmetric] add_Suc)
   done
 
 lemma bin_nth_numeral_unfold:
   "(bit :: int \<Rightarrow> nat \<Rightarrow> bool) (numeral (num.Bit0 x)) n \<longleftrightarrow> n > 0 \<and> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) (numeral x) (n - 1)"
   "(bit :: int \<Rightarrow> nat \<Rightarrow> bool) (numeral (num.Bit1 x)) n \<longleftrightarrow> (n > 0 \<longrightarrow> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) (numeral x) (n - 1))"
   by (cases n; simp)+
 
 
 subsection \<open>Truncating\<close>
 
 definition bin_sign :: "int \<Rightarrow> int"
   where "bin_sign k = (if k \<ge> 0 then 0 else - 1)"
 
 lemma bin_sign_simps [simp]:
   "bin_sign 0 = 0"
   "bin_sign 1 = 0"
   "bin_sign (- 1) = - 1"
   "bin_sign (numeral k) = 0"
   "bin_sign (- numeral k) = -1"
   by (simp_all add: bin_sign_def)
 
 lemma bin_sign_rest [simp]: "bin_sign ((\<lambda>k::int. k div 2) w) = bin_sign w"
   by (simp add: bin_sign_def)
 
 lemma bintrunc_mod2p: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w = w mod 2 ^ n"
   by (fact take_bit_eq_mod)
 
 lemma sbintrunc_mod2p: "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w = (w + 2 ^ n) mod 2 ^ Suc n - 2 ^ n"
   by (simp add: bintrunc_mod2p signed_take_bit_eq_take_bit_shift)
 
 lemma sbintrunc_eq_take_bit:
   \<open>(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n k = take_bit (Suc n) (k + 2 ^ n) - 2 ^ n\<close>
   by (fact signed_take_bit_eq_take_bit_shift)
 
 lemma sign_bintr: "bin_sign ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w) = 0"
   by (simp add: bin_sign_def)
 
 lemma bintrunc_n_0: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n 0 = 0"
   by (fact take_bit_of_0)
 
 lemma sbintrunc_n_0: "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n 0 = 0"
   by (fact signed_take_bit_of_0)
 
 lemma sbintrunc_n_minus1: "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (- 1) = -1"
   by (fact signed_take_bit_of_minus_1)
 
 lemma bintrunc_Suc_numeral:
   "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) 1 = 1"
   "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) (- 1) = 1 + 2 * (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (- 1)"
   "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) (numeral (Num.Bit0 w)) = 2 * (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (numeral w)"
   "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) (numeral (Num.Bit1 w)) = 1 + 2 * (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (numeral w)"
   "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) (- numeral (Num.Bit0 w)) = 2 * (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (- numeral w)"
   "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) (- numeral (Num.Bit1 w)) = 1 + 2 * (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (- numeral (w + Num.One))"
   by (simp_all add: take_bit_Suc)
 
 lemma sbintrunc_0_numeral [simp]:
   "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) 0 1 = -1"
   "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) 0 (numeral (Num.Bit0 w)) = 0"
   "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) 0 (numeral (Num.Bit1 w)) = -1"
   "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) 0 (- numeral (Num.Bit0 w)) = 0"
   "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) 0 (- numeral (Num.Bit1 w)) = -1"
   by simp_all
 
 lemma sbintrunc_Suc_numeral:
   "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) 1 = 1"
   "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) (numeral (Num.Bit0 w)) = 2 * (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (numeral w)"
   "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) (numeral (Num.Bit1 w)) = 1 + 2 * (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (numeral w)"
   "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) (- numeral (Num.Bit0 w)) = 2 * (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (- numeral w)"
   "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) (- numeral (Num.Bit1 w)) = 1 + 2 * (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (- numeral (w + Num.One))"
   by (simp_all add: signed_take_bit_Suc)
 
 lemma bin_sign_lem: "(bin_sign ((signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n bin) = -1) = bit bin n"
   by (simp add: bin_sign_def)
 
 lemma nth_bintr: "(bit :: int \<Rightarrow> nat \<Rightarrow> bool) ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m w) n \<longleftrightarrow> n < m \<and> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) w n"
   by (fact bit_take_bit_iff)
 
 lemma nth_sbintr: "(bit :: int \<Rightarrow> nat \<Rightarrow> bool) ((signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m w) n = (if n < m then (bit :: int \<Rightarrow> nat \<Rightarrow> bool) w n else (bit :: int \<Rightarrow> nat \<Rightarrow> bool) w m)"
   by (simp add: bit_signed_take_bit_iff min_def)
 
 lemma bin_nth_Bit0:
   "(bit :: int \<Rightarrow> nat \<Rightarrow> bool) (numeral (Num.Bit0 w)) n \<longleftrightarrow>
     (\<exists>m. n = Suc m \<and> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) (numeral w) m)"
   using bit_double_iff [of \<open>numeral w :: int\<close> n]
   by (auto intro: exI [of _ \<open>n - 1\<close>])
 
 lemma bin_nth_Bit1:
   "(bit :: int \<Rightarrow> nat \<Rightarrow> bool) (numeral (Num.Bit1 w)) n \<longleftrightarrow>
     n = 0 \<or> (\<exists>m. n = Suc m \<and> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) (numeral w) m)"
   using even_bit_succ_iff [of \<open>2 * numeral w :: int\<close> n]
     bit_double_iff [of \<open>numeral w :: int\<close> n]
   by auto
 
 lemma bintrunc_bintrunc_l: "n \<le> m \<Longrightarrow> (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w) = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w"
   by (simp add: min.absorb2)
 
 lemma sbintrunc_sbintrunc_l: "n \<le> m \<Longrightarrow> (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m ((signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w) = (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w"
   by (simp add: min.absorb2)
 
 lemma bintrunc_bintrunc_ge: "n \<le> m \<Longrightarrow> (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m w) = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w"
   by (rule bin_eqI) (auto simp: nth_bintr)
 
 lemma bintrunc_bintrunc_min [simp]: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w) = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (min m n) w"
   by (rule take_bit_take_bit)
 
 lemma sbintrunc_sbintrunc_min [simp]: "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m ((signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w) = (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (min m n) w"
   by (rule signed_take_bit_signed_take_bit)
 
 lemmas sbintrunc_Suc_Pls =
   signed_take_bit_Suc [where a="0::int", simplified bin_last_numeral_simps bin_rest_numeral_simps]
 
 lemmas sbintrunc_Suc_Min =
   signed_take_bit_Suc [where a="-1::int", simplified bin_last_numeral_simps bin_rest_numeral_simps]
 
 lemmas sbintrunc_Sucs = sbintrunc_Suc_Pls sbintrunc_Suc_Min
   sbintrunc_Suc_numeral
 
 lemmas sbintrunc_Pls =
   signed_take_bit_0 [where a="0::int", simplified bin_last_numeral_simps bin_rest_numeral_simps]
 
 lemmas sbintrunc_Min =
   signed_take_bit_0 [where a="-1::int", simplified bin_last_numeral_simps bin_rest_numeral_simps]
 
 lemmas sbintrunc_0_simps =
   sbintrunc_Pls sbintrunc_Min
 
 lemmas sbintrunc_simps = sbintrunc_0_simps sbintrunc_Sucs
 
 lemma bintrunc_minus: "0 < n \<Longrightarrow> (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc (n - 1)) w = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w"
   by auto
 
 lemma sbintrunc_minus: "0 < n \<Longrightarrow> (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc (n - 1)) w = (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w"
   by auto
 
 lemmas sbintrunc_minus_simps =
   sbintrunc_Sucs [THEN [2] sbintrunc_minus [symmetric, THEN trans]]
 
 lemma sbintrunc_BIT_I:
   \<open>0 < n \<Longrightarrow>
   (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (n - 1) 0 = y \<Longrightarrow>
   (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n 0 = 2 * y\<close>
   by simp
 
 lemma sbintrunc_Suc_Is:
   \<open>(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (- 1) = y \<Longrightarrow>
   (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) (- 1) = 1 + 2 * y\<close>
   by auto
 
 lemma sbintrunc_Suc_lem: "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) x = y \<Longrightarrow> m = Suc n \<Longrightarrow> (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m x = y"
   by (rule ssubst)
 
 lemmas sbintrunc_Suc_Ialts =
   sbintrunc_Suc_Is [THEN sbintrunc_Suc_lem]
 
 lemma sbintrunc_bintrunc_lt: "m > n \<Longrightarrow> (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m w) = (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w"
   by (rule bin_eqI) (auto simp: nth_sbintr nth_bintr)
 
 lemma bintrunc_sbintrunc_le: "m \<le> Suc n \<Longrightarrow> (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m ((signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w) = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m w"
   by (rule take_bit_signed_take_bit)
 
 lemmas bintrunc_sbintrunc [simp] = order_refl [THEN bintrunc_sbintrunc_le]
 lemmas sbintrunc_bintrunc [simp] = lessI [THEN sbintrunc_bintrunc_lt]
 lemmas bintrunc_bintrunc [simp] = order_refl [THEN bintrunc_bintrunc_l]
 lemmas sbintrunc_sbintrunc [simp] = order_refl [THEN sbintrunc_sbintrunc_l]
 
 lemma bintrunc_sbintrunc' [simp]: "0 < n \<Longrightarrow> (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n ((signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (n - 1) w) = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w"
   by (cases n) simp_all
 
 lemma sbintrunc_bintrunc' [simp]: "0 < n \<Longrightarrow> (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (n - 1) ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w) = (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (n - 1) w"
   by (cases n) simp_all
 
 lemma bin_sbin_eq_iff: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) x = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) y \<longleftrightarrow> (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n x = (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n y"
   apply (rule iffI)
    apply (rule box_equals [OF _ sbintrunc_bintrunc sbintrunc_bintrunc])
    apply simp
   apply (rule box_equals [OF _ bintrunc_sbintrunc bintrunc_sbintrunc])
   apply simp
   done
 
 lemma bin_sbin_eq_iff':
   "0 < n \<Longrightarrow> (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n x = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n y \<longleftrightarrow> (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (n - 1) x = (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (n - 1) y"
   by (cases n) (simp_all add: bin_sbin_eq_iff)
 
 lemmas bintrunc_sbintruncS0 [simp] = bintrunc_sbintrunc' [unfolded One_nat_def]
 lemmas sbintrunc_bintruncS0 [simp] = sbintrunc_bintrunc' [unfolded One_nat_def]
 
 lemmas bintrunc_bintrunc_l' = le_add1 [THEN bintrunc_bintrunc_l]
 lemmas sbintrunc_sbintrunc_l' = le_add1 [THEN sbintrunc_sbintrunc_l]
 
 (* although bintrunc_minus_simps, if added to default simpset,
   tends to get applied where it's not wanted in developing the theories,
   we get a version for when the word length is given literally *)
 
 lemmas nat_non0_gr =
   trans [OF iszero_def [THEN Not_eq_iff [THEN iffD2]] refl]
 
 lemma bintrunc_numeral:
   "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (numeral k) x = of_bool (odd x) + 2 * (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (pred_numeral k) (x div 2)"
   by (simp add: numeral_eq_Suc take_bit_Suc mod_2_eq_odd)
 
 lemma sbintrunc_numeral:
   "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (numeral k) x = of_bool (odd x) + 2 * (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (pred_numeral k) (x div 2)"
   by (simp add: numeral_eq_Suc signed_take_bit_Suc mod2_eq_if)
 
 lemma bintrunc_numeral_simps [simp]:
   "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (numeral k) (numeral (Num.Bit0 w)) =
     2 * (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (pred_numeral k) (numeral w)"
   "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (numeral k) (numeral (Num.Bit1 w)) =
     1 + 2 * (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (pred_numeral k) (numeral w)"
   "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (numeral k) (- numeral (Num.Bit0 w)) =
     2 * (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (pred_numeral k) (- numeral w)"
   "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (numeral k) (- numeral (Num.Bit1 w)) =
     1 + 2 * (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (pred_numeral k) (- numeral (w + Num.One))"
   "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (numeral k) 1 = 1"
   by (simp_all add: bintrunc_numeral)
 
 lemma sbintrunc_numeral_simps [simp]:
   "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (numeral k) (numeral (Num.Bit0 w)) =
     2 * (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (pred_numeral k) (numeral w)"
   "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (numeral k) (numeral (Num.Bit1 w)) =
     1 + 2 * (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (pred_numeral k) (numeral w)"
   "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (numeral k) (- numeral (Num.Bit0 w)) =
     2 * (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (pred_numeral k) (- numeral w)"
   "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (numeral k) (- numeral (Num.Bit1 w)) =
     1 + 2 * (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (pred_numeral k) (- numeral (w + Num.One))"
   "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (numeral k) 1 = 1"
   by (simp_all add: sbintrunc_numeral)
 
 lemma no_bintr_alt1: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n = (\<lambda>w. w mod 2 ^ n :: int)"
   by (rule ext) (rule bintrunc_mod2p)
 
 lemma range_bintrunc: "range ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n) = {i. 0 \<le> i \<and> i < 2 ^ n}"
   by (auto simp add: take_bit_eq_mod image_iff) (metis mod_pos_pos_trivial)
 
 lemma no_sbintr_alt2: "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n = (\<lambda>w. (w + 2 ^ n) mod 2 ^ Suc n - 2 ^ n :: int)"
   by (rule ext) (simp add : sbintrunc_mod2p)
 
 lemma range_sbintrunc: "range ((signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n) = {i. - (2 ^ n) \<le> i \<and> i < 2 ^ n}"
 proof -
   have \<open>surj (\<lambda>k::int. k + 2 ^ n)\<close>
     by (rule surjI [of _ \<open>(\<lambda>k. k - 2 ^ n)\<close>]) simp
   moreover have \<open>(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n = ((\<lambda>k. k - 2 ^ n) \<circ> take_bit (Suc n) \<circ> (\<lambda>k. k + 2 ^ n))\<close>
     by (simp add: sbintrunc_eq_take_bit fun_eq_iff)
   ultimately show ?thesis
     apply (simp only: fun.set_map range_bintrunc)
     apply (auto simp add: image_iff)
     apply presburger
     done
 qed
 
 lemma sbintrunc_inc:
   \<open>k + 2 ^ Suc n \<le> (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n k\<close> if \<open>k < - (2 ^ n)\<close>
   using that by (fact signed_take_bit_int_greater_eq)
 
 lemma sbintrunc_dec:
   \<open>(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n k \<le> k - 2 ^ (Suc n)\<close> if \<open>k \<ge> 2 ^ n\<close>
   using that by (fact signed_take_bit_int_less_eq)
 
 lemma bintr_ge0: "0 \<le> (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w"
   by (simp add: bintrunc_mod2p)
 
 lemma bintr_lt2p: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w < 2 ^ n"
   by (simp add: bintrunc_mod2p)
 
 lemma bintr_Min: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (- 1) = 2 ^ n - 1"
   by (simp add: stable_imp_take_bit_eq)
 
 lemma sbintr_ge: "- (2 ^ n) \<le> (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w"
   by (fact signed_take_bit_int_greater_eq_minus_exp)
 
 lemma sbintr_lt: "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w < 2 ^ n"
   by (fact signed_take_bit_int_less_exp)
 
 lemma sign_Pls_ge_0: "bin_sign bin = 0 \<longleftrightarrow> bin \<ge> 0"
   for bin :: int
   by (simp add: bin_sign_def)
 
 lemma sign_Min_lt_0: "bin_sign bin = -1 \<longleftrightarrow> bin < 0"
   for bin :: int
   by (simp add: bin_sign_def)
 
 lemma bin_rest_trunc: "(\<lambda>k::int. k div 2) ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n bin) = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (n - 1) ((\<lambda>k::int. k div 2) bin)"
   by (simp add: take_bit_rec [of n bin])
 
 lemma bin_rest_power_trunc:
   "((\<lambda>k::int. k div 2) ^^ k) ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n bin) = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (n - k) (((\<lambda>k::int. k div 2) ^^ k) bin)"
   by (induct k) (auto simp: bin_rest_trunc)
 
 lemma bin_rest_trunc_i: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n ((\<lambda>k::int. k div 2) bin) = (\<lambda>k::int. k div 2) ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) bin)"
   by (auto simp add: take_bit_Suc)
 
 lemma bin_rest_strunc: "(\<lambda>k::int. k div 2) ((signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) bin) = (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n ((\<lambda>k::int. k div 2) bin)"
   by (simp add: signed_take_bit_Suc)
 
 lemma bintrunc_rest [simp]: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n ((\<lambda>k::int. k div 2) ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n bin)) = (\<lambda>k::int. k div 2) ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n bin)"
   by (induct n arbitrary: bin) (simp_all add: take_bit_Suc)
 
 lemma sbintrunc_rest [simp]: "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n ((\<lambda>k::int. k div 2) ((signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n bin)) = (\<lambda>k::int. k div 2) ((signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n bin)"
   by (induct n arbitrary: bin) (simp_all add: signed_take_bit_Suc mod2_eq_if)
 
 lemma bintrunc_rest': "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n \<circ> (\<lambda>k::int. k div 2) \<circ> (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n = (\<lambda>k::int. k div 2) \<circ> (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n"
   by (rule ext) auto
 
 lemma sbintrunc_rest': "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n \<circ> (\<lambda>k::int. k div 2) \<circ> (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n = (\<lambda>k::int. k div 2) \<circ> (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n"
   by (rule ext) auto
 
 lemma rco_lem: "f \<circ> g \<circ> f = g \<circ> f \<Longrightarrow> f \<circ> (g \<circ> f) ^^ n = g ^^ n \<circ> f"
   apply (rule ext)
   apply (induct_tac n)
    apply (simp_all (no_asm))
   apply (drule fun_cong)
   apply (unfold o_def)
   apply (erule trans)
   apply simp
   done
 
 lemmas rco_bintr = bintrunc_rest'
   [THEN rco_lem [THEN fun_cong], unfolded o_def]
 lemmas rco_sbintr = sbintrunc_rest'
   [THEN rco_lem [THEN fun_cong], unfolded o_def]
 
 
 subsection \<open>Splitting and concatenation\<close>
 
 definition bin_split :: \<open>nat \<Rightarrow> int \<Rightarrow> int \<times> int\<close>
   where [simp]: \<open>bin_split n k = (drop_bit n k, take_bit n k)\<close>
 
 lemma [code]:
   "bin_split (Suc n) w = (let (w1, w2) = bin_split n (w div 2) in (w1, of_bool (odd w) + 2 * w2))"
   "bin_split 0 w = (w, 0)"
   by (simp_all add: drop_bit_Suc take_bit_Suc mod_2_eq_odd)
 
 lemma bin_cat_eq_push_bit_add_take_bit:
   \<open>concat_bit n l k = push_bit n k + take_bit n l\<close>
   by (simp add: concat_bit_eq)
 
 lemma bin_sign_cat: "bin_sign ((\<lambda>k n l. concat_bit n l k) x n y) = bin_sign x"
 proof -
   have \<open>0 \<le> x\<close> if \<open>0 \<le> x * 2 ^ n + y mod 2 ^ n\<close>
   proof -
     have \<open>y mod 2 ^ n < 2 ^ n\<close>
       using pos_mod_bound [of \<open>2 ^ n\<close> y] by simp
     then have \<open>\<not> y mod 2 ^ n \<ge> 2 ^ n\<close>
       by (simp add: less_le)
     with that have \<open>x \<noteq> - 1\<close>
       by auto
     have *: \<open>- 1 \<le> (- (y mod 2 ^ n)) div 2 ^ n\<close>
       by (simp add: zdiv_zminus1_eq_if)
     from that have \<open>- (y mod 2 ^ n) \<le> x * 2 ^ n\<close>
       by simp
     then have \<open>(- (y mod 2 ^ n)) div 2 ^ n \<le> (x * 2 ^ n) div 2 ^ n\<close>
       using zdiv_mono1 zero_less_numeral zero_less_power by blast
     with * have \<open>- 1 \<le> x * 2 ^ n div 2 ^ n\<close> by simp
     with \<open>x \<noteq> - 1\<close> show ?thesis
       by simp
   qed
   then show ?thesis
     by (simp add: bin_sign_def not_le not_less bin_cat_eq_push_bit_add_take_bit push_bit_eq_mult take_bit_eq_mod)
 qed
 
 lemma bin_cat_assoc: "(\<lambda>k n l. concat_bit n l k) ((\<lambda>k n l. concat_bit n l k) x m y) n z = (\<lambda>k n l. concat_bit n l k) x (m + n) ((\<lambda>k n l. concat_bit n l k) y n z)"
   by (fact concat_bit_assoc)
 
 lemma bin_cat_assoc_sym: "(\<lambda>k n l. concat_bit n l k) x m ((\<lambda>k n l. concat_bit n l k) y n z) = (\<lambda>k n l. concat_bit n l k) ((\<lambda>k n l. concat_bit n l k) x (m - n) y) (min m n) z"
   by (fact concat_bit_assoc_sym)
 
 definition bin_rcat :: \<open>nat \<Rightarrow> int list \<Rightarrow> int\<close>
   where \<open>bin_rcat n = horner_sum (take_bit n) (2 ^ n) \<circ> rev\<close>
 
 lemma bin_rcat_eq_foldl:
   \<open>bin_rcat n = foldl (\<lambda>u v. (\<lambda>k n l. concat_bit n l k) u n v) 0\<close>
 proof
   fix ks :: \<open>int list\<close>
   show \<open>bin_rcat n ks = foldl (\<lambda>u v. (\<lambda>k n l. concat_bit n l k) u n v) 0 ks\<close>
     by (induction ks rule: rev_induct)
       (simp_all add: bin_rcat_def concat_bit_eq push_bit_eq_mult)
 qed
 
 fun bin_rsplit_aux :: "nat \<Rightarrow> nat \<Rightarrow> int \<Rightarrow> int list \<Rightarrow> int list"
   where "bin_rsplit_aux n m c bs =
     (if m = 0 \<or> n = 0 then bs
      else
       let (a, b) = bin_split n c
       in bin_rsplit_aux n (m - n) a (b # bs))"
 
 definition bin_rsplit :: "nat \<Rightarrow> nat \<times> int \<Rightarrow> int list"
   where "bin_rsplit n w = bin_rsplit_aux n (fst w) (snd w) []"
 
 fun bin_rsplitl_aux :: "nat \<Rightarrow> nat \<Rightarrow> int \<Rightarrow> int list \<Rightarrow> int list"
   where "bin_rsplitl_aux n m c bs =
     (if m = 0 \<or> n = 0 then bs
      else
       let (a, b) = bin_split (min m n) c
       in bin_rsplitl_aux n (m - n) a (b # bs))"
 
 definition bin_rsplitl :: "nat \<Rightarrow> nat \<times> int \<Rightarrow> int list"
   where "bin_rsplitl n w = bin_rsplitl_aux n (fst w) (snd w) []"
 
 declare bin_rsplit_aux.simps [simp del]
 declare bin_rsplitl_aux.simps [simp del]
 
 lemma bin_nth_cat:
   "(bit :: int \<Rightarrow> nat \<Rightarrow> bool) ((\<lambda>k n l. concat_bit n l k) x k y) n =
     (if n < k then (bit :: int \<Rightarrow> nat \<Rightarrow> bool) y n else (bit :: int \<Rightarrow> nat \<Rightarrow> bool) x (n - k))"
   by (simp add: bit_concat_bit_iff)
 
 lemma bin_nth_drop_bit_iff:
   \<open>(bit :: int \<Rightarrow> nat \<Rightarrow> bool) (drop_bit n c) k \<longleftrightarrow> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) c (n + k)\<close>
   by (simp add: bit_drop_bit_eq)
 
 lemma bin_nth_take_bit_iff:
   \<open>(bit :: int \<Rightarrow> nat \<Rightarrow> bool) (take_bit n c) k \<longleftrightarrow> k < n \<and> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) c k\<close>
   by (fact bit_take_bit_iff)
 
 lemma bin_nth_split:
   "bin_split n c = (a, b) \<Longrightarrow>
     (\<forall>k. (bit :: int \<Rightarrow> nat \<Rightarrow> bool) a k = (bit :: int \<Rightarrow> nat \<Rightarrow> bool) c (n + k)) \<and>
     (\<forall>k. (bit :: int \<Rightarrow> nat \<Rightarrow> bool) b k = (k < n \<and> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) c k))"
   by (auto simp add: bin_nth_drop_bit_iff bin_nth_take_bit_iff)
 
 lemma bin_cat_zero [simp]: "(\<lambda>k n l. concat_bit n l k) 0 n w = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w"
   by (simp add: bin_cat_eq_push_bit_add_take_bit)
 
 lemma bintr_cat1: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (k + n) ((\<lambda>k n l. concat_bit n l k) a n b) = (\<lambda>k n l. concat_bit n l k) ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) k a) n b"
   by (metis bin_cat_assoc bin_cat_zero)
 
 lemma bintr_cat: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m ((\<lambda>k n l. concat_bit n l k) a n b) =
     (\<lambda>k n l. concat_bit n l k) ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (m - n) a) n ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (min m n) b)"
   by (rule bin_eqI) (auto simp: bin_nth_cat nth_bintr)
 
 lemma bintr_cat_same [simp]: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n ((\<lambda>k n l. concat_bit n l k) a n b) = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n b"
   by (auto simp add : bintr_cat)
 
 lemma cat_bintr [simp]: "(\<lambda>k n l. concat_bit n l k) a n ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n b) = (\<lambda>k n l. concat_bit n l k) a n b"
   by (simp add: bin_cat_eq_push_bit_add_take_bit)
 
 lemma split_bintrunc: "bin_split n c = (a, b) \<Longrightarrow> b = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n c"
   by simp
 
 lemma bin_cat_split: "bin_split n w = (u, v) \<Longrightarrow> w = (\<lambda>k n l. concat_bit n l k) u n v"
   by (auto simp add: bin_cat_eq_push_bit_add_take_bit bits_ident)
 
 lemma drop_bit_bin_cat_eq:
   \<open>drop_bit n ((\<lambda>k n l. concat_bit n l k) v n w) = v\<close>
   by (rule bit_eqI) (simp add: bit_drop_bit_eq bit_concat_bit_iff)
 
 lemma take_bit_bin_cat_eq:
   \<open>take_bit n ((\<lambda>k n l. concat_bit n l k) v n w) = take_bit n w\<close>
   by (rule bit_eqI) (simp add: bit_concat_bit_iff)
 
 lemma bin_split_cat: "bin_split n ((\<lambda>k n l. concat_bit n l k) v n w) = (v, (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w)"
   by (simp add: drop_bit_bin_cat_eq take_bit_bin_cat_eq)
 
 lemma bin_split_zero [simp]: "bin_split n 0 = (0, 0)"
   by simp
 
 lemma bin_split_minus1 [simp]:
   "bin_split n (- 1) = (- 1, (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (- 1))"
   by simp
 
 lemma bin_split_trunc:
   "bin_split (min m n) c = (a, b) \<Longrightarrow>
     bin_split n ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m c) = ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (m - n) a, b)"
   apply (induct n arbitrary: m b c, clarsimp)
   apply (simp add: bin_rest_trunc Let_def split: prod.split_asm)
   apply (case_tac m)
    apply (auto simp: Let_def drop_bit_Suc take_bit_Suc mod_2_eq_odd split: prod.split_asm)
   done
 
 lemma bin_split_trunc1:
   "bin_split n c = (a, b) \<Longrightarrow>
     bin_split n ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m c) = ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (m - n) a, (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m b)"
   apply (induct n arbitrary: m b c, clarsimp)
   apply (simp add: bin_rest_trunc Let_def split: prod.split_asm)
   apply (case_tac m)
    apply (auto simp: Let_def drop_bit_Suc take_bit_Suc mod_2_eq_odd split: prod.split_asm)
   done
 
 lemma bin_cat_num: "(\<lambda>k n l. concat_bit n l k) a n b = a * 2 ^ n + (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n b"
   by (simp add: bin_cat_eq_push_bit_add_take_bit push_bit_eq_mult)
 
 lemma bin_split_num: "bin_split n b = (b div 2 ^ n, b mod 2 ^ n)"
   by (simp add: drop_bit_eq_div take_bit_eq_mod)
 
 lemmas bin_rsplit_aux_simps = bin_rsplit_aux.simps bin_rsplitl_aux.simps
 lemmas rsplit_aux_simps = bin_rsplit_aux_simps
 
 lemmas th_if_simp1 = if_split [where P = "(=) l", THEN iffD1, THEN conjunct1, THEN mp] for l
 lemmas th_if_simp2 = if_split [where P = "(=) l", THEN iffD1, THEN conjunct2, THEN mp] for l
 
 lemmas rsplit_aux_simp1s = rsplit_aux_simps [THEN th_if_simp1]
 
 lemmas rsplit_aux_simp2ls = rsplit_aux_simps [THEN th_if_simp2]
 \<comment> \<open>these safe to \<open>[simp add]\<close> as require calculating \<open>m - n\<close>\<close>
 lemmas bin_rsplit_aux_simp2s [simp] = rsplit_aux_simp2ls [unfolded Let_def]
 lemmas rbscl = bin_rsplit_aux_simp2s (2)
 
 lemmas rsplit_aux_0_simps [simp] =
   rsplit_aux_simp1s [OF disjI1] rsplit_aux_simp1s [OF disjI2]
 
 lemma bin_rsplit_aux_append: "bin_rsplit_aux n m c (bs @ cs) = bin_rsplit_aux n m c bs @ cs"
   apply (induct n m c bs rule: bin_rsplit_aux.induct)
   apply (subst bin_rsplit_aux.simps)
   apply (subst bin_rsplit_aux.simps)
   apply (clarsimp split: prod.split)
   done
 
 lemma bin_rsplitl_aux_append: "bin_rsplitl_aux n m c (bs @ cs) = bin_rsplitl_aux n m c bs @ cs"
   apply (induct n m c bs rule: bin_rsplitl_aux.induct)
   apply (subst bin_rsplitl_aux.simps)
   apply (subst bin_rsplitl_aux.simps)
   apply (clarsimp split: prod.split)
   done
 
 lemmas rsplit_aux_apps [where bs = "[]"] =
   bin_rsplit_aux_append bin_rsplitl_aux_append
 
 lemmas rsplit_def_auxs = bin_rsplit_def bin_rsplitl_def
 
 lemmas rsplit_aux_alts = rsplit_aux_apps
   [unfolded append_Nil rsplit_def_auxs [symmetric]]
 
 lemma bin_split_minus: "0 < n \<Longrightarrow> bin_split (Suc (n - 1)) w = bin_split n w"
   by auto
 
 lemma bin_split_pred_simp [simp]:
   "(0::nat) < numeral bin \<Longrightarrow>
     bin_split (numeral bin) w =
       (let (w1, w2) = bin_split (numeral bin - 1) ((\<lambda>k::int. k div 2) w)
        in (w1, of_bool (odd w) + 2 * w2))"
   by (simp add: take_bit_rec drop_bit_rec mod_2_eq_odd)
 
 lemma bin_rsplit_aux_simp_alt:
   "bin_rsplit_aux n m c bs =
     (if m = 0 \<or> n = 0 then bs
      else let (a, b) = bin_split n c in bin_rsplit n (m - n, a) @ b # bs)"
   apply (simp add: bin_rsplit_aux.simps [of n m c bs])
   apply (subst rsplit_aux_alts)
   apply (simp add: bin_rsplit_def)
   done
 
 lemmas bin_rsplit_simp_alt =
   trans [OF bin_rsplit_def bin_rsplit_aux_simp_alt]
 
 lemmas bthrs = bin_rsplit_simp_alt [THEN [2] trans]
 
 lemma bin_rsplit_size_sign' [rule_format]:
   "n > 0 \<Longrightarrow> rev sw = bin_rsplit n (nw, w) \<Longrightarrow> \<forall>v\<in>set sw. (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n v = v"
   apply (induct sw arbitrary: nw w)
    apply clarsimp
   apply clarsimp
   apply (drule bthrs)
   apply (simp (no_asm_use) add: Let_def split: prod.split_asm if_split_asm)
   apply clarify
   apply simp
   done
 
 lemmas bin_rsplit_size_sign = bin_rsplit_size_sign' [OF asm_rl
   rev_rev_ident [THEN trans] set_rev [THEN equalityD2 [THEN subsetD]]]
 
 lemma bin_nth_rsplit [rule_format] :
   "n > 0 \<Longrightarrow> m < n \<Longrightarrow>
     \<forall>w k nw.
       rev sw = bin_rsplit n (nw, w) \<longrightarrow>
       k < size sw \<longrightarrow> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) (sw ! k) m = (bit :: int \<Rightarrow> nat \<Rightarrow> bool) w (k * n + m)"
   apply (induct sw)
    apply clarsimp
   apply clarsimp
   apply (drule bthrs)
   apply (simp (no_asm_use) add: Let_def split: prod.split_asm if_split_asm)
   apply (erule allE, erule impE, erule exI)
   apply (case_tac k)
    apply clarsimp
    prefer 2
    apply clarsimp
    apply (erule allE)
    apply (erule (1) impE)
    apply (simp add: bit_drop_bit_eq ac_simps)
   apply (simp add: bit_take_bit_iff ac_simps)
   done
 
 lemma bin_rsplit_all: "0 < nw \<Longrightarrow> nw \<le> n \<Longrightarrow> bin_rsplit n (nw, w) = [(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w]"
   by (auto simp: bin_rsplit_def rsplit_aux_simp2ls split: prod.split dest!: split_bintrunc)
 
 lemma bin_rsplit_l [rule_format]:
   "\<forall>bin. bin_rsplitl n (m, bin) = bin_rsplit n (m, (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m bin)"
   apply (rule_tac a = "m" in wf_less_than [THEN wf_induct])
   apply (simp (no_asm) add: bin_rsplitl_def bin_rsplit_def)
   apply (rule allI)
   apply (subst bin_rsplitl_aux.simps)
   apply (subst bin_rsplit_aux.simps)
   apply (clarsimp simp: Let_def split: prod.split)
   apply (simp add: ac_simps)
   apply (subst rsplit_aux_alts(1))
   apply (subst rsplit_aux_alts(2))
   apply clarsimp
   unfolding bin_rsplit_def bin_rsplitl_def
   apply (simp add: drop_bit_take_bit)
   apply (case_tac \<open>x < n\<close>)
   apply (simp_all add: not_less min_def)
   done
 
 lemma bin_rsplit_rcat [rule_format]:
   "n > 0 \<longrightarrow> bin_rsplit n (n * size ws, bin_rcat n ws) = map ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n) ws"
   apply (unfold bin_rsplit_def bin_rcat_eq_foldl)
   apply (rule_tac xs = ws in rev_induct)
    apply clarsimp
   apply clarsimp
   apply (subst rsplit_aux_alts)
   apply (simp add: drop_bit_bin_cat_eq take_bit_bin_cat_eq)
   done
 
 lemma bin_rsplit_aux_len_le [rule_format] :
   "\<forall>ws m. n \<noteq> 0 \<longrightarrow> ws = bin_rsplit_aux n nw w bs \<longrightarrow>
     length ws \<le> m \<longleftrightarrow> nw + length bs * n \<le> m * n"
 proof -
   have *: R
     if d: "i \<le> j \<or> m < j'"
     and R1: "i * k \<le> j * k \<Longrightarrow> R"
     and R2: "Suc m * k' \<le> j' * k' \<Longrightarrow> R"
     for i j j' k k' m :: nat and R
     using d
     apply safe
     apply (rule R1, erule mult_le_mono1)
     apply (rule R2, erule Suc_le_eq [THEN iffD2 [THEN mult_le_mono1]])
     done
   have **: "0 < sc \<Longrightarrow> sc - n + (n + lb * n) \<le> m * n \<longleftrightarrow> sc + lb * n \<le> m * n"
     for sc m n lb :: nat
     apply safe
      apply arith
     apply (case_tac "sc \<ge> n")
      apply arith
     apply (insert linorder_le_less_linear [of m lb])
     apply (erule_tac k=n and k'=n in *)
      apply arith
     apply simp
     done
   show ?thesis
     apply (induct n nw w bs rule: bin_rsplit_aux.induct)
     apply (subst bin_rsplit_aux.simps)
     apply (simp add: ** Let_def split: prod.split)
     done
 qed
 
 lemma bin_rsplit_len_le: "n \<noteq> 0 \<longrightarrow> ws = bin_rsplit n (nw, w) \<longrightarrow> length ws \<le> m \<longleftrightarrow> nw \<le> m * n"
   by (auto simp: bin_rsplit_def bin_rsplit_aux_len_le)
 
 lemma bin_rsplit_aux_len:
   "n \<noteq> 0 \<Longrightarrow> length (bin_rsplit_aux n nw w cs) = (nw + n - 1) div n + length cs"
   apply (induct n nw w cs rule: bin_rsplit_aux.induct)
   apply (subst bin_rsplit_aux.simps)
   apply (clarsimp simp: Let_def split: prod.split)
   apply (erule thin_rl)
   apply (case_tac m)
    apply simp
   apply (case_tac "m \<le> n")
    apply (auto simp add: div_add_self2)
   done
 
 lemma bin_rsplit_len: "n \<noteq> 0 \<Longrightarrow> length (bin_rsplit n (nw, w)) = (nw + n - 1) div n"
   by (auto simp: bin_rsplit_def bin_rsplit_aux_len)
 
 lemma bin_rsplit_aux_len_indep:
   "n \<noteq> 0 \<Longrightarrow> length bs = length cs \<Longrightarrow>
     length (bin_rsplit_aux n nw v bs) =
     length (bin_rsplit_aux n nw w cs)"
 proof (induct n nw w cs arbitrary: v bs rule: bin_rsplit_aux.induct)
   case (1 n m w cs v bs)
   show ?case
   proof (cases "m = 0")
     case True
     with \<open>length bs = length cs\<close> show ?thesis by simp
   next
     case False
     from "1.hyps" [of \<open>bin_split n w\<close> \<open>drop_bit n w\<close> \<open>take_bit n w\<close>] \<open>m \<noteq> 0\<close> \<open>n \<noteq> 0\<close>
     have hyp: "\<And>v bs. length bs = Suc (length cs) \<Longrightarrow>
       length (bin_rsplit_aux n (m - n) v bs) =
       length (bin_rsplit_aux n (m - n) (drop_bit n w) (take_bit n w # cs))"
       using bin_rsplit_aux_len by fastforce
     from \<open>length bs = length cs\<close> \<open>n \<noteq> 0\<close> show ?thesis
       by (auto simp add: bin_rsplit_aux_simp_alt Let_def bin_rsplit_len split: prod.split)
   qed
 qed
 
 lemma bin_rsplit_len_indep:
   "n \<noteq> 0 \<Longrightarrow> length (bin_rsplit n (nw, v)) = length (bin_rsplit n (nw, w))"
   apply (unfold bin_rsplit_def)
   apply (simp (no_asm))
   apply (erule bin_rsplit_aux_len_indep)
   apply (rule refl)
   done
 
 
 subsection \<open>Logical operations\<close>
 
 abbreviation (input) bin_sc :: \<open>nat \<Rightarrow> bool \<Rightarrow> int \<Rightarrow> int\<close>
   where \<open>bin_sc n b i \<equiv> set_bit i n b\<close>
 
 lemma bin_sc_0 [simp]:
   "bin_sc 0 b w = of_bool b + 2 * (\<lambda>k::int. k div 2) w"
   by (simp add: set_bit_int_def)
 
 lemma bin_sc_Suc [simp]:
   "bin_sc (Suc n) b w = of_bool (odd w) + 2 * bin_sc n b (w div 2)"
   by (simp add: set_bit_int_def set_bit_Suc unset_bit_Suc bin_last_def)
 
 lemma bin_nth_sc [bit_simps]: "bit (bin_sc n b w) n \<longleftrightarrow> b"
   by (simp add: bit_simps)
 
 lemma bin_sc_sc_same [simp]: "bin_sc n c (bin_sc n b w) = bin_sc n c w"
   by (induction n arbitrary: w) (simp_all add: bit_Suc)
 
 lemma bin_sc_sc_diff: "m \<noteq> n \<Longrightarrow> bin_sc m c (bin_sc n b w) = bin_sc n b (bin_sc m c w)"
   apply (induct n arbitrary: w m)
    apply (case_tac [!] m)
      apply auto
   done
 
 lemma bin_nth_sc_gen: "(bit :: int \<Rightarrow> nat \<Rightarrow> bool) (bin_sc n b w) m = (if m = n then b else (bit :: int \<Rightarrow> nat \<Rightarrow> bool) w m)"
   apply (induct n arbitrary: w m)
    apply (case_tac m; simp add: bit_Suc)
   apply (case_tac m; simp add: bit_Suc)
   done
 
 lemma bin_sc_eq:
   \<open>bin_sc n False = unset_bit n\<close>
   \<open>bin_sc n True = Bit_Operations.set_bit n\<close>
    apply (simp_all add: fun_eq_iff bit_eq_iff)
   apply (simp_all add: bit_simps bin_nth_sc_gen)
   done
 
 lemma bin_sc_nth [simp]: "bin_sc n ((bit :: int \<Rightarrow> nat \<Rightarrow> bool) w n) w = w"
   by (rule bit_eqI) (simp add: bin_nth_sc_gen)
 
 lemma bin_sign_sc [simp]: "bin_sign (bin_sc n b w) = bin_sign w"
 proof (induction n arbitrary: w)
   case 0
   then show ?case
     by (auto simp add: bin_sign_def) (use bin_rest_ge_0 in fastforce)
 next
   case (Suc n)
   from Suc [of \<open>w div 2\<close>]
   show ?case by (auto simp add: bin_sign_def split: if_splits)
 qed
 
 lemma bin_sc_bintr [simp]:
   "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m (bin_sc n x ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m w)) = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m (bin_sc n x w)"
   apply (rule bit_eqI)
   apply (cases x)
    apply (auto simp add: bit_simps bin_sc_eq)
   done
 
 lemma bin_clr_le: "bin_sc n False w \<le> w"
   by (simp add: set_bit_int_def unset_bit_less_eq)
 
 lemma bin_set_ge: "bin_sc n True w \<ge> w"
   by (simp add: set_bit_int_def set_bit_greater_eq)
 
 lemma bintr_bin_clr_le: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (bin_sc m False w) \<le> (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w"
   by (simp add: set_bit_int_def take_bit_unset_bit_eq unset_bit_less_eq)
 
 lemma bintr_bin_set_ge: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (bin_sc m True w) \<ge> (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w"
   by (simp add: set_bit_int_def take_bit_set_bit_eq set_bit_greater_eq)
 
 lemma bin_sc_FP [simp]: "bin_sc n False 0 = 0"
   by (induct n) auto
 
 lemma bin_sc_TM [simp]: "bin_sc n True (- 1) = - 1"
   by (induct n) auto
 
 lemmas bin_sc_simps = bin_sc_0 bin_sc_Suc bin_sc_TM bin_sc_FP
 
 lemma bin_sc_minus: "0 < n \<Longrightarrow> bin_sc (Suc (n - 1)) b w = bin_sc n b w"
   by auto
 
 lemmas bin_sc_Suc_minus =
   trans [OF bin_sc_minus [symmetric] bin_sc_Suc]
 
 lemma bin_sc_numeral [simp]:
   "bin_sc (numeral k) b w =
     of_bool (odd w) + 2 * bin_sc (pred_numeral k) b (w div 2)"
   by (simp add: numeral_eq_Suc)
 
 lemmas bin_sc_minus_simps =
   bin_sc_simps (2,3,4) [THEN [2] trans, OF bin_sc_minus [THEN sym]]
 
 lemma int_set_bit_0 [simp]: fixes x :: int shows
   "set_bit x 0 b = of_bool b + 2 * (x div 2)"
   by (fact bin_sc_0)
 
 lemma int_set_bit_Suc: fixes x :: int shows
   "set_bit x (Suc n) b = of_bool (odd x) + 2 * set_bit (x div 2) n b"
   by (fact bin_sc_Suc)
 
 lemma bin_last_set_bit:
   "odd (set_bit x n b :: int) = (if n > 0 then odd x else b)"
   by (cases n) (simp_all add: int_set_bit_Suc)
 
 lemma bin_rest_set_bit:
   "(set_bit x n b :: int) div 2 = (if n > 0 then set_bit (x div 2) (n - 1) b else x div 2)"
   by (cases n) (simp_all add: int_set_bit_Suc)
 
 lemma int_set_bit_numeral: fixes x :: int shows
   "set_bit x (numeral w) b = of_bool (odd x) + 2 * set_bit (x div 2) (pred_numeral w) b"
   by (fact bin_sc_numeral)
 
 lemmas int_set_bit_numerals [simp] =
   int_set_bit_numeral[where x="numeral w'"]
   int_set_bit_numeral[where x="- numeral w'"]
   int_set_bit_numeral[where x="Numeral1"]
   int_set_bit_numeral[where x="1"]
   int_set_bit_numeral[where x="0"]
   int_set_bit_Suc[where x="numeral w'"]
   int_set_bit_Suc[where x="- numeral w'"]
   int_set_bit_Suc[where x="Numeral1"]
   int_set_bit_Suc[where x="1"]
   int_set_bit_Suc[where x="0"]
   for w'
 
 lemma msb_set_bit [simp]:
   "msb (set_bit (x :: int) n b) \<longleftrightarrow> msb x"
   by (simp add: msb_int_def set_bit_int_def)
 
 lemma word_set_bit_def:
   \<open>set_bit a n x = word_of_int (bin_sc n x (uint a))\<close>
   apply (rule bit_word_eqI)
   apply (cases x)
    apply (simp_all add: bit_simps bin_sc_eq)
   done
 
 lemma set_bit_word_of_int:
   "set_bit (word_of_int x) n b = word_of_int (bin_sc n b x)"
   unfolding word_set_bit_def
   by (rule word_eqI) (simp add: word_size bin_nth_sc_gen nth_bintr bit_simps)
 
 lemma word_set_numeral [simp]:
   "set_bit (numeral bin::'a::len word) n b =
     word_of_int (bin_sc n b (numeral bin))"
   unfolding word_numeral_alt by (rule set_bit_word_of_int)
 
 lemma word_set_neg_numeral [simp]:
   "set_bit (- numeral bin::'a::len word) n b =
     word_of_int (bin_sc n b (- numeral bin))"
   unfolding word_neg_numeral_alt by (rule set_bit_word_of_int)
 
 lemma word_set_bit_0 [simp]: "set_bit 0 n b = word_of_int (bin_sc n b 0)"
   unfolding word_0_wi by (rule set_bit_word_of_int)
 
 lemma word_set_bit_1 [simp]: "set_bit 1 n b = word_of_int (bin_sc n b 1)"
   unfolding word_1_wi by (rule set_bit_word_of_int)
 
 lemma shiftl_int_def:
   "push_bit n x = x * 2 ^ n" for x :: int
   by (fact push_bit_eq_mult)
 
 lemma shiftr_int_def:
   "drop_bit n x = x div 2 ^ n" for x :: int
   by (fact drop_bit_eq_div)
 
 
 subsubsection \<open>Basic simplification rules\<close>
 
 context
   includes bit_operations_syntax
 begin
 
 lemmas int_not_def = not_int_def
 
 lemma int_not_simps:
   "NOT (0::int) = -1"
   "NOT (1::int) = -2"
   "NOT (- 1::int) = 0"
   "NOT (numeral w::int) = - numeral (w + Num.One)"
   "NOT (- numeral (Num.Bit0 w)::int) = numeral (Num.BitM w)"
   "NOT (- numeral (Num.Bit1 w)::int) = numeral (Num.Bit0 w)"
   by (simp_all add: not_int_def)
 
 lemma int_not_not: "NOT (NOT x) = x"
   for x :: int
   by (fact bit.double_compl)
 
 lemma int_and_0 [simp]: "0 AND x = 0"
   for x :: int
   by (fact bit.conj_zero_left)
 
 lemma int_and_m1 [simp]: "-1 AND x = x"
   for x :: int
-  by (fact bit.conj_one_left)
+  by (fact and.left_neutral)
 
 lemma int_or_zero [simp]: "0 OR x = x"
   for x :: int
-  by (fact bit.disj_zero_left)
+  by (fact or.left_neutral)
 
 lemma int_or_minus1 [simp]: "-1 OR x = -1"
   for x :: int
   by (fact bit.disj_one_left)
 
 lemma int_xor_zero [simp]: "0 XOR x = x"
   for x :: int
-  by (fact bit.xor_zero_left)
+  by (fact xor.left_neutral)
 
 
 subsubsection \<open>Binary destructors\<close>
 
 lemma bin_rest_NOT [simp]: "(\<lambda>k::int. k div 2) (NOT x) = NOT ((\<lambda>k::int. k div 2) x)"
   by (fact not_int_div_2)
 
 lemma bin_last_NOT [simp]: "(odd :: int \<Rightarrow> bool) (NOT x) \<longleftrightarrow> \<not> (odd :: int \<Rightarrow> bool) x"
   by simp
 
 lemma bin_rest_AND [simp]: "(\<lambda>k::int. k div 2) (x AND y) = (\<lambda>k::int. k div 2) x AND (\<lambda>k::int. k div 2) y"
   by (subst and_int_rec) auto
 
 lemma bin_last_AND [simp]: "(odd :: int \<Rightarrow> bool) (x AND y) \<longleftrightarrow> (odd :: int \<Rightarrow> bool) x \<and> (odd :: int \<Rightarrow> bool) y"
   by (subst and_int_rec) auto
 
 lemma bin_rest_OR [simp]: "(\<lambda>k::int. k div 2) (x OR y) = (\<lambda>k::int. k div 2) x OR (\<lambda>k::int. k div 2) y"
   by (subst or_int_rec) auto
 
 lemma bin_last_OR [simp]: "(odd :: int \<Rightarrow> bool) (x OR y) \<longleftrightarrow> (odd :: int \<Rightarrow> bool) x \<or> (odd :: int \<Rightarrow> bool) y"
   by (subst or_int_rec) auto
 
 lemma bin_rest_XOR [simp]: "(\<lambda>k::int. k div 2) (x XOR y) = (\<lambda>k::int. k div 2) x XOR (\<lambda>k::int. k div 2) y"
   by (subst xor_int_rec) auto
 
 lemma bin_last_XOR [simp]: "(odd :: int \<Rightarrow> bool) (x XOR y) \<longleftrightarrow> ((odd :: int \<Rightarrow> bool) x \<or> (odd :: int \<Rightarrow> bool) y) \<and> \<not> ((odd :: int \<Rightarrow> bool) x \<and> (odd :: int \<Rightarrow> bool) y)"
   by (subst xor_int_rec) auto
 
 lemma bin_nth_ops:
   "\<And>x y. (bit :: int \<Rightarrow> nat \<Rightarrow> bool) (x AND y) n \<longleftrightarrow> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) x n \<and> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) y n"
   "\<And>x y. (bit :: int \<Rightarrow> nat \<Rightarrow> bool) (x OR y) n \<longleftrightarrow> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) x n \<or> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) y n"
   "\<And>x y. (bit :: int \<Rightarrow> nat \<Rightarrow> bool) (x XOR y) n \<longleftrightarrow> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) x n \<noteq> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) y n"
   "\<And>x. (bit :: int \<Rightarrow> nat \<Rightarrow> bool) (NOT x) n \<longleftrightarrow> \<not> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) x n"
   by (simp_all add: bit_and_iff bit_or_iff bit_xor_iff bit_not_iff)
 
 
 subsubsection \<open>Derived properties\<close>
 
 lemma int_xor_minus1 [simp]: "-1 XOR x = NOT x"
   for x :: int
   by (fact bit.xor_one_left)
 
 lemma int_xor_extra_simps [simp]:
   "w XOR 0 = w"
   "w XOR -1 = NOT w"
   for w :: int
   by simp_all
 
 lemma int_or_extra_simps [simp]:
   "w OR 0 = w"
   "w OR -1 = -1"
   for w :: int
   by simp_all
 
 lemma int_and_extra_simps [simp]:
   "w AND 0 = 0"
   "w AND -1 = w"
   for w :: int
   by simp_all
 
 text \<open>Commutativity of the above.\<close>
 lemma bin_ops_comm:
   fixes x y :: int
   shows int_and_comm: "x AND y = y AND x"
     and int_or_comm:  "x OR y = y OR x"
     and int_xor_comm: "x XOR y = y XOR x"
   by (simp_all add: ac_simps)
 
 lemma bin_ops_same [simp]:
   "x AND x = x"
   "x OR x = x"
   "x XOR x = 0"
   for x :: int
   by simp_all
 
 lemmas bin_log_esimps =
   int_and_extra_simps  int_or_extra_simps  int_xor_extra_simps
   int_and_0 int_and_m1 int_or_zero int_or_minus1 int_xor_zero int_xor_minus1
 
 
 subsubsection \<open>Basic properties of logical (bit-wise) operations\<close>
 
 lemma bbw_ao_absorb: "x AND (y OR x) = x \<and> x OR (y AND x) = x"
   for x y :: int
   by (auto simp add: bin_eq_iff bin_nth_ops)
 
 lemma bbw_ao_absorbs_other:
   "x AND (x OR y) = x \<and> (y AND x) OR x = x"
   "(y OR x) AND x = x \<and> x OR (x AND y) = x"
   "(x OR y) AND x = x \<and> (x AND y) OR x = x"
   for x y :: int
   by (auto simp add: bin_eq_iff bin_nth_ops)
 
 lemmas bbw_ao_absorbs [simp] = bbw_ao_absorb bbw_ao_absorbs_other
 
 lemma int_xor_not: "(NOT x) XOR y = NOT (x XOR y) \<and> x XOR (NOT y) = NOT (x XOR y)"
   for x y :: int
   by (auto simp add: bin_eq_iff bin_nth_ops)
 
 lemma int_and_assoc: "(x AND y) AND z = x AND (y AND z)"
   for x y z :: int
   by (auto simp add: bin_eq_iff bin_nth_ops)
 
 lemma int_or_assoc: "(x OR y) OR z = x OR (y OR z)"
   for x y z :: int
   by (auto simp add: bin_eq_iff bin_nth_ops)
 
 lemma int_xor_assoc: "(x XOR y) XOR z = x XOR (y XOR z)"
   for x y z :: int
   by (auto simp add: bin_eq_iff bin_nth_ops)
 
 lemmas bbw_assocs = int_and_assoc int_or_assoc int_xor_assoc
 
 (* BH: Why are these declared as simp rules??? *)
 lemma bbw_lcs [simp]:
   "y AND (x AND z) = x AND (y AND z)"
   "y OR (x OR z) = x OR (y OR z)"
   "y XOR (x XOR z) = x XOR (y XOR z)"
   for x y :: int
   by (auto simp add: bin_eq_iff bin_nth_ops)
 
 lemma bbw_not_dist:
   "NOT (x OR y) = (NOT x) AND (NOT y)"
   "NOT (x AND y) = (NOT x) OR (NOT y)"
   for x y :: int
   by (auto simp add: bin_eq_iff bin_nth_ops)
 
 lemma bbw_oa_dist: "(x AND y) OR z = (x OR z) AND (y OR z)"
   for x y z :: int
   by (auto simp add: bin_eq_iff bin_nth_ops)
 
 lemma bbw_ao_dist: "(x OR y) AND z = (x AND z) OR (y AND z)"
   for x y z :: int
   by (auto simp add: bin_eq_iff bin_nth_ops)
 
 
 subsubsection \<open>Simplification with numerals\<close>
 
 text \<open>Cases for \<open>0\<close> and \<open>-1\<close> are already covered by other simp rules.\<close>
 
 lemma bin_rest_neg_numeral_BitM [simp]:
   "(\<lambda>k::int. k div 2) (- numeral (Num.BitM w)) = - numeral w"
   by simp
 
 lemma bin_last_neg_numeral_BitM [simp]:
   "(odd :: int \<Rightarrow> bool) (- numeral (Num.BitM w))"
   by simp
 
 
 subsubsection \<open>Interactions with arithmetic\<close>
 
 lemma le_int_or: "bin_sign y = 0 \<Longrightarrow> x \<le> x OR y"
   for x y :: int
   by (simp add: bin_sign_def or_greater_eq split: if_splits)
 
 lemmas int_and_le =
   xtrans(3) [OF bbw_ao_absorbs (2) [THEN conjunct2, symmetric] le_int_or]
 
 text \<open>Interaction between bit-wise and arithmetic: good example of \<open>bin_induction\<close>.\<close>
 lemma bin_add_not: "x + NOT x = (-1::int)"
   by (simp add: not_int_def)
 
 lemma AND_mod: "x AND (2 ^ n - 1) = x mod 2 ^ n"
   for x :: int
   by (simp flip: take_bit_eq_mod add: take_bit_eq_mask mask_eq_exp_minus_1)
 
 
 subsubsection \<open>Truncating results of bit-wise operations\<close>
 
 lemma bin_trunc_ao:
   "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n x AND (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n y = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (x AND y)"
   "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n x OR (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n y = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (x OR y)"
   by simp_all
 
 lemma bin_trunc_xor: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n x XOR (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n y) = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (x XOR y)"
   by simp
 
 lemma bin_trunc_not: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (NOT ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n x)) = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (NOT x)"
   by (fact take_bit_not_take_bit)
 
 text \<open>Want theorems of the form of \<open>bin_trunc_xor\<close>.\<close>
 lemma bintr_bintr_i: "x = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n y \<Longrightarrow> (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n x = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n y"
   by auto
 
 lemmas bin_trunc_and = bin_trunc_ao(1) [THEN bintr_bintr_i]
 lemmas bin_trunc_or = bin_trunc_ao(2) [THEN bintr_bintr_i]
 
 
 subsubsection \<open>More lemmas\<close>
 
 lemma not_int_cmp_0 [simp]:
   fixes i :: int shows
   "0 < NOT i \<longleftrightarrow> i < -1"
   "0 \<le> NOT i \<longleftrightarrow> i < 0"
   "NOT i < 0 \<longleftrightarrow> i \<ge> 0"
   "NOT i \<le> 0 \<longleftrightarrow> i \<ge> -1"
 by(simp_all add: int_not_def) arith+
 
 lemma bbw_ao_dist2: "(x :: int) AND (y OR z) = x AND y OR x AND z"
   by (fact bit.conj_disj_distrib)
 
 lemmas int_and_ac = bbw_lcs(1) int_and_comm int_and_assoc
 
 lemma int_nand_same [simp]: fixes x :: int shows "x AND NOT x = 0"
   by simp
 
 lemma int_nand_same_middle: fixes x :: int shows "x AND y AND NOT x = 0"
   by (simp add: bit_eq_iff bit_and_iff bit_not_iff)
 
 lemma and_xor_dist: fixes x :: int shows
   "x AND (y XOR z) = (x AND y) XOR (x AND z)"
   by (fact bit.conj_xor_distrib)
 
 lemma int_and_lt0 [simp]:
   \<open>x AND y < 0 \<longleftrightarrow> x < 0 \<and> y < 0\<close> for x y :: int
   by (fact and_negative_int_iff)
 
 lemma int_and_ge0 [simp]:
   \<open>x AND y \<ge> 0 \<longleftrightarrow> x \<ge> 0 \<or> y \<ge> 0\<close> for x y :: int
   by (fact and_nonnegative_int_iff)
 
 lemma int_and_1: fixes x :: int shows "x AND 1 = x mod 2"
   by (fact and_one_eq)
 
 lemma int_1_and: fixes x :: int shows "1 AND x = x mod 2"
   by (fact one_and_eq)
 
 lemma int_or_lt0 [simp]:
   \<open>x OR y < 0 \<longleftrightarrow> x < 0 \<or> y < 0\<close> for x y :: int
   by (fact or_negative_int_iff)
 
 lemma int_or_ge0 [simp]:
   \<open>x OR y \<ge> 0 \<longleftrightarrow> x \<ge> 0 \<and> y \<ge> 0\<close> for x y :: int
   by (fact or_nonnegative_int_iff)
 
 lemma int_xor_lt0 [simp]:
   \<open>x XOR y < 0 \<longleftrightarrow> (x < 0) \<noteq> (y < 0)\<close> for x y :: int
   by (fact xor_negative_int_iff)
 
 lemma int_xor_ge0 [simp]:
   \<open>x XOR y \<ge> 0 \<longleftrightarrow> (x \<ge> 0 \<longleftrightarrow> y \<ge> 0)\<close> for x y :: int
   by (fact xor_nonnegative_int_iff)
 
 lemma even_conv_AND:
   \<open>even i \<longleftrightarrow> i AND 1 = 0\<close> for i :: int
   by (simp add: and_one_eq mod2_eq_if)
 
 lemma bin_last_conv_AND:
   "(odd :: int \<Rightarrow> bool) i \<longleftrightarrow> i AND 1 \<noteq> 0"
   by (simp add: and_one_eq mod2_eq_if)
 
 lemma bitval_bin_last:
   "of_bool ((odd :: int \<Rightarrow> bool) i) = i AND 1"
   by (simp add: and_one_eq mod2_eq_if)
 
 lemma bin_sign_and:
   "bin_sign (i AND j) = - (bin_sign i * bin_sign j)"
 by(simp add: bin_sign_def)
 
 lemma int_not_neg_numeral: "NOT (- numeral n) = (Num.sub n num.One :: int)"
 by(simp add: int_not_def)
 
 lemma int_neg_numeral_pOne_conv_not: "- numeral (n + num.One) = (NOT (numeral n) :: int)"
 by(simp add: int_not_def)
 
 
 subsection \<open>Setting and clearing bits\<close>
 
 lemma int_shiftl_BIT: fixes x :: int
   shows int_shiftl0: "push_bit 0 x = x"
   and int_shiftl_Suc: "push_bit (Suc n) x = 2 * push_bit n x"
   by (auto simp add: shiftl_int_def)
 
 lemma int_0_shiftl: "push_bit n 0 = (0 :: int)"
   by (fact push_bit_of_0)
 
 lemma bin_last_shiftl: "odd (push_bit n x) \<longleftrightarrow> n = 0 \<and> (odd :: int \<Rightarrow> bool) x"
   by simp
 
 lemma bin_rest_shiftl: "(\<lambda>k::int. k div 2) (push_bit n x) = (if n > 0 then push_bit (n - 1) x else (\<lambda>k::int. k div 2) x)"
   by (cases n) (simp_all add: push_bit_eq_mult)
 
 lemma bin_nth_shiftl: "(bit :: int \<Rightarrow> nat \<Rightarrow> bool) (push_bit n x) m \<longleftrightarrow> n \<le> m \<and> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) x (m - n)"
   by (fact bit_push_bit_iff_int)
 
 lemma bin_last_shiftr: "odd (drop_bit n x) \<longleftrightarrow> bit x n" for x :: int
   by (simp add: bit_iff_odd_drop_bit)
 
 lemma bin_rest_shiftr: "(\<lambda>k::int. k div 2) (drop_bit n x) = drop_bit (Suc n) x"
   by (simp add: drop_bit_Suc drop_bit_half)
 
 lemma bin_nth_shiftr: "(bit :: int \<Rightarrow> nat \<Rightarrow> bool) (drop_bit n x) m = (bit :: int \<Rightarrow> nat \<Rightarrow> bool) x (n + m)"
   by (simp add: bit_simps)
 
 lemma bin_nth_conv_AND:
   fixes x :: int shows
   "(bit :: int \<Rightarrow> nat \<Rightarrow> bool) x n \<longleftrightarrow> x AND (push_bit n 1) \<noteq> 0"
   by (fact bit_iff_and_push_bit_not_eq_0)
 
 lemma int_shiftl_numeral [simp]:
   "push_bit (numeral w') (numeral w :: int) = push_bit (pred_numeral w') (numeral (num.Bit0 w))"
   "push_bit (numeral w') (- numeral w :: int) = push_bit (pred_numeral w') (- numeral (num.Bit0 w))"
 by(simp_all add: numeral_eq_Suc shiftl_int_def)
   (metis add_One mult_inc semiring_norm(11) semiring_norm(13) semiring_norm(2) semiring_norm(6) semiring_norm(87))+
 
 lemma int_shiftl_One_numeral [simp]:
   "push_bit (numeral w) (1::int) = push_bit (pred_numeral w) 2"
   using int_shiftl_numeral [of Num.One w]
   by (simp add: numeral_eq_Suc) 
 
 lemma shiftl_ge_0: fixes i :: int shows "push_bit n i \<ge> 0 \<longleftrightarrow> i \<ge> 0"
   by (fact push_bit_nonnegative_int_iff)
 
 lemma shiftl_lt_0: fixes i :: int shows "push_bit n i < 0 \<longleftrightarrow> i < 0"
   by (fact push_bit_negative_int_iff)
 
 lemma int_shiftl_test_bit: "bit (push_bit i n :: int) m \<longleftrightarrow> m \<ge> i \<and> bit n (m - i)"
   by (fact bit_push_bit_iff_int)
 
 lemma int_0shiftr: "drop_bit x (0 :: int) = 0"
   by (fact drop_bit_of_0)
 
 lemma int_minus1_shiftr: "drop_bit x (-1 :: int) = -1"
   by (fact drop_bit_minus_one)
 
 lemma int_shiftr_ge_0: fixes i :: int shows "drop_bit n i \<ge> 0 \<longleftrightarrow> i \<ge> 0"
   by (fact drop_bit_nonnegative_int_iff)
 
 lemma int_shiftr_lt_0 [simp]: fixes i :: int shows "drop_bit n i < 0 \<longleftrightarrow> i < 0"
   by (fact drop_bit_negative_int_iff)
 
 lemma int_shiftr_numeral [simp]:
   "drop_bit (numeral w') (1 :: int) = 0"
   "drop_bit (numeral w') (numeral num.One :: int) = 0"
   "drop_bit (numeral w') (numeral (num.Bit0 w) :: int) = drop_bit (pred_numeral w') (numeral w)"
   "drop_bit (numeral w') (numeral (num.Bit1 w) :: int) = drop_bit (pred_numeral w') (numeral w)"
   "drop_bit (numeral w') (- numeral (num.Bit0 w) :: int) = drop_bit (pred_numeral w') (- numeral w)"
   "drop_bit (numeral w') (- numeral (num.Bit1 w) :: int) = drop_bit (pred_numeral w') (- numeral (Num.inc w))"
   by (simp_all add: numeral_eq_Suc add_One drop_bit_Suc)
 
 lemma int_shiftr_numeral_Suc0 [simp]:
   "drop_bit (Suc 0) (1 :: int) = 0"
   "drop_bit (Suc 0) (numeral num.One :: int) = 0"
   "drop_bit (Suc 0) (numeral (num.Bit0 w) :: int) = numeral w"
   "drop_bit (Suc 0) (numeral (num.Bit1 w) :: int) = numeral w"
   "drop_bit (Suc 0) (- numeral (num.Bit0 w) :: int) = - numeral w"
   "drop_bit (Suc 0) (- numeral (num.Bit1 w) :: int) = - numeral (Num.inc w)"
   by (simp_all add: drop_bit_Suc add_One)
 
 lemma bin_nth_minus_p2:
   assumes sign: "bin_sign x = 0"
   and y: "y = push_bit n 1"
   and m: "m < n"
   and x: "x < y"
   shows "bit (x - y) m = bit x m"
 proof -
   from sign y x have \<open>x \<ge> 0\<close> and \<open>y = 2 ^ n\<close> and \<open>x < 2 ^ n\<close>
     by (simp_all add: bin_sign_def push_bit_eq_mult split: if_splits)
   from \<open>0 \<le> x\<close> \<open>x < 2 ^ n\<close> \<open>m < n\<close> have \<open>bit x m \<longleftrightarrow> bit (x - 2 ^ n) m\<close>
   proof (induction m arbitrary: x n)
     case 0
     then show ?case
       by simp
   next
     case (Suc m)
     moreover define q where \<open>q = n - 1\<close>
     ultimately have n: \<open>n = Suc q\<close>
       by simp
     have \<open>(x - 2 ^ Suc q) div 2 = x div 2 - 2 ^ q\<close>
       by simp
     moreover from Suc.IH [of \<open>x div 2\<close> q] Suc.prems
     have \<open>bit (x div 2) m \<longleftrightarrow> bit (x div 2 - 2 ^ q) m\<close>
       by (simp add: n)
     ultimately show ?case
       by (simp add: bit_Suc n)
   qed
   with \<open>y = 2 ^ n\<close> show ?thesis
     by simp
 qed
 
 lemma bin_clr_conv_NAND:
   "bin_sc n False i = i AND NOT (push_bit n 1)"
   by (rule bit_eqI) (auto simp add: bin_sc_eq bit_simps)
 
 lemma bin_set_conv_OR:
   "bin_sc n True i = i OR (push_bit n 1)"
   by (rule bit_eqI) (auto simp add: bin_sc_eq bit_simps)
 
 end
 
 
 subsection \<open>More lemmas on words\<close>
 
 lemma msb_conv_bin_sign:
   "msb x \<longleftrightarrow> bin_sign x = -1"
   by (simp add: bin_sign_def not_le msb_int_def)
 
 lemma msb_bin_sc [simp]:
   "msb (bin_sc n b x) \<longleftrightarrow> msb x"
   by (simp add: msb_conv_bin_sign)
 
 lemma msb_word_def:
   \<open>msb a \<longleftrightarrow> bin_sign (signed_take_bit (LENGTH('a) - 1) (uint a)) = - 1\<close>
   for a :: \<open>'a::len word\<close>
   by (simp add: bin_sign_def bit_simps msb_word_iff_bit)
 
 lemma word_msb_def:
   "msb a \<longleftrightarrow> bin_sign (sint a) = - 1"
   by (simp add: msb_word_def sint_uint)
 
 lemma word_rcat_eq:
   \<open>word_rcat ws = word_of_int (bin_rcat (LENGTH('a::len)) (map uint ws))\<close>
   for ws :: \<open>'a::len word list\<close>
   apply (simp add: word_rcat_def bin_rcat_def rev_map)
   apply transfer
   apply (simp add: horner_sum_foldr foldr_map comp_def)
   done
 
 lemma sign_uint_Pls [simp]: "bin_sign (uint x) = 0"
   by (simp add: sign_Pls_ge_0)
 
 lemmas bin_log_bintrs = bin_trunc_not bin_trunc_xor bin_trunc_and bin_trunc_or
 
 \<comment> \<open>following definitions require both arithmetic and bit-wise word operations\<close>
 
 \<comment> \<open>to get \<open>word_no_log_defs\<close> from \<open>word_log_defs\<close>, using \<open>bin_log_bintrs\<close>\<close>
 lemmas wils1 = bin_log_bintrs [THEN word_of_int_eq_iff [THEN iffD2],
   folded uint_word_of_int_eq, THEN eq_reflection]
 
 \<comment> \<open>the binary operations only\<close>  (* BH: why is this needed? *)
 lemmas word_log_binary_defs =
   word_and_def word_or_def word_xor_def
 
 lemma setBit_no: "Bit_Operations.set_bit n (numeral bin) = word_of_int (bin_sc n True (numeral bin))"
   by (rule bit_word_eqI) (simp add: bit_simps)
 
 lemma clearBit_no:
   "unset_bit n (numeral bin) = word_of_int (bin_sc n False (numeral bin))"
   by (rule bit_word_eqI) (simp add: bit_simps)
 
 lemma eq_mod_iff: "0 < n \<Longrightarrow> b = b mod n \<longleftrightarrow> 0 \<le> b \<and> b < n"
   for b n :: int
   by auto (metis pos_mod_conj)+
 
 lemma split_uint_lem: "bin_split n (uint w) = (a, b) \<Longrightarrow>
     a = take_bit (LENGTH('a) - n) a \<and> b = take_bit (LENGTH('a)) b"
   for w :: "'a::len word"
   by transfer (simp add: drop_bit_take_bit ac_simps)
 
 \<comment> \<open>limited hom result\<close>
 lemma word_cat_hom:
   "LENGTH('a::len) \<le> LENGTH('b::len) + LENGTH('c::len) \<Longrightarrow>
     (word_cat (word_of_int w :: 'b word) (b :: 'c word) :: 'a word) =
     word_of_int ((\<lambda>k n l. concat_bit n l k) w (size b) (uint b))"
   by transfer (simp add: take_bit_concat_bit_eq)
 
 lemma bintrunc_shiftl:
   "take_bit n (push_bit i m) = push_bit i (take_bit (n - i) m)"
   for m :: int
   by (fact take_bit_push_bit)
 
 lemma uint_shiftl:
   "uint (push_bit i n) = take_bit (size n) (push_bit i (uint n))"
   by (simp add: unsigned_push_bit_eq word_size)
 
 lemma bin_mask_conv_pow2:
   "mask n = 2 ^ n - (1 :: int)"
   by (fact mask_eq_exp_minus_1)
 
 lemma bin_mask_ge0: "mask n \<ge> (0 :: int)"
   by (fact mask_nonnegative_int)
 
 context
   includes bit_operations_syntax
 begin
 
 lemma and_bin_mask_conv_mod: "x AND mask n = x mod 2 ^ n"
   for x :: int
   by (simp flip: take_bit_eq_mod add: take_bit_eq_mask)
 
 end
 
 lemma bin_mask_numeral:
   "mask (numeral n) = (1 :: int) + 2 * mask (pred_numeral n)"
   by (fact mask_numeral)
 
 lemma bin_nth_mask: "bit (mask n :: int) i \<longleftrightarrow> i < n"
   by (simp add: bit_mask_iff)
 
 lemma bin_sign_mask [simp]: "bin_sign (mask n) = 0"
   by (simp add: bin_sign_def bin_mask_conv_pow2)
 
 lemma bin_mask_p1_conv_shift: "mask n + 1 = push_bit n (1 :: int)"
   by (simp add: bin_mask_conv_pow2 shiftl_int_def)
 
 lemma sbintrunc_eq_in_range:
   "((signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n x = x) = (x \<in> range ((signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n))"
   "(x = (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n x) = (x \<in> range ((signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n))"
   apply (simp_all add: image_def)
   apply (metis sbintrunc_sbintrunc)+
   done
 
 lemma sbintrunc_If:
   "- 3 * (2 ^ n) \<le> x \<and> x < 3 * (2 ^ n)
     \<Longrightarrow> (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n x = (if x < - (2 ^ n) then x + 2 * (2 ^ n)
         else if x \<ge> 2 ^ n then x - 2 * (2 ^ n) else x)"
   apply (simp add: no_sbintr_alt2, safe)
    apply (simp add: mod_pos_geq)
   apply (subst mod_add_self1[symmetric], simp)
   done
 
 lemma sint_range':
   \<open>- (2 ^ (LENGTH('a) - Suc 0)) \<le> sint x \<and> sint x < 2 ^ (LENGTH('a) - Suc 0)\<close>
   for x :: \<open>'a::len word\<close>
   apply transfer
   using sbintr_ge sbintr_lt apply auto
   done
 
 lemma signed_arith_eq_checks_to_ord:
   "(sint a + sint b = sint (a + b ))
     = ((a <=s a + b) = (0 <=s b))"
   "(sint a - sint b = sint (a - b ))
     = ((0 <=s a - b) = (b <=s a))"
   "(- sint a = sint (- a)) = (0 <=s (- a) = (a <=s 0))"
   using sint_range'[where x=a] sint_range'[where x=b]
   by (simp_all add: sint_word_ariths word_sle_eq word_sless_alt sbintrunc_If)
 
 lemma signed_mult_eq_checks_double_size:
   assumes mult_le: "(2 ^ (len_of TYPE ('a) - 1) + 1) ^ 2 \<le> (2 :: int) ^ (len_of TYPE ('b) - 1)"
            and le: "2 ^ (LENGTH('a) - 1) \<le> (2 :: int) ^ (len_of TYPE ('b) - 1)"
   shows "(sint (a :: 'a :: len word) * sint b = sint (a * b))
        = (scast a * scast b = (scast (a * b) :: 'b :: len word))"
 proof -
   have P: "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (size a - 1) (sint a * sint b) \<in> range ((signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (size a - 1))"
     by simp
 
   have abs: "!! x :: 'a word. abs (sint x) < 2 ^ (size a - 1) + 1"
     apply (cut_tac x=x in sint_range')
     apply (simp add: abs_le_iff word_size)
     done
   have abs_ab: "abs (sint a * sint b) < 2 ^ (LENGTH('b) - 1)"
     using abs_mult_less[OF abs[where x=a] abs[where x=b]] mult_le
     by (simp add: abs_mult power2_eq_square word_size)
   define r s where \<open>r = LENGTH('a) - 1\<close> \<open>s = LENGTH('b) - 1\<close>
   then have \<open>LENGTH('a) = Suc r\<close> \<open>LENGTH('b) = Suc s\<close>
     \<open>size a = Suc r\<close> \<open>size b = Suc r\<close>
     by (simp_all add: word_size)
   then show ?thesis
     using P[unfolded range_sbintrunc] abs_ab le
     apply clarsimp
     apply (transfer fixing: r s)
     apply (auto simp add: signed_take_bit_int_eq_self min.absorb2 simp flip: signed_take_bit_eq_iff_take_bit_eq)
     done
 qed
 
 lemma bintrunc_id:
   "\<lbrakk>m \<le> int n; 0 < m\<rbrakk> \<Longrightarrow> take_bit n m = m"
   by (simp add: take_bit_int_eq_self_iff le_less_trans less_exp)
 
 lemma bin_cat_cong: "concat_bit n b a = concat_bit m d c"
   if "n = m" "a = c" "take_bit m b = take_bit m d"
   using that(3) unfolding that(1,2)
   by (simp add: bin_cat_eq_push_bit_add_take_bit)
 
 lemma bin_cat_eqD1: "concat_bit n b a = concat_bit n d c \<Longrightarrow> a = c"
   by (metis drop_bit_bin_cat_eq)
 
 lemma bin_cat_eqD2: "concat_bit n b a = concat_bit n d c \<Longrightarrow> take_bit n b = take_bit n d"
   by (metis take_bit_bin_cat_eq)
 
 lemma bin_cat_inj: "(concat_bit n b a) = concat_bit n d c \<longleftrightarrow> a = c \<and> take_bit n b = take_bit n d"
   by (auto intro: bin_cat_cong bin_cat_eqD1 bin_cat_eqD2)
 
 code_identifier
   code_module Bits_Int \<rightharpoonup>
   (SML) Bit_Operations and (OCaml) Bit_Operations and (Haskell) Bit_Operations and (Scala) Bit_Operations
 
 end
diff --git a/thys/Word_Lib/Legacy_Aliases.thy b/thys/Word_Lib/Legacy_Aliases.thy
--- a/thys/Word_Lib/Legacy_Aliases.thy
+++ b/thys/Word_Lib/Legacy_Aliases.thy
@@ -1,212 +1,271 @@
 (*
  * Copyright Data61, CSIRO (ABN 41 687 119 230)
  *
  * SPDX-License-Identifier: BSD-2-Clause
  *)
 
 section \<open>Legacy aliases\<close>
 
 theory Legacy_Aliases
   imports "HOL-Library.Word"
 begin
 
+context abstract_boolean_algebra
+begin
+
+lemma conj_assoc: "(x \<^bold>\<sqinter> y) \<^bold>\<sqinter> z = x \<^bold>\<sqinter> (y \<^bold>\<sqinter> z)"
+  by (fact conj.assoc)
+
+lemma conj_commute: "x \<^bold>\<sqinter> y = y \<^bold>\<sqinter> x"
+  by (fact conj.commute)
+
+lemmas conj_left_commute = conj.left_commute
+lemmas conj_ac = conj.assoc conj.commute conj.left_commute
+
+lemma conj_one_left: "\<^bold>1 \<^bold>\<sqinter> x = x"
+  by (fact conj.left_neutral)
+
+lemma conj_left_absorb: "x \<^bold>\<sqinter> (x \<^bold>\<sqinter> y) = x \<^bold>\<sqinter> y"
+  by (fact conj.left_idem)
+
+lemma conj_absorb: "x \<^bold>\<sqinter> x = x"
+  by (fact conj.idem)
+
+lemma disj_assoc: "(x \<^bold>\<squnion> y) \<^bold>\<squnion> z = x \<^bold>\<squnion> (y \<^bold>\<squnion> z)"
+  by (fact disj.assoc)
+
+lemma disj_commute: "x \<^bold>\<squnion> y = y \<^bold>\<squnion> x"
+  by (fact disj.commute)
+
+lemmas disj_left_commute = disj.left_commute
+
+lemmas disj_ac = disj.assoc disj.commute disj.left_commute
+
+lemma disj_zero_left: "\<^bold>0 \<^bold>\<squnion> x = x"
+  by (fact disj.left_neutral)
+
+lemma disj_left_absorb: "x \<^bold>\<squnion> (x \<^bold>\<squnion> y) = x \<^bold>\<squnion> y"
+  by (fact disj.left_idem)
+
+lemma disj_absorb: "x \<^bold>\<squnion> x = x"
+  by (fact disj.idem)
+
+end
+
+context abstract_boolean_algebra_sym_diff
+begin
+
+lemmas xor_assoc = xor.assoc
+lemmas xor_commute = xor.commute
+lemmas xor_left_commute = xor.left_commute
+
+lemmas xor_ac = xor.assoc xor.commute xor.left_commute
+
+lemma xor_zero_right: "x \<^bold>\<ominus> \<^bold>0 = x"
+  by (fact xor.comm_neutral)
+
+lemma xor_zero_left: "\<^bold>0 \<^bold>\<ominus> x = x"
+  by (fact xor.left_neutral)
+
+end
+
 abbreviation (input) test_bit :: \<open>'a::semiring_bits \<Rightarrow> nat \<Rightarrow> bool\<close>
   where \<open>test_bit \<equiv> bit\<close>
 
 abbreviation (input) bin_nth :: \<open>int \<Rightarrow> nat \<Rightarrow> bool\<close>
   where \<open>bin_nth \<equiv> bit\<close>
 
 abbreviation (input) bin_last :: \<open>int \<Rightarrow> bool\<close>
   where \<open>bin_last \<equiv> odd\<close>
 
 abbreviation (input) bin_rest :: \<open>int \<Rightarrow> int\<close>
   where \<open>bin_rest w \<equiv> w div 2\<close>
 
 abbreviation (input) bintrunc :: \<open>nat \<Rightarrow> int \<Rightarrow> int\<close>
   where \<open>bintrunc \<equiv> take_bit\<close>
 
 abbreviation (input) sbintrunc :: \<open>nat \<Rightarrow> int \<Rightarrow> int\<close>
   where \<open>sbintrunc \<equiv> signed_take_bit\<close>
 
 abbreviation (input) bin_cat :: \<open>int \<Rightarrow> nat \<Rightarrow> int \<Rightarrow> int\<close>
   where \<open>bin_cat k n l \<equiv> concat_bit n l k\<close>
 
 abbreviation (input) norm_sint :: \<open>nat \<Rightarrow> int \<Rightarrow> int\<close>
   where \<open>norm_sint n \<equiv> signed_take_bit (n - 1)\<close>
 
 abbreviation (input) max_word :: \<open>'a::len word\<close>
   where \<open>max_word \<equiv> - 1\<close>
 
 abbreviation (input) complement :: \<open>'a::len word \<Rightarrow> 'a word\<close>
   where \<open>complement \<equiv> not\<close>
 
 lemma complement_mask:
   "complement (2 ^ n - 1) = NOT (mask n)"
   unfolding mask_eq_decr_exp by simp
 
 abbreviation (input) shiftl1 :: \<open>'a::len word \<Rightarrow> 'a word\<close>
   where \<open>shiftl1 \<equiv> (*) 2\<close>
 
 abbreviation (input)  shiftr1 :: \<open>'a::len word \<Rightarrow> 'a word\<close>
   where \<open>shiftr1 w \<equiv> w div 2\<close>
 
 abbreviation (input) sshiftr1 :: \<open>'a::len word \<Rightarrow> 'a word\<close>
   where \<open>sshiftr1 \<equiv> signed_drop_bit (Suc 0)\<close>
 
 context
   includes bit_operations_syntax
 begin
 
 abbreviation (input) bshiftr1 :: \<open>bool \<Rightarrow> 'a::len word \<Rightarrow> 'a word\<close>
   where \<open>bshiftr1 b w \<equiv> w div 2 OR push_bit (LENGTH('a) - Suc 0) (of_bool b) \<close>
 
 end
 
 lemma shiftr1_1: "shiftr1 (1::'a::len word) = 0"
   by (fact bits_1_div_2)
 
 lemma sshiftr1_eq:
   \<open>sshiftr1 w = word_of_int (sint w div 2)\<close>
   by (rule bit_word_eqI) (auto simp add: bit_simps min_def simp flip: bit_Suc elim: le_SucE)
 
 lemma shiftl1_eq:
   \<open>shiftl1 w = word_of_int (2 * uint w)\<close>
   by (rule bit_word_eqI) (simp add: bit_simps)
 
 lemma bit_shiftl1_iff:
   \<open>bit (shiftl1 w) n \<longleftrightarrow> 0 < n \<and> n < LENGTH('a) \<and> bit w (n - 1)\<close>
   for w :: \<open>'a::len word\<close>
   by (auto simp add: bit_simps)
 
 lemma bit_shiftr1_iff:
   \<open>bit (shiftr1 w) n \<longleftrightarrow> bit w (Suc n)\<close>
   by (simp add: bit_Suc)
 
 lemma shiftr1_eq:
   \<open>shiftr1 w = word_of_int (uint w div 2)\<close>
   by (rule bit_word_eqI) (simp add: bit_simps flip: bit_Suc)
 
 lemma shiftl1_rev:
   "shiftl1 w = word_reverse (shiftr1 (word_reverse w))"
   by (rule bit_word_eqI) (auto simp add: bit_simps Suc_diff_Suc simp flip: bit_Suc)
 
 lemma shiftl1_p:
   "shiftl1 w = w + w"
   for w :: "'a::len word"
   by (fact mult_2)
 
 lemma shiftr1_bintr:
   "(shiftr1 (numeral w) :: 'a::len word) =
     word_of_int (take_bit LENGTH('a) (numeral w) div 2)"
   by (rule bit_word_eqI) (simp add: bit_simps flip: bit_Suc)
 
 lemma sshiftr1_sbintr:
   "(sshiftr1 (numeral w) :: 'a::len word) =
     word_of_int (signed_take_bit (LENGTH('a) - 1) (numeral w) div 2)"
   apply (cases \<open>LENGTH('a)\<close>)
   apply simp_all
   apply (rule bit_word_eqI)
   apply (auto simp add: bit_simps min_def simp flip: bit_Suc elim: le_SucE)
   done
 
 lemma shiftl1_wi:
   "shiftl1 (word_of_int w) = word_of_int (2 * w)"
   by transfer simp
 
 lemma shiftl1_numeral:
   "shiftl1 (numeral w) = numeral (Num.Bit0 w)"
   unfolding word_numeral_alt shiftl1_wi by simp
 
 lemma shiftl1_neg_numeral:
   "shiftl1 (- numeral w) = - numeral (Num.Bit0 w)"
   unfolding word_neg_numeral_alt shiftl1_wi by simp
 
 lemma shiftl1_0:
   "shiftl1 0 = 0"
   by (fact mult_zero_right)
 
 lemma shiftl1_def_u:
   "shiftl1 w = word_of_int (2 * uint w)"
   by (fact shiftl1_eq)
 
 lemma shiftl1_def_s:
   "shiftl1 w = word_of_int (2 * sint w)"
   by simp
 
 lemma shiftr1_0:
   "shiftr1 0 = 0"
   by (fact bits_div_0)
 
 lemma sshiftr1_0:
   "sshiftr1 0 = 0"
   by (fact signed_drop_bit_of_0)
 
 lemma sshiftr1_n1:
   "sshiftr1 (- 1) = - 1"
   by (fact signed_drop_bit_of_minus_1)
 
 lemma uint_shiftr1:
   "uint (shiftr1 w) = uint w div 2"
   by (rule bit_eqI) (simp add: bit_simps flip: bit_Suc)
 
 lemma shiftr1_div_2:
   "uint (shiftr1 w) = uint w div 2"
   by (fact uint_shiftr1)
 
 lemma sshiftr1_div_2:
   "sint (sshiftr1 w) = sint w div 2"
   by (rule bit_eqI) (auto simp add: bit_simps ac_simps min_def simp flip: bit_Suc elim: le_SucE)
 
 lemma bit_sshiftr1_iff:
   \<open>bit (sshiftr1 w) n \<longleftrightarrow> bit w (if n = LENGTH('a) - 1 then LENGTH('a) - 1 else Suc n)\<close>
     for w :: \<open>'a::len word\<close>
   by (auto simp add: bit_simps)
 
 lemma bit_bshiftr1_iff:
   \<open>bit (bshiftr1 b w) n \<longleftrightarrow> b \<and> n = LENGTH('a) - 1 \<or> bit w (Suc n)\<close>
     for w :: \<open>'a::len word\<close>
   by (auto simp add: bit_simps simp flip: bit_Suc)
 
 lemma nth_shiftl1:
   "bit (shiftl1 w) n \<longleftrightarrow> n < size w \<and> n > 0 \<and> bit w (n - 1)"
   by (auto simp add: word_size bit_simps)
 
 lemma nth_shiftr1:
   "bit (shiftr1 w) n = bit w (Suc n)"
   by (simp add: bit_Suc)
 
 lemma nth_sshiftr1: "bit (sshiftr1 w) n = (if n = size w - 1 then bit w n else bit w (Suc n))"
   by (auto simp add: word_size bit_simps)
 
 lemma shiftl_power:
   "(shiftl1 ^^ x) (y::'a::len word) = 2 ^ x * y"
   by (induction x) simp_all
 
 lemma le_shiftr1:
   \<open>shiftr1 u \<le> shiftr1 v\<close> if \<open>u \<le> v\<close>
   using that by (simp add: word_le_nat_alt unat_div div_le_mono)
 
 lemma le_shiftr1':
   "\<lbrakk> shiftr1 u \<le> shiftr1 v ; shiftr1 u \<noteq> shiftr1 v \<rbrakk> \<Longrightarrow> u \<le> v"
   by (meson dual_order.antisym le_cases le_shiftr1)
 
 abbreviation (input) setBit :: \<open>'a::len word \<Rightarrow> nat \<Rightarrow> 'a word\<close>
   where \<open>setBit w n \<equiv> set_bit n w\<close>
 
 abbreviation (input) clearBit :: \<open>'a::len word \<Rightarrow> nat \<Rightarrow> 'a word\<close>
   where \<open>clearBit w n \<equiv> unset_bit n w\<close>
 
 lemma bit_setBit_iff:
   \<open>bit (setBit w m) n \<longleftrightarrow> (m = n \<and> n < LENGTH('a) \<or> bit w n)\<close>
   for w :: \<open>'a::len word\<close>
   by (auto simp add: bit_simps)
 
 lemma bit_clearBit_iff:
   \<open>bit (clearBit w m) n \<longleftrightarrow> m \<noteq> n \<and> bit w n\<close>
   for w :: \<open>'a::len word\<close>
   by (auto simp add: bit_simps)
 
 lemmas less_def = less_eq [symmetric]
 lemmas le_def = not_less [symmetric, where ?'a = nat]
 
 end
diff --git a/thys/Word_Lib/Word_Lemmas.thy b/thys/Word_Lib/Word_Lemmas.thy
--- a/thys/Word_Lib/Word_Lemmas.thy
+++ b/thys/Word_Lib/Word_Lemmas.thy
@@ -1,1940 +1,1944 @@
 (*
  * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
  *
  * SPDX-License-Identifier: BSD-2-Clause
  *)
 
 section "Lemmas with Generic Word Length"
 
 theory Word_Lemmas
   imports
     Type_Syntax
     Signed_Division_Word
     Signed_Words
     More_Word
     Most_significant_bit
     Enumeration_Word
     Aligned
     Bit_Shifts_Infix_Syntax
 begin
 
 context
   includes bit_operations_syntax
 begin
 
 lemma ucast_le_ucast_eq:
   fixes x y :: "'a::len word"
   assumes x: "x < 2 ^ n"
   assumes y: "y < 2 ^ n"
   assumes n: "n = LENGTH('b::len)"
   shows "(UCAST('a \<rightarrow> 'b) x \<le> UCAST('a \<rightarrow> 'b) y) = (x \<le> y)"
   apply (rule iffI)
    apply (cases "LENGTH('b) < LENGTH('a)")
     apply (subst less_mask_eq[OF x, symmetric])
     apply (subst less_mask_eq[OF y, symmetric])
     apply (unfold n)
     apply (subst ucast_ucast_mask[symmetric])+
     apply (simp add: ucast_le_ucast)+
   apply (erule ucast_mono_le[OF _ y[unfolded n]])
   done
 
 lemma ucast_zero_is_aligned:
   \<open>is_aligned w n\<close> if \<open>UCAST('a::len \<rightarrow> 'b::len) w = 0\<close> \<open>n \<le> LENGTH('b)\<close>
 proof (rule is_aligned_bitI)
   fix q
   assume \<open>q < n\<close>
   moreover have \<open>bit (UCAST('a::len \<rightarrow> 'b::len) w) q = bit 0 q\<close>
     using that by simp
   with \<open>q < n\<close> \<open>n \<le> LENGTH('b)\<close> show \<open>\<not> bit w q\<close>
     by (simp add: bit_simps)
 qed
 
 lemma unat_ucast_eq_unat_and_mask:
   "unat (UCAST('b::len \<rightarrow> 'a::len) w) = unat (w AND mask LENGTH('a))"
   apply (simp flip: take_bit_eq_mask)
   apply transfer
   apply (simp add: ac_simps)
   done
 
 lemma le_max_word_ucast_id:
   \<open>UCAST('b \<rightarrow> 'a) (UCAST('a \<rightarrow> 'b) x) = x\<close>
     if \<open>x \<le> UCAST('b::len \<rightarrow> 'a) (- 1)\<close>
     for x :: \<open>'a::len word\<close>
 proof -
   from that have a1: \<open>x \<le> word_of_int (uint (word_of_int (2 ^ LENGTH('b) - 1) :: 'b word))\<close>
     by simp
   have f2: "((\<exists>i ia. (0::int) \<le> i \<and> \<not> 0 \<le> i + - 1 * ia \<and> i mod ia \<noteq> i) \<or>
             \<not> (0::int) \<le> - 1 + 2 ^ LENGTH('b) \<or> (0::int) \<le> - 1 + 2 ^ LENGTH('b) + - 1 * 2 ^ LENGTH('b) \<or>
             (- (1::int) + 2 ^ LENGTH('b)) mod 2 ^ LENGTH('b) =
               - 1 + 2 ^ LENGTH('b)) = ((\<exists>i ia. (0::int) \<le> i \<and> \<not> 0 \<le> i + - 1 * ia \<and> i mod ia \<noteq> i) \<or>
             \<not> (1::int) \<le> 2 ^ LENGTH('b) \<or>
             2 ^ LENGTH('b) + - (1::int) * ((- 1 + 2 ^ LENGTH('b)) mod 2 ^ LENGTH('b)) = 1)"
     by force
   have f3: "\<forall>i ia. \<not> (0::int) \<le> i \<or> 0 \<le> i + - 1 * ia \<or> i mod ia = i"
     using mod_pos_pos_trivial by force
   have "(1::int) \<le> 2 ^ LENGTH('b)"
     by simp
   then have "2 ^ LENGTH('b) + - (1::int) * ((- 1 + 2 ^ LENGTH('b)) mod 2 ^ len_of TYPE ('b)) = 1"
     using f3 f2 by blast
   then have f4: "- (1::int) + 2 ^ LENGTH('b) = (- 1 + 2 ^ LENGTH('b)) mod 2 ^ LENGTH('b)"
     by linarith
   have f5: "x \<le> word_of_int (uint (word_of_int (- 1 + 2 ^ LENGTH('b))::'b word))"
     using a1 by force
   have f6: "2 ^ LENGTH('b) + - (1::int) = - 1 + 2 ^ LENGTH('b)"
     by force
   have f7: "- (1::int) * 1 = - 1"
     by auto
   have "\<forall>x0 x1. (x1::int) - x0 = x1 + - 1 * x0"
     by force
   then have "x \<le> 2 ^ LENGTH('b) - 1"
     using f7 f6 f5 f4 by (metis uint_word_of_int wi_homs(2) word_arith_wis(8) word_of_int_2p)
   then have \<open>uint x \<le> uint (2 ^ LENGTH('b) - (1 :: 'a word))\<close>
     by (simp add: word_le_def)
   then have \<open>uint x \<le> 2 ^ LENGTH('b) - 1\<close>
     by (simp add: uint_word_ariths)
       (metis \<open>1 \<le> 2 ^ LENGTH('b)\<close> \<open>uint x \<le> uint (2 ^ LENGTH('b) - 1)\<close> linorder_not_less lt2p_lem uint_1 uint_minus_simple_alt uint_power_lower word_le_def zle_diff1_eq)
   then show ?thesis
     apply (simp add: unsigned_ucast_eq take_bit_word_eq_self_iff)
     apply (meson \<open>x \<le> 2 ^ LENGTH('b) - 1\<close> not_le word_less_sub_le)
     done
 qed
 
 lemma uint_shiftr_eq:
   \<open>uint (w >> n) = uint w div 2 ^ n\<close>
   by transfer (simp flip: drop_bit_eq_div add: drop_bit_take_bit min_def le_less less_diff_conv)
 
 lemma bit_shiftl_word_iff [bit_simps]:
   \<open>bit (w << m) n \<longleftrightarrow> m \<le> n \<and> n < LENGTH('a) \<and> bit w (n - m)\<close>
   for w :: \<open>'a::len word\<close>
   by (simp add: bit_push_bit_iff not_le)
 
 lemma shiftl_def:
   \<open>w << n = ((*) 2 ^^ n) w\<close> for w :: \<open>'a::len word\<close>
 proof -
   have \<open>push_bit n = (((*) 2 ^^ n) :: int \<Rightarrow> int)\<close> for n
     by (induction n) (simp_all add: fun_eq_iff funpow_swap1, simp add: ac_simps)
   then show ?thesis
     by transfer simp
 qed
 
 lemma shiftr_def:
   \<open>w >> n = ((\<lambda>w. w div 2) ^^ n) w\<close> for w :: \<open>'a::len word\<close>
 proof -
   have \<open>(\<lambda>w. w div 2) ^^ n = (drop_bit n :: 'a word \<Rightarrow> 'a word)\<close>
     by (induction n) (simp_all add: drop_bit_half drop_bit_Suc)
   then show ?thesis
     by simp
 qed
 
 lemma bit_shiftr_word_iff:
   \<open>bit (w >> m) n \<longleftrightarrow> bit w (m + n)\<close>
   for w :: \<open>'a::len word\<close>
   by (simp add: bit_simps)
 
 lemma sshiftr_eq_funpow_sshiftr1:
   \<open>w >>> n = (signed_drop_bit (Suc 0) ^^ n) w\<close>
   apply (rule sym)
   apply (induction n)
    apply simp_all
   done
 
 lemma uint_sshiftr_eq:
   \<open>uint (w >>> n) = take_bit LENGTH('a) (sint w div 2 ^  n)\<close>
   for w :: \<open>'a::len word\<close>
   by transfer (simp flip: drop_bit_eq_div)
 
 lemma sshiftr_0: "0 >>> n = 0"
   by (fact signed_drop_bit_of_0)
 
 lemma sshiftr_n1: "-1 >>> n = -1"
   by (fact signed_drop_bit_of_minus_1)
 
 lemma bit_sshiftr_word_iff:
   \<open>bit (w >>> m) n \<longleftrightarrow> bit w (if LENGTH('a) - m \<le> n \<and> n < LENGTH('a) then LENGTH('a) - 1 else (m + n))\<close>
   for w :: \<open>'a::len word\<close>
   by (fact bit_signed_drop_bit_iff)
 
 lemma nth_sshiftr :
   "bit (w >>> m) n =
     (n < size w \<and> (if n + m \<ge> size w then bit w (size w - 1) else bit w (n + m)))"
   apply (auto simp add: bit_simps word_size ac_simps not_less)
   apply (meson bit_imp_le_length bit_shiftr_word_iff leD)
   done
 
 lemma sshiftr_numeral:
   \<open>(numeral k >>> numeral n :: 'a::len word) =
     word_of_int (drop_bit (numeral n) (signed_take_bit (LENGTH('a) - 1) (numeral k)))\<close>
   by (fact signed_drop_bit_word_numeral)
 
 lemma sshiftr_div_2n: "sint (w >>> n) = sint w div 2 ^ n"
   using sint_signed_drop_bit_eq [of n w]
   by (simp add: drop_bit_eq_div)
 
 lemma mask_eq:
   \<open>mask n = (1 << n) - (1 :: 'a::len word)\<close>
   by (simp add: mask_eq_exp_minus_1 push_bit_of_1)
 
 lemma shiftl_0: "(0::'a::len word) << n = 0"
   by (fact push_bit_of_0)
 
 lemma shiftr_0: "(0::'a::len word) >> n = 0"
   by (fact drop_bit_of_0)
 
 lemma nth_shiftl': "bit (w << m) n \<longleftrightarrow> n < size w \<and> n >= m \<and> bit w (n - m)"
   for w :: "'a::len word"
   by transfer (auto simp add: bit_push_bit_iff)
 
 lemmas nth_shiftl = nth_shiftl' [unfolded word_size]
 
 lemma nth_shiftr: "bit (w >> m) n = bit w (n + m)"
   for w :: "'a::len word"
   by (simp add: bit_simps ac_simps)
 
 lemma shiftr_div_2n: "uint (shiftr w n) = uint w div 2 ^ n"
   by (fact uint_shiftr_eq)
 
 lemma shiftl_rev: "shiftl w n = word_reverse (shiftr (word_reverse w) n)"
   by (rule bit_word_eqI) (auto simp add: bit_simps)
 
 lemma rev_shiftl: "word_reverse w << n = word_reverse (w >> n)"
   by (simp add: shiftl_rev)
 
 lemma shiftr_rev: "w >> n = word_reverse (word_reverse w << n)"
   by (simp add: rev_shiftl)
 
 lemma rev_shiftr: "word_reverse w >> n = word_reverse (w << n)"
   by (simp add: shiftr_rev)
 
 lemmas ucast_up =
   rc1 [simplified rev_shiftr [symmetric] revcast_ucast [symmetric]]
 lemmas ucast_down =
   rc2 [simplified rev_shiftr revcast_ucast [symmetric]]
 
 lemma shiftl_zero_size: "size x \<le> n \<Longrightarrow> x << n = 0"
   for x :: "'a::len word"
   apply transfer
   apply (simp add: take_bit_push_bit)
   done
 
 lemma shiftl_t2n: "shiftl w n = 2 ^ n * w"
   for w :: "'a::len word"
   by (simp add: push_bit_eq_mult)
 
 lemma word_shift_by_2:
   "x * 4 = (x::'a::len word) << 2"
   by (simp add: shiftl_t2n)
 
 lemma slice_shiftr: "slice n w = ucast (w >> n)"
   apply (rule bit_word_eqI)
   apply (cases \<open>n \<le> LENGTH('b)\<close>)
    apply (auto simp add: bit_slice_iff bit_ucast_iff bit_shiftr_word_iff ac_simps
     dest: bit_imp_le_length)
   done
 
 lemma shiftr_zero_size: "size x \<le> n \<Longrightarrow> x >> n = 0"
   for x :: "'a :: len word"
   by (rule word_eqI) (auto simp add: nth_shiftr dest: test_bit_size)
 
 lemma shiftr_x_0: "x >> 0 = x"
   for x :: "'a::len word"
   by simp
 
 lemma shiftl_x_0: "x << 0 = x"
   for x :: "'a::len word"
   by simp
 
 lemma shiftl_1: "(1::'a::len word) << n = 2^n"
   by (fact push_bit_of_1)
 
 lemma shiftr_1: "(1::'a::len word) >> n = (if n = 0 then 1 else 0)"
   by simp
 
 lemma shiftl0:
   "x << 0 = (x :: 'a :: len word)"
   by (fact shiftl_x_0)
 
 lemma and_not_mask:
   "w AND NOT (mask n) = (w >> n) << n"
   for w :: \<open>'a::len word\<close>
   by (rule bit_word_eqI) (auto simp add: bit_simps)
 
 lemma and_mask:
   "w AND mask n = (w << (size w - n)) >> (size w - n)"
   for w :: \<open>'a::len word\<close>
   by (rule bit_word_eqI) (auto simp add: bit_simps word_size)
 
 lemma shiftr_div_2n_w: "n < size w \<Longrightarrow> w >> n = w div (2^n :: 'a :: len word)"
   apply (unfold word_div_def)
   apply (simp add: uint_2p_alt word_size)
   apply (metis uint_shiftr_eq word_of_int_uint)
   done
 
 lemma le_shiftr:
   "u \<le> v \<Longrightarrow> u >> (n :: nat) \<le> (v :: 'a :: len word) >> n"
   apply transfer
   apply (simp add: take_bit_drop_bit)
   apply (simp add: drop_bit_eq_div zdiv_mono1)
   done
 
 lemma le_shiftr':
   "\<lbrakk> u >> n \<le> v >> n ; u >> n \<noteq> v >> n \<rbrakk> \<Longrightarrow> (u::'a::len word) \<le> v"
   apply (metis le_cases le_shiftr verit_la_disequality)
   done
 
 lemma shiftr_mask_le:
   "n <= m \<Longrightarrow> mask n >> m = (0 :: 'a::len word)"
   by (rule bit_word_eqI) (auto simp add: bit_simps)
 
 lemma shiftr_mask [simp]:
   \<open>mask m >> m = (0::'a::len word)\<close>
   by (rule shiftr_mask_le) simp
 
 lemma le_mask_iff:
   "(w \<le> mask n) = (w >> n = 0)"
   for w :: \<open>'a::len word\<close>
   apply safe
    apply (rule word_le_0_iff [THEN iffD1])
    apply (rule xtrans(3))
     apply (erule_tac [2] le_shiftr)
    apply simp
   apply (rule word_leI)
   apply (rename_tac n')
   apply (drule_tac x = "n' - n" in word_eqD)
   apply (simp add : nth_shiftr word_size bit_simps)
   apply (case_tac "n <= n'")
   by auto
 
 lemma and_mask_eq_iff_shiftr_0:
   "(w AND mask n = w) = (w >> n = 0)"
   for w :: \<open>'a::len word\<close>
   apply (unfold test_bit_eq_iff [THEN sym])
   apply (rule iffI)
    apply (rule ext)
    apply (rule_tac [2] ext)
    apply (auto simp add : word_ao_nth nth_shiftr)
     apply (drule arg_cong)
     apply (drule iffD2)
      apply assumption
     apply (simp add : word_ao_nth)
    prefer 2
    apply (simp add : word_size test_bit_bin)
   apply transfer
   apply (auto simp add: fun_eq_iff bit_simps)
   apply (metis add_diff_inverse_nat)
   done
 
 lemma mask_shiftl_decompose:
   "mask m << n = mask (m + n) AND NOT (mask n :: 'a::len word)"
   by (rule bit_word_eqI) (auto simp add: bit_simps)
 
 lemma shiftl_over_and_dist:
   fixes a::"'a::len word"
   shows "(a AND b) << c = (a << c) AND (b << c)"
   by (fact push_bit_and)
 
 lemma shiftr_over_and_dist:
   fixes a::"'a::len word"
   shows "a AND b >> c = (a >> c) AND (b >> c)"
   by (fact drop_bit_and)
 
 lemma sshiftr_over_and_dist:
   fixes a::"'a::len word"
   shows "a AND b >>> c = (a >>> c) AND (b >>> c)"
   apply(rule word_eqI)
   apply(simp add:nth_sshiftr word_ao_nth word_size)
   done
 
 lemma shiftl_over_or_dist:
   fixes a::"'a::len word"
   shows "a OR b << c = (a << c) OR (b << c)"
   by (fact push_bit_or)
 
 lemma shiftr_over_or_dist:
   fixes a::"'a::len word"
   shows "a OR b >> c = (a >> c) OR (b >> c)"
   by (fact drop_bit_or)
 
 lemma sshiftr_over_or_dist:
   fixes a::"'a::len word"
   shows "a OR b >>> c = (a >>> c) OR (b >>> c)"
   apply(rule word_eqI)
   apply(simp add:nth_sshiftr word_ao_nth word_size)
   done
 
 lemmas shift_over_ao_dists =
   shiftl_over_or_dist shiftr_over_or_dist
   sshiftr_over_or_dist shiftl_over_and_dist
   shiftr_over_and_dist sshiftr_over_and_dist
 
 lemma shiftl_shiftl:
   fixes a::"'a::len word"
   shows "a << b << c = a << (b + c)"
   apply(rule word_eqI)
   apply(auto simp:word_size nth_shiftl add.commute add.left_commute)
   done
 
 lemma shiftr_shiftr:
   fixes a::"'a::len word"
   shows "a >> b >> c = a >> (b + c)"
   apply(rule word_eqI)
   apply(simp add:word_size nth_shiftr add.left_commute add.commute)
   done
 
 lemma shiftl_shiftr1:
   fixes a::"'a::len word"
   shows "c \<le> b \<Longrightarrow> a << b >> c = a AND (mask (size a - b)) << (b - c)"
   apply (rule word_eqI)
   apply (auto simp add: bit_simps not_le word_size ac_simps)
   done
 
 lemma shiftl_shiftr2:
   fixes a::"'a::len word"
   shows "b < c \<Longrightarrow> a << b >> c = (a >> (c - b)) AND (mask (size a - c))"
   apply(rule word_eqI)
   apply(auto simp:nth_shiftr nth_shiftl word_size word_ao_nth bit_simps)
   done
 
 lemma shiftr_shiftl1:
   fixes a::"'a::len word"
   shows "c \<le> b \<Longrightarrow> a >> b << c = (a >> (b - c)) AND (NOT (mask c))"
   by (rule bit_word_eqI) (auto simp add: bit_simps)
 
 lemma shiftr_shiftl2:
   fixes a::"'a::len word"
   shows "b < c \<Longrightarrow> a >> b << c = (a << (c - b)) AND (NOT (mask c))"
   apply (rule word_eqI)
   apply (auto simp add: bit_simps not_le word_size ac_simps)
   done
 
 lemmas multi_shift_simps =
   shiftl_shiftl shiftr_shiftr
   shiftl_shiftr1 shiftl_shiftr2
   shiftr_shiftl1 shiftr_shiftl2
 
 lemma shiftr_mask2:
   "n \<le> LENGTH('a) \<Longrightarrow> (mask n >> m :: ('a :: len) word) = mask (n - m)"
   by (rule bit_word_eqI) (auto simp add: bit_simps)
 
 lemma word_shiftl_add_distrib:
   fixes x :: "'a :: len word"
   shows "(x + y) << n = (x << n) + (y << n)"
   by (simp add: shiftl_t2n ring_distribs)
 
 lemma mask_shift:
   "(x AND NOT (mask y)) >> y = x >> y"
   for x :: \<open>'a::len word\<close>
   apply (rule bit_eqI)
   apply (simp add: bit_and_iff bit_not_iff bit_shiftr_word_iff bit_mask_iff not_le)
   using bit_imp_le_length apply auto
   done
 
 lemma shiftr_div_2n':
   "unat (w >> n) = unat w div 2 ^ n"
   apply (unfold unat_eq_nat_uint)
   apply (subst shiftr_div_2n)
   apply (subst nat_div_distrib)
    apply simp
   apply (simp add: nat_power_eq)
   done
 
 lemma shiftl_shiftr_id:
   assumes nv: "n < LENGTH('a)"
   and     xv: "x < 2 ^ (LENGTH('a) - n)"
   shows "x << n >> n = (x::'a::len word)"
   apply (simp add: shiftl_t2n)
   apply (rule word_eq_unatI)
   apply (subst shiftr_div_2n')
   apply (cases n)
    apply simp
   apply (subst iffD1 [OF unat_mult_lem])+
    apply (subst unat_power_lower[OF nv])
    apply (rule nat_less_power_trans [OF _ order_less_imp_le [OF nv]])
    apply (rule order_less_le_trans [OF unat_mono [OF xv] order_eq_refl])
    apply (rule unat_power_lower)
    apply simp
   apply (subst unat_power_lower[OF nv])
   apply simp
   done
 
 lemma ucast_shiftl_eq_0:
   fixes w :: "'a :: len word"
   shows "\<lbrakk> n \<ge> LENGTH('b) \<rbrakk> \<Longrightarrow> ucast (w << n) = (0 :: 'b :: len word)"
   by transfer (simp add: take_bit_push_bit)
 
 lemma word_shift_nonzero:
   "\<lbrakk> (x::'a::len word) \<le> 2 ^ m; m + n < LENGTH('a::len); x \<noteq> 0\<rbrakk>
    \<Longrightarrow> x << n \<noteq> 0"
   apply (simp only: word_neq_0_conv word_less_nat_alt
                     shiftl_t2n mod_0 unat_word_ariths
                     unat_power_lower word_le_nat_alt)
   apply (subst mod_less)
    apply (rule order_le_less_trans)
     apply (erule mult_le_mono2)
    apply (subst power_add[symmetric])
    apply (rule power_strict_increasing)
     apply simp
    apply simp
   apply simp
   done
 
 lemma word_shiftr_lt:
   fixes w :: "'a::len word"
   shows "unat (w >> n) < (2 ^ (LENGTH('a) - n))"
   apply (subst shiftr_div_2n')
   apply transfer
   apply (simp flip: drop_bit_eq_div add: drop_bit_nat_eq drop_bit_take_bit)
   done
 
 lemma shiftr_less_t2n':
   "\<lbrakk> x AND mask (n + m) = x; m < LENGTH('a) \<rbrakk> \<Longrightarrow> x >> n < 2 ^ m" for x :: "'a :: len word"
   apply (simp add: word_size mask_eq_iff_w2p [symmetric] flip: take_bit_eq_mask)
   apply transfer
   apply (simp add: take_bit_drop_bit ac_simps)
   done
 
 lemma shiftr_less_t2n:
   "x < 2 ^ (n + m) \<Longrightarrow> x >> n < 2 ^ m" for x :: "'a :: len word"
   apply (rule shiftr_less_t2n')
    apply (erule less_mask_eq)
   apply (rule ccontr)
   apply (simp add: not_less)
   apply (subst (asm) p2_eq_0[symmetric])
   apply (simp add: power_add)
   done
 
 lemma shiftr_eq_0:
   "n \<ge> LENGTH('a) \<Longrightarrow> ((w::'a::len word) >> n) = 0"
   apply (cut_tac shiftr_less_t2n'[of w n 0], simp)
    apply (simp add: mask_eq_iff)
   apply (simp add: lt2p_lem)
   apply simp
   done
 
 lemma shiftl_less_t2n:
   fixes x :: "'a :: len word"
   shows "\<lbrakk> x < (2 ^ (m - n)); m < LENGTH('a) \<rbrakk> \<Longrightarrow> (x << n) < 2 ^ m"
   apply (simp add: word_size mask_eq_iff_w2p [symmetric] flip: take_bit_eq_mask)
   apply transfer
   apply (simp add: take_bit_push_bit)
   done
 
 lemma shiftl_less_t2n':
   "(x::'a::len word) < 2 ^ m \<Longrightarrow> m+n < LENGTH('a) \<Longrightarrow> x << n < 2 ^ (m + n)"
   by (rule shiftl_less_t2n) simp_all
 
 lemma scast_bit_test [simp]:
   "scast ((1 :: 'a::len signed word) << n) = (1 :: 'a word) << n"
   by (rule bit_word_eqI) (simp add: bit_simps)
 
 lemma signed_shift_guard_to_word:
   \<open>unat x * 2 ^ y < 2 ^ n \<longleftrightarrow> x = 0 \<or> x < 1 << n >> y\<close>
     if \<open>n < LENGTH('a)\<close> \<open>0 < n\<close>
     for x :: \<open>'a::len word\<close>
 proof (cases \<open>x = 0\<close>)
   case True
   then show ?thesis
     by simp
 next
   case False
   then have \<open>unat x \<noteq> 0\<close>
     by (simp add: unat_eq_0)
   then have \<open>unat x \<ge> 1\<close>
     by simp
   show ?thesis
   proof (cases \<open>y < n\<close>)
     case False
     then have \<open>n \<le> y\<close>
       by simp
     then obtain q where \<open>y = n + q\<close>
       using le_Suc_ex by blast
     moreover have \<open>(2 :: nat) ^ n >> n + q \<le> 1\<close>
       by (simp add: drop_bit_eq_div power_add)
     ultimately show ?thesis
       using \<open>x \<noteq> 0\<close> \<open>unat x \<ge> 1\<close> \<open>n < LENGTH('a)\<close>
       by (simp add: power_add not_less word_le_nat_alt unat_drop_bit_eq push_bit_of_1)
   next
     case True
     with that have \<open>y < LENGTH('a)\<close>
       by simp
     show ?thesis
     proof (cases \<open>2 ^ n = unat x * 2 ^ y\<close>)
       case True
       moreover have \<open>unat x * 2 ^ y < 2 ^ LENGTH('a)\<close>
         using \<open>n < LENGTH('a)\<close> by (simp flip: True)
       moreover have \<open>(word_of_nat (2 ^ n) :: 'a word) = word_of_nat (unat x * 2 ^ y)\<close>
         using True by simp
       then have \<open>2 ^ n = x * 2 ^ y\<close>
         by simp
       ultimately show ?thesis
         using \<open>y < LENGTH('a)\<close>
         by (auto simp add: push_bit_of_1 drop_bit_eq_div word_less_nat_alt unat_div unat_word_ariths)
     next
       case False
       with \<open>y < n\<close> have *: \<open>unat x \<noteq> 2 ^ n div 2 ^ y\<close>
         by (auto simp flip: power_sub power_add)
       have \<open>unat x * 2 ^ y < 2 ^ n \<longleftrightarrow> unat x * 2 ^ y \<le> 2 ^ n\<close>
         using False by (simp add: less_le)
       also have \<open>\<dots> \<longleftrightarrow> unat x \<le> 2 ^ n div 2 ^ y\<close>
         by (simp add: less_eq_div_iff_mult_less_eq)
       also have \<open>\<dots> \<longleftrightarrow> unat x < 2 ^ n div 2 ^ y\<close>
         using * by (simp add: less_le)
       finally show ?thesis
       using that \<open>x \<noteq> 0\<close> by (simp flip: push_bit_eq_mult drop_bit_eq_div
         add: push_bit_of_1 unat_drop_bit_eq word_less_iff_unsigned [where ?'a = nat])
     qed
   qed
 qed
 
 lemma shiftr_not_mask_0:
   "n+m \<ge> LENGTH('a :: len) \<Longrightarrow> ((w::'a::len word) >> n) AND NOT (mask m) = 0"
   by (rule bit_word_eqI) (auto simp add: bit_simps word_size dest: bit_imp_le_length)
 
 lemma shiftl_mask_is_0[simp]:
   "(x << n) AND mask n = 0"
   for x :: \<open>'a::len word\<close>
   by (simp flip: take_bit_eq_mask add: take_bit_push_bit)
 
 lemma rshift_sub_mask_eq:
   "(a >> (size a - b)) AND mask b = a >> (size a - b)"
   for a :: \<open>'a::len word\<close>
   using shiftl_shiftr2[where a=a and b=0 and c="size a - b"]
   apply (cases "b < size a")
    apply simp
   apply (simp add: linorder_not_less mask_eq_decr_exp word_size
                    p2_eq_0[THEN iffD2])
   done
 
 lemma shiftl_shiftr3:
   "b \<le> c \<Longrightarrow> a << b >> c = (a >> c - b) AND mask (size a - c)"
   for a :: \<open>'a::len word\<close>
   apply (cases "b = c")
    apply (simp add: shiftl_shiftr1)
   apply (simp add: shiftl_shiftr2)
   done
 
 lemma and_mask_shiftr_comm:
   "m \<le> size w \<Longrightarrow> (w AND mask m) >> n = (w >> n) AND mask (m-n)"
   for w :: \<open>'a::len word\<close>
   by (simp add: and_mask shiftr_shiftr) (simp add: word_size shiftl_shiftr3)
 
 lemma and_mask_shiftl_comm:
   "m+n \<le> size w \<Longrightarrow> (w AND mask m) << n = (w << n) AND mask (m+n)"
   for w :: \<open>'a::len word\<close>
   by (simp add: and_mask word_size shiftl_shiftl) (simp add: shiftl_shiftr1)
 
 lemma le_mask_shiftl_le_mask: "s = m + n \<Longrightarrow> x \<le> mask n \<Longrightarrow> x << m \<le> mask s"
   for x :: \<open>'a::len word\<close>
   by (simp add: le_mask_iff shiftl_shiftr3)
 
 lemma word_and_1_shiftl:
   "x AND (1 << n) = (if bit x n then (1 << n) else 0)" for x :: "'a :: len word"
   apply (rule bit_word_eqI; transfer)
   apply (auto simp add: bit_simps not_le ac_simps)
   done
 
 lemmas word_and_1_shiftls'
     = word_and_1_shiftl[where n=0]
       word_and_1_shiftl[where n=1]
       word_and_1_shiftl[where n=2]
 
 lemmas word_and_1_shiftls = word_and_1_shiftls' [simplified]
 
 lemma word_and_mask_shiftl:
   "x AND (mask n << m) = ((x >> m) AND mask n) << m"
   for x :: \<open>'a::len word\<close>
   apply (rule bit_word_eqI; transfer)
   apply (auto simp add: bit_simps not_le ac_simps)
   done
 
 lemma shift_times_fold:
   "(x :: 'a :: len word) * (2 ^ n) << m = x << (m + n)"
   by (simp add: shiftl_t2n ac_simps power_add)
 
 lemma of_bool_nth:
   "of_bool (bit x v) = (x >> v) AND 1"
   for x :: \<open>'a::len word\<close>
   by (simp add: bit_iff_odd_drop_bit word_and_1)
 
 lemma shiftr_mask_eq:
   "(x >> n) AND mask (size x - n) = x >> n" for x :: "'a :: len word"
   apply (simp flip: take_bit_eq_mask)
   apply transfer
   apply (simp add: take_bit_drop_bit)
   done
 
 lemma shiftr_mask_eq':
   "m = (size x - n) \<Longrightarrow> (x >> n) AND mask m = x >> n" for x :: "'a :: len word"
   by (simp add: shiftr_mask_eq)
 
 lemma and_eq_0_is_nth:
   fixes x :: "'a :: len word"
   shows "y = 1 << n \<Longrightarrow> ((x AND y) = 0) = (\<not> (bit x n))"
   by (simp add: and_exp_eq_0_iff_not_bit push_bit_of_1)
 
 lemma word_shift_zero:
   "\<lbrakk> x << n = 0; x \<le> 2^m; m + n < LENGTH('a)\<rbrakk> \<Longrightarrow> (x::'a::len word) = 0"
   apply (rule ccontr)
   apply (drule (2) word_shift_nonzero)
   apply simp
   done
 
 lemma mask_shift_and_negate[simp]:"(w AND mask n << m) AND NOT (mask n << m) = 0"
   for w :: \<open>'a::len word\<close>
   by (rule bit_word_eqI) (simp add: bit_simps)
 
 (* The seL4 bitfield generator produces functions containing mask and shift operations, such that
  * invoking two of them consecutively can produce something like the following.
  *)
 lemma bitfield_op_twice:
   "(x AND NOT (mask n << m) OR ((y AND mask n) << m)) AND NOT (mask n << m) = x AND NOT (mask n << m)"
   for x :: \<open>'a::len word\<close>
   by (induct n arbitrary: m) (auto simp: word_ao_dist)
 
 lemma bitfield_op_twice'':
   "\<lbrakk>NOT a = b << c; \<exists>x. b = mask x\<rbrakk> \<Longrightarrow> (x AND a OR (y AND b << c)) AND a = x AND a"
   for a b :: \<open>'a::len word\<close>
   apply clarsimp
   apply (cut_tac n=xa and m=c and x=x and y=y in bitfield_op_twice)
   apply (clarsimp simp:mask_eq_decr_exp)
   apply (drule not_switch)
   apply clarsimp
   done
 
 lemma shiftr1_unfold: "x div 2 = x >> 1"
   by (simp add: drop_bit_eq_div)
 
 lemma shiftr1_is_div_2: "(x::('a::len) word) >> 1 = x div 2"
   by (simp add: drop_bit_eq_div)
 
 lemma shiftl1_is_mult: "(x << 1) = (x :: 'a::len word) * 2"
   by (metis One_nat_def mult_2 mult_2_right one_add_one
         power_0 power_Suc shiftl_t2n)
 
 lemma shiftr1_lt:"x \<noteq> 0 \<Longrightarrow> (x::('a::len) word) >> 1 < x"
   apply (subst shiftr1_is_div_2)
   apply (rule div_less_dividend_word)
    apply simp+
   done
 
 lemma shiftr1_0_or_1:"(x::('a::len) word) >> 1 = 0 \<Longrightarrow> x = 0 \<or> x = 1"
   apply (subst (asm) shiftr1_is_div_2)
   apply (drule word_less_div)
   apply (case_tac "LENGTH('a) = 1")
    apply (simp add:degenerate_word)
   apply (erule disjE)
    apply (subgoal_tac "(2::'a word) \<noteq> 0")
     apply simp
    apply (rule not_degenerate_imp_2_neq_0)
    apply (subgoal_tac "LENGTH('a) \<noteq> 0")
     apply arith
    apply simp
   apply (rule x_less_2_0_1', simp+)
   done
 
 lemma shiftr1_irrelevant_lsb: "bit (x::('a::len) word) 0 \<or> x >> 1 = (x + 1) >> 1"
   apply (cases \<open>LENGTH('a)\<close>; transfer)
    apply (simp_all add: take_bit_drop_bit)
   apply (simp add: drop_bit_take_bit drop_bit_Suc)
   done
 
 lemma shiftr1_0_imp_only_lsb:"((x::('a::len) word) + 1) >> 1 = 0 \<Longrightarrow> x = 0 \<or> x + 1 = 0"
   by (metis One_nat_def shiftr1_0_or_1 word_less_1 word_overflow)
 
 lemma shiftr1_irrelevant_lsb': "\<not> (bit (x::('a::len) word) 0) \<Longrightarrow> x >> 1 = (x + 1) >> 1"
   by (metis shiftr1_irrelevant_lsb)
 
 (* Perhaps this one should be a simp lemma, but it seems a little dangerous. *)
 lemma cast_chunk_assemble_id:
   "\<lbrakk>n = LENGTH('a::len); m = LENGTH('b::len); n * 2 = m\<rbrakk> \<Longrightarrow>
   (((ucast ((ucast (x::'b word))::'a word))::'b word) OR (((ucast ((ucast (x >> n))::'a word))::'b word) << n)) = x"
   apply (subgoal_tac "((ucast ((ucast (x >> n))::'a word))::'b word) = x >> n")
    apply clarsimp
    apply (subst and_not_mask[symmetric])
    apply (subst ucast_ucast_mask)
    apply (subst word_ao_dist2[symmetric])
    apply clarsimp
   apply (rule ucast_ucast_len)
   apply (rule shiftr_less_t2n')
    apply (subst and_mask_eq_iff_le_mask)
    apply (simp_all add: mask_eq_decr_exp flip: mult_2_right)
   apply (metis add_diff_cancel_left' len_gt_0 mult_2_right zero_less_diff)
   done
 
 lemma cast_chunk_scast_assemble_id:
   "\<lbrakk>n = LENGTH('a::len); m = LENGTH('b::len); n * 2 = m\<rbrakk> \<Longrightarrow>
   (((ucast ((scast (x::'b word))::'a word))::'b word) OR
    (((ucast ((scast (x >> n))::'a word))::'b word) << n)) = x"
   apply (subgoal_tac "((scast x)::'a word) = ((ucast x)::'a word)")
    apply (subgoal_tac "((scast (x >> n))::'a word) = ((ucast (x >> n))::'a word)")
     apply (simp add:cast_chunk_assemble_id)
    apply (subst down_cast_same[symmetric], subst is_down, arith, simp)+
   done
 
 lemma unat_shiftr_less_t2n:
   fixes x :: "'a :: len word"
   shows "unat x < 2 ^ (n + m) \<Longrightarrow> unat (x >> n) < 2 ^ m"
   by (simp add: shiftr_div_2n' power_add mult.commute less_mult_imp_div_less)
 
 lemma ucast_less_shiftl_helper:
   "\<lbrakk> LENGTH('b) + 2 < LENGTH('a); 2 ^ (LENGTH('b) + 2) \<le> n\<rbrakk>
     \<Longrightarrow> (ucast (x :: 'b::len word) << 2) < (n :: 'a::len word)"
   apply (erule order_less_le_trans[rotated])
   using ucast_less[where x=x and 'a='a]
   apply (simp only: shiftl_t2n field_simps)
   apply (rule word_less_power_trans2; simp)
   done
 
 (* negating a mask which has been shifted to the very left *)
 lemma NOT_mask_shifted_lenword:
   "NOT (mask len << (LENGTH('a) - len) ::'a::len word) = mask (LENGTH('a) - len)"
   by (rule bit_word_eqI)
     (auto simp add: word_size bit_not_iff bit_push_bit_iff bit_mask_iff)
 
 (* Comparisons between different word sizes. *)
 
 lemma shiftr_less:
   "(w::'a::len word) < k \<Longrightarrow> w >> n < k"
   by (metis div_le_dividend le_less_trans shiftr_div_2n' unat_arith_simps(2))
 
 lemma word_and_notzeroD:
   "w AND w' \<noteq> 0 \<Longrightarrow> w \<noteq> 0 \<and> w' \<noteq> 0"
   by auto
 
 lemma shiftr_le_0:
   "unat (w::'a::len word) < 2 ^ n \<Longrightarrow> w >> n = (0::'a::len word)"
   apply (auto simp add: take_bit_word_eq_self_iff word_less_nat_alt
     simp flip: take_bit_eq_self_iff_drop_bit_eq_0)
   apply (rule ccontr)
   apply (simp add: not_le)
   done
 
 lemma of_nat_shiftl:
   "(of_nat x << n) = (of_nat (x * 2 ^ n) :: ('a::len) word)"
 proof -
   have "(of_nat x::'a word) << n = of_nat (2 ^ n) * of_nat x"
     using shiftl_t2n by (metis word_unat_power)
   thus ?thesis by simp
 qed
 
 lemma shiftl_1_not_0:
   "n < LENGTH('a) \<Longrightarrow> (1::'a::len word) << n \<noteq> 0"
   by (simp add: shiftl_t2n)
 
 (* continue sorting out from here *)
 
 (* usually: x,y = (len_of TYPE ('a)) *)
 lemma bitmagic_zeroLast_leq_or1Last:
   "(a::('a::len) word) AND (mask len << x - len) \<le> a OR mask (y - len)"
   by (meson le_word_or2 order_trans word_and_le2)
 
 lemma zero_base_lsb_imp_set_eq_as_bit_operation:
   fixes base ::"'a::len word"
   assumes valid_prefix: "mask (LENGTH('a) - len) AND base = 0"
   shows "(base = NOT (mask (LENGTH('a) - len)) AND a) \<longleftrightarrow>
          (a \<in> {base .. base OR mask (LENGTH('a) - len)})"
 proof
   have helper3: "x OR y = x OR y AND NOT x" for x y ::"'a::len word" by (simp add: word_oa_dist2)
   from assms show "base = NOT (mask (LENGTH('a) - len)) AND a \<Longrightarrow>
                     a \<in> {base..base OR mask (LENGTH('a) - len)}"
     apply(simp add: word_and_le1)
     apply(metis helper3 le_word_or2 word_bw_comms(1) word_bw_comms(2))
   done
 next
   assume "a \<in> {base..base OR mask (LENGTH('a) - len)}"
   hence a: "base \<le> a \<and> a \<le> base OR mask (LENGTH('a) - len)" by simp
   show "base = NOT (mask (LENGTH('a) - len)) AND a"
   proof -
     have f2: "\<forall>x\<^sub>0. base AND NOT (mask x\<^sub>0) \<le> a AND NOT (mask x\<^sub>0)"
       using a neg_mask_mono_le by blast
     have f3: "\<forall>x\<^sub>0. a AND NOT (mask x\<^sub>0) \<le> (base OR mask (LENGTH('a) - len)) AND NOT (mask x\<^sub>0)"
       using a neg_mask_mono_le by blast
     have f4: "base = base AND NOT (mask (LENGTH('a) - len))"
       using valid_prefix by (metis mask_eq_0_eq_x word_bw_comms(1))
     hence f5: "\<forall>x\<^sub>6. (base OR x\<^sub>6) AND NOT (mask (LENGTH('a) - len)) =
                       base OR x\<^sub>6 AND NOT (mask (LENGTH('a) - len))"
       using word_ao_dist by (metis)
     have f6: "\<forall>x\<^sub>2 x\<^sub>3. a AND NOT (mask x\<^sub>2) \<le> x\<^sub>3 \<or>
                       \<not> (base OR mask (LENGTH('a) - len)) AND NOT (mask x\<^sub>2) \<le> x\<^sub>3"
       using f3 dual_order.trans by auto
     have "base = (base OR mask (LENGTH('a) - len)) AND NOT (mask (LENGTH('a) - len))"
       using f5 by auto
     hence "base = a AND NOT (mask (LENGTH('a) - len))"
       using f2 f4 f6 by (metis eq_iff)
     thus "base = NOT (mask (LENGTH('a) - len)) AND a"
       by (metis word_bw_comms(1))
   qed
 qed
 
 lemma of_nat_eq_signed_scast:
   "(of_nat x = (y :: ('a::len) signed word))
    = (of_nat x = (scast y :: 'a word))"
   by (metis scast_of_nat scast_scast_id(2))
 
 lemma word_aligned_add_no_wrap_bounded:
   "\<lbrakk> w + 2^n \<le> x; w + 2^n \<noteq> 0; is_aligned w n \<rbrakk> \<Longrightarrow> (w::'a::len word) < x"
   by (blast dest: is_aligned_no_overflow le_less_trans word_leq_le_minus_one)
 
 lemma mask_Suc:
   "mask (Suc n) = (2 :: 'a::len word) ^ n + mask n"
   by (simp add: mask_eq_decr_exp)
 
 lemma mask_mono:
   "sz' \<le> sz \<Longrightarrow> mask sz' \<le> (mask sz :: 'a::len word)"
   by (simp add: le_mask_iff shiftr_mask_le)
 
 lemma aligned_mask_disjoint:
   "\<lbrakk> is_aligned (a :: 'a :: len word) n; b \<le> mask n \<rbrakk> \<Longrightarrow> a AND b = 0"
   by (metis and_zero_eq is_aligned_mask le_mask_imp_and_mask word_bw_lcs(1))
 
 lemma word_and_or_mask_aligned:
   "\<lbrakk> is_aligned a n; b \<le> mask n \<rbrakk> \<Longrightarrow> a + b = a OR b"
   by (simp add: aligned_mask_disjoint word_plus_and_or_coroll)
 
 lemma word_and_or_mask_aligned2:
   \<open>is_aligned b n \<Longrightarrow> a \<le> mask n \<Longrightarrow> a + b = a OR b\<close>
   using word_and_or_mask_aligned [of b n a] by (simp add: ac_simps)
 
 lemma is_aligned_ucastI:
   "is_aligned w n \<Longrightarrow> is_aligned (ucast w) n"
   by (simp add: bit_ucast_iff is_aligned_nth)
 
 lemma ucast_le_maskI:
   "a \<le> mask n \<Longrightarrow> UCAST('a::len \<rightarrow> 'b::len) a \<le> mask n"
   by (metis and_mask_eq_iff_le_mask ucast_and_mask)
 
 lemma ucast_add_mask_aligned:
   "\<lbrakk> a \<le> mask n; is_aligned b n \<rbrakk> \<Longrightarrow> UCAST ('a::len \<rightarrow> 'b::len) (a + b) = ucast a + ucast b"
   by (metis add.commute is_aligned_ucastI ucast_le_maskI ucast_or_distrib word_and_or_mask_aligned)
 
 lemma ucast_shiftl:
   "LENGTH('b) \<le> LENGTH ('a) \<Longrightarrow> UCAST ('a::len \<rightarrow> 'b::len) x << n = ucast (x << n)"
   by word_eqI_solve
 
 lemma ucast_leq_mask:
   "LENGTH('a) \<le> n \<Longrightarrow> ucast (x::'a::len word) \<le> mask n"
   apply (simp add: less_eq_mask_iff_take_bit_eq_self)
   apply transfer
   apply (simp add: ac_simps)
   done
 
 lemma shiftl_inj:
   "\<lbrakk> x << n = y << n; x \<le> mask (LENGTH('a)-n); y \<le> mask (LENGTH('a)-n) \<rbrakk> \<Longrightarrow>
    x = (y :: 'a :: len word)"
   apply word_eqI
   apply (rename_tac n')
   apply (case_tac "LENGTH('a) - n \<le> n'", simp)
   by (metis add.commute add.right_neutral diff_add_inverse le_diff_conv linorder_not_less zero_order(1))
 
 lemma distinct_word_add_ucast_shift_inj:
   \<open>p' = p \<and> off' = off\<close>
   if *: \<open>p + (UCAST('a::len \<rightarrow> 'b::len) off << n) = p' + (ucast off' << n)\<close>
     and \<open>is_aligned p n'\<close> \<open>is_aligned p' n'\<close> \<open>n' = n + LENGTH('a)\<close> \<open>n' < LENGTH('b)\<close>
 proof -
   from \<open>n' = n + LENGTH('a)\<close>
   have [simp]: \<open>n' - n = LENGTH('a)\<close> \<open>n + LENGTH('a) = n'\<close>
     by simp_all
   from \<open>is_aligned p n'\<close> obtain q
     where p: \<open>p = push_bit n' (word_of_nat q)\<close> \<open>q < 2 ^ (LENGTH('b) - n')\<close>
     by (rule is_alignedE')
   from \<open>is_aligned p' n'\<close> obtain q'
     where p': \<open>p' = push_bit n' (word_of_nat q')\<close> \<open>q' < 2 ^ (LENGTH('b) - n')\<close>
     by (rule is_alignedE')
   define m :: nat where \<open>m = unat off\<close>
   then have off: \<open>off = word_of_nat m\<close>
     by simp
   define m' :: nat where \<open>m' = unat off'\<close>
   then have off': \<open>off' = word_of_nat m'\<close>
     by simp
   have \<open>push_bit n' q + take_bit n' (push_bit n m) < 2 ^ LENGTH('b)\<close>
     by (metis id_apply is_aligned_no_wrap''' of_nat_eq_id of_nat_push_bit p(1) p(2) take_bit_nat_eq_self_iff take_bit_nat_less_exp take_bit_push_bit that(2) that(5) unsigned_of_nat)
   moreover have \<open>push_bit n' q' + take_bit n' (push_bit n m') < 2 ^ LENGTH('b)\<close>
     by (metis \<open>n' - n = LENGTH('a)\<close> id_apply is_aligned_no_wrap''' m'_def of_nat_eq_id of_nat_push_bit off' p'(1) p'(2) take_bit_nat_eq_self_iff take_bit_push_bit that(3) that(5) unsigned_of_nat)
   ultimately have \<open>push_bit n' q + take_bit n' (push_bit n m) = push_bit n' q' + take_bit n' (push_bit n m')\<close>
     using * by (simp add: p p' off off' push_bit_of_nat push_bit_take_bit word_of_nat_inj flip: of_nat_add)
   then have \<open>int (push_bit n' q + take_bit n' (push_bit n m))
     = int (push_bit n' q' + take_bit n' (push_bit n m'))\<close>
     by simp
   then have \<open>concat_bit n' (int (push_bit n m)) (int q)
     = concat_bit n' (int (push_bit n m')) (int q')\<close>
     by (simp add: of_nat_push_bit of_nat_take_bit concat_bit_eq)
   then show ?thesis
     by (simp add: p p' off off' take_bit_of_nat take_bit_push_bit word_of_nat_eq_iff concat_bit_eq_iff)
       (simp add: push_bit_eq_mult)
 qed
 
 lemma word_upto_Nil:
   "y < x \<Longrightarrow> [x .e. y ::'a::len word] = []"
   by (simp add: upto_enum_red not_le word_less_nat_alt)
 
 lemma word_enum_decomp_elem:
   assumes "[x .e. (y ::'a::len word)] = as @ a # bs"
   shows "x \<le> a \<and> a \<le> y"
 proof -
   have "set as \<subseteq> set [x .e. y] \<and> a \<in> set [x .e. y]"
     using assms by (auto dest: arg_cong[where f=set])
   then show ?thesis by auto
 qed
 
 lemma word_enum_prefix:
   "[x .e. (y ::'a::len word)] = as @ a # bs \<Longrightarrow> as = (if x < a then [x .e. a - 1] else [])"
   apply (induct as arbitrary: x; clarsimp)
    apply (case_tac "x < y")
     prefer 2
     apply (case_tac "x = y", simp)
     apply (simp add: not_less)
     apply (drule (1) dual_order.not_eq_order_implies_strict)
     apply (simp add: word_upto_Nil)
    apply (simp add: word_upto_Cons_eq)
   apply (case_tac "x < y")
    prefer 2
    apply (case_tac "x = y", simp)
    apply (simp add: not_less)
    apply (drule (1) dual_order.not_eq_order_implies_strict)
    apply (simp add: word_upto_Nil)
   apply (clarsimp simp: word_upto_Cons_eq)
   apply (frule word_enum_decomp_elem)
   apply clarsimp
   apply (rule conjI)
    prefer 2
    apply (subst word_Suc_le[symmetric]; clarsimp)
   apply (drule meta_spec)
   apply (drule (1) meta_mp)
   apply clarsimp
   apply (rule conjI; clarsimp)
   apply (subst (2) word_upto_Cons_eq)
    apply unat_arith
   apply simp
   done
 
 lemma word_enum_decomp_set:
   "[x .e. (y ::'a::len word)] = as @ a # bs \<Longrightarrow> a \<notin> set as"
   by (metis distinct_append distinct_enum_upto' not_distinct_conv_prefix)
 
 lemma word_enum_decomp:
   assumes "[x .e. (y ::'a::len word)] = as @ a # bs"
   shows "x \<le> a \<and> a \<le> y \<and> a \<notin> set as \<and> (\<forall>z \<in> set as. x \<le> z \<and> z \<le> y)"
 proof -
   from assms
   have "set as \<subseteq> set [x .e. y] \<and> a \<in> set [x .e. y]"
     by (auto dest: arg_cong[where f=set])
   with word_enum_decomp_set[OF assms]
   show ?thesis by auto
 qed
 
 lemma of_nat_unat_le_mask_ucast:
   "\<lbrakk>of_nat (unat t) = w; t \<le> mask LENGTH('a)\<rbrakk> \<Longrightarrow> t = UCAST('a::len \<rightarrow> 'b::len) w"
   by (clarsimp simp: ucast_nat_def ucast_ucast_mask simp flip: and_mask_eq_iff_le_mask)
 
 lemma less_diff_gt0:
   "a < b \<Longrightarrow> (0 :: 'a :: len word) < b - a"
   by unat_arith
 
 lemma unat_plus_gt:
   "unat ((a :: 'a :: len word) + b) \<le> unat a + unat b"
   by (clarsimp simp: unat_plus_if_size)
 
 lemma const_less:
   "\<lbrakk> (a :: 'a :: len word) - 1 < b; a \<noteq> b \<rbrakk> \<Longrightarrow> a < b"
   by (metis less_1_simp word_le_less_eq)
 
 lemma add_mult_aligned_neg_mask:
   \<open>(x + y * m) AND NOT(mask n) = (x AND NOT(mask n)) + y * m\<close>
   if \<open>m AND (2 ^ n - 1) = 0\<close>
   for x y m :: \<open>'a::len word\<close>
   by (metis (no_types, opaque_lifting)
     add.assoc add.commute add.right_neutral add_uminus_conv_diff
    mask_eq_decr_exp mask_eqs(2) mask_eqs(6) mult.commute mult_zero_left
    subtract_mask(1) that)
 
 lemma unat_of_nat_minus_1:
   "\<lbrakk> n < 2 ^ LENGTH('a); n \<noteq> 0 \<rbrakk> \<Longrightarrow> unat ((of_nat n:: 'a :: len word) - 1) = n - 1"
   by (simp add: of_nat_diff unat_eq_of_nat)
 
 lemma word_eq_zeroI:
   "a \<le> a - 1 \<Longrightarrow> a = 0" for a :: "'a :: len word"
   by (simp add: word_must_wrap)
 
 lemma word_add_format:
   "(-1 :: 'a :: len  word) + b + c = b + (c - 1)"
   by simp
 
 lemma upto_enum_word_nth:
   "\<lbrakk> i \<le> j; k \<le> unat (j - i) \<rbrakk> \<Longrightarrow> [i .e. j] ! k = i + of_nat k"
   apply (clarsimp simp: upto_enum_def nth_append)
   apply (clarsimp simp: word_le_nat_alt[symmetric])
   apply (rule conjI, clarsimp)
    apply (subst toEnum_of_nat, unat_arith)
    apply unat_arith
   apply (clarsimp simp: not_less unat_sub[symmetric])
   apply unat_arith
   done
 
 lemma upto_enum_step_nth:
   "\<lbrakk> a \<le> c; n \<le> unat ((c - a) div (b - a)) \<rbrakk>
    \<Longrightarrow> [a, b .e. c] ! n = a + of_nat n * (b - a)"
   by (clarsimp simp: upto_enum_step_def not_less[symmetric] upto_enum_word_nth)
 
 lemma upto_enum_inc_1_len:
   "a < - 1 \<Longrightarrow> [(0 :: 'a :: len word) .e. 1 + a] = [0 .e. a] @ [1 + a]"
   apply (simp add: upto_enum_word)
   apply (subgoal_tac "unat (1+a) = 1 + unat a")
    apply simp
   apply (subst unat_plus_simple[THEN iffD1])
    apply (metis add.commute no_plus_overflow_neg olen_add_eqv)
   apply unat_arith
   done
 
 lemma neg_mask_add:
   "y AND mask n = 0 \<Longrightarrow> x + y AND NOT(mask n) = (x AND NOT(mask n)) + y"
   for x y :: \<open>'a::len word\<close>
   by (clarsimp simp: mask_out_sub_mask mask_eqs(7)[symmetric] mask_twice)
 
 lemma shiftr_shiftl_shiftr[simp]:
   "(x :: 'a :: len word) >> a << a >> a = x >> a"
   by word_eqI_solve
 
 lemma add_right_shift:
   "\<lbrakk> x AND mask n = 0; y AND mask n = 0; x \<le> x + y \<rbrakk>
    \<Longrightarrow> (x + y :: ('a :: len) word) >> n = (x >> n) + (y >> n)"
   apply (simp add: no_olen_add_nat is_aligned_mask[symmetric])
   apply (simp add: unat_arith_simps shiftr_div_2n' split del: if_split)
   apply (subst if_P)
    apply (erule order_le_less_trans[rotated])
    apply (simp add: add_mono)
   apply (simp add: shiftr_div_2n' is_aligned_iff_dvd_nat)
   done
 
 lemma sub_right_shift:
   "\<lbrakk> x AND mask n = 0; y AND mask n = 0; y \<le> x \<rbrakk>
    \<Longrightarrow> (x - y) >> n = (x >> n :: 'a :: len word) - (y >> n)"
   using add_right_shift[where x="x - y" and y=y and n=n]
   by (simp add: aligned_sub_aligned is_aligned_mask[symmetric] word_sub_le)
 
 lemma and_and_mask_simple:
   "y AND mask n = mask n \<Longrightarrow> (x AND y) AND mask n = x AND mask n"
   by (simp add: ac_simps)
 
 lemma and_and_mask_simple_not:
   "y AND mask n = 0 \<Longrightarrow> (x AND y) AND mask n = 0"
   by (simp add: ac_simps)
 
 lemma word_and_le':
   "b \<le> c \<Longrightarrow> (a :: 'a :: len word) AND b \<le> c"
   by (metis word_and_le1 order_trans)
 
 lemma word_and_less':
   "b < c \<Longrightarrow> (a :: 'a :: len word) AND b < c"
   by transfer simp
 
 lemma shiftr_w2p:
   "x < LENGTH('a) \<Longrightarrow> 2 ^ x = (2 ^ (LENGTH('a) - 1) >> (LENGTH('a) - 1 - x) :: 'a :: len word)"
   by word_eqI_solve
 
 lemma t2p_shiftr:
   "\<lbrakk> b \<le> a; a < LENGTH('a) \<rbrakk> \<Longrightarrow> (2 :: 'a :: len word) ^ a >> b = 2 ^ (a - b)"
   by word_eqI_solve
 
 lemma scast_1[simp]:
   "scast (1 :: 'a :: len signed word) = (1 :: 'a word)"
   by simp
 
 lemma unsigned_uminus1 [simp]:
   \<open>(unsigned (-1::'b::len word)::'c::len word) = mask LENGTH('b)\<close>
   by (rule bit_word_eqI) (auto simp add: bit_simps)
 
 lemma ucast_ucast_mask_eq:
   "\<lbrakk> UCAST('a::len \<rightarrow> 'b::len) x = y; x AND mask LENGTH('b) = x \<rbrakk> \<Longrightarrow> x = ucast y"
   by (drule sym) (simp flip: take_bit_eq_mask add: unsigned_ucast_eq)
 
 lemma ucast_up_eq:
   "\<lbrakk> ucast x = (ucast y::'b::len word); LENGTH('a) \<le> LENGTH ('b) \<rbrakk>
    \<Longrightarrow> ucast x = (ucast y::'a::len word)"
   by word_eqI_solve
 
 lemma ucast_up_neq:
   "\<lbrakk> ucast x \<noteq> (ucast y::'b::len word); LENGTH('b) \<le> LENGTH ('a) \<rbrakk>
    \<Longrightarrow> ucast x \<noteq> (ucast y::'a::len word)"
   by (fastforce dest: ucast_up_eq)
 
 lemma mask_AND_less_0:
   "\<lbrakk> x AND mask n = 0; m \<le> n \<rbrakk> \<Longrightarrow> x AND mask m = 0"
   for x :: \<open>'a::len word\<close>
   by (metis mask_twice2 word_and_notzeroD)
 
 lemma mask_len_id [simp]:
   "(x :: 'a :: len word) AND mask LENGTH('a) = x"
   using uint_lt2p [of x] by (simp add: mask_eq_iff)
 
 lemma scast_ucast_down_same:
   "LENGTH('b) \<le> LENGTH('a) \<Longrightarrow> SCAST('a \<rightarrow> 'b) = UCAST('a::len \<rightarrow> 'b::len)"
   by (simp add: down_cast_same is_down)
 
 lemma word_aligned_0_sum:
   "\<lbrakk> a + b = 0; is_aligned (a :: 'a :: len word) n; b \<le> mask n; n < LENGTH('a) \<rbrakk>
    \<Longrightarrow> a = 0 \<and> b = 0"
   by (simp add: word_plus_and_or_coroll aligned_mask_disjoint word_or_zero)
 
 lemma mask_eq1_nochoice:
   "\<lbrakk> LENGTH('a) > 1; (x :: 'a :: len word) AND 1 = x \<rbrakk> \<Longrightarrow> x = 0 \<or> x = 1"
   by (metis word_and_1)
 
 lemma shiftr_and_eq_shiftl:
   "(w >> n) AND x = y \<Longrightarrow> w AND (x << n) = (y << n)" for y :: "'a:: len word"
-  by (metis (no_types, lifting) and_not_mask bit.conj_ac(1) bit.conj_ac(2) mask_eq_0_eq_x shiftl_mask_is_0 shiftl_over_and_dist)
+  apply (drule sym)
+  apply simp
+  apply (rule bit_word_eqI)
+  apply (auto simp add: bit_simps)
+  done
 
 lemma add_mask_lower_bits':
   "\<lbrakk> len = LENGTH('a); is_aligned (x :: 'a :: len word) n;
      \<forall>n' \<ge> n. n' < len \<longrightarrow> \<not> bit p n' \<rbrakk>
    \<Longrightarrow> x + p AND NOT(mask n) = x"
   using add_mask_lower_bits by auto
 
 lemma leq_mask_shift:
   "(x :: 'a :: len word) \<le> mask (low_bits + high_bits) \<Longrightarrow> (x >> low_bits) \<le> mask high_bits"
   by (simp add: le_mask_iff shiftr_shiftr ac_simps)
 
 lemma ucast_ucast_eq_mask_shift:
   "(x :: 'a :: len word) \<le> mask (low_bits + LENGTH('b))
    \<Longrightarrow> ucast((ucast (x >> low_bits)) :: 'b :: len word) = x >> low_bits"
   by (meson and_mask_eq_iff_le_mask eq_ucast_ucast_eq not_le_imp_less shiftr_less_t2n'
             ucast_ucast_len)
 
 lemma const_le_unat:
   "\<lbrakk> b < 2 ^ LENGTH('a); of_nat b \<le> a \<rbrakk> \<Longrightarrow> b \<le> unat (a :: 'a :: len word)"
   apply (simp add: word_le_def)
   apply (simp only: uint_nat zle_int)
   apply transfer
   apply (simp add: take_bit_nat_eq_self)
   done
 
 lemma upt_enum_offset_trivial:
   "\<lbrakk> x < 2 ^ LENGTH('a) - 1 ; n \<le> unat x \<rbrakk>
    \<Longrightarrow> ([(0 :: 'a :: len word) .e. x] ! n) = of_nat n"
   apply (induct x arbitrary: n)
     apply simp
   by (simp add: upto_enum_word_nth)
 
 lemma word_le_mask_out_plus_2sz:
   "x \<le> (x AND NOT(mask sz)) + 2 ^ sz - 1"
   for x :: \<open>'a::len word\<close>
   by (metis add_diff_eq word_neg_and_le)
 
 lemma ucast_add:
   "ucast (a + (b :: 'a :: len word)) = ucast a + (ucast b :: ('a signed word))"
   by transfer (simp add: take_bit_add)
 
 lemma ucast_minus:
   "ucast (a - (b :: 'a :: len word)) = ucast a - (ucast b :: ('a signed word))"
   apply (insert ucast_add[where a=a and b="-b"])
   apply (metis (no_types, opaque_lifting) add_diff_eq diff_add_cancel ucast_add)
   done
 
 lemma scast_ucast_add_one [simp]:
   "scast (ucast (x :: 'a::len word) + (1 :: 'a signed word)) = x + 1"
   apply (subst ucast_1[symmetric])
   apply (subst ucast_add[symmetric])
   apply clarsimp
   done
 
 lemma word_and_le_plus_one:
   "a > 0 \<Longrightarrow> (x :: 'a :: len word) AND (a - 1) < a"
   by (simp add: gt0_iff_gem1 word_and_less')
 
 lemma unat_of_ucast_then_shift_eq_unat_of_shift[simp]:
   "LENGTH('b) \<ge> LENGTH('a)
    \<Longrightarrow> unat ((ucast (x :: 'a :: len word) :: 'b :: len word) >> n) = unat (x >> n)"
   by (simp add: shiftr_div_2n' unat_ucast_up_simp)
 
 lemma unat_of_ucast_then_mask_eq_unat_of_mask[simp]:
   "LENGTH('b) \<ge> LENGTH('a)
    \<Longrightarrow> unat ((ucast (x :: 'a :: len word) :: 'b :: len word) AND mask m) = unat (x AND mask m)"
   by (metis ucast_and_mask unat_ucast_up_simp)
 
 lemma shiftr_less_t2n3:
   "\<lbrakk> (2 :: 'a word) ^ (n + m) = 0; m < LENGTH('a) \<rbrakk>
    \<Longrightarrow> (x :: 'a :: len word) >> n < 2 ^ m"
   by (fastforce intro: shiftr_less_t2n' simp: mask_eq_decr_exp power_overflow)
 
 lemma unat_shiftr_le_bound:
   "\<lbrakk> 2 ^ (LENGTH('a :: len) - n) - 1 \<le> bnd; 0 < n \<rbrakk>
    \<Longrightarrow> unat ((x :: 'a word) >> n) \<le> bnd"
   apply transfer
   apply (simp add: take_bit_drop_bit)
   apply (simp add: drop_bit_take_bit)
   apply (rule order_trans)
    defer
    apply assumption
   apply (simp add: nat_le_iff of_nat_diff)
   done
 
 lemma shiftr_eqD:
   "\<lbrakk> x >> n = y >> n; is_aligned x n; is_aligned y n \<rbrakk>
    \<Longrightarrow> x = y"
   by (metis is_aligned_shiftr_shiftl)
 
 lemma word_shiftr_shiftl_shiftr_eq_shiftr:
   "a \<ge> b \<Longrightarrow> (x :: 'a :: len word) >> a << b >> b = x >> a"
   apply (rule bit_word_eqI)
   apply (auto simp add: bit_simps dest: bit_imp_le_length)
   done
 
 lemma of_int_uint_ucast:
    "of_int (uint (x :: 'a::len word)) = (ucast x :: 'b::len word)"
   by (fact Word.of_int_uint)
 
 lemma mod_mask_drop:
   "\<lbrakk> m = 2 ^ n; 0 < m; mask n AND msk = mask n \<rbrakk>
    \<Longrightarrow> (x mod m) AND msk = x mod m"
   for x :: \<open>'a::len word\<close>
   by (simp add: word_mod_2p_is_mask word_bw_assocs)
 
 lemma mask_eq_ucast_eq:
   "\<lbrakk> x AND mask LENGTH('a) = (x :: ('c :: len word));
      LENGTH('a) \<le> LENGTH('b)\<rbrakk>
     \<Longrightarrow> ucast (ucast x :: ('a :: len word)) = (ucast x :: ('b :: len word))"
   by (metis ucast_and_mask ucast_id ucast_ucast_mask ucast_up_eq)
 
 lemma of_nat_less_t2n:
   "of_nat i < (2 :: ('a :: len) word) ^ n \<Longrightarrow> n < LENGTH('a) \<and> unat (of_nat i :: 'a word) < 2 ^ n"
   by (metis order_less_trans p2_gt_0 unat_less_power word_neq_0_conv)
 
 lemma two_power_increasing_less_1:
   "\<lbrakk> n \<le> m; m \<le> LENGTH('a) \<rbrakk> \<Longrightarrow> (2 :: 'a :: len word) ^ n - 1 \<le> 2 ^ m - 1"
   by (metis diff_diff_cancel le_m1_iff_lt less_imp_diff_less p2_gt_0 two_power_increasing
             word_1_le_power word_le_minus_mono_left word_less_sub_1)
 
 lemma word_sub_mono4:
   "\<lbrakk> y + x \<le> z + x; y \<le> y + x; z \<le> z + x \<rbrakk> \<Longrightarrow> y \<le> z" for y :: "'a :: len word"
   by (simp add: word_add_le_iff2)
 
 lemma eq_or_less_helperD:
   "\<lbrakk> n = unat (2 ^ m - 1 :: 'a :: len word) \<or> n < unat (2 ^ m - 1 :: 'a word); m < LENGTH('a) \<rbrakk>
    \<Longrightarrow> n < 2 ^ m"
   by (meson le_less_trans nat_less_le unat_less_power word_power_less_1)
 
 lemma mask_sub:
   "n \<le> m \<Longrightarrow> mask m - mask n = mask m AND NOT(mask n :: 'a::len word)"
   by (metis (full_types) and_mask_eq_iff_shiftr_0 mask_out_sub_mask shiftr_mask_le word_bw_comms(1))
 
 lemma neg_mask_diff_bound:
   "sz'\<le> sz \<Longrightarrow> (ptr AND NOT(mask sz')) - (ptr AND NOT(mask sz)) \<le> 2 ^ sz - 2 ^ sz'"
   (is "_ \<Longrightarrow> ?lhs \<le> ?rhs")
   for ptr :: \<open>'a::len word\<close>
 proof -
   assume lt: "sz' \<le> sz"
   hence "?lhs = ptr AND (mask sz AND NOT(mask sz'))"
     by (metis add_diff_cancel_left' multiple_mask_trivia)
   also have "\<dots> \<le> ?rhs" using lt
     by (metis (mono_tags) add_diff_eq diff_eq_eq eq_iff mask_2pm1 mask_sub word_and_le')
   finally show ?thesis by simp
 qed
 
 lemma mask_out_eq_0:
   "\<lbrakk> idx < 2 ^ sz; sz < LENGTH('a) \<rbrakk> \<Longrightarrow> (of_nat idx :: 'a :: len word) AND NOT(mask sz) = 0"
   by (simp add: of_nat_power less_mask_eq mask_eq_0_eq_x)
 
 lemma is_aligned_neg_mask_eq':
   "is_aligned ptr sz = (ptr AND NOT(mask sz) = ptr)"
   using is_aligned_mask mask_eq_0_eq_x by blast
 
 lemma neg_mask_mask_unat:
   "sz < LENGTH('a)
    \<Longrightarrow> unat ((ptr :: 'a :: len word) AND NOT(mask sz)) + unat (ptr AND mask sz) = unat ptr"
   by (metis AND_NOT_mask_plus_AND_mask_eq unat_plus_simple word_and_le2)
 
 lemma unat_pow_le_intro:
   "LENGTH('a) \<le> n \<Longrightarrow> unat (x :: 'a :: len word) < 2 ^ n"
   by (metis lt2p_lem not_le of_nat_le_iff of_nat_numeral semiring_1_class.of_nat_power uint_nat)
 
 lemma unat_shiftl_less_t2n:
   "\<lbrakk> unat (x :: 'a :: len word) < 2 ^ (m - n); m < LENGTH('a) \<rbrakk> \<Longrightarrow> unat (x << n) < 2 ^ m"
   by (metis More_Word.of_nat_power nat_mult_power_less_eq numeral_2_eq_2 of_nat_push_bit push_bit_eq_mult unat_less_power unat_of_nat_len unsigned_less word_eq_unatI zero_less_Suc)
 
 lemma unat_is_aligned_add:
   "\<lbrakk> is_aligned p n; unat d < 2 ^ n \<rbrakk>
    \<Longrightarrow> unat (p + d AND mask n) = unat d \<and> unat (p + d AND NOT(mask n)) = unat p"
   by (metis add.right_neutral and_mask_eq_iff_le_mask and_not_mask le_mask_iff mask_add_aligned
             mask_out_add_aligned mult_zero_right shiftl_t2n shiftr_le_0)
 
 lemma unat_shiftr_shiftl_mask_zero:
   "\<lbrakk> c + a \<ge> LENGTH('a) + b ; c < LENGTH('a) \<rbrakk>
    \<Longrightarrow> unat (((q :: 'a :: len word) >> a << b) AND NOT(mask c)) = 0"
   by (fastforce intro: unat_is_aligned_add[where p=0 and n=c, simplified, THEN conjunct2]
                        unat_shiftl_less_t2n unat_shiftr_less_t2n unat_pow_le_intro)
 
 lemmas of_nat_ucast = ucast_of_nat[symmetric]
 
 lemma shift_then_mask_eq_shift_low_bits:
   "x \<le> mask (low_bits + high_bits) \<Longrightarrow> (x >> low_bits) AND mask high_bits = x >> low_bits"
   for x :: \<open>'a::len word\<close>
   by (simp add: leq_mask_shift le_mask_imp_and_mask)
 
 lemma leq_low_bits_iff_zero:
   "\<lbrakk> x \<le> mask (low bits + high bits); x >> low_bits = 0 \<rbrakk> \<Longrightarrow> (x AND mask low_bits = 0) = (x = 0)"
   for x :: \<open>'a::len word\<close>
   using and_mask_eq_iff_shiftr_0 by force
 
 lemma unat_less_iff:
   "\<lbrakk> unat (a :: 'a :: len word) = b; c < 2 ^ LENGTH('a) \<rbrakk> \<Longrightarrow> (a < of_nat c) = (b < c)"
   using unat_ucast_less_no_overflow_simp by blast
 
 lemma is_aligned_no_overflow3:
  "\<lbrakk> is_aligned (a :: 'a :: len word) n; n < LENGTH('a); b < 2 ^ n; c \<le> 2 ^ n; b < c \<rbrakk>
   \<Longrightarrow> a + b \<le> a + (c - 1)"
   by (meson is_aligned_no_wrap' le_m1_iff_lt not_le word_less_sub_1 word_plus_mono_right)
 
 lemma mask_add_aligned_right:
   "is_aligned p n \<Longrightarrow> (q + p) AND mask n = q AND mask n"
   by (simp add: mask_add_aligned add.commute)
 
 lemma leq_high_bits_shiftr_low_bits_leq_bits_mask:
   "x \<le> mask high_bits \<Longrightarrow> (x :: 'a :: len word) << low_bits \<le> mask (low_bits + high_bits)"
   by (metis le_mask_shiftl_le_mask)
 
 lemma word_two_power_neg_ineq:
   "2 ^ m \<noteq> (0 :: 'a word) \<Longrightarrow> 2 ^ n \<le> - (2 ^ m :: 'a :: len word)"
   apply (cases "n < LENGTH('a)"; simp add: power_overflow)
   apply (cases "m < LENGTH('a)"; simp add: power_overflow)
   apply (simp add: word_le_nat_alt unat_minus word_size)
   apply (cases "LENGTH('a)"; simp)
   apply (simp add: less_Suc_eq_le)
   apply (drule power_increasing[where a=2 and n=n] power_increasing[where a=2 and n=m], simp)+
   apply (drule(1) add_le_mono)
   apply simp
   done
 
 lemma unat_shiftl_absorb:
   "\<lbrakk> x \<le> 2 ^ p; p + k < LENGTH('a) \<rbrakk> \<Longrightarrow> unat (x :: 'a :: len word) * 2 ^ k = unat (x * 2 ^ k)"
   by (smt add_diff_cancel_right' add_lessD1 le_add2 le_less_trans mult.commute nat_le_power_trans
           unat_lt2p unat_mult_lem unat_power_lower word_le_nat_alt)
 
 lemma word_plus_mono_right_split:
   "\<lbrakk> unat ((x :: 'a :: len word) AND mask sz) + unat z < 2 ^ sz; sz < LENGTH('a) \<rbrakk>
    \<Longrightarrow> x \<le> x + z"
   apply (subgoal_tac "(x AND NOT(mask sz)) + (x AND mask sz) \<le> (x AND NOT(mask sz)) + ((x AND mask sz) + z)")
    apply (simp add:word_plus_and_or_coroll2 field_simps)
   apply (rule word_plus_mono_right)
    apply (simp add: less_le_trans no_olen_add_nat)
   using of_nat_power is_aligned_no_wrap' by force
 
 lemma mul_not_mask_eq_neg_shiftl:
   "NOT(mask n :: 'a::len word) = -1 << n"
   by (simp add: NOT_mask shiftl_t2n)
 
 lemma shiftr_mul_not_mask_eq_and_not_mask:
   "(x >> n) * NOT(mask n) = - (x AND NOT(mask n))"
   for x :: \<open>'a::len word\<close>
   by (metis NOT_mask and_not_mask mult_minus_left semiring_normalization_rules(7) shiftl_t2n)
 
 lemma mask_eq_n1_shiftr:
   "n \<le> LENGTH('a) \<Longrightarrow> (mask n :: 'a :: len word) = -1 >> (LENGTH('a) - n)"
   by (metis diff_diff_cancel eq_refl mask_full shiftr_mask2)
 
 lemma is_aligned_mask_out_add_eq:
   "is_aligned p n \<Longrightarrow> (p + x) AND NOT(mask n) = p + (x AND NOT(mask n))"
   by (simp add: mask_out_sub_mask mask_add_aligned)
 
 lemmas is_aligned_mask_out_add_eq_sub
     = is_aligned_mask_out_add_eq[where x="a - b" for a b, simplified field_simps]
 
 lemma aligned_bump_down:
   "is_aligned x n \<Longrightarrow> (x - 1) AND NOT(mask n) = x - 2 ^ n"
   by (drule is_aligned_mask_out_add_eq[where x="-1"]) (simp add: NOT_mask)
 
 lemma unat_2tp_if:
   "unat (2 ^ n :: ('a :: len) word) = (if n < LENGTH ('a) then 2 ^ n else 0)"
   by (split if_split, simp_all add: power_overflow)
 
 lemma mask_of_mask:
   "mask (n::nat) AND mask (m::nat) = (mask (min m n) :: 'a::len word)"
   by word_eqI_solve
 
 lemma unat_signed_ucast_less_ucast:
   "LENGTH('a) \<le> LENGTH('b) \<Longrightarrow> unat (ucast (x :: 'a :: len word) :: 'b :: len signed word) = unat x"
   by (simp add: unat_ucast_up_simp)
 
 lemma toEnum_of_ucast:
   "LENGTH('b) \<le> LENGTH('a) \<Longrightarrow>
    (toEnum (unat (b::'b :: len word))::'a :: len word) = of_nat (unat b)"
   by (simp add: unat_pow_le_intro)
 
 lemmas unat_ucast_mask = unat_ucast_eq_unat_and_mask[where w=a for a]
 
 lemma t2n_mask_eq_if:
   "2 ^ n AND mask m = (if n < m then 2 ^ n else (0 :: 'a::len word))"
   by (rule word_eqI) (auto simp add: bit_simps)
 
 lemma unat_ucast_le:
   "unat (ucast (x :: 'a :: len word) :: 'b :: len word) \<le> unat x"
   by (simp add: ucast_nat_def word_unat_less_le)
 
 lemma ucast_le_up_down_iff:
   "\<lbrakk> LENGTH('a) \<le> LENGTH('b); (x :: 'b :: len word) \<le> ucast (- 1 :: 'a :: len word) \<rbrakk>
    \<Longrightarrow> (ucast x \<le> (y :: 'a word)) = (x \<le> ucast y)"
   using le_max_word_ucast_id ucast_le_ucast by metis
 
 lemma ucast_ucast_mask_shift:
   "a \<le> LENGTH('a) + b
    \<Longrightarrow> ucast (ucast (p AND mask a >> b) :: 'a :: len word) = p AND mask a >> b"
   by (metis add.commute le_mask_iff shiftr_mask_le ucast_ucast_eq_mask_shift word_and_le')
 
 lemma unat_ucast_mask_shift:
   "a \<le> LENGTH('a) + b
    \<Longrightarrow> unat (ucast (p AND mask a >> b) :: 'a :: len word) = unat (p AND mask a >> b)"
   by (metis linear ucast_ucast_mask_shift unat_ucast_up_simp)
 
 lemma mask_overlap_zero:
   "a \<le> b \<Longrightarrow> (p AND mask a) AND NOT(mask b) = 0"
   for p :: \<open>'a::len word\<close>
   by (metis NOT_mask_AND_mask mask_lower_twice2 max_def)
 
 lemma mask_shifl_overlap_zero:
   "a + c \<le> b \<Longrightarrow> (p AND mask a << c) AND NOT(mask b) = 0"
   for p :: \<open>'a::len word\<close>
   by (metis and_mask_0_iff_le_mask mask_mono mask_shiftl_decompose order_trans shiftl_over_and_dist word_and_le' word_and_le2)
 
 lemma mask_overlap_zero':
   "a \<ge> b \<Longrightarrow> (p AND NOT(mask a)) AND mask b = 0"
   for p :: \<open>'a::len word\<close>
   using mask_AND_NOT_mask mask_AND_less_0 by blast
 
 lemma mask_rshift_mult_eq_rshift_lshift:
   "((a :: 'a :: len word) >> b) * (1 << c) = (a >> b << c)"
   by (simp add: shiftl_t2n)
 
 lemma shift_alignment:
   "a \<ge> b \<Longrightarrow> is_aligned (p >> a << a) b"
   using is_aligned_shift is_aligned_weaken by blast
 
 lemma mask_split_sum_twice:
   "a \<ge> b \<Longrightarrow> (p AND NOT(mask a)) + ((p AND mask a) AND NOT(mask b)) + (p AND mask b) = p"
   for p :: \<open>'a::len word\<close>
   by (simp add: add.commute multiple_mask_trivia word_bw_comms(1) word_bw_lcs(1) word_plus_and_or_coroll2)
 
 lemma mask_shift_eq_mask_mask:
   "(p AND mask a >> b << b) = (p AND mask a) AND NOT(mask b)"
   for p :: \<open>'a::len word\<close>
   by (simp add: and_not_mask)
 
 lemma mask_shift_sum:
   "\<lbrakk> a \<ge> b; unat n = unat (p AND mask b) \<rbrakk>
    \<Longrightarrow> (p AND NOT(mask a)) + (p AND mask a >> b) * (1 << b) + n = (p :: 'a :: len word)"
   apply (simp add: push_bit_of_1 flip: push_bit_eq_mult)
   apply (subst disjunctive_add)
    apply (auto simp add: bit_simps)
   apply (smt (z3) AND_NOT_mask_plus_AND_mask_eq and.comm_neutral and.right_idem and_not_mask bit.conj_disj_distrib bit.disj_cancel_right mask_out_first_mask_some word_bw_assocs(1) word_bw_comms(1) word_bw_comms(2) word_eq_unatI)
   done
 
 lemma is_up_compose:
   "\<lbrakk> is_up uc; is_up uc' \<rbrakk> \<Longrightarrow> is_up (uc' \<circ> uc)"
   unfolding is_up_def by (simp add: Word.target_size Word.source_size)
 
 lemma of_int_sint_scast:
   "of_int (sint (x :: 'a :: len word)) = (scast x :: 'b :: len word)"
   by (fact Word.of_int_sint)
 
 lemma scast_of_nat_to_signed [simp]:
   "scast (of_nat x :: 'a :: len word) = (of_nat x :: 'a signed word)"
   by (rule bit_word_eqI) (simp add: bit_simps)
 
 lemma scast_of_nat_signed_to_unsigned_add:
   "scast (of_nat x + of_nat y :: 'a :: len signed word) = (of_nat x + of_nat y :: 'a :: len word)"
   by (metis of_nat_add scast_of_nat)
 
 lemma scast_of_nat_unsigned_to_signed_add:
   "(scast (of_nat x + of_nat y :: 'a :: len word)) = (of_nat x + of_nat y :: 'a :: len signed word)"
   by (metis Abs_fnat_hom_add scast_of_nat_to_signed)
 
 lemma and_mask_cases:
   fixes x :: "'a :: len word"
   assumes len: "n < LENGTH('a)"
   shows "x AND mask n \<in> of_nat ` set [0 ..< 2 ^ n]"
   apply (simp flip: take_bit_eq_mask)
   apply (rule image_eqI [of _ _ \<open>unat (take_bit n x)\<close>])
   using len apply simp_all
   apply transfer
   apply simp
   done
 
 lemma sint_eq_uint_2pl:
   "\<lbrakk> (a :: 'a :: len word) < 2 ^ (LENGTH('a) - 1) \<rbrakk>
    \<Longrightarrow> sint a = uint a"
   by (simp add: not_msb_from_less sint_eq_uint word_2p_lem word_size)
 
 lemma pow_sub_less:
   "\<lbrakk> a + b \<le> LENGTH('a); unat (x :: 'a :: len word) = 2 ^ a \<rbrakk>
    \<Longrightarrow> unat (x * 2 ^ b - 1) < 2 ^ (a + b)"
   by (smt (z3) eq_or_less_helperD le_add2 le_eq_less_or_eq le_trans power_add unat_mult_lem unat_pow_le_intro unat_power_lower word_eq_unatI)
 
 lemma sle_le_2pl:
   "\<lbrakk> (b :: 'a :: len word) < 2 ^ (LENGTH('a) - 1); a \<le> b \<rbrakk> \<Longrightarrow> a <=s b"
   by (simp add: not_msb_from_less word_sle_msb_le)
 
 lemma sless_less_2pl:
   "\<lbrakk> (b :: 'a :: len word) < 2 ^ (LENGTH('a) - 1); a < b \<rbrakk> \<Longrightarrow> a <s b"
   using not_msb_from_less word_sless_msb_less by blast
 
 lemma and_mask2:
   "w << n >> n = w AND mask (size w - n)"
   for w :: \<open>'a::len word\<close>
   by (cases "n \<le> size w"; clarsimp simp: word_and_le2 and_mask shiftl_zero_size)
 
 lemma aligned_sub_aligned_simple:
   "\<lbrakk> is_aligned a n; is_aligned b n \<rbrakk> \<Longrightarrow> is_aligned (a - b) n"
   by (simp add: aligned_sub_aligned)
 
 lemma minus_one_shift:
   "- (1 << n) = (-1 << n :: 'a::len word)"
   by (simp flip: mul_not_mask_eq_neg_shiftl minus_exp_eq_not_mask add: push_bit_of_1)
 
 lemma ucast_eq_mask:
   "(UCAST('a::len \<rightarrow> 'b::len) x = UCAST('a \<rightarrow> 'b) y) =
    (x AND mask LENGTH('b) = y AND mask LENGTH('b))"
   by transfer (simp flip: take_bit_eq_mask add: ac_simps)
 
 context
   fixes w :: "'a::len word"
 begin
 
 private lemma sbintrunc_uint_ucast:
   assumes "Suc n = LENGTH('b::len)"
   shows "signed_take_bit n (uint (ucast w :: 'b word)) = signed_take_bit n (uint w)"
   by (rule bit_eqI) (use assms in \<open>simp add: bit_simps\<close>)
 
 private lemma test_bit_sbintrunc:
   assumes "i < LENGTH('a)"
   shows "bit (word_of_int (signed_take_bit n (uint w)) :: 'a word) i
            = (if n < i then bit w n else bit w i)"
   using assms by (simp add: bit_simps)
 
 private lemma test_bit_sbintrunc_ucast:
   assumes len_a: "i < LENGTH('a)"
   shows "bit (word_of_int (signed_take_bit (LENGTH('b) - 1) (uint (ucast w :: 'b word))) :: 'a word) i
           = (if LENGTH('b::len) \<le> i then bit w (LENGTH('b) - 1) else bit w i)"
   using len_a by (auto simp add: sbintrunc_uint_ucast bit_simps)
 
 lemma scast_ucast_high_bits:
   \<open>scast (ucast w :: 'b::len word) = w
      \<longleftrightarrow> (\<forall> i \<in> {LENGTH('b) ..< size w}. bit w i = bit w (LENGTH('b) - 1))\<close>
 proof (cases \<open>LENGTH('a) \<le> LENGTH('b)\<close>)
   case True
   moreover define m where \<open>m = LENGTH('b) - LENGTH('a)\<close>
   ultimately have \<open>LENGTH('b) = m + LENGTH('a)\<close>
     by simp
   then show ?thesis
     apply (simp_all add: signed_ucast_eq word_size)
     apply (rule bit_word_eqI)
     apply (simp add: bit_signed_take_bit_iff)
     done
 next
   case False
   define q where \<open>q = LENGTH('b) - 1\<close>
   then have \<open>LENGTH('b) = Suc q\<close>
     by simp
   moreover define m where \<open>m = Suc LENGTH('a) - LENGTH('b)\<close>
   with False \<open>LENGTH('b) = Suc q\<close> have \<open>LENGTH('a) = m + q\<close>
     by (simp add: not_le)
   ultimately show ?thesis
     apply (simp_all add: signed_ucast_eq word_size)
     apply (transfer fixing: m q)
     apply (simp add: signed_take_bit_take_bit)
     apply rule
     apply (subst bit_eq_iff)
     apply (simp add: bit_take_bit_iff bit_signed_take_bit_iff min_def)
     apply (auto simp add: Suc_le_eq)
     using less_imp_le_nat apply blast
     using less_imp_le_nat apply blast
     done
 qed
 
 lemma scast_ucast_mask_compare:
   "scast (ucast w :: 'b::len word) = w
    \<longleftrightarrow> (w \<le> mask (LENGTH('b) - 1) \<or> NOT(mask (LENGTH('b) - 1)) \<le> w)"
   apply (clarsimp simp: le_mask_high_bits neg_mask_le_high_bits scast_ucast_high_bits word_size)
   apply (rule iffI; clarsimp)
    apply (rename_tac i j; case_tac "i = LENGTH('b) - 1"; case_tac "j = LENGTH('b) - 1")
   by auto
 
 lemma ucast_less_shiftl_helper':
   "\<lbrakk> LENGTH('b) + (a::nat) < LENGTH('a); 2 ^ (LENGTH('b) + a) \<le> n\<rbrakk>
    \<Longrightarrow> (ucast (x :: 'b::len word) << a) < (n :: 'a::len word)"
   apply (erule order_less_le_trans[rotated])
   using ucast_less[where x=x and 'a='a]
   apply (simp only: shiftl_t2n field_simps)
   apply (rule word_less_power_trans2; simp)
   done
 
 end
 
 lemma ucast_ucast_mask2:
   "is_down (UCAST ('a \<rightarrow> 'b)) \<Longrightarrow>
    UCAST ('b::len \<rightarrow> 'c::len) (UCAST ('a::len \<rightarrow> 'b::len) x) = UCAST ('a \<rightarrow> 'c) (x AND mask LENGTH('b))"
   apply (simp flip: take_bit_eq_mask)
   apply transfer
   apply simp
   done
 
 lemma ucast_NOT:
   "ucast (NOT x) = NOT(ucast x) AND mask (LENGTH('a))" for x::"'a::len word"
   by word_eqI
 
 lemma ucast_NOT_down:
   "is_down UCAST('a::len \<rightarrow> 'b::len) \<Longrightarrow> UCAST('a \<rightarrow> 'b) (NOT x) = NOT(UCAST('a \<rightarrow> 'b) x)"
   by word_eqI
 
 lemma upto_enum_step_shift:
   "\<lbrakk> is_aligned p n \<rbrakk> \<Longrightarrow>
   ([p , p + 2 ^ m .e. p + 2 ^ n - 1])
       = map ((+) p) [0, 2 ^ m .e. 2 ^ n - 1]"
   apply (erule is_aligned_get_word_bits)
    prefer 2
    apply (simp add: map_idI)
   apply (clarsimp simp: upto_enum_step_def)
   apply (frule is_aligned_no_overflow)
   apply (simp add: linorder_not_le [symmetric])
   done
 
 lemma upto_enum_step_shift_red:
   "\<lbrakk> is_aligned p sz; sz < LENGTH('a); us \<le> sz \<rbrakk>
      \<Longrightarrow> [p :: 'a :: len word, p + 2 ^ us .e. p + 2 ^ sz - 1]
           = map (\<lambda>x. p + of_nat x * 2 ^ us) [0 ..< 2 ^ (sz - us)]"
   apply (subst upto_enum_step_shift, assumption)
   apply (simp add: upto_enum_step_red)
   done
 
 lemma upto_enum_step_subset:
   "set [x, y .e. z] \<subseteq> {x .. z}"
   apply (clarsimp simp: upto_enum_step_def linorder_not_less)
   apply (drule div_to_mult_word_lt)
   apply (rule conjI)
    apply (erule word_random[rotated])
    apply simp
   apply (rule order_trans)
    apply (erule word_plus_mono_right)
    apply simp
   apply simp
   done
 
 lemma ucast_distrib:
   fixes M :: "'a::len word \<Rightarrow> 'a::len word \<Rightarrow> 'a::len word"
   fixes M' :: "'b::len word \<Rightarrow> 'b::len word \<Rightarrow> 'b::len word"
   fixes L :: "int \<Rightarrow> int \<Rightarrow> int"
   assumes lift_M: "\<And>x y. uint (M x y) = L (uint x) (uint y)  mod 2 ^ LENGTH('a)"
   assumes lift_M': "\<And>x y. uint (M' x y) = L (uint x) (uint y)  mod 2 ^ LENGTH('b)"
   assumes distrib: "\<And>x y. (L (x mod (2 ^ LENGTH('b))) (y mod (2 ^ LENGTH('b)))) mod (2 ^ LENGTH('b))
                                = (L x y) mod (2 ^ LENGTH('b))"
   assumes is_down: "is_down (ucast :: 'a word \<Rightarrow> 'b word)"
   shows "ucast (M a b) = M' (ucast a) (ucast b)"
   apply (simp only: ucast_eq)
   apply (subst lift_M)
   apply (subst of_int_uint [symmetric], subst lift_M')
   apply (metis local.distrib local.is_down take_bit_eq_mod ucast_down_wi uint_word_of_int_eq word_of_int_uint)
   done
 
 lemma ucast_down_add:
     "is_down (ucast:: 'a word \<Rightarrow> 'b word) \<Longrightarrow>  ucast ((a :: 'a::len word) + b) = (ucast a + ucast b :: 'b::len word)"
   by (rule ucast_distrib [where L="(+)"], (clarsimp simp: uint_word_ariths)+, presburger, simp)
 
 lemma ucast_down_minus:
     "is_down (ucast:: 'a word \<Rightarrow> 'b word) \<Longrightarrow>  ucast ((a :: 'a::len word) - b) = (ucast a - ucast b :: 'b::len word)"
   apply (rule ucast_distrib [where L="(-)"], (clarsimp simp: uint_word_ariths)+)
   apply (metis mod_diff_left_eq mod_diff_right_eq)
   apply simp
   done
 
 lemma ucast_down_mult:
     "is_down (ucast:: 'a word \<Rightarrow> 'b word) \<Longrightarrow>  ucast ((a :: 'a::len word) * b) = (ucast a * ucast b :: 'b::len word)"
   apply (rule ucast_distrib [where L="(*)"], (clarsimp simp: uint_word_ariths)+)
   apply (metis mod_mult_eq)
   apply simp
   done
 
 lemma scast_distrib:
   fixes M :: "'a::len word \<Rightarrow> 'a::len word \<Rightarrow> 'a::len word"
   fixes M' :: "'b::len word \<Rightarrow> 'b::len word \<Rightarrow> 'b::len word"
   fixes L :: "int \<Rightarrow> int \<Rightarrow> int"
   assumes lift_M: "\<And>x y. uint (M x y) = L (uint x) (uint y)  mod 2 ^ LENGTH('a)"
   assumes lift_M': "\<And>x y. uint (M' x y) = L (uint x) (uint y)  mod 2 ^ LENGTH('b)"
   assumes distrib: "\<And>x y. (L (x mod (2 ^ LENGTH('b))) (y mod (2 ^ LENGTH('b)))) mod (2 ^ LENGTH('b))
                                = (L x y) mod (2 ^ LENGTH('b))"
   assumes is_down: "is_down (scast :: 'a word \<Rightarrow> 'b word)"
   shows "scast (M a b) = M' (scast a) (scast b)"
   apply (subst (1 2 3) down_cast_same [symmetric])
    apply (insert is_down)
    apply (clarsimp simp: is_down_def target_size source_size is_down)
   apply (rule ucast_distrib [where L=L, OF lift_M lift_M' distrib])
   apply (insert is_down)
   apply (clarsimp simp: is_down_def target_size source_size is_down)
   done
 
 lemma scast_down_add:
     "is_down (scast:: 'a word \<Rightarrow> 'b word) \<Longrightarrow>  scast ((a :: 'a::len word) + b) = (scast a + scast b :: 'b::len word)"
   by (rule scast_distrib [where L="(+)"], (clarsimp simp: uint_word_ariths)+, presburger, simp)
 
 lemma scast_down_minus:
     "is_down (scast:: 'a word \<Rightarrow> 'b word) \<Longrightarrow>  scast ((a :: 'a::len word) - b) = (scast a - scast b :: 'b::len word)"
   apply (rule scast_distrib [where L="(-)"], (clarsimp simp: uint_word_ariths)+)
   apply (metis mod_diff_left_eq mod_diff_right_eq)
   apply simp
   done
 
 lemma scast_down_mult:
     "is_down (scast:: 'a word \<Rightarrow> 'b word) \<Longrightarrow>  scast ((a :: 'a::len word) * b) = (scast a * scast b :: 'b::len word)"
   apply (rule scast_distrib [where L="(*)"], (clarsimp simp: uint_word_ariths)+)
   apply (metis mod_mult_eq)
   apply simp
   done
 
 lemma scast_ucast_1:
   "\<lbrakk> is_down (ucast :: 'a word \<Rightarrow> 'b word); is_down (ucast :: 'b word \<Rightarrow> 'c word) \<rbrakk> \<Longrightarrow>
          (scast (ucast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = ucast a"
   by (metis down_cast_same ucast_eq ucast_down_wi)
 
 lemma scast_ucast_3:
   "\<lbrakk> is_down (ucast :: 'a word \<Rightarrow> 'c word); is_down (ucast :: 'b word \<Rightarrow> 'c word) \<rbrakk> \<Longrightarrow>
          (scast (ucast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = ucast a"
   by (metis down_cast_same ucast_eq ucast_down_wi)
 
 lemma scast_ucast_4:
   "\<lbrakk> is_up (ucast :: 'a word \<Rightarrow> 'b word); is_down (ucast :: 'b word \<Rightarrow> 'c word) \<rbrakk> \<Longrightarrow>
          (scast (ucast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = ucast a"
   by (metis down_cast_same ucast_eq ucast_down_wi)
 
 lemma scast_scast_b:
   "\<lbrakk> is_up (scast :: 'a word \<Rightarrow> 'b word) \<rbrakk> \<Longrightarrow>
      (scast (scast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = scast a"
   by (metis scast_eq sint_up_scast)
 
 lemma ucast_scast_1:
   "\<lbrakk> is_down (scast :: 'a word \<Rightarrow> 'b word); is_down (ucast :: 'b word \<Rightarrow> 'c word) \<rbrakk> \<Longrightarrow>
             (ucast (scast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = scast a"
   by (metis scast_eq ucast_down_wi)
 
 lemma ucast_scast_3:
   "\<lbrakk> is_down (scast :: 'a word \<Rightarrow> 'c word); is_down (ucast :: 'b word \<Rightarrow> 'c word) \<rbrakk> \<Longrightarrow>
      (ucast (scast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = scast a"
   by (metis scast_eq ucast_down_wi)
 
 lemma ucast_scast_4:
   "\<lbrakk> is_up (scast :: 'a word \<Rightarrow> 'b word); is_down (ucast :: 'b word \<Rightarrow> 'c word) \<rbrakk> \<Longrightarrow>
      (ucast (scast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = scast a"
   by (metis down_cast_same scast_eq sint_up_scast)
 
 lemma ucast_ucast_a:
   "\<lbrakk> is_down (ucast :: 'b word \<Rightarrow> 'c word) \<rbrakk> \<Longrightarrow>
         (ucast (ucast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = ucast a"
   by (metis down_cast_same ucast_eq ucast_down_wi)
 
 lemma ucast_ucast_b:
   "\<lbrakk> is_up (ucast :: 'a word \<Rightarrow> 'b word) \<rbrakk> \<Longrightarrow>
      (ucast (ucast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = ucast a"
   by (metis ucast_up_ucast)
 
 lemma scast_scast_a:
   "\<lbrakk> is_down (scast :: 'b word \<Rightarrow> 'c word) \<rbrakk> \<Longrightarrow>
             (scast (scast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = scast a"
   apply (simp only: scast_eq)
   apply (metis down_cast_same is_up_down scast_eq ucast_down_wi)
   done
 
 lemma scast_down_wi [OF refl]:
   "uc = scast \<Longrightarrow> is_down uc \<Longrightarrow> uc (word_of_int x) = word_of_int x"
   by (metis down_cast_same is_up_down ucast_down_wi)
 
 lemmas cast_simps =
   is_down is_up
   scast_down_add scast_down_minus scast_down_mult
   ucast_down_add ucast_down_minus ucast_down_mult
   scast_ucast_1 scast_ucast_3 scast_ucast_4
   ucast_scast_1 ucast_scast_3 ucast_scast_4
   ucast_ucast_a ucast_ucast_b
   scast_scast_a scast_scast_b
   ucast_down_wi scast_down_wi
   ucast_of_nat scast_of_nat
   uint_up_ucast sint_up_scast
   up_scast_surj up_ucast_surj
 
 lemma sdiv_word_max:
     "(sint (a :: ('a::len) word) sdiv sint (b :: ('a::len) word) < (2 ^ (size a - 1))) =
           ((a \<noteq> - (2 ^ (size a - 1)) \<or> (b \<noteq> -1)))"
     (is "?lhs = (\<not> ?a_int_min \<or> \<not> ?b_minus1)")
 proof (rule classical)
   assume not_thesis: "\<not> ?thesis"
 
   have not_zero: "b \<noteq> 0"
     using not_thesis
     by (clarsimp)
 
   let ?range = \<open>{- (2 ^ (size a - 1))..<2 ^ (size a - 1)} :: int set\<close>
 
   have result_range: "sint a sdiv sint b \<in> ?range \<union> {2 ^ (size a - 1)}"
     using sdiv_word_min [of a b] sdiv_word_max [of a b] by auto
 
   have result_range_overflow: "(sint a sdiv sint b = 2 ^ (size a - 1)) = (?a_int_min \<and> ?b_minus1)"
     apply (rule iffI [rotated])
      apply (clarsimp simp: signed_divide_int_def sgn_if word_size sint_int_min)
     apply (rule classical)
     apply (case_tac "?a_int_min")
      apply (clarsimp simp: word_size sint_int_min)
      apply (metis diff_0_right
               int_sdiv_negated_is_minus1 minus_diff_eq minus_int_code(2)
               power_eq_0_iff sint_minus1 zero_neq_numeral)
     apply (subgoal_tac "abs (sint a) < 2 ^ (size a - 1)")
      apply (insert sdiv_int_range [where a="sint a" and b="sint b"])[1]
      apply (clarsimp simp: word_size)
     apply (insert sdiv_int_range [where a="sint a" and b="sint b"])[1]
     apply auto
     apply (cases \<open>size a\<close>)
      apply simp_all
     apply (smt (z3) One_nat_def diff_Suc_1 signed_word_eqI sint_int_min sint_range_size wsst_TYs(3))
     done
 
   have result_range_simple: "(sint a sdiv sint b \<in> ?range) \<Longrightarrow> ?thesis"
     apply (insert sdiv_int_range [where a="sint a" and b="sint b"])
     apply (clarsimp simp: word_size sint_int_min)
     done
 
   show ?thesis
     apply (rule UnE [OF result_range result_range_simple])
      apply simp
     apply (clarsimp simp: word_size)
     using result_range_overflow
     apply (clarsimp simp: word_size)
     done
 qed
 
 lemmas sdiv_word_min' = sdiv_word_min [simplified word_size, simplified]
 lemmas sdiv_word_max' = sdiv_word_max [simplified word_size, simplified]
 
 lemma signed_arith_ineq_checks_to_eq:
   "((- (2 ^ (size a - 1)) \<le> (sint a + sint b)) \<and> (sint a + sint b \<le> (2 ^ (size a - 1) - 1)))
     = (sint a + sint b = sint (a + b ))"
   "((- (2 ^ (size a - 1)) \<le> (sint a - sint b)) \<and> (sint a - sint b \<le> (2 ^ (size a - 1) - 1)))
     = (sint a - sint b = sint (a - b))"
   "((- (2 ^ (size a - 1)) \<le> (- sint a)) \<and> (- sint a) \<le> (2 ^ (size a - 1) - 1))
     = ((- sint a) = sint (- a))"
   "((- (2 ^ (size a - 1)) \<le> (sint a * sint b)) \<and> (sint a * sint b \<le> (2 ^ (size a - 1) - 1)))
     = (sint a * sint b = sint (a * b))"
   "((- (2 ^ (size a - 1)) \<le> (sint a sdiv sint b)) \<and> (sint a sdiv sint b \<le> (2 ^ (size a - 1) - 1)))
     = (sint a sdiv sint b = sint (a sdiv b))"
   "((- (2 ^ (size a - 1)) \<le> (sint a smod sint b)) \<and> (sint a smod sint b \<le> (2 ^ (size a - 1) - 1)))
     = (sint a smod sint b = sint (a smod b))"
   by (auto simp: sint_word_ariths word_size signed_div_arith signed_mod_arith signed_take_bit_int_eq_self_iff intro: sym dest: sym)
 
 lemma signed_arith_sint:
   "((- (2 ^ (size a - 1)) \<le> (sint a + sint b)) \<and> (sint a + sint b \<le> (2 ^ (size a - 1) - 1)))
     \<Longrightarrow> sint (a + b) = (sint a + sint b)"
   "((- (2 ^ (size a - 1)) \<le> (sint a - sint b)) \<and> (sint a - sint b \<le> (2 ^ (size a - 1) - 1)))
     \<Longrightarrow> sint (a - b) = (sint a - sint b)"
   "((- (2 ^ (size a - 1)) \<le> (- sint a)) \<and> (- sint a) \<le> (2 ^ (size a - 1) - 1))
     \<Longrightarrow> sint (- a) = (- sint a)"
   "((- (2 ^ (size a - 1)) \<le> (sint a * sint b)) \<and> (sint a * sint b \<le> (2 ^ (size a - 1) - 1)))
     \<Longrightarrow> sint (a * b) = (sint a * sint b)"
   "((- (2 ^ (size a - 1)) \<le> (sint a sdiv sint b)) \<and> (sint a sdiv sint b \<le> (2 ^ (size a - 1) - 1)))
     \<Longrightarrow> sint (a sdiv b) = (sint a sdiv sint b)"
   "((- (2 ^ (size a - 1)) \<le> (sint a smod sint b)) \<and> (sint a smod sint b \<le> (2 ^ (size a - 1) - 1)))
     \<Longrightarrow> sint (a smod b) = (sint a smod sint b)"
   by (subst (asm) signed_arith_ineq_checks_to_eq; simp)+
 
 end
 
 end