diff --git a/thys/Amortized_Complexity/Splay_Tree_Analysis.thy b/thys/Amortized_Complexity/Splay_Tree_Analysis.thy
--- a/thys/Amortized_Complexity/Splay_Tree_Analysis.thy
+++ b/thys/Amortized_Complexity/Splay_Tree_Analysis.thy
@@ -1,432 +1,432 @@
 subsection "Splay Tree Analysis"
 
 theory Splay_Tree_Analysis
 imports
   Splay_Tree_Analysis_Base
   Amortized_Framework
 begin
 
 subsubsection "Analysis of splay"
 
 definition A_splay :: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> real" where
 "A_splay a t = T_splay a t + \<Phi>(splay a t) - \<Phi> t"
 
 text\<open>The following lemma is an attempt to prove a generic lemma that covers
 both zig-zig cases. However, the lemma is not as nice as one would like.
 Hence it is used only once, as a demo. Ideally the lemma would involve
 function @{const A_splay}, but that is impossible because this involves @{const splay}
 and thus depends on the ordering. We would need a truly symmetric version of @{const splay}
 that takes the ordering as an explicit argument. Then we could define
 all the symmetric cases by one final equation
-@{term"splay2 less t = splay2 (not o less) (mirror t)"}.
+\<^prop>\<open>splay2 less t = splay2 (\<lambda>x y. Not (less x y)) (mirror t)\<close>.
 This would simplify the code and the proofs.\<close>
 
 lemma zig_zig: fixes lx x rx lb b rb a ra u lb1 lb2
 defines [simp]: "X == Node lx (x) rx" defines[simp]: "B == Node lb b rb"
 defines [simp]: "t == Node B a ra" defines [simp]: "A' == Node rb a ra"
 defines [simp]: "t' == Node lb1 u (Node lb2 b A')"
 assumes hyps: "lb \<noteq> \<langle>\<rangle>" and IH: "T_splay x lb + \<Phi> lb1 + \<Phi> lb2 - \<Phi> lb \<le> 2 * \<phi> lb - 3 * \<phi> X + 1" and
  prems: "size lb = size lb1 + size lb2 + 1" "X \<in> subtrees lb"
 shows "T_splay x lb + \<Phi> t' - \<Phi> t \<le> 3 * (\<phi> t - \<phi> X)"
 proof -
   define B' where [simp]: "B' = Node lb2 b A'"
   have "T_splay x lb + \<Phi> t' - \<Phi> t = T_splay x lb + \<Phi> lb1 + \<Phi> lb2 - \<Phi> lb + \<phi> B' + \<phi> A' - \<phi> B"
     using prems
     by(auto simp: A_splay_def size_if_splay algebra_simps in_set_tree_if split: tree.split)
   also have "\<dots> \<le> 2 * \<phi> lb + \<phi> B' + \<phi> A' - \<phi> B - 3 * \<phi> X + 1"
     using IH prems(2) by(auto simp: algebra_simps)
   also have "\<dots> \<le> \<phi> lb + \<phi> B' + \<phi> A' - 3 * \<phi> X + 1" by(simp)
   also have "\<dots> \<le> \<phi> B' + 2 * \<phi> t - 3 * \<phi> X "
     using prems ld_ld_1_less[of "size1 lb" "size1 A'"]
     by(simp add: size_if_splay)
   also have "\<dots> \<le> 3 * \<phi> t - 3 * \<phi> X"
     using prems by(simp add: size_if_splay)
   finally show ?thesis by simp
 qed
 
 lemma A_splay_ub: "\<lbrakk> bst t; Node l x r : subtrees t \<rbrakk>
   \<Longrightarrow> A_splay x t \<le> 3 * (\<phi> t - \<phi>(Node l x r)) + 1"
 proof(induction x t rule: splay.induct)
   case 1 thus ?case by simp
 next
   case 2 thus ?case by (auto simp: A_splay_def)
 next
   case 4 hence False by(fastforce dest: in_set_tree_if) thus ?case ..
 next
   case 5 hence False by(fastforce dest: in_set_tree_if) thus ?case ..
 next
   case 7 hence False by(fastforce dest: in_set_tree_if) thus ?case ..
 next
   case 10 hence False by(fastforce dest: in_set_tree_if) thus ?case ..
 next
   case 12 hence False by(fastforce dest: in_set_tree_if) thus ?case ..
 next
   case 13 hence False by(fastforce dest: in_set_tree_if) thus ?case ..
 next
   case (3 x b A B CD)
   (* A readable proof *)
   let ?t = "\<langle>\<langle>A, x, B\<rangle>, b, CD\<rangle>"
   let ?t' = "\<langle>A, x, \<langle>B, b, CD\<rangle>\<rangle>"
   have *: "l = A \<and> r = B" using "3.prems" by(fastforce dest: in_set_tree_if)
   have "A_splay x ?t = 1 + \<Phi> ?t' - \<Phi> ?t" using "3.hyps" by (simp add: A_splay_def)
   also have "\<dots> = 1 + \<phi> ?t' + \<phi> \<langle>B, b, CD\<rangle>  - \<phi> ?t - \<phi> \<langle>A, x, B\<rangle>" by(simp)
   also have "\<dots> = 1 + \<phi> \<langle>B, b, CD\<rangle> - \<phi> \<langle>A, x, B\<rangle>" by(simp)
   also have "\<dots> \<le>  1 + \<phi> ?t - \<phi>(Node A x B)"
     using log_le_cancel_iff[of 2 "size1(Node B b CD)" "size1 ?t"] by (simp)
   also have "\<dots> \<le> 1 + 3 * (\<phi> ?t - \<phi>(Node A x B))"
     using log_le_cancel_iff[of 2 "size1(Node A x B)" "size1 ?t"] by (simp)
   finally show ?case using * by simp
 next
   case (9 b x AB C D)
   (* An automatic proof *)
   let ?A = "\<langle>AB, b, \<langle>C, x, D\<rangle>\<rangle>"
   have "x \<notin> set_tree AB" using "9.prems"(1) by auto
   with 9 show ?case using
     log_le_cancel_iff[of 2 "size1(Node AB b C)" "size1 ?A"]
     log_le_cancel_iff[of 2 "size1(Node C x D)" "size1 ?A"]
     by (auto simp: A_splay_def algebra_simps simp del:log_le_cancel_iff)
 next
   case (6 x a b A B C)
   hence *: "\<langle>l, x, r\<rangle> \<in> subtrees A" by(fastforce dest: in_set_tree_if)
   obtain A1 a' A2 where sp: "splay x A = Node A1 a' A2"
     using splay_not_Leaf[OF \<open>A \<noteq> Leaf\<close>] by blast
   let ?X = "Node l x r" let ?AB = "Node A a B"  let ?ABC = "Node ?AB b C"
   let ?A' = "Node A1 a' A2"
   let ?BC = "Node B b C"  let ?A2BC = "Node A2 a ?BC" let ?A1A2BC = "Node A1 a' ?A2BC"
   have 0: "\<phi> ?A1A2BC = \<phi> ?ABC" using sp by(simp add: size_if_splay)
   have 1: "\<Phi> ?A1A2BC - \<Phi> ?ABC = \<Phi> A1 + \<Phi> A2 + \<phi> ?A2BC + \<phi> ?BC - \<Phi> A - \<phi> ?AB"
     using 0 by (simp)
   have "A_splay x ?ABC = T_splay x A + 1 + \<Phi> ?A1A2BC - \<Phi> ?ABC"
     using "6.hyps" sp by(simp add: A_splay_def)
   also have "\<dots> = T_splay x A + 1 + \<Phi> A1 + \<Phi> A2 + \<phi> ?A2BC + \<phi> ?BC - \<Phi> A - \<phi> ?AB"
     using 1 by simp
   also have "\<dots> = T_splay x A + \<Phi> ?A' - \<phi> ?A' - \<Phi> A + \<phi> ?A2BC + \<phi> ?BC - \<phi> ?AB + 1"
     by(simp)
   also have "\<dots> = A_splay x A + \<phi> ?A2BC + \<phi> ?BC - \<phi> ?AB - \<phi> ?A' + 1"
     using sp by(simp add: A_splay_def)
   also have "\<dots> \<le> 3 * \<phi> A + \<phi> ?A2BC + \<phi> ?BC - \<phi> ?AB - \<phi> ?A' - 3 * \<phi> ?X + 2"
     using "6.IH" "6.prems"(1) * by(simp)
   also have "\<dots> = 2 * \<phi> A + \<phi> ?A2BC + \<phi> ?BC - \<phi> ?AB - 3 * \<phi> ?X + 2"
     using sp by(simp add: size_if_splay)
   also have "\<dots> < \<phi> A + \<phi> ?A2BC + \<phi> ?BC - 3 * \<phi> ?X + 2" by(simp)
   also have "\<dots> < \<phi> ?A2BC + 2 * \<phi> ?ABC - 3 * \<phi> ?X + 1"
     using sp ld_ld_1_less[of "size1 A" "size1 ?BC"]
     by(simp add: size_if_splay)
   also have "\<dots> < 3 * \<phi> ?ABC - 3 * \<phi> ?X + 1"
     using sp by(simp add: size_if_splay)
   finally show ?case by simp
 next
   case (8 a x b B A C)
   hence *: "\<langle>l, x, r\<rangle> \<in> subtrees B" by(fastforce dest: in_set_tree_if)
   obtain B1 b' B2 where sp: "splay x B = Node B1 b' B2"
      using splay_not_Leaf[OF \<open>B \<noteq> Leaf\<close>] by blast
   let ?X = "Node l x r" let ?AB = "Node A a B"  let ?ABC = "Node ?AB b C"
   let ?B' = "Node B1 b' B2"
   let ?AB1 = "Node A a B1"  let ?B2C = "Node B2 b C" let ?AB1B2C = "Node ?AB1 b' ?B2C"
   have 0: "\<phi> ?AB1B2C = \<phi> ?ABC" using sp by(simp add: size_if_splay)
   have 1: "\<Phi> ?AB1B2C - \<Phi> ?ABC = \<Phi> B1 + \<Phi> B2 + \<phi> ?AB1 + \<phi> ?B2C - \<Phi> B - \<phi> ?AB"
     using 0 by (simp)
   have "A_splay x ?ABC = T_splay x B + 1 + \<Phi> ?AB1B2C - \<Phi> ?ABC"
     using "8.hyps" sp by(simp add: A_splay_def)
   also have "\<dots> = T_splay x B + 1 + \<Phi> B1 + \<Phi> B2 + \<phi> ?AB1 + \<phi> ?B2C - \<Phi> B - \<phi> ?AB"
     using 1 by simp
   also have "\<dots> = T_splay x B + \<Phi> ?B' - \<phi> ?B' - \<Phi> B + \<phi> ?AB1 + \<phi> ?B2C - \<phi> ?AB + 1"
     by simp
   also have "\<dots> = A_splay x B + \<phi> ?AB1 + \<phi> ?B2C - \<phi> ?AB - \<phi> ?B' + 1"
     using sp by (simp add: A_splay_def)
   also have "\<dots> \<le> 3 * \<phi> B + \<phi> ?AB1 + \<phi> ?B2C - \<phi> ?AB - \<phi> ?B' - 3 * \<phi> ?X + 2"
     using "8.IH" "8.prems"(1) * by(simp)
   also have "\<dots> = 2 * \<phi> B + \<phi> ?AB1 + \<phi> ?B2C - \<phi> ?AB - 3 * \<phi> ?X + 2"
     using sp by(simp add: size_if_splay)
   also have "\<dots> < \<phi> B + \<phi> ?AB1 + \<phi> ?B2C - 3 * \<phi> ?X + 2" by(simp)
   also have "\<dots> < \<phi> B + 2 * \<phi> ?ABC - 3 * \<phi> ?X + 1"
     using sp ld_ld_1_less[of "size1 ?AB1" "size1 ?B2C"]
     by(simp add: size_if_splay)
   also have "\<dots> < 3 * \<phi> ?ABC - 3 * \<phi> ?X + 1" by(simp)
   finally show ?case by simp
 next
   case (11 b x c C A D)
   hence *: "\<langle>l, x, r\<rangle> \<in> subtrees C" by(fastforce dest: in_set_tree_if)
   obtain C1 c' C2 where sp: "splay x C = Node C1 c' C2"
     using splay_not_Leaf[OF \<open>C \<noteq> Leaf\<close>] by blast
   let ?X = "Node l x r" let ?CD = "Node C c D"  let ?ACD = "Node A b ?CD"
   let ?C' = "Node C1 c' C2"
   let ?C2D = "Node C2 c D"  let ?AC1 = "Node A b C1"
   have "A_splay x ?ACD = A_splay x C + \<phi> ?C2D + \<phi> ?AC1 - \<phi> ?CD - \<phi> ?C' + 1"
     using "11.hyps" sp
     by(auto simp: A_splay_def size_if_splay algebra_simps split: tree.split)
   also have "\<dots> \<le> 3 * \<phi> C + \<phi> ?C2D + \<phi> ?AC1 - \<phi> ?CD - \<phi> ?C' - 3 * \<phi> ?X + 2"
     using "11.IH" "11.prems"(1) * by(auto simp: algebra_simps)
   also have "\<dots> = 2 * \<phi> C + \<phi> ?C2D + \<phi> ?AC1 - \<phi> ?CD - 3 * \<phi> ?X + 2"
     using sp by(simp add: size_if_splay)
   also have "\<dots> \<le> \<phi> C + \<phi> ?C2D + \<phi> ?AC1 - 3 * \<phi> ?X + 2" by(simp)
   also have "\<dots> \<le> \<phi> C + 2 * \<phi> ?ACD - 3 * \<phi> ?X + 1"
     using sp ld_ld_1_less[of "size1 ?C2D" "size1 ?AC1"]
     by(simp add: size_if_splay algebra_simps)
   also have "\<dots> \<le> 3 * \<phi> ?ACD - 3 * \<phi> ?X + 1" by(simp)
   finally show ?case by simp
 next
   case (14 a x b CD A B)
   hence 0: "x \<notin> set_tree B \<and> x \<notin> set_tree A"
     using "14.prems"(1) \<open>b<x\<close> by(auto)
   hence 1: "x \<in> set_tree CD" using "14.prems" \<open>b<x\<close> \<open>a<x\<close> by (auto)
   obtain C c D where sp: "splay x CD = Node C c D"
     using splay_not_Leaf[OF \<open>CD \<noteq> Leaf\<close>] by blast
   from zig_zig[of CD x D C l r _ b B a A] 14 sp 0
   show ?case by(auto simp: A_splay_def size_if_splay algebra_simps)
 (* The explicit version:
   have "A_splay x ?A = A_splay x ?R + \<phi> ?B' + \<phi> ?A' - \<phi> ?B - \<phi> ?R' + 1"
     using "14.prems" 1 sp
     by(auto simp: A_splay_def size_if_splay algebra_simps split: tree.split)
   also have "\<dots> \<le> 3 * \<phi> ?R + \<phi> ?B' + \<phi> ?A' - \<phi> ?B - \<phi> ?R' - 3 * \<phi> ?X + 2"
     using 14 0 by(auto simp: algebra_simps)
   also have "\<dots> = 2 * \<phi> rb + \<phi> ?B' + \<phi> ?A' - \<phi> ?B - 3 * \<phi> ?X + 2"
     using sp by(simp add: size_if_splay)
   also have "\<dots> \<le> \<phi> ?R + \<phi> ?B' + \<phi> ?A' - 3 * \<phi> ?X + 2" by(simp)
   also have "\<dots> \<le> \<phi> ?B' + 2 * \<phi> ?A - 3 * \<phi> ?X + 1"
     using sp ld_ld_1_less[of "size1 ?R" "size1 ?A'"]
     by(simp add: size_if_splay algebra_simps)
   also have "\<dots> \<le> 3 * \<phi> ?A - 3 * \<phi> ?X + 1"
     using sp by(simp add: size_if_splay)
   finally show ?case by simp
 *)
 qed
 
 lemma A_splay_ub2: assumes "bst t" "x : set_tree t"
 shows "A_splay x t \<le> 3 * (\<phi> t - 1) + 1"
 proof -
   from assms(2) obtain l r where N: "Node l x r : subtrees t"
     by (metis set_treeE)
   have "A_splay x t \<le> 3 * (\<phi> t - \<phi>(Node l x r)) + 1" by(rule A_splay_ub[OF assms(1) N])
   also have "\<dots> \<le> 3 * (\<phi> t - 1) + 1" by(simp add: field_simps)
   finally show ?thesis .
 qed
 
 lemma A_splay_ub3: assumes "bst t" shows "A_splay x t \<le> 3 * \<phi> t + 1"
 proof cases
   assume "t = Leaf" thus ?thesis by(simp add: A_splay_def)
 next
   assume "t \<noteq> Leaf"
   from ex_in_set_tree[OF this assms] obtain x' where
     a': "x' \<in> set_tree t"  "splay x' t = splay x t"  "T_splay x' t = T_splay x t"
     by blast
   show ?thesis using A_splay_ub2[OF assms a'(1)] by(simp add: A_splay_def a')
 qed
 
 
 subsubsection "Analysis of insert"
 
 lemma amor_insert: assumes "bst t"
 shows "T_insert x t + \<Phi>(Splay_Tree.insert x t) - \<Phi> t \<le> 4 * log 2 (size1 t) + 3" (is "?l \<le> ?r")
 proof cases
   assume "t = Leaf" thus ?thesis by(simp add: T_insert_def)
 next
   assume "t \<noteq> Leaf"
   then obtain l e r where [simp]: "splay x t = Node l e r"
     by (metis tree.exhaust splay_Leaf_iff)
   let ?t = "real(T_splay x t)"
   let ?Plr = "\<Phi> l + \<Phi> r"  let ?Ps = "\<Phi> t"
   let ?slr = "real(size1 l) + real(size1 r)" let ?LR = "log 2 (1 + ?slr)"
   have opt: "?t + \<Phi> (splay x t) - ?Ps  \<le> 3 * log 2 (real (size1 t)) + 1"
     using A_splay_ub3[OF \<open>bst t\<close>, simplified A_splay_def, of x] by (simp)
   from less_linear[of e x]
   show ?thesis
   proof (elim disjE)
     assume "e=x"
     have nneg: "log 2 (1 + real (size t)) \<ge> 0" by simp
     thus ?thesis using \<open>t \<noteq> Leaf\<close> opt \<open>e=x\<close>
       apply(simp add: T_insert_def algebra_simps) using nneg by arith
   next
     let ?L = "log 2 (real(size1 l) + 1)"
     assume "e < x" hence "e \<noteq> x" by simp
     hence "?l = (?t + ?Plr - ?Ps) + ?L + ?LR + 1"
       using  \<open>t \<noteq> Leaf\<close> \<open>e<x\<close> by(simp add: T_insert_def)
     also have "?t + ?Plr - ?Ps \<le> 2 * log 2 ?slr + 1"
       using opt size_splay[of x t,symmetric] by(simp)
     also have "?L \<le> log 2 ?slr" by(simp)
     also have "?LR \<le> log 2 ?slr + 1"
     proof -
       have "?LR \<le> log 2 (2 * ?slr)" by (simp add:)
       also have "\<dots> \<le> log 2 ?slr + 1"
         by (simp add: log_mult del:distrib_left_numeral)
       finally show ?thesis .
     qed
     finally show ?thesis using size_splay[of x t,symmetric] by (simp)
   next
     let ?R = "log 2 (2 + real(size r))"
     assume "x < e" hence "e \<noteq> x" by simp
     hence "?l = (?t + ?Plr - ?Ps) + ?R + ?LR + 1"
       using \<open>t \<noteq> Leaf\<close> \<open>x < e\<close> by(simp add: T_insert_def)
     also have "?t + ?Plr - ?Ps \<le> 2 * log 2 ?slr + 1"
       using opt size_splay[of x t,symmetric] by(simp)
     also have "?R \<le> log 2 ?slr" by(simp)
     also have "?LR \<le> log 2 ?slr + 1"
     proof -
       have "?LR \<le> log 2 (2 * ?slr)" by (simp add:)
       also have "\<dots> \<le> log 2 ?slr + 1"
         by (simp add: log_mult del:distrib_left_numeral)
       finally show ?thesis .
     qed
     finally show ?thesis using size_splay[of x t, symmetric] by simp
   qed
 qed
 
 
 subsubsection "Analysis of delete"
 
 definition A_splay_max :: "'a::linorder tree \<Rightarrow> real" where
 "A_splay_max t = T_splay_max t + \<Phi>(splay_max t) - \<Phi> t"
 
 lemma A_splay_max_ub: "t \<noteq> Leaf \<Longrightarrow> A_splay_max t \<le> 3 * (\<phi> t - 1) + 1"
 proof(induction t rule: splay_max.induct)
   case 1 thus ?case by (simp)
 next
   case (2 A)
   thus ?case using one_le_log_cancel_iff[of 2 "size1 A + 1"]
     by (simp add: A_splay_max_def del: one_le_log_cancel_iff)
 next
   case (3 l b rl c rr)
   show ?case
   proof cases
     assume "rr = Leaf"
     thus ?thesis
       using one_le_log_cancel_iff[of 2 "1 + size1 rl"]
         one_le_log_cancel_iff[of 2 "1 + size1 l + size1 rl"]
         log_le_cancel_iff[of 2 "size1 l + size1 rl" "1 + size1 l + size1 rl"]
      by (auto simp: A_splay_max_def field_simps
            simp del: log_le_cancel_iff one_le_log_cancel_iff)
   next
     assume "rr \<noteq> Leaf"
     then obtain l' u r' where sp: "splay_max rr = Node l' u r'"
       using splay_max_Leaf_iff tree.exhaust by blast
     hence 1: "size rr = size l' + size r' + 1"
       using size_splay_max[of rr,symmetric] by(simp)
     let ?C = "Node rl c rr"  let ?B = "Node l b ?C"
     let ?B' = "Node l b rl"  let ?C' = "Node ?B' c l'"
     have "A_splay_max ?B = A_splay_max rr + \<phi> ?B' + \<phi> ?C' - \<phi> rr - \<phi> ?C + 1" using "3.prems" sp 1
       by(auto simp add: A_splay_max_def)
     also have "\<dots> \<le> 3 * (\<phi> rr - 1) + \<phi> ?B' + \<phi> ?C' - \<phi> rr - \<phi> ?C + 2"
       using 3 \<open>rr \<noteq> Leaf\<close> by auto
     also have "\<dots> = 2 * \<phi> rr + \<phi> ?B' + \<phi> ?C' - \<phi> ?C - 1" by simp
     also have "\<dots> \<le> \<phi> rr + \<phi> ?B' + \<phi> ?C' - 1" by simp
     also have "\<dots> \<le> 2 * \<phi> ?B + \<phi> ?C' - 2"
       using ld_ld_1_less[of "size1 ?B'" "size1 rr"] by(simp add:)
     also have "\<dots> \<le> 3 * \<phi> ?B - 2" using 1 by simp
     finally show ?case by simp
   qed
 qed
 
 lemma A_splay_max_ub3: "A_splay_max t \<le> 3 * \<phi> t + 1"
 proof cases
   assume "t = Leaf" thus ?thesis by(simp add: A_splay_max_def)
 next
   assume "t \<noteq> Leaf"
   show ?thesis using A_splay_max_ub[OF \<open>t \<noteq> Leaf\<close>] by(simp)
 qed
 
 lemma amor_delete: assumes "bst t"
 shows "T_delete a t + \<Phi>(Splay_Tree.delete a t) - \<Phi> t \<le> 6 * log 2 (size1 t) + 3"
 proof (cases t)
   case Leaf thus ?thesis by(simp add: Splay_Tree.delete_def T_delete_def)
 next
   case [simp]: (Node ls x rs)
   then obtain l e r where sp[simp]: "splay a (Node ls x rs) = Node l e r"
     by (metis tree.exhaust splay_Leaf_iff)
   let ?t = "real(T_splay a t)"
   let ?Plr = "\<Phi> l + \<Phi> r"  let ?Ps = "\<Phi> t"
   let ?slr = "real(size1 l) + real(size1 r)" let ?LR = "log 2 (1 + ?slr)"
   let ?lslr = "log 2 (real (size ls) + (real (size rs) + 2))"
   have "?lslr \<ge> 0" by simp
   have opt: "?t + \<Phi> (splay a t) - ?Ps  \<le> 3 * log 2 (real (size1 t)) + 1"
     using A_splay_ub3[OF \<open>bst t\<close>, simplified A_splay_def, of a]
     by (simp add: field_simps)
   show ?thesis
   proof (cases "e=a")
     case False thus ?thesis
       using opt apply(simp add: Splay_Tree.delete_def T_delete_def field_simps)
       using \<open>?lslr \<ge> 0\<close> by arith
   next
     case [simp]: True
     show ?thesis
     proof (cases l)
       case Leaf
       have 1: "log 2 (real (size r) + 2) \<ge> 0" by(simp)
       show ?thesis
         using Leaf opt apply(simp add: Splay_Tree.delete_def T_delete_def field_simps)
         using 1 \<open>?lslr \<ge> 0\<close> by arith
     next
       case (Node ll y lr)
       then obtain l' y' r' where [simp]: "splay_max (Node ll y lr) = Node l' y' r'"
       using splay_max_Leaf_iff tree.exhaust by blast
       have "bst l" using bst_splay[OF \<open>bst t\<close>, of a] by simp
       have "\<Phi> r' \<ge> 0" apply (induction r') by (auto)
       have optm: "real(T_splay_max l) + \<Phi> (splay_max l) - \<Phi> l  \<le> 3 * \<phi> l + 1"
         using A_splay_max_ub3[of l, simplified A_splay_max_def] by (simp add: field_simps Node)
       have 1: "log 2 (2+(real(size l')+real(size r))) \<le> log 2 (2+(real(size l)+real(size r)))"
         using size_splay_max[of l] Node by simp
       have 2: "log 2 (2 + (real (size l') + real (size r'))) \<ge> 0" by simp
       have 3: "log 2 (size1 l' + size1 r) \<le> log 2 (size1 l' + size1 r') + log 2 ?slr"
         apply simp using 1 2 by arith
       have 4: "log 2 (real(size ll) + (real(size lr) + 2)) \<le> ?lslr"
         using size_if_splay[OF sp] Node by simp
       show ?thesis using add_mono[OF opt optm] Node 3
         apply(simp add: Splay_Tree.delete_def T_delete_def field_simps)
         using 4 \<open>\<Phi> r' \<ge> 0\<close> by arith
     qed
   qed
 qed
 
 
 subsubsection "Overall analysis"
 
 fun U where
 "U Empty [] = 1" |
 "U (Splay _) [t] = 3 * log 2 (size1 t) + 1" |
 "U (Insert _) [t] = 4 * log 2 (size1 t) + 3" |
 "U (Delete _) [t] = 6 * log 2 (size1 t) + 3"
 
 interpretation Amortized
 where arity = arity and exec = exec and inv = bst
 and cost = cost and \<Phi> = \<Phi> and U = U
 proof (standard, goal_cases)
   case (1 ss f) show ?case
   proof (cases f)
     case Empty thus ?thesis using 1 by auto
   next
     case (Splay a)
     then obtain t where "ss = [t]" "bst t" using 1 by auto
     with Splay bst_splay[OF \<open>bst t\<close>, of a] show ?thesis
       by (auto split: tree.split)
   next
     case (Insert a)
     then obtain t where "ss = [t]" "bst t" using 1 by auto
     with bst_splay[OF \<open>bst t\<close>, of a] Insert show ?thesis
       by (auto simp: splay_bstL[OF \<open>bst t\<close>] splay_bstR[OF \<open>bst t\<close>] split: tree.split)
   next
     case (Delete a)
     then obtain t where "ss = [t]" "bst t" using 1 by auto
     with 1 Delete show ?thesis by(simp add: bst_delete)
   qed
 next
   case (2 t) thus ?case by (induction t) auto
 next
   case (3 ss f)
   show ?case (is "?l \<le> ?r")
   proof(cases f)
     case Empty thus ?thesis using 3(2) by(simp add: A_splay_def)
   next
     case (Splay a)
     then obtain t where "ss = [t]" "bst t" using 3 by auto
     thus ?thesis using Splay A_splay_ub3[OF \<open>bst t\<close>] by(simp add: A_splay_def)
   next
     case [simp]: (Insert a)
     then obtain t where [simp]: "ss = [t]" and "bst t" using 3 by auto
     thus ?thesis using amor_insert[of t a] by auto
   next
     case [simp]: (Delete a)
     then obtain t where [simp]: "ss = [t]" and "bst t" using 3 by auto
     thus ?thesis using amor_delete[of t a] by auto
   qed
 qed
 
 end
diff --git a/thys/BDD/General.thy b/thys/BDD/General.thy
--- a/thys/BDD/General.thy
+++ b/thys/BDD/General.thy
@@ -1,1912 +1,1912 @@
 (*  Title:       BDD
     Author:      Veronika Ortner and Norbert Schirmer, 2004
     Maintainer:  Norbert Schirmer,  norbert.schirmer at web de
     License:     LGPL
 *)
 
 (*  
 General.thy
 
 Copyright (C) 2004-2008 Veronika Ortner and Norbert Schirmer 
 Some rights reserved, TU Muenchen
 
 This library is free software; you can redistribute it and/or modify
 it under the terms of the GNU Lesser General Public License as
 published by the Free Software Foundation; either version 2.1 of the
 License, or (at your option) any later version.
 
 This library is distributed in the hope that it will be useful, but
 WITHOUT ANY WARRANTY; without even the implied warranty of
 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
 Lesser General Public License for more details.
 
 You should have received a copy of the GNU Lesser General Public
 License along with this library; if not, write to the Free Software
 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
 USA
 *)
 
 section \<open>General Lemmas on BDD Abstractions\<close>
 
 theory General imports BinDag begin
 
 definition subdag_eq:: "dag \<Rightarrow> dag \<Rightarrow> bool" where
 "subdag_eq t\<^sub>1 t\<^sub>2 = (t\<^sub>1 = t\<^sub>2 \<or> subdag t\<^sub>1 t\<^sub>2)"
 (*"subtree_eq Tip t = (if t = Tip then True else False)"
 "subtree_eq (Node l a r) t = (t=(Node l a r) \<or> subtree_eq l t \<or> subtree_eq r t)"*)
 
 primrec root :: "dag \<Rightarrow> ref"
 where
 "root Tip = Null" |
 "root (Node l a r) = a"
 
 fun isLeaf :: "dag \<Rightarrow> bool" where
 "isLeaf Tip = False"
 | "isLeaf (Node Tip v Tip) = True"
 | "isLeaf (Node (Node l v\<^sub>1 r) v\<^sub>2 Tip) = False"
 | "isLeaf (Node Tip v\<^sub>1 (Node l v\<^sub>2 r)) = False"
 
 datatype bdt = Zero | One | Bdt_Node bdt nat bdt
 
 fun bdt_fn :: "dag \<Rightarrow> (ref \<Rightarrow> nat) \<Rightarrow> bdt option" where
 "bdt_fn Tip = (\<lambda>bdtvar . None)"
 | "bdt_fn (Node Tip vref Tip) = 
     (\<lambda>bdtvar . 
           (if (bdtvar vref = 0) 
            then Some Zero 
            else (if (bdtvar vref = 1) 
                  then Some One
                  else None)))"  
 | "bdt_fn (Node Tip vref (Node l vref1 r)) = (\<lambda>bdtvar . None)"
 | "bdt_fn (Node (Node l vref1 r) vref Tip) = (\<lambda>bdtvar . None)"
 | "bdt_fn (Node (Node l1 vref1 r1) vref (Node l2 vref2 r2)) = 
   (\<lambda>bdtvar .
     (if (bdtvar vref = 0 \<or> bdtvar vref = 1) 
      then None 
      else  
       (case (bdt_fn (Node l1 vref1 r1) bdtvar) of 
        None \<Rightarrow> None
        |(Some b1) \<Rightarrow>
          (case (bdt_fn (Node l2 vref2 r2) bdtvar) of 
           None \<Rightarrow> None
          |(Some b2) \<Rightarrow> Some (Bdt_Node b1 (bdtvar vref) b2)))))"
 
 (*
 Kongruenzregeln sind das Feintuning für den Simplifier (siehe Kapitel 9 im Isabelle
 Tutorial). Im Fall von case wird standardmäßig nur die case bedingung nicht
 aber die einzelnen Fälle simplifiziert, analog dazu beim if. Dies simuliert die
 Auswertungsstrategie einer Programmiersprache, da wird auch zunächst nur die
 Bedingung vereinfacht. Will man mehr so kann man die entsprechenden Kongruenz 
 regeln dazunehmen.
 *)
 abbreviation "bdt == bdt_fn"
 
 primrec eval :: "bdt \<Rightarrow> bool list \<Rightarrow> bool"
 where
 "eval Zero env = False" |
 "eval One env  = True" |
 "eval (Bdt_Node l v r) env  = (if (env ! v) then eval r env else eval l env)"
  
 (*A given bdt is ordered if it is a One or Zero or its value is smaller than
 its parents value*)
 fun ordered_bdt:: "bdt \<Rightarrow> bool" where
 "ordered_bdt Zero = True"
 | "ordered_bdt One = True"
 | "ordered_bdt (Bdt_Node (Bdt_Node l1 v1 r1) v (Bdt_Node l2 v2 r2)) = 
     ((v1 < v) \<and> (v2 < v) \<and> 
      (ordered_bdt (Bdt_Node l1 v1 r1)) \<and> (ordered_bdt (Bdt_Node l2 v2 r2)))"
 | "ordered_bdt (Bdt_Node (Bdt_Node l1 v1 r1) v r) = 
     ((v1 < v) \<and> (ordered_bdt (Bdt_Node l1 v1 r1)))"
 | "ordered_bdt (Bdt_Node l v (Bdt_Node l2 v2 r2)) = 
     ((v2 < v) \<and> (ordered_bdt (Bdt_Node l2 v2 r2)))"
 | "ordered_bdt (Bdt_Node l v r) = True"
 
 (*In case t = (Node Tip v Tip) v should have the values 0 or 1. This is not checked by this function*)
 fun ordered:: "dag \<Rightarrow> (ref\<Rightarrow>nat) \<Rightarrow> bool" where
 "ordered Tip = (\<lambda> var. True)"
 | "ordered (Node (Node l\<^sub>1 v\<^sub>1 r\<^sub>1) v (Node l\<^sub>2 v\<^sub>2 r\<^sub>2)) = 
     (\<lambda> var. (var v\<^sub>1 < var v \<and> var v\<^sub>2 < var v) \<and> 
         (ordered (Node l\<^sub>1 v\<^sub>1 r\<^sub>1) var) \<and> (ordered (Node l\<^sub>2 v\<^sub>2 r\<^sub>2) var))"
 | "ordered (Node Tip v Tip) = (\<lambda> var. (True))"
 | "ordered (Node Tip v r) = 
      (\<lambda> var. (var (root r) < var v) \<and> (ordered r var))"
 | "ordered (Node l v Tip) = 
      (\<lambda> var. (var (root l) < var v) \<and> (ordered l var))"
  
 
 (*Calculates maximal value in a non ordered bdt. Does not test parents of the 
 given bdt*)
 primrec max_var :: "bdt \<Rightarrow> nat"
 where
 "max_var Zero = 0" |
 "max_var One = 1" |
 "max_var (Bdt_Node l v r) = max v (max (max_var l) (max_var r))"
 
 lemma eval_zero: "\<lbrakk>bdt (Node l v r) var = Some x; 
 var (root (Node l v r)) = (0::nat)\<rbrakk> \<Longrightarrow> x = Zero"
 apply (cases l)
 apply (cases r)
 apply simp
 apply simp
 apply (cases r)
 apply simp
 apply simp
 done
 
 lemma bdt_Some_One_iff [simp]: 
   "(bdt t var = Some One) = (\<exists> p. t = Node Tip p Tip \<and> var p = 1)"
 apply (induct t rule: bdt_fn.induct)
 apply (auto split: option.splits) (*in order to split the cases Zero and One*)
 done
 
 lemma bdt_Some_Zero_iff [simp]: 
   "(bdt t var = Some Zero) = (\<exists> p. t = Node Tip p Tip \<and> var p = 0)"
 apply (induct t rule: bdt_fn.induct)
 apply (auto split: option.splits)
 done
 
 
 lemma bdt_Some_Node_iff [simp]: 
  "(bdt t var = Some (Bdt_Node bdt1 v bdt2)) = 
     (\<exists> p l r. t = Node l p r \<and> bdt l var = Some bdt1 \<and> bdt r var = Some bdt2 \<and> 
                1 < v \<and> var p = v )"
 apply (induct t rule: bdt_fn.induct)
 prefer 5
 apply (fastforce split: if_splits option.splits)
 apply auto
 done
 
 lemma balanced_bdt: 
 "\<And> p bdt1. \<lbrakk> Dag p low high t; bdt t var = Some bdt1; no \<in> set_of t\<rbrakk> 
  \<Longrightarrow> (low no = Null) = (high no = Null)"
 proof (induct t)
   case Tip
   then show ?case by simp
 next
   case (Node lt a rt)
   note NN= this
   have bdt1: "bdt (Node lt a rt) var = Some bdt1" by fact
   have no_in_t: " no \<in> set_of (Node lt a rt)" by fact
   have p_tree: "Dag p low high (Node lt a rt)" by fact
   from Node.prems obtain 
     lt: "Dag (low p) low high lt" and 
     rt: "Dag (high p) low high rt" 
     by auto
   show ?case  
   proof (cases lt)
     case (Node llt l rlt)
     note Nlt=this
     show ?thesis
     proof (cases rt)
       case (Node lrt r rrt)
       note Nrt=this
       from Nlt Nrt bdt1 obtain lbdt rbdt where 
         lbdt_def: "bdt lt var = Some lbdt" and 
         rbdt_def: "bdt rt var = Some rbdt" and 
         bdt1_def: "bdt1 = Bdt_Node lbdt (var a) rbdt"
         by (auto split: if_split_asm option.splits)
       from no_in_t show ?thesis
       proof (simp, elim disjE)
         assume " no = a"
         with p_tree Nlt Nrt show ?thesis
           by auto
       next
         assume "no \<in> set_of lt"
         with Node.hyps lbdt_def lt show ?thesis
           by simp
       next
         assume "no \<in> set_of rt"
         with Node.hyps rbdt_def rt show ?thesis
           by simp
       qed
     next
       case Tip
       with Nlt bdt1 show ?thesis
         by simp
     qed
   next
     case Tip
     note ltTip=this
     show ?thesis
     proof (cases rt)
       case Tip
       with ltTip bdt1 no_in_t p_tree show ?thesis
         by auto
     next
       case (Node rlt r rrt)
       with bdt1 ltTip show ?thesis
         by simp
     qed
   qed
 qed
 
 primrec dag_map :: "(ref \<Rightarrow> ref) \<Rightarrow> dag \<Rightarrow> dag"
 where
 "dag_map f Tip = Tip" |
 "dag_map f (Node l a r) = (Node (dag_map f l) (f a) (dag_map f r))"
 
 
 definition wf_marking :: "dag \<Rightarrow> (ref \<Rightarrow> bool) \<Rightarrow> (ref \<Rightarrow> bool) \<Rightarrow> bool \<Rightarrow> bool"
 where
 "wf_marking t mark_old mark_new marked =
 (case t of Tip \<Rightarrow> mark_new = mark_old
 | (Node lt p rt) \<Rightarrow>
   (\<forall> n. n \<notin> set_of t \<longrightarrow> mark_new n = mark_old n) \<and>
   (\<forall> n. n \<in> set_of t \<longrightarrow> mark_new n = marked))"
 
 definition dag_in_levellist:: "dag \<Rightarrow> (ref list list) \<Rightarrow> (ref \<Rightarrow> nat) \<Rightarrow> bool"
 where "dag_in_levellist t levellist var = (t \<noteq> Tip \<longrightarrow>
        (\<forall> st. subdag_eq t st \<longrightarrow> root st \<in> set (levellist ! (var (root st)))))"
 
 lemma set_of_nn: "\<lbrakk> Dag p low high t; n \<in> set_of t\<rbrakk> \<Longrightarrow> n \<noteq> Null"
 apply (induct t)
 apply simp
 apply auto
 done
 
 lemma subnodes_ordered [rule_format]: 
 "\<forall>p. n \<in> set_of t \<longrightarrow> Dag p low high t \<longrightarrow> ordered t var \<longrightarrow> var n <= var p"
 apply (induct t)
 apply simp
 apply (intro allI)
 apply (erule_tac x="low p" in allE)
 apply (erule_tac x="high p" in allE)
 apply clarsimp
 apply (case_tac t1)
 apply (case_tac t2)
 apply simp
 apply fastforce
 apply (case_tac t2)
 apply fastforce
 apply fastforce
 done
 
 
 lemma ordered_set_of: 
 "\<And> x. \<lbrakk>ordered t var; x \<in> set_of t\<rbrakk> \<Longrightarrow> var x <= var (root t)"
 apply (induct t)
 apply simp
 apply simp
 apply (elim disjE)
 apply simp
 apply (case_tac t1)
 apply simp
 apply (case_tac t2)
 apply fastforce
 apply fastforce
 apply (case_tac t2)
 apply simp
 apply (case_tac t1)
 apply fastforce
 apply fastforce
 done
 
 lemma dag_setofD: "\<And> p low high n. \<lbrakk> Dag p low high t; n \<in> set_of t \<rbrakk> \<Longrightarrow> 
   (\<exists> nt. Dag n low high nt) \<and> (\<forall> nt. Dag n low high nt \<longrightarrow> set_of nt \<subseteq> set_of t)"
 apply (induct t)
 apply simp
 apply auto
 apply fastforce
 apply (fastforce dest: Dag_unique)
 apply (fastforce dest: Dag_unique)
 apply blast
 apply blast
 done
 
 lemma dag_setof_exD: "\<lbrakk>Dag p low high t; n \<in> set_of t\<rbrakk> \<Longrightarrow> \<exists> nt. Dag n low high nt"
 apply (simp add: dag_setofD)
 done
 
 lemma dag_setof_subsetD: "\<lbrakk>Dag p low high t; n \<in> set_of t; Dag n low high nt\<rbrakk> \<Longrightarrow> set_of nt \<subseteq> set_of t"
 apply (simp add: dag_setofD)
 done  
 
-lemma subdag_parentdag_low: "not <= lt \<Longrightarrow> not <= (Node lt p rt)"
+lemma subdag_parentdag_low: "not <= lt \<Longrightarrow> not <= (Node lt p rt)" for not
 apply (cases "not = lt")
 apply (cases lt)
 apply simp
 apply (cases rt)
 apply simp
 apply (simp add: le_dag_def less_dag_def)
 apply (simp add: le_dag_def less_dag_def)
 apply (simp add: le_dag_def less_dag_def)
 apply (simp add: le_dag_def less_dag_def)
 done
 
-lemma subdag_parentdag_high: "not <= rt \<Longrightarrow> not <= (Node lt p rt)"
+lemma subdag_parentdag_high: "not <= rt \<Longrightarrow> not <= (Node lt p rt)" for not
 apply (cases "not = rt")
 apply (cases lt)
 apply simp
 apply (cases rt)
 apply simp
 apply (simp add: le_dag_def less_dag_def)
 apply (simp add: le_dag_def less_dag_def)
 apply (simp add: le_dag_def less_dag_def)
 apply (simp add: le_dag_def less_dag_def)
 done
 
 lemma set_of_subdag: "\<And> p not no. 
 \<lbrakk>Dag p low high t; Dag no low high not; no \<in> set_of t\<rbrakk> \<Longrightarrow> not <= t"
 proof (induct t)
   case Tip
   then show ?case by simp
 next
   case (Node lt po rt)
   note rtNode=this
   from Node.prems have ppo: "p=po" 
     by simp
   show ?case
   proof (cases "no = p")
     case True
     with ppo Node.prems have "not = (Node lt po rt)"
       by (simp add: Dag_unique del: Dag_Ref)
     with Node.prems ppo show ?thesis by (simp add: subdag_eq_def)
   next
     assume " no \<noteq> p"
     with Node.prems have no_in_ltorrt: "no \<in> set_of lt \<or> no \<in> set_of rt"
       by simp
     show ?thesis
     proof (cases "no \<in> set_of lt")
       case True
       from Node.prems ppo have "Dag (low po) low high lt"
         by simp
       with Node.prems ppo True have "not <= lt"
         apply -
         apply (rule Node.hyps)
         apply assumption+
         done
       with Node.prems no_in_ltorrt show ?thesis
         apply -
         apply (rule subdag_parentdag_low)
         apply simp
         done
     next
       assume "no \<notin> set_of lt"
       with no_in_ltorrt have no_in_rt: "no \<in> set_of rt"
         by simp
       from Node.prems ppo have "Dag (high po) low high rt"
         by simp
       with Node.prems ppo no_in_rt have "not <= rt"
         apply -
         apply (rule Node.hyps)
         apply assumption+
         done
       with Node.prems no_in_rt show ?thesis
         apply -
         apply (rule subdag_parentdag_high)
         apply simp
         done
     qed
   qed
 qed
 
 lemma children_ordered: "\<lbrakk>ordered (Node lt p rt) var\<rbrakk> \<Longrightarrow> 
 ordered lt var \<and> ordered rt var"
 proof (cases lt)
   case Tip
   note ltTip=this
   assume  orderedNode: "ordered (Node lt p rt) var"
   show ?thesis
   proof (cases rt)
     case Tip
     note rtTip = this
     with ltTip show ?thesis
       by simp
   next
     case (Node lrt r rrt)
     with orderedNode ltTip show ?thesis
       by simp
   qed
 next
   case (Node llt l rlt)
   note ltNode=this
   assume orderedNode: "ordered (Node lt p rt) var"
   show ?thesis
   proof (cases rt)
     case Tip
     note rtTip = this
     with orderedNode ltNode show ?thesis by simp
   next
     case (Node lrt r rrt)
     note rtNode = this
     with orderedNode ltNode show ?thesis by simp
   qed
 qed
     
-lemma ordered_subdag: "\<lbrakk>ordered t var; not <= t\<rbrakk> \<Longrightarrow> ordered not var"
+lemma ordered_subdag: "\<lbrakk>ordered t var; not <= t\<rbrakk> \<Longrightarrow> ordered not var" for not
 proof (induct t)
   case Tip
   then show ?thesis by (simp add: less_dag_def le_dag_def)
 next
   case (Node lt p rt)
   show ?case 
   proof (cases "not = Node lt p rt")
     case True
     with Node.prems show ?thesis by simp
   next
     assume notnt: "not \<noteq> Node lt p rt"
     with Node.prems have notstltorrt: "not <= lt \<or> not <= rt"
       apply -
       apply (simp add: less_dag_def le_dag_def)
       apply fastforce
       done
     from Node.prems have ord_lt: "ordered lt var"
       apply -
       apply (drule children_ordered)
       apply simp
       done
     from Node.prems have ord_rt: "ordered rt var"
       apply -
       apply (drule children_ordered)
       apply simp
       done
     show ?thesis 
     proof (cases "not <= lt")
       case True
       with ord_lt show ?thesis
         apply -
         apply (rule Node.hyps)
         apply assumption+
         done
     next
       assume "\<not> not \<le> lt"
       with notstltorrt have notinrt: "not <= rt"
         by simp
       from Node.hyps have hyprt: "\<lbrakk>ordered rt var; not \<le> rt\<rbrakk> \<Longrightarrow> ordered not var" by simp
       from notinrt ord_rt show ?thesis
         apply -
         apply (rule hyprt)
         apply assumption+
         done
     qed
   qed
 qed
 
 
 lemma subdag_ordered: 
 "\<And> not no p. \<lbrakk>ordered t var; Dag p low high t; Dag no low high not; 
               no \<in> set_of t\<rbrakk> \<Longrightarrow> ordered not var"
 proof (induct t) 
   case Tip
   from Tip.prems show ?case by simp
 next
   case (Node lt po rt)
   note nN=this
   show ?case 
   proof (cases lt)
     case Tip
     note ltTip=this
     show ?thesis
     proof (cases rt)
       case Tip
       from Node.prems have ppo: "p=po"
         by simp
       from Tip ltTip Node.prems have "no=p"
         by simp
       with ppo Node.prems have "not=(Node lt po rt)"
         by (simp del: Dag_Ref add: Dag_unique)
       with Node.prems show ?thesis by simp
     next
       case (Node lrnot rn rrnot)
       from Node.prems ltTip Node have ord_rt: "ordered rt var"
         by simp
       from Node.prems have ppo: "p=po"
         by simp
       from Node.prems have ponN: "po \<noteq> Null"
         by auto
       with ppo ponN ltTip Node.prems have *: "Dag (high po) low high rt"
         by auto
       show ?thesis
       proof (cases "no=po")
         case True
         with ppo Node.prems have "not = Node lt po rt"
           by (simp del: Dag_Ref add: Dag_unique)
         with Node.prems show ?thesis
           by simp
       next
         case False
         with Node.prems ltTip have "no \<in> set_of rt" 
           by simp
         with ord_rt * \<open>Dag no low high not\<close> show ?thesis
           by (rule Node.hyps)
       qed
     qed
   next
     case (Node llt l rlt)
     note ltNode=this
     show ?thesis
     proof (cases rt)
       case Tip
       from Node.prems Tip ltNode have ord_lt: "ordered lt var"
         by simp
       from Node.prems have ppo: "p=po"
         by simp
       from Node.prems have ponN: "po \<noteq> Null"
         by auto
       with ppo ponN Tip Node.prems ltNode have *: "Dag (low po) low high lt"
         by auto
       show ?thesis
       proof (cases "no=po")
         case True
         with ppo Node.prems have "not = (Node lt po rt)"
           by (simp del: Dag_Ref add: Dag_unique)
         with Node.prems show ?thesis by simp
       next
         case False
         with Node.prems Tip have "no \<in> set_of lt" 
           by simp
         with ord_lt * \<open>Dag no low high not\<close> show ?thesis
           by (rule Node.hyps)
       qed   
     next
       case (Node lrt r rrt)
       from Node.prems have ppo: "p=po"
         by simp
       from Node.prems Node ltNode have ord_lt: "ordered lt var"
         by simp
       from Node.prems Node ltNode have ord_rt: "ordered rt var"
         by simp
       from Node.prems have ponN: "po \<noteq> Null"
         by auto
       with ppo ponN Node Node.prems ltNode have lt_Dag: "Dag (low po) low high lt"
         by auto
       with ppo ponN Node Node.prems ltNode have rt_Dag: "Dag (high po) low high rt"
         by auto
       show ?thesis
       proof (cases "no = po")
        case True
         with ppo Node.prems have "not = (Node lt po rt)"
           by (simp del: Dag_Ref add: Dag_unique)
         with Node.prems show ?thesis by simp
       next
         assume "no \<noteq> po"
         with Node.prems have no_in_lt_or_rt: "no \<in> set_of lt \<or> no \<in> set_of rt"
           by simp
         show ?thesis 
         proof (cases "no \<in> set_of lt")
           case True
           with ord_lt lt_Dag Node.prems show ?thesis
             apply -
             apply (rule Node.hyps)
             apply assumption+
             done
         next
           assume " no \<notin> set_of lt"
           with no_in_lt_or_rt have no_in_rt: "no \<in> set_of rt"
             by simp
           from Node.hyps have hyp2: 
             "\<And>p no not. \<lbrakk>ordered rt var; Dag p low high rt; Dag no low high not; no \<in> set_of rt\<rbrakk> 
             \<Longrightarrow> ordered not var"
             apply -
             apply assumption
             done
           from no_in_rt ord_rt rt_Dag Node.prems show ?thesis
             apply -
             apply (rule hyp2)
             apply assumption+
             done
         qed
       qed
     qed
   qed
 qed
 
 lemma elem_set_of: "\<And> x st. \<lbrakk>x \<in> set_of st; set_of st \<subseteq> set_of t\<rbrakk> \<Longrightarrow> x \<in> set_of t"
 by blast
 
 
 (*procedure Levellist converts a dag with root p in a ref list list (levellist) with nodes of var = i in 
 levellist ! i. 
 In order to convert the two datastructures a dag traversal is required using a mark on nodes. m indicates
 the value which is assumed for a node to be marked. 
 (\<exists> nt. Dag n \<^bsup>\<sigma>\<^esup>low \<^bsup>\<sigma>\<^esup>high nt \<and> 
                         {\<^bsup>\<sigma>\<^esup>m} = set_of (dag_map \<^bsup>\<sigma>\<^esup>mark nt))*)
 
 definition wf_ll :: "dag \<Rightarrow> ref list list \<Rightarrow> (ref \<Rightarrow> nat) \<Rightarrow> bool"
 where
 "wf_ll t levellist var =
   ((\<forall>p. p \<in> set_of t \<longrightarrow> p \<in> set (levellist ! var p)) \<and>
    (\<forall>k < length levellist. \<forall>p \<in> set (levellist ! k). p \<in> set_of t \<and> var p = k))"
 
 definition cong_eval :: "bdt \<Rightarrow> bdt \<Rightarrow> bool" (infix "\<sim>" 60)
   where "cong_eval bdt\<^sub>1 bdt\<^sub>2 = (eval bdt\<^sub>1 = eval bdt\<^sub>2)"
 
 lemma cong_eval_sym: "l \<sim> r = r \<sim> l"
   by (auto simp add: cong_eval_def)
 
 lemma cong_eval_trans: "\<lbrakk> l \<sim> r; r \<sim> t\<rbrakk> \<Longrightarrow> l \<sim> t"
   by (simp add: cong_eval_def)
 
 lemma cong_eval_child_high: " l \<sim> r \<Longrightarrow> r \<sim> (Bdt_Node l v r)"
   apply (simp add: cong_eval_def )
   apply (rule ext)
   apply auto
   done
 
 lemma cong_eval_child_low: " l \<sim> r \<Longrightarrow> l \<sim> (Bdt_Node l v r)"
   apply (simp add: cong_eval_def )
   apply (rule ext)
   apply auto
   done
 
 
 
 
 definition null_comp :: "(ref \<Rightarrow> ref) \<Rightarrow> (ref \<Rightarrow> ref) \<Rightarrow> (ref \<Rightarrow> ref)" (infix "\<propto>" 60)
   where "null_comp a b = (\<lambda> p. (if (b p) = Null then Null else ((a \<circ> b) p)))"
 
 lemma null_comp_not_Null [simp]: "h q \<noteq> Null \<Longrightarrow> (g \<propto> h) q = g (h q)"
   by (simp add: null_comp_def)
 
 lemma id_trans: "(a \<propto> id) (b (c p)) = (a \<propto> b) (c p)"
   by (simp add: null_comp_def)
 
 definition Nodes :: "nat \<Rightarrow> ref list list \<Rightarrow> ref set"
   where "Nodes i levellist = (\<Union>k\<in>{k. k < i} . set (levellist ! k))"
 
 
 inductive_set Dags :: "ref set \<Rightarrow> (ref \<Rightarrow> ref) \<Rightarrow> (ref \<Rightarrow> ref) \<Rightarrow> dag set"
   for "nodes" "low" "high"
 where
   DagsI: "\<lbrakk> set_of t \<subseteq>  nodes; Dag p low high t; t \<noteq> Tip\<rbrakk> 
            \<Longrightarrow> t \<in> Dags nodes low high"
 
 lemma empty_Dags [simp]: "Dags {} low high = {}"
   apply rule
   apply rule
   apply (erule Dags.cases)
   apply (case_tac t)
   apply simp
   apply simp
   apply rule
   done
 
 definition isLeaf_pt :: "ref \<Rightarrow> (ref \<Rightarrow> ref) \<Rightarrow> (ref \<Rightarrow> ref) \<Rightarrow> bool"
   where "isLeaf_pt p low high = (low p = Null \<and> high p = Null)"
 
 definition repNodes_eq :: "ref \<Rightarrow> ref \<Rightarrow> (ref \<Rightarrow> ref) \<Rightarrow> (ref \<Rightarrow> ref) \<Rightarrow> (ref \<Rightarrow> ref) \<Rightarrow> bool"
 where
  "repNodes_eq p q low high rep == 
       (rep \<propto> high) p = (rep \<propto> high) q \<and> (rep \<propto> low) p = (rep \<propto> low) q"
 
 definition isomorphic_dags_eq :: "dag \<Rightarrow> dag \<Rightarrow> (ref \<Rightarrow> nat) \<Rightarrow> bool"
 where
 "isomorphic_dags_eq st\<^sub>1 st\<^sub>2 var =
     (\<forall>bdt\<^sub>1 bdt\<^sub>2. (bdt st\<^sub>1 var = Some bdt\<^sub>1 \<and> bdt st\<^sub>2 var = Some bdt\<^sub>2 \<and> (bdt\<^sub>1 = bdt\<^sub>2))
                  \<longrightarrow> st\<^sub>1 = st\<^sub>2)"
 
 lemma isomorphic_dags_eq_sym: "isomorphic_dags_eq st\<^sub>1 st\<^sub>2 var = isomorphic_dags_eq st\<^sub>2 st\<^sub>1  var"
   by (auto simp add: isomorphic_dags_eq_def)
 
 
 (*consts subdags_shared :: "dag \<Rightarrow> dag \<Rightarrow> (ref \<Rightarrow> nat) \<Rightarrow> bool"
 defs subdags_shared_def : "subdags_shared t1 t2 var == \<forall> st1 st2. (st1 <= t1 \<and> st2 <= t2) \<longrightarrow> shared_prop st1 st2 var"
 
 consts shared :: " dag \<Rightarrow> dag \<Rightarrow> (ref \<Rightarrow> nat) \<Rightarrow> bool"
 defs shared_def: "shared t1 t2 var == subdags_shared t1 t1 var \<and> subdags_shared t2 t2 var \<and> subdags_shared t1 t2 var"*)
 
 definition shared :: "dag \<Rightarrow> (ref \<Rightarrow> nat) \<Rightarrow> bool"
   where "shared t var = (\<forall>st\<^sub>1 st\<^sub>2. (st\<^sub>1 <= t \<and> st\<^sub>2 <= t) \<longrightarrow> isomorphic_dags_eq st\<^sub>1 st\<^sub>2 var)"
 
 (* shared returns True if the Dag has no different subdags which represent the same 
 bdts. 
 Note: The two subdags can have different references and code the same bdt nevertheless!
 consts shared :: "dag \<Rightarrow> (ref \<Rightarrow> nat) \<Rightarrow> bool"
 defs shared_def: "shared t bdtvar \<equiv> \<forall> st1 st2. (subdag t st1 \<and> subdag t st2 \<and> 
                        (bdt st1 bdtvar = bdt st2 bdtvar \<longrightarrow> st1 = st2))"
 
 consts shared_lower_levels :: "dag \<Rightarrow> nat \<Rightarrow> (ref \<Rightarrow> nat) \<Rightarrow> bool"
 defs shared_lower_levels_def : "shared_lower_levels t i bdtvar == \<forall> st1 st2. (st1 < t \<and> st2 < t \<and> bdtvar (root st1) < i \<and> bdtvar (root st2) < i \<and>
                                     (bdt st1 bdtvar = bdt st2 bdtvar \<longrightarrow> st1 = st2))"
 *)
 
 
 fun reduced :: "dag \<Rightarrow> bool" where
   "reduced Tip = True"
 | "reduced (Node Tip v Tip) = True"
 | "reduced (Node l v r) = (l \<noteq> r \<and> reduced l \<and> reduced r)"  
 
 primrec reduced_bdt :: "bdt \<Rightarrow> bool"
 where
   "reduced_bdt Zero = True"
 | "reduced_bdt One = True"
 | "reduced_bdt (Bdt_Node lbdt v rbdt) =
     (if lbdt = rbdt then False 
      else (reduced_bdt lbdt \<and> reduced_bdt rbdt))"
 
 
 lemma replicate_elem: "i < n ==>  (replicate n x !i) = x"
 apply (induct n)
 apply simp
 apply (cases i)
 apply auto
 done
 
 lemma no_in_one_ll: 
  "\<lbrakk>wf_ll pret levellista var; i<length levellista; j < length levellista; 
    no \<in> set (levellista ! i); i\<noteq>j\<rbrakk> 
   \<Longrightarrow> no \<notin> set (levellista ! j) "
 apply (unfold wf_ll_def)
 apply (erule conjE)
 apply (rotate_tac 5)
 apply (frule_tac x = i and ?R= "no \<in> set_of pret \<and> var no = i" in allE)
 apply (erule impE)
 apply simp
 apply (rotate_tac 6)
 apply (erule_tac x=no in ballE)
 apply assumption
 apply simp
 apply (cases "no \<notin> set (levellista ! j)")
 apply assumption
 apply (erule_tac x=j in allE)
 apply (erule impE)
 apply assumption
 apply (rotate_tac 7)
 apply (erule_tac x=no in ballE)
 prefer 2
 apply assumption
 apply (elim conjE)
 apply (thin_tac "\<forall>q. q \<in> set_of pret \<longrightarrow> q \<in> set (levellista ! var q)")
 apply fastforce
 done
 
 lemma nodes_in_wf_ll: 
 "\<lbrakk>wf_ll pret levellista var; i < length levellista;  no \<in> set (levellista ! i)\<rbrakk> 
  \<Longrightarrow> var no = i \<and> no \<in> set_of pret"
 apply (simp add: wf_ll_def)
 done
 
 lemma subelem_set_of_low: 
 "\<And> p. \<lbrakk> x \<in> set_of t; x \<noteq> Null; low x \<noteq> Null; Dag p low high t \<rbrakk> 
  \<Longrightarrow> (low x) \<in> set_of t"
 proof (induct t)
   case Tip
   then show ?case by simp
 next
   case (Node lt po rt)
   note tNode=this
   then have ppo: "p=po" by simp
   show ?case
   proof (cases "x=p")
     case True
     with Node.prems have lxrootlt: "low x = root lt"
     proof (cases lt)
       case Tip
       with True Node.prems show ?thesis
         by auto
     next
       case (Node llt l rlt)
       with Node.prems True show ?thesis
         by auto
     qed
     with True Node.prems have "low x \<in> set_of (Node lt p rt)"
     proof (cases lt)
       case Tip
       with lxrootlt Node.prems show ?thesis 
         by simp
     next
       case (Node llt l rlt)
       with lxrootlt Node.prems show ?thesis
         by simp
     qed
     with ppo show ?thesis
       by simp
   next
     assume xnp: " x \<noteq> p"  
     with Node.prems have "x \<in> set_of lt \<or> x \<in> set_of rt" 
       by simp
     show ?thesis
     proof (cases "x \<in> set_of lt")
       case True
       note xinlt=this
       from Node.prems have "Dag (low p) low high lt" 
         by fastforce
       with Node.prems True have "low x \<in> set_of lt"
         apply -
         apply (rule Node.hyps)
         apply assumption+
         done
       with Node.prems show ?thesis
         by auto
     next
       assume xnotinlt: " x \<notin> set_of lt"
       with xnp Node.prems have xinrt: "x \<in> set_of rt"
         by simp
       from Node.prems have "Dag (high p) low high rt" 
         by fastforce
       with Node.prems xinrt have "low x \<in> set_of rt"
         apply -
         apply (rule Node.hyps)
         apply assumption+
         done
       with Node.prems show ?thesis
         by auto
     qed
   qed
 qed
       
 lemma subelem_set_of_high: 
 "\<And> p. \<lbrakk> x \<in> set_of t; x \<noteq> Null; high x \<noteq> Null; Dag p low high t \<rbrakk> 
  \<Longrightarrow> (high x) \<in> set_of t"
 proof (induct t)
   case Tip
   then show ?case by simp
 next
   case (Node lt po rt)
   note tNode=this
   then have ppo: "p=po" by simp
   show ?case
   proof (cases "x=p")
     case True
     with Node.prems have lxrootlt: "high x = root rt"
     proof (cases rt)
       case Tip
       with True Node.prems show ?thesis
         by auto
     next
       case (Node lrt l rrt)
       with Node.prems True show ?thesis
         by auto
     qed
     with True Node.prems have "high x \<in> set_of (Node lt p rt)"
     proof (cases rt)
       case Tip
       with lxrootlt Node.prems show ?thesis 
         by simp
     next
       case (Node lrt l rrt)
       with lxrootlt Node.prems show ?thesis
         by simp
     qed
     with ppo show ?thesis
       by simp
   next
     assume xnp: " x \<noteq> p"  
     with Node.prems have "x \<in> set_of lt \<or> x \<in> set_of rt" 
       by simp
     show ?thesis
     proof (cases "x \<in> set_of lt")
       case True
       note xinlt=this
       from Node.prems have "Dag (low p) low high lt" 
         by fastforce
       with Node.prems True have "high x \<in> set_of lt"
         apply -
         apply (rule Node.hyps)
         apply assumption+
         done
       with Node.prems show ?thesis
         by auto
     next
       assume xnotinlt: " x \<notin> set_of lt"
       with xnp Node.prems have xinrt: "x \<in> set_of rt"
         by simp
       from Node.prems have "Dag (high p) low high rt" 
         by fastforce
       with Node.prems xinrt have "high x \<in> set_of rt"
         apply -
         apply (rule Node.hyps)
         apply assumption+
         done
       with Node.prems show ?thesis
         by auto
     qed
   qed
 qed        
 
 lemma set_split: "{k. k<(Suc n)} = {k. k<n} \<union> {n}"
 apply auto
 done
 
 
 lemma Nodes_levellist_subset_t: 
 "\<lbrakk>wf_ll t levellist var; i<= length levellist\<rbrakk> \<Longrightarrow> Nodes i levellist \<subseteq> set_of t"
 proof (induct i)
   case 0
   show ?case by (simp add: Nodes_def)
 next
   case (Suc n)
   from Suc.prems Suc.hyps have Nodesn_in_t: "Nodes n levellist \<subseteq> set_of t"
     by simp
   from Suc.prems have "\<forall> x \<in> set (levellist ! n). x \<in> set_of t"
     apply -
     apply (rule ballI)
     apply (simp add: wf_ll_def)
     apply (erule conjE)
     apply (thin_tac " \<forall>q. q \<in> set_of t \<longrightarrow> q \<in> set (levellist ! var q)")
     apply (erule_tac x=n in allE)
     apply (erule impE)
     apply simp
     apply fastforce
     done
   with Suc.prems have "set (levellist ! n) \<subseteq> set_of t"
     apply blast
     done
   with Suc.prems Nodesn_in_t show ?case 
     apply (simp add: Nodes_def)
     apply (simp add: set_split)
     done
 qed
 
 lemma bdt_child: 
 "\<lbrakk> bdt (Node (Node llt l rlt) p (Node lrt r rrt)) var = Some bdt1\<rbrakk> 
  \<Longrightarrow> \<exists> lbdt rbdt.  bdt (Node llt l rlt) var = Some lbdt \<and> 
                    bdt (Node lrt r rrt) var = Some rbdt"
   by (simp split: option.splits)
 
 
 lemma subbdt_ex_dag_def: 
 "\<And> bdt1 p. \<lbrakk>Dag p low high t; bdt t var = Some bdt1; Dag no low high not; 
-no \<in> set_of t\<rbrakk> \<Longrightarrow> \<exists> bdt2.  bdt not var = Some bdt2"
+no \<in> set_of t\<rbrakk> \<Longrightarrow> \<exists> bdt2.  bdt not var = Some bdt2" for not
 proof (induct t)
   case Tip
   then show ?case by simp
 next
   case (Node lt po rt)
   note pNode=this
   with Node.prems have p_po: "p=po" by simp
   show ?case 
   proof (cases "no = po")
     case True
     note no_eq_po=this
     from p_po Node.prems no_eq_po have "not = (Node lt po rt)" by (simp add: Dag_unique del: Dag_Ref)
     with Node.prems have "bdt not var = Some bdt1" by (simp add: le_dag_def)
     then show ?thesis by simp
   next
     assume "no \<noteq> po"
     with Node.prems have no_in_lt_or_rt: "no \<in> set_of lt \<or> no \<in> set_of rt" by simp
     show ?thesis
     proof (cases "no \<in> set_of lt")
       case True
       note no_in_lt=this
       from Node.prems p_po have lt_dag: "Dag (low po) low high lt" by simp
       from Node.prems have lbdt_def: "\<exists> lbdt. bdt lt var = Some lbdt"
       proof (cases lt)
         case Tip
         with Node.prems no_in_lt show ?thesis by (simp add: le_dag_def)
       next
         case (Node llt l rlt)
         note lNode=this
         show ?thesis
         proof (cases rt)
           case Tip
           note rNode=this
           with lNode Node.prems show ?thesis by simp
         next 
           case (Node lrt r rrt)
           note rNode=this
           with lNode Node.prems show ?thesis by (simp split: option.splits)
         qed
       qed
       then obtain lbdt where "bdt lt var = Some lbdt"..
       with Node.prems lt_dag no_in_lt show ?thesis
         apply -
         apply (rule Node.hyps)
         apply assumption+
         done
     next
       assume "no \<notin> set_of lt"
       with no_in_lt_or_rt have no_in_rt: "no \<in> set_of rt" by simp
       from Node.prems p_po have rt_dag: "Dag (high po) low high rt" by simp
       from Node.hyps have hyp2: "\<And> rbdt. \<lbrakk>Dag (high po) low high rt; bdt rt var = Some rbdt; Dag no low high not; no \<in> set_of rt\<rbrakk> \<Longrightarrow> \<exists>bdt2. bdt not var = Some bdt2"
         by simp
       from Node.prems have lbdt_def: "\<exists> rbdt. bdt rt var = Some rbdt"
       proof (cases rt)
         case Tip
         with Node.prems no_in_rt show ?thesis by (simp add: le_dag_def)
       next
         case (Node lrt l rrt)
         note rNode=this
         show ?thesis
         proof (cases lt)
           case Tip
           note lTip=this
           with rNode Node.prems show ?thesis by simp
         next 
           case (Node llt r rlt)
           note lNode=this
           with rNode Node.prems show ?thesis by (simp split: option.splits)
         qed
       qed
       then obtain rbdt where "bdt rt var = Some rbdt"..
       with Node.prems rt_dag no_in_rt show ?thesis
         apply -
         apply (rule hyp2)
         apply assumption+
         done
     qed
   qed
 qed
       
 lemma subbdt_ex: 
 "\<And> bdt1. \<lbrakk> (Node lst stp rst) <= t; bdt t var = Some bdt1\<rbrakk> 
  \<Longrightarrow> \<exists> bdt2.  bdt (Node lst stp rst) var = Some bdt2"
 proof (induct t)
   case Tip
   then show ?case by (simp add: le_dag_def)
 next 
   case (Node lt p rt)
   note pNode=this
   show ?case
   proof (cases "Node lst stp rst = Node lt p rt")
     case True
     with Node.prems show ?thesis by simp
   next
     assume " Node lst stp rst \<noteq> Node lt p rt"
     with Node.prems have "Node lst stp rst < Node lt p rt" apply (simp add: le_dag_def) apply auto done
     then have in_ltrt: "Node lst stp rst <= lt \<or> Node lst stp rst <= rt" 
       by (simp add: less_dag_Node)
     show ?thesis
     proof (cases "Node lst stp rst <= lt")
       case True 
       note in_lt=this
       from Node.prems have lbdt_def: "\<exists> lbdt. bdt lt var = Some lbdt"
       proof (cases lt)
         case Tip
         with Node.prems in_lt show ?thesis by (simp add: le_dag_def)
       next
         case (Node llt l rlt)
         note lNode=this
         show ?thesis
         proof (cases rt)
           case Tip
           note rNode=this
           with lNode Node.prems show ?thesis by simp
         next 
           case (Node lrt r rrt)
           note rNode=this
           with lNode Node.prems show ?thesis by (simp split: option.splits)
         qed
       qed
       then obtain lbdt where "bdt lt var = Some lbdt"..
       with Node.prems in_lt show ?thesis
         apply -
         apply (rule Node.hyps)
         apply assumption+
         done
     next
       assume " \<not> Node lst stp rst \<le> lt"
       with in_ltrt have in_rt: "Node lst stp rst <= rt" by simp
       from Node.hyps have hyp2: "\<And> rbdt. \<lbrakk>Node lst stp rst <= rt; bdt rt var = Some rbdt\<rbrakk> \<Longrightarrow> \<exists>bdt2. bdt (Node lst stp rst) var = Some bdt2"
         by simp
       from Node.prems have rbdt_def: "\<exists> rbdt. bdt rt var = Some rbdt"
       proof (cases rt)
         case Tip
         with Node.prems in_rt show ?thesis by (simp add: le_dag_def)
       next
         case (Node lrt l rrt)
         note rNode=this
         show ?thesis
         proof (cases lt)
           case Tip
           note lNode=this
           with rNode Node.prems show ?thesis by simp
         next 
           case (Node lrt r rrt)
           note lNode=this
           with rNode Node.prems show ?thesis by (simp split: option.splits)
         qed
       qed
       then obtain rbdt where "bdt rt var = Some rbdt"..
       with Node.prems in_rt show ?thesis
         apply -
         apply (rule hyp2)
         apply assumption+
         done
     qed
   qed
 qed
 
 
 lemma var_ordered_children: 
 "\<And> p. \<lbrakk> Dag p low high t; ordered t var; no \<in> set_of t; 
         low no \<noteq> Null; high no \<noteq> Null\<rbrakk> 
        \<Longrightarrow> var (low no) < var no \<and> var (high no) < var no"
 proof (induct t)
   case Tip
   then show ?case by simp
 next
   case (Node lt po rt)
   then have ppo: "p=po" by simp
   show ?case
   proof (cases "no = po")
     case True
     note no_po=this
     from Node.prems have "var (low po) < var po \<and> var (high po) < var po" 
     proof (cases lt)
       case Tip
       note ltTip=this
       with Node.prems no_po ppo show ?thesis by simp
     next
       case (Node llt l rlt)
       note lNode=this
       show ?thesis
       proof (cases rt)
         case Tip
         note rTip=this
         with Node.prems no_po ppo show ?thesis by simp
       next
         case (Node lrt r rrt)
         note rNode=this
         with Node.prems ppo no_po lNode  show ?thesis by (simp del: Dag_Ref) 
       qed
     qed
     with no_po show ?thesis by simp
   next
     assume " no \<noteq> po"
     with Node.prems have no_in_ltrt: "no \<in> set_of lt \<or> no \<in> set_of rt"
       by simp
     show ?thesis
     proof (cases "no \<in> set_of lt")
       case True
       note no_in_lt=this
       from Node.prems ppo have lt_dag: "Dag (low po) low high lt" 
         by simp
       from Node.prems have ord_lt: "ordered lt var"
         apply -
         apply (drule children_ordered)
         apply simp
         done
       from no_in_lt lt_dag ord_lt Node.prems show ?thesis
         apply -
         apply (rule Node.hyps)
         apply assumption+
         done
     next
       assume " no \<notin> set_of lt"
       with no_in_ltrt have no_in_rt: "no \<in> set_of rt" by simp
       from Node.prems ppo have rt_dag: "Dag (high po) low high rt" by simp
       from Node.hyps have hyp2: " \<lbrakk>Dag (high po) low high rt; ordered rt var; no \<in> set_of rt; low no \<noteq> Null; high no \<noteq> Null\<rbrakk>
                                   \<Longrightarrow> var (low no) < var no \<and> var (high no) < var no"
         by simp
       from Node.prems have ord_rt: "ordered rt var"
         apply -
         apply (drule children_ordered)
         apply simp
         done
       from rt_dag ord_rt no_in_rt Node.prems show ?thesis
         apply -
         apply (rule hyp2)
         apply assumption+
         done
     qed
   qed
 qed
 
 lemma nort_null_comp:
 assumes pret_dag: "Dag p low high pret" and
         prebdt_pret: "bdt pret var = Some prebdt" and
         nort_dag: "Dag (repc no) (repb \<propto> low) (repb \<propto> high) nort" and
         ord_pret: "ordered pret var" and
         wf_llb: "wf_ll pret levellistb var" and
         nbsll: "nb < length levellistb" and
         repbc_nc: "\<forall> nt. nt \<notin> set (levellistb ! nb) \<longrightarrow> repb nt = repc nt" and
         xsnb_in_pret: "\<forall> x \<in> set_of nort. var x < nb \<and> x \<in> set_of pret"
 shows "\<forall> x \<in> set_of nort. ((repc \<propto> low) x = (repb \<propto> low) x \<and> 
                            (repc \<propto> high) x = (repb \<propto> high) x)" 
 proof (rule ballI)
   fix x
   assume x_in_nort: "x \<in> set_of nort"
   with nort_dag have xnN: "x \<noteq> Null"
     apply -
     apply (rule set_of_nn [rule_format])
     apply auto
     done
   from x_in_nort xsnb_in_pret have xsnb: "var x <nb"
     by simp
   from x_in_nort xsnb_in_pret have x_in_pret: "x \<in> set_of pret"
     by blast
   show " (repc \<propto> low) x = (repb \<propto> low) x \<and> (repc \<propto> high) x = (repb \<propto> high) x"
   proof (cases "(low x) \<noteq> Null")
     case True
     with pret_dag prebdt_pret x_in_pret have highnN: "(high x) \<noteq> Null"
       apply -
       apply (drule balanced_bdt)
       apply assumption+
       apply simp
       done
     from x_in_pret ord_pret highnN True have children_var_smaller: "var (low x) < var x \<and> var (high x) < var x"
       apply -
       apply (rule var_ordered_children)
       apply (rule pret_dag)
       apply (rule ord_pret)
       apply (rule x_in_pret)
       apply (rule True)
       apply (rule highnN)
       done
     with xsnb have lowxsnb: "var (low x) < nb"
       by arith
     from children_var_smaller xsnb have highxsnb: "var (high x) < nb"
       by arith
     from x_in_pret xnN True pret_dag have lowxinpret: "(low x) \<in> set_of pret"
       apply -
       apply (drule subelem_set_of_low)
       apply assumption
       apply (thin_tac "x \<noteq> Null")
       apply assumption+
       done
     with wf_llb have "low x \<in> set (levellistb ! (var (low x)))" 
       by (simp add: wf_ll_def)
     with wf_llb nbsll lowxsnb have "low x \<notin> set (levellistb ! nb)"
       apply -
       apply (rule_tac ?i="(var (low x))" and ?j=nb in no_in_one_ll)
       apply auto
       done
     with repbc_nc have repclow: "repc (low x) = repb (low x)"
       by auto
     from x_in_pret xnN highnN pret_dag have highxinpret: "(high x) \<in> set_of pret"
       apply -
       apply (drule subelem_set_of_high)
       apply assumption
       apply (thin_tac "x \<noteq> Null")
       apply assumption+
       done
     with wf_llb have "high x \<in> set (levellistb ! (var (high x)))" 
       by (simp add: wf_ll_def)
     with wf_llb nbsll highxsnb have "high x \<notin> set (levellistb ! nb)"
       apply -
       apply (rule_tac ?i="(var (high x))" and ?j=nb in no_in_one_ll)
       apply auto
       done
     with repbc_nc have repchigh: "repc (high x) = repb (high x)"
       by auto
     with repclow show ?thesis 
       by (simp add: null_comp_def)
   next
     assume " \<not> low x \<noteq> Null"
     then have lowxNull: "low x = Null" by simp
     with pret_dag x_in_pret prebdt_pret have highxNull: "high x =Null" 
       apply -
       apply (drule balanced_bdt)
       apply simp
       apply simp
       apply simp
       done
     from lowxNull have repclowNull: "(repc \<propto> low) x = Null"
       by (simp add: null_comp_def)
     from lowxNull have repblowNull: "(repb \<propto> low) x = Null"
       by (simp add: null_comp_def)
     with repclowNull have lowxrepbc: "(repc \<propto> low) x = (repb \<propto> low) x"
       by simp
     from highxNull have repchighNull: "(repc \<propto> high) x = Null"
       by (simp add: null_comp_def)
     from highxNull have "(repb \<propto> high) x = Null"
       by (simp add: null_comp_def)
     with repchighNull have highxrepbc: "(repc \<propto> high) x = (repb \<propto> high) x"
       by simp
     with lowxrepbc show ?thesis
       by simp
   qed
 qed         
 
 lemma wf_ll_Nodes_pret: 
 "\<lbrakk>wf_ll pret levellista var; nb < length levellista; x \<in> Nodes nb levellista\<rbrakk> 
  \<Longrightarrow> x \<in> set_of pret \<and> var x < nb"
   apply (simp add: wf_ll_def Nodes_def)
   apply (erule conjE)
   apply (thin_tac " \<forall>q. q \<in> set_of pret \<longrightarrow> q \<in> set (levellista ! var q)")
   apply (erule exE)
   apply (elim conjE)
   apply (erule_tac x=xa in allE)
   apply (erule impE)
   apply arith
   apply (erule_tac x=x in ballE)
   apply auto
   done
 
 lemma bdt_Some_var1_One: 
 "\<And> x. \<lbrakk> bdt t var = Some x; var (root t) = 1\<rbrakk> 
  \<Longrightarrow> x = One \<and> t = (Node Tip (root t) Tip)"
 proof (induct t)
   case Tip
   then show  ?case by simp
 next
   case (Node lt p rt)
   note tNode = this
   show ?case 
   proof (cases lt)
     case Tip
     note ltTip=this
     show ?thesis
     proof (cases rt)
       case Tip
       note rtTip = this
       with ltTip Node.prems show ?thesis by auto
     next
       case (Node lrt r rrt)
       note rtNode=this
       with Node.prems ltTip show ?thesis by auto
     qed
   next
     case (Node llt l rlt)
     note ltNode=this
     show ?thesis
     proof (cases rt)
       case Tip
       with ltNode Node.prems show ?thesis by auto
     next
       case (Node lrt r rrt)
       note rtNode=this
       with ltNode Node.prems show ?thesis by auto
     qed
   qed
 qed
 
 lemma bdt_Some_var0_Zero: 
 "\<And> x. \<lbrakk> bdt t var = Some x; var (root t) = 0\<rbrakk> 
 \<Longrightarrow> x = Zero \<and> t = (Node Tip (root t) Tip)"
 proof (induct t)
   case Tip
   then show  ?case by simp
 next
   case (Node lt p rt)
   note tNode = this
   show ?case 
   proof (cases lt)
     case Tip
     note ltTip=this
     show ?thesis
     proof (cases rt)
       case Tip
       note rtTip = this
       with ltTip Node.prems show ?thesis by auto
     next
       case (Node lrt r rrt)
       note rtNode=this
       with Node.prems ltTip show ?thesis by auto
     qed
   next
     case (Node llt l rlt)
     note ltNode=this
     show ?thesis
     proof (cases rt)
       case Tip
       with ltNode Node.prems show ?thesis by auto
     next
       case (Node lrt r rrt)
       note rtNode=this
       with ltNode Node.prems show ?thesis by auto
     qed
   qed
 qed
 
 lemma reduced_children_parent: 
 "\<lbrakk> reduced l; l= (Node llt lp rlt); reduced r; r=(Node lrt rp rrt); 
   lp \<noteq> rp \<rbrakk> 
  \<Longrightarrow> reduced (Node l p r)"
   by simp
 
 (*Die allgemeine Form mit i <=j \<Longrightarrow> Nodes i levellista \<subseteq> Nodes j levellista wäre schöner, aber wie beweist man das? *)
 lemma Nodes_subset: "Nodes i levellista \<subseteq> Nodes (Suc i) levellista"
   apply (simp add: Nodes_def)
   apply (simp add: set_split)
   done
 
 lemma Nodes_levellist: 
 "\<lbrakk> wf_ll pret levellista var; nb < length levellista; p \<in> Nodes nb levellista\<rbrakk> 
  \<Longrightarrow> p \<notin> set (levellista ! nb)"
   apply (simp add: Nodes_def) 
   apply (erule exE)
   apply (rule_tac i=x and j=nb in no_in_one_ll)
   apply auto
   done
 
 lemma Nodes_var_pret: 
  "\<lbrakk>wf_ll pret levellista var; nb < length levellista; p \<in> Nodes nb levellista\<rbrakk> 
   \<Longrightarrow> var p < nb \<and> p \<in> set_of pret"
   apply (simp add: Nodes_def wf_ll_def)
   apply (erule conjE)
   apply (thin_tac "\<forall>q. q \<in> set_of pret \<longrightarrow> q \<in> set (levellista ! var q)")
   apply (erule exE)
   apply (erule_tac x=x in allE)
   apply (erule impE)
   apply arith
   apply (erule_tac x=p in ballE)
   apply arith
   apply simp
   done
 
 lemma Dags_root_in_Nodes:
 assumes t_in_DagsSucnb: "t \<in> Dags (Nodes (Suc nb) levellista) low high" 
 shows "\<exists> p . Dag p low high t  \<and> p \<in> Nodes (Suc nb) levellista"
 proof -
   from t_in_DagsSucnb obtain p where t_dag: "Dag p low high t" and t_subset_Nodes: "set_of t \<subseteq> Nodes (Suc nb) levellista" and t_nTip: "t\<noteq> Tip"
     by (fastforce elim: Dags.cases)
   from t_dag t_nTip have "p\<noteq>Null" by (cases t) auto
   with t_subset_Nodes t_dag have "p \<in> Nodes (Suc nb) levellista" 
     by (cases t) auto
   with t_dag show ?thesis
     by auto
 qed
 
   
 
 
 lemma subdag_dag: 
 "\<And> p. \<lbrakk>Dag p low high t; st <= t\<rbrakk> \<Longrightarrow> \<exists> stp. Dag stp low high st"
 proof (induct t)
   case Tip
   then show ?case
     by (simp add: less_dag_def le_dag_def)
 next
   case (Node lt po rt)
   note t_Node=this
   with Node.prems have p_po: "p=po"
     by simp
   show ?case
   proof (cases "st = Node lt po rt")
     case True
     note st_t=this
     with Node.prems show ?thesis
       by auto
   next
     assume st_nt: "st \<noteq> Node lt po rt"
     with Node.prems p_po have st_subdag_lt_rt: "st<=lt \<or> st <=rt"
       by (auto simp add:le_dag_def less_dag_def)
     from Node.prems p_po obtain lp rp where lt_dag: "Dag lp low high lt" and rt_dag: "Dag rp low high rt"
       by auto
     show ?thesis
     proof (cases "st<=lt")
       case True
       note st_lt=this
       with lt_dag show ?thesis
         apply-
         apply (rule Node.hyps)
         apply auto
         done
     next
       assume "\<not> st \<le> lt"
       with st_subdag_lt_rt have st_rt: "st <= rt"
         by simp
       from Node.hyps have rhyp: "\<lbrakk>Dag rp low high rt; st \<le> rt\<rbrakk> \<Longrightarrow> \<exists>stp. Dag stp low high st"
         by simp
       from st_rt rt_dag show ?thesis
         apply -
         apply (rule rhyp)
         apply auto
         done
     qed
   qed
 qed
 
 lemma Dags_subdags: 
 assumes t_in_Dags: "t \<in> Dags nodes low high" and
   st_t: "st <= t" and 
   st_nTip: "st \<noteq> Tip"
 shows "st \<in> Dags nodes low high"
 proof -
   from t_in_Dags obtain p where t_dag: "Dag p low high t" and t_subset_Nodes: "set_of t \<subseteq> nodes" and t_nTip: "t\<noteq> Tip"
     by (fastforce elim: Dags.cases)
   from st_t have "set_of st \<subseteq> set_of t"
     by (simp add: le_dag_set_of)
   with t_subset_Nodes have st_subset_fnctNodes: "set_of st \<subseteq> nodes"
     by blast
   from st_t t_dag obtain stp where "Dag stp low high st"
     apply -
     apply (drule subdag_dag)
     apply auto
     done
   with st_subset_fnctNodes st_nTip show ?thesis
     apply -
     apply (rule DagsI)
     apply auto
     done
 qed
 
 
 lemma Dags_Nodes_cases: 
 assumes P_sym: "\<And> t1 t2. P t1 t2 var = P t2 t1 var" and
   dags_in_lower_levels: 
   "\<And> t1 t2. \<lbrakk>t1 \<in> Dags (fnct `(Nodes n levellista)) low high; 
               t2  \<in> Dags (fnct `(Nodes n levellista)) low high\<rbrakk> 
              \<Longrightarrow> P t1 t2 var" and
   dags_in_mixed_levels: 
   "\<And> t1 t2. \<lbrakk>t1 \<in> Dags (fnct `(Nodes n levellista)) low high; 
               t2  \<in> Dags (fnct `(Nodes (Suc n) levellista)) low high; 
               t2 \<notin>  Dags (fnct `(Nodes n levellista)) low high\<rbrakk> 
              \<Longrightarrow> P t1 t2 var" and
   dags_in_high_level: 
    "\<And> t1 t2. \<lbrakk>t1 \<in> Dags (fnct `(Nodes (Suc n) levellista)) low high; 
                t1 \<notin>  Dags (fnct `(Nodes n levellista)) low high; 
                t2 \<in> Dags (fnct `(Nodes (Suc n) levellista)) low high; 
                t2 \<notin>  Dags (fnct `(Nodes n levellista)) low high\<rbrakk> 
               \<Longrightarrow> P t1 t2 var"
 shows "\<forall> t1 t2.  t1 \<in> Dags (fnct `(Nodes (Suc n) levellista)) low high \<and> 
                  t2 \<in> Dags (fnct `(Nodes (Suc n) levellista)) low high 
                  \<longrightarrow> P t1 t2 var"
 proof (intro allI impI , elim conjE)
   fix t1 t2
   assume t1_in_higher_levels: "t1 \<in> Dags (fnct ` Nodes (Suc n) levellista) low high"
   assume t2_in_higher_levels: "t2 \<in> Dags (fnct ` Nodes (Suc n) levellista) low high"
   show  "P t1 t2 var"
   proof (cases "t1 \<in> Dags (fnct ` Nodes n levellista) low high")
     case True 
     note t1_in_ll = this
     show ?thesis
     proof (cases "t2 \<in> Dags (fnct ` Nodes n levellista) low high")
       case True
       note t2_in_ll=this
       with t1_in_ll dags_in_lower_levels show ?thesis
         by simp
     next
       assume t2_notin_ll: "t2 \<notin> Dags (fnct ` Nodes n levellista) low high"
       with t1_in_ll t2_in_higher_levels dags_in_mixed_levels show ?thesis
         by simp
     qed
   next
     assume t1_notin_ll: "t1 \<notin> Dags (fnct ` Nodes n levellista) low high"
     show ?thesis
     proof (cases "t2 \<in> Dags (fnct ` Nodes n levellista) low high")
       case True
       note t2_in_ll=this
       with dags_in_mixed_levels t1_in_higher_levels t1_notin_ll P_sym show ?thesis
         by auto
     next
       assume t2_notin_ll: "t2 \<notin> Dags (fnct ` Nodes n levellista) low high"
       with t1_notin_ll t1_in_higher_levels t2_in_higher_levels dags_in_high_level show ?thesis
         by simp
     qed
   qed
 qed
 
 lemma Null_notin_Nodes: "\<lbrakk>Dag p low high t; nb <= length levellista; wf_ll t levellista var\<rbrakk> \<Longrightarrow> Null \<notin> Nodes nb levellista" 
   apply (simp add: Nodes_def wf_ll_def del: Dag_Ref)
   apply (rule allI)
   apply (rule impI)
   apply (elim conjE)
   apply (thin_tac "\<forall>q. P q" for P)
   apply (erule_tac x=x in allE)
   apply (erule impE)
   apply simp
   apply (erule_tac x=Null in ballE)
   apply (erule conjE)
   apply (drule set_of_nn [rule_format])
   apply auto
   done
 
 
 lemma Nodes_in_pret: "\<lbrakk>wf_ll t levellista var; nb <= length levellista\<rbrakk> \<Longrightarrow> Nodes nb levellista \<subseteq> set_of t"
     apply -
     apply rule
     apply (simp add: wf_ll_def Nodes_def)
     apply (erule exE)
     apply (elim conjE)
     apply (thin_tac "\<forall>q. q \<in> set_of t \<longrightarrow> q \<in> set (levellista ! var q)")
     apply (erule_tac x=xa in allE)
     apply (erule impE)
     apply simp
     apply (erule_tac x=x in ballE)
     apply auto
     done
 
 
 
 lemma restrict_root_Node: 
   "\<lbrakk>t \<in> Dags (repc `Nodes (Suc nb) levellista) (repc \<propto> low) (repc \<propto> high); t \<notin>  Dags (repc `Nodes nb levellista) (repc \<propto> low) (repc \<propto> high); 
   ordered t var; \<forall> no \<in> Nodes (Suc nb) levellista. var (repc no) <= var no \<and> repc (repc no) = repc no; wf_ll pret levellista var; nb < length levellista;repc `Nodes (Suc nb) levellista \<subseteq> Nodes (Suc nb) levellista\<rbrakk>
   \<Longrightarrow> \<exists> q. Dag (repc q) (repc \<propto> low) (repc \<propto> high) t \<and> q \<in> set (levellista ! nb)"
 proof (elim Dags.cases)
   fix p and ta :: "dag"
   assume t_notin_DagsNodesnb: "t \<notin> Dags (repc ` Nodes nb levellista) (repc \<propto> low) (repc \<propto> high)"
   assume t_ta: "t = ta"
   assume ta_in_repc_NodesSucnb: "set_of ta \<subseteq> repc ` Nodes (Suc nb) levellista"
   assume ta_dag: "Dag p (repc \<propto> low) (repc \<propto> high) ta"
   assume ta_nTip: "ta \<noteq> Tip"
   assume ord_t: "ordered t var"
   assume varrep_prop: "\<forall> no \<in> Nodes (Suc nb) levellista. var (repc no) <= var no \<and> repc (repc no) = repc no"
   assume wf_lla: "wf_ll pret levellista var"
   assume nbslla: "nb < length levellista"
   assume repcNodes_in_Nodes: "repc `Nodes (Suc nb) levellista \<subseteq> Nodes (Suc nb) levellista"
   from ta_nTip ta_dag have p_nNull: "p\<noteq> Null"
     by auto
   with ta_nTip ta_dag obtain lt rt where ta_Node: " ta = Node lt p rt"
     by auto
   with ta_nTip ta_dag have p_in_ta: "p \<in> set_of ta"
     by auto
   with ta_in_repc_NodesSucnb have p_in_repcNodes_Sucnb: "p \<in> repc `Nodes (Suc nb) levellista"
     by auto
   show ?thesis
     proof (cases "p \<in> repc `(set (levellista ! nb))")
       case True
       then obtain q where 
         p_repca: "p=repc q" and
         a_in_llanb: "q \<in> set (levellista ! nb)"
         by auto
       with ta_dag t_ta show ?thesis
         apply -
         apply (rule_tac x=q in exI)
         apply simp
         done
     next
       assume p_notin_repc_llanb: "p \<notin> repc ` set (levellista ! nb)"
       with p_in_repcNodes_Sucnb have p_in_repc_Nodesnb: "p \<in> repc `Nodes nb levellista"
         apply -
         apply (erule imageE)
         apply rule
         apply (simp add: Nodes_def)
         apply (simp add: Nodes_def)
         apply (erule exE conjE)
         apply (case_tac "xa=nb")
         apply simp
         apply (rule_tac x=xa in exI)
         apply auto
         done
       have "t \<in> Dags (repc `Nodes nb levellista) (repc \<propto> low) (repc \<propto> high)"
       proof -
         have "set_of t \<subseteq> repc `Nodes nb levellista"
         proof (rule)
           fix x :: ref
           assume x_in_t: "x \<in> set_of t"
           with ord_t have "var x <= var (root t)"
             apply -
             apply (rule ordered_set_of)
             apply auto
             done
           with t_ta ta_Node have varx_varp: "var x <= var p"
             by auto
           from p_in_repc_Nodesnb obtain k where ksnb: "k < nb" and p_in_repc_llak:  "p \<in> repc `(set (levellista ! k))"
             by (auto simp add: Nodes_def ImageE)
           then obtain q where p_repcq: "p=repc q" and q_in_llak: "q \<in> set (levellista ! k)"
             by auto
           from q_in_llak wf_lla nbslla ksnb have varqk: "var q = k"
             by (simp add: wf_ll_def)
           have Nodesnb_in_NodesSucnb: "Nodes nb levellista \<subseteq> Nodes (Suc nb) levellista"
             by (rule Nodes_subset)
           from q_in_llak ksnb have "q \<in> Nodes nb levellista"
             by (auto simp add: Nodes_def)
           with varrep_prop Nodesnb_in_NodesSucnb have "var (repc q) <= var q"
             by auto
           with varqk ksnb p_repcq have "var p < nb"
             by auto
           with varx_varp have varx_snb: "var x < nb"
             by auto
           from x_in_t t_ta ta_in_repc_NodesSucnb obtain a where 
             x_repca: "x= repc a" and
             a_in_NodesSucnb: "a \<in> Nodes (Suc nb) levellista"
             by auto
           with varrep_prop have rx_x: "repc x = x" 
             by auto
           have "x \<in> set_of pret"
           proof -
             from wf_lla nbslla have "Nodes (Suc nb) levellista \<subseteq> set_of pret"
               apply -
               apply (rule Nodes_in_pret)
               apply auto
               done
             with x_in_t t_ta ta_in_repc_NodesSucnb repcNodes_in_Nodes show ?thesis
               by auto 
           qed 
           with wf_lla have "x \<in> set (levellista ! (var x))" 
             by (auto simp add: wf_ll_def) 
           with varx_snb have "x \<in> Nodes nb levellista" 
             by (auto simp add: Nodes_def) 
           with rx_x show "x \<in> repc `Nodes nb levellista"
             apply -
             apply rule
             apply (subgoal_tac "x=repc x")
             apply auto
             done
         qed 
         with ta_nTip ta_dag t_ta show ?thesis
           apply -
           apply (rule DagsI)
           apply auto
           done
       qed
       with t_notin_DagsNodesnb show ?thesis
         by auto
     qed
   qed
           
 
 
 
 
 lemma same_bdt_var: "\<lbrakk>bdt (Node lt1 p1 rt1) var = Some bdt1; bdt (Node lt2 p2 rt2) var = Some bdt1\<rbrakk>
   \<Longrightarrow> var p1 = var p2"
 proof (induct bdt1)
   case Zero
   then obtain var_p1: "var p1 = 0" and var_p2: "var p2 = 0"
     by simp
   then show ?case
     by simp
 next
   case One
   then obtain var_p1: "var p1 = 1" and var_p2: "var p2 = 1"
     by simp
   then show ?case
     by simp
 next
   case (Bdt_Node lbdt v rbdt)
   then obtain var_p1: "var p1 = v" and var_p2: "var p2 = v"
     by simp
   then show ?case by simp
 qed
 
 lemma bdt_Some_Leaf_var_le_1: 
 "\<lbrakk>Dag p low high t; bdt t var = Some x; isLeaf_pt p low high\<rbrakk> 
   \<Longrightarrow> var p <= 1"
 proof (induct t)
   case Tip
   thus ?case by simp
 next
   case (Node lt p rt)
   note tNode=this
   from Node.prems tNode show ?case
     apply (simp add: isLeaf_pt_def)
     apply (case_tac "var p = 0")
     apply simp
     apply (case_tac "var p = Suc 0")
     apply simp
     apply simp
     done
 qed
 
 lemma subnode_dag_cons: 
 "\<And> p. \<lbrakk>Dag p low high t; no \<in> set_of t\<rbrakk> \<Longrightarrow> \<exists> not. Dag no low high not"
 proof (induct t)
   case Tip
   thus ?case by simp
 next
   case (Node lt q rt)
   with Node.prems have q_p: "p = q"
     by simp
   from Node.prems have lt_dag: "Dag (low p) low high lt"
     by auto
   from Node.prems have rt_dag: "Dag (high p) low high rt"
     by auto
   show ?case
   proof (cases "no \<in> set_of lt")
     case True
     with Node.hyps lt_dag show ?thesis
       by simp
   next
     assume no_notin_lt: "no \<notin> set_of lt"
     show ?thesis
     proof (cases "no=p")
       case True
       with Node.prems q_p show ?thesis
         by auto
     next
       assume no_neq_p: "no \<noteq> p"
       with Node.prems no_notin_lt have no_in_rt: "no \<in> set_of rt"
         by simp
       with rt_dag Node.hyps show ?thesis
         by auto
     qed
   qed
 qed
 
 
 
 
 
 
 (*theorems for the proof of share_reduce_rep_list*)
 
 
 
 
 lemma nodes_in_taken_in_takeSucn: "no \<in> set (take n nodeslist) \<Longrightarrow> no \<in> set (take (Suc n) nodeslist) "
 proof -
   assume no_in_taken: "no \<in> set (take n nodeslist)"
   have "set (take n nodeslist) \<subseteq> set (take (Suc n) nodeslist)"
     apply -
     apply (rule set_take_subset_set_take)
     apply simp
     done
   with no_in_taken show ?thesis
     by blast
 qed
 
 
 lemma ind_in_higher_take: "\<And>n k. \<lbrakk>n < k;  n < length xs\<rbrakk> 
   \<Longrightarrow> xs ! n \<in> set (take k xs)"
 apply (induct xs)
 apply simp
 apply simp
 apply (case_tac n)
 apply simp
 apply (case_tac k)
 apply simp
 apply simp
 apply simp
 apply (case_tac k)
 apply simp
 apply simp
 done
 
 lemma take_length_set: "\<And>n. n=length xs \<Longrightarrow> set (take n xs) = set xs"
 apply (induct xs)
 apply (auto simp add: take_Cons split: nat.splits)
 done
 
 
 lemma repNodes_eq_ext_rep: "\<lbrakk>low no \<noteq> nodeslist! n; high no \<noteq> nodeslist ! n; 
   low sn \<noteq> nodeslist ! n; high sn \<noteq> nodeslist ! n\<rbrakk>
   \<Longrightarrow> repNodes_eq sn no low high repa = repNodes_eq sn no low high (repa(nodeslist ! n := repa (low (nodeslist ! n))))"
   by (simp add: repNodes_eq_def null_comp_def)
 
 
 lemma filter_not_empty: "\<lbrakk>x \<in> set xs; P x\<rbrakk> \<Longrightarrow> filter P xs \<noteq> []"
   by (induct xs) auto
 
 lemma "x \<in> set (filter P xs) \<Longrightarrow> P x"
   by auto
 
 lemma hd_filter_in_list: "filter P xs \<noteq> [] \<Longrightarrow> hd (filter P xs) \<in> set xs"
   by (induct xs) auto
 
 lemma hd_filter_in_filter: "filter P xs \<noteq> [] \<Longrightarrow> hd (filter P xs) \<in> set (filter P xs)"
   by (induct xs) auto
 
 lemma hd_filter_prop: 
   assumes non_empty: "filter P xs \<noteq> []" 
   shows "P (hd (filter P xs))"
 proof -
   from non_empty have "hd (filter P xs) \<in> set (filter P xs)"
     by (rule hd_filter_in_filter)
   thus ?thesis
     by auto
 qed
 
 lemma index_elem: "x \<in> set xs \<Longrightarrow> \<exists>i<length xs. x = xs ! i"
   apply (induct xs) 
   apply simp
   apply (case_tac "x=a")
   apply  auto
   done
 
 lemma filter_hd_P_rep_indep:     
 "\<lbrakk>\<forall>x. P x x; \<forall>a b. P x a \<longrightarrow> P a b \<longrightarrow> P x b; filter (P x) xs \<noteq> []\<rbrakk>  \<Longrightarrow> 
   hd (filter (P (hd (filter (P x) xs))) xs) =  hd (filter (P x) xs)"
 apply (induct xs)
 apply simp
 apply (case_tac "P x a")
 using [[simp_depth_limit=2]]
 apply  (simp)
 apply clarsimp
 apply (fastforce dest: hd_filter_prop)
 done
 
 lemma take_Suc_not_last:
 "\<And>n. \<lbrakk>x \<in> set (take (Suc n) xs); x\<noteq>xs!n; n < length xs\<rbrakk> \<Longrightarrow> x \<in> set (take n xs)"     
 apply (induct xs)
 apply  simp
 apply (case_tac n)
 apply  simp
 using [[simp_depth_limit=2]]
 apply fastforce
 done
 
 lemma P_eq_list_filter: "\<forall>x \<in> set xs. P x = Q x \<Longrightarrow> filter P xs = filter Q xs"
   apply (induct xs)
   apply auto
   done
 
 lemma hd_filter_take_more: "\<And>n m.\<lbrakk>filter P (take n xs) \<noteq> []; n \<le> m\<rbrakk> \<Longrightarrow> 
        hd (filter P (take n xs)) =  hd (filter P (take m xs))"
 apply (induct xs)
 apply  simp
 apply (case_tac n)
 apply  simp
 apply (case_tac m)
 apply  simp
 apply clarsimp
 done
 
 (*
 consts wf_levellist :: "dag \<Rightarrow> ref list list \<Rightarrow> ref list list \<Rightarrow>
                        (ref \<Rightarrow> nat) \<Rightarrow> bool"
 defs wf_levellist_def: "wf_levellist t levellist_old levellist_new var  \<equiv> 
 case t of Tip \<Rightarrow> levellist_old = levellist_new
 | (Node lt p rt) \<Rightarrow>
   (\<forall> q. q \<in> set_of t \<longrightarrow> q \<in> set (levellist_new ! (var q))) \<and>
   (\<forall> i \<le> var p. (\<exists> prx. (levellist_new ! i) = prx@(levellist_old ! i) 
                        \<and> (\<forall> pt \<in> set prx. pt \<in> set_of t \<and> var pt = i))) \<and>
   (\<forall> i. (var p) < i \<longrightarrow> (levellist_new ! i) = (levellist_old ! i)) \<and>
   (length levellist_new = length levellist_old)" 
 *)
 
 
 end
diff --git a/thys/Formula_Derivatives/Presburger_Formula.thy b/thys/Formula_Derivatives/Presburger_Formula.thy
--- a/thys/Formula_Derivatives/Presburger_Formula.thy
+++ b/thys/Formula_Derivatives/Presburger_Formula.thy
@@ -1,696 +1,705 @@
 section \<open>Concrete Atomic Presburger Formulas\<close>
 
 (*<*)
 theory Presburger_Formula
 imports
   Abstract_Formula
   "HOL-Library.Code_Target_Int"
   "List-Index.List_Index"
 begin
 (*>*)
 
 declare [[coercion "of_bool :: bool \<Rightarrow> nat"]]
 declare [[coercion int]]
 declare [[coercion_map map]]
 declare [[coercion_enabled]]
 
 fun len :: "nat \<Rightarrow> nat" where \<comment> \<open>FIXME yet another logarithm\<close>
   "len 0 = 0"
 | "len (Suc 0) = 1"
 | "len n = Suc (len (n div 2))"
 
 lemma len_eq0_iff: "len n = 0 \<longleftrightarrow> n = 0"
   by (induct n rule: len.induct) auto
 
 lemma len_mult2[simp]: "len (2 * x) = (if x = 0 then 0 else Suc (len x))"
 proof (induct x rule: len.induct)
   show "len (2 * Suc 0) = (if Suc 0 = 0 then 0 else Suc (len (Suc 0)))" by (simp add: numeral_eq_Suc)
 qed auto
 
 lemma len_mult2'[simp]: "len (x * 2) = (if x = 0 then 0 else Suc (len x))"
   using len_mult2 [of x] by (simp add: ac_simps)
 
 lemma len_Suc_mult2[simp]: "len (Suc (2 * x)) = Suc (len x)"
 proof (induct x rule: len.induct)
   show "len (Suc (2 * Suc 0)) = Suc (len (Suc 0))"
     by (metis div_less One_nat_def div2_Suc_Suc len.simps(3) lessI mult.right_neutral numeral_2_eq_2)
 qed auto
 
 lemma len_le_iff: "len x \<le> l \<longleftrightarrow> x < 2 ^ l"
 proof (induct x arbitrary: l rule: len.induct)
   fix l show "(len (Suc 0) \<le> l) = (Suc 0 < 2 ^ l)"
   proof (cases l)
     case Suc then show ?thesis using le_less by fastforce
   qed simp
 next
   fix v l assume "\<And>l. (len (Suc (Suc v) div 2) \<le> l) = (Suc (Suc v) div 2 < 2 ^ l)"
   then show "(len (Suc (Suc v)) \<le> l) = (Suc (Suc v) < 2 ^ l)"
     by (cases l) (simp_all, linarith)
 qed simp
 
 lemma len_pow2[simp]: "len (2 ^ x) = Suc x"
   by (induct x) auto
 
 lemma len_div2[simp]: "len (x div 2) = len x - 1"
   by (induct x rule: len.induct) auto
 
 lemma less_pow2_len[simp]: "x < 2 ^ len x"
   by (induct x rule: len.induct) auto
 
 lemma len_alt: "len x = (LEAST i. x < 2 ^ i)"
 proof (rule antisym)
   show "len x \<le> (LEAST i. x < 2 ^ i)"
     unfolding len_le_iff by (rule LeastI) (rule less_pow2_len)
 qed (auto intro: Least_le)
 
 lemma len_mono[simp]: "x \<le> y \<Longrightarrow> len x \<le> len y"
   unfolding len_le_iff using less_pow2_len[of y] by linarith
 
 lemma len_div_pow2[simp]: "len (x div 2 ^ m) = len x - m"
   by (induct m arbitrary: x) (auto simp: div_mult2_eq)
 
 lemma len_mult_pow2[simp]: "len (x * 2 ^ m) = (if x = 0 then 0 else len x + m)"
   by (induct m arbitrary: x) (auto simp: div_mult2_eq mult.assoc[symmetric] mult.commute[of _ 2])
 
 lemma map_index'_Suc[simp]: "map_index' (Suc i) f xs = map_index' i (\<lambda>i. f (Suc i)) xs"
   by (induct xs arbitrary: i) auto
 
 
 abbreviation (input) "zero n \<equiv> replicate n False"
 abbreviation (input) "SUC \<equiv> \<lambda>_::unit. Suc"
 definition "test_bit m n \<equiv> (m :: nat) div 2 ^ n mod 2 = 1"
+lemma test_bit_eq_iff: \<open>test_bit = bit\<close>
+  by (simp add: fun_eq_iff test_bit_def bit_iff_odd_drop_bit mod_2_eq_odd flip: drop_bit_eq_div)
 definition "downshift m \<equiv> (m :: nat) div 2"
 definition "upshift m \<equiv> (m :: nat) * 2"
-definition "set_bit n m \<equiv> m + (if \<not> test_bit m n then 2 ^ n else (0 :: nat))"
+lemma set_bit_def: "set_bit n m \<equiv> m + (if \<not> test_bit m n then 2 ^ n else (0 :: nat))"
+  apply (rule eq_reflection)
+  apply (rule bit_eqI)
+  apply (subst disjunctive_add)
+   apply (auto simp add: bit_simps test_bit_eq_iff)
+  done
 definition "cut_bits n m \<equiv> (m :: nat) mod 2 ^ n"
 
 typedef interp = "{(n :: nat, xs :: nat list). \<forall>x \<in> set xs. len x \<le> n}"
   by (force intro: exI[of _ "[]"])
 
 setup_lifting type_definition_interp
 type_synonym atom = "bool list"
 type_synonym "value" = "nat"
 datatype presb = Eq (tm: "int list") (const: int) (offset: "int")
 derive linorder list
 derive linorder presb
 type_synonym formula = "(presb, unit) aformula"
 
 lift_definition assigns :: "nat \<Rightarrow> interp \<Rightarrow> unit \<Rightarrow> value" ("_\<^bsup>_\<^esup>_" [900, 999, 999] 999) is
   "\<lambda>n (_, I) _. if n < length I then I ! n else 0" .
 
 lift_definition nvars :: "interp \<Rightarrow> nat" ("#\<^sub>V _" [1000] 900) is
   "\<lambda>(_, I). length I" .
 
 lift_definition Length :: "interp \<Rightarrow> nat" is "\<lambda>(n, _). n" .
 
 lift_definition Extend :: "unit \<Rightarrow> nat \<Rightarrow> interp \<Rightarrow> value \<Rightarrow> interp" is
   "\<lambda>_ i (n, I) m. (max n (len m), insert_nth i m I)"
   by (force simp: max_def dest: in_set_takeD in_set_dropD)
 
 lift_definition CONS :: "atom \<Rightarrow> interp \<Rightarrow> interp" is
   "\<lambda>bs (n, I). (Suc n, map_index (\<lambda>i n. 2 * n + (if bs ! i then 1 else 0)) I)"
   by (auto simp: set_zip)
 
 lift_definition SNOC :: "atom \<Rightarrow> interp \<Rightarrow> interp" is
   "\<lambda>bs (n, I). (Suc n, map_index (\<lambda>i m. m + (if bs ! i then 2 ^ n else 0)) I)"
   by (auto simp: all_set_conv_all_nth len_le_iff)
 
 definition extend :: "unit \<Rightarrow> bool \<Rightarrow> atom \<Rightarrow> atom" where
   "extend _ b bs \<equiv> b # bs"
 
 abbreviation (input) size_atom :: "atom \<Rightarrow> nat" where
   "size_atom \<equiv> length"
 
 definition FV0 :: "unit \<Rightarrow> presb \<Rightarrow> nat set" where
   "FV0 _ fm = (case fm of Eq is _ _ \<Rightarrow> {n. n < length is \<and> is!n \<noteq> 0})"
 
 lemma FV0_code[code]:
   "FV0 x (Eq is i off) = Option.these (set (map_index (\<lambda>i x. if x = 0 then None else Some i) is))"
   unfolding FV0_def by (force simp: Option.these_def image_iff)
 
 primrec wf0 :: "nat \<Rightarrow> presb \<Rightarrow> bool" where
   "wf0 idx (Eq is _ _) = (length is = idx)"
 
 fun find0 where
   "find0 (_::unit) n (Eq is _ _) = (is ! n \<noteq> 0)"
 
 primrec decr0 where
   "decr0 (_::unit) k (Eq is i d) = Eq (take k is @ drop (Suc k) is) i d"
 
 definition scalar_product :: "nat list \<Rightarrow> int list \<Rightarrow> int" where
   "scalar_product ns is =
      sum_list (map_index (\<lambda>i b. (if i < length ns then ns ! i else 0) * b) is)"
 
 lift_definition eval_tm :: "interp \<Rightarrow> int list \<Rightarrow> int" is
   "\<lambda>(_, I). scalar_product I" .
 
 primrec satisfies0 where
   "satisfies0 I (Eq is i d) = (eval_tm I is = i - (2 ^ Length I) * d)"
 
 inductive lformula0 where
   "lformula0 (Eq is i 0)"
 
 code_pred lformula0 .
 
 fun lderiv0 :: "bool list \<Rightarrow> presb \<Rightarrow> formula" where
   "lderiv0 bs (Eq is i d) = (if d \<noteq> 0 then undefined else
   (let v = i - scalar_product bs is
    in if v mod 2 = 0 then FBase (Eq is (v div 2) 0) else FBool False))"
 
 fun rderiv0 :: "bool list \<Rightarrow> presb \<Rightarrow> formula" where
   "rderiv0 bs (Eq is i d) =
   (let
      l = - sum_list [i. i \<leftarrow> is, i < 0];
      h = - sum_list [i. i \<leftarrow> is, i > 0];
      d' = scalar_product bs is + 2 * d
    in if d' \<in> {min h i .. max l i} then FBase (Eq is i d') else FBool False)"
 
 primrec nullable0 where
   "nullable0 (Eq is i off) = (i = off)"
 
 definition \<sigma> :: "nat \<Rightarrow> atom list" where
   "\<sigma> n = List.n_lists n [True, False]"
 
 named_theorems Presb_simps
 
 lemma nvars_Extend[Presb_simps]: "#\<^sub>V (Extend () i \<AA> P) = Suc (#\<^sub>V \<AA>)"
   by (transfer, auto)
 
 lemma Length_Extend[Presb_simps]: "Length (Extend () i \<AA> P) = max (Length \<AA>) (len P)"
   by (transfer, auto)
 
 lemma Length0_inj[Presb_simps]: "Length \<AA> = 0 \<Longrightarrow> Length \<BB> = 0 \<Longrightarrow> #\<^sub>V \<AA> = #\<^sub>V \<BB> \<Longrightarrow> \<AA> = \<BB>"
   by transfer (auto intro: nth_equalityI simp: all_set_conv_all_nth len_eq0_iff)
 
 lemma ex_Length0[Presb_simps]: "\<exists>\<AA>. Length \<AA> = 0 \<and> #\<^sub>V \<AA> = idx"
   by (transfer fixing: idx) (auto intro: exI[of _ "replicate idx 0"])
 
 lemma Extend_commute_safe[Presb_simps]: "\<lbrakk>j \<le> i; i < Suc (#\<^sub>V \<AA>)\<rbrakk> \<Longrightarrow>
   Extend k j (Extend k i \<AA> P) Q = Extend k (Suc i) (Extend k j \<AA> Q) P"
   by transfer (auto simp add: min_def take_Cons take_drop le_imp_diff_is_add split: nat.splits)
 
 lemma Extend_commute_unsafe[Presb_simps]:
   "k \<noteq> k' \<Longrightarrow> Extend k j (Extend k' i \<AA> P) Q = Extend k' i (Extend k j \<AA> Q) P"
   by transfer auto
 
 lemma assigns_Extend[Presb_simps]: "i < Suc (#\<^sub>V \<AA>) \<Longrightarrow>
   m\<^bsup>Extend k i \<AA> P\<^esup>k' = (if k = k' then if m = i then P else dec i m\<^bsup>\<AA>\<^esup>k else m\<^bsup>\<AA>\<^esup>k')"
   by transfer (auto simp: nth_append dec_def min_def)
 
 lemma assigns_SNOC_zero[Presb_simps]: "m < #\<^sub>V \<AA> \<Longrightarrow> m\<^bsup>SNOC (zero (#\<^sub>V \<AA>)) \<AA>\<^esup>k = m\<^bsup>\<AA>\<^esup>k"
   by transfer auto
 
 lemma Length_CONS[Presb_simps]: "Length (CONS x \<AA>) = Suc (Length \<AA>)"
   by transfer auto
 
 lemma Length_SNOC[Presb_simps]: "Length (SNOC x \<AA>) = Suc (Length \<AA>)"
   by transfer auto
 
 lemma nvars_CONS[Presb_simps]: "#\<^sub>V (CONS x \<AA>) = #\<^sub>V \<AA>"
   by transfer auto
 
 lemma nvars_SNOC[Presb_simps]: "#\<^sub>V (SNOC x \<AA>) = #\<^sub>V \<AA>"
   by transfer auto
 
 lemma Extend_CONS[Presb_simps]: "#\<^sub>V \<AA> = length x \<Longrightarrow>
   Extend k 0 (CONS x \<AA>) P = CONS (extend k (test_bit P 0) x) (Extend k 0 \<AA> (downshift P))"
   by transfer (auto simp: extend_def downshift_def test_bit_def, presburger+)
 
 lemma Extend_SNOC[Presb_simps]: "\<lbrakk>#\<^sub>V \<AA> = length x; len P \<le> Length (SNOC x \<AA>)\<rbrakk> \<Longrightarrow>
   Extend k 0 (SNOC x \<AA>) P =
     SNOC (extend k (test_bit P (Length \<AA>)) x) (Extend k 0 \<AA> (cut_bits (Length \<AA>) P))"
   apply transfer
   apply (auto simp: cut_bits_def extend_def test_bit_def nth_Cons' max_absorb1 len_le_iff
     split: if_splits cong del: if_weak_cong)
    apply (metis add.commute mod_less mod_mult2_eq mult_numeral_1_right numeral_1_eq_Suc_0 power_commuting_commutes)
   apply (metis Euclidean_Division.div_eq_0_iff div_0 less_mult_imp_div_less mod_less nat_dvd_not_less semiring_normalization_rules(7))
   done
 
 lemma odd_neq_even:
   "Suc (2 * x) = 2 * y \<longleftrightarrow> False"
   "2 * y = Suc (2 * x) \<longleftrightarrow> False"
   by presburger+
 
 lemma CONS_inj[Presb_simps]: "size x = #\<^sub>V \<AA> \<Longrightarrow> size y = #\<^sub>V \<AA> \<Longrightarrow> #\<^sub>V \<AA> = #\<^sub>V \<BB> \<Longrightarrow>
   CONS x \<AA> = CONS y \<BB> \<longleftrightarrow> (x = y \<and> \<AA> = \<BB>)"
   by transfer (auto simp: list_eq_iff_nth_eq odd_neq_even split: if_splits)
 
 lemma mod_2_Suc_iff:
   "x mod 2 = Suc 0 \<longleftrightarrow> x = Suc (2 * (x div 2))"
   by presburger+
 
 lemma CONS_surj[Presb_simps]: "Length \<AA> \<noteq> 0 \<Longrightarrow>
   \<exists>x \<BB>. \<AA> = CONS x \<BB> \<and> #\<^sub>V \<BB> = #\<^sub>V \<AA> \<and> size x = #\<^sub>V \<AA>"
   by transfer
     (auto simp: gr0_conv_Suc list_eq_iff_nth_eq len_le_iff split: if_splits
     intro!: exI[of _ "map (\<lambda>n. n mod 2 \<noteq> 0) _"] exI[of _ "map (\<lambda>n. n div 2) _"];
     auto simp: mod_2_Suc_iff)
 
 lemma [Presb_simps]: 
   "length (extend k b x) = Suc (length x)"
   "downshift (upshift P) = P"
   "downshift (set_bit 0 P) = downshift P"
   "test_bit (set_bit n P) n"
   "\<not> test_bit (upshift P) 0"
   "len P \<le> p \<Longrightarrow> \<not> test_bit P p"
   "len (cut_bits n P) \<le> n"
   "len P \<le> n \<Longrightarrow> cut_bits n P = P"
   "len (upshift P) = (case len P of 0 \<Rightarrow> 0 | Suc n \<Rightarrow> Suc (Suc n))"
   "len (downshift P) = (case len P of 0 \<Rightarrow> 0 | Suc n \<Rightarrow> n)"
   by (auto simp: extend_def set_bit_def cut_bits_def upshift_def downshift_def test_bit_def
     len_le_iff len_eq0_iff div_add_self2 split: nat.split)
 
 lemma Suc0_div_pow2_eq: "Suc 0 div 2 ^ i = (if i = 0 then 1 else 0)"
   by (induct i) (auto simp: div_mult2_eq)
 
 lemma set_unset_bit_preserves_len:
   assumes "x div 2 ^ m = 2 * q" "m < len x"
   shows "x + 2 ^ m < 2 ^ len x"
 using assms proof (induct m arbitrary: x)
   case 0 then show ?case
     by (auto simp: div_mult2_eq len_Suc_mult2[symmetric]
       simp del: len_Suc_mult2 power_Suc split: if_splits)
 next
   case (Suc m)
   with Suc(1)[of "x div 2"] show ?case by (cases "len x") (auto simp: div_mult2_eq)
 qed
 
 lemma len_set_bit[Presb_simps]: "len (set_bit m P) = max (Suc m) (len P)"
 proof (rule antisym)
   show "len (set_bit m P) \<le> max (Suc m) (len P)"
     by (auto simp: set_bit_def test_bit_def max_def Suc_le_eq not_less len_le_iff
       set_unset_bit_preserves_len simp del: One_nat_def)
 next
   have "P < 2 ^ len (P + 2 ^ m)" by (rule order.strict_trans2[OF less_pow2_len]) auto
   moreover have "m < len (P + 2 ^ m)" by (rule order.strict_trans2[OF _ len_mono[of "2 ^ m"]]) auto
   ultimately show "max (Suc m) (len P) \<le> len (set_bit m P)"
     by (auto simp: set_bit_def test_bit_def max_def Suc_le_eq not_less len_le_iff)
 qed
 
 lemma mod_pow2_div_pow2:
   fixes p m n :: nat
   shows "m < n \<Longrightarrow> p mod 2 ^ n div 2 ^ m = p div 2 ^ m mod 2 ^ (n - m)"
   by (induct m arbitrary: p n) (auto simp: div_mult2_eq mod_mult2_eq Suc_less_eq2)
 
 lemma irrelevant_set_bit[simp]:
   fixes p m n :: nat
   assumes "n \<le> m"
   shows "(p + 2 ^ m) mod 2 ^ n = p mod 2 ^ n"
 proof -
   from assms obtain q :: nat where "2 ^ m = q * 2 ^ n"
     by (metis le_add_diff_inverse mult.commute power_add)
   then show ?thesis by simp
 qed
 
 lemma mod_lemma: "\<lbrakk> (0::nat) < c; r < b \<rbrakk> \<Longrightarrow> b * (q mod c) + r < b * c"
   by (metis add_gr_0 div_le_mono div_mult_self1_is_m less_imp_add_positive mod_less_divisor not_less split_div)
 
 lemma relevant_set_bit[simp]:
   fixes p m n :: nat
   assumes "m < n" "p div 2 ^ m = 2 * q"
   shows "(p + 2 ^ m) mod 2 ^ n = p mod 2 ^ n + 2 ^ m"
 proof -
   have "p mod 2 ^ n + 2 ^ m < 2 ^ n"
   using assms proof (induct m arbitrary: p n)
     case 0 then show ?case
       by (auto simp: gr0_conv_Suc)
          (metis One_nat_def Suc_eq_plus1 lessI mod_lemma numeral_2_eq_2 zero_less_numeral zero_less_power)
   next
     case (Suc m)
     from Suc(1)[of "n - 1" "p div 2"] Suc(2,3) show ?case
       by (auto simp: div_mult2_eq mod_mult2_eq Suc_less_eq2)
   qed
   with \<open>m < n\<close> show ?thesis by (subst mod_add_eq [symmetric]) auto
 qed
 
 lemma cut_bits_set_bit[Presb_simps]: "cut_bits n (set_bit m p) =
   (if n \<le> m then cut_bits n p else set_bit m (cut_bits n p))"
   unfolding cut_bits_def set_bit_def test_bit_def
   by (auto simp: not_le mod_pow2_div_pow2 mod_mod_cancel simp del: One_nat_def)
 
 lemma wf0_decr0[Presb_simps]:
   "wf0 (Suc idx) a \<Longrightarrow> l < Suc idx \<Longrightarrow> \<not> find0 k l a \<Longrightarrow> wf0 idx (decr0 k l a)"
   by (induct a) auto
 
 lemma lformula0_decr0[Presb_simps]: "lformula0 a \<Longrightarrow> lformula0 (decr0 k l a)"
   by (induct a) (auto elim: lformula0.cases intro: lformula0.intros)
 
 abbreviation sat0_syn (infix "\<Turnstile>0" 65) where
  "sat0_syn \<equiv> satisfies0"
 abbreviation sat_syn (infix "\<Turnstile>" 65) where
  "sat_syn \<equiv> Formula_Operations.satisfies Extend Length satisfies0"
 abbreviation sat_bounded_syn (infix "\<Turnstile>\<^sub>b" 65) where
  "sat_bounded_syn \<equiv> Formula_Operations.satisfies_bounded Extend Length len satisfies0"
 
 lemma scalar_product_Nil[simp]: "scalar_product [] xs = 0"
   by (induct xs) (auto simp: scalar_product_def)
 
 lemma scalar_product_Nil2[simp]: "scalar_product xs [] = 0"
   by (induct xs) (auto simp: scalar_product_def)
 
 lemma scalar_product_Cons[simp]:
   "scalar_product xs (y # ys) = (case xs of x # xs \<Rightarrow> x * y + scalar_product xs ys | [] \<Rightarrow> 0)"
   by (cases xs) (simp, auto simp: scalar_product_def cong del: if_weak_cong)
 
 lemma scalar_product_append[simp]: "scalar_product ns (xs @ ys) =
   scalar_product (take (length xs) ns) xs + scalar_product (drop (length xs) ns) ys"
   by (induct xs arbitrary: ns) (auto split: list.splits)
 
 lemma scalar_product_trim: "scalar_product ns xs = scalar_product (take (length xs) ns) xs"
   by (induct xs arbitrary: ns) (auto split: list.splits)
 
 lemma Extend_satisfies0_decr0[Presb_simps]:
   assumes "\<not> find0 k i a" "i < Suc (#\<^sub>V \<AA>)" "lformula0 a \<or> len P \<le> Length \<AA>"
   shows "Extend k i \<AA> P \<Turnstile>0 a = \<AA> \<Turnstile>0 decr0 k i a"
 proof -
    { fix "is" :: "int list"
      assume "is ! i = 0"
      with assms(1,2) have "eval_tm (Extend k i \<AA> P) is = eval_tm \<AA> (take i is @ drop (Suc i) is)"
        by (cases a, transfer)
          (force intro: trans[OF scalar_product_trim] simp: min_def
          arg_cong2[OF refl id_take_nth_drop, of i _ scalar_product "take i xs @ _" for i x xs])
   } note * = this
   from assms show ?thesis
     by (cases a) (auto dest!: * simp: Length_Extend max_def elim: lformula0.cases)
 qed
 
 lemma scalar_product_eq0: "\<forall>c\<in>set ns. c = 0 \<Longrightarrow> scalar_product ns is = 0"
 proof (induct "is" arbitrary: "ns")
   case Cons
   then show ?case by (cases ns) (auto simp: scalar_product_def cong del: if_weak_cong)
 qed (simp add: scalar_product_def)
 
 lemma nullable0_satisfies0[Presb_simps]: "Length \<AA> = 0 \<Longrightarrow> nullable0 a = \<AA> \<Turnstile>0 a"
 proof (induct a)
   case Eq then show ?case unfolding nullable0.simps satisfies0.simps
     by transfer (auto simp: len_eq0_iff scalar_product_eq0)
 qed
 
 lemma satisfies0_cong: "wf0 (#\<^sub>V \<BB>) a \<Longrightarrow> #\<^sub>V \<AA> = #\<^sub>V \<BB> \<Longrightarrow> lformula0 a \<Longrightarrow>
   (\<And>m k. m < #\<^sub>V \<BB> \<Longrightarrow> m\<^bsup>\<AA>\<^esup>k = m\<^bsup>\<BB>\<^esup>k) \<Longrightarrow> \<AA> \<Turnstile>0 a = \<BB> \<Turnstile>0 a"
 proof (induct a)
   case Eq then show ?case unfolding satisfies0.simps
     by transfer (auto simp: scalar_product_def
       intro!: arg_cong[of _ _ sum_list] map_index_cong elim!: lformula0.cases)
 qed
 
 lemma wf_lderiv0[Presb_simps]:
   "wf0 idx a \<Longrightarrow> lformula0 a \<Longrightarrow> Formula_Operations.wf (\<lambda>_. Suc) wf0 idx (lderiv0 x a)"
   by (induct a) (auto elim: lformula0.cases simp: Formula_Operations.wf.simps Let_def)
 
 lemma lformula_lderiv0[Presb_simps]:
   "lformula0 a \<Longrightarrow> Formula_Operations.lformula lformula0 (lderiv0 x a)"
   by (induct a)
     (auto elim: lformula0.cases intro: lformula0.intros simp: Let_def Formula_Operations.lformula.simps)
 
 lemma wf_rderiv0[Presb_simps]:
   "wf0 idx a \<Longrightarrow> Formula_Operations.wf (\<lambda>_. Suc) wf0 idx (rderiv0 x a)"
   by (induct a) (auto elim: lformula0.cases simp: Formula_Operations.wf.simps Let_def)
 
 lemma find0_FV0[Presb_simps]: "\<lbrakk>wf0 idx a; l < idx\<rbrakk> \<Longrightarrow> find0 k l a = (l \<in> FV0 k a)"
   by (induct a) (auto simp: FV0_def)
 
 lemma FV0_less[Presb_simps]: "wf0 idx a \<Longrightarrow> v \<in> FV0 k a \<Longrightarrow> v < idx"
   by (induct a) (auto simp: FV0_def)
 
 lemma finite_FV0[Presb_simps]: "finite (FV0 k a)"
   by (induct a) (auto simp: FV0_def)
 
 lemma finite_lderiv0[Presb_simps]:
   assumes "lformula0 a"
   shows "finite {\<phi>. \<exists>xs. \<phi> = fold (Formula_Operations.deriv extend lderiv0) xs (FBase a)}"
 proof -
   define d where "d = Formula_Operations.deriv extend lderiv0"
   define l where "l is = sum_list [i. i \<leftarrow> is, i < 0]" for "is" :: "int list"
   define h where "h is = sum_list [i. i \<leftarrow> is, i > 0]" for "is" :: "int list"
   define \<Phi> where "\<Phi> a = (case a of
     Eq is n z \<Rightarrow> {FBase (Eq is i 0) | i . i \<in> {min (- h is) n .. max (- l is) n}} \<union>
       {FBool False :: formula})" for a
   { fix xs
     note Formula_Operations.fold_deriv_FBool[simp] Formula_Operations.deriv.simps[simp] \<Phi>_def[simp]
     from \<open>lformula0 a\<close> have "FBase a \<in> \<Phi> a" by (auto simp: elim!: lformula0.cases)
     moreover have "\<And>x \<phi>. \<phi> \<in> \<Phi> a \<Longrightarrow> d x \<phi> \<in> \<Phi> a"
     proof (induct a, unfold \<Phi>_def presb.case, elim UnE CollectE insertE emptyE exE conjE)
       fix "is" :: "int list" and bs :: "bool list" and i n :: int and \<phi> :: formula
       assume "i \<in> {min (- h is) n..max (- l is) n}" "\<phi> = FBase (presb.Eq is i 0)"
       moreover have "scalar_product bs is \<le> h is"
       proof (induct "is" arbitrary: bs)
         case (Cons x xs)
         from Cons[of "tl bs"] show ?case by (cases bs) (auto simp: h_def)
       qed (auto simp: h_def scalar_product_def)
       moreover have "l is \<le> scalar_product bs is"
       proof (induct "is" arbitrary: bs)
         case (Cons x xs)
         from Cons[of "tl bs"] show ?case by (cases bs) (auto simp: l_def)
       qed (auto simp: l_def scalar_product_def)
       ultimately show "d bs \<phi> \<in>
         {FBase (presb.Eq is i 0) |i. i \<in> {min (- h is) n..max (- l is) n}} \<union> {FBool False}"
         by (auto simp: d_def Let_def)
     qed (auto simp: d_def)
     then have "\<And>\<phi>. \<phi> \<in> \<Phi> a \<Longrightarrow> fold d xs \<phi> \<in> \<Phi> a" by (induct xs) auto
     ultimately have "fold d xs (FBase a) \<in> \<Phi> a" by blast
    }
    moreover have "finite (\<Phi> a)" unfolding \<Phi>_def by (auto split: presb.splits)
    ultimately show "?thesis" unfolding d_def by (blast intro: finite_subset)
 qed
 
 lemma finite_rderiv0[Presb_simps]:
   "finite {\<phi>. \<exists>xs. \<phi> = fold (Formula_Operations.deriv extend rderiv0) xs (FBase a)}"
 proof -
   define d where "d = Formula_Operations.deriv extend rderiv0"
   define l where "l is = sum_list [i. i \<leftarrow> is, i < 0]"for "is" :: "int list"
   define h where "h is = sum_list [i. i \<leftarrow> is, i > 0]"for "is" :: "int list"
   define \<Phi> where "\<Phi> a = (case a of
     Eq is n z \<Rightarrow> {FBase (Eq is n i) | i . i \<in> {min (- h is) (min n z) .. max (- l is) (max n z)}} \<union>
       {FBool False :: formula})" for a
   { fix xs
     note Formula_Operations.fold_deriv_FBool[simp] Formula_Operations.deriv.simps[simp] \<Phi>_def[simp]
     have "FBase a \<in> \<Phi> a" by (auto split: presb.splits)
     moreover have "\<And>x \<phi>. \<phi> \<in> \<Phi> a \<Longrightarrow> d x \<phi> \<in> \<Phi> a"
     proof (induct a, unfold \<Phi>_def presb.case, elim UnE CollectE insertE emptyE exE conjE)
       fix "is" :: "int list" and bs :: "bool list" and i n m :: int and \<phi> :: formula
       assume "i \<in> {min (- h is) (min n m)..max (- l is) (max n m)}" "\<phi> = FBase (presb.Eq is n i)"
       moreover have "scalar_product bs is \<le> h is"
       proof (induct "is" arbitrary: bs)
         case (Cons x xs)
         from Cons[of "tl bs"] show ?case by (cases bs) (auto simp: h_def)
       qed (auto simp: h_def scalar_product_def)
       moreover have "l is \<le> scalar_product bs is"
       proof (induct "is" arbitrary: bs)
         case (Cons x xs)
         from Cons[of "tl bs"] show ?case by (cases bs) (auto simp: l_def)
       qed (auto simp: l_def scalar_product_def)
       ultimately show "d bs \<phi> \<in>
         {FBase (presb.Eq is n i) |i. i \<in> {min (- h is) (min n m)..max (- l is) (max n m)}} \<union> {FBool False}"
         by (auto 0 1 simp: d_def Let_def h_def l_def)
     qed (auto simp: d_def)
     then have "\<And>\<phi>. \<phi> \<in> \<Phi> a \<Longrightarrow> fold d xs \<phi> \<in> \<Phi> a" by (induct xs) auto
     ultimately have "fold d xs (FBase a) \<in> \<Phi> a" by blast
    }
    moreover have "finite (\<Phi> a)" unfolding \<Phi>_def by (auto split: presb.splits)
    ultimately show "?thesis" unfolding d_def by (blast intro: finite_subset)
 qed
 
 lemma scalar_product_CONS: "length xs = length (bs :: bool list) \<Longrightarrow>
   scalar_product (map_index (\<lambda>i n. 2 * n + bs ! i) xs) is =
   scalar_product bs is + 2 * scalar_product xs is"
   by (induct "is" arbitrary: bs xs) (auto split: list.splits simp: algebra_simps)
 
 lemma eval_tm_CONS[simp]:
   "\<lbrakk>length is \<le> #\<^sub>V \<AA>; #\<^sub>V \<AA> = length x\<rbrakk> \<Longrightarrow>
    eval_tm (CONS x \<AA>) is = scalar_product x is + 2 * eval_tm \<AA> is"
   by transfer (auto simp: scalar_product_CONS[symmetric]
     intro!: arg_cong2[of _ _ _ _ scalar_product] nth_equalityI)
 
 lemma satisfies_lderiv0[Presb_simps]:
   "\<lbrakk>wf0 (#\<^sub>V \<AA>) a; #\<^sub>V \<AA> = length x; lformula0 a\<rbrakk> \<Longrightarrow> \<AA> \<Turnstile> lderiv0 x a \<longleftrightarrow> CONS x \<AA> \<Turnstile>0 a"
   by (auto simp: Let_def Formula_Operations.satisfies_gen.simps
     split: if_splits elim!: lformula0.cases)
 
 lemma satisfies_bounded_lderiv0[Presb_simps]:
   "\<lbrakk>wf0 (#\<^sub>V \<AA>) a; #\<^sub>V \<AA> = length x; lformula0 a\<rbrakk> \<Longrightarrow> \<AA> \<Turnstile>\<^sub>b lderiv0 x a \<longleftrightarrow> CONS x \<AA> \<Turnstile>0 a"
   by (auto simp: Let_def Formula_Operations.satisfies_gen.simps
     split: if_splits elim!: lformula0.cases)
 
 lemma scalar_product_SNOC: "length xs = length (bs :: bool list)  \<Longrightarrow>
   scalar_product (map_index (\<lambda>i m. m + 2 ^ a * bs ! i) xs) is =
   scalar_product xs is + 2 ^ a * scalar_product bs is"
   by (induct "is" arbitrary: bs xs) (auto split: list.splits simp: algebra_simps)
 
 lemma eval_tm_SNOC[simp]:
   "\<lbrakk>length is \<le> #\<^sub>V \<AA>; #\<^sub>V \<AA> = length x\<rbrakk> \<Longrightarrow>
    eval_tm (SNOC x \<AA>) is = eval_tm \<AA> is + 2 ^ Length \<AA> * scalar_product x is"
   by transfer (auto simp: scalar_product_SNOC[symmetric]
     intro!: arg_cong2[of _ _ _ _ scalar_product] nth_equalityI)
 
 lemma Length_eq0_eval_tm_eq0[simp]: "Length \<AA> = 0 \<Longrightarrow> eval_tm \<AA> is = 0"
   by transfer (auto simp: len_eq0_iff scalar_product_eq0)
 
 lemma less_pow2: "x < 2 ^ a \<Longrightarrow> int x < 2 ^ a"
   by (metis of_nat_less_iff of_nat_numeral of_nat_power [symmetric])
 
 lemma scalar_product_upper_bound: "\<forall>x\<in>set b. len x \<le> a \<Longrightarrow>
   scalar_product b is \<le> (2 ^ a - 1) * sum_list [i. i \<leftarrow> is, i > 0]"
 proof (induct "is" arbitrary: b)
   case (Cons i "is")
   then have "scalar_product (tl b) is \<le> (2 ^ a - 1) * sum_list [i. i \<leftarrow> is, i > 0]"
     by (auto simp: in_set_tlD)
   with Cons(2) show ?case
     by (auto 0 3 split: list.splits simp: len_le_iff mult_le_0_iff
       distrib_left add.commute[of _ "(2 ^ a - 1) * i"] less_pow2
       intro: add_mono elim: order_trans[OF add_mono[OF order_refl]])
 qed simp
 
 lemma scalar_product_lower_bound: "\<forall>x\<in>set b. len x \<le> a \<Longrightarrow>
   scalar_product b is \<ge> (2 ^ a - 1) * sum_list [i. i \<leftarrow> is, i < 0]"
 proof (induct "is" arbitrary: b)
   case (Cons i "is")
   then have "scalar_product (tl b) is \<ge> (2 ^ a - 1) * sum_list [i. i \<leftarrow> is, i < 0]"
     by (auto simp: in_set_tlD)
   with Cons(2) show ?case
     by (auto 0 3 split: list.splits simp: len_le_iff mult_le_0_iff
       distrib_left add.commute[of _ "(2 ^ a - 1) * i"] less_pow2
       intro: add_mono elim: order_trans[OF add_mono[OF order_refl]] order_trans)
 qed simp
 
 lemma eval_tm_upper_bound: "eval_tm \<AA> is \<le> (2 ^ Length \<AA> - 1) * sum_list [i. i \<leftarrow> is, i > 0]"
   by transfer (auto simp: scalar_product_upper_bound)
 
 lemma eval_tm_lower_bound: "eval_tm \<AA> is \<ge> (2 ^ Length \<AA> - 1) * sum_list [i. i \<leftarrow> is, i < 0]"
   by transfer (auto simp: scalar_product_lower_bound)
 
 lemma satisfies_bounded_rderiv0[Presb_simps]:
   "\<lbrakk>wf0 (#\<^sub>V \<AA>) a; #\<^sub>V \<AA> = length x\<rbrakk> \<Longrightarrow> \<AA> \<Turnstile>\<^sub>b rderiv0 x a \<longleftrightarrow> SNOC x \<AA> \<Turnstile>0 a"
 proof (induct a)
   case (Eq "is" n d)
   let ?l = "Length \<AA>"
   define d' where "d' = scalar_product x is + 2 * d"
   define l where "l = sum_list  [i. i \<leftarrow> is, i < 0]"
   define h where "h = sum_list  [i. i \<leftarrow> is, i > 0]"
   from Eq show ?case
   unfolding wf0.simps satisfies0.simps rderiv0.simps Let_def
   proof (split if_splits, simp only: Formula_Operations.satisfies_gen.simps satisfies0.simps
     Length_SNOC eval_tm_SNOC simp_thms(13) de_Morgan_conj not_le
     min_less_iff_conj max_less_iff_conj d'_def[symmetric] h_def[symmetric] l_def[symmetric], safe)
     assume "eval_tm \<AA> is + 2 ^ ?l * scalar_product x is = n - 2 ^ Suc ?l * d"
     with eval_tm_upper_bound[of \<AA> "is"] eval_tm_lower_bound[of \<AA> "is"] have
       *: "n + h \<le> 2 ^ ?l * (h + d')" "2 ^ ?l * (l + d') \<le> n + l"
       by (auto simp: algebra_simps h_def l_def d'_def)
     assume **: "d' \<notin> {min (- h) n..max (- l) n}"
     { assume "0 \<le> n + h"
       from order_trans[OF this *(1)] have "0 \<le> h + d'"
         unfolding zero_le_mult_iff using zero_less_power[of 2] by presburger
     }
     moreover
     { assume "n + h < 0"
       with *(1) have "n \<le> d'" by (auto dest: order_trans[OF _ mult_right_mono_neg[of 1]])
     }
     moreover
     { assume "n + l < 0"
       from le_less_trans[OF *(2) this] have "l + d' < 0" unfolding mult_less_0_iff by auto
     }
     moreover
     { assume "0 \<le> n + l"
       then have "0 \<le> l + d'" using ** calculation(1-2) by force
       with *(2) have "d' \<le> n" by (force dest: order_trans[OF mult_right_mono[of 1], rotated])
     }
     ultimately have "min (- h) n \<le> d'" "d' \<le> max (- l) n" by (auto simp: min_def max_def)
     with ** show False by auto
   qed (auto simp: algebra_simps d'_def)
 qed
 
 declare [[goals_limit = 100]]
 
 global_interpretation Presb: Formula
   where SUC = SUC and LESS = "\<lambda>_. (<)" and Length = Length
   and assigns = assigns and nvars = nvars and Extend = Extend and CONS = CONS and SNOC = SNOC
   and extend = extend and size = size_atom and zero = zero and alphabet = \<sigma> and eval = test_bit
   and downshift = downshift and upshift = upshift and add = set_bit and cut = cut_bits and len = len
   and restrict = "\<lambda>_ _. True" and Restrict = "\<lambda>_ _. FBool True" and lformula0 = lformula0
   and FV0 = FV0 and find0 = find0 and wf0 = wf0 and decr0 = decr0 and satisfies0 = satisfies0
   and nullable0 = nullable0 and lderiv0 = lderiv0 and rderiv0 = rderiv0
   and TYPEVARS = undefined
   defines norm = "Formula_Operations.norm find0 decr0"
   and nFOr = "Formula_Operations.nFOr :: formula \<Rightarrow> _"
   and nFAnd = "Formula_Operations.nFAnd :: formula \<Rightarrow> _"
   and nFNot = "Formula_Operations.nFNot find0 decr0 :: formula \<Rightarrow> _"
   and nFEx = "Formula_Operations.nFEx find0 decr0"
   and nFAll = "Formula_Operations.nFAll find0 decr0"
   and decr = "Formula_Operations.decr decr0 :: _ \<Rightarrow> _ \<Rightarrow> formula \<Rightarrow> _"
   and find = "Formula_Operations.find find0 :: _ \<Rightarrow> _ \<Rightarrow> formula \<Rightarrow> _"
   and FV = "Formula_Operations.FV FV0"
   and RESTR = "Formula_Operations.RESTR (\<lambda>_ _. FBool True) :: _ \<Rightarrow> formula"
   and RESTRICT = "Formula_Operations.RESTRICT (\<lambda>_ _. FBool True) FV0"
   and deriv = "\<lambda>d0 (a :: atom) (\<phi> :: formula). Formula_Operations.deriv extend d0 a \<phi>"
   and nullable = "\<lambda>\<phi> :: formula. Formula_Operations.nullable nullable0 \<phi>"
   and fut_default = "Formula.fut_default extend zero rderiv0"
   and fut = "Formula.fut extend zero find0 decr0 rderiv0"
   and finalize = "Formula.finalize SUC extend zero find0 decr0 rderiv0"
   and final = "Formula.final SUC extend zero find0 decr0
      nullable0 rderiv0 :: nat \<Rightarrow> formula \<Rightarrow> _"
   and presb_wf = "Formula_Operations.wf SUC (wf0 :: nat \<Rightarrow> presb \<Rightarrow> _)"
   and presb_lformula = "Formula_Operations.lformula (lformula0 :: presb \<Rightarrow> _) :: formula \<Rightarrow> _"
   and check_eqv = "\<lambda>idx. DAs.check_eqv
     (\<sigma> idx) (\<lambda>\<phi>. norm (RESTRICT \<phi>) :: formula)
     (\<lambda>a \<phi>. norm (deriv (lderiv0 :: _ \<Rightarrow> _ \<Rightarrow> formula) (a :: atom) \<phi>))
     (final idx) (\<lambda>\<phi> :: formula. presb_wf idx \<phi> \<and> presb_lformula \<phi>)
     (\<sigma> idx) (\<lambda>\<phi>. norm (RESTRICT \<phi>) :: formula)
     (\<lambda>a \<phi>. norm (deriv (lderiv0 :: _ \<Rightarrow> _ \<Rightarrow> formula) (a :: atom) \<phi>))
     (final idx) (\<lambda>\<phi> :: formula. presb_wf idx \<phi> \<and> presb_lformula \<phi>)
     (=)"
   and bounded_check_eqv = "\<lambda>idx. DAs.check_eqv
     (\<sigma> idx) (\<lambda>\<phi>. norm (RESTRICT \<phi>) :: formula)
     (\<lambda>a \<phi>. norm (deriv (lderiv0 :: _ \<Rightarrow> _ \<Rightarrow> formula) (a :: atom) \<phi>))
     nullable (\<lambda>\<phi> :: formula. presb_wf idx \<phi> \<and> presb_lformula \<phi>)
     (\<sigma> idx) (\<lambda>\<phi>. norm (RESTRICT \<phi>) :: formula)
     (\<lambda>a \<phi>. norm (deriv (lderiv0 :: _ \<Rightarrow> _ \<Rightarrow> formula) (a :: atom) \<phi>))
     nullable (\<lambda>\<phi> :: formula. presb_wf idx \<phi> \<and> presb_lformula \<phi>)
     (=)"
   and automaton = "DA.automaton
     (\<lambda>a \<phi>. norm (deriv lderiv0 (a :: atom) \<phi> :: formula))"
-  by standard (auto simp: Presb_simps \<sigma>_def set_n_lists distinct_n_lists
+  apply standard apply (auto simp: Presb_simps \<sigma>_def set_n_lists distinct_n_lists
     Formula_Operations.lformula.simps Formula_Operations.satisfies_gen.simps Formula_Operations.wf.simps
     dest: satisfies0_cong split: presb.splits if_splits)
+  apply (simp add: downshift_def)
+  done
 
 (*Workaround for code generation*)
 lemma check_eqv_code[code]: "check_eqv idx r s =
   ((presb_wf idx r \<and> presb_lformula r) \<and> (presb_wf idx s \<and> presb_lformula s) \<and>
   (case rtrancl_while (\<lambda>(p, q). final idx p = final idx q)
     (\<lambda>(p, q). map (\<lambda>a. (norm (deriv lderiv0 a p), norm (deriv lderiv0 a q))) (\<sigma> idx))
     (norm (RESTRICT r), norm (RESTRICT s)) of
     None \<Rightarrow> False
   | Some ([], x) \<Rightarrow> True
   | Some (a # list, x) \<Rightarrow> False))"
   unfolding check_eqv_def Presb.check_eqv_def Presb.step_alt ..
 
 definition while where [code del, code_abbrev]: "while idx \<phi> = while_default (fut_default idx \<phi>)"
 declare while_default_code[of "fut_default idx \<phi>" for idx \<phi>, folded while_def, code]
 
 lemma check_eqv_sound: 
   "\<lbrakk>#\<^sub>V \<AA> = idx; check_eqv idx \<phi> \<psi>\<rbrakk> \<Longrightarrow> (Presb.sat \<AA> \<phi> \<longleftrightarrow> Presb.sat \<AA> \<psi>)"
   unfolding check_eqv_def by (rule Presb.check_eqv_soundness)
 
 lemma bounded_check_eqv_sound:
   "\<lbrakk>#\<^sub>V \<AA> = idx; bounded_check_eqv idx \<phi> \<psi>\<rbrakk> \<Longrightarrow> (Presb.sat\<^sub>b \<AA> \<phi> \<longleftrightarrow> Presb.sat\<^sub>b \<AA> \<psi>)"
   unfolding bounded_check_eqv_def by (rule Presb.bounded_check_eqv_soundness)
 
 method_setup check_equiv = \<open>
   let
     fun tac ctxt =
       let
         val conv = @{computation_check terms: Trueprop
           "0 :: nat" "1 :: nat" "2 :: nat" "3 :: nat" Suc
           "plus :: nat \<Rightarrow> _" "minus :: nat \<Rightarrow> _"
           "times :: nat \<Rightarrow> _" "divide :: nat \<Rightarrow> _" "modulo :: nat \<Rightarrow> _"
           "0 :: int" "1 :: int" "2 :: int" "3 :: int" "-1 :: int"
           check_eqv datatypes: formula "int list" integer bool} ctxt
       in
         CONVERSION (Conv.params_conv ~1 (K (Conv.concl_conv ~1 conv)) ctxt) THEN'
         resolve_tac ctxt [TrueI]
       end
   in
     Scan.succeed (SIMPLE_METHOD' o tac)
   end
 \<close>
 
 end
diff --git a/thys/Isabelle_Meta_Model/meta_isabelle/Meta_Isabelle.thy b/thys/Isabelle_Meta_Model/meta_isabelle/Meta_Isabelle.thy
--- a/thys/Isabelle_Meta_Model/meta_isabelle/Meta_Isabelle.thy
+++ b/thys/Isabelle_Meta_Model/meta_isabelle/Meta_Isabelle.thy
@@ -1,451 +1,451 @@
 (******************************************************************************
  * A Meta-Model for the Isabelle API
  *
  * Copyright (c) 2011-2018 Université Paris-Saclay, Univ. Paris-Sud, France
  *               2013-2017 IRT SystemX, France
  *               2011-2015 Achim D. Brucker, Germany
  *               2016-2018 The University of Sheffield, UK
  *               2016-2017 Nanyang Technological University, Singapore
  *               2017-2018 Virginia Tech, USA
  *
  * All rights reserved.
  *
  * Redistribution and use in source and binary forms, with or without
  * modification, are permitted provided that the following conditions are
  * met:
  *
  *     * Redistributions of source code must retain the above copyright
  *       notice, this list of conditions and the following disclaimer.
  *
  *     * Redistributions in binary form must reproduce the above
  *       copyright notice, this list of conditions and the following
  *       disclaimer in the documentation and/or other materials provided
  *       with the distribution.
  *
  *     * Neither the name of the copyright holders nor the names of its
  *       contributors may be used to endorse or promote products derived
  *       from this software without specific prior written permission.
  *
  * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
  * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
  * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
  * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
  * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
  * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
  * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
  * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
  * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  ******************************************************************************)
 
 section\<open>Isabelle Meta-Model aka. AST definition of Isabelle\<close>
 
 theory  Meta_Isabelle
 imports Meta_Pure
         Meta_SML
 begin
 
 subsection\<open>Type Definition\<close>
 
 text\<open>The following datatypes beginning with \verb|semi__| represent semi-concrete syntax,
        deliberately not minimal abstract syntax like (Pure) Term,
        this is for example to facilitate the pretty-printing process,
        or for manipulating recursively data-structures through an abstract and typed API.\<close>
 
 datatype semi__typ = Typ_apply semi__typ "semi__typ list"
                    | Typ_apply_bin string \<comment> \<open>binop\<close> semi__typ semi__typ
                    | Typ_apply_paren string \<comment> \<open>left\<close> string \<comment> \<open>right\<close> semi__typ
                    | Typ_base string
 
 datatype "datatype" = Datatype string \<comment> \<open>name\<close>
                                "(string \<comment> \<open>name\<close> \<times> semi__typ list \<comment> \<open>arguments\<close>) list" \<comment> \<open>constructors\<close>
 
 datatype "type_synonym" = Type_synonym string \<comment> \<open>name\<close>
                                        "string list" \<comment> \<open>parametric variables\<close>
                                        semi__typ \<comment> \<open>content\<close>
 
 datatype semi__term = Term_rewrite semi__term \<comment> \<open>left\<close> string \<comment> \<open>symb rewriting\<close> semi__term \<comment> \<open>right\<close>
                     | Term_basic "string list"
                     | Term_annot semi__term semi__typ
                     | Term_bind string \<comment> \<open>symbol\<close> semi__term \<comment> \<open>arg\<close> semi__term
                     | Term_fun_case "semi__term \<comment> \<open>value\<close> option" \<comment> \<open>none: function\<close> "(semi__term \<comment> \<open>pattern\<close> \<times> semi__term \<comment> \<open>to return\<close>) list"
                     | Term_apply semi__term "semi__term list"
                     | Term_paren string \<comment> \<open>left\<close> string \<comment> \<open>right\<close> semi__term
                     | Term_if_then_else semi__term semi__term semi__term
                     | Term_term "string list" \<comment> \<open>simulate a pre-initialized context (de bruijn variables under "lam")\<close>
                                 "term" \<comment> \<open>usual continuation of inner syntax term\<close>
 
 datatype "type_notation" = Type_notation string \<comment> \<open>name\<close>
                                          string \<comment> \<open>content\<close>
 
 datatype "instantiation" = Instantiation string \<comment> \<open>name\<close>
                                          string \<comment> \<open>name in definition\<close>
                                          semi__term
 
 datatype "overloading" = Overloading string \<comment> \<open>name consts\<close> semi__term
                                      string \<comment> \<open>name def\<close> semi__term \<comment> \<open>content\<close>
 
 datatype "consts" = Consts string \<comment> \<open>name\<close>
                            semi__typ
                            string \<comment> \<open>expression in 'post' mixfix\<close>
 
 datatype "definition" = Definition semi__term
                       | Definition_where1 string \<comment> \<open>name\<close> "semi__term \<comment> \<open>syntax extension\<close> \<times> nat \<comment> \<open>priority\<close>" semi__term
                       | Definition_where2 string \<comment> \<open>name\<close> semi__term \<comment> \<open>syntax extension\<close> semi__term
 
 datatype semi__thm_attribute = Thm_thm string \<comment> \<open>represents a single thm\<close>
                              | Thm_thms string \<comment> \<open>represents several thms\<close>
                              | Thm_THEN semi__thm_attribute semi__thm_attribute
                              | Thm_simplified semi__thm_attribute semi__thm_attribute
                              | Thm_symmetric semi__thm_attribute
                              | Thm_where semi__thm_attribute "(string \<times> semi__term) list"
                              | Thm_of semi__thm_attribute "semi__term list"
                              | Thm_OF semi__thm_attribute semi__thm_attribute
 
 datatype semi__thm = Thms_single semi__thm_attribute
                    | Thms_mult semi__thm_attribute
 
 type_synonym semi__thm_l = "semi__thm list"
 
 datatype "lemmas" = Lemmas_simp_thm bool \<comment> \<open>True : simp\<close>
                                     string \<comment> \<open>name\<close>
                                     "semi__thm_attribute list"
                   | Lemmas_simp_thms string \<comment> \<open>name\<close>
                                      "string \<comment> \<open>thms\<close> list"
 
 datatype semi__method_simp = Method_simp_only semi__thm_l
                            | Method_simp_add_del_split semi__thm_l \<comment> \<open>add\<close> semi__thm_l \<comment> \<open>del\<close> semi__thm_l \<comment> \<open>split\<close>
 
 datatype semi__method = Method_rule "semi__thm_attribute option"
                       | Method_drule semi__thm_attribute
                       | Method_erule semi__thm_attribute
                       | Method_intro "semi__thm_attribute list"
                       | Method_elim semi__thm_attribute
                       | Method_subst bool \<comment> \<open>asm\<close>
                                      "string \<comment> \<open>nat\<close> list" \<comment> \<open>pos\<close>
                                      semi__thm_attribute
                       | Method_insert semi__thm_l
                       | Method_plus "semi__method list"
                       | Method_option "semi__method list"
                       | Method_or "semi__method list"
                       | Method_one semi__method_simp
                       | Method_all semi__method_simp
                       | Method_auto_simp_add_split semi__thm_l "string list"
                       | Method_rename_tac "string list"
                       | Method_case_tac semi__term
                       | Method_blast "nat option"
                       | Method_clarify
                       | Method_metis "string list" \<comment> \<open>e.g. \<open>no_types\<close> (\<open>override_type_encs\<close>)\<close>
                                      "semi__thm_attribute list"
 
 datatype semi__command_final = Command_done
                              | Command_by "semi__method list"
                              | Command_sorry
 
 datatype semi__command_state = Command_apply_end "semi__method list" \<comment> \<open>\<^theory_text>\<open>apply_end (\<dots>, \<dots>)\<close>\<close>
 
 datatype semi__command_proof = Command_apply "semi__method list" \<comment> \<open>\<^theory_text>\<open>apply (\<dots>, \<dots>)\<close>\<close>
                              | Command_using semi__thm_l \<comment> \<open>\<^theory_text>\<open>using \<dots>\<close>\<close>
                              | Command_unfolding semi__thm_l \<comment> \<open>\<^theory_text>\<open>unfolding \<dots>\<close>\<close>
                              | Command_let semi__term \<comment> \<open>name\<close> semi__term
                              | Command_have string \<comment> \<open>name\<close>
                                             bool \<comment> \<open>true: add \<open>[simp]\<close>\<close>
                                             semi__term
                                             semi__command_final
                              | Command_fix_let "string list"
                                                "(semi__term \<comment> \<open>name\<close> \<times> semi__term) list" \<comment> \<open>let statements\<close> (* TODO merge recursively *)
                                                "( semi__term list \<comment> \<open>\<^theory_text>\<open>show \<dots> \<Longrightarrow> \<dots> \<close>\<close>
                                                 \<times> semi__term list \<comment> \<open>\<^theory_text>\<open>when \<dots> \<dots>\<close>\<close>) option" \<comment> \<open>\<open>None \<Rightarrow> ?thesis\<close>\<close>
                                                "semi__command_state list" \<comment> \<open>\<^theory_text>\<open>qed apply_end \<dots>\<close>\<close>
 
 datatype "lemma" = Lemma string \<comment> \<open>name\<close> "semi__term list" \<comment> \<open>specification to prove\<close>
                          "semi__method list list" \<comment> \<open>tactics: \<^theory_text>\<open>apply (\<dots>, \<dots>) apply \<dots>\<close>\<close>
                          semi__command_final
                  | Lemma_assumes string \<comment> \<open>name\<close>
                                  "(string \<comment> \<open>name\<close> \<times> bool \<comment> \<open>true: add \<open>[simp]\<close>\<close> \<times> semi__term) list" \<comment> \<open>specification to prove (assms)\<close>
                                  semi__term \<comment> \<open>specification to prove (conclusion)\<close>
                                  "semi__command_proof list"
                                  semi__command_final
 
 datatype "axiomatization" = Axiomatization string \<comment> \<open>name\<close>
                                            semi__term
 
 datatype "section" = Section nat \<comment> \<open>nesting level\<close>
                              string \<comment> \<open>content\<close>
 
 datatype "text" = Text string
 
 datatype "ML" = SML semi__term'
 
 datatype "setup" = Setup semi__term'
 
 datatype "thm" = Thm "semi__thm_attribute list"
 
 datatype "interpretation" = Interpretation string \<comment> \<open>name\<close>
                                            string \<comment> \<open>locale name\<close>
                                            "semi__term list" \<comment> \<open>locale param\<close>
                                            semi__command_final
 
 datatype semi__theory = Theory_datatype "datatype"
                       | Theory_type_synonym "type_synonym"
                       | Theory_type_notation "type_notation"
                       | Theory_instantiation "instantiation"
                       | Theory_overloading "overloading"
                       | Theory_consts "consts"
                       | Theory_definition "definition"
                       | Theory_lemmas "lemmas"
                       | Theory_lemma "lemma"
                       | Theory_axiomatization "axiomatization"
                       | Theory_section "section"
                       | Theory_text "text"
                       | Theory_ML "ML"
                       | Theory_setup "setup"
                       | Theory_thm "thm"
                       | Theory_interpretation "interpretation"
 
 record semi__locale = 
   HolThyLocale_name :: string
   HolThyLocale_header :: "( (semi__term \<comment> \<open>name\<close> \<times> semi__typ \<comment> \<open>\<^theory_text>\<open>fix\<close> statement\<close>) list
                           \<times> (string \<comment> \<open>name\<close> \<times> semi__term \<comment> \<open>\<^theory_text>\<open>assumes\<close> statement\<close>) option \<comment> \<open>None: no \<^theory_text>\<open>assumes\<close> to generate\<close>) list"
 
 datatype semi__theories = Theories_one semi__theory
                         | Theories_locale semi__locale "semi__theory list \<comment> \<open>positioning comments can occur before and after this group of commands\<close> list"
 
 subsection\<open>Extending the Meta-Model\<close>
 
 locale T
 begin
 definition "thm = Thm_thm"
 definition "thms = Thm_thms"
 definition "THEN = Thm_THEN"
 definition "simplified = Thm_simplified"
 definition "symmetric = Thm_symmetric"
 definition "where = Thm_where"
 definition "of' = Thm_of"
 definition "OF = Thm_OF"
 definition "OF_l s l = List.fold (\<lambda>x acc. Thm_OF acc x) l s"
 definition "simplified_l s l = List.fold (\<lambda>x acc. Thm_simplified acc x) l s"
 end
 
 lemmas [code] =
   \<comment> \<open>def\<close>
   T.thm_def
   T.thms_def
   T.THEN_def
   T.simplified_def
   T.symmetric_def
   T.where_def
   T.of'_def
   T.OF_def
   T.OF_l_def
   T.simplified_l_def
 
 definition "Opt s = Typ_apply (Typ_base \<open>option\<close>) [Typ_base s]"
 definition "Raw = Typ_base"
 definition "Type_synonym' n = Type_synonym n []"
 definition "Type_synonym'' n l f = Type_synonym n l (f l)"
 definition "Term_annot' e s = Term_annot e (Typ_base s)"
 definition "Term_lambdas s = Term_bind \<open>\<lambda>\<close> (Term_basic s)"
 definition "Term_lambda x = Term_lambdas [x]"
 definition "Term_lambdas0 = Term_bind \<open>\<lambda>\<close>"
 definition "Term_lam x f = Term_lambdas0 (Term_basic [x]) (f x)"
 definition "Term_some = Term_paren \<open>\<lfloor>\<close> \<open>\<rfloor>\<close>"
 definition "Term_parenthesis \<comment> \<open>mandatory parenthesis\<close> = Term_paren \<open>(\<close> \<open>)\<close>"
 definition "Term_warning_parenthesis \<comment> \<open>optional parenthesis that can be removed but a warning will be raised\<close> = Term_parenthesis"
 definition "Term_pat b = Term_basic [\<open>?\<close> @@ b]"
 definition "Term_And x f = Term_bind \<open>\<And>\<close> (Term_basic [x]) (f x)"
 definition "Term_exists x f = Term_bind \<open>\<exists>\<close> (Term_basic [x]) (f x)"
 definition "Term_binop = Term_rewrite"
 definition "term_binop s l = (case rev l of x # xs \<Rightarrow> List.fold (\<lambda>x. Term_binop x s) xs x)"
 definition "term_binop' s l = (case rev l of x # xs \<Rightarrow> List.fold (\<lambda>x. Term_parenthesis o Term_binop x s) xs x)"
 definition "Term_set l = (case l of [] \<Rightarrow> Term_basic [\<open>{}\<close>] | _ \<Rightarrow> Term_paren \<open>{\<close> \<open>}\<close> (term_binop \<open>,\<close> l))"
 definition "Term_list l = (case l of [] \<Rightarrow> Term_basic [\<open>[]\<close>] | _ \<Rightarrow> Term_paren \<open>[\<close> \<open>]\<close> (term_binop \<open>,\<close> l))"
 definition "Term_list' f l = Term_list (L.map f l)"
 definition "Term_pair e1 e2 = Term_parenthesis (Term_binop e1 \<open>,\<close> e2)"
 definition "Term_pair' l = (case l of [] \<Rightarrow> Term_basic [\<open>()\<close>] | _ \<Rightarrow> Term_paren \<open>(\<close> \<open>)\<close> (term_binop \<open>,\<close> l))"
 definition \<open>Term_string s = Term_basic [S.flatten [\<open>"\<close>, s, \<open>"\<close>]]\<close>
 definition "Term_applys0 e l = Term_parenthesis (Term_apply e (L.map Term_parenthesis l))"
 definition "Term_applys e l = Term_applys0 (Term_parenthesis e) l"
 definition "Term_app e = Term_applys0 (Term_basic [e])"
 definition "Term_preunary e1 e2 = Term_apply e1 [e2]" \<comment> \<open>no parenthesis and separated with one space\<close>
 definition "Term_postunary e1 e2 = Term_apply e1 [e2]" \<comment> \<open>no parenthesis and separated with one space\<close>
 definition "Term_case = Term_fun_case o Some"
 definition "Term_function = Term_fun_case None"
 definition "Term_term' = Term_term []"
 definition "Lemmas_simp = Lemmas_simp_thm True"
 definition "Lemmas_nosimp = Lemmas_simp_thm False"
 definition "Consts_value = \<open>(_)\<close>"
 definition "Consts_raw0 s l e o_arg =
        Consts s l (String.replace_integers (\<lambda>n. if n = 0x5F then \<open>'_\<close> else \<degree>n\<degree>) e @@ (case o_arg of
          None \<Rightarrow> \<open>\<close>
        | Some arg \<Rightarrow>
            let ap = \<lambda>s. \<open>'(\<close> @@ s @@ \<open>')\<close> in
            ap (if arg = 0 then
                 \<open>\<close>
               else
                 Consts_value @@ (S.flatten (L.map (\<lambda>_. \<open>,\<close> @@ Consts_value) (L.upto 2 arg))))))"
 definition "Ty_arrow = Typ_apply_bin \<open>\<Rightarrow>\<close>"
 definition "Ty_times = Typ_apply_bin \<open>\<times>\<close>"
 definition "Ty_arrow' x = Ty_arrow x (Typ_base \<open>_\<close>)"
 definition "Ty_paren = Typ_apply_paren \<open>(\<close> \<open>)\<close>"
 definition "Consts' s l e = Consts_raw0 s (Ty_arrow (Typ_base \<open>'\<alpha>\<close>) l) e None"
 definition "Overloading' n ty = Overloading n (Term_annot (Term_basic [n]) ty)"
 
 locale M
 begin
 definition "Method_simp_add_del l_a l_d = Method_simp_add_del_split l_a l_d []"
 definition "Method_subst_l = Method_subst False"
 
 definition "rule' = Method_rule None"
 definition "rule = Method_rule o Some"
 definition "drule = Method_drule"
 definition "erule = Method_erule"
 definition "intro = Method_intro"
 definition "elim = Method_elim"
 definition "subst_l0 = Method_subst"
 definition "subst_l = Method_subst_l"
 definition insert where "insert = Method_insert o L.map Thms_single"
 definition plus where "plus = Method_plus"
 definition "option = Method_option"
-definition "or = Method_or"
+definition or where "or = Method_or"
 definition "meth_gen_simp = Method_simp_add_del [] []"
 definition "meth_gen_simp_add2 l1 l2 = Method_simp_add_del (L.flatten [ L.map Thms_mult l1
                                                     , L.map (Thms_single o Thm_thm) l2])
                                            []"
 definition "meth_gen_simp_add_del l1 l2 = Method_simp_add_del (L.map (Thms_single o Thm_thm) l1)
                                               (L.map (Thms_single o Thm_thm) l2)"
 definition "meth_gen_simp_add_del_split l1 l2 l3 = Method_simp_add_del_split (L.map Thms_single l1)
                                                              (L.map Thms_single l2)
                                                              (L.map Thms_single l3)"
 definition "meth_gen_simp_add_split l1 l2 = Method_simp_add_del_split (L.map Thms_single l1)
                                                       []
                                                       (L.map Thms_single l2)"
 definition "meth_gen_simp_only l = Method_simp_only (L.map Thms_single l)"
 definition "meth_gen_simp_only' l = Method_simp_only (L.map Thms_mult l)"
 definition "meth_gen_simp_add0 l = Method_simp_add_del (L.map Thms_single l) []"
 definition "simp = Method_one meth_gen_simp"
 definition "simp_add2 l1 l2 = Method_one (meth_gen_simp_add2 l1 l2)"
 definition "simp_add_del l1 l2 = Method_one (meth_gen_simp_add_del l1 l2)"
 definition "simp_add_del_split l1 l2 l3 = Method_one (meth_gen_simp_add_del_split l1 l2 l3)"
 definition "simp_add_split l1 l2 = Method_one (meth_gen_simp_add_split l1 l2)"
 definition "simp_only l = Method_one (meth_gen_simp_only l)"
 definition "simp_only' l = Method_one (meth_gen_simp_only' l)"
 definition "simp_add0 l = Method_one (meth_gen_simp_add0 l)"
 definition "simp_add = simp_add2 []"
 definition "simp_all = Method_all meth_gen_simp"
 definition "simp_all_add l = Method_all (meth_gen_simp_add2 [] l)"
 definition "simp_all_only l = Method_all (meth_gen_simp_only l)"
 definition "simp_all_only' l = Method_all (meth_gen_simp_only' l)"
 definition "auto_simp_add2 l1 l2 = Method_auto_simp_add_split (L.flatten [ L.map Thms_mult l1
                                                                 , L.map (Thms_single o Thm_thm) l2]) []"
 definition "auto_simp_add_split l = Method_auto_simp_add_split (L.map Thms_single l)"
 definition "rename_tac = Method_rename_tac"
 definition "case_tac = Method_case_tac"
 definition "blast = Method_blast"
 definition "clarify = Method_clarify"
 definition "metis = Method_metis []"
 definition "metis0 = Method_metis"
 
 definition "subst_asm b = subst_l0 b [\<open>0\<close>]"
 definition "subst = subst_l [\<open>0\<close>]"
 definition "auto_simp_add = auto_simp_add2 []"
 definition "auto = auto_simp_add []"
 end
 
 lemmas [code] =
   \<comment> \<open>def\<close>
   M.Method_simp_add_del_def
   M.Method_subst_l_def
   M.rule'_def
   M.rule_def
   M.drule_def
   M.erule_def
   M.intro_def
   M.elim_def
   M.subst_l0_def
   M.subst_l_def
   M.insert_def
   M.plus_def
   M.option_def
   M.or_def
   M.meth_gen_simp_def
   M.meth_gen_simp_add2_def
   M.meth_gen_simp_add_del_def
   M.meth_gen_simp_add_del_split_def
   M.meth_gen_simp_add_split_def
   M.meth_gen_simp_only_def
   M.meth_gen_simp_only'_def
   M.meth_gen_simp_add0_def
   M.simp_def
   M.simp_add2_def
   M.simp_add_del_def
   M.simp_add_del_split_def
   M.simp_add_split_def
   M.simp_only_def
   M.simp_only'_def
   M.simp_add0_def
   M.simp_add_def
   M.simp_all_def
   M.simp_all_add_def
   M.simp_all_only_def
   M.simp_all_only'_def
   M.auto_simp_add2_def
   M.auto_simp_add_split_def
   M.rename_tac_def
   M.case_tac_def
   M.blast_def
   M.clarify_def
   M.metis_def
   M.metis0_def
   M.subst_asm_def
   M.subst_def
   M.auto_simp_add_def
   M.auto_def
 
 definition "ty_arrow l = (case rev l of x # xs \<Rightarrow> List.fold Ty_arrow xs x)"
 
 locale C 
 begin
 definition "done = Command_done"
 definition "by = Command_by"
 definition "sorry = Command_sorry"
 definition "apply_end = Command_apply_end"
 definition "apply = Command_apply"
 definition "using = Command_using o L.map Thms_single"
 definition "unfolding = Command_unfolding o L.map Thms_single"
 definition "let' = Command_let"
 definition "fix_let = Command_fix_let"
 definition "fix l = Command_fix_let l [] None []"
 definition "have n = Command_have n False"
 definition "have0 = Command_have"
 end
 
 lemmas [code] =
   \<comment> \<open>def\<close>
   C.done_def
   C.by_def
   C.sorry_def
   C.apply_end_def
   C.apply_def
   C.using_def
   C.unfolding_def
   C.let'_def
   C.fix_let_def
   C.fix_def
   C.have_def
   C.have0_def
 
 fun cross_abs_aux where
    "cross_abs_aux f l x = (\<lambda> (Suc n, Abs s _ t) \<Rightarrow> f s (cross_abs_aux f (s # l) (n, t))
                          | (_, e) \<Rightarrow> Term_term l e)
                          x"
 
 definition "cross_abs f n l = cross_abs_aux f [] (n, l)"
 
 subsection\<open>Operations of Fold, Map, ..., on the Meta-Model\<close>
 
 definition "map_lemma f = (\<lambda> Theory_lemma x \<Rightarrow> Theory_lemma (f x)
                            | x \<Rightarrow> x)"
 
 end
diff --git a/thys/Knot_Theory/Preliminaries.thy b/thys/Knot_Theory/Preliminaries.thy
--- a/thys/Knot_Theory/Preliminaries.thy
+++ b/thys/Knot_Theory/Preliminaries.thy
@@ -1,309 +1,309 @@
 section\<open>Preliminaries: Definitions of tangles and links\<close>
 theory Preliminaries
 imports Main
 begin
 
 text\<open>This theory contains the definition of a link. A link is defined as link diagrams upto 
  equivalence moves. Link diagrams are defined in terms of the constituent tangles\<close>
 
 text\<open>each  block is a horizontal block built by putting basic link bricks next to each other.
 (1) vert is the straight line
 (2) cup is the up facing cup
 (3) cap is the bottom facing 
 (4) over is the positive cross
 (5) under is the negative cross\<close>
 
 datatype brick = vert
                 |cup
                 |cap
                 |over
                 |under
          
 text\<open>block is obtained by putting bricks next to each other\<close>
 
 type_synonym block = "brick list"
 
 text\<open>wall are link diagrams obtained by placing a horizontal blocks a top each other\<close>
 
 datatype wall =  basic block
                 |prod block  wall  (infixr "*" 66)
 
 text\<open>Concatenate gives us the block obtained by putting two blocks next to each other\<close>
 
 
 primrec concatenate :: "block => block => block" (infixr "\<otimes>" 65) where
 concatenates_Nil: "[] \<otimes> ys = ys" |
 concatenates_Cons: "((x#xs)\<otimes>ys) = x#(xs\<otimes>ys)"
 
 lemma empty_concatenate: "xs \<otimes> Nil = xs"
  by (induction xs) (auto)
 
 
 text\<open>Associativity properties of Conscatenation\<close>
 lemma leftright_associativity: "(x\<otimes>y)\<otimes>z = x\<otimes>(y\<otimes>z)"
  by (induction x) (auto)
 
 lemma left_associativity: "(x\<otimes>y)\<otimes>z = x\<otimes>y\<otimes>z"
  by (induction x) (auto)
 
 
 lemma right_associativity: "x\<otimes>(y\<otimes>z) =x \<otimes> y \<otimes>z"
  by auto
 
 text\<open>Compose gives us the wall obtained by putting a wall above another, perhaps in an invalid way.
 \<close>
 primrec compose :: "wall => wall => wall" (infixr "\<circ>" 66) where
 compose_Nil: "(basic x) \<circ>  ys = prod x ys" |
 compose_Cons: "((prod x xs)\<circ>ys) = prod x (xs\<circ>ys)"
 
 text\<open>Associativity properties of composition\<close>
 lemma compose_leftassociativity: "(((x::wall) \<circ> y) \<circ> z) = (x\<circ>y \<circ>z)"
  by (induction x) (auto)
 
 
 lemma compose_rightassociativity: "(x::wall) \<circ> (y \<circ> z) = (x\<circ>y \<circ>z)"
  by (induction x) (auto)
 
 
 
 text\<open>block-length of a block is the number of bricks in a given block\<close>
 primrec block_length::"block \<Rightarrow> nat"
 where
 "block_length [] = 0"|
 "block_length (Cons x y) = 1 + (block_length y)"
 
 
 
 (*domain tells us the number of incoming strands*)
  primrec domain::"brick \<Rightarrow> int"
  where
  "domain vert = 1"|
  "domain cup = 0"|
  "domain cap = 2"|
  "domain over = 2"|
  "domain under = 2"
 
 lemma domain_non_negative:"\<forall>x.(domain x) \<ge> 0"
  
 proof-
  have "\<forall>x.(x = vert)\<or>(x = over)\<or>(x=under)\<or>(x=cap)\<or>(x=cup)"
                by (metis brick.exhaust)  
  moreover have 
       "\<forall>x.(((x = vert)\<or>(x = over)\<or>(x=under)\<or>(x=cap)\<or>(x=cup)) \<longrightarrow> (domain x) \<ge> 0)"
               using domain.simps by (metis order_refl zero_le_numeral zero_le_one)
  ultimately show ?thesis by auto
 qed   
    
 (*co-domain tells us the number of outgoing strands*)
  primrec codomain::"brick \<Rightarrow> int"
  where
  "codomain vert = 1"|
  "codomain cup = 2"|
  "codomain cap = 0"|
  "codomain over = 2"|
  "codomain under = 2"
 
 (*domain-block tells us the number of incoming strands of a block*)
  primrec domain_block::"block \<Rightarrow> int "
  where
  "domain_block [] = 0"
  |"domain_block (Cons x y) = (domain x + (domain_block y))"
 
 lemma domain_block_non_negative:"domain_block xs \<ge> 0"
  by (induction xs) (auto simp add:domain_non_negative)
 
 
 (*codomain-block tells us the number of outgoing strands of a block*)
 
  primrec codomain_block::"block \<Rightarrow> int "
  where
  "codomain_block [] = 0"
  |"codomain_block (Cons x y) = (codomain x + (codomain_block y))"
 
 
 (*domain-wall tells us the number of incoming strands of a wall*)
 
 primrec domain_wall:: "wall \<Rightarrow> int" where
 "domain_wall (basic x) = domain_block x"                                               
 |"domain_wall (x*ys) = domain_block x"
 
 (*domain-wall tells us the number of incoming strands of a wall*)
 
 fun codomain_wall:: "wall \<Rightarrow> int" where
 "codomain_wall (basic x) = codomain_block x"                      
 |"codomain_wall (x*ys) = codomain_wall ys"
    
 lemma domain_wall_compose: "domain_wall (xs\<circ>ys) = domain_wall xs"
  by (induction xs) (auto)
 
 
 lemma codomain_wall_compose: "codomain_wall (xs\<circ>ys) = codomain_wall ys"
  by (induction xs) (auto)
 
 text\<open>this lemma tells us the number of incoming and outgoing strands
 of a composition of two wall\<close>
 
 
 text\<open>absolute value\<close>
 definition abs::"int \<Rightarrow> int" where
 "abs x \<equiv> if (x\<ge>0) then x else (0-x)" 
 
 text\<open>theorems about abs\<close>
 lemma abs_zero: assumes "abs x = 0" shows "x = 0" 
  using abs_def assms eq_iff_diff_eq_0
  by metis
 
 lemma abs_zero_equality: assumes "abs (x - y) = 0" shows "x = y" 
  using assms abs_zero  eq_iff_diff_eq_0 
  by blast
 
 lemma abs_non_negative: " abs x \<ge> 0"
  using abs_def diff_0 le_cases neg_0_le_iff_le 
  by auto
 
 
 lemma abs_non_negative_sum:  assumes " abs x + abs y = 0"
 shows "abs x= 0" and "abs y = 0"
  using abs_def diff_0 abs_non_negative  neg_0_le_iff_le 
  add_nonneg_eq_0_iff assms
  apply (metis)
  by (metis abs_non_negative add_nonneg_eq_0_iff assms)
 
 text\<open>The following lemmas tell us that the number of incoming and outgoing strands of every brick 
 is a non negative integer\<close>
 
 lemma domain_nonnegative: "(domain x) \<ge> 0" 
  using domain.simps  brick.exhaust le_cases not_numeral_le_zero zero_le_one by (metis)
 
 
 lemma codomain_nonnegative: "(codomain x) \<ge> 0" 
  by (cases x)(auto)
 
 text\<open>The following lemmas tell us that the number of incoming and outgoing strands of every block 
 is a non negative integer\<close>
 
 lemma domain_block_nonnegative: "domain_block x \<ge> 0" 
  by (induction x)(auto simp add: domain_nonnegative) 
 
 
 lemma codomain_block_nonnegative: "(codomain_block x) \<ge> 0" 
  by (induction x)(auto simp add: codomain_nonnegative) 
 
 
 
 text\<open>The following lemmas tell us that if a block is appended to a block with incoming strands, then
 the resultant block has incoming strands\<close>
 
 lemma domain_positive: "((domain_block (x#Nil)) > 0) \<or> ((domain_block y) > 0) 
 \<Longrightarrow> (domain_block (x#y) > 0)" 
 proof-
  have "(domain_block (x#y)) =  (domain x) + (domain_block y)"  by auto
  also have " (domain x) = (domain_block (x#Nil))" by auto
  then have "(domain_block (x#Nil) > 0) = (domain x > 0)"  by auto
  then have "((domain x > 0) \<or> (domain_block y > 0)) \<Longrightarrow> (domain x + domain_block y)>0"
     using domain_nonnegative add_nonneg_pos add_pos_nonneg domain_block_nonnegative 
     by metis 
  from this  
        show "((domain_block(x#Nil)) > 0) \<or> ((domain_block y) > 0) 
                                         \<Longrightarrow> (domain_block (x#y) > 0)" 
             by auto
 qed
   
 lemma domain_additive:  "(domain_block (x\<otimes>y))= (domain_block x) + (domain_block y)"
   by (induction x)(auto)
 
 
 lemma codomain_additive:   "(codomain_block (x\<otimes>y))= (codomain_block x) + (codomain_block y)"
   by (induction x)(auto)
 
 
 lemma domain_zero_sum: assumes "(domain_block x) + (domain_block y) = 0"
 shows "domain_block x = 0" and "domain_block y = 0"
  using domain_block_nonnegative add_nonneg_eq_0_iff assms
  apply metis
  by (metis add_nonneg_eq_0_iff assms domain_block_nonnegative)
 
-lemma domain_block_positive: assumes "domain_block y>0" or "domain_block y>0"
+lemma domain_block_positive: fixes or assumes "domain_block y>0" or "domain_block y>0"
 shows "(domain_block (x\<otimes>y)) > 0"
  apply (simp add: domain_additive)
  by (metis assms(1) domain_additive domain_block_nonnegative domain_zero_sum(2) less_le)
 
-lemma codomain_block_positive: assumes "codomain_block y>0" or "codomain_block y>0"
+lemma codomain_block_positive: fixes or assumes "codomain_block y>0" or "codomain_block y>0"
 shows "(codomain_block (x\<otimes>y)) > 0"
  apply (simp add: codomain_additive)
  using  assms(1) codomain_additive codomain_block_nonnegative eq_neg_iff_add_eq_0 
         le_less_trans less_le neg_less_0_iff_less
  by (metis)
 
 text\<open>We prove that if the first count of a block is zero, then it is composed of cups and empty bricks. In
 order to do that we define the functions brick-is-cup and is-cup which check if a given block is 
 composed of cups or if the blocks are composed of blocks\<close>
 
 primrec brick_is_cup::"brick \<Rightarrow> bool"
 where
 "brick_is_cup vert = False"|
 "brick_is_cup cup = True"|
 "brick_is_cup cap = False"|
 "brick_is_cup over = False"|
 "brick_is_cup under = False"
 
 
 primrec is_cup::"block \<Rightarrow> bool"
 where
 "is_cup [] = True"|
 "is_cup (x#y) = (if (x= cup) then (is_cup y) else False)"
 
 
 lemma brickcount_zero_implies_cup:"(domain x= 0) \<Longrightarrow> (x = cup)"
  by (cases x) (auto)  
 
 lemma brickcount_zero_implies_brick_is_cup:"(domain x= 0) \<Longrightarrow> (brick_is_cup x)"
  by (cases x) (auto)  
 
 
 lemma domain_zero_implies_is_cup:"(domain_block x= 0) \<Longrightarrow> (is_cup x)"
 proof(induction x)
  case Nil
   show ?case by auto
   next
  case (Cons a y)
   show ?case 
   proof-
    have step1: "domain_block (a # y) =  (domain a) + (domain_block y)" 
                by auto
    with domain_zero_sum have"domain_block y = 0" 
                by (metis (full_types) Cons.prems domain_block_nonnegative domain_positive leD neq_iff)
    then have step2: "(is_cup y)" 
                using Cons.IH by (auto) 
    with step1 and domain_zero_sum  
             have "domain a= 0" 
                        using Cons.prems \<open>domain_block y = 0\<close> by linarith
    then have "brick_is_cup a" 
                using brickcount_zero_implies_brick_is_cup by auto
    then have "a=cup" 
         using brick_is_cup_def by (metis \<open>domain a = 0\<close> brickcount_zero_implies_cup)
    with step2 have "is_cup (a#y)" 
         using is_cup_def by auto
    then show ?case by auto
  qed
 qed
 
 
 text\<open>We need a function that checks if a wall represents a knot diagram.\<close>
 
 primrec is_tangle_diagram::"wall \<Rightarrow>  bool"
 where
 "is_tangle_diagram (basic x) = True"
 |"is_tangle_diagram (x*xs) = (if is_tangle_diagram xs
                                then (codomain_block x = domain_wall xs) 
                                else False)"
 
 
 definition is_link_diagram::"wall \<Rightarrow>  bool"
 where
 "is_link_diagram x \<equiv> (if (is_tangle_diagram x) 
                         then (abs (domain_wall x) + abs(codomain_wall x) = 0) 
                          else False)"
 
 
 end
diff --git a/thys/Monad_Normalisation/Monad_Normalisation_Test.thy b/thys/Monad_Normalisation/Monad_Normalisation_Test.thy
--- a/thys/Monad_Normalisation/Monad_Normalisation_Test.thy
+++ b/thys/Monad_Normalisation/Monad_Normalisation_Test.thy
@@ -1,269 +1,269 @@
 (*  Title:      Monad_Normalisation_Test.thy
     Author:     Manuel Eberl, TU München
     Author:     Andreas Lochbihler, ETH Zurich
     Author:     Joshua Schneider, ETH Zurich
 *)
 
 theory Monad_Normalisation_Test
 imports Monad_Normalisation
 begin
 
 section \<open>Tests and examples\<close>
 
 context includes monad_normalisation
 begin
 
 lemma
   assumes "f = id"
   shows
     "do {x \<leftarrow> B; z \<leftarrow> C x; d \<leftarrow> E z x; a \<leftarrow> D z x; y \<leftarrow> A; return_pmf (x,y)} =
      do {y \<leftarrow> A; x \<leftarrow> B; z \<leftarrow> C x; a \<leftarrow> D z x; d \<leftarrow> E z x; return_pmf (f (x,y))}"
 apply (simp)
 apply (simp add: assms)
 done
 
 lemma "(do {a \<leftarrow> E; b \<leftarrow> E; w \<leftarrow> B b a; z \<leftarrow> B a b; return_pmf (w,z)}) =
        (do {a \<leftarrow> E; b \<leftarrow> E; z \<leftarrow> B a b; w \<leftarrow> B b a; return_pmf (w,z)})"
 by (simp)
 
 lemma "(do {a \<leftarrow> E; b \<leftarrow> E; w \<leftarrow> B b a; z \<leftarrow> B a b; return_pmf (w,z)}) =
        (do {a \<leftarrow> E; b \<leftarrow> E; z \<leftarrow> B a b; w \<leftarrow> B b a; return_pmf (w,z)})"
 by (simp)
 
 lemma "do {y \<leftarrow> A; x \<leftarrow> A; z \<leftarrow> B x y y; w \<leftarrow> B x x y; Some (x,y)} =
        do {x \<leftarrow> A; y \<leftarrow> A; z \<leftarrow> B x x y; w \<leftarrow> B x y y; Some (x,y)}"
 by (simp)
 
 lemma "do {y \<leftarrow> A; x \<leftarrow> A; z \<leftarrow> B x y y; w \<leftarrow> B x x y; {x,y}} =
        do {x \<leftarrow> A; y \<leftarrow> A; z \<leftarrow> B x x y; w \<leftarrow> B x y y; {x,y}}"
 by (simp)
 
 lemma "do {y \<leftarrow> A; x \<leftarrow> A; z \<leftarrow> B x y y; w \<leftarrow> B x x y; return_pmf (x,y)} =
        do {x \<leftarrow> A; y \<leftarrow> A; z \<leftarrow> B x x y; w \<leftarrow> B x y y; return_pmf (x,y)}"
 by (simp)
 
 lemma "do {x \<leftarrow> A 0; y \<leftarrow> A x; w \<leftarrow> B y y; z \<leftarrow> B x y; a \<leftarrow> C; Predicate.single (a,a)} =
        do {x \<leftarrow> A 0; y \<leftarrow> A x; z \<leftarrow> B x y; w \<leftarrow> B y y; a \<leftarrow> C; Predicate.single (a,a)}"
 by (simp)
 
 lemma "do {x \<leftarrow> A 0; y \<leftarrow> A x; z \<leftarrow> B x y; w \<leftarrow> B y y; a \<leftarrow> C; return_pmf (a,a)} =
        do {x \<leftarrow> A 0; y \<leftarrow> A x; z \<leftarrow> B y y; w \<leftarrow> B x y; a \<leftarrow> C; return_pmf (a,a)}"
 by (simp)
 
 lemma "do {x \<leftarrow> B; z \<leftarrow> C x; d \<leftarrow> E z x; a \<leftarrow> D z x; y \<leftarrow> A; return_pmf (x,y)} =
        do {y \<leftarrow> A; x \<leftarrow> B; z \<leftarrow> C x; a \<leftarrow> D z x; d \<leftarrow> E z x; return_pmf (x,y)}"
 by (simp)
 
 
 no_adhoc_overloading Monad_Syntax.bind bind_pmf
 
 context
   fixes \<A>1 :: "'a \<Rightarrow> (('a \<times> 'a) \<times> 'b) spmf"
   and \<A>2 :: "'a \<times> 'a \<Rightarrow> 'b \<Rightarrow> bool spmf"
   and sample_uniform :: "nat \<Rightarrow> nat spmf"
   and order :: "'a \<Rightarrow> nat"
 begin
 
 lemma 
   "do {
       x \<leftarrow> sample_uniform (order \<G>);
       y \<leftarrow> sample_uniform (order \<G>);
       z \<leftarrow> sample_uniform (order \<G>);
       b \<leftarrow> coin_spmf;
       ((msg1, msg2), \<sigma>) \<leftarrow> \<A>1 (f x);
       _ :: unit \<leftarrow> assert_spmf (valid_plain msg1 \<and> valid_plain msg2);
       guess \<leftarrow> \<A>2 (f y, xor (f z) (if b then msg1 else msg2)) \<sigma>;
       return_spmf (guess \<longleftrightarrow> b)
     } = do {
       x \<leftarrow> sample_uniform (order \<G>);
       y \<leftarrow> sample_uniform (order \<G>);
       ((msg1, msg2), \<sigma>) \<leftarrow> \<A>1 (f x);
       _ :: unit \<leftarrow> assert_spmf (valid_plain msg1 \<and> valid_plain msg2);
       b \<leftarrow> coin_spmf;
       x \<leftarrow> sample_uniform (order \<G>);
       guess \<leftarrow> \<A>2 (f y, xor (f x) (if b then msg1 else msg2)) \<sigma>;
       return_spmf (guess \<longleftrightarrow> b)
-    }"
+    }" for xor
 by (simp add: split_def)
 
 lemma
   "do {
       x \<leftarrow> sample_uniform (order \<G>);
       xa \<leftarrow> sample_uniform (order \<G>);
       x \<leftarrow> \<A>1 (f x);
       case x of
       (x, xb) \<Rightarrow>
         (case x of
          (msg1, msg2) \<Rightarrow>
            \<lambda>\<sigma>. do {
                 a \<leftarrow> assert_spmf (valid_plain msg1 \<and> valid_plain msg2);
                 x \<leftarrow> coin_spmf;
                 xaa \<leftarrow> map_spmf f (sample_uniform (order \<G>));
                 guess \<leftarrow> \<A>2 (f xa, xaa) \<sigma>;
                 return_spmf (guess \<longleftrightarrow> x)
               })
          xb
     } = do {
       x \<leftarrow> sample_uniform (order \<G>);
       xa \<leftarrow> sample_uniform (order \<G>);
       x \<leftarrow> \<A>1 (f x);
       case x of
       (x, xb) \<Rightarrow>
         (case x of
          (msg1, msg2) \<Rightarrow>
            \<lambda>\<sigma>. do {
                 a \<leftarrow> assert_spmf (valid_plain msg1 \<and> valid_plain msg2);
                 z \<leftarrow> map_spmf f (sample_uniform (order \<G>));
                 guess \<leftarrow> \<A>2 (f xa, z) \<sigma>;
                 map_spmf ((\<longleftrightarrow>) guess) coin_spmf
               })
          xb
     }"
 by (simp add: map_spmf_conv_bind_spmf)
 
 lemma elgamal_step3:
   "do {
       x \<leftarrow> sample_uniform (order \<G>);
       y \<leftarrow> sample_uniform (order \<G>);
       b \<leftarrow> coin_spmf;
       p \<leftarrow> \<A>1 (f x);
       _ \<leftarrow> assert_spmf (valid_plain (fst (fst p)) \<and> valid_plain (snd (fst p)));
       guess \<leftarrow>
         \<A>2 (f y, xor (f (x * y)) (if b then fst (fst p) else snd (fst p)))
          (snd p);
       return_spmf (guess \<longleftrightarrow> b)
     }  = do {
       y \<leftarrow> sample_uniform (order \<G>);
       b \<leftarrow> coin_spmf;
       p \<leftarrow> \<A>1 (f y);
       _ \<leftarrow> assert_spmf (valid_plain (fst (fst p)) \<and> valid_plain (snd (fst p)));
       ya \<leftarrow> sample_uniform (order \<G>);
       b' \<leftarrow> \<A>2 (f ya,
                  xor (f (y * ya)) (if b then fst (fst p) else snd (fst p)))
              (snd p);
       return_spmf (b' \<longleftrightarrow> b)
-    }"
+    }" for xor
 by (simp)
 
 end
 
 text \<open>Distributivity\<close>
 
 lemma
   "do {
       x \<leftarrow> A :: nat spmf;
       a \<leftarrow> B;
       b \<leftarrow> B;
       if a = b then do {
         return_spmf x
       } else do {
         y \<leftarrow> C;
         return_spmf (x + y)
       }
    } = do {
       a \<leftarrow> B;
       b \<leftarrow> B;
       if b = a then A else do {
         y \<leftarrow> C;
         x \<leftarrow> A;
         return_spmf (y + x)
       }
    }"
 by (simp add: add.commute cong: if_cong)
 
 lemma
   "do {
       x \<leftarrow> A :: nat spmf;
       p \<leftarrow> do {
         a \<leftarrow> B;
         b \<leftarrow> B;
         return_spmf (a, b)
       };
       q \<leftarrow> coin_spmf;
       if q then do {
         return_spmf (x + fst p)
       } else do {
         y \<leftarrow> C;
         return_spmf (y + snd p)
       }
    } = do {
       q \<leftarrow> coin_spmf;
       if q then do {
         x \<leftarrow> A;
         a \<leftarrow> B;
         _ \<leftarrow> B;
         return_spmf (x + a)
       } else do {
         y \<leftarrow> C;
         a \<leftarrow> B;
         _ \<leftarrow> B;
         _ \<leftarrow> A;
         return_spmf (y + a)
       }
    }"
 by (simp cong: if_cong)
 
 lemma
   fixes f :: "nat \<Rightarrow> nat \<Rightarrow> nat + nat"
   shows
   "do {
       x \<leftarrow> (A::nat set);
       a \<leftarrow> B;
       b \<leftarrow> B;
       case f a b of
         Inl c \<Rightarrow> {x}
       | Inr c \<Rightarrow> do {
           y \<leftarrow> C x;
           {(x + y + c)}
         }
    } = do {
       a \<leftarrow> B;
       b \<leftarrow> B;
       case f b a of
         Inl c \<Rightarrow> A
       | Inr c \<Rightarrow> do {
           x \<leftarrow> A;
           y \<leftarrow> C x;
           {(y + c + x)}
       }
    }"
 by (simp add: add.commute add.left_commute cong: sum.case_cong)
 
 
 section \<open>Limits\<close>
 
 text \<open>
   The following example shows that the combination of monad normalisation and regular ordered
   rewriting is not necessarily confluent.
 \<close>
 
 lemma "do {a \<leftarrow> A; b \<leftarrow> A; Some (a \<and> b, b)} =
        do {a \<leftarrow> A; b \<leftarrow> A; Some (a \<and> b, a)}"
 apply (simp add: conj_comms)?       \<comment> \<open>no progress made\<close>
 apply (rewrite option_bind_commute) \<comment> \<open>force a particular binder order\<close>
 apply (simp only: conj_comms)
 done
 
 text \<open>
   The next example shows that even monad normalisation alone is not confluent because 
   the term ordering prevents the reordering of \<open>f A\<close> with \<open>f B\<close>.
   But if we change \<open>A\<close> to \<open>E\<close>, then the reordering works as expected.
 \<close>
 
 lemma
   "do {a \<leftarrow> f A; b \<leftarrow> f B; c \<leftarrow> D b; d \<leftarrow> f C; F a c d} = 
    do {b \<leftarrow> f B; c \<leftarrow> D b; a \<leftarrow> f A; d \<leftarrow> f C; F a c d}"
   for f :: "'b \<Rightarrow> 'a option" and D :: "'a \<Rightarrow> 'a option"
   apply(simp)? \<comment> \<open>no progress made\<close>
   apply(subst option_bind_commute, subst (2) option_bind_commute, rule refl)
   done
 
 lemma
   "do {a \<leftarrow> f E; b \<leftarrow> f B; c \<leftarrow> D b; d \<leftarrow> f C; F a c d} = 
    do {b \<leftarrow> f B; c \<leftarrow> D b; a \<leftarrow> f E; d \<leftarrow> f C; F a c d}"
   for f :: "'b \<Rightarrow> 'a option" and D :: "'a \<Rightarrow> 'a option"
   by simp
 
 end
 
 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,445 @@
 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 boolean_algebra) sup_neg_inf:
+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,320 +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 boolean_algebra \<subseteq> ba_dual: dual "uminus"  
+sublocale Lattices.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 boolean_algebra \<subseteq> badual: boolean_algebra_with_dual _ _ _ _ _ _ _ _ uminus
+sublocale Lattices.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,1269 @@
 (* 
   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 boolean_algebra
+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 boolean_algebra
+context Lattices.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)
 
 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)
 
 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)  
 
 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)
 
 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)
 
 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 boolean_algebra \<subseteq> dual_boolean_algebra: boolean_algebra "\<lambda>x y. x \<squnion> -y" uminus sup "(\<ge>)" "(>)" inf \<top> \<bottom>
+sublocale Lattices.boolean_algebra \<subseteq> dual_boolean_algebra: Lattices.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/Order_Lattice_Props_Wenzel.thy b/thys/Order_Lattice_Props/Order_Lattice_Props_Wenzel.thy
--- a/thys/Order_Lattice_Props/Order_Lattice_Props_Wenzel.thy
+++ b/thys/Order_Lattice_Props/Order_Lattice_Props_Wenzel.thy
@@ -1,289 +1,280 @@
 (* 
   Title: Duality Based on a Data Type
   Author: Georg Struth 
   Maintainer:Georg Struth <g.struth@sheffield.ac.uk> 
 *)
 
 section \<open>Duality Based on a Data Type\<close>
 
 theory Order_Lattice_Props_Wenzel
   imports Main 
           "HOL-Library.Lattice_Syntax"
 
 begin
 
 subsection \<open>Wenzel's Approach Revisited\<close>
 
 text \<open>This approach is similar to, but inferior to the explicit class-based one. The main caveat is that duality is not involutive 
 with this approach, and this allows dualising less theorems.\<close>
 
 text \<open>I copy Wenzel's development \cite{Wenzel} in this subsection and extend it with additional properties. I show only the most important properties.\<close>
 
 datatype 'a dual = dual (un_dual: 'a) ("\<partial>")
 
 notation un_dual ("\<partial>\<^sup>-")
 
 lemma dual_inj: "inj \<partial>"
   using injI by fastforce
 
 lemma dual_surj: "surj \<partial>"
   using dual.exhaust_sel by blast
 
 lemma dual_bij: "bij \<partial>"
   by (simp add: bijI dual_inj dual_surj)
 
 text \<open>Dual is not idempotent, and I see no way of imposing this condition. Yet at least an inverse exists --- namely un-dual..\<close>
 
 lemma dual_inv1 [simp]: "\<partial>\<^sup>- \<circ> \<partial> = id"
   by fastforce
 
 lemma dual_inv2 [simp]: "\<partial> \<circ> \<partial>\<^sup>- = id"
   by fastforce
 
 lemma dual_inv_inj: "inj \<partial>\<^sup>-"
   by (simp add: dual.expand injI)
 
 lemma dual_inv_surj: "surj \<partial>\<^sup>-"
   by (metis dual.sel surj_def)
 
 lemma dual_inv_bij: "bij \<partial>\<^sup>-"
   by (simp add: bij_def dual_inv_inj dual_inv_surj)
 
 lemma dual_iff: "(\<partial> x = y) \<longleftrightarrow> (x = \<partial>\<^sup>- y)"
   by fastforce
 
 text \<open>Isabelle data types come with a number of generic functions.\<close>
 
 text \<open>The functor map-dual lifts functions to dual types. Isabelle's generic definition is not straightforward to 
 understand and use. Yet conceptually it can be explained as follows.\<close>
 
 lemma map_dual_def_var [simp]: "(map_dual::('a \<Rightarrow> 'b) \<Rightarrow> 'a dual \<Rightarrow> 'b dual) f = \<partial> \<circ> f \<circ> \<partial>\<^sup>-"  
   unfolding fun_eq_iff comp_def by (metis dual.map_sel dual_iff)
 
 lemma map_dual_def_var2: "\<partial>\<^sup>- \<circ> map_dual f = f \<circ> \<partial>\<^sup>-"
   by (simp add: rewriteL_comp_comp)
 
 lemma map_dual_func1: "map_dual (f \<circ> g) = map_dual f \<circ> map_dual g"
   unfolding fun_eq_iff comp_def by (metis dual.exhaust dual.map) 
 
 lemma map_dual_func2 : "map_dual id = id"
   by simp
 
 text \<open>The functor map-dual has an inverse functor as well.\<close>
 
 definition map_dual_inv :: "('a dual \<Rightarrow> 'b dual) => ('a => 'b)" where
   "map_dual_inv f = \<partial>\<^sup>- \<circ> f \<circ> \<partial>"
 
 lemma map_dual_inv_func1: "map_dual_inv id = id"
   by (simp add: map_dual_inv_def)
 
 lemma map_dual_inv_func2: "map_dual_inv (f \<circ> g) = map_dual_inv f \<circ> map_dual_inv g"
   unfolding fun_eq_iff comp_def map_dual_inv_def by (metis dual_iff)
 
 lemma map_dual_inv1: "map_dual \<circ> map_dual_inv = id"
   unfolding fun_eq_iff map_dual_def_var map_dual_inv_def comp_def id_def
   by (metis dual_iff) 
 
 lemma map_dual_inv2: "map_dual_inv \<circ> map_dual = id"
   unfolding fun_eq_iff map_dual_def_var map_dual_inv_def comp_def id_def
   by (metis dual_iff) 
 
 text \<open>Hence dual is an isomorphism between categories.\<close>
 
 lemma subset_dual: "(\<partial> ` X = Y) \<longleftrightarrow> (X = \<partial>\<^sup>- ` Y)"
   by (metis dual_inj image_comp image_inv_f_f inv_o_cancel dual_inv2)
 
 lemma subset_dual1: "(X \<subseteq> Y) \<longleftrightarrow> (\<partial> ` X \<subseteq> \<partial> ` Y)"
   by (simp add: dual_inj inj_image_subset_iff) 
 
 lemma dual_ball: "(\<forall>x \<in> X. P (\<partial> x)) \<longleftrightarrow> (\<forall>y \<in> \<partial> ` X. P y)"
   by simp
 
 lemma dual_inv_ball: "(\<forall>x \<in> X. P (\<partial>\<^sup>- x)) \<longleftrightarrow> (\<forall>y \<in> \<partial>\<^sup>- ` X. P y)"
   by simp
 
 lemma dual_all: "(\<forall>x. P (\<partial> x)) \<longleftrightarrow> (\<forall>y. P y)"
   by (metis dual.collapse)
 
 lemma dual_inv_all: "(\<forall>x. P (\<partial>\<^sup>- x)) \<longleftrightarrow> (\<forall>y. P y)"
   by (metis dual_inv_surj surj_def)
 
 lemma dual_ex: "(\<exists>x. P (\<partial> x)) \<longleftrightarrow> (\<exists>y. P y)"  
   by (metis UNIV_I bex_imageD dual_surj)
 
 lemma dual_inv_ex: "(\<exists>x. P (\<partial>\<^sup>- x)) \<longleftrightarrow> (\<exists>y. P y)"
   by (metis dual.sel)
 
 lemma dual_Collect: "{\<partial> x |x. P (\<partial> x)} = {y. P y}"
   by (metis dual.exhaust)
 
 lemma dual_inv_Collect: "{\<partial>\<^sup>- x |x. P (\<partial>\<^sup>- x)} = {y. P y}"
   by (metis dual.collapse dual.inject)
 
 lemma fun_dual1: "(f \<circ> \<partial> = g) \<longleftrightarrow> (f = g \<circ> \<partial>\<^sup>-)"
   by auto
 
 lemma fun_dual2: "(\<partial> \<circ> f = g) \<longleftrightarrow> (f = \<partial>\<^sup>- \<circ> g)"
   by auto
 
 lemma fun_dual3: "(f \<circ> (`) \<partial> = g) \<longleftrightarrow> (f = g \<circ> (`) \<partial>\<^sup>-)"
   unfolding fun_eq_iff comp_def by (metis subset_dual)
 
 lemma fun_dual4: "(f = \<partial>\<^sup>- \<circ> g \<circ> (`) \<partial>) \<longleftrightarrow> (\<partial> \<circ> f \<circ> (`) \<partial>\<^sup>- = g)"
   by (metis fun_dual2 fun_dual3 o_assoc)
 
 text \<open>The next facts show incrementally that the dual of a complete lattice is a complete lattice.
 This follows once again Wenzel.\<close>
 
 instantiation dual :: (ord) ord
 begin  
 
 definition less_eq_dual_def: "(\<le>) = rel_dual (\<ge>)"
 
 definition less_dual_def: "(<) = rel_dual (>)"
 
 instance..
 
 end
 
 lemma less_eq_dual_def_var: "(x \<le> y) = (\<partial>\<^sup>- y \<le> \<partial>\<^sup>- x)"
   apply (rule antisym)
   apply (simp add: dual.rel_sel less_eq_dual_def)
   by (simp add: dual.rel_sel less_eq_dual_def)
 
 lemma less_dual_def_var: "(x < y) = (\<partial>\<^sup>- y < \<partial>\<^sup>- x)"
   by (simp add: dual.rel_sel less_dual_def) 
 
 instance dual :: (preorder) preorder
   apply standard
   apply (simp add: less_dual_def_var less_eq_dual_def_var less_le_not_le)
   apply (simp add: less_eq_dual_def_var)
   by (meson less_eq_dual_def_var order_trans)
  
 instance dual :: (order) order
   by (standard, simp add: dual.expand less_eq_dual_def_var)
 
 lemma dual_anti: "x \<le> y \<Longrightarrow> \<partial> y \<le> \<partial> x" 
   by (simp add: dual_inj less_eq_dual_def the_inv_f_f)
 
 lemma dual_anti_iff: "(x \<le> y) = (\<partial> y \<le> \<partial> x)"
   by (simp add: dual_inj less_eq_dual_def the_inv_f_f)
 
 text \<open>map-dual does not map isotone functions to antitone ones. It simply lifts the type!\<close>
 
 lemma "mono f \<Longrightarrow> mono (map_dual f)"
   unfolding map_dual_def_var mono_def by (metis comp_apply dual_anti less_eq_dual_def_var)
 
 instantiation dual :: (lattice) lattice
 begin
 
 definition inf_dual_def: "x \<sqinter> y = \<partial> (\<partial>\<^sup>- x \<squnion> \<partial>\<^sup>- y)"
 
 definition sup_dual_def: "x \<squnion> y = \<partial> (\<partial>\<^sup>- x \<sqinter> \<partial>\<^sup>- y)"
 
 instance
   by (standard, simp_all add: dual_inj inf_dual_def sup_dual_def less_eq_dual_def_var the_inv_f_f)
 
 end
 
 instantiation dual :: (complete_lattice) complete_lattice
 begin
 
 definition Inf_dual_def: "Inf = \<partial> \<circ> Sup \<circ> (`) \<partial>\<^sup>-"
 
 definition Sup_dual_def: "Sup = \<partial> \<circ> Inf \<circ> (`) \<partial>\<^sup>-"
 
 definition bot_dual_def: "\<bottom> = \<partial> \<top>"
 
 definition top_dual_def: "\<top> = \<partial> \<bottom>"
 
 instance
    by (standard, simp_all add: Inf_dual_def top_dual_def Sup_dual_def bot_dual_def dual_inj le_INF_iff SUP_le_iff INF_lower SUP_upper less_eq_dual_def_var the_inv_f_f)
 
 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}"
 
 end
 
 subsection \<open>Examples that Do Not Dualise\<close>
 
 text \<open>Filtered and directed sets are dual.\<close>
 
 text \<open>Proofs could be simplified if dual was idempotent.\<close>
 
 lemma filtered_directed_dual: "filtered \<circ> (`) \<partial> = directed"
 proof-
   {fix X::"'a set"
     have "(filtered \<circ> (`) \<partial>) X = (\<forall>Y. finite (\<partial>\<^sup>- ` Y) \<and> \<partial>\<^sup>- ` Y \<subseteq> X \<longrightarrow> (\<exists>x \<in> X.\<forall>y \<in> (\<partial>\<^sup>- ` Y). \<partial> x \<le> \<partial> y))"
       unfolding filtered_def comp_def by (simp, metis dual_iff finite_subset_image subset_dual subset_dual1)
     also have "... = (\<forall>Y. finite Y \<and> Y \<subseteq> X \<longrightarrow> (\<exists>x \<in> X.\<forall>y \<in> Y. y \<le> x))"
       by (metis dual_anti_iff dual_inv_surj finite_subset_image top.extremum)
     finally have "(filtered \<circ> (`) \<partial>) X = directed X"
       using directed_def by auto}
   thus ?thesis
     unfolding fun_eq_iff by simp 
 qed
 
 lemma directed_filtered_dual: "directed \<circ> (`) \<partial> = filtered"
 proof-
   {fix X::"'a set"
     have "(directed \<circ> (`) \<partial>) X = (\<forall>Y. finite (\<partial>\<^sup>- ` Y) \<and> \<partial>\<^sup>- ` Y \<subseteq> X \<longrightarrow> (\<exists>x \<in> X.\<forall>y \<in> (\<partial>\<^sup>- ` Y). \<partial> y \<le> \<partial> x))"
       unfolding directed_def comp_def by (simp, metis dual_iff finite_subset_image subset_dual subset_dual1)
   also have "... = (\<forall>Y. finite Y \<and> Y \<subseteq> X \<longrightarrow> (\<exists>x \<in> X.\<forall>y \<in> Y. x \<le> y))"
     unfolding dual_anti_iff[symmetric] by (metis dual_inv_surj finite_subset_image top_greatest)
   finally have "(directed \<circ> (`) \<partial>) X = filtered X"
     using filtered_def by auto}
   thus ?thesis
     unfolding fun_eq_iff by simp
 qed
 
 text \<open>This example illustrates the deficiency of the approach. In the class-based approach the second proof is trivial.\<close>
 
 text \<open>The next example shows that this is a systematic problem.\<close>
 
 lemma downset_set_upset_set_dual: "(`) \<partial> \<circ> \<Down> = \<Up> \<circ> (`) \<partial>"
   proof-
     {fix X::"'a set"
   have "((`) \<partial> \<circ> \<Down>) X = {\<partial> y |y. \<exists>x \<in> X. y \<le> x}"
     by (simp add: downset_set_def setcompr_eq_image)
   also have "... = {\<partial> y |y. \<exists>x \<in> X. \<partial> x \<le> \<partial> y}"
     by (meson dual_anti_iff)
   also have "... = {y. \<exists>x \<in> \<partial> ` X. x \<le> y}"
     by (metis (mono_tags, opaque_lifting) dual.exhaust image_iff)
   finally have "((`) \<partial> \<circ> \<Down>) X = (\<Up> \<circ> (`) \<partial>) X"
     by (simp add: upset_set_def)}
   thus ?thesis
     unfolding fun_eq_iff by simp
 qed
 
 lemma upset_set_downset_set_dual: "(`) \<partial> \<circ> \<Up> = \<Down> \<circ> (`) \<partial>"
   unfolding downset_set_def upset_set_def fun_eq_iff comp_def
   apply (safe, force simp: dual_anti)
   by (metis (mono_tags, lifting) dual.exhaust dual_anti_iff mem_Collect_eq rev_image_eqI)
 
 end
-
-
-
-
-
-
-
-
-
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,625 +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 boolean_algebra
+context Lattices.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)
    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 :: (boolean_algebra) boolean_algebra
+instantiation atoms :: (Lattices.boolean_algebra) Lattices.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) 
   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)
   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)
   hence "\<Squnion>Y \<sqinter> z = \<bottom>"
     using Sup_least meet_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/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 boolean_algebra
+context Lattices.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: boolean_algebra "\<lambda>f g. f \<sqinter> g\<^sup>c" mat_complement "(\<sqinter>)" "(\<le>)" "(<)" mat_add mat_zero mat_top
+interpretation matrix_ba: Lattices.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 boolean_algebra
+context Lattices.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 boolean_algebra begin
+context Lattices.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 boolean_algebra begin
+context Lattices.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 boolean_algebra begin
+context Lattices.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: 
-    boolean_algebra minus uminus "(\<sqinter>)" "(\<sqsubseteq>)" "(\<sqsubset>)" "(\<squnion>)" \<bottom> \<top>
+    Lattices.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 boolean_algebra begin
+context Lattices.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: 
-    boolean_algebra minus uminus "(\<sqinter>)" "(\<sqsubseteq>)" "(\<sqsubset>)" "(\<squnion>)" \<bottom> \<top>
+    Lattices.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: 
-    boolean_algebra minus uminus "(\<sqinter>)" "(\<sqsubseteq>)" "(\<sqsubset>)" "(\<squnion>)" \<bottom> \<top>
+    Lattices.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/Statecharts/Expr.thy b/thys/Statecharts/Expr.thy
--- a/thys/Statecharts/Expr.thy
+++ b/thys/Statecharts/Expr.thy
@@ -1,229 +1,231 @@
 (*  Title:      statecharts/SA/Expr.thy
 
     Author:     Steffen Helke, Software Engineering Group
     Copyright   2010 Technische Universitaet Berlin
 *)
 
 section \<open>Label Expressions\<close>
 theory Expr
 imports Update
 begin
 
+no_notation not ("NOT")
+
 datatype ('s,'e)expr = true
                         | In 's
                         | En 'e
                         | NOT "('s,'e)expr"
                         | And "('s,'e)expr" "('s,'e)expr"
                         | Or  "('s,'e)expr" "('s,'e)expr"
  
 type_synonym 'd guard = "('d data) => bool"
 type_synonym ('e,'d)action = "('e set * 'd pupdate)"
 type_synonym ('s,'e,'d)label = "(('s,'e)expr * 'd guard * ('e,'d)action)"
 type_synonym ('s,'e,'d)trans = "('s * ('s,'e,'d)label * 's)"
 
 primrec
    eval_expr :: "[('s set * 'e set), ('s,'e)expr] \<Rightarrow> bool" where 
      "eval_expr sc true          = True"
    | "eval_expr sc (En ev)       = (ev \<in> snd sc)"
    | "eval_expr sc (In st)       = (st \<in> fst sc)"
    | "eval_expr sc (NOT e1)      = (\<not> (eval_expr sc e1))"
    | "eval_expr sc (And e1 e2)   = ((eval_expr sc e1) \<and> (eval_expr sc e2))"
    | "eval_expr sc (Or  e1 e2)   = ((eval_expr sc e1) \<or> (eval_expr sc e2))"
 
 primrec
    ExprEvents :: "('s,'e)expr \<Rightarrow> 'e set" where
       "ExprEvents true        = {}"
    |  "ExprEvents (En ev)     = {ev}"
    |  "ExprEvents (In st)     = {}"
    |  "ExprEvents (NOT e)     = (ExprEvents e)"
    |  "ExprEvents (And e1 e2) = ((ExprEvents e1) \<union> (ExprEvents e2))"
    |  "ExprEvents (Or  e1 e2) = ((ExprEvents e1) \<union> (ExprEvents e2))"
 
 (* atomar propositions for Sequential Automata, will be necessary for CTL-interpretation *)
 
 datatype ('s, 'e, dead 'd)atomar =
                           TRUE
                           | FALSE
                           | IN 's
                           | EN 'e
                           | VAL "'d data => bool"
 
 definition
   source     :: "('s,'e,'d)trans => 's" where
   "source t  = fst t"
 
 definition
    Source     :: "('s,'e,'d)trans set => 's set" where
   "Source T == source ` T"
 
 definition
    target     :: "('s,'e,'d)trans => 's" where
   "target t  = snd(snd t)"
 
 definition
    Target     :: "('s,'e,'d)trans set => 's set" where
   "Target T = target ` T"
 
 definition
    label      :: "('s,'e,'d)trans => ('s,'e,'d)label" where
   "label t  = fst (snd t)"
 
 definition
    Label      :: "('s,'e,'d)trans set => ('s,'e,'d)label set" where
   "Label T = label ` T"
 
 definition
    expr       :: "('s,'e,'d)label => ('s,'e)expr" where
   "expr  = fst"
 
 definition
    action     :: "('s,'e,'d)label  => ('e,'d)action" where
   "action = snd o snd"
 
 definition
    Action     :: "('s,'e,'d)label set => ('e,'d)action set" where
   "Action L = action ` L"
 
 definition
    pupdate     :: "('s,'e,'d)label => 'd pupdate" where
   "pupdate   = snd o action"
 
 definition
   PUpdate     :: "('s,'e,'d)label set => ('d pupdate) set" where
   "PUpdate L = pupdate ` L"
 
 definition
    actevent   :: "('s,'e,'d)label => 'e set" where
   "actevent  = fst o action"
 
 definition
    Actevent   :: "('s,'e,'d)label set => ('e set) set" where
   "Actevent L = actevent ` L"
 
 definition
    guard      :: "('s,'e,'d)label  => 'd guard" where  
   "guard = fst o snd"
 
 definition
    Guard      :: "('s,'e,'d)label set => ('d guard) set" where
   "Guard L = guard ` L"
 
 definition
    defaultexpr :: "('s,'e)expr" where 
   "defaultexpr = true"
 
 definition
    defaultaction :: "('e,'d)action" where
   "defaultaction = ({},DefaultPUpdate)"
 
 definition
    defaultguard :: "('d guard)" where
   "defaultguard = (\<lambda> d. True)"
 
 definition
    defaultlabel :: "('s,'e,'d)label" where
   "defaultlabel = (defaultexpr, defaultguard, defaultaction)"
 
 definition
    eval :: "[('s set * 'e set * 'd data), ('s,'e,'d)label] => bool"
                                                        ("_ |= _" [91,90]90) where
   "eval scd l = (let (s,e,d) = scd
                  in
                     ((eval_expr (s,e) (expr l)) \<and> ((guard l) d)))"
 
 lemma Source_EmptySet [simp]:
  "Source {} = {}"
 by (unfold Source_def, auto)
 
 lemma Target_EmptySet [simp]:
  "Target {} = {}"
 by (unfold Target_def, auto)
 
 lemma Label_EmptySet [simp]:
  "Label {} = {}"
 by (unfold Label_def, auto)
 
 lemma Action_EmptySet [simp]:
  "Action {} = {}"
 by (unfold Action_def, auto)
 
 lemma PUpdate_EmptySet [simp]:
  "PUpdate {} = {}"
 by (unfold PUpdate_def, auto)
 
 lemma Actevent_EmptySet [simp]:
  "Actevent {} = {}"
 by (unfold Actevent_def, auto)
 
 lemma Union_Actevent_subset:
   "\<lbrakk> m \<in> M; ((\<Union> (Actevent (Label (Union M)))) \<subseteq> (N::'a set)) \<rbrakk> \<Longrightarrow>
    ((\<Union> (Actevent (Label m))) \<subseteq> N)"
 by (unfold Actevent_def Label_def, auto)
 
 lemma action_select [simp]:
  "action (a,b,c) = c"
 by (unfold action_def, auto)
 
 lemma label_select [simp]:
  "label (a,b,c) = b"
 by (unfold label_def, auto)
 
 lemma target_select [simp]:
  "target (a,b,c) = c"
 by (unfold target_def, auto)
 
 lemma actevent_select [simp]:
  "actevent (a,b,(c,d)) = c"
 by (unfold actevent_def, auto)
 
 lemma pupdate_select [simp]:
  "pupdate (a,b,c,d) = d"
 by (unfold pupdate_def, auto)
 
 lemma source_select [simp]:
  "source (a,b) = a"
 by (unfold source_def, auto)
 
 lemma finite_PUpdate [simp]:
  "finite S \<Longrightarrow> finite(PUpdate S)"
 by (unfold PUpdate_def, auto)
 
 lemma finite_Label [simp]:
  "finite S \<Longrightarrow> finite(Label S)"
 by (unfold Label_def, auto)
 
 lemma fst_defaultaction [simp]:
  "fst defaultaction = {}" 
 by (unfold defaultaction_def, auto)
 
 lemma action_defaultlabel [simp]:
  "(action defaultlabel) = defaultaction" 
 by (unfold defaultlabel_def action_def, auto)
 
 lemma fst_defaultlabel [simp]:
  "(fst defaultlabel) = defaultexpr" 
 by (unfold defaultlabel_def, auto)
 
 lemma ExprEvents_defaultexpr [simp]:
  "(ExprEvents defaultexpr) = {}" 
 by (unfold defaultexpr_def, auto)
 
 lemma defaultlabel_defaultexpr [simp]:
  "expr defaultlabel = defaultexpr"
 by (unfold defaultlabel_def expr_def, auto)
 
 lemma target_Target [simp]:
   "t \<in> T \<Longrightarrow> target t \<in> Target T"
 by (unfold Target_def, auto)
 
 lemma Source_union : "Source s \<union> Source t = Source (s \<union> t)"
 apply (unfold Source_def)
 apply auto
 done
 
 lemma Target_union : "Target s \<union> Target t = Target (s \<union> t)"
 apply (unfold Target_def)
 apply auto
 done
 
 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 boolean_algebra
+context Lattices.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 boolean_algebra
+context Lattices.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/Linear_Order_Matrices.thy b/thys/Stone_Relation_Algebras/Linear_Order_Matrices.thy
--- a/thys/Stone_Relation_Algebras/Linear_Order_Matrices.thy
+++ b/thys/Stone_Relation_Algebras/Linear_Order_Matrices.thy
@@ -1,874 +1,873 @@
 (* Title:      Matrices over Bounded Linear Orders
    Author:     Walter Guttmann
    Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
 *)
 
 section \<open>Matrices over Bounded Linear Orders\<close>
 
 text \<open>
 In this theory we characterise relation-algebraic properties of matrices over bounded linear orders (for example, extended real numbers) in terms of the entries in the matrices.
 We consider, in particular, the following properties: univalent, injective, total, surjective, mapping, bijective, vector, covector, point, arc, reflexive, coreflexive, irreflexive, symmetric, antisymmetric, asymmetric.
 We also consider the effect of composition with the matrix of greatest elements and with coreflexives (tests).
 \<close>
 
 theory Linear_Order_Matrices
 
 imports Matrix_Relation_Algebras
 
 begin
 
 class non_trivial_linorder_stone_relation_algebra_expansion = linorder_stone_relation_algebra_expansion + non_trivial
 begin
 
 subclass non_trivial_bounded_order ..
 
 end
 
 text \<open>
 Before we look at matrices, we generalise selectivity to finite suprema.
 \<close>
 
 lemma linorder_finite_sup_selective:
   fixes f :: "'a::finite \<Rightarrow> 'b::linorder_stone_algebra_expansion"
   shows "\<exists>i . (\<Squnion>\<^sub>k f k) = f i"
   apply (induct rule: comp_inf.one_sup_induct)
   apply blast
   using sup_selective by fastforce
 
 lemma linorder_top_finite_sup:
   fixes f :: "'a::finite \<Rightarrow> 'b::linorder_stone_algebra_expansion"
   assumes "\<forall>k . f k \<noteq> top"
     shows "(\<Squnion>\<^sub>k f k) \<noteq> top"
   by (metis assms linorder_finite_sup_selective)
 
 text \<open>
 The following results show the effect of composition with the \<open>top\<close> matrix from the left and from the right.
 \<close>
 
 lemma comp_top_linorder_matrix:
   fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
   shows "(f \<odot> mtop) (i,j) = (\<Squnion>\<^sub>k f (i,k))"
   apply (unfold times_matrix_def top_matrix_def)
   by (metis (no_types, lifting) case_prod_conv comp_right_one one_def sup_monoid.sum.cong)
 
 lemma top_comp_linorder_matrix:
   fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
   shows "(mtop \<odot> f) (i,j) = (\<Squnion>\<^sub>k f (k,j))"
   apply (unfold times_matrix_def top_matrix_def)
   by (metis (no_types, lifting) case_prod_conv comp_left_one one_def sup_monoid.sum.cong)
 
 text \<open>
 We characterise univalent matrices: in each row, at most one entry may be different from \<open>bot\<close>.
 \<close>
 
 lemma univalent_linorder_matrix_1:
   fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
   assumes "matrix_stone_relation_algebra.univalent f"
       and "f (i,j) \<noteq> bot"
       and "f (i,k) \<noteq> bot"
     shows "j = k"
 proof -
   have "(f\<^sup>t \<odot> f) (j,k) = (\<Squnion>\<^sub>l (f\<^sup>t) (j,l) * f (l,k))"
     by (simp add: times_matrix_def)
   also have "... = (\<Squnion>\<^sub>l (f (l,j))\<^sup>T * f (l,k))"
     by (simp add: conv_matrix_def)
   also have "... = (\<Squnion>\<^sub>l f (l,j) * f (l,k))"
     by simp
   also have "... \<ge> f (i,j) * f (i,k)"
     using comp_inf.ub_sum by fastforce
   finally have "(f\<^sup>t \<odot> f) (j,k) \<noteq> bot"
     using assms(2,3) bot.extremum_uniqueI times_dense by fastforce
   hence "mone (j,k) \<noteq> (bot::'b)"
     by (metis assms(1) bot.extremum_uniqueI less_eq_matrix_def)
   thus ?thesis
     by (metis (mono_tags, lifting) case_prod_conv one_matrix_def)
 qed
 
 lemma univalent_linorder_matrix_2:
   fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
   assumes "\<forall>i j k . f (i,j) \<noteq> bot \<and> f (i,k) \<noteq> bot \<longrightarrow> j = k"
     shows "matrix_stone_relation_algebra.univalent f"
 proof -
   show "f\<^sup>t \<odot> f \<preceq> mone"
   proof (unfold less_eq_matrix_def, rule allI, rule prod_cases)
     fix j k
     show "(f\<^sup>t \<odot> f) (j,k) \<le> mone (j,k)"
     proof (cases "j = k")
       assume "j = k"
       thus ?thesis
         by (simp add: one_matrix_def)
     next
       assume "j \<noteq> k"
       hence "(\<Squnion>\<^sub>i f (i,j) * f (i,k)) = bot"
         by (metis (no_types, lifting) assms semiring.mult_not_zero sup_monoid.sum.neutral)
       thus ?thesis
         by (simp add: times_matrix_def conv_matrix_def)
     qed
   qed
 qed
 
 lemma univalent_linorder_matrix:
   fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
   shows "matrix_stone_relation_algebra.univalent f \<longleftrightarrow> (\<forall>i j k . f (i,j) \<noteq> bot \<and> f (i,k) \<noteq> bot \<longrightarrow> j = k)"
   using univalent_linorder_matrix_1 univalent_linorder_matrix_2 by auto
 
 text \<open>
 Injective matrices can then be characterised by applying converse: in each column, at most one entry may be different from \<open>bot\<close>.
 \<close>
 
 lemma injective_linorder_matrix:
   fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
   shows "matrix_stone_relation_algebra.injective f \<longleftrightarrow> (\<forall>i j k . f (j,i) \<noteq> bot \<and> f (k,i) \<noteq> bot \<longrightarrow> j = k)"
   by (unfold matrix_stone_relation_algebra.injective_conv_univalent univalent_linorder_matrix) (simp add: conv_matrix_def)
 
 text \<open>
 Next come total matrices: each row has a \<open>top\<close> entry.
 \<close>
 
 lemma total_linorder_matrix_1:
   fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
   assumes "matrix_stone_relation_algebra.total_var f"
     shows "\<exists>j . f (i,j) = top"
 proof -
   have "mone (i,i) \<le> (f \<odot> f\<^sup>t) (i,i)"
     using assms less_eq_matrix_def by blast
   hence "top = (f \<odot> f\<^sup>t) (i,i)"
     by (simp add: one_matrix_def top.extremum_unique)
   also have "... = (\<Squnion>\<^sub>j f (i,j) * (f\<^sup>t) (j,i))"
     by (simp add: times_matrix_def)
   also have "... = (\<Squnion>\<^sub>j f (i,j) * f (i,j))"
     by (simp add: conv_matrix_def)
   also have "... = (\<Squnion>\<^sub>j f (i,j))"
     by simp
   finally show ?thesis
     by (metis linorder_top_finite_sup)
 qed
 
 lemma total_linorder_matrix_2:
   fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
   assumes "\<forall>i . \<exists>j . f (i,j) = top"
     shows "matrix_stone_relation_algebra.total_var f"
 proof (unfold less_eq_matrix_def, rule allI, rule prod_cases)
   fix j k
   show "mone (j,k) \<le> (f \<odot> f\<^sup>t) (j,k)"
   proof (cases "j = k")
     assume "j = k"
     hence "(\<Squnion>\<^sub>i f (j,i) * (f\<^sup>t) (i,k)) = (\<Squnion>\<^sub>i f (j,i))"
       by (simp add: conv_matrix_def)
     also have "... = top"
       by (metis (no_types) assms comp_inf.ub_sum sup.absorb2 sup_top_left)
     finally show ?thesis
       by (simp add: times_matrix_def)
   next
     assume "j \<noteq> k"
     thus ?thesis
       by (simp add: one_matrix_def)
   qed
 qed
 
 lemma total_linorder_matrix:
   fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
   shows "matrix_bounded_idempotent_semiring.total f \<longleftrightarrow> (\<forall>i . \<exists>j . f (i,j) = top)"
   using total_linorder_matrix_1 total_linorder_matrix_2 matrix_stone_relation_algebra.total_var by auto
 
 text \<open>
 Surjective matrices are again characterised by applying converse: each column has a \<open>top\<close> entry.
 \<close>
 
 lemma surjective_linorder_matrix:
   fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
   shows "matrix_bounded_idempotent_semiring.surjective f \<longleftrightarrow> (\<forall>j . \<exists>i . f (i,j) = top)"
   by (unfold matrix_stone_relation_algebra.surjective_conv_total total_linorder_matrix) (simp add: conv_matrix_def)
 
 text \<open>
 A mapping therefore means that each row has exactly one \<open>top\<close> entry and all others are \<open>bot\<close>.
 \<close>
 
 lemma mapping_linorder_matrix:
   fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
   shows "matrix_stone_relation_algebra.mapping f \<longleftrightarrow> (\<forall>i . \<exists>j . f (i,j) = top \<and> (\<forall>k . j \<noteq> k \<longrightarrow> f (i,k) = bot))"
   by (unfold total_linorder_matrix univalent_linorder_matrix) (metis (mono_tags, opaque_lifting) comp_inf.mult_1_right comp_inf.mult_right_zero)
 
 lemma mapping_linorder_matrix_unique:
   fixes f :: "('a::finite,'b::non_trivial_linorder_stone_relation_algebra_expansion) square"
   shows "matrix_stone_relation_algebra.mapping f \<longleftrightarrow> (\<forall>i . \<exists>!j . f (i,j) = top \<and> (\<forall>k . j \<noteq> k \<longrightarrow> f (i,k) = bot))"
   apply (unfold mapping_linorder_matrix)
   using bot_not_top by auto
 
 text \<open>
 Conversely, bijective means that each column has exactly one \<open>top\<close> entry and all others are \<open>bot\<close>.
 \<close>
 
 lemma bijective_linorder_matrix:
   fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
   shows "matrix_stone_relation_algebra.bijective f \<longleftrightarrow> (\<forall>j . \<exists>i . f (i,j) = top \<and> (\<forall>k . i \<noteq> k \<longrightarrow> f (k,j) = bot))"
   by (unfold matrix_stone_relation_algebra.bijective_conv_mapping mapping_linorder_matrix) (simp add: conv_matrix_def)
 
 lemma bijective_linorder_matrix_unique:
   fixes f :: "('a::finite,'b::non_trivial_linorder_stone_relation_algebra_expansion) square"
   shows "matrix_stone_relation_algebra.bijective f \<longleftrightarrow> (\<forall>j . \<exists>!i . f (i,j) = top \<and> (\<forall>k . i \<noteq> k \<longrightarrow> f (k,j) = bot))"
   by (unfold matrix_stone_relation_algebra.bijective_conv_mapping mapping_linorder_matrix_unique) (simp add: conv_matrix_def)
 
 text \<open>
 We derive algebraic characterisations of matrices in which each row has an entry that is different from \<open>bot\<close>.
 \<close>
 
 lemma pp_total_linorder_matrix_1:
   fixes f :: "('a::finite,'b::non_trivial_linorder_stone_relation_algebra_expansion) square"
   assumes "\<ominus>(f \<odot> mtop) = mbot"
     shows "\<exists>j . f (i,j) \<noteq> bot"
 proof -
   have "\<not>(\<exists>j . f (i,j) \<noteq> bot) \<Longrightarrow> \<ominus>(f \<odot> mtop) \<noteq> mbot"
   proof -
     assume "\<not>(\<exists>j . f (i,j) \<noteq> bot)"
     hence "top = -(f \<odot> mtop) (i,i)"
       by (simp add: comp_top_linorder_matrix linorder_finite_sup_selective)
     also have "... = (\<ominus>(f \<odot> mtop)) (i,i)"
       by (simp add: uminus_matrix_def)
     finally show "\<ominus>(f \<odot> mtop) \<noteq> mbot"
       by (metis bot_matrix_def bot_not_top)
   qed
   thus ?thesis
     using assms by blast
 qed
 
 lemma pp_total_linorder_matrix_2:
   fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
   assumes "\<forall>i . \<exists>j . f (i,j) \<noteq> bot"
     shows "\<ominus>(f \<odot> mtop) = mbot"
 proof (rule ext, rule prod_cases)
   fix i j
   have "(\<ominus>(f \<odot> mtop)) (i,j) = -(\<Squnion>\<^sub>k f (i,k))"
     by (simp add: comp_top_linorder_matrix uminus_matrix_def)
   also have "... = bot"
     by (metis antisym assms bot.extremum comp_inf.ub_sum uminus_def)
   finally show "(\<ominus>(f \<odot> mtop)) (i,j) = mbot (i,j)"
     by (simp add: bot_matrix_def)
 qed
 
 lemma pp_total_linorder_matrix_3:
   fixes f :: "('a::finite,'b::non_trivial_linorder_stone_relation_algebra_expansion) square"
   shows "\<ominus>(f \<odot> mtop) = mbot \<longleftrightarrow> (\<forall>i . \<exists>j . f (i,j) \<noteq> bot)"
   using pp_total_linorder_matrix_1 pp_total_linorder_matrix_2 by auto
 
 lemma pp_total_linorder_matrix:
   fixes f :: "('a::finite,'b::non_trivial_linorder_stone_relation_algebra_expansion) square"
   shows "matrix_bounded_idempotent_semiring.total (\<ominus>\<ominus>f) \<longleftrightarrow> (\<forall>i . \<exists>j . f (i,j) \<noteq> bot)"
   using matrix_stone_relation_algebra.pp_total pp_total_linorder_matrix_1 pp_total_linorder_matrix_2 by auto
 
 lemma pp_mapping_linorder_matrix:
   fixes f :: "('a::finite,'b::non_trivial_linorder_stone_relation_algebra_expansion) square"
   shows "matrix_stone_relation_algebra.pp_mapping f \<longleftrightarrow> (\<forall>i . \<exists>j . f (i,j) \<noteq> bot \<and> (\<forall>k . j \<noteq> k \<longrightarrow> f (i,k) = bot))"
   by (metis (mono_tags, opaque_lifting) pp_total_linorder_matrix univalent_linorder_matrix_1 univalent_linorder_matrix_2)
 
 lemma pp_mapping_linorder_matrix_unique:
   fixes f :: "('a::finite,'b::non_trivial_linorder_stone_relation_algebra_expansion) square"
   shows "matrix_stone_relation_algebra.pp_mapping f \<longleftrightarrow> (\<forall>i . \<exists>!j . f (i,j) \<noteq> bot \<and> (\<forall>k . j \<noteq> k \<longrightarrow> f (i,k) = bot))"
   apply (rule iffI)
   using pp_mapping_linorder_matrix apply blast
   by (metis pp_total_linorder_matrix univalent_linorder_matrix)
 
 text \<open>
 Next follow matrices in which each column has an entry that is different from \<open>bot\<close>.
 \<close>
 
 lemma pp_surjective_linorder_matrix_1:
   fixes f :: "('a::finite,'b::non_trivial_linorder_stone_relation_algebra_expansion) square"
   shows "\<ominus>(mtop \<odot> f) = mbot \<longleftrightarrow> (\<forall>j . \<exists>i . f (i,j) \<noteq> bot)"
 proof -
   have "\<ominus>(mtop \<odot> f) = mbot \<longleftrightarrow> (\<ominus>(mtop \<odot> f))\<^sup>t = mbot\<^sup>t"
     by (metis matrix_stone_relation_algebra.conv_involutive)
   also have "... \<longleftrightarrow> \<ominus>(f\<^sup>t \<odot> mtop) = mbot"
     by (simp add: matrix_stone_relation_algebra.conv_complement matrix_stone_relation_algebra.conv_dist_comp)
   also have "... \<longleftrightarrow> (\<forall>i . \<exists>j . (f\<^sup>t) (i,j) \<noteq> bot)"
     using pp_total_linorder_matrix_3 by auto
   also have "... \<longleftrightarrow> (\<forall>j . \<exists>i . f (i,j) \<noteq> bot)"
     by (simp add: conv_matrix_def)
   finally show ?thesis
     .
 qed
 
 lemma pp_surjective_linorder_matrix:
   fixes f :: "('a::finite,'b::non_trivial_linorder_stone_relation_algebra_expansion) square"
   shows "matrix_bounded_idempotent_semiring.surjective (\<ominus>\<ominus>f) \<longleftrightarrow> (\<forall>j . \<exists>i . f (i,j) \<noteq> bot)"
   using matrix_stone_relation_algebra.pp_surjective pp_surjective_linorder_matrix_1 by auto
 
 lemma pp_bijective_linorder_matrix:
   fixes f :: "('a::finite,'b::non_trivial_linorder_stone_relation_algebra_expansion) square"
   shows "matrix_stone_relation_algebra.pp_bijective f \<longleftrightarrow> (\<forall>j . \<exists>i . f (i,j) \<noteq> bot \<and> (\<forall>k . i \<noteq> k \<longrightarrow> f (k,j) = bot))"
   by (unfold matrix_stone_relation_algebra.pp_bijective_conv_mapping pp_mapping_linorder_matrix) (simp add: conv_matrix_def)
 
 lemma pp_bijective_linorder_matrix_unique:
   fixes f :: "('a::finite,'b::non_trivial_linorder_stone_relation_algebra_expansion) square"
   shows "matrix_stone_relation_algebra.pp_bijective f \<longleftrightarrow> (\<forall>j . \<exists>!i . f (i,j) \<noteq> bot \<and> (\<forall>k . i \<noteq> k \<longrightarrow> f (k,j) = bot))"
   by (unfold matrix_stone_relation_algebra.pp_bijective_conv_mapping pp_mapping_linorder_matrix_unique) (simp add: conv_matrix_def)
 
 text \<open>
 The regular matrices are those which contain only \<open>bot\<close> or \<open>top\<close> entries.
 \<close>
 
 lemma regular_linorder_matrix:
   fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
   shows "matrix_p_algebra.regular f \<longleftrightarrow> (\<forall>e . f e = bot \<or> f e = top)"
 proof -
   have "matrix_p_algebra.regular f \<longleftrightarrow> (\<ominus>\<ominus>f = f)"
     by auto
   also have "... \<longleftrightarrow> (\<forall>e . --f e = f e)"
     by (metis uminus_matrix_def ext)
   also have "... \<longleftrightarrow> (\<forall>e . f e = bot \<or> f e = top)"
     by force
   finally show ?thesis
     .
 qed
 
 text \<open>
 Vectors are precisely the row-constant matrices.
 \<close>
 
 lemma vector_linorder_matrix_0:
   fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
   assumes "matrix_bounded_idempotent_semiring.vector f"
     shows "f (i,j) = (\<Squnion>\<^sub>k f (i,k))"
   by (metis assms comp_top_linorder_matrix)
 
 lemma vector_linorder_matrix_1:
   fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
   assumes "matrix_bounded_idempotent_semiring.vector f"
     shows "f (i,j) = f (i,k)"
   by (metis assms vector_linorder_matrix_0)
 
 lemma vector_linorder_matrix_2:
   fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
   assumes "\<forall>i j k . f (i,j) = f (i,k)"
     shows "matrix_bounded_idempotent_semiring.vector f"
 proof (rule ext, rule prod_cases)
   fix i j
   have "(f \<odot> mtop) (i,j) = (\<Squnion>\<^sub>k f (i,k))"
     by (simp add: comp_top_linorder_matrix)
   also have "... = f (i,j)"
     by (metis assms linorder_finite_sup_selective)
   finally show "(f \<odot> mtop) (i,j) = f (i,j)"
     .
 qed
 
 lemma vector_linorder_matrix:
   fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
   shows "matrix_bounded_idempotent_semiring.vector f \<longleftrightarrow> (\<forall>i j k . f (i,j) = f (i,k))"
   using vector_linorder_matrix_1 vector_linorder_matrix_2 by auto
 
 text \<open>
 Hence covectors are precisely the column-constant matrices.
 \<close>
 
 lemma covector_linorder_matrix_0:
   fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
   assumes "matrix_bounded_idempotent_semiring.covector f"
     shows "f (i,j) = (\<Squnion>\<^sub>k f (k,j))"
   by (metis assms top_comp_linorder_matrix)
 
 lemma covector_linorder_matrix:
   fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
   shows "matrix_bounded_idempotent_semiring.covector f \<longleftrightarrow> (\<forall>i j k . f (i,j) = f (k,j))"
   by (unfold matrix_stone_relation_algebra.covector_conv_vector vector_linorder_matrix) (metis (no_types, lifting) case_prod_conv conv_matrix_def conv_def)
 
 text \<open>
 A point is a matrix that has exactly one row, which is constant \<open>top\<close>, and all other rows are constant \<open>bot\<close>.
 \<close>
 
 lemma point_linorder_matrix:
   fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
   shows "matrix_stone_relation_algebra.point f \<longleftrightarrow> (\<exists>i . \<forall>j . f (i,j) = top \<and> (\<forall>k . i \<noteq> k \<longrightarrow> f (k,j) = bot))"
   apply (unfold vector_linorder_matrix bijective_linorder_matrix)
   apply (rule iffI)
   apply metis
   by metis
 
 lemma point_linorder_matrix_unique:
   fixes f :: "('a::finite,'b::non_trivial_linorder_stone_relation_algebra_expansion) square"
   shows "matrix_stone_relation_algebra.point f \<longleftrightarrow> (\<exists>!i . \<forall>j . f (i,j) = top \<and> (\<forall>k . i \<noteq> k \<longrightarrow> f (k,j) = bot))"
   apply (unfold vector_linorder_matrix bijective_linorder_matrix)
   apply (rule iffI)
   apply (metis bot_not_top)
   by metis
 
 lemma pp_point_linorder_matrix:
   fixes f :: "('a::finite,'b::non_trivial_linorder_stone_relation_algebra_expansion) square"
   shows "matrix_stone_relation_algebra.pp_point f \<longleftrightarrow> (\<exists>i . \<forall>j . f (i,j) \<noteq> bot \<and> (\<forall>k . f (i,j) = f (i,k)) \<and> (\<forall>k . i \<noteq> k \<longrightarrow> f (k,j) = bot))"
   apply (unfold vector_linorder_matrix pp_bijective_linorder_matrix)
   apply (rule iffI)
   apply metis
   by metis
 
 lemma pp_point_linorder_matrix_unique:
   fixes f :: "('a::finite,'b::non_trivial_linorder_stone_relation_algebra_expansion) square"
   shows "matrix_stone_relation_algebra.pp_point f \<longleftrightarrow> (\<exists>!i . \<forall>j . f (i,j) \<noteq> bot \<and> (\<forall>k . f (i,j) = f (i,k)) \<and> (\<forall>k . i \<noteq> k \<longrightarrow> f (k,j) = bot))"
   apply (unfold vector_linorder_matrix pp_bijective_linorder_matrix)
   apply (rule iffI)
   apply metis
   by metis
 
 text \<open>
 An arc is a matrix that has exactly one \<open>top\<close> entry and all other entries are \<open>bot\<close>.
 \<close>
 
 lemma arc_linorder_matrix_1:
   fixes f :: "('a::finite,'b::non_trivial_linorder_stone_relation_algebra_expansion) square"
   assumes "matrix_stone_relation_algebra.arc f"
     shows "\<exists>e . f e = top \<and> (\<forall>d . e \<noteq> d \<longrightarrow> f d = bot)"
 proof -
   have "matrix_stone_relation_algebra.point (f \<odot> mtop)"
     by (simp add: assms matrix_bounded_idempotent_semiring.vector_mult_closed)
   from this obtain i where 1: "\<forall>j . (f \<odot> mtop) (i,j) = top \<and> (\<forall>k . i \<noteq> k \<longrightarrow> (f \<odot> mtop) (k,j) = bot)"
     using point_linorder_matrix by blast
   have "matrix_stone_relation_algebra.point (f\<^sup>t \<odot> mtop)"
     by (simp add: assms matrix_bounded_idempotent_semiring.vector_mult_closed)
   from this obtain j where "\<forall>i . (f\<^sup>t \<odot> mtop) (j,i) = top \<and> (\<forall>k . j \<noteq> k \<longrightarrow> (f\<^sup>t \<odot> mtop) (k,i) = bot)"
     using point_linorder_matrix by blast
   hence 2: "\<forall>i . (mtop \<odot> f) (i,j) = top \<and> (\<forall>k . j \<noteq> k \<longrightarrow> (mtop \<odot> f) (i,k) = bot)"
     by (metis (no_types) old.prod.case conv_matrix_def conv_def matrix_stone_relation_algebra.conv_dist_comp matrix_stone_relation_algebra.conv_top)
   have 3: "\<forall>i k . j \<noteq> k \<longrightarrow> f (i,k) = bot"
   proof (intro allI, rule impI)
     fix i k
     assume "j \<noteq> k"
     hence "(\<Squnion>\<^sub>l f (l,k)) = bot"
       using 2 by (simp add: top_comp_linorder_matrix)
     thus "f (i,k) = bot"
       by (metis bot.extremum_uniqueI comp_inf.ub_sum)
   qed
   have "(\<Squnion>\<^sub>k f (i,k)) = top"
     using 1 by (simp add: comp_top_linorder_matrix)
   hence 4: "f (i,j) = top"
     using 3 by (metis bot_not_top linorder_finite_sup_selective)
   have "\<forall>k l . k \<noteq> i \<or> l \<noteq> j \<longrightarrow> f (k,l) = bot"
   proof (intro allI, unfold imp_disjL, rule conjI)
     fix k l
     show "k \<noteq> i \<longrightarrow> f (k,l) = bot"
     proof
       assume "k \<noteq> i"
       hence "(\<Squnion>\<^sub>m f (k,m)) = bot"
         using 1 by (simp add: comp_top_linorder_matrix)
       thus "f (k,l) = bot"
         by (metis bot.extremum_uniqueI comp_inf.ub_sum)
     qed
     show "l \<noteq> j \<longrightarrow> f (k,l) = bot"
       using 3 by simp
   qed
   thus ?thesis using 4
     by (metis old.prod.exhaust)
 qed
 
 lemma pp_arc_linorder_matrix_2:
   fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
   assumes "\<exists>e . f e \<noteq> bot \<and> (\<forall>d . e \<noteq> d \<longrightarrow> f d = bot)"
     shows "matrix_stone_relation_algebra.pp_arc f"
 proof (unfold matrix_stone_relation_algebra.pp_arc_expanded, intro conjI)
   show "f \<odot> mtop \<odot> f\<^sup>t \<preceq> mone"
   proof (unfold less_eq_matrix_def, rule allI, rule prod_cases)
     fix i j
     show "(f \<odot> mtop \<odot> f\<^sup>t) (i,j) \<le> mone (i,j)"
     proof (cases "i = j")
       assume "i = j"
       thus ?thesis
         by (simp add: one_matrix_def)
     next
       assume "i \<noteq> j"
       hence 1: "\<forall>k l . f (i,k) * f (j,l) = bot"
         by (metis assms Pair_inject semiring.mult_not_zero)
       have "(f \<odot> mtop \<odot> f\<^sup>t) (i,j) = (\<Squnion>\<^sub>l (f \<odot> mtop) (i,l) * (f\<^sup>t) (l,j))"
         by (simp add: times_matrix_def)
       also have "... = (\<Squnion>\<^sub>l (f \<odot> mtop) (i,l) * f (j,l))"
         by (simp add: conv_matrix_def)
       also have "... = (\<Squnion>\<^sub>l (\<Squnion>\<^sub>k f (i,k)) * f (j,l))"
         by (simp add: comp_top_linorder_matrix)
       also have "... = (\<Squnion>\<^sub>l \<Squnion>\<^sub>k f (i,k) * f (j,l))"
         by (metis comp_right_dist_sum)
       also have "... = bot"
         using 1 linorder_finite_sup_selective by simp
       finally show ?thesis
         by simp
     qed
   qed
 next
   show "f\<^sup>t \<odot> mtop \<odot> f \<preceq> mone"
   proof (unfold less_eq_matrix_def, rule allI, rule prod_cases)
     fix i j
     show "(f\<^sup>t \<odot> mtop \<odot> f) (i,j) \<le> mone (i,j)"
     proof (cases "i = j")
       assume "i = j"
       thus ?thesis
         by (simp add: one_matrix_def)
     next
       assume "i \<noteq> j"
       hence 2: "\<forall>k l . f (k,i) * f (l,j) = bot"
         by (metis assms Pair_inject semiring.mult_not_zero)
       have "(f\<^sup>t \<odot> mtop \<odot> f) (i,j) = (\<Squnion>\<^sub>l (f\<^sup>t \<odot> mtop) (i,l) * f (l,j))"
         by (simp add: times_matrix_def)
       also have "... = (\<Squnion>\<^sub>l (\<Squnion>\<^sub>k (f\<^sup>t) (i,k)) * f (l,j))"
         by (simp add: comp_top_linorder_matrix)
       also have "... = (\<Squnion>\<^sub>l (\<Squnion>\<^sub>k f (k,i)) * f (l,j))"
         by (simp add: conv_matrix_def)
       also have "... = (\<Squnion>\<^sub>l \<Squnion>\<^sub>k f (k,i) * f (l,j))"
         by (metis comp_right_dist_sum)
       also have "... = bot"
         using 2 linorder_finite_sup_selective by simp
       finally show ?thesis
         by simp
     qed
   qed
 next
   show "mtop \<odot> \<ominus>\<ominus>f \<odot> mtop = mtop"
   proof (rule ext, rule prod_cases)
     fix i j
     from assms obtain k l where "f (k,l) \<noteq> bot"
       using prod.collapse by auto
     hence "top = --f (k,l)"
       by simp
     also have "... \<le> (\<Squnion>\<^sub>k --f (k,l))"
       using comp_inf.ub_sum by metis
     also have "... \<le> (\<Squnion>\<^sub>l \<Squnion>\<^sub>k --f (k,l))"
       using comp_inf.ub_sum by simp
     finally have 3: "top \<le> (\<Squnion>\<^sub>l \<Squnion>\<^sub>k --f (k,l))"
       by simp
     have "(mtop \<odot> \<ominus>\<ominus>f \<odot> mtop) (i,j) = (\<Squnion>\<^sub>l (\<Squnion>\<^sub>k top * --f (k,l)) * top)"
       by (simp add: times_matrix_def top_matrix_def uminus_matrix_def)
     also have "... = (\<Squnion>\<^sub>l \<Squnion>\<^sub>k --f (k,l))"
       by (metis (no_types, lifting) sup_monoid.sum.cong comp_inf.mult_1_left times_inf comp_inf.mult_1_right)
     also have "... = top"
       using 3 top.extremum_unique by blast
     finally show "(mtop \<odot> \<ominus>\<ominus>f \<odot> mtop) (i,j) = mtop (i,j)"
       by (simp add: top_matrix_def)
   qed
 qed
 
 lemma arc_linorder_matrix_2:
   fixes f :: "('a::finite,'b::non_trivial_linorder_stone_relation_algebra_expansion) square"
   assumes "\<exists>e . f e = top \<and> (\<forall>d . e \<noteq> d \<longrightarrow> f d = bot)"
     shows "matrix_stone_relation_algebra.arc f"
 proof (unfold matrix_stone_relation_algebra.arc_expanded, intro conjI)
   show "f \<odot> mtop \<odot> f\<^sup>t \<preceq> mone"
     by (metis (no_types, lifting) assms bot_not_top matrix_stone_relation_algebra.pp_arc_expanded pp_arc_linorder_matrix_2)
 next
   show "f\<^sup>t \<odot> mtop \<odot> f \<preceq> mone"
     by (metis (no_types, lifting) assms bot_not_top matrix_stone_relation_algebra.pp_arc_expanded pp_arc_linorder_matrix_2)
 next
   show "mtop \<odot> f \<odot> mtop = mtop"
   proof (rule ext, rule prod_cases)
     fix i j
     from assms obtain k l where "f (k,l) = top"
       using prod.collapse by auto
     hence "(\<Squnion>\<^sub>k f (k,l)) = top"
       by (metis (mono_tags) comp_inf.ub_sum top_unique)
     hence 3: "top \<le> (\<Squnion>\<^sub>l \<Squnion>\<^sub>k f (k,l))"
       by (metis (no_types) comp_inf.ub_sum)
     have "(mtop \<odot> f \<odot> mtop) (i,j) = (\<Squnion>\<^sub>l (\<Squnion>\<^sub>k top * f (k,l)) * top)"
       by (simp add: times_matrix_def top_matrix_def)
     also have "... = (\<Squnion>\<^sub>l \<Squnion>\<^sub>k f (k,l))"
       by (metis (no_types, lifting) sup_monoid.sum.cong comp_inf.mult_1_left times_inf comp_inf.mult_1_right)
     also have "... = top"
       using 3 top.extremum_unique by blast
     finally show "(mtop \<odot> f \<odot> mtop) (i,j) = mtop (i,j)"
       by (simp add: top_matrix_def)
   qed
 qed
 
 lemma arc_linorder_matrix:
   fixes f :: "('a::finite,'b::non_trivial_linorder_stone_relation_algebra_expansion) square"
   shows "matrix_stone_relation_algebra.arc f \<longleftrightarrow> (\<exists>e . f e = top \<and> (\<forall>d . e \<noteq> d \<longrightarrow> f d = bot))"
   using arc_linorder_matrix_1 arc_linorder_matrix_2 by blast
 
 lemma arc_linorder_matrix_unique:
   fixes f :: "('a::finite,'b::non_trivial_linorder_stone_relation_algebra_expansion) square"
   shows "matrix_stone_relation_algebra.arc f \<longleftrightarrow> (\<exists>!e . f e = top \<and> (\<forall>d . e \<noteq> d \<longrightarrow> f d = bot))"
   apply (rule iffI)
   apply (metis (no_types, opaque_lifting) arc_linorder_matrix bot_not_top)
   using arc_linorder_matrix by blast
 
 lemma pp_arc_linorder_matrix_1:
   fixes f :: "('a::finite,'b::non_trivial_linorder_stone_relation_algebra_expansion) square"
   assumes "matrix_stone_relation_algebra.pp_arc f"
     shows "\<exists>e . f e \<noteq> bot \<and> (\<forall>d . e \<noteq> d \<longrightarrow> f d = bot)"
 proof -
   have "matrix_stone_relation_algebra.pp_point (f \<odot> mtop)"
     by (simp add: assms matrix_bounded_idempotent_semiring.vector_mult_closed)
   from this obtain i where 1: "\<forall>j . (f \<odot> mtop) (i,j) \<noteq> bot \<and> (\<forall>k . (f \<odot> mtop) (i,j) = (f \<odot> mtop) (i,k)) \<and> (\<forall>k . i \<noteq> k \<longrightarrow> (f \<odot> mtop) (k,j) = bot)"
     by (metis pp_point_linorder_matrix)
   have "matrix_stone_relation_algebra.pp_point (f\<^sup>t \<odot> mtop)"
     by (simp add: assms matrix_bounded_idempotent_semiring.vector_mult_closed)
   from this obtain j where "\<forall>i . (f\<^sup>t \<odot> mtop) (j,i) \<noteq> bot \<and> (\<forall>k . (f\<^sup>t \<odot> mtop) (j,i) = (f\<^sup>t \<odot> mtop) (j,k)) \<and> (\<forall>k . j \<noteq> k \<longrightarrow> (f\<^sup>t \<odot> mtop) (k,i) = bot)"
     by (metis pp_point_linorder_matrix)
   hence 2: "\<forall>i . (mtop \<odot> f) (i,j) \<noteq> bot \<and> (\<forall>k . (mtop \<odot> f) (i,j) = (mtop \<odot> f) (k,j)) \<and> (\<forall>k . j \<noteq> k \<longrightarrow> (mtop \<odot> f) (i,k) = bot)"
     by (metis (no_types) old.prod.case conv_matrix_def conv_def matrix_stone_relation_algebra.conv_dist_comp matrix_stone_relation_algebra.conv_top)
   have 3: "\<forall>i k . j \<noteq> k \<longrightarrow> f (i,k) = bot"
   proof (intro allI, rule impI)
     fix i k
     assume "j \<noteq> k"
     hence "(\<Squnion>\<^sub>l f (l,k)) = bot"
       using 2 by (simp add: top_comp_linorder_matrix)
     thus "f (i,k) = bot"
       by (metis bot.extremum_uniqueI comp_inf.ub_sum)
   qed
   have "(\<Squnion>\<^sub>k f (i,k)) \<noteq> bot"
     using 1 by (simp add: comp_top_linorder_matrix)
   hence 4: "f (i,j) \<noteq> bot"
     using 3 by (metis linorder_finite_sup_selective)
   have "\<forall>k l . k \<noteq> i \<or> l \<noteq> j \<longrightarrow> f (k,l) = bot"
   proof (intro allI, unfold imp_disjL, rule conjI)
     fix k l
     show "k \<noteq> i \<longrightarrow> f (k,l) = bot"
     proof
       assume "k \<noteq> i"
       hence "(\<Squnion>\<^sub>m f (k,m)) = bot"
         using 1 by (simp add: comp_top_linorder_matrix)
       thus "f (k,l) = bot"
         by (metis bot.extremum_uniqueI comp_inf.ub_sum)
     qed
     show "l \<noteq> j \<longrightarrow> f (k,l) = bot"
       using 3 by simp
   qed
   thus ?thesis using 4
     by (metis old.prod.exhaust)
 qed
 
 lemma pp_arc_linorder_matrix:
   fixes f :: "('a::finite,'b::non_trivial_linorder_stone_relation_algebra_expansion) square"
   shows "matrix_stone_relation_algebra.pp_arc f \<longleftrightarrow> (\<exists>e . f e \<noteq> bot \<and> (\<forall>d . e \<noteq> d \<longrightarrow> f d = bot))"
   using pp_arc_linorder_matrix_1 pp_arc_linorder_matrix_2 by blast
 
 lemma pp_arc_linorder_matrix_unique:
   fixes f :: "('a::finite,'b::non_trivial_linorder_stone_relation_algebra_expansion) square"
   shows "matrix_stone_relation_algebra.pp_arc f \<longleftrightarrow> (\<exists>!e . f e \<noteq> bot \<and> (\<forall>d . e \<noteq> d \<longrightarrow> f d = bot))"
   apply (rule iffI)
   apply (metis (no_types, opaque_lifting) pp_arc_linorder_matrix)
   using pp_arc_linorder_matrix by blast
 
 text \<open>
 Reflexive matrices are those with a constant \<open>top\<close> diagonal.
 \<close>
 
 lemma reflexive_linorder_matrix_1:
   fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
   assumes "matrix_idempotent_semiring.reflexive f"
     shows "f (i,i) = top"
 proof -
   have "(top::'b) = mone (i,i)"
     by (simp add: one_matrix_def)
   also have "... \<le> f (i,i)"
     using assms less_eq_matrix_def by blast
   finally show ?thesis
     by (simp add: top.extremum_unique)
 qed
 
 lemma reflexive_linorder_matrix_2:
   fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
   assumes "\<forall>i . f (i,i) = top"
     shows "matrix_idempotent_semiring.reflexive f"
 proof (unfold less_eq_matrix_def, rule allI, rule prod_cases)
   fix i j
   show "mone (i,j) \<le> f (i,j)"
   proof (cases "i = j")
     assume "i = j"
     thus ?thesis
       by (simp add: assms)
   next
     assume "i \<noteq> j"
     hence "(bot::'b) = mone (i,j)"
       by (simp add: one_matrix_def)
     thus ?thesis
       by simp
   qed
 qed
 
 lemma reflexive_linorder_matrix:
   fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
   shows "matrix_idempotent_semiring.reflexive f \<longleftrightarrow> (\<forall>i . f (i,i) = top)"
   using reflexive_linorder_matrix_1 reflexive_linorder_matrix_2 by auto
 
 text \<open>
 Coreflexive matrices are those in which all non-diagonal entries are \<open>bot\<close>.
 \<close>
 
 lemma coreflexive_linorder_matrix_1:
   fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
   assumes "matrix_idempotent_semiring.coreflexive f"
       and "i \<noteq> j"
     shows "f (i,j) = bot"
 proof -
   have "f (i,j) \<le> mone (i,j)"
     using assms less_eq_matrix_def by blast
   also have "... = bot"
     by (simp add: assms one_matrix_def)
   finally show ?thesis
     by (simp add: bot.extremum_unique)
 qed
 
 lemma coreflexive_linorder_matrix_2:
   fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
   assumes "\<forall>i j . i \<noteq> j \<longrightarrow> f (i,j) = bot"
     shows "matrix_idempotent_semiring.coreflexive f"
 proof (unfold less_eq_matrix_def, rule allI, rule prod_cases)
   fix i j
   show "f (i,j) \<le> mone (i,j)"
   proof (cases "i = j")
     assume "i = j"
     hence "(top::'b) = mone (i,j)"
       by (simp add: one_matrix_def)
     thus ?thesis
       by simp
   next
     assume "i \<noteq> j"
     thus ?thesis
       by (simp add: assms)
   qed
 qed
 
 lemma coreflexive_linorder_matrix:
   fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
   shows "matrix_idempotent_semiring.coreflexive f \<longleftrightarrow> (\<forall>i j . i \<noteq> j \<longrightarrow> f (i,j) = bot)"
   using coreflexive_linorder_matrix_1 coreflexive_linorder_matrix_2 by auto
 
 text \<open>
 Irreflexive matrices are those with a constant \<open>bot\<close> diagonal.
 \<close>
 
 lemma irreflexive_linorder_matrix_1:
   fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
   assumes "matrix_stone_relation_algebra.irreflexive f"
     shows "f (i,i) = bot"
 proof -
   have "(top::'b) = mone (i,i)"
     by (simp add: one_matrix_def)
   hence "(bot::'b) = (\<ominus>mone) (i,i)"
     by (simp add: uminus_matrix_def)
   hence "f (i,i) \<le> bot"
     by (metis assms less_eq_matrix_def)
   thus ?thesis
     by (simp add: bot.extremum_unique)
 qed
 
 lemma irreflexive_linorder_matrix_2:
   fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
   assumes "\<forall>i . f (i,i) = bot"
     shows "matrix_stone_relation_algebra.irreflexive f"
 proof (unfold less_eq_matrix_def, rule allI, rule prod_cases)
   fix i j
   show "f (i,j) \<le> (\<ominus>mone) (i,j)"
   proof (cases "i = j")
     assume "i = j"
     thus ?thesis
       by (simp add: assms)
   next
     assume "i \<noteq> j"
     hence "(bot::'b) = mone (i,j)"
       by (simp add: one_matrix_def)
     hence "(top::'b) = (\<ominus>mone) (i,j)"
       by (simp add: uminus_matrix_def)
     thus ?thesis
       by simp
   qed
 qed
 
 lemma irreflexive_linorder_matrix:
   fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
   shows "matrix_stone_relation_algebra.irreflexive f \<longleftrightarrow> (\<forall>i . f (i,i) = bot)"
   using irreflexive_linorder_matrix_1 irreflexive_linorder_matrix_2 by auto
 
 text \<open>
 As usual, symmetric matrices are those which do not change under transposition.
 \<close>
 
 lemma symmetric_linorder_matrix:
   fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
   shows "matrix_stone_relation_algebra.symmetric f \<longleftrightarrow> (\<forall>i j . f (i,j) = f (j,i))"
   by (metis (mono_tags, lifting) case_prod_conv cond_case_prod_eta conv_matrix_def conv_def)
 
 text \<open>
 Antisymmetric matrices are characterised as follows: each entry not on the diagonal or its mirror entry across the diagonal must be \<open>bot\<close>.
 \<close>
 
 lemma antisymmetric_linorder_matrix:
   fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
   shows "matrix_stone_relation_algebra.antisymmetric f \<longleftrightarrow> (\<forall>i j . i \<noteq> j \<longrightarrow> f (i,j) = bot \<or> f (j,i) = bot)"
 proof -
   have "matrix_stone_relation_algebra.antisymmetric f \<longleftrightarrow> (\<forall>i j . i \<noteq> j \<longrightarrow> f (i,j) \<sqinter> f (j,i) \<le> bot)"
     by (simp add: conv_matrix_def inf_matrix_def less_eq_matrix_def one_matrix_def)
   thus ?thesis
     by (metis (no_types, opaque_lifting) inf.absorb_iff1 inf.cobounded1 inf_bot_right inf_dense)
 qed
 
 text \<open>
 For asymmetric matrices the diagonal is included: each entry or its mirror entry across the diagonal must be \<open>bot\<close>.
 \<close>
 
 lemma asymmetric_linorder_matrix:
   fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
   shows "matrix_stone_relation_algebra.asymmetric f \<longleftrightarrow> (\<forall>i j . f (i,j) = bot \<or> f (j,i) = bot)"
 proof -
   have "matrix_stone_relation_algebra.asymmetric f \<longleftrightarrow> (\<forall>i j . f (i,j) \<sqinter> f (j,i) \<le> bot)"
     apply (unfold conv_matrix_def inf_matrix_def conv_def id_def bot_matrix_def)
     by (metis (mono_tags, lifting) bot.extremum bot.extremum_uniqueI case_prod_conv old.prod.exhaust)
   thus ?thesis
     by (metis (no_types, opaque_lifting) inf.absorb_iff1 inf.cobounded1 inf_bot_right inf_dense)
 qed
 
 text \<open>
 In a transitive matrix, the weight of one of the edges on an indirect route must be below the weight of the direct edge.
 \<close>
 
 lemma transitive_linorder_matrix:
   fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
   shows "matrix_idempotent_semiring.transitive f \<longleftrightarrow> (\<forall>i j k . f (i,k) \<le> f (i,j) \<or> f (k,j) \<le> f (i,j))"
 proof -
   have "matrix_idempotent_semiring.transitive f \<longleftrightarrow> (\<forall>i j . (\<Squnion>\<^sub>k f (i,k) * f (k,j)) \<le> f (i,j))"
     by (simp add: times_matrix_def less_eq_matrix_def)
   also have "... \<longleftrightarrow> (\<forall>i j k . f (i,k) * f (k,j) \<le> f (i,j))"
     by (simp add: lub_sum_iff)
   also have "... \<longleftrightarrow> (\<forall>i j k . f (i,k) \<le> f (i,j) \<or> f (k,j) \<le> f (i,j))"
     using inf_less_eq by fastforce
   finally show ?thesis
     .
 qed
 
 text \<open>
 We finally show the effect of composing with a coreflexive (test) from the left and from the right.
 This amounts to a restriction of each row or column to the entry on the diagonal of the coreflexive.
 In this case, restrictions are formed by meets.
 \<close>
 
 lemma coreflexive_comp_linorder_matrix:
   fixes f g :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
   assumes "matrix_idempotent_semiring.coreflexive f"
     shows "(f \<odot> g) (i,j) = f (i,i) \<sqinter> g (i,j)"
 proof -
   have 1: "\<forall>k . i \<noteq> k \<longrightarrow> f (i,k) = bot"
     using assms coreflexive_linorder_matrix by auto
   have "(\<Squnion>\<^sub>k f (i,k)) = f (i,i) \<squnion> (\<Squnion>\<^bsub>k\<in>UNIV-{i}\<^esub> f (i,k))"
     by (metis (no_types) UNIV_def brouwer.inf_bot_right finite_UNIV insert_def sup_monoid.sum.insert_remove)
   hence 2: "(\<Squnion>\<^sub>k f (i,k)) = f (i,i)"
     using 1 by (metis (no_types) linorder_finite_sup_selective sup_not_bot)
   have "(f \<odot> g) (i,j) = (f \<odot> mtop \<otimes> g) (i,j)"
     by (metis assms matrix_stone_relation_algebra.coreflexive_comp_top_inf)
   also have "... = (\<Squnion>\<^sub>k f (i,k)) \<sqinter> g (i,j)"
     by (metis inf_matrix_def comp_top_linorder_matrix)
   finally show ?thesis
     using 2 by simp
 qed
 
 lemma comp_coreflexive_linorder_matrix:
   fixes f g :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
   assumes "matrix_idempotent_semiring.coreflexive g"
     shows "(f \<odot> g) (i,j) = f (i,j) \<sqinter> g (j,j)"
 proof -
   have "(f \<odot> g) (i,j) = ((f \<odot> g)\<^sup>t) (j,i)"
     by (simp add: conv_matrix_def)
   also have "... = (g \<odot> f\<^sup>t) (j,i)"
     by (simp add: assms matrix_stone_relation_algebra.conv_dist_comp matrix_stone_relation_algebra.coreflexive_symmetric)
   also have "... = g (j,j) \<sqinter> (f\<^sup>t) (j,i)"
     by (simp add: assms coreflexive_comp_linorder_matrix)
   also have "... = f (i,j) \<sqinter> g (j,j)"
     by (metis (no_types, lifting) conv_def old.prod.case conv_matrix_def inf_commute)
   finally show ?thesis
     .
 qed
 
 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: 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: 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
   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 boolean_algebra
+context Lattices.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 boolean_algebra
+context Lattices.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/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 boolean_algebra diff_upred not_upred conj_upred "(\<le>)" "(<)"
+interpretation Lattices.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/Guide.thy b/thys/Word_Lib/Guide.thy
--- a/thys/Word_Lib/Guide.thy
+++ b/thys/Word_Lib/Guide.thy
@@ -1,414 +1,413 @@
 (*
  * Copyright Florian Haftmann
  *
  * SPDX-License-Identifier: BSD-2-Clause
  *)
 
 (*<*)
 theory Guide
   imports Word_Lib_Sumo Word_64 Ancient_Numeral
 begin
 
 notation (output)  push_bit (\<open>push'_bit\<close>)
 
 notation (output)  drop_bit (\<open>drop'_bit\<close>)
 
 notation (output)  signed_drop_bit (\<open>signed'_drop'_bit\<close>)
 
 notation (output)  Generic_set_bit.set_bit (\<open>Generic'_set'_bit.set'_bit\<close>)
 
 hide_const (open) Generic_set_bit.set_bit push_bit drop_bit signed_drop_bit
 
 no_notation bit  (infixl \<open>!!\<close> 100)
 
 abbreviation \<open>push_bit n a \<equiv> a << n\<close>
 
 abbreviation \<open>drop_bit n a \<equiv> a >> n\<close>
 
 abbreviation \<open>signed_drop_bit n a \<equiv> a >>> n\<close>
 
 (*>*)
 section \<open>A short overview over bit operations and word types\<close>
 
 subsection \<open>Basic theories and key ideas\<close>
 
 text \<open>
   When formalizing bit operations, it is tempting to represent
   bit values as explicit lists over a binary type. This however
   is a bad idea, mainly due to the inherent ambiguities in
   representation concerning repeating leading bits.
 
   Hence this approach avoids such explicit lists altogether
   following an algebraic path:
 
     \<^item> Bit values are represented by numeric types: idealized
       unbounded bit values can be represented by type \<^typ>\<open>int\<close>,
       bounded bit values by quotient types over \<^typ>\<open>int\<close>, aka \<^typ>\<open>'a word\<close>.
 
     \<^item> (A special case are idealized unbounded bit values ending
       in @{term [source] 0} which can be represented by type \<^typ>\<open>nat\<close> but
       only support a restricted set of operations).
 
   The most fundamental ideas are developed in theory \<^theory>\<open>HOL.Parity\<close>
   (which is part of \<^theory>\<open>Main\<close>):
 
     \<^item> Multiplication by \<^term>\<open>2 :: int\<close> is a bit shift to the left and
 
     \<^item> Division by \<^term>\<open>2 :: int\<close> is a bit shift to the right.
 
     \<^item> Concerning bounded bit values, iterated shifts to the left
     may result in eliminating all bits by shifting them all
     beyond the boundary.  The property \<^prop>\<open>(2 :: int) ^ n \<noteq> 0\<close>
     represents that \<^term>\<open>n\<close> is \<^emph>\<open>not\<close> beyond that boundary.
 
     \<^item> The projection on a single bit is then @{thm [mode=iff] bit_iff_odd [where ?'a = int, no_vars]}.
 
     \<^item> This leads to the most fundamental properties of bit values:
 
       \<^item> Equality rule: @{thm [display, mode=iff] bit_eq_iff [where ?'a = int, no_vars]}
 
       \<^item> Induction rule: @{thm [display, mode=iff] bits_induct [where ?'a = int, no_vars]}
 
     \<^item> Characteristic properties @{prop [source] \<open>bit (f x) n \<longleftrightarrow> P x n\<close>}
       are available in fact collection \<^text>\<open>bit_simps\<close>.
 
-  On top of this, the following generic operations are provided
-  after import of theory \<^theory>\<open>HOL-Library.Bit_Operations\<close>:
+  On top of this, the following generic operations are provided::
 
     \<^item> Singleton \<^term>\<open>n\<close>th bit: \<^term>\<open>(2 :: int) ^ n\<close>
 
     \<^item> Bit mask upto bit \<^term>\<open>n\<close>: @{thm mask_eq_exp_minus_1 [where ?'a = int, no_vars]}
 
     \<^item> Left shift: @{thm push_bit_eq_mult [where ?'a = int, no_vars]}
 
     \<^item> Right shift: @{thm drop_bit_eq_div [where ?'a = int, no_vars]}
 
     \<^item> Truncation: @{thm take_bit_eq_mod [where ?'a = int, no_vars]}
 
     \<^item> Bitwise negation: @{thm [mode=iff] bit_not_iff [where ?'a = int, no_vars]}
 
     \<^item> Bitwise conjunction: @{thm [mode=iff] bit_and_iff [where ?'a = int, no_vars]}
 
     \<^item> Bitwise disjunction: @{thm [mode=iff] bit_or_iff [where ?'a = int, no_vars]}
 
     \<^item> Bitwise exclusive disjunction: @{thm [mode=iff] bit_xor_iff [where ?'a = int, no_vars]}
 
     \<^item> Setting a single bit: @{thm set_bit_def [where ?'a = int, no_vars]}
 
     \<^item> Unsetting a single bit: @{thm unset_bit_def [where ?'a = int, no_vars]}
 
     \<^item> Flipping a single bit: @{thm flip_bit_def [where ?'a = int, no_vars]}
 
     \<^item> Signed truncation, or modulus centered around \<^term>\<open>0::int\<close>:
         @{thm [display] signed_take_bit_def [where ?'a = int, no_vars]}
 
     \<^item> (Bounded) conversion from and to a list of bits:
         @{thm [display] horner_sum_bit_eq_take_bit [where ?'a = int, no_vars]}
 
   Bit concatenation on \<^typ>\<open>int\<close> as given by 
     @{thm [display] concat_bit_def [no_vars]}
   appears quite
   technical but is the logical foundation for the quite natural bit concatenation
   on \<^typ>\<open>'a word\<close> (see below).
   
   Proper word types are introduced in theory \<^theory>\<open>HOL-Library.Word\<close>, with
   the following specific operations:
 
     \<^item> Standard arithmetic:
         @{term \<open>(+) :: 'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word\<close>},
         @{term \<open>uminus :: 'a::len word \<Rightarrow> 'a word\<close>},
         @{term \<open>(-) :: 'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word\<close>},
         @{term \<open>(*) :: 'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word\<close>},
         @{term \<open>0 :: 'a::len word\<close>}, @{term \<open>1 :: 'a::len word\<close>}, numerals etc.
 
     \<^item> Standard bit operations: see above.
 
     \<^item> Conversion with unsigned interpretation of words:
 
         \<^item> @{term [source] \<open>unsigned :: 'a::len word \<Rightarrow> 'b::semiring_1\<close>}
 
         \<^item> Important special cases as abbreviations:
 
             \<^item> @{term [source] \<open>unat :: 'a::len word \<Rightarrow> nat\<close>}
 
             \<^item> @{term [source] \<open>uint :: 'a::len word \<Rightarrow> int\<close>}
 
             \<^item> @{term [source] \<open>ucast :: 'a::len word \<Rightarrow> 'b::len word\<close>}
 
     \<^item> Conversion with signed interpretation of words:
 
         \<^item> @{term [source] \<open>signed :: 'a::len word \<Rightarrow> 'b::ring_1\<close>}
 
         \<^item> Important special cases as abbreviations:
 
             \<^item> @{term [source] \<open>sint :: 'a::len word \<Rightarrow> int\<close>}
 
             \<^item> @{term [source] \<open>scast :: 'a::len word \<Rightarrow> 'b::len word\<close>}
 
     \<^item> Operations with unsigned interpretation of words:
 
         \<^item> @{thm [mode=iff] word_le_nat_alt [no_vars]}
 
         \<^item> @{thm [mode=iff] word_less_nat_alt [no_vars]}
 
         \<^item> @{thm unat_div_distrib [no_vars]}
 
         \<^item> @{thm unat_drop_bit_eq [no_vars]}
 
         \<^item> @{thm unat_mod_distrib [no_vars]}
 
         \<^item> @{thm [mode=iff] udvd_iff_dvd [no_vars]}
 
     \<^item> Operations with signed interpretation of words:
 
         \<^item> @{thm [mode=iff] word_sle_eq [no_vars]}
 
         \<^item> @{thm [mode=iff] word_sless_alt [no_vars]}
 
         \<^item> @{thm sint_signed_drop_bit_eq [no_vars]}
 
     \<^item> Rotation and reversal:
 
         \<^item> @{term [source] \<open>word_rotl :: nat \<Rightarrow> 'a::len word \<Rightarrow> 'a word\<close>}
 
         \<^item> @{term [source] \<open>word_rotr :: nat \<Rightarrow> 'a::len word \<Rightarrow> 'a word\<close>}
 
         \<^item> @{term [source] \<open>word_roti :: int \<Rightarrow> 'a::len word \<Rightarrow> 'a word\<close>}
 
         \<^item> @{term [source] \<open>word_reverse :: 'a::len word \<Rightarrow> 'a word\<close>}
 
     \<^item> Concatenation: @{term [source, display] \<open>word_cat :: 'a::len word \<Rightarrow> 'b::len word \<Rightarrow> 'c::len word\<close>}
 
   For proofs about words the following default strategies are applicable:
 
     \<^item> Using bit extensionality (facts \<^text>\<open>bit_eq_iff\<close>, \<^text>\<open>bit_eqI\<close>; fact
       collection \<^text>\<open>bit_simps\<close>).
 
     \<^item> Using the @{method transfer} method.
 \<close>
 
 subsection \<open>More library theories\<close>
 
 text \<open>
   Note: currently, the theories listed here are hardly separate
   entities since they import each other in various ways.
   Always inspect them to understand what you pull in if you
   want to import one.
 
     \<^descr>[Syntax]
 
       \<^descr>[\<^theory>\<open>Word_Lib.Syntax_Bundles\<close>]
         Bundles to provide alternative syntax for various bit operations.
 
       \<^descr>[\<^theory>\<open>Word_Lib.Hex_Words\<close>]
         Printing word numerals as hexadecimal numerals.
 
       \<^descr>[\<^theory>\<open>Word_Lib.Type_Syntax\<close>]
         Pretty type-sensitive syntax for cast operations.
 
       \<^descr>[\<^theory>\<open>Word_Lib.Word_Syntax\<close>]
         Specific ASCII syntax for prominent bit operations on word.
 
     \<^descr>[Proof tools]
 
       \<^descr>[\<^theory>\<open>Word_Lib.Norm_Words\<close>]
         Rewriting word numerals to normal forms.
 
       \<^descr>[\<^theory>\<open>Word_Lib.Bitwise\<close>]
         Method @{method word_bitwise} decomposes word equalities and inequalities into bit propositions.
 
       \<^descr>[\<^theory>\<open>Word_Lib.Word_EqI\<close>]
         Method @{method word_eqI_solve} decomposes word equalities and inequalities into bit propositions.
 
     \<^descr>[Operations]
 
       \<^descr>[\<^theory>\<open>Word_Lib.Signed_Division_Word\<close>]
 
         Signed division on word:
 
           \<^item> @{term [source] \<open>(sdiv) :: 'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word\<close>}
 
           \<^item> @{term [source] \<open>(smod) :: 'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word\<close>}
 
       \<^descr>[\<^theory>\<open>Word_Lib.Aligned\<close>] \
 
           \<^item> @{thm [mode=iff] is_aligned_iff_udvd [no_vars]}
 
       \<^descr>[\<^theory>\<open>Word_Lib.Least_significant_bit\<close>]
 
         The least significant bit as an alias:
         @{thm [mode=iff] lsb_odd [where ?'a = int, no_vars]}
 
       \<^descr>[\<^theory>\<open>Word_Lib.Most_significant_bit\<close>]
 
         The most significant bit:
 
           \<^item> @{thm [mode=iff] msb_int_def [of k]}
 
           \<^item> @{thm [mode=iff] word_msb_sint [no_vars]}
 
           \<^item> @{thm [mode=iff] msb_word_iff_sless_0 [no_vars]}
 
           \<^item> @{thm [mode=iff] msb_word_iff_bit [no_vars]}
 
       \<^descr>[\<^theory>\<open>Word_Lib.Bit_Shifts_Infix_Syntax\<close>]
 
         Abbreviations for bit shifts decorated with
         traditional infix syntax:
 
           \<^item> @{abbrev shiftl}
 
           \<^item> @{abbrev shiftr}
 
           \<^item> @{abbrev sshiftr}
 
       \<^descr>[\<^theory>\<open>Word_Lib.Next_and_Prev\<close>] \
 
           \<^item> @{thm word_next_unfold [no_vars]}
 
           \<^item> @{thm word_prev_unfold [no_vars]}
 
       \<^descr>[\<^theory>\<open>Word_Lib.Enumeration_Word\<close>]
 
         More on explicit enumeration of word types.
 
       \<^descr>[\<^theory>\<open>Word_Lib.More_Word_Operations\<close>]
 
         Even more operations on word.
 
     \<^descr>[Types]
 
       \<^descr>[\<^theory>\<open>Word_Lib.Signed_Words\<close>]
 
           Formal tagging of word types with a \<^text>\<open>signed\<close> marker.
 
     \<^descr>[Lemmas]
 
       \<^descr>[\<^theory>\<open>Word_Lib.More_Word\<close>]
 
           More lemmas on words.
 
       \<^descr>[\<^theory>\<open>Word_Lib.Word_Lemmas\<close>]
 
           More lemmas on words, covering many other theories mentioned here.
 
     \<^descr>[Words of popular lengths].
 
       \<^descr>[\<^theory>\<open>Word_Lib.Word_8\<close>]
 
           for 8-bit words.
 
       \<^descr>[\<^theory>\<open>Word_Lib.Word_16\<close>]
 
           for 16-bit words.
 
       \<^descr>[\<^theory>\<open>Word_Lib.Word_32\<close>]
 
           for 32-bit words.
 
       \<^descr>[\<^theory>\<open>Word_Lib.Word_64\<close>]
 
           for 64-bit words. This theory is not part of \<^text>\<open>Word_Lib_Sumo\<close>, because it shadows
           names from \<^theory>\<open>Word_Lib.Word_32\<close>. They can be used together, but then require
           to use qualified names in applications.
 \<close>
 
 
 subsection \<open>More library sessions\<close>
 
 text \<open>
   \<^descr>[\<^text>\<open>Native_Word\<close>] Makes machine words and machine arithmetic available for code generation.
   It provides a common abstraction that hides the differences between the different target languages.
   The code generator maps these operations to the APIs of the target languages.
 \<close>
 
 subsection \<open>Legacy theories\<close>
 
 text \<open>
   The following theories contain material which has been
   factored out since it is not recommended to use it in
   new applications, mostly because matters can be expressed
   succinctly using already existing operations.
 
   This section gives some indication how to migrate away
   from those theories.  However theorem coverage may still
   be terse in some cases.
 
   \<^descr>[\<^theory>\<open>Word_Lib.Word_Lib_Sumo\<close>]
 
     An entry point importing any relevant theory in that session.  Intended
     for backward compatibility: start importing this theory when
     migrating applications to Isabelle2021, and later sort out
     what you really need. You may need to include
    \<^theory>\<open>Word_Lib.Word_64\<close> separately.
 
   \<^descr>[\<^theory>\<open>Word_Lib.Generic_set_bit\<close>]
 
     Kind of an alias: @{thm set_bit_eq [no_vars]}
 
   \<^descr>[\<^theory>\<open>Word_Lib.Typedef_Morphisms\<close>]
 
     A low-level extension to HOL typedef providing
     conversions along type morphisms.  The @{method transfer} method
     seems to be sufficient for most applications though.
 
   \<^descr>[\<^theory>\<open>Word_Lib.Bit_Comprehension\<close>]
 
     Comprehension syntax for bit values over predicates
     \<^typ>\<open>nat \<Rightarrow> bool\<close>.  For \<^typ>\<open>'a::len word\<close>, straightforward
     alternatives exist; difficult to handle for \<^typ>\<open>int\<close>.
 
   \<^descr>[\<^theory>\<open>Word_Lib.Reversed_Bit_Lists\<close>]
 
     Representation of bit values as explicit list in
     \<^emph>\<open>reversed\<close> order.
 
     This should rarely be necessary: the \<^const>\<open>bit\<close> projection
     should be sufficient in most cases.  In case explicit lists
     are needed, existing operations can be used:
 
     @{thm [display] horner_sum_bit_eq_take_bit [where ?'a = int, no_vars]}
 
   \<^descr>[\<^theory>\<open>Word_Lib.Many_More\<close>]
 
     Collection of operations and theorems which are kept for backward
     compatibility and not used in other theories in session \<^text>\<open>Word_Lib\<close>.
     They are used in applications of \<^text>\<open>Word_Lib\<close>, but should be migrated to there.
 \<close>
 
 section \<open>Changelog\<close>
 
 text \<open>
   \<^descr>[Changes since AFP 2021] ~
 
     \<^item> Theory \<^theory>\<open>Word_Lib.Ancient_Numeral\<close> is no part of \<^theory>\<open>Word_Lib.Word_Lib_Sumo\<close>
       any longer.
 
     \<^item> Infix syntax for \<^term>\<open>(AND)\<close>, \<^term>\<open>(OR)\<close>, \<^term>\<open>(XOR)\<close> organized in
       syntax bundle \<^text>\<open>bit_operations_syntax\<close>.
 
     \<^item> Abbreviation \<^abbrev>\<open>max_word\<close> moved from distribution into theory
       \<^theory>\<open>Word_Lib.Legacy_Aliases\<close>.
 
     \<^item> Operation \<^const>\<open>test_bit\<close> replaced by input abbreviation \<^abbrev>\<open>test_bit\<close>.
 
     \<^item> Operation \<^const>\<open>shiftl\<close> replaced by input abbreviation \<^abbrev>\<open>shiftl\<close>.
 
     \<^item> Operation \<^const>\<open>shiftr\<close> replaced by input abbreviation \<^abbrev>\<open>shiftr\<close>.
 
     \<^item> Operation \<^const>\<open>sshiftr\<close> replaced by input abbreviation \<^abbrev>\<open>sshiftr\<close>.
 
     \<^item> Abbreviations \<^abbrev>\<open>bin_nth\<close>, \<^abbrev>\<open>bin_last\<close>, \<^abbrev>\<open>bin_rest\<close>,
       \<^abbrev>\<open>bintrunc\<close>, \<^abbrev>\<open>sbintrunc\<close>, \<^abbrev>\<open>norm_sint\<close>,
       \<^abbrev>\<open>bin_cat\<close> moved into theory \<^theory>\<open>Word_Lib.Legacy_Aliases\<close>.
 
     \<^item> Operations \<^abbrev>\<open>shiftl1\<close>, \<^abbrev>\<open>shiftr1\<close>, \<^abbrev>\<open>sshiftr1\<close>, \<^abbrev>\<open>bshiftr1\<close>,
       \<^abbrev>\<open>setBit\<close>, \<^abbrev>\<open>clearBit\<close> moved from distribution into theory
       \<^theory>\<open>Word_Lib.Legacy_Aliases\<close> and replaced by input abbreviations.
 
     \<^item> Operation \<^const>\<open>complement\<close> replaced by input abbreviation \<^abbrev>\<open>complement\<close>.
 \<close>
 
 (*<*)
 end
 (*>*)
diff --git a/thys/Word_Lib/More_Arithmetic.thy b/thys/Word_Lib/More_Arithmetic.thy
--- a/thys/Word_Lib/More_Arithmetic.thy
+++ b/thys/Word_Lib/More_Arithmetic.thy
@@ -1,137 +1,137 @@
 (*
  * Copyright Data61, CSIRO (ABN 41 687 119 230)
  *
  * SPDX-License-Identifier: BSD-2-Clause
  *)
 
 section \<open>Arithmetic lemmas\<close>
 
 theory More_Arithmetic
-  imports Main "HOL-Library.Type_Length" "HOL-Library.Bit_Operations"
+  imports Main "HOL-Library.Type_Length"
 begin
 
 lemma n_less_equal_power_2:
   "n < 2 ^ n"
   by (fact less_exp)
 
 lemma min_pm [simp]: "min a b + (a - b) = a"
   for a b :: nat
   by arith
 
 lemma min_pm1 [simp]: "a - b + min a b = a"
   for a b :: nat
   by arith
 
 lemma rev_min_pm [simp]: "min b a + (a - b) = a"
   for a b :: nat
   by arith
 
 lemma rev_min_pm1 [simp]: "a - b + min b a = a"
   for a b :: nat
   by arith
 
 lemma min_minus [simp]: "min m (m - k) = m - k"
   for m k :: nat
   by arith
 
 lemma min_minus' [simp]: "min (m - k) m = m - k"
   for m k :: nat
   by arith
 
 lemma nat_less_power_trans:
   fixes n :: nat
   assumes nv: "n < 2 ^ (m - k)"
   and     kv: "k \<le> m"
   shows "2 ^ k * n < 2 ^ m"
 proof (rule order_less_le_trans)
   show "2 ^ k * n < 2 ^ k * 2 ^ (m - k)"
     by (rule mult_less_mono2 [OF nv zero_less_power]) simp
   show "(2::nat) ^ k * 2 ^ (m - k) \<le> 2 ^ m" using nv kv
     by (subst power_add [symmetric]) simp
 qed
 
 lemma nat_le_power_trans:
   fixes n :: nat
   shows "\<lbrakk>n \<le> 2 ^ (m - k); k \<le> m\<rbrakk> \<Longrightarrow> 2 ^ k * n \<le> 2 ^ m"
   by (metis le_add_diff_inverse mult_le_mono2 semiring_normalization_rules(26))
 
 lemma nat_add_offset_less:
   fixes x :: nat
   assumes yv: "y < 2 ^ n"
   and     xv: "x < 2 ^ m"
   and     mn: "sz = m + n"
   shows   "x * 2 ^ n + y < 2 ^ sz"
 proof (subst mn)
   from yv obtain qy where "y + qy = 2 ^ n" and "0 < qy"
     by (auto dest: less_imp_add_positive)
 
   have "x * 2 ^ n + y < x * 2 ^ n + 2 ^ n" by simp fact+
   also have "\<dots> = (x + 1) * 2 ^ n" by simp
   also have "\<dots> \<le> 2 ^ (m + n)" using xv
     by (subst power_add) (rule mult_le_mono1, simp)
   finally show "x * 2 ^ n + y < 2 ^ (m + n)" .
 qed
 
 lemma nat_power_less_diff:
   assumes lt: "(2::nat) ^ n * q < 2 ^ m"
   shows "q < 2 ^ (m - n)"
   using lt
 proof (induct n arbitrary: m)
   case 0
   then show ?case by simp
 next
   case (Suc n)
 
   have ih: "\<And>m. 2 ^ n * q < 2 ^ m \<Longrightarrow> q < 2 ^ (m - n)"
     and prem: "2 ^ Suc n * q < 2 ^ m" by fact+
 
   show ?case
   proof (cases m)
     case 0
     then show ?thesis using Suc by simp
   next
     case (Suc m')
     then show ?thesis using prem
       by (simp add: ac_simps ih)
   qed
 qed
 
 lemma power_2_mult_step_le:
   "\<lbrakk>n' \<le> n; 2 ^ n' * k' < 2 ^ n * k\<rbrakk> \<Longrightarrow> 2 ^ n' * (k' + 1) \<le> 2 ^ n * (k::nat)"
   apply (cases "n'=n", simp)
    apply (metis Suc_leI le_refl mult_Suc_right mult_le_mono semiring_normalization_rules(7))
   apply (drule (1) le_neq_trans)
   apply clarsimp
   apply (subgoal_tac "\<exists>m. n = n' + m")
    prefer 2
    apply (simp add: le_Suc_ex)
   apply (clarsimp simp: power_add)
   apply (metis Suc_leI mult.assoc mult_Suc_right nat_mult_le_cancel_disj)
   done
 
 lemma nat_mult_power_less_eq:
   "b > 0 \<Longrightarrow> (a * b ^ n < (b :: nat) ^ m) = (a < b ^ (m - n))"
   using mult_less_cancel2[where m = a and k = "b ^ n" and n="b ^ (m - n)"]
         mult_less_cancel2[where m="a * b ^ (n - m)" and k="b ^ m" and n=1]
   apply (simp only: power_add[symmetric] nat_minus_add_max)
   apply (simp only: power_add[symmetric] nat_minus_add_max ac_simps)
   apply (simp add: max_def split: if_split_asm)
   done
 
 lemma diff_diff_less:
   "(i < m - (m - (n :: nat))) = (i < m \<and> i < n)"
   by auto
 
 lemma small_powers_of_2:
   \<open>x < 2 ^ (x - 1)\<close> if \<open>x \<ge> 3\<close> for x :: nat
 proof -
   define m where \<open>m = x - 3\<close>
   with that have \<open>x = m + 3\<close>
     by simp
   moreover have \<open>m + 3 < 4 * 2 ^ m\<close>
     by (induction m) simp_all
   ultimately show ?thesis
     by simp
 qed
 
 end
diff --git a/thys/Word_Lib/More_Word.thy b/thys/Word_Lib/More_Word.thy
--- a/thys/Word_Lib/More_Word.thy
+++ b/thys/Word_Lib/More_Word.thy
@@ -1,2550 +1,2550 @@
 (*
  * Copyright Data61, CSIRO (ABN 41 687 119 230)
  *
  * SPDX-License-Identifier: BSD-2-Clause
  *)
 
 section \<open>Lemmas on words\<close>
 
 theory More_Word
   imports
     "HOL-Library.Word"
     More_Arithmetic
     More_Divides
 begin
 
 context
   includes bit_operations_syntax
 begin
 
 \<comment> \<open>problem posed by TPHOLs referee:
       criterion for overflow of addition of signed integers\<close>
 
 lemma sofl_test:
   \<open>sint x + sint y = sint (x + y) \<longleftrightarrow>
     drop_bit (size x - 1) ((x + y XOR x) AND (x + y XOR y)) = 0\<close>
   for x y :: \<open>'a::len word\<close>
 proof -
   obtain n where n: \<open>LENGTH('a) = Suc n\<close>
     by (cases \<open>LENGTH('a)\<close>) simp_all
   have *: \<open>sint x + sint y + 2 ^ Suc n > signed_take_bit n (sint x + sint y) \<Longrightarrow> sint x + sint y \<ge> - (2 ^ n)\<close>
     \<open>signed_take_bit n (sint x + sint y) > sint x + sint y - 2 ^ Suc n \<Longrightarrow> 2 ^ n > sint x + sint y\<close>
     using signed_take_bit_int_greater_eq [of \<open>sint x + sint y\<close> n] signed_take_bit_int_less_eq [of n \<open>sint x + sint y\<close>]
     by (auto intro: ccontr)
   have \<open>sint x + sint y = sint (x + y) \<longleftrightarrow>
     (sint (x + y) < 0 \<longleftrightarrow> sint x < 0) \<or>
     (sint (x + y) < 0 \<longleftrightarrow> sint y < 0)\<close>
     using sint_less [of x] sint_greater_eq [of x] sint_less [of y] sint_greater_eq [of y]
     signed_take_bit_int_eq_self [of \<open>LENGTH('a) - 1\<close> \<open>sint x + sint y\<close>]
     apply (auto simp add: not_less)
        apply (unfold sint_word_ariths)
        apply (subst signed_take_bit_int_eq_self)
          prefer 4
          apply (subst signed_take_bit_int_eq_self)
            prefer 7
            apply (subst signed_take_bit_int_eq_self)
              prefer 10
              apply (subst signed_take_bit_int_eq_self)
                apply (auto simp add: signed_take_bit_int_eq_self signed_take_bit_eq_take_bit_minus take_bit_Suc_from_most n not_less intro!: *)
        apply (smt (z3) take_bit_nonnegative)
       apply (smt (z3) take_bit_int_less_exp)
      apply (smt (z3) take_bit_nonnegative)
     apply (smt (z3) take_bit_int_less_exp)
     done
   then show ?thesis
     apply (simp only: One_nat_def word_size drop_bit_eq_zero_iff_not_bit_last bit_and_iff bit_xor_iff)
     apply (simp add: bit_last_iff)
     done
 qed
 
 lemma unat_power_lower [simp]:
   "unat ((2::'a::len word) ^ n) = 2 ^ n" if "n < LENGTH('a::len)"
   using that by transfer simp
 
 lemma unat_p2: "n < LENGTH('a :: len) \<Longrightarrow> unat (2 ^ n :: 'a word) = 2 ^ n"
   by (fact unat_power_lower)
 
 lemma word_div_lt_eq_0:
   "x < y \<Longrightarrow> x div y = 0" for x :: "'a :: len word"
   by transfer simp
 
 lemma word_div_eq_1_iff: "n div m = 1 \<longleftrightarrow> n \<ge> m \<and> unat n < 2 * unat (m :: 'a :: len word)"
   apply (simp only: word_arith_nat_defs word_le_nat_alt word_of_nat_eq_iff flip: nat_div_eq_Suc_0_iff)
   apply (simp flip: unat_div unsigned_take_bit_eq)
   done
 
 lemma AND_twice [simp]:
   "(w AND m) AND m = w AND m"
   by (fact and.right_idem)
 
 lemma word_combine_masks:
   "w AND m = z \<Longrightarrow> w AND m' = z' \<Longrightarrow> w AND (m OR m') = (z OR z')"
   for w m m' z z' :: \<open>'a::len word\<close>
   by (simp add: bit.conj_disj_distrib)
 
 lemma p2_gt_0:
   "(0 < (2 ^ n :: 'a :: len word)) = (n < LENGTH('a))"
   by (simp add : word_gt_0 not_le)
 
 lemma uint_2p_alt:
   \<open>n < LENGTH('a::len) \<Longrightarrow> uint ((2::'a::len word) ^ n) = 2 ^ n\<close>
   using p2_gt_0 [of n, where ?'a = 'a] by (simp add: uint_2p)
 
 lemma p2_eq_0:
   \<open>(2::'a::len word) ^ n = 0 \<longleftrightarrow> LENGTH('a::len) \<le> n\<close>
   by (fact exp_eq_zero_iff)
 
 lemma p2len:
   \<open>(2 :: 'a word) ^ LENGTH('a::len) = 0\<close>
   by simp
 
 lemma neg_mask_is_div:
   "w AND NOT (mask n) = (w div 2^n) * 2^n"
   for w :: \<open>'a::len word\<close>
   by (rule bit_word_eqI)
     (auto simp add: bit_simps simp flip: push_bit_eq_mult drop_bit_eq_div)
 
 lemma neg_mask_is_div':
   "n < size w \<Longrightarrow> w AND NOT (mask n) = ((w div (2 ^ n)) * (2 ^ n))"
   for w :: \<open>'a::len word\<close>
   by (rule neg_mask_is_div)
 
 lemma and_mask_arith:
   "w AND mask n = (w * 2^(size w - n)) div 2^(size w - n)"
   for w :: \<open>'a::len word\<close>
   by (rule bit_word_eqI)
     (auto simp add: bit_simps word_size simp flip: push_bit_eq_mult drop_bit_eq_div)
 
 lemma and_mask_arith':
   "0 < n \<Longrightarrow> w AND mask n = (w * 2^(size w - n)) div 2^(size w - n)"
   for w :: \<open>'a::len word\<close>
   by (rule and_mask_arith)
 
 lemma mask_2pm1: "mask n = 2 ^ n - (1 :: 'a::len word)"
   by (fact mask_eq_decr_exp)
 
 lemma add_mask_fold:
   "x + 2 ^ n - 1 = x + mask n"
   for x :: \<open>'a::len word\<close>
   by (simp add: mask_eq_decr_exp)
 
 lemma word_and_mask_le_2pm1: "w AND mask n \<le> 2 ^ n - 1"
   for w :: \<open>'a::len word\<close>
   by (simp add: mask_2pm1[symmetric] word_and_le1)
 
 lemma is_aligned_AND_less_0:
   "u AND mask n = 0 \<Longrightarrow> v < 2^n \<Longrightarrow> u AND v = 0"
   for u v :: \<open>'a::len word\<close>
   apply (drule less_mask_eq)
   apply (simp flip: take_bit_eq_mask)
   apply (simp add: bit_eq_iff)
   apply (auto simp add: bit_simps)
   done
 
 lemma and_mask_eq_iff_le_mask:
   \<open>w AND mask n = w \<longleftrightarrow> w \<le> mask n\<close>
   for w :: \<open>'a::len word\<close>
   apply (simp flip: take_bit_eq_mask)
   apply (cases \<open>n \<ge> LENGTH('a)\<close>; transfer)
    apply (simp_all add: not_le min_def)
    apply (simp_all add: mask_eq_exp_minus_1)
   apply auto
    apply (metis take_bit_int_less_exp)
   apply (metis min_def nat_less_le take_bit_int_eq_self_iff take_bit_take_bit)
   done
 
 lemma less_eq_mask_iff_take_bit_eq_self:
   \<open>w \<le> mask n \<longleftrightarrow> take_bit n w = w\<close>
   for w :: \<open>'a::len word\<close>
   by (simp add: and_mask_eq_iff_le_mask take_bit_eq_mask)
 
 lemma NOT_eq:
   "NOT (x :: 'a :: len word) = - x - 1"
   apply (cut_tac x = "x" in word_add_not)
   apply (drule add.commute [THEN trans])
   apply (drule eq_diff_eq [THEN iffD2])
   by simp
 
 lemma NOT_mask: "NOT (mask n :: 'a::len word) = - (2 ^ n)"
   by (simp add : NOT_eq mask_2pm1)
 
 lemma le_m1_iff_lt: "(x > (0 :: 'a :: len word)) = ((y \<le> x - 1) = (y < x))"
   by uint_arith
 
 lemma gt0_iff_gem1:
   \<open>0 < x \<longleftrightarrow> x - 1 < x\<close>
   for x :: \<open>'a::len word\<close>
   by (metis add.right_neutral diff_add_cancel less_irrefl measure_unat unat_arith_simps(2) word_neq_0_conv word_sub_less_iff)
 
 lemma power_2_ge_iff:
   \<open>2 ^ n - (1 :: 'a::len word) < 2 ^ n \<longleftrightarrow> n < LENGTH('a)\<close>
   using gt0_iff_gem1 p2_gt_0 by blast
 
 lemma le_mask_iff_lt_2n:
   "n < len_of TYPE ('a) = (((w :: 'a :: len word) \<le> mask n) = (w < 2 ^ n))"
   unfolding mask_2pm1 by (rule trans [OF p2_gt_0 [THEN sym] le_m1_iff_lt])
 
 lemma mask_lt_2pn:
   \<open>n < LENGTH('a) \<Longrightarrow> mask n < (2 :: 'a::len word) ^ n\<close>
   by (simp add: mask_eq_exp_minus_1 power_2_ge_iff)
 
 lemma word_unat_power:
   "(2 :: 'a :: len word) ^ n = of_nat (2 ^ n)"
   by simp
 
 lemma of_nat_mono_maybe:
   assumes xlt: "x < 2 ^ len_of TYPE ('a)"
   shows   "y < x \<Longrightarrow> of_nat y < (of_nat x :: 'a :: len word)"
   apply (subst word_less_nat_alt)
   apply (subst unat_of_nat)+
   apply (subst mod_less)
    apply (erule order_less_trans [OF _ xlt])
   apply (subst mod_less [OF xlt])
   apply assumption
   done
 
 lemma word_and_max_word:
   fixes a::"'a::len word"
   shows "x = - 1 \<Longrightarrow> a AND x = a"
   by simp
 
 lemma word_and_full_mask_simp:
   \<open>x AND mask LENGTH('a) = x\<close> for x :: \<open>'a::len word\<close>
 proof (rule bit_eqI)
   fix n
   assume \<open>2 ^ n \<noteq> (0 :: 'a word)\<close>
   then have \<open>n < LENGTH('a)\<close>
     by simp
   then show \<open>bit (x AND Bit_Operations.mask LENGTH('a)) n \<longleftrightarrow> bit x n\<close>
     by (simp add: bit_and_iff bit_mask_iff)
 qed
 
 lemma of_int_uint:
   "of_int (uint x) = x"
   by (fact word_of_int_uint)
 
 corollary word_plus_and_or_coroll:
   "x AND y = 0 \<Longrightarrow> x + y = x OR y"
   for x y :: \<open>'a::len word\<close>
   using word_plus_and_or[where x=x and y=y]
   by simp
 
 corollary word_plus_and_or_coroll2:
   "(x AND w) + (x AND NOT w) = x"
   for x w :: \<open>'a::len word\<close>
   apply (subst disjunctive_add)
    apply (simp add: bit_simps)
   apply (simp flip: bit.conj_disj_distrib)
   done
 
 lemma nat_mask_eq:
   \<open>nat (mask n) = mask n\<close>
   by (simp add: nat_eq_iff of_nat_mask_eq)
 
 lemma unat_mask_eq:
   \<open>unat (mask n :: 'a::len word) = mask (min LENGTH('a) n)\<close>
   by transfer (simp add: nat_mask_eq)
 
 lemma word_plus_mono_left:
   fixes x :: "'a :: len word"
   shows "\<lbrakk>y \<le> z; x \<le> x + z\<rbrakk> \<Longrightarrow> y + x \<le> z + x"
   by unat_arith
 
 lemma less_Suc_unat_less_bound:
   "n < Suc (unat (x :: 'a :: len word)) \<Longrightarrow> n < 2 ^ LENGTH('a)"
   by (auto elim!: order_less_le_trans intro: Suc_leI)
 
 lemma up_ucast_inj:
   "\<lbrakk> ucast x = (ucast y::'b::len word); LENGTH('a) \<le> len_of TYPE ('b) \<rbrakk> \<Longrightarrow> x = (y::'a::len word)"
   by transfer (simp add: min_def split: if_splits)
 
 lemmas ucast_up_inj = up_ucast_inj
 
 lemma up_ucast_inj_eq:
   "LENGTH('a) \<le> len_of TYPE ('b) \<Longrightarrow> (ucast x = (ucast y::'b::len word)) = (x = (y::'a::len word))"
   by (fastforce dest: up_ucast_inj)
 
 lemma no_plus_overflow_neg:
   "(x :: 'a :: len word) < -y \<Longrightarrow> x \<le> x + y"
   by (metis diff_minus_eq_add less_imp_le sub_wrap_lt)
 
 lemma ucast_ucast_eq:
   "\<lbrakk> ucast x = (ucast (ucast y::'a word)::'c::len word); LENGTH('a) \<le> LENGTH('b);
      LENGTH('b) \<le> LENGTH('c) \<rbrakk> \<Longrightarrow>
    x = ucast y" for x :: "'a::len word" and y :: "'b::len word"
   apply transfer
   apply (cases \<open>LENGTH('c) = LENGTH('a)\<close>)
    apply (auto simp add: min_def)
   done
 
 lemma ucast_0_I:
   "x = 0 \<Longrightarrow> ucast x = 0"
   by simp
 
 lemma word_add_offset_less:
   fixes x :: "'a :: len word"
   assumes yv: "y < 2 ^ n"
   and     xv: "x < 2 ^ m"
   and     mnv: "sz < LENGTH('a :: len)"
   and    xv': "x < 2 ^ (LENGTH('a :: len) - n)"
   and     mn: "sz = m + n"
   shows   "x * 2 ^ n + y < 2 ^ sz"
 proof (subst mn)
   from mnv mn have nv: "n < LENGTH('a)" and mv: "m < LENGTH('a)"  by auto
 
   have uy: "unat y < 2 ^ n"
     by (rule order_less_le_trans [OF unat_mono [OF yv] order_eq_refl],
         rule unat_power_lower[OF nv])
 
   have ux: "unat x < 2 ^ m"
     by (rule order_less_le_trans [OF unat_mono [OF xv] order_eq_refl],
         rule unat_power_lower[OF mv])
 
   then show "x * 2 ^ n + y < 2 ^ (m + n)" using ux uy nv mnv xv'
     apply (subst word_less_nat_alt)
     apply (subst unat_word_ariths)+
     apply (subst mod_less)
      apply simp
      apply (subst mult.commute)
      apply (rule nat_less_power_trans [OF _ order_less_imp_le [OF nv]])
      apply (rule order_less_le_trans [OF unat_mono [OF xv']])
      apply (cases "n = 0"; simp)
     apply (subst unat_power_lower[OF nv])
     apply (subst mod_less)
      apply (erule order_less_le_trans [OF nat_add_offset_less], assumption)
       apply (rule mn)
      apply simp
     apply (simp add: mn mnv)
     apply (erule nat_add_offset_less; simp)
     done
 qed
 
 lemma word_less_power_trans:
   fixes n :: "'a :: len word"
   assumes nv: "n < 2 ^ (m - k)"
   and     kv: "k \<le> m"
   and     mv: "m < len_of TYPE ('a)"
   shows "2 ^ k * n < 2 ^ m"
   using nv kv mv
   apply -
   apply (subst word_less_nat_alt)
   apply (subst unat_word_ariths)
   apply (subst mod_less)
    apply simp
    apply (rule nat_less_power_trans)
     apply (erule order_less_trans [OF unat_mono])
     apply simp
    apply simp
   apply simp
   apply (rule nat_less_power_trans)
    apply (subst unat_power_lower[where 'a = 'a, symmetric])
     apply simp
    apply (erule unat_mono)
   apply simp
   done
 
 lemma  word_less_power_trans2:
   fixes n :: "'a::len word"
   shows "\<lbrakk>n < 2 ^ (m - k); k \<le> m; m < LENGTH('a)\<rbrakk> \<Longrightarrow> n * 2 ^ k < 2 ^ m"
   by (subst field_simps, rule word_less_power_trans)
 
 lemma Suc_unat_diff_1:
   fixes x :: "'a :: len word"
   assumes lt: "1 \<le> x"
   shows "Suc (unat (x - 1)) = unat x"
 proof -
   have "0 < unat x"
     by (rule order_less_le_trans [where y = 1], simp, subst unat_1 [symmetric],
         rule iffD1 [OF word_le_nat_alt lt])
 
   then show ?thesis
     by ((subst unat_sub [OF lt])+, simp only:  unat_1)
 qed
 
 lemma word_eq_unatI:
   \<open>v = w\<close> if \<open>unat v = unat w\<close>
   using that by transfer (simp add: nat_eq_iff)
 
 lemma word_div_sub:
   fixes x :: "'a :: len word"
   assumes yx: "y \<le> x"
   and     y0: "0 < y"
   shows "(x - y) div y = x div y - 1"
   apply (rule word_eq_unatI)
   apply (subst unat_div)
   apply (subst unat_sub [OF yx])
   apply (subst unat_sub)
    apply (subst word_le_nat_alt)
    apply (subst unat_div)
    apply (subst le_div_geq)
      apply (rule order_le_less_trans [OF _ unat_mono [OF y0]])
      apply simp
     apply (subst word_le_nat_alt [symmetric], rule yx)
    apply simp
   apply (subst unat_div)
   apply (subst le_div_geq [OF _ iffD1 [OF word_le_nat_alt yx]])
    apply (rule order_le_less_trans [OF _ unat_mono [OF y0]])
    apply simp
   apply simp
   done
 
 lemma word_mult_less_mono1:
   fixes i :: "'a :: len word"
   assumes ij: "i < j"
   and    knz: "0 < k"
   and    ujk: "unat j * unat k < 2 ^ len_of TYPE ('a)"
   shows  "i * k < j * k"
 proof -
   from ij ujk knz have jk: "unat i * unat k < 2 ^ len_of TYPE ('a)"
     by (auto intro: order_less_subst2 simp: word_less_nat_alt elim: mult_less_mono1)
 
   then show ?thesis using ujk knz ij
     by (auto simp: word_less_nat_alt iffD1 [OF unat_mult_lem])
 qed
 
 lemma word_mult_less_dest:
   fixes i :: "'a :: len word"
   assumes ij: "i * k < j * k"
   and    uik: "unat i * unat k < 2 ^ len_of TYPE ('a)"
   and    ujk: "unat j * unat k < 2 ^ len_of TYPE ('a)"
   shows  "i < j"
   using uik ujk ij
   by (auto simp: word_less_nat_alt iffD1 [OF unat_mult_lem] elim: mult_less_mono1)
 
 lemma word_mult_less_cancel:
   fixes k :: "'a :: len word"
   assumes knz: "0 < k"
   and    uik: "unat i * unat k < 2 ^ len_of TYPE ('a)"
   and    ujk: "unat j * unat k < 2 ^ len_of TYPE ('a)"
   shows "(i * k < j * k) = (i < j)"
   by (rule iffI [OF word_mult_less_dest [OF _ uik ujk] word_mult_less_mono1 [OF _ knz ujk]])
 
 lemma Suc_div_unat_helper:
   assumes szv: "sz < LENGTH('a :: len)"
   and   usszv: "us \<le> sz"
   shows "2 ^ (sz - us) = Suc (unat (((2::'a :: len word) ^ sz - 1) div 2 ^ us))"
 proof -
   note usv = order_le_less_trans [OF usszv szv]
 
   from usszv obtain q where qv: "sz = us + q" by (auto simp: le_iff_add)
 
   have "Suc (unat (((2:: 'a word) ^ sz - 1) div 2 ^ us)) =
     (2 ^ us + unat ((2:: 'a word) ^ sz - 1)) div 2 ^ us"
     apply (subst unat_div unat_power_lower[OF usv])+
     apply (subst div_add_self1, simp+)
     done
 
   also have "\<dots> = ((2 ^ us - 1) + 2 ^ sz) div 2 ^ us" using szv
     by (simp add: unat_minus_one)
 
   also have "\<dots> = 2 ^ q + ((2 ^ us - 1) div 2 ^ us)"
     apply (subst qv)
     apply (subst power_add)
     apply (subst div_mult_self2; simp)
     done
 
   also have "\<dots> = 2 ^ (sz - us)" using qv by simp
 
   finally show ?thesis ..
 qed
 
 lemma enum_word_nth_eq:
   \<open>(Enum.enum :: 'a::len word list) ! n = word_of_nat n\<close>
     if \<open>n < 2 ^ LENGTH('a)\<close>
     for n
   using that by (simp add: enum_word_def)
 
 lemma length_enum_word_eq:
   \<open>length (Enum.enum :: 'a::len word list) = 2 ^ LENGTH('a)\<close>
   by (simp add: enum_word_def)
 
 lemma unat_lt2p [iff]:
   \<open>unat x < 2 ^ LENGTH('a)\<close> for x :: \<open>'a::len word\<close>
   by transfer simp
 
 lemma of_nat_unat [simp]:
   "of_nat \<circ> unat = id"
   by (rule ext, simp)
 
 lemma Suc_unat_minus_one [simp]:
   "x \<noteq> 0 \<Longrightarrow> Suc (unat (x - 1)) = unat x"
   by (metis Suc_diff_1 unat_gt_0 unat_minus_one)
 
 lemma word_add_le_dest:
   fixes i :: "'a :: len word"
   assumes le: "i + k \<le> j + k"
   and    uik: "unat i + unat k < 2 ^ len_of TYPE ('a)"
   and    ujk: "unat j + unat k < 2 ^ len_of TYPE ('a)"
   shows  "i \<le> j"
   using uik ujk le
   by (auto simp: word_le_nat_alt iffD1 [OF unat_add_lem] elim: add_le_mono1)
 
 lemma word_add_le_mono1:
   fixes i :: "'a :: len word"
   assumes ij: "i \<le> j"
   and    ujk: "unat j + unat k < 2 ^ len_of TYPE ('a)"
   shows  "i + k \<le> j + k"
 proof -
   from ij ujk have jk: "unat i + unat k < 2 ^ len_of TYPE ('a)"
     by (auto elim: order_le_less_subst2 simp: word_le_nat_alt elim: add_le_mono1)
 
   then show ?thesis using ujk ij
     by (auto simp: word_le_nat_alt iffD1 [OF unat_add_lem])
 qed
 
 lemma word_add_le_mono2:
   fixes i :: "'a :: len word"
   shows "\<lbrakk>i \<le> j; unat j + unat k < 2 ^ LENGTH('a)\<rbrakk> \<Longrightarrow> k + i \<le> k + j"
   by (subst field_simps, subst field_simps, erule (1) word_add_le_mono1)
 
 lemma word_add_le_iff:
   fixes i :: "'a :: len word"
   assumes uik: "unat i + unat k < 2 ^ len_of TYPE ('a)"
   and     ujk: "unat j + unat k < 2 ^ len_of TYPE ('a)"
   shows  "(i + k \<le> j + k) = (i \<le> j)"
 proof
   assume "i \<le> j"
   show "i + k \<le> j + k" by (rule word_add_le_mono1) fact+
 next
   assume "i + k \<le> j + k"
   show "i \<le> j" by (rule word_add_le_dest) fact+
 qed
 
 lemma word_add_less_mono1:
   fixes i :: "'a :: len word"
   assumes ij: "i < j"
   and    ujk: "unat j + unat k < 2 ^ len_of TYPE ('a)"
   shows  "i + k < j + k"
 proof -
   from ij ujk have jk: "unat i + unat k < 2 ^ len_of TYPE ('a)"
     by (auto elim: order_le_less_subst2 simp: word_less_nat_alt elim: add_less_mono1)
 
   then show ?thesis using ujk ij
     by (auto simp: word_less_nat_alt iffD1 [OF unat_add_lem])
 qed
 
 lemma word_add_less_dest:
   fixes i :: "'a :: len word"
   assumes le: "i + k < j + k"
   and    uik: "unat i + unat k < 2 ^ len_of TYPE ('a)"
   and    ujk: "unat j + unat k < 2 ^ len_of TYPE ('a)"
   shows  "i < j"
   using uik ujk le
   by (auto simp: word_less_nat_alt iffD1 [OF unat_add_lem] elim: add_less_mono1)
 
 lemma word_add_less_iff:
   fixes i :: "'a :: len word"
   assumes uik: "unat i + unat k < 2 ^ len_of TYPE ('a)"
   and     ujk: "unat j + unat k < 2 ^ len_of TYPE ('a)"
   shows  "(i + k < j + k) = (i < j)"
 proof
   assume "i < j"
   show "i + k < j + k" by (rule word_add_less_mono1) fact+
 next
   assume "i + k < j + k"
   show "i < j" by (rule word_add_less_dest) fact+
 qed
 
 lemma word_mult_less_iff:
   fixes i :: "'a :: len word"
   assumes knz: "0 < k"
   and     uik: "unat i * unat k < 2 ^ len_of TYPE ('a)"
   and     ujk: "unat j * unat k < 2 ^ len_of TYPE ('a)"
   shows  "(i * k < j * k) = (i < j)"
   using assms by (rule word_mult_less_cancel)
 
 lemma word_le_imp_diff_le:
   fixes n :: "'a::len word"
   shows "\<lbrakk>k \<le> n; n \<le> m\<rbrakk> \<Longrightarrow> n - k \<le> m"
   by (auto simp: unat_sub word_le_nat_alt)
 
 lemma word_less_imp_diff_less:
   fixes n :: "'a::len word"
   shows "\<lbrakk>k \<le> n; n < m\<rbrakk> \<Longrightarrow> n - k < m"
   by (clarsimp simp: unat_sub word_less_nat_alt
              intro!: less_imp_diff_less)
 
 lemma word_mult_le_mono1:
   fixes i :: "'a :: len word"
   assumes ij: "i \<le> j"
   and    knz: "0 < k"
   and    ujk: "unat j * unat k < 2 ^ len_of TYPE ('a)"
   shows  "i * k \<le> j * k"
 proof -
   from ij ujk knz have jk: "unat i * unat k < 2 ^ len_of TYPE ('a)"
     by (auto elim: order_le_less_subst2 simp: word_le_nat_alt elim: mult_le_mono1)
 
   then show ?thesis using ujk knz ij
     by (auto simp: word_le_nat_alt iffD1 [OF unat_mult_lem])
 qed
 
 lemma word_mult_le_iff:
   fixes i :: "'a :: len word"
   assumes knz: "0 < k"
   and     uik: "unat i * unat k < 2 ^ len_of TYPE ('a)"
   and     ujk: "unat j * unat k < 2 ^ len_of TYPE ('a)"
   shows  "(i * k \<le> j * k) = (i \<le> j)"
 proof
   assume "i \<le> j"
   show "i * k \<le> j * k" by (rule word_mult_le_mono1) fact+
 next
   assume p: "i * k \<le> j * k"
 
   have "0 < unat k" using knz by (simp add: word_less_nat_alt)
   then show "i \<le> j" using p
     by (clarsimp simp: word_le_nat_alt iffD1 [OF unat_mult_lem uik]
       iffD1 [OF unat_mult_lem ujk])
 qed
 
 lemma word_diff_less:
   fixes n :: "'a :: len word"
   shows "\<lbrakk>0 < n; 0 < m; n \<le> m\<rbrakk> \<Longrightarrow> m - n < m"
   apply (subst word_less_nat_alt)
   apply (subst unat_sub)
    apply assumption
   apply (rule diff_less)
    apply (simp_all add: word_less_nat_alt)
   done
 
 lemma word_add_increasing:
   fixes x :: "'a :: len word"
   shows "\<lbrakk> p + w \<le> x; p \<le> p + w \<rbrakk> \<Longrightarrow> p \<le> x"
   by unat_arith
 
 lemma word_random:
   fixes x :: "'a :: len word"
   shows "\<lbrakk> p \<le> p + x'; x \<le> x' \<rbrakk> \<Longrightarrow> p \<le> p + x"
   by unat_arith
 
 lemma word_sub_mono:
   "\<lbrakk> a \<le> c; d \<le> b; a - b \<le> a; c - d \<le> c \<rbrakk>
     \<Longrightarrow> (a - b) \<le> (c - d :: 'a :: len word)"
   by unat_arith
 
 lemma power_not_zero:
   "n < LENGTH('a::len) \<Longrightarrow> (2 :: 'a word) ^ n \<noteq> 0"
   by (metis p2_gt_0 word_neq_0_conv)
 
 lemma word_gt_a_gt_0:
   "a < n \<Longrightarrow> (0 :: 'a::len word) < n"
   apply (case_tac "n = 0")
    apply clarsimp
   apply (clarsimp simp: word_neq_0_conv)
   done
 
 lemma word_power_less_1 [simp]:
   "sz < LENGTH('a::len) \<Longrightarrow> (2::'a word) ^ sz - 1 < 2 ^ sz"
   apply (simp add: word_less_nat_alt)
   apply (subst unat_minus_one)
   apply simp_all
   done
 
 lemma word_sub_1_le:
   "x \<noteq> 0 \<Longrightarrow> x - 1 \<le> (x :: ('a :: len) word)"
   apply (subst no_ulen_sub)
   apply simp
   apply (cases "uint x = 0")
    apply (simp add: uint_0_iff)
   apply (insert uint_ge_0[where x=x])
   apply arith
   done
 
 lemma push_bit_word_eq_nonzero:
   \<open>push_bit n w \<noteq> 0\<close> if \<open>w < 2 ^ m\<close> \<open>m + n < LENGTH('a)\<close> \<open>w \<noteq> 0\<close>
     for w :: \<open>'a::len word\<close>
   using that
   apply (simp only: word_neq_0_conv word_less_nat_alt
                     mod_0 unat_word_ariths
                     unat_power_lower word_le_nat_alt)
   apply (metis add_diff_cancel_right' gr0I gr_implies_not0 less_or_eq_imp_le min_def push_bit_eq_0_iff take_bit_nat_eq_self_iff take_bit_push_bit take_bit_take_bit unsigned_push_bit_eq)
   done
 
 lemma unat_less_power:
   fixes k :: "'a::len word"
   assumes szv: "sz < LENGTH('a)"
   and     kv:  "k < 2 ^ sz"
   shows   "unat k < 2 ^ sz"
   using szv unat_mono [OF kv] by simp
 
 lemma unat_mult_power_lem:
   assumes kv: "k < 2 ^ (LENGTH('a::len) - sz)"
   shows "unat (2 ^ sz * of_nat k :: (('a::len) word)) = 2 ^ sz * k"
 proof (cases \<open>sz < LENGTH('a)\<close>)
   case True
   with assms show ?thesis
     by (simp add: unat_word_ariths take_bit_eq_mod mod_simps)
       (simp add: take_bit_nat_eq_self_iff nat_less_power_trans flip: take_bit_eq_mod)
 next
   case False
   with assms show ?thesis
     by simp
 qed
 
 lemma word_plus_mcs_4:
   "\<lbrakk>v + x \<le> w + x; x \<le> v + x\<rbrakk> \<Longrightarrow> v \<le> (w::'a::len word)"
   by uint_arith
 
 lemma word_plus_mcs_3:
   "\<lbrakk>v \<le> w; x \<le> w + x\<rbrakk> \<Longrightarrow> v + x \<le> w + (x::'a::len word)"
   by unat_arith
 
 lemma word_le_minus_one_leq:
   "x < y \<Longrightarrow> x \<le> y - 1" for x :: "'a :: len word"
   by transfer (metis le_less_trans less_irrefl take_bit_decr_eq take_bit_nonnegative zle_diff1_eq)
 
 lemma word_less_sub_le[simp]:
   fixes x :: "'a :: len word"
   assumes nv: "n < LENGTH('a)"
   shows "(x \<le> 2 ^ n - 1) = (x < 2 ^ n)"
   using le_less_trans word_le_minus_one_leq nv power_2_ge_iff by blast
 
 lemma unat_of_nat_len:
   "x < 2 ^ LENGTH('a) \<Longrightarrow> unat (of_nat x :: 'a::len word) = x"
   by (simp add: take_bit_nat_eq_self_iff)
 
 lemma unat_of_nat_eq:
   "x < 2 ^ LENGTH('a) \<Longrightarrow> unat (of_nat x ::'a::len word) = x"
   by (rule unat_of_nat_len)
 
 lemma unat_eq_of_nat:
   "n < 2 ^ LENGTH('a) \<Longrightarrow> (unat (x :: 'a::len word) = n) = (x = of_nat n)"
   by transfer
     (auto simp add: take_bit_of_nat nat_eq_iff take_bit_nat_eq_self_iff intro: sym)
 
 lemma alignUp_div_helper:
   fixes a :: "'a::len word"
   assumes kv: "k < 2 ^ (LENGTH('a) - n)"
   and     xk: "x = 2 ^ n * of_nat k"
   and    le: "a \<le> x"
   and    sz: "n < LENGTH('a)"
   and   anz: "a mod 2 ^ n \<noteq> 0"
   shows "a div 2 ^ n < of_nat k"
 proof -
   have kn: "unat (of_nat k :: 'a word) * unat ((2::'a word) ^ n) < 2 ^ LENGTH('a)"
     using xk kv sz
     apply (subst unat_of_nat_eq)
      apply (erule order_less_le_trans)
      apply simp
     apply (subst unat_power_lower, simp)
     apply (subst mult.commute)
     apply (rule nat_less_power_trans)
      apply simp
     apply simp
     done
 
   have "unat a div 2 ^ n * 2 ^ n \<noteq> unat a"
   proof -
     have "unat a = unat a div 2 ^ n * 2 ^ n + unat a mod 2 ^ n"
       by (simp add: div_mult_mod_eq)
     also have "\<dots> \<noteq> unat a div 2 ^ n * 2 ^ n" using sz anz
       by (simp add: unat_arith_simps)
     finally show ?thesis ..
   qed
 
   then have "a div 2 ^ n * 2 ^ n < a" using sz anz
     apply (subst word_less_nat_alt)
     apply (subst unat_word_ariths)
     apply (subst unat_div)
     apply simp
     apply (rule order_le_less_trans [OF mod_less_eq_dividend])
     apply (erule order_le_neq_trans [OF div_mult_le])
     done
 
   also from xk le have "\<dots> \<le> of_nat k * 2 ^ n" by (simp add: field_simps)
   finally show ?thesis using sz kv
     apply -
     apply (erule word_mult_less_dest [OF _ _ kn])
     apply (simp add: unat_div)
     apply (rule order_le_less_trans [OF div_mult_le])
     apply (rule unat_lt2p)
     done
 qed
 
 lemma mask_out_sub_mask:
   "(x AND NOT (mask n)) = x - (x AND (mask n))"
   for x :: \<open>'a::len word\<close>
   by (simp add: field_simps word_plus_and_or_coroll2)
 
 lemma subtract_mask:
   "p - (p AND mask n) = (p AND NOT (mask n))"
   "p - (p AND NOT (mask n)) = (p AND mask n)"
   for p :: \<open>'a::len word\<close>
   by (simp add: field_simps word_plus_and_or_coroll2)+
 
 lemma take_bit_word_eq_self_iff:
   \<open>take_bit n w = w \<longleftrightarrow> n \<ge> LENGTH('a) \<or> w < 2 ^ n\<close>
   for w :: \<open>'a::len word\<close>
   using take_bit_int_eq_self_iff [of n \<open>take_bit LENGTH('a) (uint w)\<close>]
   by (transfer fixing: n) auto
 
 lemma word_power_increasing:
   assumes x: "2 ^ x < (2 ^ y::'a::len word)" "x < LENGTH('a::len)" "y < LENGTH('a::len)"
   shows "x < y" using x
   using assms by transfer simp
 
 lemma mask_twice:
   "(x AND mask n) AND mask m = x AND mask (min m n)"
   for x :: \<open>'a::len word\<close>
   by (simp flip: take_bit_eq_mask)
 
 lemma plus_one_helper[elim!]:
   "x < n + (1 :: 'a :: len word) \<Longrightarrow> x \<le> n"
   apply (simp add: word_less_nat_alt word_le_nat_alt field_simps)
   apply (case_tac "1 + n = 0")
    apply simp_all
   apply (subst(asm) unatSuc, assumption)
   apply arith
   done
 
 lemma plus_one_helper2:
   "\<lbrakk> x \<le> n; n + 1 \<noteq> 0 \<rbrakk> \<Longrightarrow> x < n + (1 :: 'a :: len word)"
   by (simp add: word_less_nat_alt word_le_nat_alt field_simps
                 unatSuc)
 
 lemma less_x_plus_1:
   fixes x :: "'a :: len word" shows
   "x \<noteq> - 1 \<Longrightarrow> (y < (x + 1)) = (y < x \<or> y = x)"
   apply (rule iffI)
    apply (rule disjCI)
    apply (drule plus_one_helper)
    apply simp
   apply (subgoal_tac "x < x + 1")
    apply (erule disjE, simp_all)
   apply (rule plus_one_helper2 [OF order_refl])
   apply (rule notI, drule max_word_wrap)
   apply simp
   done
 
 lemma word_Suc_leq:
   fixes k::"'a::len word" shows "k \<noteq> - 1 \<Longrightarrow> x < k + 1 \<longleftrightarrow> x \<le> k"
   using less_x_plus_1 word_le_less_eq by auto
 
 lemma word_Suc_le:
    fixes k::"'a::len word" shows "x \<noteq> - 1 \<Longrightarrow> x + 1 \<le> k \<longleftrightarrow> x < k"
   by (meson not_less word_Suc_leq)
 
 lemma word_lessThan_Suc_atMost:
   \<open>{..< k + 1} = {..k}\<close> if \<open>k \<noteq> - 1\<close> for k :: \<open>'a::len word\<close>
   using that by (simp add: lessThan_def atMost_def word_Suc_leq)
 
 lemma word_atLeastLessThan_Suc_atLeastAtMost:
   \<open>{l ..< u + 1} = {l..u}\<close> if \<open>u \<noteq> - 1\<close> for l :: \<open>'a::len word\<close>
   using that by (simp add: atLeastAtMost_def atLeastLessThan_def word_lessThan_Suc_atMost)
 
 lemma word_atLeastAtMost_Suc_greaterThanAtMost:
   \<open>{m<..u} = {m + 1..u}\<close> if \<open>m \<noteq> - 1\<close> for m :: \<open>'a::len word\<close>
   using that by (simp add: greaterThanAtMost_def greaterThan_def atLeastAtMost_def atLeast_def word_Suc_le)
 
 lemma word_atLeastLessThan_Suc_atLeastAtMost_union:
   fixes l::"'a::len word"
   assumes "m \<noteq> - 1" and "l \<le> m" and "m \<le> u"
   shows "{l..m} \<union> {m+1..u} = {l..u}"
   proof -
   from ivl_disj_un_two(8)[OF assms(2) assms(3)] have "{l..u} = {l..m} \<union> {m<..u}" by blast
   with assms show ?thesis by(simp add: word_atLeastAtMost_Suc_greaterThanAtMost)
   qed
 
 lemma max_word_less_eq_iff [simp]:
   \<open>- 1 \<le> w \<longleftrightarrow> w = - 1\<close> for w :: \<open>'a::len word\<close>
   by (fact word_order.extremum_unique)
 
 lemma word_or_zero:
   "(a OR b = 0) = (a = 0 \<and> b = 0)"
   for a b :: \<open>'a::len word\<close>
   by (fact or_eq_0_iff)
 
 lemma word_2p_mult_inc:
   assumes x: "2 * 2 ^ n < (2::'a::len word) * 2 ^ m"
   assumes suc_n: "Suc n < LENGTH('a::len)"
   shows "2^n < (2::'a::len word)^m"
   by (smt suc_n le_less_trans lessI nat_less_le nat_mult_less_cancel_disj p2_gt_0
           power_Suc power_Suc unat_power_lower word_less_nat_alt x)
 
 lemma power_overflow:
   "n \<ge> LENGTH('a) \<Longrightarrow> 2 ^ n = (0 :: 'a::len word)"
   by simp
 
 lemmas extra_sle_sless_unfolds [simp] =
     word_sle_eq[where a=0 and b=1]
     word_sle_eq[where a=0 and b="numeral n"]
     word_sle_eq[where a=1 and b=0]
     word_sle_eq[where a=1 and b="numeral n"]
     word_sle_eq[where a="numeral n" and b=0]
     word_sle_eq[where a="numeral n" and b=1]
     word_sless_alt[where a=0 and b=1]
     word_sless_alt[where a=0 and b="numeral n"]
     word_sless_alt[where a=1 and b=0]
     word_sless_alt[where a=1 and b="numeral n"]
     word_sless_alt[where a="numeral n" and b=0]
     word_sless_alt[where a="numeral n" and b=1]
   for n
 
 lemma word_sint_1:
   "sint (1::'a::len word) = (if LENGTH('a) = 1 then -1 else 1)"
   by (fact signed_1)
 
 lemma ucast_of_nat:
   "is_down (ucast :: 'a :: len word \<Rightarrow> 'b :: len word)
     \<Longrightarrow> ucast (of_nat n :: 'a word) = (of_nat n :: 'b word)"
   by transfer simp
 
 lemma scast_1':
   "(scast (1::'a::len word) :: 'b::len word) =
    (word_of_int (signed_take_bit (LENGTH('a::len) - Suc 0) (1::int)))"
   by transfer simp
 
 lemma scast_1:
   "(scast (1::'a::len word) :: 'b::len word) = (if LENGTH('a) = 1 then -1 else 1)"
   by (fact signed_1)
 
 lemma unat_minus_one_word:
   "unat (-1 :: 'a :: len word) = 2 ^ LENGTH('a) - 1"
   apply (simp only: flip: mask_eq_exp_minus_1)
   apply transfer
   apply (simp add: take_bit_minus_one_eq_mask nat_mask_eq)
   done
 
 lemmas word_diff_ls'' = word_diff_ls [where xa=x and x=x for x]
 lemmas word_diff_ls' = word_diff_ls'' [simplified]
 
 lemmas word_l_diffs' = word_l_diffs [where xa=x and x=x for x]
 lemmas word_l_diffs = word_l_diffs' [simplified]
 
 lemma two_power_increasing:
   "\<lbrakk> n \<le> m; m < LENGTH('a) \<rbrakk> \<Longrightarrow> (2 :: 'a :: len word) ^ n \<le> 2 ^ m"
   by (simp add: word_le_nat_alt)
 
 lemma word_leq_le_minus_one:
   "\<lbrakk> x \<le> y; x \<noteq> 0 \<rbrakk> \<Longrightarrow> x - 1 < (y :: 'a :: len word)"
   apply (simp add: word_less_nat_alt word_le_nat_alt)
   apply (subst unat_minus_one)
    apply assumption
   apply (cases "unat x")
    apply (simp add: unat_eq_zero)
   apply arith
   done
 
 lemma neg_mask_combine:
   "NOT(mask a) AND NOT(mask b) = NOT(mask (max a b) :: 'a::len word)"
   by (rule bit_word_eqI) (auto simp add: bit_simps)
 
 lemma neg_mask_twice:
   "x AND NOT(mask n) AND NOT(mask m) = x AND NOT(mask (max n m))"
   for x :: \<open>'a::len word\<close>
   by (rule bit_word_eqI) (auto simp add: bit_simps)
 
 lemma multiple_mask_trivia:
   "n \<ge> m \<Longrightarrow> (x AND NOT(mask n)) + (x AND mask n AND NOT(mask m)) = x AND NOT(mask m)"
   for x :: \<open>'a::len word\<close>
   apply (rule trans[rotated], rule_tac w="mask n" in word_plus_and_or_coroll2)
   apply (simp add: word_bw_assocs word_bw_comms word_bw_lcs neg_mask_twice
                    max_absorb2)
   done
 
 lemma word_of_nat_less:
   "\<lbrakk> n < unat x \<rbrakk> \<Longrightarrow> of_nat n < x"
   apply (simp add: word_less_nat_alt)
   apply (erule order_le_less_trans[rotated])
   apply (simp add: take_bit_eq_mod)
   done
 
 lemma unat_mask:
   "unat (mask n :: 'a :: len word) = 2 ^ (min n (LENGTH('a))) - 1"
   apply (subst min.commute)
   apply (simp add: mask_eq_decr_exp not_less min_def  split: if_split_asm)
   apply (intro conjI impI)
    apply (simp add: unat_sub_if_size)
    apply (simp add: power_overflow word_size)
   apply (simp add: unat_sub_if_size)
   done
 
 lemma mask_over_length:
   "LENGTH('a) \<le> n \<Longrightarrow> mask n = (-1::'a::len word)"
   by (simp add: mask_eq_decr_exp)
 
 lemma Suc_2p_unat_mask:
   "n < LENGTH('a) \<Longrightarrow> Suc (2 ^ n * k + unat (mask n :: 'a::len word)) = 2 ^ n * (k+1)"
   by (simp add: unat_mask)
 
 lemma sint_of_nat_ge_zero:
   "x < 2 ^ (LENGTH('a) - 1) \<Longrightarrow> sint (of_nat x :: 'a :: len word) \<ge> 0"
   by (simp add: bit_iff_odd)
 
 lemma int_eq_sint:
   "x < 2 ^ (LENGTH('a) - 1) \<Longrightarrow> sint (of_nat x :: 'a :: len word) = int x"
   apply transfer
   apply (rule signed_take_bit_int_eq_self)
    apply simp_all
   apply (metis negative_zle numeral_power_eq_of_nat_cancel_iff)
   done
 
 lemma sint_of_nat_le:
   "\<lbrakk> b < 2 ^ (LENGTH('a) - 1); a \<le> b \<rbrakk>
    \<Longrightarrow> sint (of_nat a :: 'a :: len word) \<le> sint (of_nat b :: 'a :: len word)"
   apply (cases \<open>LENGTH('a)\<close>)
   apply simp_all
   apply transfer
   apply (subst signed_take_bit_eq_if_positive)
    apply (simp add: bit_simps)
   apply (metis bit_take_bit_iff nat_less_le order_less_le_trans take_bit_nat_eq_self_iff)
   apply (subst signed_take_bit_eq_if_positive)
     apply (simp add: bit_simps)
   apply (metis bit_take_bit_iff nat_less_le take_bit_nat_eq_self_iff)
     apply (simp flip: of_nat_take_bit add: take_bit_nat_eq_self)
   done
 
 lemma word_le_not_less:
   "((b::'a::len word) \<le> a) = (\<not>(a < b))"
   by fastforce
 
 lemma less_is_non_zero_p1:
   fixes a :: "'a :: len word"
   shows "a < k \<Longrightarrow> a + 1 \<noteq> 0"
   apply (erule contrapos_pn)
   apply (drule max_word_wrap)
   apply (simp add: not_less)
   done
 
 lemma unat_add_lem':
   "(unat x + unat y < 2 ^ LENGTH('a)) \<Longrightarrow>
     (unat (x + y :: 'a :: len word) = unat x + unat y)"
   by (subst unat_add_lem[symmetric], assumption)
 
 lemma word_less_two_pow_divI:
   "\<lbrakk> (x :: 'a::len word) < 2 ^ (n - m); m \<le> n; n < LENGTH('a) \<rbrakk> \<Longrightarrow> x < 2 ^ n div 2 ^ m"
   apply (simp add: word_less_nat_alt)
   apply (subst unat_word_ariths)
   apply (subst mod_less)
    apply (rule order_le_less_trans [OF div_le_dividend])
    apply (rule unat_lt2p)
   apply (simp add: power_sub)
   done
 
 lemma word_less_two_pow_divD:
   "\<lbrakk> (x :: 'a::len word) < 2 ^ n div 2 ^ m \<rbrakk>
      \<Longrightarrow> n \<ge> m \<and> (x < 2 ^ (n - m))"
   apply (cases "n < LENGTH('a)")
    apply (cases "m < LENGTH('a)")
     apply (simp add: word_less_nat_alt)
     apply (subst(asm) unat_word_ariths)
     apply (subst(asm) mod_less)
      apply (rule order_le_less_trans [OF div_le_dividend])
      apply (rule unat_lt2p)
     apply (clarsimp dest!: less_two_pow_divD)
    apply (simp add: power_overflow)
    apply (simp add: word_div_def)
   apply (simp add: power_overflow word_div_def)
   done
 
 lemma of_nat_less_two_pow_div_set:
   "\<lbrakk> n < LENGTH('a) \<rbrakk> \<Longrightarrow>
    {x. x < (2 ^ n div 2 ^ m :: 'a::len word)}
       = of_nat ` {k. k < 2 ^ n div 2 ^ m}"
   apply (simp add: image_def)
   apply (safe dest!: word_less_two_pow_divD less_two_pow_divD
              intro!: word_less_two_pow_divI)
    apply (rule_tac x="unat x" in exI)
    apply (simp add: power_sub[symmetric])
    apply (subst unat_power_lower[symmetric, where 'a='a])
     apply simp
    apply (erule unat_mono)
   apply (subst word_unat_power)
   apply (rule of_nat_mono_maybe)
    apply (rule power_strict_increasing)
     apply simp
    apply simp
   apply assumption
   done
 
 lemma ucast_less:
   "LENGTH('b) < LENGTH('a) \<Longrightarrow>
    (ucast (x :: 'b :: len word) :: ('a :: len word)) < 2 ^ LENGTH('b)"
   by transfer simp
 
 lemma ucast_range_less:
   "LENGTH('a :: len) < LENGTH('b :: len) \<Longrightarrow>
    range (ucast :: 'a word \<Rightarrow> 'b word) = {x. x < 2 ^ len_of TYPE ('a)}"
   apply safe
    apply (erule ucast_less)
   apply (simp add: image_def)
   apply (rule_tac x="ucast x" in exI)
   apply (rule bit_word_eqI)
   apply (auto simp add: bit_simps)
   apply (metis bit_take_bit_iff less_mask_eq not_less take_bit_eq_mask)
   done
 
 lemma word_power_less_diff:
   "\<lbrakk>2 ^ n * q < (2::'a::len word) ^ m; q < 2 ^ (LENGTH('a) - n)\<rbrakk> \<Longrightarrow> q < 2 ^ (m - n)"
   apply (case_tac "m \<ge> LENGTH('a)")
    apply (simp add: power_overflow)
   apply (case_tac "n \<ge> LENGTH('a)")
    apply (simp add: power_overflow)
   apply (cases "n = 0")
    apply simp
   apply (subst word_less_nat_alt)
   apply (subst unat_power_lower)
    apply simp
   apply (rule nat_power_less_diff)
   apply (simp add: word_less_nat_alt)
   apply (subst (asm) iffD1 [OF unat_mult_lem])
    apply (simp add:nat_less_power_trans)
   apply simp
   done
 
 lemma word_less_sub_1:
   "x < (y :: 'a :: len word) \<Longrightarrow> x \<le> y - 1"
   by (fact word_le_minus_one_leq)
 
 lemma word_sub_mono2:
   "\<lbrakk> a + b \<le> c + d; c \<le> a; b \<le> a + b; d \<le> c + d \<rbrakk>
     \<Longrightarrow> b \<le> (d :: 'a :: len word)"
   apply (drule(1) word_sub_mono)
     apply simp
    apply simp
   apply simp
   done
 
 lemma word_not_le:
   "(\<not> x \<le> (y :: 'a :: len word)) = (y < x)"
   by fastforce
 
 lemma word_subset_less:
   "\<lbrakk> {x .. x + r - 1} \<subseteq> {y .. y + s - 1};
      x \<le> x + r - 1; y \<le> y + (s :: 'a :: len word) - 1;
      s \<noteq> 0 \<rbrakk>
      \<Longrightarrow> r \<le> s"
   apply (frule subsetD[where c=x])
    apply simp
   apply (drule subsetD[where c="x + r - 1"])
    apply simp
   apply (clarsimp simp: add_diff_eq[symmetric])
   apply (drule(1) word_sub_mono2)
     apply (simp_all add: olen_add_eqv[symmetric])
   apply (erule word_le_minus_cancel)
   apply (rule ccontr)
   apply (simp add: word_not_le)
   done
 
 lemma uint_power_lower:
   "n < LENGTH('a) \<Longrightarrow> uint (2 ^ n :: 'a :: len word) = (2 ^ n :: int)"
   by (rule uint_2p_alt)
 
 lemma power_le_mono:
   "\<lbrakk>2 ^ n \<le> (2::'a::len word) ^ m; n < LENGTH('a); m < LENGTH('a)\<rbrakk>
    \<Longrightarrow> n \<le> m"
   apply (clarsimp simp add: le_less)
   apply safe
   apply (simp add: word_less_nat_alt)
   apply (simp only: uint_arith_simps(3))
   apply (drule uint_power_lower)+
   apply simp
   done
 
 lemma two_power_eq:
   "\<lbrakk>n < LENGTH('a); m < LENGTH('a)\<rbrakk>
    \<Longrightarrow> ((2::'a::len word) ^ n = 2 ^ m) = (n = m)"
   apply safe
   apply (rule order_antisym)
    apply (simp add: power_le_mono[where 'a='a])+
   done
 
 lemma unat_less_helper:
   "x < of_nat n \<Longrightarrow> unat x < n"
   apply (simp add: word_less_nat_alt)
   apply (erule order_less_le_trans)
   apply (simp add: take_bit_eq_mod)
   done
 
 lemma nat_uint_less_helper:
   "nat (uint y) = z \<Longrightarrow> x < y \<Longrightarrow> nat (uint x) < z"
   apply (erule subst)
   apply (subst unat_eq_nat_uint [symmetric])
   apply (subst unat_eq_nat_uint [symmetric])
   by (simp add: unat_mono)
 
 lemma of_nat_0:
   "\<lbrakk>of_nat n = (0::'a::len word); n < 2 ^ LENGTH('a)\<rbrakk> \<Longrightarrow> n = 0"
   by transfer (simp add: take_bit_eq_mod)
 
 lemma of_nat_inj:
   "\<lbrakk>x < 2 ^ LENGTH('a); y < 2 ^ LENGTH('a)\<rbrakk> \<Longrightarrow>
    (of_nat x = (of_nat y :: 'a :: len word)) = (x = y)"
   by (metis unat_of_nat_len)
 
 lemma div_to_mult_word_lt:
   "\<lbrakk> (x :: 'a :: len word) \<le> y div z \<rbrakk> \<Longrightarrow> x * z \<le> y"
   apply (cases "z = 0")
    apply simp
   apply (simp add: word_neq_0_conv)
   apply (rule order_trans)
    apply (erule(1) word_mult_le_mono1)
    apply (simp add: unat_div)
    apply (rule order_le_less_trans [OF div_mult_le])
    apply simp
   apply (rule word_div_mult_le)
   done
 
 lemma ucast_ucast_mask:
   "(ucast :: 'a :: len word \<Rightarrow> 'b :: len word) (ucast x) = x AND mask (len_of TYPE ('a))"
   apply (simp flip: take_bit_eq_mask)
   apply transfer
   apply (simp add: ac_simps)
   done
 
 lemma ucast_ucast_len:
   "\<lbrakk> x < 2 ^ LENGTH('b) \<rbrakk> \<Longrightarrow> ucast (ucast x::'b::len word) = (x::'a::len word)"
   apply (subst ucast_ucast_mask)
   apply (erule less_mask_eq)
   done
 
 lemma ucast_ucast_id:
   "LENGTH('a) < LENGTH('b) \<Longrightarrow> ucast (ucast (x::'a::len word)::'b::len word) = x"
   by (auto intro: ucast_up_ucast_id simp: is_up_def source_size_def target_size_def word_size)
 
 lemma unat_ucast:
   "unat (ucast x :: ('a :: len) word) = unat x mod 2 ^ (LENGTH('a))"
 proof -
   have \<open>2 ^ LENGTH('a) = nat (2 ^ LENGTH('a))\<close>
     by simp
   moreover have \<open>unat (ucast x :: 'a word) = unat x mod nat (2 ^ LENGTH('a))\<close>
     by transfer (simp flip: nat_mod_distrib take_bit_eq_mod)
   ultimately show ?thesis
     by (simp only:)
 qed
 
 lemma ucast_less_ucast:
   "LENGTH('a) \<le> LENGTH('b) \<Longrightarrow>
    (ucast x < ((ucast (y :: 'a::len word)) :: 'b::len word)) = (x < y)"
   apply (simp add: word_less_nat_alt unat_ucast)
   apply (subst mod_less)
    apply(rule less_le_trans[OF unat_lt2p], simp)
   apply (subst mod_less)
    apply(rule less_le_trans[OF unat_lt2p], simp)
   apply simp
   done
 
 \<comment> \<open>This weaker version was previously called @{text ucast_less_ucast}. We retain it to
     support existing proofs.\<close>
 lemmas ucast_less_ucast_weak = ucast_less_ucast[OF order.strict_implies_order]
 
 lemma unat_Suc2:
   fixes n :: "'a :: len word"
   shows
   "n \<noteq> -1 \<Longrightarrow> unat (n + 1) = Suc (unat n)"
   apply (subst add.commute, rule unatSuc)
   apply (subst eq_diff_eq[symmetric], simp add: minus_equation_iff)
   done
 
 lemma word_div_1:
   "(n :: 'a :: len word) div 1 = n"
   by (fact bits_div_by_1)
 
 lemma word_minus_one_le:
   "-1 \<le> (x :: 'a :: len word) = (x = -1)"
   by (fact word_order.extremum_unique)
 
 lemma up_scast_inj:
       "\<lbrakk> scast x = (scast y :: 'b :: len word); size x \<le> LENGTH('b) \<rbrakk>
          \<Longrightarrow> x = y"
   apply transfer
   apply (cases \<open>LENGTH('a)\<close>)
   apply simp_all
   apply (metis order_refl take_bit_signed_take_bit take_bit_tightened)
   done
 
 lemma up_scast_inj_eq:
   "LENGTH('a) \<le> len_of TYPE ('b) \<Longrightarrow>
   (scast x = (scast y::'b::len word)) = (x = (y::'a::len word))"
   by (fastforce dest: up_scast_inj simp: word_size)
 
 lemma word_le_add:
   fixes x :: "'a :: len word"
   shows "x \<le> y \<Longrightarrow> \<exists>n. y = x + of_nat n"
   by (rule exI [where x = "unat (y - x)"]) simp
 
 lemma word_plus_mcs_4':
   fixes x :: "'a :: len word"
   shows "\<lbrakk>x + v \<le> x + w; x \<le> x + v\<rbrakk> \<Longrightarrow> v \<le> w"
   apply (rule word_plus_mcs_4)
    apply (simp add: add.commute)
   apply (simp add: add.commute)
   done
 
 lemma unat_eq_1:
   \<open>unat x = Suc 0 \<longleftrightarrow> x = 1\<close>
   by (auto intro!: unsigned_word_eqI [where ?'a = nat])
 
 lemma word_unat_Rep_inject1:
   \<open>unat x = unat 1 \<longleftrightarrow> x = 1\<close>
   by (simp add: unat_eq_1)
 
 lemma and_not_mask_twice:
   "(w AND NOT (mask n)) AND NOT (mask m) = w AND NOT (mask (max m n))"
   for w :: \<open>'a::len word\<close>
   by (rule bit_word_eqI) (auto simp add: bit_simps)
 
 lemma word_less_cases:
   "x < y \<Longrightarrow> x = y - 1 \<or> x < y - (1 ::'a::len word)"
   apply (drule word_less_sub_1)
   apply (drule order_le_imp_less_or_eq)
   apply auto
   done
 
 lemma mask_and_mask:
   "mask a AND mask b = (mask (min a b) :: 'a::len word)"
   by (simp flip: take_bit_eq_mask ac_simps)
 
 lemma mask_eq_0_eq_x:
   "(x AND w = 0) = (x AND NOT w = x)"
   for x w :: \<open>'a::len word\<close>
   using word_plus_and_or_coroll2[where x=x and w=w]
   by auto
 
 lemma mask_eq_x_eq_0:
   "(x AND w = x) = (x AND NOT w = 0)"
   for x w :: \<open>'a::len word\<close>
   using word_plus_and_or_coroll2[where x=x and w=w]
   by auto
 
 lemma compl_of_1: "NOT 1 = (-2 :: 'a :: len word)"
   by (fact not_one)
 
 lemma split_word_eq_on_mask:
   "(x = y) = (x AND m = y AND m \<and> x AND NOT m = y AND NOT m)"
   for x y m :: \<open>'a::len word\<close>
   apply transfer
   apply (simp add: bit_eq_iff)
   apply (auto simp add: bit_simps ac_simps)
   done
 
 lemma word_FF_is_mask:
   "0xFF = (mask 8 :: 'a::len word)"
   by (simp add: mask_eq_decr_exp)
 
 lemma word_1FF_is_mask:
   "0x1FF = (mask 9 :: 'a::len word)"
   by (simp add: mask_eq_decr_exp)
 
 lemma ucast_of_nat_small:
   "x < 2 ^ LENGTH('a) \<Longrightarrow> ucast (of_nat x :: 'a :: len word) = (of_nat x :: 'b :: len word)"
   apply transfer
   apply (auto simp add: take_bit_of_nat min_def not_le)
   apply (metis linorder_not_less min_def take_bit_nat_eq_self take_bit_take_bit)
   done
 
 lemma word_le_make_less:
   fixes x :: "'a :: len word"
   shows "y \<noteq> -1 \<Longrightarrow> (x \<le> y) = (x < (y + 1))"
   apply safe
   apply (erule plus_one_helper2)
   apply (simp add: eq_diff_eq[symmetric])
   done
 
 lemmas finite_word = finite [where 'a="'a::len word"]
 
 lemma word_to_1_set:
   "{0 ..< (1 :: 'a :: len word)} = {0}"
   by fastforce
 
 lemma word_leq_minus_one_le:
   fixes x :: "'a::len word"
   shows "\<lbrakk>y \<noteq> 0; x \<le> y - 1 \<rbrakk> \<Longrightarrow> x < y"
   using le_m1_iff_lt word_neq_0_conv by blast
 
 lemma word_count_from_top:
   "n \<noteq> 0 \<Longrightarrow> {0 ..< n :: 'a :: len word} = {0 ..< n - 1} \<union> {n - 1}"
   apply (rule set_eqI, rule iffI)
    apply simp
    apply (drule word_le_minus_one_leq)
    apply (rule disjCI)
    apply simp
   apply simp
   apply (erule word_leq_minus_one_le)
   apply fastforce
   done
 
 lemma word_minus_one_le_leq:
   "\<lbrakk> x - 1 < y \<rbrakk> \<Longrightarrow> x \<le> (y :: 'a :: len word)"
   apply (cases "x = 0")
    apply simp
   apply (simp add: word_less_nat_alt word_le_nat_alt)
   apply (subst(asm) unat_minus_one)
    apply (simp add: word_less_nat_alt)
   apply (cases "unat x")
    apply (simp add: unat_eq_zero)
   apply arith
   done
 
 lemma word_div_less:
   "m < n \<Longrightarrow> m div n = 0" for m :: "'a :: len word"
   by (simp add: unat_mono word_arith_nat_defs(6))
 
 lemma word_must_wrap:
   "\<lbrakk> x \<le> n - 1; n \<le> x \<rbrakk> \<Longrightarrow> n = (0 :: 'a :: len word)"
   using dual_order.trans sub_wrap word_less_1 by blast
 
 lemma range_subset_card:
   "\<lbrakk> {a :: 'a :: len word .. b} \<subseteq> {c .. d}; b \<ge> a \<rbrakk> \<Longrightarrow> d \<ge> c \<and> d - c \<ge> b - a"
   using word_sub_le word_sub_mono by fastforce
 
 lemma less_1_simp:
   "n - 1 < m = (n \<le> (m :: 'a :: len word) \<and> n \<noteq> 0)"
   by unat_arith
 
 lemma word_power_mod_div:
   fixes x :: "'a::len word"
   shows "\<lbrakk> n < LENGTH('a); m < LENGTH('a)\<rbrakk>
   \<Longrightarrow> x mod 2 ^ n div 2 ^ m = x div 2 ^ m mod 2 ^ (n - m)"
   apply (simp add: word_arith_nat_div unat_mod power_mod_div)
   apply (subst unat_arith_simps(3))
   apply (subst unat_mod)
   apply (subst unat_of_nat)+
   apply (simp add: mod_mod_power min.commute)
   done
 
 lemma word_range_minus_1':
   fixes a :: "'a :: len word"
   shows "a \<noteq> 0 \<Longrightarrow> {a - 1<..b} = {a..b}"
   by (simp add: greaterThanAtMost_def atLeastAtMost_def greaterThan_def atLeast_def less_1_simp)
 
 lemma word_range_minus_1:
   fixes a :: "'a :: len word"
   shows "b \<noteq> 0 \<Longrightarrow> {a..b - 1} = {a..<b}"
   apply (simp add: atLeastLessThan_def atLeastAtMost_def atMost_def lessThan_def)
   apply (rule arg_cong [where f = "\<lambda>x. {a..} \<inter> x"])
   apply rule
    apply clarsimp
    apply (erule contrapos_pp)
    apply (simp add: linorder_not_less linorder_not_le word_must_wrap)
   apply (clarsimp)
   apply (drule word_le_minus_one_leq)
   apply (auto simp: word_less_sub_1)
   done
 
 lemma ucast_nat_def:
   "of_nat (unat x) = (ucast :: 'a :: len word \<Rightarrow> 'b :: len word) x"
   by transfer simp
 
 lemma overflow_plus_one_self:
   "(1 + p \<le> p) = (p = (-1 :: 'a :: len word))"
   apply rule
   apply (rule ccontr)
    apply (drule plus_one_helper2)
    apply (rule notI)
    apply (drule arg_cong[where f="\<lambda>x. x - 1"])
    apply simp
    apply (simp add: field_simps)
   apply simp
   done
 
 lemma plus_1_less:
   "(x + 1 \<le> (x :: 'a :: len word)) = (x = -1)"
   apply (rule iffI)
    apply (rule ccontr)
    apply (cut_tac plus_one_helper2[where x=x, OF order_refl])
     apply simp
    apply clarsimp
    apply (drule arg_cong[where f="\<lambda>x. x - 1"])
    apply simp
   apply simp
   done
 
 lemma pos_mult_pos_ge:
   "[|x > (0::int); n>=0 |] ==> n * x >= n*1"
   apply (simp only: mult_left_mono)
   done
 
 lemma word_plus_strict_mono_right:
   fixes x :: "'a :: len word"
   shows "\<lbrakk>y < z; x \<le> x + z\<rbrakk> \<Longrightarrow> x + y < x + z"
   by unat_arith
 
 lemma word_div_mult:
   "0 < c \<Longrightarrow> a < b * c \<Longrightarrow> a div c < b" for a b c :: "'a::len word"
   by (rule classical)
      (use div_to_mult_word_lt [of b a c] in
       \<open>auto simp add: word_less_nat_alt word_le_nat_alt unat_div\<close>)
 
 lemma word_less_power_trans_ofnat:
   "\<lbrakk>n < 2 ^ (m - k); k \<le> m; m < LENGTH('a)\<rbrakk>
    \<Longrightarrow> of_nat n * 2 ^ k < (2::'a::len word) ^ m"
   apply (subst mult.commute)
   apply (rule word_less_power_trans)
     apply (simp_all add: word_less_nat_alt less_le_trans take_bit_eq_mod)
   done
 
 lemma word_1_le_power:
   "n < LENGTH('a) \<Longrightarrow> (1 :: 'a :: len word) \<le> 2 ^ n"
   by (rule inc_le[where i=0, simplified], erule iffD2[OF p2_gt_0])
 
 lemma unat_1_0:
   "1 \<le> (x::'a::len word) = (0 < unat x)"
   by (auto simp add: word_le_nat_alt)
 
 lemma x_less_2_0_1':
   fixes x :: "'a::len word"
   shows "\<lbrakk>LENGTH('a) \<noteq> 1; x < 2\<rbrakk> \<Longrightarrow> x = 0 \<or> x = 1"
   apply (cases \<open>2 \<le> LENGTH('a)\<close>)
   apply simp_all
   apply transfer
   apply auto
   apply (metis add.commute add.right_neutral even_two_times_div_two mod_div_trivial mod_pos_pos_trivial mult.commute mult_zero_left not_less not_take_bit_negative odd_two_times_div_two_succ)
   done
 
 lemmas word_add_le_iff2 = word_add_le_iff [folded no_olen_add_nat]
 
 lemma of_nat_power:
   shows "\<lbrakk> p < 2 ^ x; x < len_of TYPE ('a) \<rbrakk> \<Longrightarrow> of_nat p < (2 :: 'a :: len word) ^ x"
   apply (rule order_less_le_trans)
    apply (rule of_nat_mono_maybe)
     apply (erule power_strict_increasing)
     apply simp
    apply assumption
   apply (simp add: word_unat_power del: of_nat_power)
   done
 
 lemma of_nat_n_less_equal_power_2:
   "n < LENGTH('a::len) \<Longrightarrow> ((of_nat n)::'a word) < 2 ^ n"
   apply (induct n)
    apply clarsimp
   apply clarsimp
   apply (metis of_nat_power n_less_equal_power_2 of_nat_Suc power_Suc)
   done
 
 lemma eq_mask_less:
   fixes w :: "'a::len word"
   assumes eqm: "w = w AND mask n"
   and      sz: "n < len_of TYPE ('a)"
   shows "w < (2::'a word) ^ n"
   by (subst eqm, rule and_mask_less' [OF sz])
 
 lemma of_nat_mono_maybe':
   fixes Y :: "nat"
   assumes xlt: "x < 2 ^ len_of TYPE ('a)"
   assumes ylt: "y < 2 ^ len_of TYPE ('a)"
   shows   "(y < x) = (of_nat y < (of_nat x :: 'a :: len word))"
   apply (subst word_less_nat_alt)
   apply (subst unat_of_nat)+
   apply (subst mod_less)
    apply (rule ylt)
   apply (subst mod_less)
    apply (rule xlt)
   apply simp
   done
 
 lemma of_nat_mono_maybe_le:
   "\<lbrakk>x < 2 ^ LENGTH('a); y < 2 ^ LENGTH('a)\<rbrakk> \<Longrightarrow>
   (y \<le> x) = ((of_nat y :: 'a :: len word) \<le> of_nat x)"
   apply (clarsimp simp: le_less)
   apply (rule disj_cong)
    apply (rule of_nat_mono_maybe', assumption+)
   apply auto
   using of_nat_inj apply blast
   done
 
 lemma mask_AND_NOT_mask:
   "(w AND NOT (mask n)) AND mask n = 0"
   for w :: \<open>'a::len word\<close>
   by (rule bit_word_eqI) (simp add: bit_simps)
 
 lemma AND_NOT_mask_plus_AND_mask_eq:
   "(w AND NOT (mask n)) + (w AND mask n) = w"
   for w :: \<open>'a::len word\<close>
   apply (subst disjunctive_add)
   apply (auto simp add: bit_simps)
   apply (rule bit_word_eqI)
   apply (auto simp add: bit_simps)
   done
 
 lemma mask_eqI:
   fixes x :: "'a :: len word"
   assumes m1: "x AND mask n = y AND mask n"
   and     m2: "x AND NOT (mask n) = y AND NOT (mask n)"
   shows "x = y"
 proof -
   have *: \<open>x = x AND mask n OR x AND NOT (mask n)\<close> for x :: \<open>'a word\<close>
     by (rule bit_word_eqI) (auto simp add: bit_simps)
   from assms * [of x] * [of y] show ?thesis
     by simp
 qed
 
 lemma neq_0_no_wrap:
   fixes x :: "'a :: len word"
   shows "\<lbrakk> x \<le> x + y; x \<noteq> 0 \<rbrakk> \<Longrightarrow> x + y \<noteq> 0"
   by clarsimp
 
 lemma unatSuc2:
   fixes n :: "'a :: len word"
   shows "n + 1 \<noteq> 0 \<Longrightarrow> unat (n + 1) = Suc (unat n)"
   by (simp add: add.commute unatSuc)
 
 lemma word_of_nat_le:
   "n \<le> unat x \<Longrightarrow> of_nat n \<le> x"
   apply (simp add: word_le_nat_alt unat_of_nat)
   apply (erule order_trans[rotated])
   apply (simp add: take_bit_eq_mod)
   done
 
 lemma word_unat_less_le:
   "a \<le> of_nat b \<Longrightarrow> unat a \<le> b"
   by (metis eq_iff le_cases le_unat_uoi word_of_nat_le)
 
 lemma mask_Suc_0 : "mask (Suc 0) = (1 :: 'a::len word)"
   by (simp add: mask_eq_decr_exp)
 
 lemma bool_mask':
   fixes x :: "'a :: len word"
   shows "2 < LENGTH('a) \<Longrightarrow> (0 < x AND 1) = (x AND 1 = 1)"
   by (simp add: and_one_eq mod_2_eq_odd)
 
 lemma ucast_ucast_add:
   fixes x :: "'a :: len word"
   fixes y :: "'b :: len word"
   shows
   "LENGTH('b) \<ge> LENGTH('a) \<Longrightarrow>
     ucast (ucast x + y) = x + ucast y"
   apply transfer
   apply simp
   apply (subst (2) take_bit_add [symmetric])
   apply (subst take_bit_add [symmetric])
   apply simp
   done
 
 lemma lt1_neq0:
   fixes x :: "'a :: len word"
   shows "(1 \<le> x) = (x \<noteq> 0)" by unat_arith
 
 lemma word_plus_one_nonzero:
   fixes x :: "'a :: len word"
   shows "\<lbrakk>x \<le> x + y; y \<noteq> 0\<rbrakk> \<Longrightarrow> x + 1 \<noteq> 0"
   apply (subst lt1_neq0 [symmetric])
   apply (subst olen_add_eqv [symmetric])
   apply (erule word_random)
   apply (simp add: lt1_neq0)
   done
 
 lemma word_sub_plus_one_nonzero:
   fixes n :: "'a :: len word"
   shows "\<lbrakk>n' \<le> n; n' \<noteq> 0\<rbrakk> \<Longrightarrow> (n - n') + 1 \<noteq> 0"
   apply (subst lt1_neq0 [symmetric])
   apply (subst olen_add_eqv [symmetric])
   apply (rule word_random [where x' = n'])
    apply simp
    apply (erule word_sub_le)
   apply (simp add: lt1_neq0)
   done
 
 lemma word_le_minus_mono_right:
   fixes x :: "'a :: len word"
   shows "\<lbrakk> z \<le> y; y \<le> x; z \<le> x \<rbrakk> \<Longrightarrow> x - y \<le> x - z"
   apply (rule word_sub_mono)
      apply simp
     apply assumption
    apply (erule word_sub_le)
   apply (erule word_sub_le)
   done
 
 lemma word_0_sle_from_less:
   \<open>0 \<le>s x\<close> if \<open>x < 2 ^ (LENGTH('a) - 1)\<close> for x :: \<open>'a::len word\<close>
   using that
   apply transfer
   apply (cases \<open>LENGTH('a)\<close>)
    apply simp_all
   apply (metis bit_take_bit_iff min_def nat_less_le not_less_eq take_bit_int_eq_self_iff take_bit_take_bit)
   done
 
 lemma ucast_sub_ucast:
   fixes x :: "'a::len word"
   assumes "y \<le> x"
   assumes T: "LENGTH('a) \<le> LENGTH('b)"
   shows "ucast (x - y) = (ucast x - ucast y :: 'b::len word)"
 proof -
   from T
   have P: "unat x < 2 ^ LENGTH('b)" "unat y < 2 ^ LENGTH('b)"
     by (fastforce intro!: less_le_trans[OF unat_lt2p])+
   then show ?thesis
     by (simp add: unat_arith_simps unat_ucast assms[simplified unat_arith_simps])
 qed
 
 lemma word_1_0:
   "\<lbrakk>a + (1::('a::len) word) \<le> b; a < of_nat x\<rbrakk> \<Longrightarrow> a < b"
   apply transfer
   apply (subst (asm) take_bit_incr_eq)
    apply (auto simp add: diff_less_eq)
   using take_bit_int_less_exp le_less_trans by blast
 
 lemma unat_of_nat_less:"\<lbrakk> a < b; unat b = c \<rbrakk> \<Longrightarrow> a < of_nat c"
   by fastforce
 
 lemma word_le_plus_1: "\<lbrakk> (y::('a::len) word) < y + n; a < n \<rbrakk> \<Longrightarrow> y + a \<le> y + a + 1"
   by unat_arith
 
 lemma word_le_plus:"\<lbrakk>(a::('a::len) word) < a + b; c < b\<rbrakk> \<Longrightarrow> a \<le> a + c"
   by (metis order_less_imp_le word_random)
 
 lemma sint_minus1 [simp]: "(sint x = -1) = (x = -1)"
   apply (cases \<open>LENGTH('a)\<close>)
    apply simp_all
   apply transfer
   apply (simp flip: signed_take_bit_eq_iff_take_bit_eq)
   done
 
 lemma sint_0 [simp]: "(sint x = 0) = (x = 0)"
   by (fact signed_eq_0_iff)
 
 (* It is not always that case that "sint 1 = 1", because of 1-bit word sizes.
  * This lemma produces the different cases. *)
 lemma sint_1_cases:
   P if \<open>\<lbrakk> len_of TYPE ('a::len) = 1; (a::'a word) = 0; sint a = 0 \<rbrakk> \<Longrightarrow> P\<close>
      \<open>\<lbrakk> len_of TYPE ('a) = 1; a = 1; sint (1 :: 'a word) = -1 \<rbrakk> \<Longrightarrow> P\<close>
      \<open>\<lbrakk> len_of TYPE ('a) > 1; sint (1 :: 'a word) = 1 \<rbrakk> \<Longrightarrow> P\<close>
 proof (cases \<open>LENGTH('a) = 1\<close>)
   case True
   then have \<open>a = 0 \<or> a = 1\<close>
     by transfer auto
   with True that show ?thesis
     by auto
 next
   case False
   with that show ?thesis
     by (simp add: less_le Suc_le_eq)
 qed
 
 lemma sint_int_min:
   "sint (- (2 ^ (LENGTH('a) - Suc 0)) :: ('a::len) word) = - (2 ^ (LENGTH('a) - Suc 0))"
   apply (cases \<open>LENGTH('a)\<close>)
    apply simp_all
   apply transfer
   apply (simp add: signed_take_bit_int_eq_self)
   done
 
 lemma sint_int_max_plus_1:
   "sint (2 ^ (LENGTH('a) - Suc 0) :: ('a::len) word) = - (2 ^ (LENGTH('a) - Suc 0))"
   apply (cases \<open>LENGTH('a)\<close>)
    apply simp_all
   apply (subst word_of_int_2p [symmetric])
   apply (subst int_word_sint)
   apply simp
   done
 
 lemma uint_range':
   \<open>0 \<le> uint x \<and> uint x < 2 ^ LENGTH('a)\<close>
   for x :: \<open>'a::len word\<close>
   by transfer simp
 
 lemma sint_of_int_eq:
   "\<lbrakk> - (2 ^ (LENGTH('a) - 1)) \<le> x; x < 2 ^ (LENGTH('a) - 1) \<rbrakk> \<Longrightarrow> sint (of_int x :: ('a::len) word) = x"
   by (simp add: signed_take_bit_int_eq_self)
 
 lemma of_int_sint:
   "of_int (sint a) = a"
   by simp
 
 lemma sint_ucast_eq_uint:
     "\<lbrakk> \<not> is_down (ucast :: ('a::len word \<Rightarrow> 'b::len word)) \<rbrakk>
             \<Longrightarrow> sint ((ucast :: ('a::len word \<Rightarrow> 'b::len word)) x) = uint x"
   apply transfer
   apply (simp add: signed_take_bit_take_bit)
   done
 
 lemma word_less_nowrapI':
   "(x :: 'a :: len word) \<le> z - k \<Longrightarrow> k \<le> z \<Longrightarrow> 0 < k \<Longrightarrow> x < x + k"
   by uint_arith
 
 lemma mask_plus_1:
   "mask n + 1 = (2 ^ n :: 'a::len word)"
   by (clarsimp simp: mask_eq_decr_exp)
 
 lemma unat_inj: "inj unat"
   by (metis eq_iff injI word_le_nat_alt)
 
 lemma unat_ucast_upcast:
   "is_up (ucast :: 'b word \<Rightarrow> 'a word)
       \<Longrightarrow> unat (ucast x :: ('a::len) word) = unat (x :: ('b::len) word)"
   unfolding ucast_eq unat_eq_nat_uint
   apply transfer
   apply simp
   done
 
 lemma ucast_mono:
   "\<lbrakk> (x :: 'b :: len word) < y; y < 2 ^ LENGTH('a) \<rbrakk>
    \<Longrightarrow> ucast x < ((ucast y) :: 'a :: len word)"
   apply (simp only: flip: ucast_nat_def)
   apply (rule of_nat_mono_maybe)
   apply (rule unat_less_helper)
   apply simp
   apply (simp add: word_less_nat_alt)
   done
 
 lemma ucast_mono_le:
   "\<lbrakk>x \<le> y; y < 2 ^ LENGTH('b)\<rbrakk> \<Longrightarrow> (ucast (x :: 'a :: len word) :: 'b :: len word) \<le> ucast y"
   apply (simp only: flip: ucast_nat_def)
   apply (subst of_nat_mono_maybe_le[symmetric])
     apply (rule unat_less_helper)
     apply simp
    apply (rule unat_less_helper)
    apply (erule le_less_trans)
   apply (simp_all add: word_le_nat_alt)
   done
 
 lemma ucast_mono_le':
   "\<lbrakk> unat y < 2 ^ LENGTH('b); LENGTH('b::len) < LENGTH('a::len); x \<le> y \<rbrakk>
    \<Longrightarrow> ucast x \<le> (ucast y :: 'b word)" for x y :: \<open>'a::len word\<close>
   by (auto simp: word_less_nat_alt intro: ucast_mono_le)
 
 lemma neg_mask_add_mask:
   "((x:: 'a :: len word) AND NOT (mask n)) + (2 ^ n - 1) = x OR mask n"
   unfolding mask_2pm1 [symmetric]
   apply (subst word_plus_and_or_coroll; rule bit_word_eqI)
    apply (auto simp add: bit_simps)
   done
 
 lemma le_step_down_word:"\<lbrakk>(i::('a::len) word) \<le> n; i = n \<longrightarrow> P; i \<le> n - 1 \<longrightarrow> P\<rbrakk> \<Longrightarrow> P"
   by unat_arith
 
 lemma le_step_down_word_2:
   fixes x :: "'a::len word"
   shows "\<lbrakk>x \<le>  y; x \<noteq> y\<rbrakk> \<Longrightarrow> x \<le> y - 1"
   by (subst (asm) word_le_less_eq,
       clarsimp,
       simp add: word_le_minus_one_leq)
 
 lemma NOT_mask_AND_mask[simp]: "(w AND mask n) AND NOT (mask n) = 0"
-  by (clarsimp simp add: mask_eq_decr_exp Parity.bit_eq_iff bit_and_iff bit_not_iff bit_mask_iff)
+  by (rule bit_eqI) (simp add: bit_simps)
 
 lemma and_and_not[simp]:"(a AND b) AND NOT b = 0"
   for a b :: \<open>'a::len word\<close>
   apply (subst word_bw_assocs(1))
   apply clarsimp
   done
 
 lemma ex_mask_1[simp]: "(\<exists>x. mask x = (1 :: 'a::len word))"
   apply (rule_tac x=1 in exI)
   apply (simp add:mask_eq_decr_exp)
   done
 
 lemma not_switch:"NOT a = x \<Longrightarrow> a = NOT x"
   by auto
 
 lemma test_bit_eq_iff: "bit u = bit v \<longleftrightarrow> u = v"
   for u v :: "'a::len word"
   by (simp add: bit_eq_iff fun_eq_iff)
 
 lemma test_bit_size: "bit w n \<Longrightarrow> n < size w"
   for w :: "'a::len word"
   by transfer simp
 
 lemma word_eq_iff: "x = y \<longleftrightarrow> (\<forall>n<LENGTH('a). bit x n = bit y n)" (is \<open>?P \<longleftrightarrow> ?Q\<close>)
   for x y :: "'a::len word"
   by transfer (auto simp add: bit_eq_iff bit_take_bit_iff)
 
 lemma word_eqI: "(\<And>n. n < size u \<longrightarrow> bit u n = bit v n) \<Longrightarrow> u = v"
   for u :: "'a::len word"
   by (simp add: word_size word_eq_iff)
 
 lemma word_eqD: "u = v \<Longrightarrow> bit u x = bit v x"
   for u v :: "'a::len word"
   by simp
 
 lemma test_bit_bin': "bit w n \<longleftrightarrow> n < size w \<and> bit (uint w) n"
   by transfer (simp add: bit_take_bit_iff)
 
 lemmas test_bit_bin = test_bit_bin' [unfolded word_size]
 
 lemma word_test_bit_def:
   \<open>bit a = bit (uint a)\<close>
   by transfer (simp add: fun_eq_iff bit_take_bit_iff)
 
 lemmas test_bit_def' = word_test_bit_def [THEN fun_cong]
 
 lemma word_test_bit_transfer [transfer_rule]:
   "(rel_fun pcr_word (rel_fun (=) (=)))
     (\<lambda>x n. n < LENGTH('a) \<and> bit x n) (bit :: 'a::len word \<Rightarrow> _)"
   by transfer_prover
 
 lemma test_bit_wi:
   "bit (word_of_int x :: 'a::len word) n \<longleftrightarrow> n < LENGTH('a) \<and> bit x n"
   by transfer simp
 
 lemma word_ops_nth_size:
   "n < size x \<Longrightarrow>
     bit (x OR y) n = (bit x n | bit y n) \<and>
     bit (x AND y) n = (bit x n \<and> bit y n) \<and>
     bit (x XOR y) n = (bit x n \<noteq> bit y n) \<and>
     bit (NOT x) n = (\<not> bit x n)"
   for x :: "'a::len word"
   by transfer (simp add: bit_or_iff bit_and_iff bit_xor_iff bit_not_iff)
 
 lemma word_ao_nth:
   "bit (x OR y) n = (bit x n | bit y n) \<and>
     bit (x AND y) n = (bit x n \<and> bit y n)"
   for x :: "'a::len word"
   by transfer (auto simp add: bit_or_iff bit_and_iff)
 
 lemmas lsb0 = len_gt_0 [THEN word_ops_nth_size [unfolded word_size]]
 
 lemma nth_sint:
   fixes w :: "'a::len word"
   defines "l \<equiv> LENGTH('a)"
   shows "bit (sint w) n = (if n < l - 1 then bit w n else bit w (l - 1))"
   unfolding sint_uint l_def
   by (auto simp: bit_signed_take_bit_iff word_test_bit_def not_less min_def)
 
 lemma test_bit_2p: "bit (word_of_int (2 ^ n)::'a::len word) m \<longleftrightarrow> m = n \<and> m < LENGTH('a)"
   by transfer (auto simp add: bit_exp_iff)
 
 lemma nth_w2p: "bit ((2::'a::len word) ^ n) m \<longleftrightarrow> m = n \<and> m < LENGTH('a::len)"
   by transfer (auto simp add: bit_exp_iff)
 
 lemma bang_is_le: "bit x m \<Longrightarrow> 2 ^ m \<le> x"
   for x :: "'a::len word"
   apply (rule xtrans(3))
    apply (rule_tac [2] y = "x" in le_word_or2)
   apply (rule word_eqI)
   apply (auto simp add: word_ao_nth nth_w2p word_size)
   done
 
 lemmas msb0 = len_gt_0 [THEN diff_Suc_less, THEN word_ops_nth_size [unfolded word_size]]
 lemmas msb1 = msb0 [where i = 0]
 
 lemma test_bit_1 [iff]: "bit (1 :: 'a::len word) n \<longleftrightarrow> n = 0"
   by transfer (auto simp add: bit_1_iff)
 
 lemma nth_0: "\<not> bit (0 :: 'a::len word) n"
   by transfer simp
 
 lemma nth_minus1: "bit (-1 :: 'a::len word) n \<longleftrightarrow> n < LENGTH('a)"
   by transfer simp
 
 lemma nth_ucast:
   "bit (ucast w::'a::len word) n = (bit w n \<and> n < LENGTH('a))"
   by transfer (simp add: bit_take_bit_iff ac_simps)
 
 lemma drop_bit_numeral_bit0_1 [simp]:
   \<open>drop_bit (Suc 0) (numeral k) =
     (word_of_int (drop_bit (Suc 0) (take_bit LENGTH('a) (numeral k))) :: 'a::len word)\<close>
   by (metis Word_eq_word_of_int drop_bit_word.abs_eq of_int_numeral)
 
 lemma nth_mask:
   \<open>bit (mask n :: 'a::len word) i \<longleftrightarrow> i < n \<and> i < size (mask n :: 'a word)\<close>
   by (auto simp add: word_size Word.bit_mask_iff)
 
 lemma nth_slice: "bit (slice n w :: 'a::len word) m = (bit w (m + n) \<and> m < LENGTH('a))"
   apply (auto simp add: bit_simps less_diff_conv dest: bit_imp_le_length)
   using bit_imp_le_length
   apply fastforce
   done
 
 lemma test_bit_cat [OF refl]:
   "wc = word_cat a b \<Longrightarrow> bit wc n = (n < size wc \<and>
     (if n < size b then bit b n else bit a (n - size b)))"
   apply (simp add: word_size not_less; transfer)
        apply (auto simp add: bit_concat_bit_iff bit_take_bit_iff)
   done
 
 \<comment> \<open>keep quantifiers for use in simplification\<close>
 lemma test_bit_split':
   "word_split c = (a, b) \<longrightarrow>
     (\<forall>n m.
       bit b n = (n < size b \<and> bit c n) \<and>
       bit a m = (m < size a \<and> bit c (m + size b)))"
   by (auto simp add: word_split_bin' bit_unsigned_iff word_size bit_drop_bit_eq ac_simps
            dest: bit_imp_le_length)
 
 lemma test_bit_split:
   "word_split c = (a, b) \<Longrightarrow>
     (\<forall>n::nat. bit b n \<longleftrightarrow> n < size b \<and> bit c n) \<and>
     (\<forall>m::nat. bit a m \<longleftrightarrow> m < size a \<and> bit c (m + size b))"
   by (simp add: test_bit_split')
 
 lemma test_bit_split_eq:
   "word_split c = (a, b) \<longleftrightarrow>
     ((\<forall>n::nat. bit b n = (n < size b \<and> bit c n)) \<and>
      (\<forall>m::nat. bit a m = (m < size a \<and> bit c (m + size b))))"
   apply (rule_tac iffI)
    apply (rule_tac conjI)
     apply (erule test_bit_split [THEN conjunct1])
    apply (erule test_bit_split [THEN conjunct2])
   apply (case_tac "word_split c")
   apply (frule test_bit_split)
   apply (erule trans)
   apply (fastforce intro!: word_eqI simp add: word_size)
   done
 
 lemma test_bit_rcat:
   "sw = size (hd wl) \<Longrightarrow> rc = word_rcat wl \<Longrightarrow> bit rc n =
     (n < size rc \<and> n div sw < size wl \<and> bit ((rev wl) ! (n div sw)) (n mod sw))"
   for wl :: "'a::len word list"
   by (simp add: word_size word_rcat_def rev_map bit_horner_sum_uint_exp_iff bit_simps not_le)
 
 lemmas test_bit_cong = arg_cong [where f = "bit", THEN fun_cong]
 
 lemma max_test_bit: "bit (- 1::'a::len word) n \<longleftrightarrow> n < LENGTH('a)"
   by (fact nth_minus1)
 
 lemma map_nth_0 [simp]: "map (bit (0::'a::len word)) xs = replicate (length xs) False"
   by (simp flip: map_replicate_const)
 
 lemma word_and_1:
   "n AND 1 = (if bit n 0 then 1 else 0)" for n :: "_ word"
   by (rule bit_word_eqI) (auto simp add: bit_and_iff bit_1_iff intro: gr0I)
 
 lemma test_bit_1':
   "bit (1 :: 'a :: len word) n \<longleftrightarrow> 0 < LENGTH('a) \<and> n = 0"
   by simp
 
 lemma nth_w2p_same:
   "bit (2^n :: 'a :: len word) n = (n < LENGTH('a))"
   by (simp add: nth_w2p)
 
 lemma word_leI:
   "(\<And>n.  \<lbrakk>n < size (u::'a::len word); bit u n \<rbrakk> \<Longrightarrow> bit (v::'a::len word) n) \<Longrightarrow> u <= v"
   apply (rule order_trans [of u \<open>u AND v\<close> v])
    apply (rule eq_refl)
    apply (rule bit_word_eqI)
    apply (auto simp add: bit_simps word_and_le1 word_size)
   done
 
 lemma bang_eq:
   fixes x :: "'a::len word"
   shows "(x = y) = (\<forall>n. bit x n = bit y n)"
   by (auto simp add: bit_eq_iff)
 
 lemma neg_mask_test_bit:
   "bit (NOT(mask n) :: 'a :: len word) m = (n \<le> m \<and> m < LENGTH('a))"
   by (auto simp add: bit_simps)
 
 lemma upper_bits_unset_is_l2p:
   \<open>(\<forall>n' \<ge> n. n' < LENGTH('a) \<longrightarrow> \<not> bit p n') \<longleftrightarrow> (p < 2 ^ n)\<close> (is \<open>?P \<longleftrightarrow> ?Q\<close>)
     if \<open>n < LENGTH('a)\<close>
     for p :: "'a :: len word"
 proof
   assume ?Q
   then show ?P
     by (meson bang_is_le le_less_trans not_le word_power_increasing)
 next
   assume ?P
   have \<open>take_bit n p = p\<close>
   proof (rule bit_word_eqI)
     fix q
     assume \<open>q < LENGTH('a)\<close>
     show \<open>bit (take_bit n p) q \<longleftrightarrow> bit p q\<close>
     proof (cases \<open>q < n\<close>)
       case True
       then show ?thesis
         by (auto simp add: bit_simps)
     next
       case False
       then have \<open>n \<le> q\<close>
         by simp
       with \<open>?P\<close> \<open>q < LENGTH('a)\<close> have \<open>\<not> bit p q\<close>
         by simp
       then show ?thesis
         by (simp add: bit_simps)
     qed
   qed
   with that show ?Q
     using take_bit_word_eq_self_iff [of n p] by auto
 qed
 
 lemma less_2p_is_upper_bits_unset:
   "p < 2 ^ n \<longleftrightarrow> n < LENGTH('a) \<and> (\<forall>n' \<ge> n. n' < LENGTH('a) \<longrightarrow> \<not> bit p n')" for p :: "'a :: len word"
   by (meson le_less_trans le_mask_iff_lt_2n upper_bits_unset_is_l2p word_zero_le)
 
 lemma test_bit_over:
   "n \<ge> size (x::'a::len word) \<Longrightarrow> (bit x n) = False"
   by transfer auto
 
 lemma le_mask_high_bits:
   "w \<le> mask n \<longleftrightarrow> (\<forall>i \<in> {n ..< size w}. \<not> bit w i)"
   for w :: \<open>'a::len word\<close>
   apply (auto simp add: bit_simps word_size less_eq_mask_iff_take_bit_eq_self)
    apply (metis bit_take_bit_iff leD)
   apply (metis atLeastLessThan_iff leI take_bit_word_eq_self_iff upper_bits_unset_is_l2p)
   done
 
 lemma test_bit_conj_lt:
   "(bit x m \<and> m < LENGTH('a)) = bit x m" for x :: "'a :: len word"
   using test_bit_bin by blast
 
 lemma neg_test_bit:
   "bit (NOT x) n = (\<not> bit x n \<and> n < LENGTH('a))" for x :: "'a::len word"
   by (cases "n < LENGTH('a)") (auto simp add: test_bit_over word_ops_nth_size word_size)
 
 lemma nth_bounded:
   "\<lbrakk>bit (x :: 'a :: len word) n; x < 2 ^ m; m \<le> len_of TYPE ('a)\<rbrakk> \<Longrightarrow> n < m"
   apply (rule ccontr)
   apply (auto simp add: not_less)
   apply (meson bit_imp_le_length bit_uint_iff less_2p_is_upper_bits_unset test_bit_bin)
   done
 
 lemma and_neq_0_is_nth:
   \<open>x AND y \<noteq> 0 \<longleftrightarrow> bit x n\<close> if \<open>y = 2 ^ n\<close> for x y :: \<open>'a::len word\<close>
   apply (simp add: bit_eq_iff bit_simps)
   using that apply (simp add: bit_simps not_le)
   apply transfer
   apply auto
   done
 
 lemma nth_is_and_neq_0:
   "bit (x::'a::len word) n = (x AND 2 ^ n \<noteq> 0)"
   by (subst and_neq_0_is_nth; rule refl)
 
 lemma max_word_not_less [simp]:
    "\<not> - 1 < x" for x :: \<open>'a::len word\<close>
   by (fact word_order.extremum_strict)
 
 lemma bit_twiddle_min:
   "(y::'a::len word) XOR (((x::'a::len word) XOR y) AND (if x < y then -1 else 0)) = min x y"
   by (rule bit_eqI) (auto simp add: bit_simps)
 
 lemma bit_twiddle_max:
   "(x::'a::len word) XOR (((x::'a::len word) XOR y) AND (if x < y then -1 else 0)) = max x y"
   by (rule bit_eqI) (auto simp add: bit_simps max_def)
 
 lemma swap_with_xor:
   "\<lbrakk>(x::'a::len word) = a XOR b; y = b XOR x; z = x XOR y\<rbrakk> \<Longrightarrow> z = b \<and> y = a"
-  by (auto simp add: Parity.bit_eq_iff bit_xor_iff max_def)
+  by (auto intro: bit_word_eqI simp add: bit_simps)
 
 lemma le_mask_imp_and_mask:
   "(x::'a::len word) \<le> mask n \<Longrightarrow> x AND mask n = x"
   by (metis and_mask_eq_iff_le_mask)
 
 lemma or_not_mask_nop:
   "((x::'a::len word) OR NOT (mask n)) AND mask n = x AND mask n"
   by (metis word_and_not word_ao_dist2 word_bw_comms(1) word_log_esimps(3))
 
 lemma mask_subsume:
   "\<lbrakk>n \<le> m\<rbrakk> \<Longrightarrow> ((x::'a::len word) OR y AND mask n) AND NOT (mask m) = x AND NOT (mask m)"
   by (rule bit_word_eqI) (auto simp add: bit_simps word_size)
 
 lemma and_mask_0_iff_le_mask:
   fixes w :: "'a::len word"
   shows "(w AND NOT(mask n) = 0) = (w \<le> mask n)"
   by (simp add: mask_eq_0_eq_x le_mask_imp_and_mask and_mask_eq_iff_le_mask)
 
 lemma mask_twice2:
   "n \<le> m \<Longrightarrow> ((x::'a::len word) AND mask m) AND mask n = x AND mask n"
   by (metis mask_twice min_def)
 
 lemma uint_2_id:
   "LENGTH('a) \<ge> 2 \<Longrightarrow> uint (2::('a::len) word) = 2"
   by simp
 
 lemma div_of_0_id[simp]:"(0::('a::len) word) div n = 0"
   by (simp add: word_div_def)
 
 lemma degenerate_word:"LENGTH('a) = 1 \<Longrightarrow> (x::('a::len) word) = 0 \<or> x = 1"
   by (metis One_nat_def less_irrefl_nat sint_1_cases)
 
 lemma div_by_0_word:"(x::('a::len) word) div 0 = 0"
   by (metis div_0 div_by_0 unat_0 word_arith_nat_defs(6) word_div_1)
 
 lemma div_less_dividend_word:"\<lbrakk>x \<noteq> 0; n \<noteq> 1\<rbrakk> \<Longrightarrow> (x::('a::len) word) div n < x"
   apply (cases \<open>n = 0\<close>)
    apply clarsimp
    apply (simp add:word_neq_0_conv)
   apply (subst word_arith_nat_div)
   apply (rule word_of_nat_less)
   apply (rule div_less_dividend)
   using unat_eq_zero word_unat_Rep_inject1 apply force
   apply (simp add:unat_gt_0)
   done
 
 lemma word_less_div:
   fixes x :: "('a::len) word"
     and y :: "('a::len) word"
   shows "x div y = 0 \<Longrightarrow> y = 0 \<or> x < y"
   apply (case_tac "y = 0", clarsimp+)
   by (metis One_nat_def Suc_le_mono le0 le_div_geq not_less unat_0 unat_div unat_gt_0 word_less_nat_alt zero_less_one)
 
 lemma not_degenerate_imp_2_neq_0:"LENGTH('a) > 1 \<Longrightarrow> (2::('a::len) word) \<noteq> 0"
   by (metis numerals(1) power_not_zero power_zero_numeral)
 
 lemma word_overflow:"(x::('a::len) word) + 1 > x \<or> x + 1 = 0"
   apply clarsimp
   by (metis diff_0 eq_diff_eq less_x_plus_1)
 
 lemma word_overflow_unat:"unat ((x::('a::len) word) + 1) = unat x + 1 \<or> x + 1 = 0"
   by (metis Suc_eq_plus1 add.commute unatSuc)
 
 lemma even_word_imp_odd_next:"even (unat (x::('a::len) word)) \<Longrightarrow> x + 1 = 0 \<or> odd (unat (x + 1))"
   apply (cut_tac x=x in word_overflow_unat)
   apply clarsimp
   done
 
 lemma odd_word_imp_even_next:"odd (unat (x::('a::len) word)) \<Longrightarrow> x + 1 = 0 \<or> even (unat (x + 1))"
   apply (cut_tac x=x in word_overflow_unat)
   apply clarsimp
   done
 
 lemma overflow_imp_lsb:"(x::('a::len) word) + 1 = 0 \<Longrightarrow> bit x 0"
   using even_plus_one_iff [of x] by simp
 
 lemma odd_iff_lsb:"odd (unat (x::('a::len) word)) = bit x 0"
   by transfer (simp add: even_nat_iff)
 
 lemma of_nat_neq_iff_word:
       "x mod 2 ^ LENGTH('a) \<noteq> y mod 2 ^ LENGTH('a) \<Longrightarrow>
          (((of_nat x)::('a::len) word) \<noteq> of_nat y) = (x \<noteq> y)"
   apply (rule iffI)
    apply (case_tac "x = y")
    apply (subst (asm) of_nat_eq_iff[symmetric])
    apply auto
   apply (case_tac "((of_nat x)::('a::len) word) = of_nat y")
   apply auto
    apply (metis unat_of_nat)
   done
 
 lemma lsb_this_or_next: "\<not> (bit ((x::('a::len) word) + 1) 0) \<Longrightarrow> bit x 0"
   by simp
 
 lemma mask_or_not_mask:
   "x AND mask n OR x AND NOT (mask n) = x"
   for x :: \<open>'a::len word\<close>
   apply (subst word_oa_dist, simp)
   apply (subst word_oa_dist2, simp)
   done
 
 lemma word_gr0_conv_Suc: "(m::'a::len word) > 0 \<Longrightarrow> \<exists>n. m = n + 1"
   by (metis add.commute add_minus_cancel)
 
 lemma revcast_down_us [OF refl]:
   "rc = revcast \<Longrightarrow> source_size rc = target_size rc + n \<Longrightarrow> rc w = ucast (signed_drop_bit n w)"
   for w :: "'a::len word"
   apply (simp add: source_size_def target_size_def)
   apply (rule bit_word_eqI)
   apply (simp add: bit_simps ac_simps)
   done
 
 lemma revcast_down_ss [OF refl]:
   "rc = revcast \<Longrightarrow> source_size rc = target_size rc + n \<Longrightarrow> rc w = scast (signed_drop_bit n w)"
   for w :: "'a::len word"
   apply (simp add: source_size_def target_size_def)
   apply (rule bit_word_eqI)
   apply (simp add: bit_simps ac_simps)
   done
 
 lemma revcast_down_uu [OF refl]:
   "rc = revcast \<Longrightarrow> source_size rc = target_size rc + n \<Longrightarrow> rc w = ucast (drop_bit n w)"
   for w :: "'a::len word"
   apply (simp add: source_size_def target_size_def)
   apply (rule bit_word_eqI)
   apply (simp add: bit_simps ac_simps)
   done
 
 lemma revcast_down_su [OF refl]:
   "rc = revcast \<Longrightarrow> source_size rc = target_size rc + n \<Longrightarrow> rc w = scast (drop_bit n w)"
   for w :: "'a::len word"
   apply (simp add: source_size_def target_size_def)
   apply (rule bit_word_eqI)
   apply (simp add: bit_simps ac_simps)
   done
 
 lemma cast_down_rev [OF refl]:
   "uc = ucast \<Longrightarrow> source_size uc = target_size uc + n \<Longrightarrow> uc w = revcast (push_bit n w)"
   for w :: "'a::len word"
   apply (simp add: source_size_def target_size_def)
   apply (rule bit_word_eqI)
   apply (simp add: bit_simps)
   done
 
 lemma revcast_up [OF refl]:
   "rc = revcast \<Longrightarrow> source_size rc + n = target_size rc \<Longrightarrow>
     rc w = push_bit n (ucast w :: 'a::len word)"
   apply (simp add: source_size_def target_size_def)
   apply (rule bit_word_eqI)
   apply (simp add: bit_simps)
   apply auto
   apply (metis add.commute add_diff_cancel_right)
   apply (metis diff_add_inverse2 diff_diff_add)
   done
 
 lemmas rc1 = revcast_up [THEN
   revcast_rev_ucast [symmetric, THEN trans, THEN word_rev_gal, symmetric]]
 lemmas rc2 = revcast_down_uu [THEN
   revcast_rev_ucast [symmetric, THEN trans, THEN word_rev_gal, symmetric]]
 
 lemma word_ops_nth:
   fixes x y :: \<open>'a::len word\<close>
   shows
   word_or_nth:  "bit (x OR y) n = (bit x n \<or> bit y n)" and
   word_and_nth: "bit (x AND y) n = (bit x n \<and> bit y n)" and
   word_xor_nth: "bit (x XOR y) n = (bit x n \<noteq> bit y n)"
   by (simp_all add: bit_simps)
 
 lemma word_power_nonzero:
   "\<lbrakk> (x :: 'a::len word) < 2 ^ (LENGTH('a) - n); n < LENGTH('a); x \<noteq> 0 \<rbrakk>
   \<Longrightarrow> x * 2 ^ n \<noteq> 0"
   by (metis gr_implies_not0 mult_eq_0_iff nat_mult_power_less_eq numeral_2_eq_2
     p2_gt_0 unat_eq_zero unat_less_power unat_mult_lem unat_power_lower word_gt_a_gt_0 zero_less_Suc)
 
 lemma less_1_helper:
   "n \<le> m \<Longrightarrow> (n - 1 :: int) < m"
   by arith
 
 lemma div_power_helper:
   "\<lbrakk> x \<le> y; y < LENGTH('a) \<rbrakk> \<Longrightarrow> (2 ^ y - 1) div (2 ^ x :: 'a::len word) = 2 ^ (y - x) - 1"
   apply (simp flip: mask_eq_exp_minus_1 drop_bit_eq_div)
   apply (rule bit_word_eqI)
   apply (auto simp add: bit_simps not_le)
   done
 
 lemma max_word_mask:
   "(- 1 :: 'a::len word) = mask LENGTH('a)"
   by (fact minus_1_eq_mask)
 
 lemmas mask_len_max = max_word_mask[symmetric]
 
 lemma mask_out_first_mask_some:
   "\<lbrakk> x AND NOT (mask n) = y; n \<le> m \<rbrakk> \<Longrightarrow> x AND NOT (mask m) = y AND NOT (mask m)"
   for x y :: \<open>'a::len word\<close>
   by (rule bit_word_eqI) (auto simp add: bit_simps word_size)
 
 lemma mask_lower_twice:
   "n \<le> m \<Longrightarrow> (x AND NOT (mask n)) AND NOT (mask m) = x AND NOT (mask m)"
   for x :: \<open>'a::len word\<close>
   by (rule bit_word_eqI) (auto simp add: bit_simps word_size)
 
 lemma mask_lower_twice2:
   "(a AND NOT (mask n)) AND NOT (mask m) = a AND NOT (mask (max n m))"
   for a :: \<open>'a::len word\<close>
   by (rule bit_word_eqI) (auto simp add: bit_simps)
 
 lemma ucast_and_neg_mask:
   "ucast (x AND NOT (mask n)) = ucast x AND NOT (mask n)"
   apply (rule bit_word_eqI)
   apply (auto simp add: bit_simps dest: bit_imp_le_length)
   done
 
 lemma ucast_and_mask:
   "ucast (x AND mask n) = ucast x AND mask n"
   apply (rule bit_word_eqI)
   apply (auto simp add: bit_simps dest: bit_imp_le_length)
   done
 
 lemma ucast_mask_drop:
   "LENGTH('a :: len) \<le> n \<Longrightarrow> (ucast (x AND mask n) :: 'a word) = ucast x"
   apply (rule bit_word_eqI)
   apply (auto simp add: bit_simps dest: bit_imp_le_length)
   done
 
 lemma mask_exceed:
   "n \<ge> LENGTH('a) \<Longrightarrow> (x::'a::len word) AND NOT (mask n) = 0"
   by (rule bit_word_eqI) (simp add: bit_simps)
 
 lemma word_add_no_overflow:"(x::'a::len word) < - 1 \<Longrightarrow> x < x + 1"
   using less_x_plus_1 order_less_le by blast
 
 lemma lt_plus_1_le_word:
   fixes x :: "'a::len word"
   assumes bound:"n < unat (maxBound::'a word)"
   shows "x < 1 + of_nat n = (x \<le> of_nat n)"
   by (metis add.commute bound max_word_max word_Suc_leq word_not_le word_of_nat_less)
 
 lemma unat_ucast_up_simp:
   fixes x :: "'a::len word"
   assumes "LENGTH('a) \<le> LENGTH('b)"
   shows "unat (ucast x :: 'b::len word) = unat x"
   apply (rule bit_eqI)
   using assms apply (auto simp add: bit_simps dest: bit_imp_le_length)
   done
 
 lemma unat_ucast_less_no_overflow:
   "\<lbrakk>n < 2 ^ LENGTH('a); unat f < n\<rbrakk> \<Longrightarrow> (f::('a::len) word) < of_nat n"
   by (erule (1)  order_le_less_trans[OF _ of_nat_mono_maybe,rotated]) simp
 
 lemma unat_ucast_less_no_overflow_simp:
   "n < 2 ^ LENGTH('a) \<Longrightarrow> (unat f < n) = ((f::('a::len) word) < of_nat n)"
   using unat_less_helper unat_ucast_less_no_overflow by blast
 
 lemma unat_ucast_no_overflow_le:
   assumes no_overflow: "unat b < (2 :: nat) ^ LENGTH('a)"
   and upward_cast: "LENGTH('a) < LENGTH('b)"
   shows "(ucast (f::'a::len word) < (b :: 'b :: len word)) = (unat f < unat b)"
 proof -
   have LR: "ucast f < b \<Longrightarrow> unat f < unat b"
     apply (rule unat_less_helper)
     apply (simp add:ucast_nat_def)
     apply (rule_tac 'b1 = 'b in  ucast_less_ucast[OF order.strict_implies_order, THEN iffD1])
      apply (rule upward_cast)
     apply (simp add: ucast_ucast_mask less_mask_eq word_less_nat_alt
                      unat_power_lower[OF upward_cast] no_overflow)
     done
   have RL: "unat f < unat b \<Longrightarrow> ucast f < b"
   proof-
     assume ineq: "unat f < unat b"
     have "ucast (f::'a::len word) < ((ucast (ucast b ::'a::len word)) :: 'b :: len word)"
       apply (simp add: ucast_less_ucast[OF order.strict_implies_order] upward_cast)
       apply (simp only: flip: ucast_nat_def)
       apply (rule unat_ucast_less_no_overflow[OF no_overflow ineq])
       done
     then show ?thesis
       apply (rule order_less_le_trans)
       apply (simp add:ucast_ucast_mask word_and_le2)
       done
   qed
   then show ?thesis by (simp add:RL LR iffI)
 qed
 
 lemmas ucast_up_mono = ucast_less_ucast[THEN iffD2]
 
 lemma minus_one_word:
   "(-1 :: 'a :: len word) = 2 ^ LENGTH('a) - 1"
   by simp
 
 lemma le_2p_upper_bits:
   "\<lbrakk> (p::'a::len word) \<le> 2^n - 1; n < LENGTH('a) \<rbrakk> \<Longrightarrow>
   \<forall>n'\<ge>n. n' < LENGTH('a) \<longrightarrow> \<not> bit p n'"
   by (subst upper_bits_unset_is_l2p; simp)
 
 lemma le2p_bits_unset:
   "p \<le> 2 ^ n - 1 \<Longrightarrow> \<forall>n'\<ge>n. n' < LENGTH('a) \<longrightarrow> \<not> bit (p::'a::len word) n'"
   using upper_bits_unset_is_l2p [where p=p]
   by (cases "n < LENGTH('a)") auto
 
 lemma complement_nth_w2p:
   shows "n' < LENGTH('a) \<Longrightarrow> bit (NOT (2 ^ n :: 'a::len word)) n' = (n' \<noteq> n)"
   by (fastforce simp: word_ops_nth_size word_size nth_w2p)
 
 lemma word_unat_and_lt:
   "unat x < n \<or> unat y < n \<Longrightarrow> unat (x AND y) < n"
   by (meson le_less_trans word_and_le1 word_and_le2 word_le_nat_alt)
 
 lemma word_unat_mask_lt:
   "m \<le> size w \<Longrightarrow> unat ((w::'a::len word) AND mask m) < 2 ^ m"
   by (rule word_unat_and_lt) (simp add: unat_mask word_size)
 
 lemma word_sless_sint_le:"x <s y \<Longrightarrow> sint x \<le> sint y - 1"
   by (metis word_sless_alt zle_diff1_eq)
 
 lemma upper_trivial:
   fixes x :: "'a::len word"
   shows "x \<noteq> 2 ^ LENGTH('a) - 1 \<Longrightarrow> x < 2 ^ LENGTH('a) - 1"
   by (simp add: less_le)
 
 lemma constraint_expand:
   fixes x :: "'a::len word"
   shows "x \<in> {y. lower \<le> y \<and> y \<le> upper} = (lower \<le> x \<and> x \<le> upper)"
   by (rule mem_Collect_eq)
 
 lemma card_map_elide:
   "card ((of_nat :: nat \<Rightarrow> 'a::len word) ` {0..<n}) = card {0..<n}"
   if "n \<le> CARD('a::len word)"
 proof -
   let ?of_nat = "of_nat :: nat \<Rightarrow> 'a word"
   have "inj_on ?of_nat {i. i < CARD('a word)}"
     by (rule inj_onI) (simp add: card_word of_nat_inj)
   moreover have "{0..<n} \<subseteq> {i. i < CARD('a word)}"
     using that by auto
   ultimately have "inj_on ?of_nat {0..<n}"
     by (rule inj_on_subset)
   then show ?thesis
     by (simp add: card_image)
 qed
 
 lemma card_map_elide2:
   "n \<le> CARD('a::len word) \<Longrightarrow> card ((of_nat::nat \<Rightarrow> 'a::len word) ` {0..<n}) = n"
   by (subst card_map_elide) clarsimp+
 
 lemma eq_ucast_ucast_eq:
   "LENGTH('b) \<le> LENGTH('a) \<Longrightarrow> x = ucast y \<Longrightarrow> ucast x = y"
   for x :: "'a::len word" and y :: "'b::len word"
   by transfer simp
 
 lemma le_ucast_ucast_le:
   "x \<le> ucast y \<Longrightarrow> ucast x \<le> y"
   for x :: "'a::len word" and y :: "'b::len word"
   by (smt le_unat_uoi linorder_not_less order_less_imp_le ucast_nat_def unat_arith_simps(1))
 
 lemma less_ucast_ucast_less:
   "LENGTH('b) \<le> LENGTH('a) \<Longrightarrow> x < ucast y \<Longrightarrow> ucast x < y"
   for x :: "'a::len word" and y :: "'b::len word"
   by (metis ucast_nat_def unat_mono unat_ucast_up_simp word_of_nat_less)
 
 lemma ucast_le_ucast:
   "LENGTH('a) \<le> LENGTH('b) \<Longrightarrow> (ucast x \<le> (ucast y::'b::len word)) = (x \<le> y)"
   for x :: "'a::len word"
   by (simp add: unat_arith_simps(1) unat_ucast_up_simp)
 
 lemmas ucast_up_mono_le = ucast_le_ucast[THEN iffD2]
 
 lemma ucast_or_distrib:
   fixes x :: "'a::len word"
   fixes y :: "'a::len word"
   shows "(ucast (x OR y) :: ('b::len) word) = ucast x OR ucast y"
   by (fact unsigned_or_eq)
 
 lemma word_exists_nth:
   "(w::'a::len word) \<noteq> 0 \<Longrightarrow> \<exists>i. bit w i"
   by (simp add: bit_eq_iff)
 
 lemma max_word_not_0 [simp]:
   "- 1 \<noteq> (0 :: 'a::len word)"
   by simp
 
 lemma unat_max_word_pos[simp]: "0 < unat (- 1 :: 'a::len word)"
   using unat_gt_0 [of \<open>- 1 :: 'a::len word\<close>] by simp
 
 
 (* Miscellaneous conditional injectivity rules. *)
 
 lemma mult_pow2_inj:
   assumes ws: "m + n \<le> LENGTH('a)"
   assumes le: "x \<le> mask m" "y \<le> mask m"
   assumes eq: "x * 2 ^ n = y * (2 ^ n::'a::len word)"
   shows "x = y"
 proof (rule bit_word_eqI)
   fix q
   assume \<open>q < LENGTH('a)\<close>
   from eq have \<open>push_bit n x = push_bit n y\<close>
     by (simp add: push_bit_eq_mult)
   moreover from le have \<open>take_bit m x = x\<close> \<open>take_bit m y = y\<close>
     by (simp_all add: less_eq_mask_iff_take_bit_eq_self)
   ultimately have \<open>push_bit n (take_bit m x) = push_bit n (take_bit m y)\<close>
     by simp_all
   with \<open>q < LENGTH('a)\<close> ws show \<open>bit x q \<longleftrightarrow> bit y q\<close>
     apply (simp add: push_bit_take_bit)
     unfolding bit_eq_iff
     apply (simp add: bit_simps not_le)
     apply (metis (full_types) \<open>take_bit m x = x\<close> \<open>take_bit m y = y\<close> add.commute add_diff_cancel_right' add_less_cancel_right bit_take_bit_iff le_add2 less_le_trans)
     done
 qed
 
 lemma word_of_nat_inj:
   assumes bounded: "x < 2 ^ LENGTH('a)" "y < 2 ^ LENGTH('a)"
   assumes of_nats: "of_nat x = (of_nat y :: 'a::len word)"
   shows "x = y"
   by (rule contrapos_pp[OF of_nats]; cases "x < y"; cases "y < x")
      (auto dest: bounded[THEN of_nat_mono_maybe])
 
 lemma word_of_int_bin_cat_eq_iff:
   "(word_of_int (concat_bit LENGTH('b) (uint b) (uint a))::'c::len word) =
   word_of_int (concat_bit LENGTH('b) (uint d) (uint c)) \<longleftrightarrow> b = d \<and> a = c"
   if "LENGTH('a) + LENGTH('b) \<le> LENGTH('c)"
   for a::"'a::len word" and b::"'b::len word"
 proof -
   from that show ?thesis
   using that concat_bit_eq_iff [of \<open>LENGTH('b)\<close> \<open>uint b\<close> \<open>uint a\<close> \<open>uint d\<close> \<open>uint c\<close>]
   apply (simp add: word_of_int_eq_iff take_bit_int_eq_self flip: word_eq_iff_unsigned)
   apply (simp add: concat_bit_def take_bit_int_eq_self bintr_uint take_bit_push_bit)
   done
 qed
 
 lemma word_cat_inj: "(word_cat a b::'c::len word) = word_cat c d \<longleftrightarrow> a = c \<and> b = d"
   if "LENGTH('a) + LENGTH('b) \<le> LENGTH('c)"
   for a::"'a::len word" and b::"'b::len word"
   using word_of_int_bin_cat_eq_iff [OF that, of b a d c]
   by (simp add: word_cat_eq' ac_simps)
 
 lemma p2_eq_1: "2 ^ n = (1::'a::len word) \<longleftrightarrow> n = 0"
 proof -
   have "2 ^ n = (1::'a word) \<Longrightarrow> n = 0"
     by (metis One_nat_def not_less one_less_numeral_iff p2_eq_0 p2_gt_0 power_0 power_0
         power_inject_exp semiring_norm(76) unat_power_lower zero_neq_one)
   then show ?thesis by auto
 qed
 
 end
 
 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,1940 @@
 (*
  * 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 (clarsimp simp add: mask_eq_decr_exp Parity.bit_eq_iff bit_and_iff bit_not_iff bit_push_bit_iff)
+  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)
 
 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