diff --git a/thys/Stone_Algebras/Filters.thy b/thys/Stone_Algebras/Filters.thy
--- a/thys/Stone_Algebras/Filters.thy
+++ b/thys/Stone_Algebras/Filters.thy
@@ -1,911 +1,943 @@
 (* Title:      Filters
    Author:     Walter Guttmann
    Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
 *)
 
 section \<open>Filters\<close>
 
 text \<open>
 This theory develops filters based on orders, semilattices, lattices and distributive lattices.
 We prove the ultrafilter lemma for orders with a least element.
 We show the following structure theorems:
 \begin{itemize}
 \item The set of filters over a directed semilattice forms a lattice with a greatest element.
 \item The set of filters over a bounded semilattice forms a bounded lattice.
 \item The set of filters over a distributive lattice with a greatest element forms a bounded distributive lattice.
 \end{itemize}
 Another result is that in a distributive lattice ultrafilters are prime filters.
 We also prove a lemma of Gr\"atzer and Schmidt about principal filters.
 
 We apply these results in proving the construction theorem for Stone algebras (described in a separate theory).
 See, for example, \cite{BalbesDwinger1974,Birkhoff1967,Blyth2005,DaveyPriestley2002,Graetzer1971} for further results about filters.
 \<close>
 
 theory Filters
 
 imports Lattice_Basics
 
 begin
 
 subsection \<open>Orders\<close>
 
 text \<open>
 This section gives the basic definitions related to filters in terms of orders.
 The main result is the ultrafilter lemma.
 \<close>
 
 context ord
 begin
 
 abbreviation down :: "'a \<Rightarrow> 'a set" ("\<down>_" [81] 80)
   where "\<down>x \<equiv> { y . y \<le> x }"
 
 abbreviation down_set :: "'a set \<Rightarrow> 'a set" ("\<Down>_" [81] 80)
   where "\<Down>X \<equiv> { y . \<exists>x\<in>X . y \<le> x }"
 
 abbreviation is_down_set :: "'a set \<Rightarrow> bool"
   where "is_down_set X \<equiv> \<forall>x\<in>X . \<forall>y . y \<le> x \<longrightarrow> y\<in>X"
 
 abbreviation is_principal_down :: "'a set \<Rightarrow> bool"
   where "is_principal_down X \<equiv> \<exists>x . X = \<down>x"
 
 abbreviation up :: "'a \<Rightarrow> 'a set" ("\<up>_" [81] 80)
   where "\<up>x \<equiv> { y . x \<le> y }"
 
 abbreviation up_set :: "'a set \<Rightarrow> 'a set" ("\<Up>_" [81] 80)
   where "\<Up>X \<equiv> { y . \<exists>x\<in>X . x \<le> y }"
 
 abbreviation is_up_set :: "'a set \<Rightarrow> bool"
   where "is_up_set X \<equiv> \<forall>x\<in>X . \<forall>y . x \<le> y \<longrightarrow> y\<in>X"
 
 abbreviation is_principal_up :: "'a set \<Rightarrow> bool"
   where "is_principal_up X \<equiv> \<exists>x . X = \<up>x"
 
 text \<open>
 A filter is a non-empty, downward directed, up-closed set.
 \<close>
 
 definition filter :: "'a set \<Rightarrow> bool"
   where "filter F \<equiv> (F \<noteq> {}) \<and> (\<forall>x\<in>F . \<forall>y\<in>F . \<exists>z\<in>F . z \<le> x \<and> z \<le> y) \<and> is_up_set F"
 
 abbreviation proper_filter :: "'a set \<Rightarrow> bool"
   where "proper_filter F \<equiv> filter F \<and> F \<noteq> UNIV"
 
 abbreviation ultra_filter :: "'a set \<Rightarrow> bool"
   where "ultra_filter F \<equiv> proper_filter F \<and> (\<forall>G . proper_filter G \<and> F \<subseteq> G \<longrightarrow> F = G)"
 
+abbreviation filters :: "'a set set"
+  where "filters \<equiv> { F::'a set . filter F }"
+
+lemma filter_map_filter:
+  assumes "filter F"
+      and "mono f"
+      and "\<forall>x y . f x \<le> y \<longrightarrow> (\<exists>z . x \<le> z \<and> y = f z)"
+    shows "filter (f ` F)"
+proof (unfold ord_class.filter_def, intro conjI)
+  show "f ` F \<noteq> {}"
+    using assms(1) ord_class.filter_def by auto
+next
+  show "\<forall>x\<in>f ` F . \<forall>y\<in>f ` F . \<exists>z\<in>f ` F . z \<le> x \<and> z \<le> y"
+  proof (intro ballI)
+    fix x y
+    assume "x \<in> f ` F" and "y \<in> f ` F"
+    then obtain u v where 1: "x = f u \<and> u \<in> F \<and> y = f v \<and> v \<in> F"
+      by auto
+    then obtain w where "w \<le> u \<and> w \<le> v \<and> w \<in> F"
+      by (meson assms(1) ord_class.filter_def)
+    thus "\<exists>z\<in>f ` F . z \<le> x \<and> z \<le> y"
+      using 1 assms(2) mono_def image_eqI by blast
+  qed
+next
+  show "is_up_set (f ` F)"
+  proof
+    fix x
+    assume "x \<in> f ` F"
+    then obtain u where 1: "x = f u \<and> u \<in> F"
+      by auto
+    show "\<forall>y . x \<le> y \<longrightarrow> y \<in> f ` F"
+    proof (rule allI, rule impI)
+      fix y
+      assume "x \<le> y"
+      hence "f u \<le> y"
+        using 1 by simp
+      then obtain z where "u \<le> z \<and> y = f z"
+        using assms(3) by auto
+      thus "y \<in> f ` F"
+        by (meson 1 assms(1) image_iff ord_class.filter_def)
+    qed
+  qed
+qed
+
 end
 
 context order
 begin
 
 lemma self_in_downset [simp]:
   "x \<in> \<down>x"
   by simp
 
 lemma self_in_upset [simp]:
   "x \<in> \<up>x"
   by simp
 
 lemma up_filter [simp]:
   "filter (\<up>x)"
   using filter_def order_lesseq_imp by auto
 
 lemma up_set_up_set [simp]:
   "is_up_set (\<Up>X)"
   using order.trans by fastforce
 
 lemma up_injective:
   "\<up>x = \<up>y \<Longrightarrow> x = y"
   using antisym by auto
 
 lemma up_antitone:
   "x \<le> y \<longleftrightarrow> \<up>y \<subseteq> \<up>x"
   by auto
 
 end
 
 context order_bot
 begin
 
 lemma bot_in_downset [simp]:
   "bot \<in> \<down>x"
   by simp
 
 lemma down_bot [simp]:
   "\<down>bot = {bot}"
   by (simp add: bot_unique)
 
 lemma up_bot [simp]:
   "\<up>bot = UNIV"
   by simp
 
 text \<open>
 The following result is the ultrafilter lemma, generalised from \cite[10.17]{DaveyPriestley2002} to orders with a least element.
 Its proof uses Isabelle/HOL's \<open>Zorn_Lemma\<close>, which requires closure under union of arbitrary (possibly empty) chains.
 Actually, the proof does not use any of the underlying order properties except \<open>bot_least\<close>.
 \<close>
 
 lemma ultra_filter:
   assumes "proper_filter F"
     shows "\<exists>G . ultra_filter G \<and> F \<subseteq> G"
 proof -
   let ?A = "{ G . (proper_filter G \<and> F \<subseteq> G) \<or> G = {} }"
   have "\<forall>C \<in> chains ?A . \<Union>C \<in> ?A"
   proof
     fix C :: "'a set set"
     let ?D = "C - {{}}"
     assume 1: "C \<in> chains ?A"
     hence 2: "\<forall>x\<in>\<Union>?D . \<exists>H\<in>?D . x \<in> H \<and> proper_filter H"
       using chainsD2 by fastforce
     have 3: "\<Union>?D = \<Union>C"
       by blast
     have "\<Union>?D \<in> ?A"
     proof (cases "?D = {}")
       assume "?D = {}"
       thus ?thesis
         by auto
     next
       assume 4: "?D \<noteq> {}"
       then obtain G where "G \<in> ?D"
         by auto
       hence 5: "F \<subseteq> \<Union>?D"
         using 1 chainsD2 by blast
       have 6: "is_up_set (\<Union>?D)"
       proof
         fix x
         assume "x \<in> \<Union>?D"
         then obtain H where "x \<in> H \<and> H \<in> ?D \<and> filter H"
           using 2 by auto
         thus "\<forall>y . x \<le> y \<longrightarrow> y\<in>\<Union>?D"
           using filter_def UnionI by fastforce
       qed
       have 7: "\<Union>?D \<noteq> UNIV"
       proof (rule ccontr)
         assume "\<not> \<Union>?D \<noteq> UNIV"
         then obtain H where "bot \<in> H \<and> proper_filter H"
           using 2 by blast
         thus False
           by (meson UNIV_I bot_least filter_def subsetI subset_antisym)
       qed
       {
         fix x y
         assume "x\<in>\<Union>?D \<and> y\<in>\<Union>?D"
         then obtain H I where 8: "x \<in> H \<and> H \<in> ?D \<and> filter H \<and> y \<in> I \<and> I \<in> ?D \<and> filter I"
           using 2 by metis
         have "\<exists>z\<in>\<Union>?D . z \<le> x \<and> z \<le> y"
         proof (cases "H \<subseteq> I")
           assume "H \<subseteq> I"
           hence "\<exists>z\<in>I . z \<le> x \<and> z \<le> y"
             using 8 by (metis subsetCE filter_def)
           thus ?thesis
             using 8 by (metis UnionI)
         next
           assume "\<not> (H \<subseteq> I)"
           hence "I \<subseteq> H"
             using 1 8 by (meson DiffE chainsD)
           hence "\<exists>z\<in>H . z \<le> x \<and> z \<le> y"
             using 8 by (metis subsetCE filter_def)
           thus ?thesis
             using 8 by (metis UnionI)
         qed
       }
       thus ?thesis
         using 4 5 6 7 filter_def by auto
     qed
     thus "\<Union>C \<in> ?A"
       using 3 by simp
   qed
   hence "\<exists>M\<in>?A . \<forall>X\<in>?A . M \<subseteq> X \<longrightarrow> X = M"
     by (rule Zorn_Lemma)
   then obtain M where 9: "M \<in> ?A \<and> (\<forall>X\<in>?A . M \<subseteq> X \<longrightarrow> X = M)"
     by auto
   hence 10: "M \<noteq> {}"
     using assms filter_def by auto
   {
     fix G
     assume 11: "proper_filter G \<and> M \<subseteq> G"
     hence "F \<subseteq> G"
       using 9 10 by blast
     hence "M = G"
       using 9 11 by auto
   }
   thus ?thesis
     using 9 10 by blast
 qed
 
 end
 
 context order_top
 begin
 
 lemma down_top [simp]:
   "\<down>top = UNIV"
   by simp
 
 lemma top_in_upset [simp]:
   "top \<in> \<up>x"
   by simp
 
 lemma up_top [simp]:
   "\<up>top = {top}"
   by (simp add: top_unique)
 
 lemma filter_top [simp]:
   "filter {top}"
   using filter_def top_unique by auto
 
 lemma top_in_filter [simp]:
   "filter F \<Longrightarrow> top \<in> F"
   using filter_def by fastforce
 
 end
 
 text \<open>
 The existence of proper filters and ultrafilters requires that the underlying order contains at least two elements.
 \<close>
 
 context non_trivial_order
 begin
 
 lemma proper_filter_exists:
   "\<exists>F . proper_filter F"
 proof -
   from consistent obtain x y :: 'a where "x \<noteq> y"
     by auto
   hence "\<up>x \<noteq> UNIV \<or> \<up>y \<noteq> UNIV"
     using antisym by blast
   hence "proper_filter (\<up>x) \<or> proper_filter (\<up>y)"
     by simp
   thus ?thesis
     by blast
 qed
 
 end
 
 context non_trivial_order_bot
 begin
 
 lemma ultra_filter_exists:
   "\<exists>F . ultra_filter F"
   using ultra_filter proper_filter_exists by blast
 
 end
 
 context non_trivial_bounded_order
 begin
 
 lemma proper_filter_top:
   "proper_filter {top}"
   using bot_not_top filter_top by blast
 
 lemma ultra_filter_top:
   "\<exists>G . ultra_filter G \<and> top \<in> G"
   using ultra_filter proper_filter_top by fastforce
 
 end
 
 subsection \<open>Lattices\<close>
 
 text \<open>
 This section develops the lattice structure of filters based on a semilattice structure of the underlying order.
 The main results are that filters over a directed semilattice form a lattice with a greatest element and that filters over a bounded semilattice form a bounded lattice.
 \<close>
 
 context semilattice_sup
 begin
 
 abbreviation prime_filter :: "'a set \<Rightarrow> bool"
   where "prime_filter F \<equiv> proper_filter F \<and> (\<forall>x y . x \<squnion> y \<in> F \<longrightarrow> x \<in> F \<or> y \<in> F)"
 
 end
 
 context semilattice_inf
 begin
 
 lemma filter_inf_closed:
   "filter F \<Longrightarrow> x \<in> F \<Longrightarrow> y \<in> F \<Longrightarrow> x \<sqinter> y \<in> F"
   by (meson filter_def inf.boundedI)
 
 lemma filter_univ:
   "filter UNIV"
   by (meson UNIV_I UNIV_not_empty filter_def inf.cobounded1 inf.cobounded2)
 
 text \<open>
 The operation \<open>filter_sup\<close> is the join operation in the lattice of filters.
 \<close>
 
-abbreviation "filter_sup F G \<equiv> { z . \<exists>x\<in>F . \<exists>y\<in>G . x \<sqinter> y \<le> z }"
+definition "filter_sup F G \<equiv> { z . \<exists>x\<in>F . \<exists>y\<in>G . x \<sqinter> y \<le> z }"
 
 lemma filter_sup:
   assumes "filter F"
       and "filter G"
     shows "filter (filter_sup F G)"
 proof -
   have "F \<noteq> {} \<and> G \<noteq> {}"
     using assms filter_def by blast
   hence 1: "filter_sup F G \<noteq> {}"
-    by blast
+    using filter_sup_def by blast
   have 2: "\<forall>x\<in>filter_sup F G . \<forall>y\<in>filter_sup F G . \<exists>z\<in>filter_sup F G . z \<le> x \<and> z \<le> y"
   proof
     fix x
     assume "x\<in>filter_sup F G"
     then obtain t u where 3: "t \<in> F \<and> u \<in> G \<and> t \<sqinter> u \<le> x"
-      by auto
+      using filter_sup_def by auto
     show "\<forall>y\<in>filter_sup F G . \<exists>z\<in>filter_sup F G . z \<le> x \<and> z \<le> y"
     proof
       fix y
       assume "y\<in>filter_sup F G"
       then obtain v w where 4: "v \<in> F \<and> w \<in> G \<and> v \<sqinter> w \<le> y"
-        by auto
+        using filter_sup_def by auto
       let ?z = "(t \<sqinter> v) \<sqinter> (u \<sqinter> w)"
       have 5: "?z \<le> x \<and> ?z \<le> y"
         using 3 4 by (meson order.trans inf.cobounded1 inf.cobounded2 inf_mono)
       have "?z \<in> filter_sup F G"
-        using assms 3 4 filter_inf_closed by blast
+        unfolding filter_sup_def using assms 3 4 filter_inf_closed by blast
       thus "\<exists>z\<in>filter_sup F G . z \<le> x \<and> z \<le> y"
         using 5 by blast
     qed
   qed
   have "\<forall>x\<in>filter_sup F G . \<forall>y . x \<le> y \<longrightarrow> y \<in> filter_sup F G"
-    using order_trans by blast
+    unfolding filter_sup_def using order_trans by blast
   thus ?thesis
     using 1 2 filter_def by presburger
 qed
 
 lemma filter_sup_left_upper_bound:
   assumes "filter G"
     shows "F \<subseteq> filter_sup F G"
 proof -
   from assms obtain y where "y\<in>G"
     using all_not_in_conv filter_def by auto
   thus ?thesis
-    using inf.cobounded1 by blast
+    unfolding filter_sup_def using inf.cobounded1 by blast
 qed
 
 lemma filter_sup_symmetric:
   "filter_sup F G = filter_sup G F"
-  using inf.commute by fastforce
+  unfolding filter_sup_def using inf.commute by fastforce
 
 lemma filter_sup_right_upper_bound:
   "filter F \<Longrightarrow> G \<subseteq> filter_sup F G"
   using filter_sup_symmetric filter_sup_left_upper_bound by simp
 
 lemma filter_sup_least_upper_bound:
   assumes "filter H"
       and "F \<subseteq> H"
       and "G \<subseteq> H"
     shows "filter_sup F G \<subseteq> H"
 proof
   fix x
   assume "x \<in> filter_sup F G"
   then obtain y z where 1: "y \<in> F \<and> z \<in> G \<and> y \<sqinter> z \<le> x"
-    by auto
+    using filter_sup_def by auto
   hence "y \<in> H \<and> z \<in> H"
     using assms(2-3) by auto
   hence "y \<sqinter> z \<in> H"
     by (simp add: assms(1) filter_inf_closed)
   thus "x \<in> H"
     using 1 assms(1) filter_def by auto
 qed
 
 lemma filter_sup_left_isotone:
   "G \<subseteq> H \<Longrightarrow> filter_sup G F \<subseteq> filter_sup H F"
-  by blast
+  unfolding filter_sup_def by blast
 
 lemma filter_sup_right_isotone:
   "G \<subseteq> H \<Longrightarrow> filter_sup F G \<subseteq> filter_sup F H"
-  by blast
+  unfolding filter_sup_def by blast
 
 lemma filter_sup_right_isotone_var:
   "filter_sup F (G \<inter> H) \<subseteq> filter_sup F H"
-  by blast
+  unfolding filter_sup_def by blast
 
 lemma up_dist_inf:
   "\<up>(x \<sqinter> y) = filter_sup (\<up>x) (\<up>y)"
 proof
   show "\<up>(x \<sqinter> y) \<subseteq> filter_sup (\<up>x) (\<up>y)"
-    by blast
+    unfolding filter_sup_def by blast
 next
   show "filter_sup (\<up>x) (\<up>y) \<subseteq> \<up>(x \<sqinter> y)"
   proof
     fix z
     assume "z \<in> filter_sup (\<up>x) (\<up>y)"
     then obtain u v where "u\<in>\<up>x \<and> v\<in>\<up>y \<and> u \<sqinter> v \<le> z"
-      by auto
+      using filter_sup_def by auto
     hence "x \<sqinter> y \<le> z"
       using order.trans inf_mono by blast
     thus "z \<in> \<up>(x \<sqinter> y)"
       by blast
   qed
 qed
 
 text \<open>
 The following result is part of \cite[Exercise 2.23]{DaveyPriestley2002}.
 \<close>
 
 lemma filter_inf_filter [simp]:
   assumes "filter F"
     shows "filter (\<Up>{ y . \<exists>z\<in>F . x \<sqinter> z = y})"
 proof -
   let ?G = "\<Up>{ y . \<exists>z\<in>F . x \<sqinter> z = y}"
   have "F \<noteq> {}"
     using assms filter_def by simp
   hence 1: "?G \<noteq> {}"
     by blast
   have 2: "is_up_set ?G"
     by auto
   {
     fix y z
     assume "y \<in> ?G \<and> z \<in> ?G"
     then obtain v w where "v \<in> F \<and> w \<in> F \<and> x \<sqinter> v \<le> y \<and> x \<sqinter> w \<le> z"
       by auto
     hence "v \<sqinter> w \<in> F \<and> x \<sqinter> (v \<sqinter> w) \<le> y \<sqinter> z"
       by (meson assms filter_inf_closed order.trans inf.boundedI inf.cobounded1 inf.cobounded2)
     hence "\<exists>u\<in>?G . u \<le> y \<and> u \<le> z"
       by auto
   }
   hence "\<forall>x\<in>?G . \<forall>y\<in>?G . \<exists>z\<in>?G . z \<le> x \<and> z \<le> y"
     by auto
   thus ?thesis
     using 1 2 filter_def by presburger
 qed
 
 end
 
 context directed_semilattice_inf
 begin
 
 text \<open>
 Set intersection is the meet operation in the lattice of filters.
 \<close>
 
 lemma filter_inf:
   assumes "filter F"
       and "filter G"
     shows "filter (F \<inter> G)"
 proof (unfold filter_def, intro conjI)
   from assms obtain x y where 1: "x\<in>F \<and> y\<in>G"
     using all_not_in_conv filter_def by auto
   from ub obtain z where "x \<le> z \<and> y \<le> z"
     by auto
   hence "z \<in> F \<inter> G"
     using 1 by (meson assms Int_iff filter_def)
   thus "F \<inter> G \<noteq> {}"
     by blast
 next
   show "is_up_set (F \<inter> G)"
     by (meson assms Int_iff filter_def)
 next
   show "\<forall>x\<in>F \<inter> G . \<forall>y\<in>F \<inter> G . \<exists>z\<in>F \<inter> G . z \<le> x \<and> z \<le> y"
     by (metis assms Int_iff filter_inf_closed inf.cobounded2 inf.commute)
 qed
 
 end
 
 text \<open>
 We introduce the following type of filters to instantiate the lattice classes and thereby inherit the results shown about lattices.
 \<close>
 
 typedef (overloaded) 'a filter = "{ F::'a::order set . filter F }"
   by (meson mem_Collect_eq up_filter)
 
 lemma simp_filter [simp]:
   "filter (Rep_filter x)"
   using Rep_filter by simp
 
 setup_lifting type_definition_filter
 
 text \<open>
 The set of filters over a directed semilattice forms a lattice with a greatest element.
 \<close>
 
 instantiation filter :: (directed_semilattice_inf) bounded_lattice_top
 begin
 
 lift_definition top_filter :: "'a filter" is UNIV
   by (simp add: filter_univ)
 
 lift_definition sup_filter :: "'a filter \<Rightarrow> 'a filter \<Rightarrow> 'a filter" is filter_sup
   by (simp add: filter_sup)
 
 lift_definition inf_filter :: "'a filter \<Rightarrow> 'a filter \<Rightarrow> 'a filter" is inter
   by (simp add: filter_inf)
 
 lift_definition less_eq_filter :: "'a filter \<Rightarrow> 'a filter \<Rightarrow> bool" is subset_eq .
 
 lift_definition less_filter :: "'a filter \<Rightarrow> 'a filter \<Rightarrow> bool" is subset .
 
 instance
   apply intro_classes
-  apply (simp add: less_eq_filter.rep_eq less_filter.rep_eq inf.less_le_not_le)
-  apply (simp add: less_eq_filter.rep_eq)
-  apply (simp add: less_eq_filter.rep_eq)
-  apply (simp add: Rep_filter_inject less_eq_filter.rep_eq)
-  apply (simp add: inf_filter.rep_eq less_eq_filter.rep_eq)
-  apply (simp add: inf_filter.rep_eq less_eq_filter.rep_eq)
-  apply (simp add: inf_filter.rep_eq less_eq_filter.rep_eq)
-  apply (simp add: less_eq_filter.rep_eq filter_sup_left_upper_bound sup_filter.rep_eq)
-  apply (simp add: less_eq_filter.rep_eq filter_sup_right_upper_bound sup_filter.rep_eq)
-  apply (simp add: less_eq_filter.rep_eq filter_sup_least_upper_bound sup_filter.rep_eq)
-  by (simp add: less_eq_filter.rep_eq top_filter.rep_eq)
+  subgoal apply transfer by (simp add: less_le_not_le)
+  subgoal apply transfer by simp
+  subgoal apply transfer by simp
+  subgoal apply transfer by simp
+  subgoal apply transfer by simp
+  subgoal apply transfer by simp
+  subgoal apply transfer by simp
+  subgoal apply transfer by (simp add: filter_sup_left_upper_bound)
+  subgoal apply transfer by (simp add: filter_sup_right_upper_bound)
+  subgoal apply transfer by (simp add: filter_sup_least_upper_bound)
+  subgoal apply transfer by simp
+  done
 
 end
 
 context bounded_semilattice_inf_top
 begin
 
 abbreviation "filter_complements F G \<equiv> filter F \<and> filter G \<and> filter_sup F G = UNIV \<and> F \<inter> G = {top}"
 
 end
 
 text \<open>
 The set of filters over a bounded semilattice forms a bounded lattice.
 \<close>
 
 instantiation filter :: (bounded_semilattice_inf_top) bounded_lattice
 begin
 
 lift_definition bot_filter :: "'a filter" is "{top}"
   by simp
 
 instance
-  by intro_classes (simp add: less_eq_filter.rep_eq bot_filter.rep_eq)
+  apply intro_classes
+  apply transfer
+  by simp
 
 end
 
 context lattice
 begin
 
 lemma up_dist_sup:
   "\<up>(x \<squnion> y) = \<up>x \<inter> \<up>y"
   by auto
 
 end
 
 text \<open>
 For convenience, the following function injects principal filters into the filter type.
 We cannot define it in the \<open>order\<close> class since the type filter requires the sort constraint \<open>order\<close> that is not available in the class.
 The result of the function is a filter by lemma \<open>up_filter\<close>.
 \<close>
 
 abbreviation up_filter :: "'a::order \<Rightarrow> 'a filter"
   where "up_filter x \<equiv> Abs_filter (\<up>x)"
 
 lemma up_filter_dist_inf:
   "up_filter ((x::'a::lattice) \<sqinter> y) = up_filter x \<squnion> up_filter y"
   by (simp add: eq_onp_def sup_filter.abs_eq up_dist_inf)
 
 lemma up_filter_dist_sup:
   "up_filter ((x::'a::lattice) \<squnion> y) = up_filter x \<sqinter> up_filter y"
   by (metis eq_onp_def inf_filter.abs_eq up_dist_sup up_filter)
 
 lemma up_filter_injective:
   "up_filter x = up_filter y \<Longrightarrow> x = y"
   by (metis Abs_filter_inject mem_Collect_eq up_filter up_injective)
 
 lemma up_filter_antitone:
   "x \<le> y \<longleftrightarrow> up_filter y \<le> up_filter x"
   by (metis eq_onp_same_args less_eq_filter.abs_eq up_antitone up_filter)
 
 text \<open>
 The following definition applies a function to each element of a filter.
 The subsequent lemma gives conditions under which the result of this application is a filter.
 \<close>
 
 abbreviation filter_map :: "('a::order \<Rightarrow> 'b::order) \<Rightarrow> 'a filter \<Rightarrow> 'b filter"
   where "filter_map f F \<equiv> Abs_filter (f ` Rep_filter F)"
 
 lemma filter_map_filter:
   assumes "mono f"
       and "\<forall>x y . f x \<le> y \<longrightarrow> (\<exists>z . x \<le> z \<and> y = f z)"
     shows "filter (f ` Rep_filter F)"
-proof (unfold filter_def, intro conjI)
-  show "f ` Rep_filter F \<noteq> {}"
-    by (metis empty_is_image filter_def simp_filter)
-next
-  show "\<forall>x\<in>f ` Rep_filter F . \<forall>y\<in>f ` Rep_filter F . \<exists>z\<in>f ` Rep_filter F . z \<le> x \<and> z \<le> y"
-  proof (intro ballI)
-    fix x y
-    assume "x \<in> f ` Rep_filter F" and "y \<in> f ` Rep_filter F"
-    then obtain u v where 1: "x = f u \<and> u \<in> Rep_filter F \<and> y = f v \<and> v \<in> Rep_filter F"
-      by auto
-    then obtain w where "w \<le> u \<and> w \<le> v \<and> w \<in> Rep_filter F"
-      by (meson filter_def simp_filter)
-    thus "\<exists>z\<in>f ` Rep_filter F . z \<le> x \<and> z \<le> y"
-      using 1 assms(1) mono_def rev_image_eqI by blast
-  qed
-next
-  show "is_up_set (f ` Rep_filter F)"
-  proof
-    fix x
-    assume "x \<in> f ` Rep_filter F"
-    then obtain u where 1: "x = f u \<and> u \<in> Rep_filter F"
-      by auto
-    show "\<forall>y . x \<le> y \<longrightarrow> y \<in> f ` Rep_filter F"
-    proof (rule allI, rule impI)
-      fix y
-      assume "x \<le> y"
-      hence "f u \<le> y"
-        using 1 by simp
-      then obtain z where "u \<le> z \<and> y = f z"
-        using assms(2) by auto
-      thus "y \<in> f ` Rep_filter F"
-        using 1 by (meson image_iff filter_def simp_filter)
-    qed
-  qed
-qed
+  by (simp add: assms inf.filter_map_filter)
 
 subsection \<open>Distributive Lattices\<close>
 
 text \<open>
 In this section we additionally assume that the underlying order forms a distributive lattice.
 Then filters form a bounded distributive lattice if the underlying order has a greatest element.
 Moreover ultrafilters are prime filters.
 We also prove a lemma of Gr\"atzer and Schmidt about principal filters.
 \<close>
 
 context distrib_lattice
 begin
 
 lemma filter_sup_left_dist_inf:
   assumes "filter F"
       and "filter G"
       and "filter H"
     shows "filter_sup F (G \<inter> H) = filter_sup F G \<inter> filter_sup F H"
 proof
   show "filter_sup F (G \<inter> H) \<subseteq> filter_sup F G \<inter> filter_sup F H"
-    using filter_sup_right_isotone_var by blast
+    unfolding filter_sup_def using filter_sup_right_isotone_var by blast
 next
   show "filter_sup F G \<inter> filter_sup F H \<subseteq> filter_sup F (G \<inter> H)"
   proof
     fix x
     assume "x \<in> filter_sup F G \<inter> filter_sup F H"
     then obtain t u v w where 1: "t \<in> F \<and> u \<in> G \<and> v \<in> F \<and> w \<in> H \<and> t \<sqinter> u \<le> x \<and> v \<sqinter> w \<le> x"
-      by auto
+      using filter_sup_def by auto
     let ?y = "t \<sqinter> v"
     let ?z = "u \<squnion> w"
     have 2: "?y \<in> F"
       using 1 by (simp add: assms(1) filter_inf_closed)
     have 3: "?z \<in> G \<inter> H"
       using 1 by (meson assms(2-3) Int_iff filter_def sup_ge1 sup_ge2)
     have "?y \<sqinter> ?z = (t \<sqinter> v \<sqinter> u) \<squnion> (t \<sqinter> v \<sqinter> w)"
       by (simp add: inf_sup_distrib1)
     also have "... \<le> (t \<sqinter> u) \<squnion> (v \<sqinter> w)"
       by (metis inf.cobounded1 inf.cobounded2 inf.left_idem inf_mono sup.mono)
     also have "... \<le> x"
       using 1 by (simp add: le_supI)
     finally show "x \<in> filter_sup F (G \<inter> H)"
-      using 2 3 by blast
+      unfolding filter_sup_def using 2 3 by blast
   qed
 qed
 
 lemma filter_inf_principal_rep:
   "F \<inter> G = \<up>z \<Longrightarrow> (\<exists>x\<in>F . \<exists>y\<in>G . z = x \<squnion> y)"
   by force
 
 lemma filter_sup_principal_rep:
   assumes "filter F"
       and "filter G"
       and "filter_sup F G = \<up>z"
     shows "\<exists>x\<in>F . \<exists>y\<in>G . z = x \<sqinter> y"
 proof -
   from assms(3) obtain x y where 1: "x\<in>F \<and> y\<in>G \<and> x \<sqinter> y \<le> z"
-    using order_refl by blast
+    unfolding filter_sup_def using order_refl by blast
   hence 2: "x \<squnion> z \<in> F \<and> y \<squnion> z \<in> G"
     by (meson assms(1-2) sup_ge1 filter_def)
   have "(x \<squnion> z) \<sqinter> (y \<squnion> z) = z"
     using 1 sup_absorb2 sup_inf_distrib2 by fastforce
   thus ?thesis
     using 2 by force
 qed
 
 lemma inf_sup_principal_aux:
   assumes "filter F"
       and "filter G"
       and "is_principal_up (filter_sup F G)"
       and "is_principal_up (F \<inter> G)"
     shows "is_principal_up F"
 proof -
   from assms(3-4) obtain x y where 1: "filter_sup F G = \<up>x \<and> F \<inter> G = \<up>y"
     by blast
   from filter_inf_principal_rep obtain t u where 2: "t\<in>F \<and> u\<in>G \<and> y = t \<squnion> u"
     using 1 by meson
   from filter_sup_principal_rep obtain v w where 3: "v\<in>F \<and> w\<in>G \<and> x = v \<sqinter> w"
     using 1 by (meson assms(1-2))
   have "t \<in> filter_sup F G \<and> u \<in> filter_sup F G"
-    using 2 inf.cobounded1 inf.cobounded2 by blast
+    unfolding filter_sup_def using 2 inf.cobounded1 inf.cobounded2 by blast
   hence "x \<le> t \<and> x \<le> u"
     using 1 by blast
   hence 4: "(t \<sqinter> v) \<sqinter> (u \<sqinter> w) = x"
     using 3 by (simp add: inf.absorb2 inf.assoc inf.left_commute)
   have "(t \<sqinter> v) \<squnion> (u \<sqinter> w) \<in> F \<and> (t \<sqinter> v) \<squnion> (u \<sqinter> w) \<in> G"
     using 2 3 by (metis (no_types, lifting) assms(1-2) filter_inf_closed sup.cobounded1 sup.cobounded2 filter_def)
   hence "y \<le> (t \<sqinter> v) \<squnion> (u \<sqinter> w)"
     using 1 Int_iff by blast
   hence 5: "(t \<sqinter> v) \<squnion> (u \<sqinter> w) = y"
     using 2 by (simp add: antisym inf.coboundedI1)
   have "F = \<up>(t \<sqinter> v)"
   proof
     show "F \<subseteq> \<up>(t \<sqinter> v)"
     proof
       fix z
       assume 6: "z \<in> F"
       hence "z \<in> filter_sup F G"
-        using 2 inf.cobounded1 by blast
+        unfolding filter_sup_def using 2 inf.cobounded1 by blast
       hence "x \<le> z"
         using 1 by simp
       hence 7: "(t \<sqinter> v \<sqinter> z) \<sqinter> (u \<sqinter> w) = x"
         using 4 by (metis inf.absorb1 inf.assoc inf.commute)
       have "z \<squnion> u \<in> F \<and> z \<squnion> u \<in> G \<and> z \<squnion> w \<in> F \<and> z \<squnion> w \<in> G"
         using 2 3 6 by (meson assms(1-2) filter_def sup_ge1 sup_ge2)
       hence "y \<le> (z \<squnion> u) \<sqinter> (z \<squnion> w)"
         using 1 Int_iff filter_inf_closed by auto
       hence 8: "(t \<sqinter> v \<sqinter> z) \<squnion> (u \<sqinter> w) = y"
         using 5 by (metis inf.absorb1 sup.commute sup_inf_distrib2)
       have "t \<sqinter> v \<sqinter> z = t \<sqinter> v"
         using 4 5 7 8 relative_equality by blast
       thus "z \<in> \<up>(t \<sqinter> v)"
         by (simp add: inf.orderI)
     qed
   next
     show "\<up>(t \<sqinter> v) \<subseteq> F"
     proof
       fix z
       have 9: "t \<sqinter> v \<in> F"
         using 2 3 by (simp add: assms(1) filter_inf_closed)
       assume "z \<in> \<up>(t \<sqinter> v)"
       hence "t \<sqinter> v \<le> z" by simp
       thus "z \<in> F"
         using assms(1) 9 filter_def by auto
     qed
   qed
   thus ?thesis
     by blast
 qed
 
 text \<open>
 The following result is \cite[Lemma II]{GraetzerSchmidt1958}.
 If both join and meet of two filters are principal filters, both filters are principal filters.
 \<close>
 
 lemma inf_sup_principal:
   assumes "filter F"
       and "filter G"
       and "is_principal_up (filter_sup F G)"
       and "is_principal_up (F \<inter> G)"
     shows "is_principal_up F \<and> is_principal_up G"
 proof -
   have "filter G \<and> filter F \<and> is_principal_up (filter_sup G F) \<and> is_principal_up (G \<inter> F)"
     by (simp add: assms Int_commute filter_sup_symmetric)
   thus ?thesis
     using assms(3) inf_sup_principal_aux by blast
 qed
 
 lemma filter_sup_absorb_inf: "filter F \<Longrightarrow> filter G \<Longrightarrow> filter_sup (F \<inter> G) G = G"
   by (simp add: filter_inf filter_sup_least_upper_bound filter_sup_left_upper_bound filter_sup_symmetric subset_antisym)
 
 lemma filter_inf_absorb_sup: "filter F \<Longrightarrow> filter G \<Longrightarrow> filter_sup F G \<inter> G = G"
   apply (rule subset_antisym)
   apply simp
   by (simp add: filter_sup_right_upper_bound)
 
 lemma filter_inf_right_dist_sup:
   assumes "filter F"
       and "filter G"
       and "filter H"
     shows "filter_sup F G \<inter> H = filter_sup (F \<inter> H) (G \<inter> H)"
 proof -
   have "filter_sup (F \<inter> H) (G \<inter> H) = filter_sup (F \<inter> H) G \<inter> filter_sup (F \<inter> H) H"
     by (simp add: assms filter_sup_left_dist_inf filter_inf)
   also have "... = filter_sup (F \<inter> H) G \<inter> H"
     using assms(1,3) filter_sup_absorb_inf by simp
   also have "... = filter_sup F G \<inter> filter_sup G H \<inter> H"
     using assms filter_sup_left_dist_inf filter_sup_symmetric by simp
   also have "... = filter_sup F G \<inter> H"
     by (simp add: assms(2-3) filter_inf_absorb_sup semilattice_inf_class.inf_assoc)
   finally show ?thesis
     by simp
 qed
 
 text \<open>
 The following result generalises \cite[10.11]{DaveyPriestley2002} to distributive lattices as remarked after that section.
 \<close>
 
 lemma ultra_filter_prime:
   assumes "ultra_filter F"
     shows "prime_filter F"
 proof -
   {
     fix x y
     assume 1: "x \<squnion> y \<in> F \<and> x \<notin> F"
     let ?G = "\<Up>{ z . \<exists>w\<in>F . x \<sqinter> w = z }"
     have 2: "filter ?G"
       using assms filter_inf_filter by simp
     have "x \<in> ?G"
       using 1 by auto
     hence 3: "F \<noteq> ?G"
       using 1 by auto
     have "F \<subseteq> ?G"
       using inf_le2 order_trans by blast
     hence "?G = UNIV"
       using 2 3 assms by blast
     then obtain z where 4: "z \<in> F \<and> x \<sqinter> z \<le> y"
       by blast
     hence "y \<sqinter> z = (x \<squnion> y) \<sqinter> z"
       by (simp add: inf_sup_distrib2 sup_absorb2)
     also have "... \<in> F"
       using 1 4 assms filter_inf_closed by auto
     finally have "y \<in> F"
       using assms by (simp add: filter_def)
   }
   thus ?thesis
     using assms by blast
 qed
 
+lemma up_dist_inf_inter:
+  assumes "is_up_set S"
+    shows "\<up>(x \<sqinter> y) \<inter> S = filter_sup (\<up>x \<inter> S) (\<up>y \<inter> S) \<inter> S"
+proof
+  show "\<up>(x \<sqinter> y) \<inter> S \<subseteq> filter_sup (\<up>x \<inter> S) (\<up>y \<inter> S) \<inter> S"
+  proof
+    fix z
+    let ?x = "x \<squnion> z"
+    let ?y = "y \<squnion> z"
+    assume "z \<in> \<up>(x \<sqinter> y) \<inter> S"
+    hence 1: "x \<sqinter> y \<le> z \<and> z \<in> S"
+      by auto
+    hence "?x \<in> (\<up>x \<inter> S) \<and> ?y \<in> (\<up>y \<inter> S) \<and> ?x \<sqinter> ?y \<le> z"
+      using assms sup_absorb2 sup_inf_distrib2 by fastforce
+    thus "z \<in> filter_sup (\<up>x \<inter> S) (\<up>y \<inter> S) \<inter> S"
+      using filter_sup_def 1 by fastforce
+  qed
+next
+  show "filter_sup (\<up>x \<inter> S) (\<up>y \<inter> S) \<inter> S \<subseteq> \<up>(x \<sqinter> y) \<inter> S"
+  proof
+    fix z
+    assume "z \<in> filter_sup (\<up>x \<inter> S) (\<up>y \<inter> S) \<inter> S"
+    then obtain u v where 2: "u\<in>\<up>x \<and> v\<in>\<up>y \<and> u \<sqinter> v \<le> z \<and> z \<in> S"
+      using filter_sup_def by auto
+    hence "x \<sqinter> y \<le> z"
+      using order.trans inf_mono by blast
+    thus "z \<in> \<up>(x \<sqinter> y) \<inter> S"
+      using 2 by blast
+  qed
+qed
+
 end
 
 context distrib_lattice_bot
 begin
 
 lemma prime_filter:
   "proper_filter F \<Longrightarrow> \<exists>G . prime_filter G \<and> F \<subseteq> G"
   by (metis ultra_filter ultra_filter_prime)
 
 end
 
 context distrib_lattice_top
 begin
 
 lemma complemented_filter_inf_principal:
   assumes "filter_complements F G"
     shows "is_principal_up (F \<inter> \<up>x)"
 proof -
   have 1: "filter F \<and> filter G"
     by (simp add: assms)
   hence 2: "filter (F \<inter> \<up>x) \<and> filter (G \<inter> \<up>x)"
     by (simp add: filter_inf)
   have "(F \<inter> \<up>x) \<inter> (G \<inter> \<up>x) = {top}"
     using assms Int_assoc Int_insert_left_if1 inf_bot_left inf_sup_aci(3) top_in_upset inf.idem by auto
   hence 3: "is_principal_up ((F \<inter> \<up>x) \<inter> (G \<inter> \<up>x))"
     using up_top by blast
   have "filter_sup (F \<inter> \<up>x) (G \<inter> \<up>x) = filter_sup F G \<inter> \<up>x"
     using 1 filter_inf_right_dist_sup up_filter by auto
   also have "... = \<up>x"
     by (simp add: assms)
   finally have "is_principal_up (filter_sup (F \<inter> \<up>x) (G \<inter> \<up>x))"
     by auto
   thus ?thesis
     using 1 2 3 inf_sup_principal_aux by blast
 qed
 
 end
 
 text \<open>
 The set of filters over a distributive lattice with a greatest element forms a bounded distributive lattice.
 \<close>
 
 instantiation filter :: (distrib_lattice_top) bounded_distrib_lattice
 begin
 
 instance
-proof
-  fix x y z :: "'a filter"
-  have "Rep_filter (x \<squnion> (y \<sqinter> z)) = filter_sup (Rep_filter x) (Rep_filter (y \<sqinter> z))"
-    by (simp add: sup_filter.rep_eq)
-  also have "... = filter_sup (Rep_filter x) (Rep_filter y \<inter> Rep_filter z)"
-    by (simp add: inf_filter.rep_eq)
-  also have "... = filter_sup (Rep_filter x) (Rep_filter y) \<inter> filter_sup (Rep_filter x) (Rep_filter z)"
-    by (simp add: filter_sup_left_dist_inf)
-  also have "... = Rep_filter (x \<squnion> y) \<inter> Rep_filter (x \<squnion> z)"
-    by (simp add: sup_filter.rep_eq)
-  also have "... = Rep_filter ((x \<squnion> y) \<sqinter> (x \<squnion> z))"
-    by (simp add: inf_filter.rep_eq)
-  finally show "x \<squnion> (y \<sqinter> z) = (x \<squnion> y) \<sqinter> (x \<squnion> z)"
-    by (simp add: Rep_filter_inject)
-qed
+  apply intro_classes
+  apply transfer
+  by (simp add: filter_sup_left_dist_inf)
 
 end
 
 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,447 +1,558 @@
 (* 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 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 (metis (full_types) antisym ext 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 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 unfold_locales
   by (metis inf_selective antisym distrib_sup_le inf.commute inf_le2)
 
 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
+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,1319 +1,1324 @@
 (* 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 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 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 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 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.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 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 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 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 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 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 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 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 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 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 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 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
 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_Algebras/Stone_Construction.thy b/thys/Stone_Algebras/Stone_Construction.thy
--- a/thys/Stone_Algebras/Stone_Construction.thy
+++ b/thys/Stone_Algebras/Stone_Construction.thy
@@ -1,2351 +1,2308 @@
 (* Title:      Construction of Stone Algebras
    Author:     Walter Guttmann
    Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
 *)
 
 section \<open>Stone Construction\<close>
 
 text \<open>
 This theory proves the uniqueness theorem for the triple representation of Stone algebras and the construction theorem of Stone algebras \cite{ChenGraetzer1969,Katrinak1973}.
 Every Stone algebra $S$ has an associated triple consisting of
 \begin{itemize}
 \item the set of regular elements $B(S)$ of $S$,
 \item the set of dense elements $D(S)$ of $S$, and
 \item the structure map $\varphi(S) : B(S) \to F(D(S))$ defined by $\varphi(x) = {\uparrow} x \cap D(S)$.
 \end{itemize}
 Here $F(X)$ is the set of filters of a partially ordered set $X$.
 We first show that
 \begin{itemize}
 \item $B(S)$ is a Boolean algebra,
 \item $D(S)$ is a distributive lattice with a greatest element, whence $F(D(S))$ is a bounded distributive lattice, and
 \item $\varphi(S)$ is a bounded lattice homomorphism.
 \end{itemize}
 Next, from a triple $T = (B,D,\varphi)$ such that $B$ is a Boolean algebra, $D$ is a distributive lattice with a greatest element and $\varphi : B \to F(D)$ is a bounded lattice homomorphism, we construct a Stone algebra $S(T)$.
 The elements of $S(T)$ are pairs taken from $B \times F(D)$ following the construction of \cite{Katrinak1973}.
 We need to represent $S(T)$ as a type to be able to instantiate the Stone algebra class.
 Because the pairs must satisfy a condition depending on $\varphi$, this would require dependent types.
 Since Isabelle/HOL does not have dependent types, we use a function lifting instead.
 The lifted pairs form a Stone algebra.
 
 Next, we specialise the construction to start with the triple associated with a Stone algebra $S$, that is, we construct $S(B(S),D(S),\varphi(S))$.
 In this case, we can instantiate the lifted pairs to obtain a type of pairs (that no longer implements a dependent type).
 To achieve this, we construct an embedding of the type of pairs into the lifted pairs, so that we inherit the Stone algebra axioms (using a technique of universal algebra that works for universally quantified equations and equational implications).
 
 Next, we show that the Stone algebras $S(B(S),D(S),\varphi(S))$ and $S$ are isomorphic.
 We give explicit mappings in both directions.
 This implies the uniqueness theorem for the triple representation of Stone algebras.
 
 Finally, we show that the triples $(B(S(T)),D(S(T)),\varphi(S(T)))$ and $T$ are isomorphic.
 This requires an isomorphism of the Boolean algebras $B$ and $B(S(T))$, an isomorphism of the distributive lattices $D$ and $D(S(T))$, and a proof that they preserve the structure maps.
 We give explicit mappings of the Boolean algebra isomorphism and the distributive lattice isomorphism in both directions.
 This implies the construction theorem of Stone algebras.
 Because $S(T)$ is implemented by lifted pairs, so are $B(S(T))$ and $D(S(T))$; we therefore also lift $B$ and $D$ to establish the isomorphisms.
 \<close>
 
 theory Stone_Construction
 
 imports P_Algebras Filters
 
 begin
 
-subsection \<open>Triples\<close>
-
-text \<open>
-This section gives definitions of lattice homomorphisms and isomorphisms and basic properties.
-It concludes with a locale that represents triples as discussed above.
-\<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 p_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 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> f top = top"
-
-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> f bot = bot"
-
-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> (\<forall>x . f (-x) = -f x)"
-
-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 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"
-
-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"
-
-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
-
 text \<open>
 A triple consists of a Boolean algebra, a distributive lattice with a greatest element, and a structure map.
 The Boolean algebra and the distributive lattice are represented as HOL types.
 Because both occur in the type of the structure map, the triple is determined simply by the structure map and its HOL type.
 The structure map needs to be a bounded lattice homomorphism.
 \<close>
 
 locale triple =
   fixes phi :: "'a::boolean_algebra \<Rightarrow> 'b::distrib_lattice_top filter"
   assumes hom: "bounded_lattice_homomorphism phi"
 
 subsection \<open>The Triple of a Stone Algebra\<close>
 
 text \<open>
 In this section we construct the triple associated to a Stone algebra.
 \<close>
 
 subsubsection \<open>Regular Elements\<close>
 
 text \<open>
 The regular elements of a Stone algebra form a Boolean subalgebra.
 \<close>
 
 typedef (overloaded) 'a regular = "regular_elements::'a::stone_algebra set"
   by auto
 
 lemma simp_regular [simp]:
   "\<exists>y . Rep_regular x = -y"
   using Rep_regular by simp
 
 setup_lifting type_definition_regular
 
 instantiation regular :: (stone_algebra) boolean_algebra
 begin
 
 lift_definition sup_regular :: "'a regular \<Rightarrow> 'a regular \<Rightarrow> 'a regular" is sup
   by (meson regular_in_p_image_iff regular_closed_sup)
 
 lift_definition inf_regular :: "'a regular \<Rightarrow> 'a regular \<Rightarrow> 'a regular" is inf
   by (meson regular_in_p_image_iff regular_closed_inf)
 
 lift_definition minus_regular :: "'a regular \<Rightarrow> 'a regular \<Rightarrow> 'a regular" is "\<lambda>x y . x \<sqinter> -y"
   by (meson regular_in_p_image_iff regular_closed_inf)
 
 lift_definition uminus_regular :: "'a regular \<Rightarrow> 'a regular" is uminus
   by auto
 
 lift_definition bot_regular :: "'a regular" is bot
   by (meson regular_in_p_image_iff regular_closed_bot)
 
 lift_definition top_regular :: "'a regular" is top
   by (meson regular_in_p_image_iff regular_closed_top)
 
 lift_definition less_eq_regular :: "'a regular \<Rightarrow> 'a regular \<Rightarrow> bool" is less_eq .
 
 lift_definition less_regular :: "'a regular \<Rightarrow> 'a regular \<Rightarrow> bool" is less .
 
 instance
   apply intro_classes
-  apply (simp add: less_eq_regular.rep_eq less_regular.rep_eq inf.less_le_not_le)
-  apply (simp add: less_eq_regular.rep_eq)
-  apply (simp add: less_eq_regular.rep_eq)
-  apply (simp add: Rep_regular_inject less_eq_regular.rep_eq)
-  apply (simp add: inf_regular.rep_eq less_eq_regular.rep_eq)
-  apply (simp add: inf_regular.rep_eq less_eq_regular.rep_eq)
-  apply (simp add: inf_regular.rep_eq less_eq_regular.rep_eq)
-  apply (simp add: sup_regular.rep_eq less_eq_regular.rep_eq)
-  apply (simp add: sup_regular.rep_eq less_eq_regular.rep_eq)
-  apply (simp add: sup_regular.rep_eq less_eq_regular.rep_eq)
-  apply (simp add: bot_regular.rep_eq less_eq_regular.rep_eq)
-  apply (simp add: top_regular.rep_eq less_eq_regular.rep_eq)
-  apply (metis (mono_tags) Rep_regular_inject inf_regular.rep_eq sup_inf_distrib1 sup_regular.rep_eq)
-  apply (metis (mono_tags) Rep_regular_inverse bot_regular.abs_eq inf_regular.rep_eq inf_p uminus_regular.rep_eq)
-  apply (metis (mono_tags) top_regular.abs_eq Rep_regular_inverse simp_regular stone sup_regular.rep_eq uminus_regular.rep_eq)
-  by (metis (mono_tags) Rep_regular_inject inf_regular.rep_eq minus_regular.rep_eq uminus_regular.rep_eq)
+  subgoal apply transfer by (simp add: less_le_not_le)
+  subgoal apply transfer by simp
+  subgoal apply transfer by simp
+  subgoal apply transfer by simp
+  subgoal apply transfer by simp
+  subgoal apply transfer by simp
+  subgoal apply transfer by simp
+  subgoal apply transfer by simp
+  subgoal apply transfer by simp
+  subgoal apply transfer by simp
+  subgoal apply transfer by simp
+  subgoal apply transfer by simp
+  subgoal apply transfer by (simp add: sup_inf_distrib1)
+  subgoal apply transfer by simp
+  subgoal apply transfer by auto
+  subgoal apply transfer by simp
+  done
 
 end
 
 instantiation regular :: (non_trivial_stone_algebra) non_trivial_boolean_algebra
 begin
 
 instance
 proof (intro_classes, rule ccontr)
   assume "\<not>(\<exists>x y::'a regular . x \<noteq> y)"
   hence "(bot::'a regular) = top"
     by simp
   hence "(bot::'a) = top"
     by (metis bot_regular.rep_eq top_regular.rep_eq)
   thus False
     by (simp add: bot_not_top)
 qed
 
 end
 
 subsubsection \<open>Dense Elements\<close>
 
 text \<open>
 The dense elements of a Stone algebra form a distributive lattice with a greatest element.
 \<close>
 
 typedef (overloaded) 'a dense = "dense_elements::'a::stone_algebra set"
   using dense_closed_top by blast
 
 lemma simp_dense [simp]:
   "-Rep_dense x = bot"
   using Rep_dense by simp
 
 setup_lifting type_definition_dense
 
 instantiation dense :: (stone_algebra) distrib_lattice_top
 begin
 
 lift_definition sup_dense :: "'a dense \<Rightarrow> 'a dense \<Rightarrow> 'a dense" is sup
   by simp
 
 lift_definition inf_dense :: "'a dense \<Rightarrow> 'a dense \<Rightarrow> 'a dense" is inf
   by simp
 
 lift_definition top_dense :: "'a dense" is top
   by simp
 
 lift_definition less_eq_dense :: "'a dense \<Rightarrow> 'a dense \<Rightarrow> bool" is less_eq .
 
 lift_definition less_dense :: "'a dense \<Rightarrow> 'a dense \<Rightarrow> bool" is less .
 
 instance
   apply intro_classes
-  apply (simp add: less_eq_dense.rep_eq less_dense.rep_eq inf.less_le_not_le)
-  apply (simp add: less_eq_dense.rep_eq)
-  apply (simp add: less_eq_dense.rep_eq)
-  apply (simp add: Rep_dense_inject less_eq_dense.rep_eq)
-  apply (simp add: inf_dense.rep_eq less_eq_dense.rep_eq)
-  apply (simp add: inf_dense.rep_eq less_eq_dense.rep_eq)
-  apply (simp add: inf_dense.rep_eq less_eq_dense.rep_eq)
-  apply (simp add: sup_dense.rep_eq less_eq_dense.rep_eq)
-  apply (simp add: sup_dense.rep_eq less_eq_dense.rep_eq)
-  apply (simp add: sup_dense.rep_eq less_eq_dense.rep_eq)
-  apply (simp add: top_dense.rep_eq less_eq_dense.rep_eq)
-  by (metis (mono_tags, lifting) Rep_dense_inject sup_inf_distrib1 inf_dense.rep_eq sup_dense.rep_eq)
+  subgoal apply transfer by (simp add: inf.less_le_not_le)
+  subgoal apply transfer by simp
+  subgoal apply transfer by simp
+  subgoal apply transfer by simp
+  subgoal apply transfer by simp
+  subgoal apply transfer by simp
+  subgoal apply transfer by simp
+  subgoal apply transfer by simp
+  subgoal apply transfer by simp
+  subgoal apply transfer by simp
+  subgoal apply transfer by simp
+  subgoal apply transfer by (simp add: sup_inf_distrib1)
+  done
 
 end
 
 lemma up_filter_dense_antitone_dense:
   "dense (x \<squnion> -x \<squnion> y) \<and> dense (x \<squnion> -x \<squnion> y \<squnion> z)"
   by simp
 
 lemma up_filter_dense_antitone:
   "up_filter (Abs_dense (x \<squnion> -x \<squnion> y \<squnion> z)) \<le> up_filter (Abs_dense (x \<squnion> -x \<squnion> y))"
   by (unfold up_filter_antitone[THEN sym]) (simp add: Abs_dense_inverse less_eq_dense.rep_eq)
 
 text \<open>
 The filters of dense elements of a Stone algebra form a bounded distributive lattice.
 \<close>
 
 type_synonym 'a dense_filter = "'a dense filter"
 
 typedef (overloaded) 'a dense_filter_type = "{ x::'a dense_filter . True }"
   using filter_top by blast
 
 setup_lifting type_definition_dense_filter_type
 
 instantiation dense_filter_type :: (stone_algebra) bounded_distrib_lattice
 begin
 
 lift_definition sup_dense_filter_type :: "'a dense_filter_type \<Rightarrow> 'a dense_filter_type \<Rightarrow> 'a dense_filter_type" is sup .
 
 lift_definition inf_dense_filter_type :: "'a dense_filter_type \<Rightarrow> 'a dense_filter_type \<Rightarrow> 'a dense_filter_type" is inf .
 
 lift_definition bot_dense_filter_type :: "'a dense_filter_type" is bot ..
 
 lift_definition top_dense_filter_type :: "'a dense_filter_type" is top ..
 
 lift_definition less_eq_dense_filter_type :: "'a dense_filter_type \<Rightarrow> 'a dense_filter_type \<Rightarrow> bool" is less_eq .
 
 lift_definition less_dense_filter_type :: "'a dense_filter_type \<Rightarrow> 'a dense_filter_type \<Rightarrow> bool" is less .
 
 instance
   apply intro_classes
-  apply (simp add: less_eq_dense_filter_type.rep_eq less_dense_filter_type.rep_eq inf.less_le_not_le)
-  apply (simp add: less_eq_dense_filter_type.rep_eq)
-  apply (simp add: less_eq_dense_filter_type.rep_eq inf.order_lesseq_imp)
-  apply (simp add: Rep_dense_filter_type_inject less_eq_dense_filter_type.rep_eq)
-  apply (simp add: inf_dense_filter_type.rep_eq less_eq_dense_filter_type.rep_eq)
-  apply (simp add: inf_dense_filter_type.rep_eq less_eq_dense_filter_type.rep_eq)
-  apply (simp add: inf_dense_filter_type.rep_eq less_eq_dense_filter_type.rep_eq)
-  apply (simp add: less_eq_dense_filter_type.rep_eq sup_dense_filter_type.rep_eq)
-  apply (simp add: less_eq_dense_filter_type.rep_eq sup_dense_filter_type.rep_eq)
-  apply (simp add: less_eq_dense_filter_type.rep_eq sup_dense_filter_type.rep_eq)
-  apply (simp add: less_eq_dense_filter_type.rep_eq bot_dense_filter_type.rep_eq)
-  apply (simp add: top_dense_filter_type.rep_eq less_eq_dense_filter_type.rep_eq)
-  by (metis (mono_tags, lifting) Rep_dense_filter_type_inject sup_inf_distrib1 inf_dense_filter_type.rep_eq sup_dense_filter_type.rep_eq)
+  subgoal apply transfer by (simp add: inf.less_le_not_le)
+  subgoal apply transfer by simp
+  subgoal apply transfer by simp
+  subgoal apply transfer by simp
+  subgoal apply transfer by simp
+  subgoal apply transfer by simp
+  subgoal apply transfer by simp
+  subgoal apply transfer by simp
+  subgoal apply transfer by simp
+  subgoal apply transfer by simp
+  subgoal apply transfer by simp
+  subgoal apply transfer by simp
+  subgoal apply transfer by (simp add: sup_inf_distrib1)
+  done
 
 end
 
 subsubsection \<open>The Structure Map\<close>
 
 text \<open>
 The structure map of a Stone algebra is a bounded lattice homomorphism.
 It maps a regular element \<open>x\<close> to the set of all dense elements above \<open>-x\<close>.
 This set is a filter.
 \<close>
 
-abbreviation stone_phi_set :: "'a::stone_algebra regular \<Rightarrow> 'a dense set"
-  where "stone_phi_set x \<equiv> { y . -Rep_regular x \<le> Rep_dense y }"
+abbreviation stone_phi_base :: "'a::stone_algebra regular \<Rightarrow> 'a dense set"
+  where "stone_phi_base x \<equiv> { y . -Rep_regular x \<le> Rep_dense y }"
 
-lemma stone_phi_set_filter:
-  "filter (stone_phi_set x)"
+lemma stone_phi_base_filter:
+  "filter (stone_phi_base x)"
   apply (unfold filter_def, intro conjI)
   apply (metis Collect_empty_eq top_dense.rep_eq top_greatest)
   apply (metis inf_dense.rep_eq inf_le2 le_inf_iff mem_Collect_eq)
   using order_trans less_eq_dense.rep_eq by blast
 
 definition stone_phi :: "'a::stone_algebra regular \<Rightarrow> 'a dense_filter"
-  where "stone_phi x = Abs_filter (stone_phi_set x)"
+  where "stone_phi x = Abs_filter (stone_phi_base x)"
 
 text \<open>
 To show that we obtain a triple, we only need to prove that \<open>stone_phi\<close> is a bounded lattice homomorphism.
 The Boolean algebra and the distributive lattice requirements are taken care of by the type system.
 \<close>
 
 interpretation stone_phi: triple "stone_phi"
 proof (unfold_locales, intro conjI)
   have 1: "Rep_regular (Abs_regular bot) = bot"
     by (metis bot_regular.rep_eq bot_regular_def)
   show "stone_phi bot = bot"
     apply (unfold stone_phi_def bot_regular_def 1 p_bot bot_filter_def)
     by (metis (mono_tags, lifting) Collect_cong Rep_dense_inject order_refl singleton_conv top.extremum_uniqueI top_dense.rep_eq)
 next
   show "stone_phi top = top"
     by (metis Collect_cong stone_phi_def UNIV_I bot.extremum dense_closed_top top_empty_eq top_filter.abs_eq top_regular.rep_eq top_set_def)
 next
   show "\<forall>x y::'a regular . stone_phi (x \<squnion> y) = stone_phi x \<squnion> stone_phi y"
   proof (intro allI)
     fix x y :: "'a regular"
-    have "stone_phi_set (x \<squnion> y) = filter_sup (stone_phi_set x) (stone_phi_set y)"
+    have "stone_phi_base (x \<squnion> y) = filter_sup (stone_phi_base x) (stone_phi_base y)"
     proof (rule set_eqI, rule iffI)
       fix z
-      assume 2: "z \<in> stone_phi_set (x \<squnion> y)"
+      assume 2: "z \<in> stone_phi_base (x \<squnion> y)"
       let ?t = "-Rep_regular x \<squnion> Rep_dense z"
       let ?u = "-Rep_regular y \<squnion> Rep_dense z"
       let ?v = "Abs_dense ?t"
       let ?w = "Abs_dense ?u"
-      have 3: "?v \<in> stone_phi_set x \<and> ?w \<in> stone_phi_set y"
+      have 3: "?v \<in> stone_phi_base x \<and> ?w \<in> stone_phi_base y"
         by (simp add: Abs_dense_inverse)
       have "?v \<sqinter> ?w = Abs_dense (?t \<sqinter> ?u)"
         by (simp add: eq_onp_def inf_dense.abs_eq)
       also have "... = Abs_dense (-Rep_regular (x \<squnion> y) \<squnion> Rep_dense z)"
         by (simp add: distrib(1) sup_commute sup_regular.rep_eq)
       also have "... = Abs_dense (Rep_dense z)"
         using 2 by (simp add: le_iff_sup)
       also have "... = z"
         by (simp add: Rep_dense_inverse)
-      finally show "z \<in> filter_sup (stone_phi_set x) (stone_phi_set y)"
-        using 3 mem_Collect_eq order_refl by fastforce
+      finally show "z \<in> filter_sup (stone_phi_base x) (stone_phi_base y)"
+        using 3 mem_Collect_eq order_refl filter_sup_def by fastforce
     next
       fix z
-      assume "z \<in> filter_sup (stone_phi_set x) (stone_phi_set y)"
-      then obtain v w where 4: "v \<in> stone_phi_set x \<and> w \<in> stone_phi_set y \<and> v \<sqinter> w \<le> z"
-        by auto
+      assume "z \<in> filter_sup (stone_phi_base x) (stone_phi_base y)"
+      then obtain v w where 4: "v \<in> stone_phi_base x \<and> w \<in> stone_phi_base y \<and> v \<sqinter> w \<le> z"
+        unfolding filter_sup_def by auto
       have "-Rep_regular (x \<squnion> y) = Rep_regular (-(x \<squnion> y))"
         by (metis uminus_regular.rep_eq)
       also have "... = -Rep_regular x \<sqinter> -Rep_regular y"
         by (simp add: inf_regular.rep_eq uminus_regular.rep_eq)
       also have "... \<le> Rep_dense v \<sqinter> Rep_dense w"
         using 4 inf_mono mem_Collect_eq by blast
       also have "... = Rep_dense (v \<sqinter> w)"
         by (simp add: inf_dense.rep_eq)
       also have "... \<le> Rep_dense z"
         using 4 by (simp add: less_eq_dense.rep_eq)
-      finally show "z \<in> stone_phi_set (x \<squnion> y)"
+      finally show "z \<in> stone_phi_base (x \<squnion> y)"
         by simp
     qed
     thus "stone_phi (x \<squnion> y) = stone_phi x \<squnion> stone_phi y"
-      by (simp add: stone_phi_def eq_onp_same_args stone_phi_set_filter sup_filter.abs_eq)
+      by (simp add: stone_phi_def eq_onp_same_args stone_phi_base_filter sup_filter.abs_eq)
   qed
 next
   show "\<forall>x y::'a regular . stone_phi (x \<sqinter> y) = stone_phi x \<sqinter> stone_phi y"
   proof (intro allI)
     fix x y :: "'a regular"
     have "\<forall>z . -Rep_regular (x \<sqinter> y) \<le> Rep_dense z \<longleftrightarrow> -Rep_regular x \<le> Rep_dense z \<and> -Rep_regular y \<le> Rep_dense z"
       by (simp add: inf_regular.rep_eq)
-    hence "stone_phi_set (x \<sqinter> y) = (stone_phi_set x) \<inter> (stone_phi_set y)"
+    hence "stone_phi_base (x \<sqinter> y) = (stone_phi_base x) \<inter> (stone_phi_base y)"
       by auto
     thus "stone_phi (x \<sqinter> y) = stone_phi x \<sqinter> stone_phi y"
-      by (simp add: stone_phi_def eq_onp_same_args stone_phi_set_filter inf_filter.abs_eq)
+      by (simp add: stone_phi_def eq_onp_same_args stone_phi_base_filter inf_filter.abs_eq)
   qed
 qed
 
 subsection \<open>Properties of Triples\<close>
 
 text \<open>
 In this section we construct a certain set of pairs from a triple, introduce operations on these pairs and develop their properties.
 The given set and operations will form a Stone algebra.
 \<close>
 
 context triple
 begin
 
 lemma phi_bot:
   "phi bot = Abs_filter {top}"
   by (metis hom bot_filter_def)
 
 lemma phi_top:
   "phi top = Abs_filter UNIV"
   by (metis hom top_filter_def)
 
 text \<open>
 The occurrence of \<open>phi\<close> in the following definition of the pairs creates a need for dependent types.
 \<close>
 
 definition pairs :: "('a \<times> 'b filter) set"
   where "pairs = { (x,y) . \<exists>z . y = phi (-x) \<squnion> up_filter z }"
 
 text \<open>
 Operations on pairs are defined in the following.
 They will be used to establish that the pairs form a Stone algebra.
 \<close>
 
 fun pairs_less_eq :: "('a \<times> 'b filter) \<Rightarrow> ('a \<times> 'b filter) \<Rightarrow> bool"
   where "pairs_less_eq (x,y) (z,w) = (x \<le> z \<and> w \<le> y)"
 
 fun pairs_less :: "('a \<times> 'b filter) \<Rightarrow> ('a \<times> 'b filter) \<Rightarrow> bool"
   where "pairs_less (x,y) (z,w) = (pairs_less_eq (x,y) (z,w) \<and> \<not> pairs_less_eq (z,w) (x,y))"
 
 fun pairs_sup :: "('a \<times> 'b filter) \<Rightarrow> ('a \<times> 'b filter) \<Rightarrow> ('a \<times> 'b filter)"
   where "pairs_sup (x,y) (z,w) = (x \<squnion> z,y \<sqinter> w)"
 
 fun pairs_inf :: "('a \<times> 'b filter) \<Rightarrow> ('a \<times> 'b filter) \<Rightarrow> ('a \<times> 'b filter)"
   where "pairs_inf (x,y) (z,w) = (x \<sqinter> z,y \<squnion> w)"
 
+fun pairs_minus :: "('a \<times> 'b filter) \<Rightarrow> ('a \<times> 'b filter) \<Rightarrow> ('a \<times> 'b filter)"
+  where "pairs_minus (x,y) (z,w) = (x \<sqinter> -z,y \<squnion> phi z)"
+
 fun pairs_uminus :: "('a \<times> 'b filter) \<Rightarrow> ('a \<times> 'b filter)"
   where "pairs_uminus (x,y) = (-x,phi x)"
 
 abbreviation pairs_bot :: "('a \<times> 'b filter)"
   where "pairs_bot \<equiv> (bot,Abs_filter UNIV)"
 
 abbreviation pairs_top :: "('a \<times> 'b filter)"
   where "pairs_top \<equiv> (top,Abs_filter {top})"
 
 lemma pairs_top_in_set:
   "(x,y) \<in> pairs \<Longrightarrow> top \<in> Rep_filter y"
   by simp
 
 lemma phi_complemented:
   "complement (phi x) (phi (-x))"
   by (metis hom inf_compl_bot sup_compl_top)
 
 lemma phi_inf_principal:
   "\<exists>z . up_filter z = phi x \<sqinter> up_filter y"
 proof -
   let ?F = "Rep_filter (phi x)"
   let ?G = "Rep_filter (phi (-x))"
   have 1: "eq_onp filter ?F ?F \<and> eq_onp filter (\<up>y) (\<up>y)"
     by (simp add: eq_onp_def)
   have "filter_complements ?F ?G"
     apply (intro conjI)
     apply simp
     apply simp
     apply (metis (no_types) phi_complemented sup_filter.rep_eq top_filter.rep_eq)
     by (metis (no_types) phi_complemented inf_filter.rep_eq bot_filter.rep_eq)
   hence "is_principal_up (?F \<inter> \<up>y)"
     using complemented_filter_inf_principal by blast
   then obtain z where "\<up>z = ?F \<inter> \<up>y"
     by auto
   hence "up_filter z = Abs_filter (?F \<inter> \<up>y)"
     by simp
   also have "... = Abs_filter ?F \<sqinter> up_filter y"
     using 1 inf_filter.abs_eq by force
   also have "... = phi x \<sqinter> up_filter y"
     by (simp add: Rep_filter_inverse)
   finally show ?thesis
     by auto
 qed
 
 text \<open>
 Quite a bit of filter theory is involved in showing that the intersection of \<open>phi x\<close> with a principal filter is a principal filter, so the following function can extract its least element.
 \<close>
 
 fun rho :: "'a \<Rightarrow> 'b \<Rightarrow> 'b"
   where "rho x y = (SOME z . up_filter z = phi x \<sqinter> up_filter y)"
 
 lemma rho_char:
   "up_filter (rho x y) = phi x \<sqinter> up_filter y"
   by (metis (mono_tags) someI_ex rho.simps phi_inf_principal)
 
 text \<open>
 The following results show that the pairs are closed under the given operations.
 \<close>
 
 lemma pairs_sup_closed:
   assumes "(x,y) \<in> pairs"
       and "(z,w) \<in> pairs"
     shows "pairs_sup (x,y) (z,w) \<in> pairs"
 proof -
   from assms obtain u v where "y = phi (-x) \<squnion> up_filter u \<and> w = phi (-z) \<squnion> up_filter v"
     using pairs_def by auto
   hence "pairs_sup (x,y) (z,w) = (x \<squnion> z,(phi (-x) \<squnion> up_filter u) \<sqinter> (phi (-z) \<squnion> up_filter v))"
     by simp
   also have "... = (x \<squnion> z,(phi (-x) \<sqinter> phi (-z)) \<squnion> (phi (-x) \<sqinter> up_filter v) \<squnion> (up_filter u \<sqinter> phi (-z)) \<squnion> (up_filter u \<sqinter> up_filter v))"
     by (simp add: inf.sup_commute inf_sup_distrib1 sup_commute sup_left_commute)
   also have "... = (x \<squnion> z,phi (-(x \<squnion> z)) \<squnion> (phi (-x) \<sqinter> up_filter v) \<squnion> (up_filter u \<sqinter> phi (-z)) \<squnion> (up_filter u \<sqinter> up_filter v))"
     using hom by simp
   also have "... = (x \<squnion> z,phi (-(x \<squnion> z)) \<squnion> up_filter (rho (-x) v) \<squnion> up_filter (rho (-z) u) \<squnion> (up_filter u \<sqinter> up_filter v))"
     by (metis inf.sup_commute rho_char)
   also have "... = (x \<squnion> z,phi (-(x \<squnion> z)) \<squnion> up_filter (rho (-x) v) \<squnion> up_filter (rho (-z) u) \<squnion> up_filter (u \<squnion> v))"
     by (metis up_filter_dist_sup)
   also have "... = (x \<squnion> z,phi (-(x \<squnion> z)) \<squnion> up_filter (rho (-x) v \<sqinter> rho (-z) u \<sqinter> (u \<squnion> v)))"
     by (simp add: sup_commute sup_left_commute up_filter_dist_inf)
   finally show ?thesis
     using pairs_def by auto
 qed
 
 lemma pairs_inf_closed:
   assumes "(x,y) \<in> pairs"
       and "(z,w) \<in> pairs"
     shows "pairs_inf (x,y) (z,w) \<in> pairs"
 proof -
   from assms obtain u v where "y = phi (-x) \<squnion> up_filter u \<and> w = phi (-z) \<squnion> up_filter v"
     using pairs_def by auto
   hence "pairs_inf (x,y) (z,w) = (x \<sqinter> z,(phi (-x) \<squnion> up_filter u) \<squnion> (phi (-z) \<squnion> up_filter v))"
     by simp
   also have "... = (x \<sqinter> z,(phi (-x) \<squnion> phi (-z)) \<squnion> (up_filter u \<squnion> up_filter v))"
     by (simp add: sup_commute sup_left_commute)
   also have "... = (x \<sqinter> z,phi (-(x \<sqinter> z)) \<squnion> (up_filter u \<squnion> up_filter v))"
     using hom by simp
   also have "... = (x \<sqinter> z,phi (-(x \<sqinter> z)) \<squnion> up_filter (u \<sqinter> v))"
     by (simp add: up_filter_dist_inf)
   finally show ?thesis
     using pairs_def by auto
 qed
 
 lemma pairs_uminus_closed:
   "pairs_uminus (x,y) \<in> pairs"
 proof -
   have "pairs_uminus (x,y) = (-x,phi (--x) \<squnion> bot)"
     by simp
   also have "... = (-x,phi (--x) \<squnion> up_filter top)"
     by (simp add: bot_filter.abs_eq)
   finally show ?thesis
     by (metis (mono_tags, lifting) mem_Collect_eq old.prod.case pairs_def)
 qed
 
 lemma pairs_bot_closed:
   "pairs_bot \<in> pairs"
   using pairs_def phi_top triple.hom triple_axioms by fastforce
 
 lemma pairs_top_closed:
   "pairs_top \<in> pairs"
   by (metis p_bot pairs_uminus.simps pairs_uminus_closed phi_bot)
 
 text \<open>
 We prove enough properties of the pair operations so that we can later show they form a Stone algebra.
 \<close>
 
 lemma pairs_sup_dist_inf:
   "(x,y) \<in> pairs \<Longrightarrow> (z,w) \<in> pairs \<Longrightarrow> (u,v) \<in> pairs \<Longrightarrow> pairs_sup (x,y) (pairs_inf (z,w) (u,v)) = pairs_inf (pairs_sup (x,y) (z,w)) (pairs_sup (x,y) (u,v))"
   using sup_inf_distrib1 inf_sup_distrib1 by auto
 
 lemma pairs_phi_less_eq:
   "(x,y) \<in> pairs \<Longrightarrow> phi (-x) \<le> y"
   using pairs_def by auto
 
 lemma pairs_uminus_galois:
   assumes "(x,y) \<in> pairs"
       and "(z,w) \<in> pairs"
     shows "pairs_inf (x,y) (z,w) = pairs_bot \<longleftrightarrow> pairs_less_eq (x,y) (pairs_uminus (z,w))"
 proof -
   have 1: "x \<sqinter> z = bot \<and> y \<squnion> w = Abs_filter UNIV \<longrightarrow> phi z \<le> y"
     by (metis (no_types, lifting) assms(1) heyting.implies_inf_absorb hom le_supE pairs_phi_less_eq sup_bot_right)
   have 2: "x \<le> -z \<and> phi z \<le> y \<longrightarrow> y \<squnion> w = Abs_filter UNIV"
   proof
     assume 3: "x \<le> -z \<and> phi z \<le> y"
     have "Abs_filter UNIV = phi z \<squnion> phi (-z)"
       using hom phi_complemented phi_top by auto
     also have "... \<le> y \<squnion> w"
       using 3 assms(2) sup_mono pairs_phi_less_eq by auto
     finally show "y \<squnion> w = Abs_filter UNIV"
       using hom phi_top top.extremum_uniqueI by auto
   qed
   have "x \<sqinter> z = bot \<longleftrightarrow> x \<le> -z"
     by (simp add: shunting_1)
   thus ?thesis
     using 1 2 Pair_inject pairs_inf.simps pairs_less_eq.simps pairs_uminus.simps by auto
 qed
 
 lemma pairs_stone:
   "(x,y) \<in> pairs \<Longrightarrow> pairs_sup (pairs_uminus (x,y)) (pairs_uminus (pairs_uminus (x,y))) = pairs_top"
   by (metis hom pairs_sup.simps pairs_uminus.simps phi_bot phi_complemented stone)
 
 text \<open>
 The following results show how the regular elements and the dense elements among the pairs look like.
 \<close>
 
 abbreviation "dense_pairs \<equiv> { (x,y) . (x,y) \<in> pairs \<and> pairs_uminus (x,y) = pairs_bot }"
 abbreviation "regular_pairs \<equiv> { (x,y) . (x,y) \<in> pairs \<and> pairs_uminus (pairs_uminus (x,y)) = (x,y) }"
 abbreviation "is_principal_up_filter x \<equiv> \<exists>y . x = up_filter y"
 
 lemma dense_pairs:
   "dense_pairs = { (x,y) . x = top \<and> is_principal_up_filter y }"
 proof -
   have "dense_pairs = { (x,y) . (x,y) \<in> pairs \<and> x = top }"
     by (metis Pair_inject compl_bot_eq double_compl pairs_uminus.simps phi_top)
   also have "... = { (x,y) . (\<exists>z . y = up_filter z) \<and> x = top }"
     using hom pairs_def by auto
   finally show ?thesis
     by auto
 qed
 
 lemma regular_pairs:
   "regular_pairs = { (x,y) . y = phi (-x) }"
   using pairs_def pairs_uminus_closed by fastforce
 
 text \<open>
 The following extraction function will be used in defining one direction of the Stone algebra isomorphism.
 \<close>
 
 fun rho_pair :: "'a \<times> 'b filter \<Rightarrow> 'b"
   where "rho_pair (x,y) = (SOME z . up_filter z = phi x \<sqinter> y)"
 
 lemma get_rho_pair_char:
   assumes "(x,y) \<in> pairs"
     shows "up_filter (rho_pair (x,y)) = phi x \<sqinter> y"
 proof -
   from assms obtain w where "y = phi (-x) \<squnion> up_filter w"
     using pairs_def by auto
   hence "phi x \<sqinter> y = phi x \<sqinter> up_filter w"
     by (simp add: inf_sup_distrib1 phi_complemented)
   thus ?thesis
     using rho_char by auto
 qed
 
 lemma sa_iso_pair:
   "(--x,phi (-x) \<squnion> up_filter y) \<in> pairs"
   using pairs_def by auto
 
 end
 
 subsection \<open>The Stone Algebra of a Triple\<close>
 
 text \<open>
 In this section we prove that the set of pairs constructed in a triple forms a Stone Algebra.
 The following type captures the parameter \<open>phi\<close> on which the type of triples depends.
 This parameter is the structure map that occurs in the definition of the set of pairs.
 The set of all structure maps is the set of all bounded lattice homomorphisms (of appropriate type).
 In order to make it a HOL type, we need to show that at least one such structure map exists.
 To this end we use the ultrafilter lemma: the required bounded lattice homomorphism is essentially the characteristic map of an ultrafilter, but the latter must exist.
 In particular, the underlying Boolean algebra must contain at least two elements.
 \<close>
 
 typedef (overloaded) ('a,'b) phi = "{ f::'a::non_trivial_boolean_algebra \<Rightarrow> 'b::distrib_lattice_top filter . bounded_lattice_homomorphism f }"
 proof -
   from ultra_filter_exists obtain F :: "'a set" where 1: "ultra_filter F"
     by auto
   hence 2: "prime_filter F"
     using ultra_filter_prime by auto
   let ?f = "\<lambda>x . if x\<in>F then top else bot::'b filter"
   have "bounded_lattice_homomorphism ?f"
   proof (intro conjI)
     show "?f bot = bot"
       using 1 by (meson bot.extremum filter_def subset_eq top.extremum_unique)
   next
     show "?f top = top"
       using 1 by simp
   next
     show "\<forall>x y . ?f (x \<squnion> y) = ?f x \<squnion> ?f y"
     proof (intro allI)
       fix x y
       show "?f (x \<squnion> y) = ?f x \<squnion> ?f y"
         apply (cases "x \<in> F"; cases "y \<in> F")
         using 1 filter_def apply fastforce
         using 1 filter_def apply fastforce
         using 1 filter_def apply fastforce
         using 2 sup_bot_left by auto
    qed
   next
     show "\<forall>x y . ?f (x \<sqinter> y) = ?f x \<sqinter> ?f y"
     proof (intro allI)
       fix x y
       show "?f (x \<sqinter> y) = ?f x \<sqinter> ?f y"
         apply (cases "x \<in> F"; cases "y \<in> F")
         using 1 apply (simp add: filter_inf_closed)
         using 1 apply (metis (mono_tags, lifting) brouwer.inf_sup_ord(4) inf_top_left filter_def)
         using 1 apply (metis (mono_tags, lifting) brouwer.inf_sup_ord(3) inf_top_right filter_def)
         using 1 filter_def by force
     qed
   qed
   hence "?f \<in> {f . bounded_lattice_homomorphism f}"
     by simp
   thus ?thesis
     by meson
 qed
 
 lemma simp_phi [simp]:
   "bounded_lattice_homomorphism (Rep_phi x)"
   using Rep_phi by simp
 
 setup_lifting type_definition_phi
 
 text \<open>
 The following implements the dependent type of pairs depending on structure maps.
 It uses functions from structure maps to pairs with the requirement that, for each structure map, the corresponding pair is contained in the set of pairs constructed for a triple with that structure map.
 
 If this type could be defined in the locale \<open>triple\<close> and instantiated to Stone algebras there, there would be no need for the lifting and we could work with triples directly.
 \<close>
 
 typedef (overloaded) ('a,'b) lifted_pair = "{ pf::('a::non_trivial_boolean_algebra,'b::distrib_lattice_top) phi \<Rightarrow> 'a \<times> 'b filter . \<forall>f . pf f \<in> triple.pairs (Rep_phi f) }"
 proof -
   have "\<forall>f::('a,'b) phi . triple.pairs_bot \<in> triple.pairs (Rep_phi f)"
   proof
     fix f :: "('a,'b) phi"
     have "triple (Rep_phi f)"
       by (simp add: triple_def)
     thus "triple.pairs_bot \<in> triple.pairs (Rep_phi f)"
       using triple.regular_pairs triple.phi_top by fastforce
   qed
   thus ?thesis
     by auto
 qed
 
 lemma simp_lifted_pair [simp]:
   "\<forall>f . Rep_lifted_pair pf f \<in> triple.pairs (Rep_phi f)"
   using Rep_lifted_pair by simp
 
 setup_lifting type_definition_lifted_pair
 
 text \<open>
 The lifted pairs form a Stone algebra.
 \<close>
 
 instantiation lifted_pair :: (non_trivial_boolean_algebra,distrib_lattice_top) stone_algebra
 begin
 
 text \<open>
 All operations are lifted point-wise.
 \<close>
 
 lift_definition sup_lifted_pair :: "('a,'b) lifted_pair \<Rightarrow> ('a,'b) lifted_pair \<Rightarrow> ('a,'b) lifted_pair" is "\<lambda>xf yf f . triple.pairs_sup (xf f) (yf f)"
   by (metis (no_types, hide_lams) simp_phi triple_def triple.pairs_sup_closed prod.collapse)
 
 lift_definition inf_lifted_pair :: "('a,'b) lifted_pair \<Rightarrow> ('a,'b) lifted_pair \<Rightarrow> ('a,'b) lifted_pair" is "\<lambda>xf yf f . triple.pairs_inf (xf f) (yf f)"
   by (metis (no_types, hide_lams) simp_phi triple_def triple.pairs_inf_closed prod.collapse)
 
 lift_definition uminus_lifted_pair :: "('a,'b) lifted_pair \<Rightarrow> ('a,'b) lifted_pair" is "\<lambda>xf f . triple.pairs_uminus (Rep_phi f) (xf f)"
   by (metis (no_types, hide_lams) simp_phi triple_def triple.pairs_uminus_closed prod.collapse)
 
 lift_definition bot_lifted_pair :: "('a,'b) lifted_pair" is "\<lambda>f . triple.pairs_bot"
   by (metis (no_types, hide_lams) simp_phi triple_def triple.pairs_bot_closed)
 
 lift_definition top_lifted_pair :: "('a,'b) lifted_pair" is "\<lambda>f . triple.pairs_top"
   by (metis (no_types, hide_lams) simp_phi triple_def triple.pairs_top_closed)
 
 lift_definition less_eq_lifted_pair :: "('a,'b) lifted_pair \<Rightarrow> ('a,'b) lifted_pair \<Rightarrow> bool" is "\<lambda>xf yf . \<forall>f . triple.pairs_less_eq (xf f) (yf f)" .
 
 lift_definition less_lifted_pair :: "('a,'b) lifted_pair \<Rightarrow> ('a,'b) lifted_pair \<Rightarrow> bool" is "\<lambda>xf yf . (\<forall>f . triple.pairs_less_eq (xf f) (yf f)) \<and> \<not> (\<forall>f . triple.pairs_less_eq (yf f) (xf f))" .
 
 instance
 proof intro_classes
   fix xf yf :: "('a,'b) lifted_pair"
   show "xf < yf \<longleftrightarrow> xf \<le> yf \<and> \<not> yf \<le> xf"
     by (simp add: less_lifted_pair.rep_eq less_eq_lifted_pair.rep_eq)
 next
   fix xf :: "('a,'b) lifted_pair"
   {
     fix f :: "('a,'b) phi"
     have 1: "triple (Rep_phi f)"
       by (simp add: triple_def)
     let ?x = "Rep_lifted_pair xf f"
     obtain x1 x2 where "(x1,x2) = ?x"
       using prod.collapse by blast
     hence "triple.pairs_less_eq ?x ?x"
       using 1 by (metis triple.pairs_less_eq.simps order_refl)
   }
   thus "xf \<le> xf"
     by (simp add: less_eq_lifted_pair.rep_eq)
 next
   fix xf yf zf :: "('a,'b) lifted_pair"
   assume 1: "xf \<le> yf" and 2: "yf \<le> zf"
   {
     fix f :: "('a,'b) phi"
     have 3: "triple (Rep_phi f)"
       by (simp add: triple_def)
     let ?x = "Rep_lifted_pair xf f"
     let ?y = "Rep_lifted_pair yf f"
     let ?z = "Rep_lifted_pair zf f"
     obtain x1 x2 y1 y2 z1 z2 where 4: "(x1,x2) = ?x \<and> (y1,y2) = ?y \<and> (z1,z2) = ?z"
       using prod.collapse by blast
     have "triple.pairs_less_eq ?x ?y \<and> triple.pairs_less_eq ?y ?z"
       using 1 2 3 less_eq_lifted_pair.rep_eq by simp
     hence "triple.pairs_less_eq ?x ?z"
       using 3 4 by (metis (mono_tags, lifting) triple.pairs_less_eq.simps order_trans)
   }
   thus "xf \<le> zf"
     by (simp add: less_eq_lifted_pair.rep_eq)
 next
   fix xf yf :: "('a,'b) lifted_pair"
   assume 1: "xf \<le> yf" and 2: "yf \<le> xf"
   {
     fix f :: "('a,'b) phi"
     have 3: "triple (Rep_phi f)"
       by (simp add: triple_def)
     let ?x = "Rep_lifted_pair xf f"
     let ?y = "Rep_lifted_pair yf f"
     obtain x1 x2 y1 y2 where 4: "(x1,x2) = ?x \<and> (y1,y2) = ?y"
       using prod.collapse by blast
     have "triple.pairs_less_eq ?x ?y \<and> triple.pairs_less_eq ?y ?x"
       using 1 2 3 less_eq_lifted_pair.rep_eq by simp
     hence "?x = ?y"
       using 3 4 by (metis (mono_tags, lifting) triple.pairs_less_eq.simps antisym)
   }
   thus "xf = yf"
     by (metis Rep_lifted_pair_inverse ext)
 next
   fix xf yf :: "('a,'b) lifted_pair"
   {
     fix f :: "('a,'b) phi"
     have 1: "triple (Rep_phi f)"
       by (simp add: triple_def)
     let ?x = "Rep_lifted_pair xf f"
     let ?y = "Rep_lifted_pair yf f"
     obtain x1 x2 y1 y2 where "(x1,x2) = ?x \<and> (y1,y2) = ?y"
       using prod.collapse by blast
     hence "triple.pairs_less_eq (triple.pairs_inf ?x ?y) ?y"
       using 1 by (metis (mono_tags, lifting) inf_sup_ord(2) sup.cobounded2 triple.pairs_inf.simps triple.pairs_less_eq.simps inf_lifted_pair.rep_eq)
   }
   thus "xf \<sqinter> yf \<le> yf"
     by (simp add: less_eq_lifted_pair.rep_eq inf_lifted_pair.rep_eq)
 next
   fix xf yf :: "('a,'b) lifted_pair"
   {
     fix f :: "('a,'b) phi"
     have 1: "triple (Rep_phi f)"
       by (simp add: triple_def)
     let ?x = "Rep_lifted_pair xf f"
     let ?y = "Rep_lifted_pair yf f"
     obtain x1 x2 y1 y2 where "(x1,x2) = ?x \<and> (y1,y2) = ?y"
       using prod.collapse by blast
     hence "triple.pairs_less_eq (triple.pairs_inf ?x ?y) ?x"
       using 1 by (metis (mono_tags, lifting) inf_sup_ord(1) sup.cobounded1 triple.pairs_inf.simps triple.pairs_less_eq.simps inf_lifted_pair.rep_eq)
   }
   thus "xf \<sqinter> yf \<le> xf"
     by (simp add: less_eq_lifted_pair.rep_eq inf_lifted_pair.rep_eq)
 next
   fix xf yf zf :: "('a,'b) lifted_pair"
   assume 1: "xf \<le> yf" and 2: "xf \<le> zf"
   {
     fix f :: "('a,'b) phi"
     have 3: "triple (Rep_phi f)"
       by (simp add: triple_def)
     let ?x = "Rep_lifted_pair xf f"
     let ?y = "Rep_lifted_pair yf f"
     let ?z = "Rep_lifted_pair zf f"
     obtain x1 x2 y1 y2 z1 z2 where 4: "(x1,x2) = ?x \<and> (y1,y2) = ?y \<and> (z1,z2) = ?z"
       using prod.collapse by blast
     have "triple.pairs_less_eq ?x ?y \<and> triple.pairs_less_eq ?x ?z"
       using 1 2 3 less_eq_lifted_pair.rep_eq by simp
     hence "triple.pairs_less_eq ?x (triple.pairs_inf ?y ?z)"
       using 3 4 by (metis (mono_tags, lifting) le_inf_iff sup.bounded_iff triple.pairs_inf.simps triple.pairs_less_eq.simps)
   }
   thus "xf \<le> yf \<sqinter> zf"
     by (simp add: less_eq_lifted_pair.rep_eq inf_lifted_pair.rep_eq)
 next
   fix xf yf :: "('a,'b) lifted_pair"
   {
     fix f :: "('a,'b) phi"
     have 1: "triple (Rep_phi f)"
       by (simp add: triple_def)
     let ?x = "Rep_lifted_pair xf f"
     let ?y = "Rep_lifted_pair yf f"
     obtain x1 x2 y1 y2 where "(x1,x2) = ?x \<and> (y1,y2) = ?y"
       using prod.collapse by blast
     hence "triple.pairs_less_eq ?x (triple.pairs_sup ?x ?y)"
       using 1 by (metis (no_types, lifting) inf_commute sup.cobounded1 inf.cobounded2 triple.pairs_sup.simps triple.pairs_less_eq.simps sup_lifted_pair.rep_eq)
   }
   thus "xf \<le> xf \<squnion> yf"
     by (simp add: less_eq_lifted_pair.rep_eq sup_lifted_pair.rep_eq)
 next
   fix xf yf :: "('a,'b) lifted_pair"
   {
     fix f :: "('a,'b) phi"
     have 1: "triple (Rep_phi f)"
       by (simp add: triple_def)
     let ?x = "Rep_lifted_pair xf f"
     let ?y = "Rep_lifted_pair yf f"
     obtain x1 x2 y1 y2 where "(x1,x2) = ?x \<and> (y1,y2) = ?y"
       using prod.collapse by blast
     hence "triple.pairs_less_eq ?y (triple.pairs_sup ?x ?y)"
       using 1 by (metis (no_types, lifting) sup.cobounded2 inf.cobounded2 triple.pairs_sup.simps triple.pairs_less_eq.simps sup_lifted_pair.rep_eq)
   }
   thus "yf \<le> xf \<squnion> yf"
     by (simp add: less_eq_lifted_pair.rep_eq sup_lifted_pair.rep_eq)
 next
   fix xf yf zf :: "('a,'b) lifted_pair"
   assume 1: "yf \<le> xf" and 2: "zf \<le> xf"
   {
     fix f :: "('a,'b) phi"
     have 3: "triple (Rep_phi f)"
       by (simp add: triple_def)
     let ?x = "Rep_lifted_pair xf f"
     let ?y = "Rep_lifted_pair yf f"
     let ?z = "Rep_lifted_pair zf f"
     obtain x1 x2 y1 y2 z1 z2 where 4: "(x1,x2) = ?x \<and> (y1,y2) = ?y \<and> (z1,z2) = ?z"
       using prod.collapse by blast
     have "triple.pairs_less_eq ?y ?x \<and> triple.pairs_less_eq ?z ?x"
       using 1 2 3 less_eq_lifted_pair.rep_eq by simp
     hence "triple.pairs_less_eq (triple.pairs_sup ?y ?z) ?x"
       using 3 4 by (metis (mono_tags, lifting) le_inf_iff sup.bounded_iff triple.pairs_sup.simps triple.pairs_less_eq.simps)
   }
   thus "yf \<squnion> zf \<le> xf"
     by (simp add: less_eq_lifted_pair.rep_eq sup_lifted_pair.rep_eq)
 next
   fix xf :: "('a,'b) lifted_pair"
   {
     fix f :: "('a,'b) phi"
     have 1: "triple (Rep_phi f)"
       by (simp add: triple_def)
     let ?x = "Rep_lifted_pair xf f"
     obtain x1 x2 where "(x1,x2) = ?x"
       using prod.collapse by blast
     hence "triple.pairs_less_eq triple.pairs_bot ?x"
       using 1 by (metis bot.extremum top_greatest top_filter.abs_eq triple.pairs_less_eq.simps)
   }
   thus "bot \<le> xf"
     by (simp add: less_eq_lifted_pair.rep_eq bot_lifted_pair.rep_eq)
 next
   fix xf :: "('a,'b) lifted_pair"
   {
     fix f :: "('a,'b) phi"
     have 1: "triple (Rep_phi f)"
       by (simp add: triple_def)
     let ?x = "Rep_lifted_pair xf f"
     obtain x1 x2 where "(x1,x2) = ?x"
       using prod.collapse by blast
     hence "triple.pairs_less_eq ?x triple.pairs_top"
       using 1 by (metis top.extremum bot_least bot_filter.abs_eq triple.pairs_less_eq.simps)
   }
   thus "xf \<le> top"
     by (simp add: less_eq_lifted_pair.rep_eq top_lifted_pair.rep_eq)
 next
   fix xf yf zf :: "('a,'b) lifted_pair"
   {
     fix f :: "('a,'b) phi"
     have 1: "triple (Rep_phi f)"
       by (simp add: triple_def)
     let ?x = "Rep_lifted_pair xf f"
     let ?y = "Rep_lifted_pair yf f"
     let ?z = "Rep_lifted_pair zf f"
     obtain x1 x2 y1 y2 z1 z2 where "(x1,x2) = ?x \<and> (y1,y2) = ?y \<and> (z1,z2) = ?z"
       using prod.collapse by blast
     hence "triple.pairs_sup ?x (triple.pairs_inf ?y ?z) = triple.pairs_inf (triple.pairs_sup ?x ?y) (triple.pairs_sup ?x ?z)"
       using 1 by (metis (no_types) sup_inf_distrib1 inf_sup_distrib1 triple.pairs_sup.simps triple.pairs_inf.simps)
   }
   thus "xf \<squnion> (yf \<sqinter> zf) = (xf \<squnion> yf) \<sqinter> (xf \<squnion> zf)"
     by (metis Rep_lifted_pair_inverse ext sup_lifted_pair.rep_eq inf_lifted_pair.rep_eq)
 next
   fix xf yf :: "('a,'b) lifted_pair"
   {
     fix f :: "('a,'b) phi"
     have 1: "triple (Rep_phi f)"
       by (simp add: triple_def)
     let ?x = "Rep_lifted_pair xf f"
     let ?y = "Rep_lifted_pair yf f"
     obtain x1 x2 y1 y2 where 2: "(x1,x2) = ?x \<and> (y1,y2) = ?y"
       using prod.collapse by blast
     have "?x \<in> triple.pairs (Rep_phi f) \<and> ?y \<in> triple.pairs (Rep_phi f)"
       by simp
     hence "(triple.pairs_inf ?x ?y = triple.pairs_bot) \<longleftrightarrow> triple.pairs_less_eq ?x (triple.pairs_uminus (Rep_phi f) ?y)"
       using 1 2 by (metis triple.pairs_uminus_galois)
   }
   hence "\<forall>f . (Rep_lifted_pair (xf \<sqinter> yf) f = Rep_lifted_pair bot f) \<longleftrightarrow> triple.pairs_less_eq (Rep_lifted_pair xf f) (Rep_lifted_pair (-yf) f)"
     using bot_lifted_pair.rep_eq inf_lifted_pair.rep_eq uminus_lifted_pair.rep_eq by simp
   hence "(Rep_lifted_pair (xf \<sqinter> yf) = Rep_lifted_pair bot) \<longleftrightarrow> xf \<le> -yf"
     using less_eq_lifted_pair.rep_eq by auto
   thus "(xf \<sqinter> yf = bot) \<longleftrightarrow> (xf \<le> -yf)"
     by (simp add: Rep_lifted_pair_inject)
 next
   fix xf :: "('a,'b) lifted_pair"
   {
     fix f :: "('a,'b) phi"
     have 1: "triple (Rep_phi f)"
       by (simp add: triple_def)
     let ?x = "Rep_lifted_pair xf f"
     obtain x1 x2 where "(x1,x2) = ?x"
       using prod.collapse by blast
     hence "triple.pairs_sup (triple.pairs_uminus (Rep_phi f) ?x) (triple.pairs_uminus (Rep_phi f) (triple.pairs_uminus (Rep_phi f) ?x)) = triple.pairs_top"
       using 1 by (metis simp_lifted_pair triple.pairs_stone)
   }
   hence "Rep_lifted_pair (-xf \<squnion> --xf) = Rep_lifted_pair top"
     using sup_lifted_pair.rep_eq uminus_lifted_pair.rep_eq top_lifted_pair.rep_eq by simp
   thus "-xf \<squnion> --xf = top"
     by (simp add: Rep_lifted_pair_inject)
 qed
 
 end
 
 subsection \<open>The Stone Algebra of the Triple of a Stone Algebra\<close>
 
 text \<open>
 In this section we specialise the above construction to a particular structure map, namely the one obtained in the triple of a Stone algebra.
 For this particular structure map (as well as for any other particular structure map) the resulting type is no longer a dependent type.
 It is just the set of pairs obtained for the given structure map.
 \<close>
 
 typedef (overloaded) 'a stone_phi_pair = "triple.pairs (stone_phi::'a::stone_algebra regular \<Rightarrow> 'a dense_filter)"
   using stone_phi.pairs_bot_closed by auto
 
 setup_lifting type_definition_stone_phi_pair
 
 instantiation stone_phi_pair :: (stone_algebra) sup_inf_top_bot_uminus_ord
 begin
 
 lift_definition sup_stone_phi_pair :: "'a stone_phi_pair \<Rightarrow> 'a stone_phi_pair \<Rightarrow> 'a stone_phi_pair" is triple.pairs_sup
   using stone_phi.pairs_sup_closed by auto
 
 lift_definition inf_stone_phi_pair :: "'a stone_phi_pair \<Rightarrow> 'a stone_phi_pair \<Rightarrow> 'a stone_phi_pair" is triple.pairs_inf
   using stone_phi.pairs_inf_closed by auto
 
 lift_definition uminus_stone_phi_pair :: "'a stone_phi_pair \<Rightarrow> 'a stone_phi_pair" is "triple.pairs_uminus stone_phi"
   using stone_phi.pairs_uminus_closed by auto
 
 lift_definition bot_stone_phi_pair :: "'a stone_phi_pair" is "triple.pairs_bot"
   by (rule stone_phi.pairs_bot_closed)
 
 lift_definition top_stone_phi_pair :: "'a stone_phi_pair" is "triple.pairs_top"
   by (rule stone_phi.pairs_top_closed)
 
 lift_definition less_eq_stone_phi_pair :: "'a stone_phi_pair \<Rightarrow> 'a stone_phi_pair \<Rightarrow> bool" is triple.pairs_less_eq .
 
-lift_definition less_stone_phi_pair :: "'a stone_phi_pair \<Rightarrow> 'a stone_phi_pair \<Rightarrow> bool" is "\<lambda>xf yf . triple.pairs_less_eq xf yf \<and> \<not> triple.pairs_less_eq yf xf" .
+lift_definition less_stone_phi_pair :: "'a stone_phi_pair \<Rightarrow> 'a stone_phi_pair \<Rightarrow> bool" is triple.pairs_less .
 
 instance ..
 
 end
 
+(*
+instantiation stone_phi_pair :: (stone_algebra) stone_algebra
+begin
+
+instance
+  apply intro_classes
+  subgoal apply transfer by auto
+  subgoal apply transfer by auto
+  subgoal apply transfer by auto
+  subgoal apply transfer by auto
+  subgoal apply transfer by auto
+  subgoal apply transfer by auto
+  subgoal apply transfer by auto
+  subgoal apply transfer by auto
+  subgoal apply transfer by auto
+  subgoal apply transfer by auto
+  subgoal apply transfer by (metis (no_types, lifting) Pair_inject compl_bot_eq heyting.implies_order stone_phi.pairs_less_eq.elims(3) stone_phi.phi_top stone_phi.triple_axioms sup_top_left top_greatest triple_def)
+  subgoal apply transfer by (metis (no_types, lifting) Pair_inject stone_phi.pairs_less_eq.elims(3) top.extremum bot_least bot_filter.abs_eq)
+  subgoal apply transfer using stone_phi.triple_axioms triple.pairs_sup_dist_inf by fastforce
+  subgoal apply transfer using stone_phi.pairs_uminus_galois by fastforce
+  subgoal apply transfer using stone_phi.pairs_stone by fastforce
+  done
+
+end
+*)
+
 text \<open>
 The result is a Stone algebra and could be proved so by repeating and specialising the above proof for lifted pairs.
 We choose a different approach, namely by embedding the type of pairs into the lifted type.
 The embedding injects a pair \<open>x\<close> into a function as the value at the given structure map; this makes the embedding injective.
 The value of the function at any other structure map needs to be carefully chosen so that the resulting function is a Stone algebra homomorphism.
 We use \<open>--x\<close>, which is essentially a projection to the regular element component of \<open>x\<close>, whence the image has the structure of a Boolean algebra.
 \<close>
 
 fun stone_phi_embed :: "'a::non_trivial_stone_algebra stone_phi_pair \<Rightarrow> ('a regular,'a dense) lifted_pair"
   where "stone_phi_embed x = Abs_lifted_pair (\<lambda>f . if Rep_phi f = stone_phi then Rep_stone_phi_pair x else triple.pairs_uminus (Rep_phi f) (triple.pairs_uminus (Rep_phi f) (Rep_stone_phi_pair x)))"
 
 text \<open>
 The following lemma shows that in both cases the value of the function is a valid pair for the given structure map.
 \<close>
 
 lemma stone_phi_embed_triple_pair:
   "(if Rep_phi f = stone_phi then Rep_stone_phi_pair x else triple.pairs_uminus (Rep_phi f) (triple.pairs_uminus (Rep_phi f) (Rep_stone_phi_pair x))) \<in> triple.pairs (Rep_phi f)"
   by (metis (no_types, hide_lams) Rep_stone_phi_pair simp_phi surj_pair triple.pairs_uminus_closed triple_def)
 
 text \<open>
 The following result shows that the embedding preserves the operations of Stone algebras.
 Of course, it is not (yet) a Stone algebra homomorphism as we do not know (yet) that the domain of the embedding is a Stone algebra.
 To establish the latter is the purpose of the embedding.
 \<close>
 
 lemma stone_phi_embed_homomorphism:
   "sup_inf_top_bot_uminus_ord_homomorphism stone_phi_embed"
 proof (intro conjI)
   let ?p = "\<lambda>f . triple.pairs_uminus (Rep_phi f)"
   let ?pp = "\<lambda>f x . ?p f (?p f x)"
   let ?q = "\<lambda>f x . ?pp f (Rep_stone_phi_pair x)"
   show "\<forall>x y::'a stone_phi_pair . stone_phi_embed (x \<squnion> y) = stone_phi_embed x \<squnion> stone_phi_embed y"
   proof (intro allI)
     fix x y :: "'a stone_phi_pair"
     have 1: "\<forall>f . triple.pairs_sup (?q f x) (?q f y) = ?q f (x \<squnion> y)"
     proof
       fix f :: "('a regular,'a dense) phi"
       let ?r = "Rep_phi f"
       obtain x1 x2 y1 y2 where 2: "(x1,x2) = Rep_stone_phi_pair x \<and> (y1,y2) = Rep_stone_phi_pair y"
         using prod.collapse by blast
       hence "triple.pairs_sup (?q f x) (?q f y) = triple.pairs_sup (?pp f (x1,x2)) (?pp f (y1,y2))"
         by simp
       also have "... = triple.pairs_sup (--x1,?r (-x1)) (--y1,?r (-y1))"
         by (simp add: triple.pairs_uminus.simps triple_def)
       also have "... = (--x1 \<squnion> --y1,?r (-x1) \<sqinter> ?r (-y1))"
         by simp
       also have "... = (--(x1 \<squnion> y1),?r (-(x1 \<squnion> y1)))"
         by simp
       also have "... = ?pp f (x1 \<squnion> y1,x2 \<sqinter> y2)"
         by (simp add: triple.pairs_uminus.simps triple_def)
       also have "... = ?pp f (triple.pairs_sup (x1,x2) (y1,y2))"
         by simp
       also have "... = ?q f (x \<squnion> y)"
         using 2 by (simp add: sup_stone_phi_pair.rep_eq)
       finally show "triple.pairs_sup (?q f x) (?q f y) = ?q f (x \<squnion> y)"
         .
     qed
     have "stone_phi_embed x \<squnion> stone_phi_embed y = Abs_lifted_pair (\<lambda>f . if Rep_phi f = stone_phi then Rep_stone_phi_pair x else ?q f x) \<squnion> Abs_lifted_pair (\<lambda>f . if Rep_phi f = stone_phi then Rep_stone_phi_pair y else ?q f y)"
       by simp
     also have "... = Abs_lifted_pair (\<lambda>f . triple.pairs_sup (if Rep_phi f = stone_phi then Rep_stone_phi_pair x else ?q f x) (if Rep_phi f = stone_phi then Rep_stone_phi_pair y else ?q f y))"
       by (rule sup_lifted_pair.abs_eq) (simp_all add: eq_onp_same_args stone_phi_embed_triple_pair)
     also have "... = Abs_lifted_pair (\<lambda>f . if Rep_phi f = stone_phi then triple.pairs_sup (Rep_stone_phi_pair x) (Rep_stone_phi_pair y) else triple.pairs_sup (?q f x) (?q f y))"
       by (simp add: if_distrib_2)
     also have "... = Abs_lifted_pair (\<lambda>f . if Rep_phi f = stone_phi then triple.pairs_sup (Rep_stone_phi_pair x) (Rep_stone_phi_pair y) else ?q f (x \<squnion> y))"
       using 1 by meson
     also have "... = Abs_lifted_pair (\<lambda>f . if Rep_phi f = stone_phi then Rep_stone_phi_pair (x \<squnion> y) else ?q f (x \<squnion> y))"
       by (metis sup_stone_phi_pair.rep_eq)
     also have "... = stone_phi_embed (x \<squnion> y)"
       by simp
     finally show "stone_phi_embed (x \<squnion> y) = stone_phi_embed x \<squnion> stone_phi_embed y"
       by simp
   qed
 next
   let ?p = "\<lambda>f . triple.pairs_uminus (Rep_phi f)"
   let ?pp = "\<lambda>f x . ?p f (?p f x)"
   let ?q = "\<lambda>f x . ?pp f (Rep_stone_phi_pair x)"
   show "\<forall>x y::'a stone_phi_pair . stone_phi_embed (x \<sqinter> y) = stone_phi_embed x \<sqinter> stone_phi_embed y"
   proof (intro allI)
     fix x y :: "'a stone_phi_pair"
     have 1: "\<forall>f . triple.pairs_inf (?q f x) (?q f y) = ?q f (x \<sqinter> y)"
     proof
       fix f :: "('a regular,'a dense) phi"
       let ?r = "Rep_phi f"
       obtain x1 x2 y1 y2 where 2: "(x1,x2) = Rep_stone_phi_pair x \<and> (y1,y2) = Rep_stone_phi_pair y"
         using prod.collapse by blast
       hence "triple.pairs_inf (?q f x) (?q f y) = triple.pairs_inf (?pp f (x1,x2)) (?pp f (y1,y2))"
         by simp
       also have "... = triple.pairs_inf (--x1,?r (-x1)) (--y1,?r (-y1))"
         by (simp add: triple.pairs_uminus.simps triple_def)
       also have "... = (--x1 \<sqinter> --y1,?r (-x1) \<squnion> ?r (-y1))"
         by simp
       also have "... = (--(x1 \<sqinter> y1),?r (-(x1 \<sqinter> y1)))"
         by simp
       also have "... = ?pp f (x1 \<sqinter> y1,x2 \<squnion> y2)"
         by (simp add: triple.pairs_uminus.simps triple_def)
       also have "... = ?pp f (triple.pairs_inf (x1,x2) (y1,y2))"
         by simp
       also have "... = ?q f (x \<sqinter> y)"
         using 2 by (simp add: inf_stone_phi_pair.rep_eq)
       finally show "triple.pairs_inf (?q f x) (?q f y) = ?q f (x \<sqinter> y)"
         .
     qed
     have "stone_phi_embed x \<sqinter> stone_phi_embed y = Abs_lifted_pair (\<lambda>f . if Rep_phi f = stone_phi then Rep_stone_phi_pair x else ?q f x) \<sqinter> Abs_lifted_pair (\<lambda>f . if Rep_phi f = stone_phi then Rep_stone_phi_pair y else ?q f y)"
       by simp
     also have "... = Abs_lifted_pair (\<lambda>f . triple.pairs_inf (if Rep_phi f = stone_phi then Rep_stone_phi_pair x else ?q f x) (if Rep_phi f = stone_phi then Rep_stone_phi_pair y else ?q f y))"
       by (rule inf_lifted_pair.abs_eq) (simp_all add: eq_onp_same_args stone_phi_embed_triple_pair)
     also have "... = Abs_lifted_pair (\<lambda>f . if Rep_phi f = stone_phi then triple.pairs_inf (Rep_stone_phi_pair x) (Rep_stone_phi_pair y) else triple.pairs_inf (?q f x) (?q f y))"
       by (simp add: if_distrib_2)
     also have "... = Abs_lifted_pair (\<lambda>f . if Rep_phi f = stone_phi then triple.pairs_inf (Rep_stone_phi_pair x) (Rep_stone_phi_pair y) else ?q f (x \<sqinter> y))"
       using 1 by meson
     also have "... = Abs_lifted_pair (\<lambda>f . if Rep_phi f = stone_phi then Rep_stone_phi_pair (x \<sqinter> y) else ?q f (x \<sqinter> y))"
       by (metis inf_stone_phi_pair.rep_eq)
     also have "... = stone_phi_embed (x \<sqinter> y)"
       by simp
     finally show "stone_phi_embed (x \<sqinter> y) = stone_phi_embed x \<sqinter> stone_phi_embed y"
       by simp
   qed
 next
   have "stone_phi_embed (top::'a stone_phi_pair) = Abs_lifted_pair (\<lambda>f . if Rep_phi f = stone_phi then Rep_stone_phi_pair top else triple.pairs_uminus (Rep_phi f) (triple.pairs_uminus (Rep_phi f) (Rep_stone_phi_pair top)))"
     by simp
   also have "... = Abs_lifted_pair (\<lambda>f . if Rep_phi f = stone_phi then (top,bot) else triple.pairs_uminus (Rep_phi f) (triple.pairs_uminus (Rep_phi f) (top,bot)))"
     by (metis (no_types, hide_lams) bot_filter.abs_eq top_stone_phi_pair.rep_eq)
   also have "... = Abs_lifted_pair (\<lambda>f . if Rep_phi f = stone_phi then (top,bot) else triple.pairs_uminus (Rep_phi f) (bot,top))"
     by (metis (no_types, hide_lams) dense_closed_top simp_phi triple.pairs_uminus.simps triple_def)
   also have "... = Abs_lifted_pair (\<lambda>f . if Rep_phi f = stone_phi then (top,bot) else (top,bot))"
     by (metis (no_types, hide_lams) p_bot simp_phi triple.pairs_uminus.simps triple_def)
   also have "... = Abs_lifted_pair (\<lambda>f . (top,Abs_filter {top}))"
     by (simp add: bot_filter.abs_eq)
   also have "... = top"
     by (rule top_lifted_pair.abs_eq[THEN sym])
   finally show "stone_phi_embed (top::'a stone_phi_pair) = top"
     .
 next
   have "stone_phi_embed (bot::'a stone_phi_pair) = Abs_lifted_pair (\<lambda>f . if Rep_phi f = stone_phi then Rep_stone_phi_pair bot else triple.pairs_uminus (Rep_phi f) (triple.pairs_uminus (Rep_phi f) (Rep_stone_phi_pair bot)))"
     by simp
   also have "... = Abs_lifted_pair (\<lambda>f . if Rep_phi f = stone_phi then (bot,top) else triple.pairs_uminus (Rep_phi f) (triple.pairs_uminus (Rep_phi f) (bot,top)))"
     by (metis (no_types, hide_lams) top_filter.abs_eq bot_stone_phi_pair.rep_eq)
   also have "... = Abs_lifted_pair (\<lambda>f . if Rep_phi f = stone_phi then (bot,top) else triple.pairs_uminus (Rep_phi f) (top,bot))"
     by (metis (no_types, hide_lams) p_bot simp_phi triple.pairs_uminus.simps triple_def)
   also have "... = Abs_lifted_pair (\<lambda>f . if Rep_phi f = stone_phi then (bot,top) else (bot,top))"
     by (metis (no_types, hide_lams) p_top simp_phi triple.pairs_uminus.simps triple_def)
   also have "... = Abs_lifted_pair (\<lambda>f . (bot,Abs_filter UNIV))"
     by (simp add: top_filter.abs_eq)
   also have "... = bot"
     by (rule bot_lifted_pair.abs_eq[THEN sym])
   finally show "stone_phi_embed (bot::'a stone_phi_pair) = bot"
     .
 next
   let ?p = "\<lambda>f . triple.pairs_uminus (Rep_phi f)"
   let ?pp = "\<lambda>f x . ?p f (?p f x)"
   let ?q = "\<lambda>f x . ?pp f (Rep_stone_phi_pair x)"
   show "\<forall>x::'a stone_phi_pair . stone_phi_embed (-x) = -stone_phi_embed x"
   proof (intro allI)
     fix x :: "'a stone_phi_pair"
     have 1: "\<forall>f . triple.pairs_uminus (Rep_phi f) (?q f x) = ?q f (-x)"
     proof
       fix f :: "('a regular,'a dense) phi"
       let ?r = "Rep_phi f"
       obtain x1 x2 where 2: "(x1,x2) = Rep_stone_phi_pair x"
         using prod.collapse by blast
       hence "triple.pairs_uminus (Rep_phi f) (?q f x) = triple.pairs_uminus (Rep_phi f) (?pp f (x1,x2))"
         by simp
       also have "... = triple.pairs_uminus (Rep_phi f) (--x1,?r (-x1))"
         by (simp add: triple.pairs_uminus.simps triple_def)
       also have "... = (---x1,?r (--x1))"
         by (simp add: triple.pairs_uminus.simps triple_def)
       also have "... = ?pp f (-x1,stone_phi x1)"
         by (simp add: triple.pairs_uminus.simps triple_def)
       also have "... = ?pp f (triple.pairs_uminus stone_phi (x1,x2))"
         by simp
       also have "... = ?q f (-x)"
         using 2 by (simp add: uminus_stone_phi_pair.rep_eq)
       finally show "triple.pairs_uminus (Rep_phi f) (?q f x) = ?q f (-x)"
         .
     qed
     have "-stone_phi_embed x = -Abs_lifted_pair (\<lambda>f . if Rep_phi f = stone_phi then Rep_stone_phi_pair x else ?q f x)"
       by simp
     also have "... = Abs_lifted_pair (\<lambda>f . triple.pairs_uminus (Rep_phi f) (if Rep_phi f = stone_phi then Rep_stone_phi_pair x else ?q f x))"
       by (rule uminus_lifted_pair.abs_eq) (simp_all add: eq_onp_same_args stone_phi_embed_triple_pair)
     also have "... = Abs_lifted_pair (\<lambda>f . if Rep_phi f = stone_phi then triple.pairs_uminus (Rep_phi f) (Rep_stone_phi_pair x) else triple.pairs_uminus (Rep_phi f) (?q f x))"
       by (simp add: if_distrib)
     also have "... = Abs_lifted_pair (\<lambda>f . if Rep_phi f = stone_phi then triple.pairs_uminus (Rep_phi f) (Rep_stone_phi_pair x) else ?q f (-x))"
       using 1 by meson
     also have "... = Abs_lifted_pair (\<lambda>f . if Rep_phi f = stone_phi then Rep_stone_phi_pair (-x) else ?q f (-x))"
       by (metis uminus_stone_phi_pair.rep_eq)
     also have "... = stone_phi_embed (-x)"
       by simp
     finally show "stone_phi_embed (-x) = -stone_phi_embed x"
       by simp
   qed
 next
   let ?p = "\<lambda>f . triple.pairs_uminus (Rep_phi f)"
   let ?pp = "\<lambda>f x . ?p f (?p f x)"
   let ?q = "\<lambda>f x . ?pp f (Rep_stone_phi_pair x)"
   show "\<forall>x y::'a stone_phi_pair . x \<le> y \<longrightarrow> stone_phi_embed x \<le> stone_phi_embed y"
   proof (intro allI, rule impI)
     fix x y :: "'a stone_phi_pair"
     assume 1: "x \<le> y"
     have "\<forall>f . triple.pairs_less_eq (if Rep_phi f = stone_phi then Rep_stone_phi_pair x else ?q f x) (if Rep_phi f = stone_phi then Rep_stone_phi_pair y else ?q f y)"
     proof
       fix f :: "('a regular,'a dense) phi"
       let ?r = "Rep_phi f"
       obtain x1 x2 y1 y2 where 2: "(x1,x2) = Rep_stone_phi_pair x \<and> (y1,y2) = Rep_stone_phi_pair y"
         using prod.collapse by blast
       have "x1 \<le> y1"
         using 1 2 by (metis less_eq_stone_phi_pair.rep_eq stone_phi.pairs_less_eq.simps)
       hence "--x1 \<le> --y1 \<and> ?r (-y1) \<le> ?r (-x1)"
         by (metis compl_le_compl_iff le_iff_sup simp_phi)
       hence "triple.pairs_less_eq (--x1,?r (-x1)) (--y1,?r (-y1))"
         by simp
       hence "triple.pairs_less_eq (?pp f (x1,x2)) (?pp f (y1,y2))"
         by (simp add: triple.pairs_uminus.simps triple_def)
       hence "triple.pairs_less_eq (?q f x) (?q f y)"
         using 2 by simp
       hence "if ?r = stone_phi then triple.pairs_less_eq (Rep_stone_phi_pair x) (Rep_stone_phi_pair y) else triple.pairs_less_eq (?q f x) (?q f y)"
         using 1 by (simp add: less_eq_stone_phi_pair.rep_eq)
       thus "triple.pairs_less_eq (if ?r = stone_phi then Rep_stone_phi_pair x else ?q f x) (if ?r = stone_phi then Rep_stone_phi_pair y else ?q f y)"
         by (simp add: if_distrib_2)
     qed
     hence "Abs_lifted_pair (\<lambda>f . if Rep_phi f = stone_phi then Rep_stone_phi_pair x else ?q f x) \<le> Abs_lifted_pair (\<lambda>f . if Rep_phi f = stone_phi then Rep_stone_phi_pair y else ?q f y)"
       by (subst less_eq_lifted_pair.abs_eq) (simp_all add: eq_onp_same_args stone_phi_embed_triple_pair)
     thus "stone_phi_embed x \<le> stone_phi_embed y"
       by simp
   qed
 qed
 
 text \<open>
 The following lemmas show that the embedding is injective and reflects the order.
 The latter allows us to easily inherit properties involving inequalities from the target of the embedding, without transforming them to equations.
 \<close>
 
 lemma stone_phi_embed_injective:
   "inj stone_phi_embed"
 proof (rule injI)
   fix x y :: "'a stone_phi_pair"
   have 1: "Rep_phi (Abs_phi stone_phi) = stone_phi"
     by (simp add: Abs_phi_inverse stone_phi.hom)
   assume 2: "stone_phi_embed x = stone_phi_embed y"
   have "\<forall>x::'a stone_phi_pair . Rep_lifted_pair (stone_phi_embed x) = (\<lambda>f . if Rep_phi f = stone_phi then Rep_stone_phi_pair x else triple.pairs_uminus (Rep_phi f) (triple.pairs_uminus (Rep_phi f) (Rep_stone_phi_pair x)))"
     by (simp add: Abs_lifted_pair_inverse stone_phi_embed_triple_pair)
   hence "(\<lambda>f . if Rep_phi f = stone_phi then Rep_stone_phi_pair x else triple.pairs_uminus (Rep_phi f) (triple.pairs_uminus (Rep_phi f) (Rep_stone_phi_pair x))) = (\<lambda>f . if Rep_phi f = stone_phi then Rep_stone_phi_pair y else triple.pairs_uminus (Rep_phi f) (triple.pairs_uminus (Rep_phi f) (Rep_stone_phi_pair y)))"
     using 2 by metis
   hence "Rep_stone_phi_pair x = Rep_stone_phi_pair y"
     using 1 by metis
   thus "x = y"
     by (simp add: Rep_stone_phi_pair_inject)
 qed
 
 lemma stone_phi_embed_order_injective:
   assumes "stone_phi_embed x \<le> stone_phi_embed y"
     shows "x \<le> y"
 proof -
   let ?f = "Abs_phi stone_phi"
   have "\<forall>f . triple.pairs_less_eq (if Rep_phi f = stone_phi then Rep_stone_phi_pair x else triple.pairs_uminus (Rep_phi f) (triple.pairs_uminus (Rep_phi f) (Rep_stone_phi_pair x))) (if Rep_phi f = stone_phi then Rep_stone_phi_pair y else triple.pairs_uminus (Rep_phi f) (triple.pairs_uminus (Rep_phi f) (Rep_stone_phi_pair y)))"
     using assms by (subst less_eq_lifted_pair.abs_eq[THEN sym]) (simp_all add: eq_onp_same_args stone_phi_embed_triple_pair)
   hence "triple.pairs_less_eq (if Rep_phi ?f = (stone_phi::'a regular \<Rightarrow> 'a dense_filter) then Rep_stone_phi_pair x else triple.pairs_uminus (Rep_phi ?f) (triple.pairs_uminus (Rep_phi ?f) (Rep_stone_phi_pair x))) (if Rep_phi ?f = (stone_phi::'a regular \<Rightarrow> 'a dense_filter) then Rep_stone_phi_pair y else triple.pairs_uminus (Rep_phi ?f) (triple.pairs_uminus (Rep_phi ?f) (Rep_stone_phi_pair y)))"
     by simp
   hence "triple.pairs_less_eq (Rep_stone_phi_pair x) (Rep_stone_phi_pair y)"
     by (simp add: Abs_phi_inverse stone_phi.hom)
   thus "x \<le> y"
     by (simp add: less_eq_stone_phi_pair.rep_eq)
 qed
 
+lemma stone_phi_embed_strict_order_isomorphism:
+  "x < y \<longleftrightarrow> stone_phi_embed x < stone_phi_embed y"
+  by (smt less_eq_stone_phi_pair.rep_eq less_le_not_le less_stone_phi_pair.rep_eq stone_phi.pairs_less.elims(2,3) stone_phi_embed_homomorphism stone_phi_embed_order_injective)
+
 text \<open>
 Now all Stone algebra axioms can be inherited using the embedding.
 This is due to the fact that the axioms are universally quantified equations or conditional equations (or inequalities); this is called a quasivariety in universal algebra.
 It would be useful to have this construction available for arbitrary quasivarieties.
 \<close>
 
 instantiation stone_phi_pair :: (non_trivial_stone_algebra) stone_algebra
 begin
 
 instance
   apply intro_classes
-  apply (simp add: less_stone_phi_pair.rep_eq less_eq_stone_phi_pair.rep_eq)
+  apply (metis (mono_tags, lifting) stone_phi_embed_homomorphism stone_phi_embed_strict_order_isomorphism stone_phi_embed_order_injective less_le_not_le)
   apply (simp add: stone_phi_embed_order_injective)
   apply (meson order.trans stone_phi_embed_homomorphism stone_phi_embed_order_injective)
   apply (meson stone_phi_embed_homomorphism antisym stone_phi_embed_injective injD)
   apply (metis inf.sup_ge1 stone_phi_embed_homomorphism stone_phi_embed_order_injective)
   apply (metis inf.sup_ge2 stone_phi_embed_homomorphism stone_phi_embed_order_injective)
   apply (metis inf_greatest stone_phi_embed_homomorphism stone_phi_embed_order_injective)
   apply (metis stone_phi_embed_homomorphism stone_phi_embed_order_injective sup_ge1)
   apply (metis stone_phi_embed_homomorphism stone_phi_embed_order_injective sup.cobounded2)
   apply (metis stone_phi_embed_homomorphism stone_phi_embed_order_injective sup_least)
   apply (metis bot.extremum stone_phi_embed_homomorphism stone_phi_embed_order_injective)
   apply (metis stone_phi_embed_homomorphism stone_phi_embed_order_injective top_greatest)
   apply (metis (mono_tags, lifting) stone_phi_embed_homomorphism sup_inf_distrib1 stone_phi_embed_injective injD)
   apply (metis stone_phi_embed_homomorphism stone_phi_embed_injective injD stone_phi_embed_order_injective pseudo_complement)
   by (metis injD stone_phi_embed_homomorphism stone_phi_embed_injective stone)
 
 end
 
 subsection \<open>Stone Algebra Isomorphism\<close>
 
 text \<open>
 In this section we prove that the Stone algebra of the triple of a Stone algebra is isomorphic to the original Stone algebra.
 The following two definitions give the isomorphism.
 \<close>
 
 abbreviation sa_iso_inv :: "'a::non_trivial_stone_algebra stone_phi_pair \<Rightarrow> 'a"
   where "sa_iso_inv \<equiv> \<lambda>p . Rep_regular (fst (Rep_stone_phi_pair p)) \<sqinter> Rep_dense (triple.rho_pair stone_phi (Rep_stone_phi_pair p))"
 
 abbreviation sa_iso :: "'a::non_trivial_stone_algebra \<Rightarrow> 'a stone_phi_pair"
   where "sa_iso \<equiv> \<lambda>x . Abs_stone_phi_pair (Abs_regular (--x),stone_phi (Abs_regular (-x)) \<squnion> up_filter (Abs_dense (x \<squnion> -x)))"
 
 lemma sa_iso_triple_pair:
   "(Abs_regular (--x),stone_phi (Abs_regular (-x)) \<squnion> up_filter (Abs_dense (x \<squnion> -x))) \<in> triple.pairs stone_phi"
   by (metis (mono_tags, lifting) double_compl eq_onp_same_args stone_phi.sa_iso_pair uminus_regular.abs_eq)
 
 lemma stone_phi_inf_dense:
   "stone_phi (Abs_regular (-x)) \<sqinter> up_filter (Abs_dense (y \<squnion> -y)) \<le> up_filter (Abs_dense (y \<squnion> -y \<squnion> x))"
 proof -
   have "Rep_filter (stone_phi (Abs_regular (-x)) \<sqinter> up_filter (Abs_dense (y \<squnion> -y))) \<le> \<up>(Abs_dense (y \<squnion> -y \<squnion> x))"
   proof
     fix z :: "'a dense"
     let ?r = "Rep_dense z"
     assume "z \<in> Rep_filter (stone_phi (Abs_regular (-x)) \<sqinter> up_filter (Abs_dense (y \<squnion> -y)))"
     also have "... = Rep_filter (stone_phi (Abs_regular (-x))) \<inter> Rep_filter (up_filter (Abs_dense (y \<squnion> -y)))"
       by (simp add: inf_filter.rep_eq)
-    also have "... = stone_phi_set (Abs_regular (-x)) \<inter> \<up>(Abs_dense (y \<squnion> -y))"
-      by (metis Abs_filter_inverse mem_Collect_eq up_filter stone_phi_set_filter stone_phi_def)
+    also have "... = stone_phi_base (Abs_regular (-x)) \<inter> \<up>(Abs_dense (y \<squnion> -y))"
+      by (metis Abs_filter_inverse mem_Collect_eq up_filter stone_phi_base_filter stone_phi_def)
     finally have "--x \<le> ?r \<and> Abs_dense (y \<squnion> -y) \<le> z"
       by (metis (mono_tags, lifting) Abs_regular_inverse Int_Collect mem_Collect_eq)
     hence "--x \<le> ?r \<and> y \<squnion> -y \<le> ?r"
       by (simp add: Abs_dense_inverse less_eq_dense.rep_eq)
     hence "y \<squnion> -y \<squnion> x \<le> ?r"
       using order_trans pp_increasing by auto
     hence "Abs_dense (y \<squnion> -y \<squnion> x) \<le> Abs_dense ?r"
       by (subst less_eq_dense.abs_eq) (simp_all add: eq_onp_same_args)
     thus "z \<in> \<up>(Abs_dense (y \<squnion> -y \<squnion> x))"
       by (simp add: Rep_dense_inverse)
   qed
   hence "Abs_filter (Rep_filter (stone_phi (Abs_regular (-x)) \<sqinter> up_filter (Abs_dense (y \<squnion> -y)))) \<le> up_filter (Abs_dense (y \<squnion> -y \<squnion> x))"
     by (simp add: eq_onp_same_args less_eq_filter.abs_eq)
   thus ?thesis
     by (simp add: Rep_filter_inverse)
 qed
 
 lemma stone_phi_complement:
   "complement (stone_phi (Abs_regular (-x))) (stone_phi (Abs_regular (--x)))"
   by (metis (mono_tags, lifting) eq_onp_same_args stone_phi.phi_complemented uminus_regular.abs_eq)
 
 lemma up_dense_stone_phi:
   "up_filter (Abs_dense (x \<squnion> -x)) \<le> stone_phi (Abs_regular (--x))"
 proof -
-  have "\<up>(Abs_dense (x \<squnion> -x)) \<le> stone_phi_set (Abs_regular (--x))"
+  have "\<up>(Abs_dense (x \<squnion> -x)) \<le> stone_phi_base (Abs_regular (--x))"
   proof
     fix z :: "'a dense"
     let ?r = "Rep_dense z"
     assume "z \<in> \<up>(Abs_dense (x \<squnion> -x))"
     hence "---x \<le> ?r"
       by (simp add: Abs_dense_inverse less_eq_dense.rep_eq)
     hence "-Rep_regular (Abs_regular (--x)) \<le> ?r"
       by (metis (mono_tags, lifting) Abs_regular_inverse mem_Collect_eq)
-    thus "z \<in> stone_phi_set (Abs_regular (--x))"
+    thus "z \<in> stone_phi_base (Abs_regular (--x))"
       by simp
   qed
   thus ?thesis
-    by (unfold stone_phi_def, subst less_eq_filter.abs_eq, simp_all add: eq_onp_same_args stone_phi_set_filter)
+    by (unfold stone_phi_def, subst less_eq_filter.abs_eq, simp_all add: eq_onp_same_args stone_phi_base_filter)
 qed
 
 text \<open>
 The following two results prove that the isomorphisms are mutually inverse.
 \<close>
 
 lemma sa_iso_left_invertible:
   "sa_iso_inv (sa_iso x) = x"
 proof -
   have "up_filter (triple.rho_pair stone_phi (Abs_regular (--x),stone_phi (Abs_regular (-x)) \<squnion> up_filter (Abs_dense (x \<squnion> -x)))) = stone_phi (Abs_regular (--x)) \<sqinter> (stone_phi (Abs_regular (-x)) \<squnion> up_filter (Abs_dense (x \<squnion> -x)))"
     using sa_iso_triple_pair stone_phi.get_rho_pair_char by blast
   also have "... = stone_phi (Abs_regular (--x)) \<sqinter> up_filter (Abs_dense (x \<squnion> -x))"
     by (simp add: inf.sup_commute inf_sup_distrib1 stone_phi_complement)
   also have "... = up_filter (Abs_dense (x \<squnion> -x))"
     using up_dense_stone_phi inf.absorb2 by auto
   finally have 1: "triple.rho_pair stone_phi (Abs_regular (--x),stone_phi (Abs_regular (-x)) \<squnion> up_filter (Abs_dense (x \<squnion> -x))) = Abs_dense (x \<squnion> -x)"
     using up_filter_injective by auto
   have "sa_iso_inv (sa_iso x) = (\<lambda>p . Rep_regular (fst p) \<sqinter> Rep_dense (triple.rho_pair stone_phi p)) (Abs_regular (--x),stone_phi (Abs_regular (-x)) \<squnion> up_filter (Abs_dense (x \<squnion> -x)))"
     by (simp add: Abs_stone_phi_pair_inverse sa_iso_triple_pair)
   also have "... = Rep_regular (Abs_regular (--x)) \<sqinter> Rep_dense (triple.rho_pair stone_phi (Abs_regular (--x),stone_phi (Abs_regular (-x)) \<squnion> up_filter (Abs_dense (x \<squnion> -x))))"
     by simp
   also have "... = --x \<sqinter> Rep_dense (Abs_dense (x \<squnion> -x))"
     using 1 by (subst Abs_regular_inverse) auto
   also have "... = --x \<sqinter> (x \<squnion> -x)"
     by (subst Abs_dense_inverse) simp_all
   also have "... = x"
     by simp
   finally show ?thesis
     by auto
 qed
 
 lemma sa_iso_right_invertible:
   "sa_iso (sa_iso_inv p) = p"
 proof -
   obtain x y where 1: "(x,y) = Rep_stone_phi_pair p"
     using prod.collapse by blast
   hence 2: "(x,y) \<in> triple.pairs stone_phi"
     by (simp add: Rep_stone_phi_pair)
   hence 3: "stone_phi (-x) \<le> y"
     by (simp add: stone_phi.pairs_phi_less_eq)
   have 4: "\<forall>z . z \<in> Rep_filter (stone_phi x \<sqinter> y) \<longrightarrow> -Rep_regular x \<le> Rep_dense z"
   proof (rule allI, rule impI)
     fix z :: "'a dense"
     let ?r = "Rep_dense z"
     assume "z \<in> Rep_filter (stone_phi x \<sqinter> y)"
     hence "z \<in> Rep_filter (stone_phi x)"
       by (simp add: inf_filter.rep_eq)
-    also have "... = stone_phi_set x"
-      by (simp add: stone_phi_def Abs_filter_inverse stone_phi_set_filter)
+    also have "... = stone_phi_base x"
+      by (simp add: stone_phi_def Abs_filter_inverse stone_phi_base_filter)
     finally show "-Rep_regular x \<le> ?r"
       by simp
   qed
   have "triple.rho_pair stone_phi (x,y) \<in> \<up>(triple.rho_pair stone_phi (x,y))"
     by simp
   also have "... = Rep_filter (Abs_filter (\<up>(triple.rho_pair stone_phi (x,y))))"
     by (simp add: Abs_filter_inverse)
   also have "... = Rep_filter (stone_phi x \<sqinter> y)"
     using 2 stone_phi.get_rho_pair_char by fastforce
   finally have "triple.rho_pair stone_phi (x,y) \<in> Rep_filter (stone_phi x \<sqinter> y)"
     by simp
   hence 5: "-Rep_regular x \<le> Rep_dense (triple.rho_pair stone_phi (x,y))"
     using 4 by simp
   have 6: "sa_iso_inv p = Rep_regular x \<sqinter> Rep_dense (triple.rho_pair stone_phi (x,y))"
     using 1 by (metis fstI)
   hence "-sa_iso_inv p = -Rep_regular x"
     by simp
   hence "sa_iso (sa_iso_inv p) = Abs_stone_phi_pair (Abs_regular (--Rep_regular x),stone_phi (Abs_regular (-Rep_regular x)) \<squnion> up_filter (Abs_dense ((Rep_regular x \<sqinter> Rep_dense (triple.rho_pair stone_phi (x,y))) \<squnion> -Rep_regular x)))"
     using 6 by simp
   also have "... = Abs_stone_phi_pair (x,stone_phi (-x) \<squnion> up_filter (Abs_dense ((Rep_regular x \<sqinter> Rep_dense (triple.rho_pair stone_phi (x,y))) \<squnion> -Rep_regular x)))"
     by (metis (mono_tags, lifting) Rep_regular_inverse double_compl uminus_regular.rep_eq)
   also have "... = Abs_stone_phi_pair (x,stone_phi (-x) \<squnion> up_filter (Abs_dense (Rep_dense (triple.rho_pair stone_phi (x,y)) \<squnion> -Rep_regular x)))"
     by (metis inf_sup_aci(5) maddux_3_21_pp simp_regular)
   also have "... = Abs_stone_phi_pair (x,stone_phi (-x) \<squnion> up_filter (Abs_dense (Rep_dense (triple.rho_pair stone_phi (x,y)))))"
     using 5 by (simp add: sup.absorb1)
   also have "... = Abs_stone_phi_pair (x,stone_phi (-x) \<squnion> up_filter (triple.rho_pair stone_phi (x,y)))"
     by (simp add: Rep_dense_inverse)
   also have "... = Abs_stone_phi_pair (x,stone_phi (-x) \<squnion> (stone_phi x \<sqinter> y))"
     using 2 stone_phi.get_rho_pair_char by fastforce
   also have "... = Abs_stone_phi_pair (x,stone_phi (-x) \<squnion> y)"
     by (simp add: stone_phi.phi_complemented sup.commute sup_inf_distrib1)
   also have "... = Abs_stone_phi_pair (x,y)"
     using 3 by (simp add: le_iff_sup)
   also have "... = p"
     using 1 by (simp add: Rep_stone_phi_pair_inverse)
   finally show ?thesis
     .
 qed
 
 text \<open>
 It remains to show the homomorphism properties, which is done in the following result.
 \<close>
 
 lemma sa_iso:
   "stone_algebra_isomorphism sa_iso"
 proof (intro conjI)
   have "Abs_stone_phi_pair (Abs_regular (--bot),stone_phi (Abs_regular (-bot)) \<squnion> up_filter (Abs_dense (bot \<squnion> -bot))) = Abs_stone_phi_pair (bot,stone_phi top \<squnion> up_filter top)"
     by (simp add: bot_regular.abs_eq top_regular.abs_eq top_dense.abs_eq)
   also have "... = Abs_stone_phi_pair (bot,stone_phi top)"
     by (simp add: stone_phi.hom)
   also have "... = bot"
     by (simp add: bot_stone_phi_pair_def stone_phi.phi_top)
   finally show "sa_iso bot = bot"
     .
 next
   have "Abs_stone_phi_pair (Abs_regular (--top),stone_phi (Abs_regular (-top)) \<squnion> up_filter (Abs_dense (top \<squnion> -top))) = Abs_stone_phi_pair (top,stone_phi bot \<squnion> up_filter top)"
     by (simp add: bot_regular.abs_eq top_regular.abs_eq top_dense.abs_eq)
   also have "... = top"
     by (simp add: stone_phi.phi_bot top_stone_phi_pair_def)
   finally show "sa_iso top = top"
     .
 next
   have 1: "\<forall>x y::'a . dense (x \<squnion> -x \<squnion> y)"
     by simp
   have 2: "\<forall>x y::'a . up_filter (Abs_dense (x \<squnion> -x \<squnion> y)) \<le> (stone_phi (Abs_regular (-x)) \<squnion> up_filter (Abs_dense (x \<squnion> -x))) \<sqinter> (stone_phi (Abs_regular (-y)) \<squnion> up_filter (Abs_dense (y \<squnion> -y)))"
   proof (intro allI)
     fix x y :: 'a
     let ?u = "Abs_dense (x \<squnion> -x \<squnion> --y)"
     let ?v = "Abs_dense (y \<squnion> -y)"
     have "\<up>(Abs_dense (x \<squnion> -x \<squnion> y)) \<le> Rep_filter (stone_phi (Abs_regular (-y)) \<squnion> up_filter ?v)"
     proof
       fix z
       assume "z \<in> \<up>(Abs_dense (x \<squnion> -x \<squnion> y))"
       hence "Abs_dense (x \<squnion> -x \<squnion> y) \<le> z"
         by simp
       hence 3: "x \<squnion> -x \<squnion> y \<le> Rep_dense z"
         by (simp add: Abs_dense_inverse less_eq_dense.rep_eq)
       have "y \<le> x \<squnion> -x \<squnion> --y"
         by (simp add: le_supI2 pp_increasing)
       hence "(x \<squnion> -x \<squnion> --y) \<sqinter> (y \<squnion> -y) = y \<squnion> ((x \<squnion> -x \<squnion> --y) \<sqinter> -y)"
         by (simp add: le_iff_sup sup_inf_distrib1)
       also have "... = y \<squnion> ((x \<squnion> -x) \<sqinter> -y)"
         by (simp add: inf_commute inf_sup_distrib1)
       also have "... \<le> Rep_dense z"
         using 3 by (meson le_infI1 sup.bounded_iff)
       finally have "Abs_dense ((x \<squnion> -x \<squnion> --y) \<sqinter> (y \<squnion> -y)) \<le> z"
         by (simp add: Abs_dense_inverse less_eq_dense.rep_eq)
       hence 4: "?u \<sqinter> ?v \<le> z"
         by (simp add: eq_onp_same_args inf_dense.abs_eq)
       have "-Rep_regular (Abs_regular (-y)) = --y"
         by (metis (mono_tags, lifting) mem_Collect_eq Abs_regular_inverse)
       also have "... \<le> Rep_dense ?u"
         by (simp add: Abs_dense_inverse)
-      finally have "?u \<in> stone_phi_set (Abs_regular (-y))"
+      finally have "?u \<in> stone_phi_base (Abs_regular (-y))"
         by simp
       hence 5: "?u \<in> Rep_filter (stone_phi (Abs_regular (-y)))"
-        by (metis mem_Collect_eq stone_phi_def stone_phi_set_filter Abs_filter_inverse)
+        by (metis mem_Collect_eq stone_phi_def stone_phi_base_filter Abs_filter_inverse)
       have "?v \<in> \<up>?v"
         by simp
       hence "?v \<in> Rep_filter (up_filter ?v)"
         by (metis Abs_filter_inverse mem_Collect_eq up_filter)
       thus "z \<in> Rep_filter (stone_phi (Abs_regular (-y)) \<squnion> up_filter ?v)"
-        using 4 5 sup_filter.rep_eq by blast
+        using 4 5 sup_filter.rep_eq filter_sup_def by blast
     qed
     hence "up_filter (Abs_dense (x \<squnion> -x \<squnion> y)) \<le> Abs_filter (Rep_filter (stone_phi (Abs_regular (-y)) \<squnion> up_filter ?v))"
       by (simp add: eq_onp_same_args less_eq_filter.abs_eq)
     also have "... = stone_phi (Abs_regular (-y)) \<squnion> up_filter ?v"
       by (simp add: Rep_filter_inverse)
     finally show "up_filter (Abs_dense (x \<squnion> -x \<squnion> y)) \<le> (stone_phi (Abs_regular (-x)) \<squnion> up_filter (Abs_dense (x \<squnion> -x))) \<sqinter> (stone_phi (Abs_regular (-y)) \<squnion> up_filter (Abs_dense (y \<squnion> -y)))"
       by (metis le_infI le_supI2 sup_bot.right_neutral up_filter_dense_antitone)
   qed
   have 6: "\<forall>x::'a . in_p_image (-x)"
     by auto
   show "\<forall>x y::'a . sa_iso (x \<squnion> y) = sa_iso x \<squnion> sa_iso y"
   proof (intro allI)
     fix x y :: 'a
     have 7: "up_filter (Abs_dense (x \<squnion> -x)) \<sqinter> up_filter (Abs_dense (y \<squnion> -y)) \<le> up_filter (Abs_dense (y \<squnion> -y \<squnion> x))"
     proof -
       have "up_filter (Abs_dense (x \<squnion> -x)) \<sqinter> up_filter (Abs_dense (y \<squnion> -y)) = up_filter (Abs_dense (x \<squnion> -x) \<squnion> Abs_dense (y \<squnion> -y))"
         by (metis up_filter_dist_sup)
       also have "... = up_filter (Abs_dense (x \<squnion> -x \<squnion> (y \<squnion> -y)))"
         by (subst sup_dense.abs_eq) (simp_all add: eq_onp_same_args)
       also have "... = up_filter (Abs_dense (y \<squnion> -y \<squnion> x \<squnion> -x))"
         by (simp add: sup_commute sup_left_commute)
       also have "... \<le> up_filter (Abs_dense (y \<squnion> -y \<squnion> x))"
         using up_filter_dense_antitone by auto
       finally show ?thesis
         .
     qed
     have "Abs_dense (x \<squnion> y \<squnion> -(x \<squnion> y)) = Abs_dense ((x \<squnion> -x \<squnion> y) \<sqinter> (y \<squnion> -y \<squnion> x))"
       by (simp add: sup_commute sup_inf_distrib1 sup_left_commute)
     also have "... = Abs_dense (x \<squnion> -x \<squnion> y) \<sqinter> Abs_dense (y \<squnion> -y \<squnion> x)"
       using 1 by (metis (mono_tags, lifting) Abs_dense_inverse Rep_dense_inverse inf_dense.rep_eq mem_Collect_eq)
     finally have 8: "up_filter (Abs_dense (x \<squnion> y \<squnion> -(x \<squnion> y))) = up_filter (Abs_dense (x \<squnion> -x \<squnion> y)) \<squnion> up_filter (Abs_dense (y \<squnion> -y \<squnion> x))"
       by (simp add: up_filter_dist_inf)
     also have "... \<le> (stone_phi (Abs_regular (-x)) \<squnion> up_filter (Abs_dense (x \<squnion> -x))) \<sqinter> (stone_phi (Abs_regular (-y)) \<squnion> up_filter (Abs_dense (y \<squnion> -y)))"
       using 2 by (simp add: inf.sup_commute le_sup_iff)
     finally have 9: "(stone_phi (Abs_regular (-x)) \<sqinter> stone_phi (Abs_regular (-y))) \<squnion> up_filter (Abs_dense (x \<squnion> y \<squnion> -(x \<squnion> y))) \<le> ..."
       by (simp add: le_supI1)
     have "... = (stone_phi (Abs_regular (-x)) \<sqinter> stone_phi (Abs_regular (-y))) \<squnion> (stone_phi (Abs_regular (-x)) \<sqinter> up_filter (Abs_dense (y \<squnion> -y))) \<squnion> ((up_filter (Abs_dense (x \<squnion> -x)) \<sqinter> stone_phi (Abs_regular (-y))) \<squnion> (up_filter (Abs_dense (x \<squnion> -x)) \<sqinter> up_filter (Abs_dense (y \<squnion> -y))))"
       by (metis (no_types) inf_sup_distrib1 inf_sup_distrib2)
     also have "... \<le> (stone_phi (Abs_regular (-x)) \<sqinter> stone_phi (Abs_regular (-y))) \<squnion> up_filter (Abs_dense (y \<squnion> -y \<squnion> x)) \<squnion> ((up_filter (Abs_dense (x \<squnion> -x)) \<sqinter> stone_phi (Abs_regular (-y))) \<squnion> (up_filter (Abs_dense (x \<squnion> -x)) \<sqinter> up_filter (Abs_dense (y \<squnion> -y))))"
       by (meson sup_left_isotone sup_right_isotone stone_phi_inf_dense)
     also have "... \<le> (stone_phi (Abs_regular (-x)) \<sqinter> stone_phi (Abs_regular (-y))) \<squnion> up_filter (Abs_dense (y \<squnion> -y \<squnion> x)) \<squnion> (up_filter (Abs_dense (x \<squnion> -x \<squnion> y)) \<squnion> (up_filter (Abs_dense (x \<squnion> -x)) \<sqinter> up_filter (Abs_dense (y \<squnion> -y))))"
       by (metis inf.commute sup_left_isotone sup_right_isotone stone_phi_inf_dense)
     also have "... \<le> (stone_phi (Abs_regular (-x)) \<sqinter> stone_phi (Abs_regular (-y))) \<squnion> up_filter (Abs_dense (y \<squnion> -y \<squnion> x)) \<squnion> up_filter (Abs_dense (x \<squnion> -x \<squnion> y))"
       using 7 by (simp add: sup.absorb1 sup_commute sup_left_commute)
     also have "... = (stone_phi (Abs_regular (-x)) \<sqinter> stone_phi (Abs_regular (-y))) \<squnion> up_filter (Abs_dense (x \<squnion> y \<squnion> -(x \<squnion> y)))"
       using 8 by (simp add: sup.commute sup.left_commute)
     finally have "(stone_phi (Abs_regular (-x)) \<squnion> up_filter (Abs_dense (x \<squnion> -x))) \<sqinter> (stone_phi (Abs_regular (-y)) \<squnion> up_filter (Abs_dense (y \<squnion> -y))) = ..."
       using 9 using antisym by blast
     also have "... = stone_phi (Abs_regular (-x) \<sqinter> Abs_regular (-y)) \<squnion> up_filter (Abs_dense (x \<squnion> y \<squnion> -(x \<squnion> y)))"
       by (simp add: stone_phi.hom)
     also have "... = stone_phi (Abs_regular (-(x \<squnion> y))) \<squnion> up_filter (Abs_dense (x \<squnion> y \<squnion> -(x \<squnion> y)))"
       using 6 by (subst inf_regular.abs_eq) (simp_all add: eq_onp_same_args)
     finally have 10: "stone_phi (Abs_regular (-(x \<squnion> y))) \<squnion> up_filter (Abs_dense (x \<squnion> y \<squnion> -(x \<squnion> y))) = (stone_phi (Abs_regular (-x)) \<squnion> up_filter (Abs_dense (x \<squnion> -x))) \<sqinter> (stone_phi (Abs_regular (-y)) \<squnion> up_filter (Abs_dense (y \<squnion> -y)))"
       by simp
     have "Abs_regular (--(x \<squnion> y)) = Abs_regular (--x) \<squnion> Abs_regular (--y)"
       using 6 by (subst sup_regular.abs_eq) (simp_all add: eq_onp_same_args)
     hence "Abs_stone_phi_pair (Abs_regular (--(x \<squnion> y)),stone_phi (Abs_regular (-(x \<squnion> y))) \<squnion> up_filter (Abs_dense (x \<squnion> y \<squnion> -(x \<squnion> y)))) = Abs_stone_phi_pair (triple.pairs_sup (Abs_regular (--x),stone_phi (Abs_regular (-x)) \<squnion> up_filter (Abs_dense (x \<squnion> -x))) (Abs_regular (--y),stone_phi (Abs_regular (-y)) \<squnion> up_filter (Abs_dense (y \<squnion> -y))))"
       using 10 by auto
     also have "... = Abs_stone_phi_pair (Abs_regular (--x),stone_phi (Abs_regular (-x)) \<squnion> up_filter (Abs_dense (x \<squnion> -x))) \<squnion> Abs_stone_phi_pair (Abs_regular (--y),stone_phi (Abs_regular (-y)) \<squnion> up_filter (Abs_dense (y \<squnion> -y)))"
       by (rule sup_stone_phi_pair.abs_eq[THEN sym]) (simp_all add: eq_onp_same_args sa_iso_triple_pair)
     finally show "sa_iso (x \<squnion> y) = sa_iso x \<squnion> sa_iso y"
       .
   qed
 next
   have 1: "\<forall>x y::'a . dense (x \<squnion> -x \<squnion> y)"
     by simp
   have 2: "\<forall>x::'a . in_p_image (-x)"
     by auto
   have 3: "\<forall>x y::'a . stone_phi (Abs_regular (-y)) \<squnion> up_filter (Abs_dense (x \<squnion> -x)) = stone_phi (Abs_regular (-y)) \<squnion> up_filter (Abs_dense (x \<squnion> -x \<squnion> -y))"
   proof (intro allI)
     fix x y :: 'a
     have 4: "up_filter (Abs_dense (x \<squnion> -x)) \<le> stone_phi (Abs_regular (-y)) \<squnion> up_filter (Abs_dense (x \<squnion> -x \<squnion> -y))"
       by (metis (no_types, lifting) complement_shunting stone_phi_inf_dense stone_phi_complement complement_symmetric)
     have "up_filter (Abs_dense (x \<squnion> -x \<squnion> -y)) \<le> up_filter (Abs_dense (x \<squnion> -x))"
       by (metis sup_idem up_filter_dense_antitone)
     thus "stone_phi (Abs_regular (-y)) \<squnion> up_filter (Abs_dense (x \<squnion> -x)) = stone_phi (Abs_regular (-y)) \<squnion> up_filter (Abs_dense (x \<squnion> -x \<squnion> -y))"
       using 4 by (simp add: le_iff_sup sup_commute sup_left_commute)
   qed
   show "\<forall>x y::'a . sa_iso (x \<sqinter> y) = sa_iso x \<sqinter> sa_iso y"
   proof (intro allI)
     fix x y :: 'a
     have "Abs_dense ((x \<sqinter> y) \<squnion> -(x \<sqinter> y)) = Abs_dense ((x \<squnion> -x \<squnion> -y) \<sqinter> (y \<squnion> -y \<squnion> -x))"
       by (simp add: sup_commute sup_inf_distrib1 sup_left_commute)
     also have "... = Abs_dense (x \<squnion> -x \<squnion> -y) \<sqinter> Abs_dense (y \<squnion> -y \<squnion> -x)"
       using 1 by (metis (mono_tags, lifting) Abs_dense_inverse Rep_dense_inverse inf_dense.rep_eq mem_Collect_eq)
     finally have 5: "up_filter (Abs_dense ((x \<sqinter> y) \<squnion> -(x \<sqinter> y))) = up_filter (Abs_dense (x \<squnion> -x \<squnion> -y)) \<squnion> up_filter (Abs_dense (y \<squnion> -y \<squnion> -x))"
       by (simp add: up_filter_dist_inf)
     have "(stone_phi (Abs_regular (-x)) \<squnion> up_filter (Abs_dense (x \<squnion> -x))) \<squnion> (stone_phi (Abs_regular (-y)) \<squnion> up_filter (Abs_dense (y \<squnion> -y))) = (stone_phi (Abs_regular (-y)) \<squnion> up_filter (Abs_dense (x \<squnion> -x))) \<squnion> (stone_phi (Abs_regular (-x)) \<squnion> up_filter (Abs_dense (y \<squnion> -y)))"
       by (simp add: inf_sup_aci(6) sup_left_commute)
     also have "... = (stone_phi (Abs_regular (-y)) \<squnion> up_filter (Abs_dense (x \<squnion> -x \<squnion> -y))) \<squnion> (stone_phi (Abs_regular (-x)) \<squnion> up_filter (Abs_dense (y \<squnion> -y \<squnion> -x)))"
       using 3 by simp
     also have "... = (stone_phi (Abs_regular (-x)) \<squnion> stone_phi (Abs_regular (-y))) \<squnion> (up_filter (Abs_dense (x \<squnion> -x \<squnion> -y)) \<squnion> up_filter (Abs_dense (y \<squnion> -y \<squnion> -x)))"
       by (simp add: inf_sup_aci(6) sup_left_commute)
     also have "... = (stone_phi (Abs_regular (-x)) \<squnion> stone_phi (Abs_regular (-y))) \<squnion> up_filter (Abs_dense ((x \<sqinter> y) \<squnion> -(x \<sqinter> y)))"
       using 5 by (simp add: sup.commute sup.left_commute)
     finally have "(stone_phi (Abs_regular (-x)) \<squnion> up_filter (Abs_dense (x \<squnion> -x))) \<squnion> (stone_phi (Abs_regular (-y)) \<squnion> up_filter (Abs_dense (y \<squnion> -y))) = ..."
       by simp
     also have "... = stone_phi (Abs_regular (-x) \<squnion> Abs_regular (-y)) \<squnion> up_filter (Abs_dense ((x \<sqinter> y) \<squnion> -(x \<sqinter> y)))"
       by (simp add: stone_phi.hom)
     also have "... = stone_phi (Abs_regular (-(x \<sqinter> y))) \<squnion> up_filter (Abs_dense ((x \<sqinter> y) \<squnion> -(x \<sqinter> y)))"
       using 2 by (subst sup_regular.abs_eq) (simp_all add: eq_onp_same_args)
     finally have 6: "stone_phi (Abs_regular (-(x \<sqinter> y))) \<squnion> up_filter (Abs_dense ((x \<sqinter> y) \<squnion> -(x \<sqinter> y))) = (stone_phi (Abs_regular (-x)) \<squnion> up_filter (Abs_dense (x \<squnion> -x))) \<squnion> (stone_phi (Abs_regular (-y)) \<squnion> up_filter (Abs_dense (y \<squnion> -y)))"
       by simp
     have "Abs_regular (--(x \<sqinter> y)) = Abs_regular (--x) \<sqinter> Abs_regular (--y)"
       using 2 by (subst inf_regular.abs_eq) (simp_all add: eq_onp_same_args)
     hence "Abs_stone_phi_pair (Abs_regular (--(x \<sqinter> y)),stone_phi (Abs_regular (-(x \<sqinter> y))) \<squnion> up_filter (Abs_dense ((x \<sqinter> y) \<squnion> -(x \<sqinter> y)))) = Abs_stone_phi_pair (triple.pairs_inf (Abs_regular (--x),stone_phi (Abs_regular (-x)) \<squnion> up_filter (Abs_dense (x \<squnion> -x))) (Abs_regular (--y),stone_phi (Abs_regular (-y)) \<squnion> up_filter (Abs_dense (y \<squnion> -y))))"
       using 6 by auto
     also have "... = Abs_stone_phi_pair (Abs_regular (--x),stone_phi (Abs_regular (-x)) \<squnion> up_filter (Abs_dense (x \<squnion> -x))) \<sqinter> Abs_stone_phi_pair (Abs_regular (--y),stone_phi (Abs_regular (-y)) \<squnion> up_filter (Abs_dense (y \<squnion> -y)))"
       by (rule inf_stone_phi_pair.abs_eq[THEN sym]) (simp_all add: eq_onp_same_args sa_iso_triple_pair)
     finally show "sa_iso (x \<sqinter> y) = sa_iso x \<sqinter> sa_iso y"
       .
   qed
 next
   show "\<forall>x::'a . sa_iso (-x) = -sa_iso x"
   proof
     fix x :: 'a
     have "sa_iso (-x) = Abs_stone_phi_pair (Abs_regular (---x),stone_phi (Abs_regular (--x)) \<squnion> up_filter top)"
       by (simp add: top_dense_def)
     also have "... = Abs_stone_phi_pair (Abs_regular (---x),stone_phi (Abs_regular (--x)))"
       by (metis bot_filter.abs_eq sup_bot.right_neutral up_top)
     also have "... = Abs_stone_phi_pair (triple.pairs_uminus stone_phi (Abs_regular (--x),stone_phi (Abs_regular (-x)) \<squnion> up_filter (Abs_dense (x \<squnion> -x))))"
       by (subst uminus_regular.abs_eq[THEN sym], unfold eq_onp_same_args) auto
     also have "... = -sa_iso x"
       by (simp add: eq_onp_def sa_iso_triple_pair uminus_stone_phi_pair.abs_eq)
     finally show "sa_iso (-x) = -sa_iso x"
       by simp
   qed
 next
   show "bij sa_iso"
     by (metis (mono_tags, lifting) sa_iso_left_invertible sa_iso_right_invertible invertible_bij[where g=sa_iso_inv])
 qed
 
 subsection \<open>Triple Isomorphism\<close>
 
 text \<open>
 In this section we prove that the triple of the Stone algebra of a triple is isomorphic to the original triple.
 The notion of isomorphism for triples is described in \cite{ChenGraetzer1969}.
 It amounts to an isomorphism of Boolean algebras, an isomorphism of distributive lattices with a greatest element, and a commuting diagram involving the structure maps.
 \<close>
 
 subsubsection \<open>Boolean Algebra Isomorphism\<close>
 
 text \<open>
 We first define and prove the isomorphism of Boolean algebras.
 Because the Stone algebra of a triple is implemented as a lifted pair, we also lift the Boolean algebra.
 \<close>
 
 typedef (overloaded) ('a,'b) lifted_boolean_algebra = "{ xf::('a::non_trivial_boolean_algebra,'b::distrib_lattice_top) phi \<Rightarrow> 'a . True }"
   by simp
 
 setup_lifting type_definition_lifted_boolean_algebra
 
 instantiation lifted_boolean_algebra :: (non_trivial_boolean_algebra,distrib_lattice_top) boolean_algebra
 begin
 
 lift_definition sup_lifted_boolean_algebra :: "('a,'b) lifted_boolean_algebra \<Rightarrow> ('a,'b) lifted_boolean_algebra \<Rightarrow> ('a,'b) lifted_boolean_algebra" is "\<lambda>xf yf f . sup (xf f) (yf f)" .
 
 lift_definition inf_lifted_boolean_algebra :: "('a,'b) lifted_boolean_algebra \<Rightarrow> ('a,'b) lifted_boolean_algebra \<Rightarrow> ('a,'b) lifted_boolean_algebra" is "\<lambda>xf yf f . inf (xf f) (yf f)" .
 
 lift_definition minus_lifted_boolean_algebra :: "('a,'b) lifted_boolean_algebra \<Rightarrow> ('a,'b) lifted_boolean_algebra \<Rightarrow> ('a,'b) lifted_boolean_algebra" is "\<lambda>xf yf f . minus (xf f) (yf f)" .
 
 lift_definition uminus_lifted_boolean_algebra :: "('a,'b) lifted_boolean_algebra \<Rightarrow> ('a,'b) lifted_boolean_algebra" is "\<lambda>xf f . uminus (xf f)" .
 
 lift_definition bot_lifted_boolean_algebra :: "('a,'b) lifted_boolean_algebra" is "\<lambda>f . bot" ..
 
 lift_definition top_lifted_boolean_algebra :: "('a,'b) lifted_boolean_algebra" is "\<lambda>f . top" ..
 
 lift_definition less_eq_lifted_boolean_algebra :: "('a,'b) lifted_boolean_algebra \<Rightarrow> ('a,'b) lifted_boolean_algebra \<Rightarrow> bool" is "\<lambda>xf yf . \<forall>f . less_eq (xf f) (yf f)" .
 
 lift_definition less_lifted_boolean_algebra :: "('a,'b) lifted_boolean_algebra \<Rightarrow> ('a,'b) lifted_boolean_algebra \<Rightarrow> bool" is "\<lambda>xf yf . (\<forall>f . less_eq (xf f) (yf f)) \<and> \<not> (\<forall>f . less_eq (yf f) (xf f))" .
 
 instance
   apply intro_classes
-  apply (simp add: less_eq_lifted_boolean_algebra.rep_eq less_lifted_boolean_algebra.rep_eq)
-  apply (simp add: less_eq_lifted_boolean_algebra.rep_eq)
-  using less_eq_lifted_boolean_algebra.rep_eq order_trans apply fastforce
-  apply (metis less_eq_lifted_boolean_algebra.rep_eq antisym ext Rep_lifted_boolean_algebra_inject)
-  apply (simp add: inf_lifted_boolean_algebra.rep_eq less_eq_lifted_boolean_algebra.rep_eq)
-  apply (simp add: inf_lifted_boolean_algebra.rep_eq less_eq_lifted_boolean_algebra.rep_eq)
-  apply (simp add: inf_lifted_boolean_algebra.rep_eq less_eq_lifted_boolean_algebra.rep_eq)
-  apply (simp add: sup_lifted_boolean_algebra.rep_eq less_eq_lifted_boolean_algebra.rep_eq)
-  apply (simp add: less_eq_lifted_boolean_algebra.rep_eq sup_lifted_boolean_algebra.rep_eq)
-  apply (simp add: less_eq_lifted_boolean_algebra.rep_eq sup_lifted_boolean_algebra.rep_eq)
-  apply (simp add: bot_lifted_boolean_algebra.rep_eq less_eq_lifted_boolean_algebra.rep_eq)
-  apply (simp add: less_eq_lifted_boolean_algebra.rep_eq top_lifted_boolean_algebra.rep_eq)
-  apply (unfold Rep_lifted_boolean_algebra_inject[THEN sym] sup_lifted_boolean_algebra.rep_eq inf_lifted_boolean_algebra.rep_eq, simp add: sup_inf_distrib1)
-  apply (unfold Rep_lifted_boolean_algebra_inject[THEN sym] inf_lifted_boolean_algebra.rep_eq uminus_lifted_boolean_algebra.rep_eq bot_lifted_boolean_algebra.rep_eq, simp)
-  apply (unfold Rep_lifted_boolean_algebra_inject[THEN sym] sup_lifted_boolean_algebra.rep_eq uminus_lifted_boolean_algebra.rep_eq top_lifted_boolean_algebra.rep_eq, simp)
-  by (unfold Rep_lifted_boolean_algebra_inject[THEN sym] inf_lifted_boolean_algebra.rep_eq uminus_lifted_boolean_algebra.rep_eq minus_lifted_boolean_algebra.rep_eq, simp add: diff_eq)
+  subgoal apply transfer by auto
+  subgoal apply transfer by auto
+  subgoal apply transfer using order_trans by blast
+  subgoal apply transfer using antisym ext by blast
+  subgoal apply transfer by auto
+  subgoal apply transfer by auto
+  subgoal apply transfer by auto
+  subgoal apply transfer by auto
+  subgoal apply transfer by auto
+  subgoal apply transfer by auto
+  subgoal apply transfer by auto
+  subgoal apply transfer by auto
+  subgoal apply transfer by (simp add: sup_inf_distrib1)
+  subgoal apply transfer by auto
+  subgoal apply transfer by auto
+  subgoal apply transfer by (simp add: diff_eq)
+  done
 
 end
 
 text \<open>
 The following two definitions give the Boolean algebra isomorphism.
 \<close>
 
 abbreviation ba_iso_inv :: "('a::non_trivial_boolean_algebra,'b::distrib_lattice_top) lifted_boolean_algebra \<Rightarrow> ('a,'b) lifted_pair regular"
   where "ba_iso_inv \<equiv> \<lambda>xf . Abs_regular (Abs_lifted_pair (\<lambda>f . (Rep_lifted_boolean_algebra xf f,Rep_phi f (-Rep_lifted_boolean_algebra xf f))))"
 
 abbreviation ba_iso :: "('a::non_trivial_boolean_algebra,'b::distrib_lattice_top) lifted_pair regular \<Rightarrow> ('a,'b) lifted_boolean_algebra"
   where "ba_iso \<equiv> \<lambda>pf . Abs_lifted_boolean_algebra (\<lambda>f . fst (Rep_lifted_pair (Rep_regular pf) f))"
 
 lemma ba_iso_inv_lifted_pair:
   "(Rep_lifted_boolean_algebra xf f,Rep_phi f (-Rep_lifted_boolean_algebra xf f)) \<in> triple.pairs (Rep_phi f)"
   by (metis (no_types, hide_lams) double_compl simp_phi triple.pairs_uminus.simps triple_def triple.pairs_uminus_closed)
 
 lemma ba_iso_inv_regular:
   "regular (Abs_lifted_pair (\<lambda>f . (Rep_lifted_boolean_algebra xf f,Rep_phi f (-Rep_lifted_boolean_algebra xf f))))"
 proof -
   have "\<forall>f . (Rep_lifted_boolean_algebra xf f,Rep_phi f (-Rep_lifted_boolean_algebra xf f)) = triple.pairs_uminus (Rep_phi f) (triple.pairs_uminus (Rep_phi f) (Rep_lifted_boolean_algebra xf f,Rep_phi f (-Rep_lifted_boolean_algebra xf f)))"
     by (simp add: triple.pairs_uminus.simps triple_def)
   hence "Abs_lifted_pair (\<lambda>f . (Rep_lifted_boolean_algebra xf f,Rep_phi f (-Rep_lifted_boolean_algebra xf f))) = --Abs_lifted_pair (\<lambda>f . (Rep_lifted_boolean_algebra xf f,Rep_phi f (-Rep_lifted_boolean_algebra xf f)))"
     by (simp add: triple.pairs_uminus_closed triple_def eq_onp_def uminus_lifted_pair.abs_eq ba_iso_inv_lifted_pair)
   thus ?thesis
     by simp
 qed
 
 text \<open>
 The following two results prove that the isomorphisms are mutually inverse.
 \<close>
 
 lemma ba_iso_left_invertible:
   "ba_iso_inv (ba_iso pf) = pf"
 proof -
   have 1: "\<forall>f . snd (Rep_lifted_pair (Rep_regular pf) f) = Rep_phi f (-fst (Rep_lifted_pair (Rep_regular pf) f))"
   proof
     fix f :: "('a,'b) phi"
     let ?r = "Rep_phi f"
     have "triple ?r"
       by (simp add: triple_def)
     hence 2: "\<forall>p . triple.pairs_uminus ?r p = (-fst p,?r (fst p))"
       by (metis prod.collapse triple.pairs_uminus.simps)
     have 3: "Rep_regular pf = --Rep_regular pf"
       by (simp add: regular_in_p_image_iff)
     show "snd (Rep_lifted_pair (Rep_regular pf) f) = ?r (-fst (Rep_lifted_pair (Rep_regular pf) f))"
       using 2 3 by (metis fstI sndI uminus_lifted_pair.rep_eq)
   qed
   have "ba_iso_inv (ba_iso pf) = Abs_regular (Abs_lifted_pair (\<lambda>f . (fst (Rep_lifted_pair (Rep_regular pf) f),Rep_phi f (-fst (Rep_lifted_pair (Rep_regular pf) f)))))"
     by (simp add: Abs_lifted_boolean_algebra_inverse)
   also have "... = Abs_regular (Abs_lifted_pair (Rep_lifted_pair (Rep_regular pf)))"
     using 1 by (metis prod.collapse)
   also have "... = pf"
     by (simp add: Rep_regular_inverse Rep_lifted_pair_inverse)
   finally show ?thesis
     .
 qed
 
 lemma ba_iso_right_invertible:
   "ba_iso (ba_iso_inv xf) = xf"
 proof -
   let ?rf = "Rep_lifted_boolean_algebra xf"
   have 1: "\<forall>f . (-?rf f,Rep_phi f (?rf f)) \<in> triple.pairs (Rep_phi f) \<and> (?rf f,Rep_phi f (-?rf f)) \<in> triple.pairs (Rep_phi f)"
   proof
     fix f
     have "up_filter top = bot"
       by (simp add: bot_filter.abs_eq)
     hence "(\<exists>z . Rep_phi f (?rf f) = Rep_phi f (?rf f) \<squnion> up_filter z) \<and> (\<exists>z . Rep_phi f (-?rf f) = Rep_phi f (-?rf f) \<squnion> up_filter z)"
       by (metis sup_bot_right)
     thus "(-?rf f,Rep_phi f (?rf f)) \<in> triple.pairs (Rep_phi f) \<and> (?rf f,Rep_phi f (-?rf f)) \<in> triple.pairs (Rep_phi f)"
       by (simp add: triple_def triple.pairs_def)
   qed
   have "regular (Abs_lifted_pair (\<lambda>f . (?rf f,Rep_phi f (-?rf f))))"
   proof -
     have "--Abs_lifted_pair (\<lambda>f . (?rf f,Rep_phi f (-?rf f))) = -Abs_lifted_pair (\<lambda>f . triple.pairs_uminus (Rep_phi f) (?rf f,Rep_phi f (-?rf f)))"
       using 1 by (simp add: eq_onp_same_args uminus_lifted_pair.abs_eq)
     also have "... = -Abs_lifted_pair (\<lambda>f . (-?rf f,Rep_phi f (?rf f)))"
       by (metis (no_types, lifting) simp_phi triple_def triple.pairs_uminus.simps)
     also have "... = Abs_lifted_pair (\<lambda>f . triple.pairs_uminus (Rep_phi f) (-?rf f,Rep_phi f (?rf f)))"
       using 1 by (simp add: eq_onp_same_args uminus_lifted_pair.abs_eq)
     also have "... = Abs_lifted_pair (\<lambda>f . (?rf f,Rep_phi f (-?rf f)))"
       by (metis (no_types, lifting) simp_phi triple_def triple.pairs_uminus.simps double_compl)
     finally show ?thesis
       by simp
   qed
   hence "in_p_image (Abs_lifted_pair (\<lambda>f . (?rf f,Rep_phi f (-?rf f))))"
     by blast
   thus ?thesis
     using 1 by (simp add: Rep_lifted_boolean_algebra_inverse Abs_lifted_pair_inverse Abs_regular_inverse)
 qed
 
 text \<open>
 The isomorphism is established by proving the remaining Boolean algebra homomorphism properties.
 \<close>
 
 lemma ba_iso:
   "boolean_algebra_isomorphism ba_iso"
 proof (intro conjI)
   show "Abs_lifted_boolean_algebra (\<lambda>f . fst (Rep_lifted_pair (Rep_regular bot) f)) = bot"
     by (simp add: bot_lifted_boolean_algebra_def bot_regular.rep_eq bot_lifted_pair.rep_eq)
-next
   show "Abs_lifted_boolean_algebra (\<lambda>f . fst (Rep_lifted_pair (Rep_regular top) f)) = top"
     by (simp add: top_lifted_boolean_algebra_def top_regular.rep_eq top_lifted_pair.rep_eq)
-next
   show "\<forall>pf qf . Abs_lifted_boolean_algebra (\<lambda>f::('a,'b) phi . fst (Rep_lifted_pair (Rep_regular (pf \<squnion> qf)) f)) = Abs_lifted_boolean_algebra (\<lambda>f . fst (Rep_lifted_pair (Rep_regular pf) f)) \<squnion> Abs_lifted_boolean_algebra (\<lambda>f . fst (Rep_lifted_pair (Rep_regular qf) f))"
   proof (intro allI)
     fix pf qf :: "('a,'b) lifted_pair regular"
     {
       fix f
       obtain x y z w where 1: "(x,y) = Rep_lifted_pair (Rep_regular pf) f \<and> (z,w) = Rep_lifted_pair (Rep_regular qf) f"
         using prod.collapse by blast
       have "triple (Rep_phi f)"
         by (simp add: triple_def)
       hence "fst (triple.pairs_sup (x,y) (z,w)) = fst (x,y) \<squnion> fst (z,w)"
         using triple.pairs_sup.simps by force
       hence "fst (triple.pairs_sup (Rep_lifted_pair (Rep_regular pf) f) (Rep_lifted_pair (Rep_regular qf) f)) = fst (Rep_lifted_pair (Rep_regular pf) f) \<squnion> fst (Rep_lifted_pair (Rep_regular qf) f)"
         using 1 by simp
       hence "fst (Rep_lifted_pair (Rep_regular (pf \<squnion> qf)) f) = fst (Rep_lifted_pair (Rep_regular pf) f) \<squnion> fst (Rep_lifted_pair (Rep_regular qf) f)"
         by (unfold sup_regular.rep_eq sup_lifted_pair.rep_eq) simp
     }
     thus "Abs_lifted_boolean_algebra (\<lambda>f . fst (Rep_lifted_pair (Rep_regular (pf \<squnion> qf)) f)) = Abs_lifted_boolean_algebra (\<lambda>f . fst (Rep_lifted_pair (Rep_regular pf) f)) \<squnion> Abs_lifted_boolean_algebra (\<lambda>f . fst (Rep_lifted_pair (Rep_regular qf) f))"
       by (simp add: eq_onp_same_args sup_lifted_boolean_algebra.abs_eq sup_regular.rep_eq sup_lifted_boolean_algebra.rep_eq)
   qed
-next
-  show "\<forall>pf qf . Abs_lifted_boolean_algebra (\<lambda>f::('a,'b) phi . fst (Rep_lifted_pair (Rep_regular (pf \<sqinter> qf)) f)) = Abs_lifted_boolean_algebra (\<lambda>f . fst (Rep_lifted_pair (Rep_regular pf) f)) \<sqinter> Abs_lifted_boolean_algebra (\<lambda>f . fst (Rep_lifted_pair (Rep_regular qf) f))"
+  show 1: "\<forall>pf qf . Abs_lifted_boolean_algebra (\<lambda>f::('a,'b) phi . fst (Rep_lifted_pair (Rep_regular (pf \<sqinter> qf)) f)) = Abs_lifted_boolean_algebra (\<lambda>f . fst (Rep_lifted_pair (Rep_regular pf) f)) \<sqinter> Abs_lifted_boolean_algebra (\<lambda>f . fst (Rep_lifted_pair (Rep_regular qf) f))"
   proof (intro allI)
     fix pf qf :: "('a,'b) lifted_pair regular"
     {
       fix f
       obtain x y z w where 1: "(x,y) = Rep_lifted_pair (Rep_regular pf) f \<and> (z,w) = Rep_lifted_pair (Rep_regular qf) f"
         using prod.collapse by blast
       have "triple (Rep_phi f)"
         by (simp add: triple_def)
       hence "fst (triple.pairs_inf (x,y) (z,w)) = fst (x,y) \<sqinter> fst (z,w)"
         using triple.pairs_inf.simps by force
       hence "fst (triple.pairs_inf (Rep_lifted_pair (Rep_regular pf) f) (Rep_lifted_pair (Rep_regular qf) f)) = fst (Rep_lifted_pair (Rep_regular pf) f) \<sqinter> fst (Rep_lifted_pair (Rep_regular qf) f)"
         using 1 by simp
       hence "fst (Rep_lifted_pair (Rep_regular (pf \<sqinter> qf)) f) = fst (Rep_lifted_pair (Rep_regular pf) f) \<sqinter> fst (Rep_lifted_pair (Rep_regular qf) f)"
         by (unfold inf_regular.rep_eq inf_lifted_pair.rep_eq) simp
     }
     thus "Abs_lifted_boolean_algebra (\<lambda>f . fst (Rep_lifted_pair (Rep_regular (pf \<sqinter> qf)) f)) = Abs_lifted_boolean_algebra (\<lambda>f . fst (Rep_lifted_pair (Rep_regular pf) f)) \<sqinter> Abs_lifted_boolean_algebra (\<lambda>f . fst (Rep_lifted_pair (Rep_regular qf) f))"
       by (simp add: eq_onp_same_args inf_lifted_boolean_algebra.abs_eq inf_regular.rep_eq inf_lifted_boolean_algebra.rep_eq)
   qed
-next
   show "\<forall>pf . Abs_lifted_boolean_algebra (\<lambda>f::('a,'b) phi . fst (Rep_lifted_pair (Rep_regular (-pf)) f)) = -Abs_lifted_boolean_algebra (\<lambda>f . fst (Rep_lifted_pair (Rep_regular pf) f))"
   proof
     fix pf :: "('a,'b) lifted_pair regular"
     {
       fix f
       obtain x y where 1: "(x,y) = Rep_lifted_pair (Rep_regular pf) f"
         using prod.collapse by blast
       have "triple (Rep_phi f)"
         by (simp add: triple_def)
       hence "fst (triple.pairs_uminus (Rep_phi f) (x,y)) = -fst (x,y)"
         using triple.pairs_uminus.simps by force
       hence "fst (triple.pairs_uminus (Rep_phi f) (Rep_lifted_pair (Rep_regular pf) f)) = -fst (Rep_lifted_pair (Rep_regular pf) f)"
         using 1 by simp
       hence "fst (Rep_lifted_pair (Rep_regular (-pf)) f) = -fst (Rep_lifted_pair (Rep_regular pf) f)"
         by (unfold uminus_regular.rep_eq uminus_lifted_pair.rep_eq) simp
     }
     thus "Abs_lifted_boolean_algebra (\<lambda>f . fst (Rep_lifted_pair (Rep_regular (-pf)) f)) = -Abs_lifted_boolean_algebra (\<lambda>f . fst (Rep_lifted_pair (Rep_regular pf) f))"
       by (simp add: eq_onp_same_args uminus_lifted_boolean_algebra.abs_eq uminus_regular.rep_eq uminus_lifted_boolean_algebra.rep_eq)
   qed
-next
+  thus "\<forall>pf qf . Abs_lifted_boolean_algebra (\<lambda>f::('a,'b) phi . fst (Rep_lifted_pair (Rep_regular (pf - qf)) f)) = Abs_lifted_boolean_algebra (\<lambda>f . fst (Rep_lifted_pair (Rep_regular pf) f)) - Abs_lifted_boolean_algebra (\<lambda>f . fst (Rep_lifted_pair (Rep_regular qf) f))"
+    using 1 by (simp add: diff_eq)
   show "bij ba_iso"
     by (rule invertible_bij[where g=ba_iso_inv]) (simp_all add: ba_iso_left_invertible ba_iso_right_invertible)
 qed
 
 subsubsection \<open>Distributive Lattice Isomorphism\<close>
 
 text \<open>
 We carry out a similar development for the isomorphism of distributive lattices.
 Again, the original distributive lattice with a greatest element needs to be lifted to match the lifted pairs.
 \<close>
 
 typedef (overloaded) ('a,'b) lifted_distrib_lattice_top = "{ xf::('a::non_trivial_boolean_algebra,'b::distrib_lattice_top) phi \<Rightarrow> 'b . True }"
   by simp
 
 setup_lifting type_definition_lifted_distrib_lattice_top
 
 instantiation lifted_distrib_lattice_top :: (non_trivial_boolean_algebra,distrib_lattice_top) distrib_lattice_top
 begin
 
 lift_definition sup_lifted_distrib_lattice_top :: "('a,'b) lifted_distrib_lattice_top \<Rightarrow> ('a,'b) lifted_distrib_lattice_top \<Rightarrow> ('a,'b) lifted_distrib_lattice_top" is "\<lambda>xf yf f . sup (xf f) (yf f)" .
 
 lift_definition inf_lifted_distrib_lattice_top :: "('a,'b) lifted_distrib_lattice_top \<Rightarrow> ('a,'b) lifted_distrib_lattice_top \<Rightarrow> ('a,'b) lifted_distrib_lattice_top" is "\<lambda>xf yf f . inf (xf f) (yf f)" .
 
 lift_definition top_lifted_distrib_lattice_top :: "('a,'b) lifted_distrib_lattice_top" is "\<lambda>f . top" ..
 
 lift_definition less_eq_lifted_distrib_lattice_top :: "('a,'b) lifted_distrib_lattice_top \<Rightarrow> ('a,'b) lifted_distrib_lattice_top \<Rightarrow> bool" is "\<lambda>xf yf . \<forall>f . less_eq (xf f) (yf f)" .
 
 lift_definition less_lifted_distrib_lattice_top :: "('a,'b) lifted_distrib_lattice_top \<Rightarrow> ('a,'b) lifted_distrib_lattice_top \<Rightarrow> bool" is "\<lambda>xf yf . (\<forall>f . less_eq (xf f) (yf f)) \<and> \<not> (\<forall>f . less_eq (yf f) (xf f))" .
 
 instance
   apply intro_classes
-  apply (simp add: less_eq_lifted_distrib_lattice_top.rep_eq less_lifted_distrib_lattice_top.rep_eq)
-  apply (simp add: less_eq_lifted_distrib_lattice_top.rep_eq)
-  using less_eq_lifted_distrib_lattice_top.rep_eq order_trans apply fastforce
-  apply (metis less_eq_lifted_distrib_lattice_top.rep_eq antisym ext Rep_lifted_distrib_lattice_top_inject)
-  apply (simp add: inf_lifted_distrib_lattice_top.rep_eq less_eq_lifted_distrib_lattice_top.rep_eq)
-  apply (simp add: inf_lifted_distrib_lattice_top.rep_eq less_eq_lifted_distrib_lattice_top.rep_eq)
-  apply (simp add: inf_lifted_distrib_lattice_top.rep_eq less_eq_lifted_distrib_lattice_top.rep_eq)
-  apply (simp add: sup_lifted_distrib_lattice_top.rep_eq less_eq_lifted_distrib_lattice_top.rep_eq)
-  apply (simp add: less_eq_lifted_distrib_lattice_top.rep_eq sup_lifted_distrib_lattice_top.rep_eq)
-  apply (simp add: less_eq_lifted_distrib_lattice_top.rep_eq sup_lifted_distrib_lattice_top.rep_eq)
-  apply (simp add: less_eq_lifted_distrib_lattice_top.rep_eq top_lifted_distrib_lattice_top.rep_eq)
-  by (unfold Rep_lifted_distrib_lattice_top_inject[THEN sym] sup_lifted_distrib_lattice_top.rep_eq inf_lifted_distrib_lattice_top.rep_eq, simp add: sup_inf_distrib1)
+  subgoal apply transfer by auto
+  subgoal apply transfer by auto
+  subgoal apply transfer using order_trans by blast
+  subgoal apply transfer using antisym ext by blast
+  subgoal apply transfer by auto
+  subgoal apply transfer by auto
+  subgoal apply transfer by auto
+  subgoal apply transfer by auto
+  subgoal apply transfer by auto
+  subgoal apply transfer by auto
+  subgoal apply transfer by auto
+  subgoal apply transfer by (simp add: sup_inf_distrib1)
+  done
 
 end
 
 text \<open>
 The following function extracts the least element of the filter of a dense pair, which turns out to be a principal filter.
 It is used to define one of the isomorphisms below.
 \<close>
 
 fun get_dense :: "('a::non_trivial_boolean_algebra,'b::distrib_lattice_top) lifted_pair dense \<Rightarrow> ('a,'b) phi \<Rightarrow> 'b"
   where "get_dense pf f = (SOME z . Rep_lifted_pair (Rep_dense pf) f = (top,up_filter z))"
 
 lemma get_dense_char:
   "Rep_lifted_pair (Rep_dense pf) f = (top,up_filter (get_dense pf f))"
 proof -
   obtain x y where 1: "(x,y) = Rep_lifted_pair (Rep_dense pf) f \<and> (x,y) \<in> triple.pairs (Rep_phi f) \<and> triple.pairs_uminus (Rep_phi f) (x,y) = triple.pairs_bot"
     by (metis bot_lifted_pair.rep_eq prod.collapse simp_dense simp_lifted_pair uminus_lifted_pair.rep_eq)
   hence 2: "x = top"
     by (simp add: triple.intro triple.pairs_uminus.simps dense_pp)
   have "triple (Rep_phi f)"
     by (simp add: triple_def)
   hence "\<exists>z. y = Rep_phi f (-x) \<squnion> up_filter z"
     using 1 triple.pairs_def by blast
   then obtain z where "y = up_filter z"
     using 2 by auto
   hence "Rep_lifted_pair (Rep_dense pf) f = (top,up_filter z)"
     using 1 2 by simp
   thus ?thesis
     by (metis (mono_tags, lifting) tfl_some get_dense.simps)
 qed
 
 text \<open>
 The following two definitions give the distributive lattice isomorphism.
 \<close>
 
 abbreviation dl_iso_inv :: "('a::non_trivial_boolean_algebra,'b::distrib_lattice_top) lifted_distrib_lattice_top \<Rightarrow> ('a,'b) lifted_pair dense"
   where "dl_iso_inv \<equiv> \<lambda>xf . Abs_dense (Abs_lifted_pair (\<lambda>f . (top,up_filter (Rep_lifted_distrib_lattice_top xf f))))"
 
 abbreviation dl_iso :: "('a::non_trivial_boolean_algebra,'b::distrib_lattice_top) lifted_pair dense \<Rightarrow> ('a,'b) lifted_distrib_lattice_top"
   where "dl_iso \<equiv> \<lambda>pf . Abs_lifted_distrib_lattice_top (get_dense pf)"
 
 lemma dl_iso_inv_lifted_pair:
   "(top,up_filter (Rep_lifted_distrib_lattice_top xf f)) \<in> triple.pairs (Rep_phi f)"
   by (metis (no_types, hide_lams) compl_bot_eq double_compl simp_phi sup_bot.left_neutral triple.sa_iso_pair triple_def)
 
 lemma dl_iso_inv_dense:
   "dense (Abs_lifted_pair (\<lambda>f . (top,up_filter (Rep_lifted_distrib_lattice_top xf f))))"
 proof -
   have "\<forall>f . triple.pairs_uminus (Rep_phi f) (top,up_filter (Rep_lifted_distrib_lattice_top xf f)) = triple.pairs_bot"
     by (simp add: top_filter.abs_eq triple.pairs_uminus.simps triple_def)
   hence "bot = -Abs_lifted_pair (\<lambda>f . (top,up_filter (Rep_lifted_distrib_lattice_top xf f)))"
     by (simp add: eq_onp_def uminus_lifted_pair.abs_eq dl_iso_inv_lifted_pair bot_lifted_pair_def)
   thus ?thesis
     by simp
 qed
 
 text \<open>
 The following two results prove that the isomorphisms are mutually inverse.
 \<close>
 
 lemma dl_iso_left_invertible:
   "dl_iso_inv (dl_iso pf) = pf"
 proof -
   have "dl_iso_inv (dl_iso pf) = Abs_dense (Abs_lifted_pair (\<lambda>f . (top,up_filter (get_dense pf f))))"
     by (metis Abs_lifted_distrib_lattice_top_inverse UNIV_I UNIV_def)
   also have "... = Abs_dense (Abs_lifted_pair (Rep_lifted_pair (Rep_dense pf)))"
     by (metis get_dense_char)
   also have "... = pf"
     by (simp add: Rep_dense_inverse Rep_lifted_pair_inverse)
   finally show ?thesis
     .
 qed
 
 lemma dl_iso_right_invertible:
   "dl_iso (dl_iso_inv xf) = xf"
 proof -
   let ?rf = "Rep_lifted_distrib_lattice_top xf"
   let ?pf = "Abs_dense (Abs_lifted_pair (\<lambda>f . (top,up_filter (?rf f))))"
   have 1: "\<forall>f . (top,up_filter (?rf f)) \<in> triple.pairs (Rep_phi f)"
   proof
     fix f :: "('a,'b) phi"
     have "triple (Rep_phi f)"
       by (simp add: triple_def)
     thus "(top,up_filter (?rf f)) \<in> triple.pairs (Rep_phi f)"
       using triple.pairs_def by force
   qed
   have 2: "dense (Abs_lifted_pair (\<lambda>f . (top,up_filter (?rf f))))"
   proof -
     have "-Abs_lifted_pair (\<lambda>f . (top,up_filter (?rf f))) = Abs_lifted_pair (\<lambda>f . triple.pairs_uminus (Rep_phi f) (top,up_filter (?rf f)))"
       using 1 by (simp add: eq_onp_same_args uminus_lifted_pair.abs_eq)
     also have "... = Abs_lifted_pair (\<lambda>f . (bot,Rep_phi f top))"
       by (simp add: triple.pairs_uminus.simps triple_def)
     also have "... = Abs_lifted_pair (\<lambda>f . triple.pairs_bot)"
       by (metis (no_types, hide_lams) simp_phi triple.phi_top triple_def)
     also have "... = bot"
       by (simp add: bot_lifted_pair_def)
     finally show ?thesis
       by simp
   qed
   have "get_dense ?pf = ?rf"
   proof
     fix f
     have "(top,up_filter (get_dense ?pf f)) = Rep_lifted_pair (Rep_dense ?pf) f"
       by (metis get_dense_char)
     also have "... = Rep_lifted_pair (Abs_lifted_pair (\<lambda>f . (top,up_filter (?rf f)))) f"
       using Abs_dense_inverse 2 by force
     also have "... = (top,up_filter (?rf f))"
       using 1 by (simp add: Abs_lifted_pair_inverse)
     finally show "get_dense ?pf f = ?rf f"
       using up_filter_injective by auto
   qed
   thus ?thesis
     by (simp add: Rep_lifted_distrib_lattice_top_inverse)
 qed
 
 text \<open>
 To obtain the isomorphism, it remains to show the homomorphism properties of lattices with a greatest element.
 \<close>
 
 lemma dl_iso:
   "bounded_lattice_top_isomorphism dl_iso"
 proof (intro conjI)
   have "get_dense top = (\<lambda>f::('a,'b) phi . top)"
   proof
     fix f :: "('a,'b) phi"
     have "Rep_lifted_pair (Rep_dense top) f = (top,Abs_filter {top})"
       by (simp add: top_dense.rep_eq top_lifted_pair.rep_eq)
     hence "up_filter (get_dense top f) = Abs_filter {top}"
       by (metis prod.inject get_dense_char)
     hence "Rep_filter (up_filter (get_dense top f)) = {top}"
       by (metis bot_filter.abs_eq bot_filter.rep_eq)
     thus "get_dense top f = top"
       by (metis self_in_upset singletonD Abs_filter_inverse mem_Collect_eq up_filter)
   qed
   thus "Abs_lifted_distrib_lattice_top (get_dense top::('a,'b) phi \<Rightarrow> 'b) = top"
     by (metis top_lifted_distrib_lattice_top_def)
 next
   show "\<forall>pf qf :: ('a,'b) lifted_pair dense . Abs_lifted_distrib_lattice_top (get_dense (pf \<squnion> qf)) = Abs_lifted_distrib_lattice_top (get_dense pf) \<squnion> Abs_lifted_distrib_lattice_top (get_dense qf)"
   proof (intro allI)
     fix pf qf :: "('a,'b) lifted_pair dense"
     have 1: "Abs_lifted_distrib_lattice_top (get_dense pf) \<squnion> Abs_lifted_distrib_lattice_top (get_dense qf) = Abs_lifted_distrib_lattice_top (\<lambda>f . get_dense pf f \<squnion> get_dense qf f)"
       by (simp add: eq_onp_same_args sup_lifted_distrib_lattice_top.abs_eq)
     have "(\<lambda>f . get_dense (pf \<squnion> qf) f) = (\<lambda>f . get_dense pf f \<squnion> get_dense qf f)"
     proof
       fix f
       have "(top,up_filter (get_dense (pf \<squnion> qf) f)) = Rep_lifted_pair (Rep_dense (pf \<squnion> qf)) f"
         by (metis get_dense_char)
       also have "... = triple.pairs_sup (Rep_lifted_pair (Rep_dense pf) f) (Rep_lifted_pair (Rep_dense qf) f)"
         by (simp add: sup_lifted_pair.rep_eq sup_dense.rep_eq)
       also have "... = triple.pairs_sup (top,up_filter (get_dense pf f)) (top,up_filter (get_dense qf f))"
         by (metis get_dense_char)
       also have "... = (top,up_filter (get_dense pf f) \<sqinter> up_filter (get_dense qf f))"
         by (metis (no_types, lifting) calculation prod.simps(1) simp_phi triple.pairs_sup.simps triple_def)
       also have "... = (top,up_filter (get_dense pf f \<squnion> get_dense qf f))"
         by (metis up_filter_dist_sup)
       finally show "get_dense (pf \<squnion> qf) f = get_dense pf f \<squnion> get_dense qf f"
         using up_filter_injective by blast
     qed
     thus "Abs_lifted_distrib_lattice_top (get_dense (pf \<squnion> qf)) = Abs_lifted_distrib_lattice_top (get_dense pf) \<squnion> Abs_lifted_distrib_lattice_top (get_dense qf)"
       using 1 by metis
   qed
 next
   show "\<forall>pf qf :: ('a,'b) lifted_pair dense . Abs_lifted_distrib_lattice_top (get_dense (pf \<sqinter> qf)) = Abs_lifted_distrib_lattice_top (get_dense pf) \<sqinter> Abs_lifted_distrib_lattice_top (get_dense qf)"
   proof (intro allI)
     fix pf qf :: "('a,'b) lifted_pair dense"
     have 1: "Abs_lifted_distrib_lattice_top (get_dense pf) \<sqinter> Abs_lifted_distrib_lattice_top (get_dense qf) = Abs_lifted_distrib_lattice_top (\<lambda>f . get_dense pf f \<sqinter> get_dense qf f)"
       by (simp add: eq_onp_same_args inf_lifted_distrib_lattice_top.abs_eq)
     have "(\<lambda>f . get_dense (pf \<sqinter> qf) f) = (\<lambda>f . get_dense pf f \<sqinter> get_dense qf f)"
     proof
       fix f
       have "(top,up_filter (get_dense (pf \<sqinter> qf) f)) = Rep_lifted_pair (Rep_dense (pf \<sqinter> qf)) f"
         by (metis get_dense_char)
       also have "... = triple.pairs_inf (Rep_lifted_pair (Rep_dense pf) f) (Rep_lifted_pair (Rep_dense qf) f)"
         by (simp add: inf_lifted_pair.rep_eq inf_dense.rep_eq)
       also have "... = triple.pairs_inf (top,up_filter (get_dense pf f)) (top,up_filter (get_dense qf f))"
         by (metis get_dense_char)
       also have "... = (top,up_filter (get_dense pf f) \<squnion> up_filter (get_dense qf f))"
         by (metis (no_types, lifting) calculation prod.simps(1) simp_phi triple.pairs_inf.simps triple_def)
       also have "... = (top,up_filter (get_dense pf f \<sqinter> get_dense qf f))"
         by (metis up_filter_dist_inf)
       finally show "get_dense (pf \<sqinter> qf) f = get_dense pf f \<sqinter> get_dense qf f"
         using up_filter_injective by blast
     qed
     thus "Abs_lifted_distrib_lattice_top (get_dense (pf \<sqinter> qf)) = Abs_lifted_distrib_lattice_top (get_dense pf) \<sqinter> Abs_lifted_distrib_lattice_top (get_dense qf)"
       using 1 by metis
   qed
 next
   show "bij dl_iso"
     by (rule invertible_bij[where g=dl_iso_inv]) (simp_all add: dl_iso_left_invertible dl_iso_right_invertible)
 qed
 
 subsubsection \<open>Structure Map Preservation\<close>
 
 text \<open>
 We finally show that the isomorphisms are compatible with the structure maps.
 This involves lifting the distributive lattice isomorphism to filters of distributive lattices (as these are the targets of the structure maps).
 To this end, we first show that the lifted isomorphism preserves filters.
 \<close>
 
 lemma phi_iso_filter:
   "filter ((\<lambda>qf::('a::non_trivial_boolean_algebra,'b::distrib_lattice_top) lifted_pair dense . Rep_lifted_distrib_lattice_top (dl_iso qf) f) ` Rep_filter (stone_phi pf))"
 proof (rule filter_map_filter)
   show "mono (\<lambda>qf::('a::non_trivial_boolean_algebra,'b::distrib_lattice_top) lifted_pair dense . Rep_lifted_distrib_lattice_top (dl_iso qf) f)"
     by (metis (no_types, lifting) mono_def dl_iso le_iff_sup sup_lifted_distrib_lattice_top.rep_eq)
 next
   show "\<forall>qf y . Rep_lifted_distrib_lattice_top (dl_iso qf) f \<le> y \<longrightarrow> (\<exists>rf . qf \<le> rf \<and> y = Rep_lifted_distrib_lattice_top (dl_iso rf) f)"
   proof (intro allI, rule impI)
     fix qf :: "('a,'b) lifted_pair dense"
     fix y :: 'b
     assume 1: "Rep_lifted_distrib_lattice_top (dl_iso qf) f \<le> y"
     let ?rf = "Abs_dense (Abs_lifted_pair (\<lambda>g . if g = f then (top,up_filter y) else Rep_lifted_pair (Rep_dense qf) g))"
     have 2: "\<forall>g . (if g = f then (top,up_filter y) else Rep_lifted_pair (Rep_dense qf) g) \<in> triple.pairs (Rep_phi g)"
       by (metis Abs_lifted_distrib_lattice_top_inverse dl_iso_inv_lifted_pair mem_Collect_eq simp_lifted_pair)
     hence "-Abs_lifted_pair (\<lambda>g . if g = f then (top,up_filter y) else Rep_lifted_pair (Rep_dense qf) g) = Abs_lifted_pair (\<lambda>g . triple.pairs_uminus (Rep_phi g) (if g = f then (top,up_filter y) else Rep_lifted_pair (Rep_dense qf) g))"
       by (simp add: eq_onp_def uminus_lifted_pair.abs_eq)
     also have "... = Abs_lifted_pair (\<lambda>g . if g = f then triple.pairs_uminus (Rep_phi g) (top,up_filter y) else triple.pairs_uminus (Rep_phi g) (Rep_lifted_pair (Rep_dense qf) g))"
       by (simp add: if_distrib)
     also have "... = Abs_lifted_pair (\<lambda>g . if g = f then (bot,top) else triple.pairs_uminus (Rep_phi g) (Rep_lifted_pair (Rep_dense qf) g))"
       by (subst triple.pairs_uminus.simps, simp add: triple_def, metis compl_top_eq simp_phi)
     also have "... = Abs_lifted_pair (\<lambda>g . if g = f then (bot,top) else (bot,top))"
       by (metis bot_lifted_pair.rep_eq simp_dense top_filter.abs_eq uminus_lifted_pair.rep_eq)
     also have "... = bot"
       by (simp add: bot_lifted_pair.abs_eq top_filter.abs_eq)
     finally have 3: "Abs_lifted_pair (\<lambda>g . if g = f then (top,up_filter y) else Rep_lifted_pair (Rep_dense qf) g) \<in> dense_elements"
       by blast
     hence "(top,up_filter (get_dense (Abs_dense (Abs_lifted_pair (\<lambda>g . if g = f then (top,up_filter y) else Rep_lifted_pair (Rep_dense qf) g))) f)) = Rep_lifted_pair (Rep_dense (Abs_dense (Abs_lifted_pair (\<lambda>g . if g = f then (top,up_filter y) else Rep_lifted_pair (Rep_dense qf) g)))) f"
       by (metis (mono_tags, lifting) get_dense_char)
     also have "... = Rep_lifted_pair (Abs_lifted_pair (\<lambda>g . if g = f then (top,up_filter y) else Rep_lifted_pair (Rep_dense qf) g)) f"
       using 3 by (simp add: Abs_dense_inverse)
     also have "... = (top,up_filter y)"
       using 2 by (simp add: Abs_lifted_pair_inverse)
     finally have "get_dense (Abs_dense (Abs_lifted_pair (\<lambda>g . if g = f then (top,up_filter y) else Rep_lifted_pair (Rep_dense qf) g))) f = y"
       using up_filter_injective by blast
     hence 4: "Rep_lifted_distrib_lattice_top (dl_iso ?rf) f = y"
       by (simp add: Abs_lifted_distrib_lattice_top_inverse)
     {
       fix g
       have "Rep_lifted_distrib_lattice_top (dl_iso qf) g \<le> Rep_lifted_distrib_lattice_top (dl_iso ?rf) g"
       proof (cases "g = f")
         assume "g = f"
         thus ?thesis
           using 1 4 by simp
       next
         assume 5: "g \<noteq> f"
         have "(top,up_filter (get_dense ?rf g)) = Rep_lifted_pair (Rep_dense (Abs_dense (Abs_lifted_pair (\<lambda>g . if g = f then (top,up_filter y) else Rep_lifted_pair (Rep_dense qf) g)))) g"
           by (metis (mono_tags, lifting) get_dense_char)
         also have "... = Rep_lifted_pair (Abs_lifted_pair (\<lambda>g . if g = f then (top,up_filter y) else Rep_lifted_pair (Rep_dense qf) g)) g"
           using 3 by (simp add: Abs_dense_inverse)
         also have "... = Rep_lifted_pair (Rep_dense qf) g"
           using 2 5 by (simp add: Abs_lifted_pair_inverse)
         also have "... = (top,up_filter (get_dense qf g))"
           using get_dense_char by auto
         finally have "get_dense ?rf g = get_dense qf g"
           using up_filter_injective by blast
         thus "Rep_lifted_distrib_lattice_top (dl_iso qf) g \<le> Rep_lifted_distrib_lattice_top (dl_iso ?rf) g"
           by (simp add: Abs_lifted_distrib_lattice_top_inverse)
       qed
     }
     hence "Rep_lifted_distrib_lattice_top (dl_iso qf) \<le> Rep_lifted_distrib_lattice_top (dl_iso ?rf)"
       by (simp add: le_funI)
     hence 6: "dl_iso qf \<le> dl_iso ?rf"
       by (simp add: le_funD less_eq_lifted_distrib_lattice_top.rep_eq)
     hence "qf \<le> ?rf"
       by (metis (no_types, lifting) dl_iso sup_isomorphism_ord_isomorphism)
     thus "\<exists>rf . qf \<le> rf \<and> y = Rep_lifted_distrib_lattice_top (dl_iso rf) f"
       using 4 by auto
   qed
 qed
 
 text \<open>
 The commutativity property states that the same result is obtained in two ways by starting with a regular lifted pair \<open>pf\<close>:
 \begin{itemize}
 \item apply the Boolean algebra isomorphism to the pair; then apply a structure map \<open>f\<close> to obtain a filter of dense elements; or,
 \item apply the structure map \<open>stone_phi\<close> to the pair; then apply the distributive lattice isomorphism lifted to the resulting filter.
 \end{itemize}
 \<close>
 
 lemma phi_iso:
   "Rep_phi f (Rep_lifted_boolean_algebra (ba_iso pf) f) = filter_map (\<lambda>qf::('a::non_trivial_boolean_algebra,'b::distrib_lattice_top) lifted_pair dense . Rep_lifted_distrib_lattice_top (dl_iso qf) f) (stone_phi pf)"
 proof -
   let ?r = "Rep_phi f"
   let ?ppf = "\<lambda>g . triple.pairs_uminus (Rep_phi g) (Rep_lifted_pair (Rep_regular pf) g)"
   have 1: "triple ?r"
     by (simp add: triple_def)
   have 2: "Rep_filter (?r (fst (Rep_lifted_pair (Rep_regular pf) f))) \<subseteq> { z . \<exists>qf . -Rep_regular pf \<le> Rep_dense qf \<and> z = get_dense qf f }"
   proof
     fix z
     obtain x where 3: "x = fst (Rep_lifted_pair (Rep_regular pf) f)"
       by simp
     assume "z \<in> Rep_filter (?r (fst (Rep_lifted_pair (Rep_regular pf) f)))"
     hence "\<up>z \<subseteq> Rep_filter (?r x)"
       using 3 filter_def by fastforce
     hence 4: "up_filter z \<le> ?r x"
       by (metis Rep_filter_cases Rep_filter_inverse less_eq_filter.rep_eq mem_Collect_eq up_filter)
     have 5: "\<forall>g . ?ppf g \<in> triple.pairs (Rep_phi g)"
       by (metis (no_types) simp_lifted_pair uminus_lifted_pair.rep_eq)
     let ?zf = "\<lambda>g . if g = f then (top,up_filter z) else triple.pairs_top"
     have 6: "\<forall>g . ?zf g \<in> triple.pairs (Rep_phi g)"
     proof
       fix g :: "('a,'b) phi"
       have "triple (Rep_phi g)"
         by (simp add: triple_def)
       hence "(top,up_filter z) \<in> triple.pairs (Rep_phi g)"
         using triple.pairs_def by force
       thus "?zf g \<in> triple.pairs (Rep_phi g)"
         by (metis simp_lifted_pair top_lifted_pair.rep_eq)
     qed
     hence "-Abs_lifted_pair ?zf = Abs_lifted_pair (\<lambda>g . triple.pairs_uminus (Rep_phi g) (?zf g))"
       by (subst uminus_lifted_pair.abs_eq) (simp_all add: eq_onp_same_args)
     also have "... = Abs_lifted_pair (\<lambda>g . if g = f then triple.pairs_uminus (Rep_phi g) (top,up_filter z) else triple.pairs_uminus (Rep_phi g) triple.pairs_top)"
       by (rule arg_cong[where f=Abs_lifted_pair]) auto
     also have "... = Abs_lifted_pair (\<lambda>g . triple.pairs_bot)"
       using 1 by (metis bot_lifted_pair.rep_eq dense_closed_top top_lifted_pair.rep_eq triple.pairs_uminus.simps uminus_lifted_pair.rep_eq)
     finally have 7: "Abs_lifted_pair ?zf \<in> dense_elements"
       by (simp add: bot_lifted_pair.abs_eq)
     let ?qf = "Abs_dense (Abs_lifted_pair ?zf)"
     have "\<forall>g . triple.pairs_less_eq (?ppf g) (?zf g)"
     proof
       fix g
       show "triple.pairs_less_eq (?ppf g) (?zf g)"
       proof (cases "g = f")
         assume 8: "g = f"
         hence 9: "?ppf g = (-x,?r x)"
           using 1 3 by (metis prod.collapse triple.pairs_uminus.simps)
         have "triple.pairs_less_eq (-x,?r x) (top,up_filter z)"
           using 1 4 by (meson inf.bot_least triple.pairs_less_eq.simps)
         thus ?thesis
           using 8 9 by simp
       next
         assume 10: "g \<noteq> f"
         have "triple.pairs_less_eq (?ppf g) triple.pairs_top"
           using 1 by (metis (no_types, hide_lams) bot.extremum top_greatest prod.collapse triple_def triple.pairs_less_eq.simps triple.phi_bot)
         thus ?thesis
           using 10 by simp
       qed
     qed
     hence "Abs_lifted_pair ?ppf \<le> Abs_lifted_pair ?zf"
       using 5 6 by (subst less_eq_lifted_pair.abs_eq) (simp_all add: eq_onp_same_args)
     hence 11: "-Rep_regular pf \<le> Rep_dense ?qf"
       using 7 by (simp add: uminus_lifted_pair_def Abs_dense_inverse)
     have "(top,up_filter (get_dense ?qf f)) = Rep_lifted_pair (Rep_dense ?qf) f"
       by (metis get_dense_char)
     also have "... = (top,up_filter z)"
       using 6 7 Abs_dense_inverse Abs_lifted_pair_inverse by force
     finally have "z = get_dense ?qf f"
       using up_filter_injective by force
     thus "z \<in> { z . \<exists>qf . -Rep_regular pf \<le> Rep_dense qf \<and> z = get_dense qf f }"
       using 11 by auto
   qed
   have 12: "Rep_filter (?r (fst (Rep_lifted_pair (Rep_regular pf) f))) \<supseteq> { z . \<exists>qf . -Rep_regular pf \<le> Rep_dense qf \<and> z = get_dense qf f }"
   proof
     fix z
     assume "z \<in> { z . \<exists>qf . -Rep_regular pf \<le> Rep_dense qf \<and> z = get_dense qf f }"
     hence "\<exists>qf . -Rep_regular pf \<le> Rep_dense qf \<and> z = get_dense qf f"
       by auto
     hence "triple.pairs_less_eq (Rep_lifted_pair (-Rep_regular pf) f) (top,up_filter z)"
       by (metis less_eq_lifted_pair.rep_eq get_dense_char)
     hence "up_filter z \<le> snd (Rep_lifted_pair (-Rep_regular pf) f)"
       using 1 by (metis (no_types, hide_lams) prod.collapse triple.pairs_less_eq.simps)
     also have "... = snd (?ppf f)"
       by (metis uminus_lifted_pair.rep_eq)
     also have "... = ?r (fst (Rep_lifted_pair (Rep_regular pf) f))"
       using 1 by (metis (no_types) prod.collapse prod.inject triple.pairs_uminus.simps)
     finally have "Rep_filter (up_filter z) \<subseteq> Rep_filter (?r (fst (Rep_lifted_pair (Rep_regular pf) f)))"
       by (simp add: less_eq_filter.rep_eq)
     hence "\<up>z \<subseteq> Rep_filter (?r (fst (Rep_lifted_pair (Rep_regular pf) f)))"
       by (metis Abs_filter_inverse mem_Collect_eq up_filter)
     thus "z \<in> Rep_filter (?r (fst (Rep_lifted_pair (Rep_regular pf) f)))"
       by blast
   qed
   have 13: "\<forall>qf\<in>Rep_filter (stone_phi pf) . Rep_lifted_distrib_lattice_top (Abs_lifted_distrib_lattice_top (get_dense qf)) f = get_dense qf f"
     by (metis Abs_lifted_distrib_lattice_top_inverse UNIV_I UNIV_def)
-  have "Rep_filter (?r (fst (Rep_lifted_pair (Rep_regular pf) f))) = { z . \<exists>qf\<in>stone_phi_set pf . z = get_dense qf f }"
+  have "Rep_filter (?r (fst (Rep_lifted_pair (Rep_regular pf) f))) = { z . \<exists>qf\<in>stone_phi_base pf . z = get_dense qf f }"
     using 2 12 by simp
-  hence "?r (fst (Rep_lifted_pair (Rep_regular pf) f)) = Abs_filter { z . \<exists>qf\<in>stone_phi_set pf . z = get_dense qf f }"
+  hence "?r (fst (Rep_lifted_pair (Rep_regular pf) f)) = Abs_filter { z . \<exists>qf\<in>stone_phi_base pf . z = get_dense qf f }"
     by (metis Rep_filter_inverse)
   hence "?r (Rep_lifted_boolean_algebra (ba_iso pf) f) = Abs_filter { z . \<exists>qf\<in>Rep_filter (stone_phi pf) . z = Rep_lifted_distrib_lattice_top (dl_iso qf) f }"
-    using 13 by (simp add: Abs_filter_inverse stone_phi_set_filter stone_phi_def Abs_lifted_boolean_algebra_inverse)
+    using 13 by (simp add: Abs_filter_inverse stone_phi_base_filter stone_phi_def Abs_lifted_boolean_algebra_inverse)
   thus ?thesis
     by (simp add: image_def)
 qed
 
 end
 
diff --git a/thys/Stone_Kleene_Relation_Algebras/Kleene_Relation_Algebras.thy b/thys/Stone_Kleene_Relation_Algebras/Kleene_Relation_Algebras.thy
--- a/thys/Stone_Kleene_Relation_Algebras/Kleene_Relation_Algebras.thy
+++ b/thys/Stone_Kleene_Relation_Algebras/Kleene_Relation_Algebras.thy
@@ -1,3173 +1,3173 @@
 (* Title:      Kleene Relation Algebras
    Author:     Walter Guttmann
    Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
 *)
 
 section \<open>Kleene Relation Algebras\<close>
 
 text \<open>
 This theory combines Kleene algebras with Stone relation algebras.
 Relation algebras with transitive closure have been studied by \cite{Ng1984}.
 The weakening to Stone relation algebras allows us to talk about reachability in weighted graphs, for example.
 
 Many results in this theory are used in the correctness proof of Prim's minimum spanning tree algorithm.
 In particular, they are concerned with the exchange property, preservation of parts of the invariant and with establishing parts of the postcondition.
 \<close>
 
 theory Kleene_Relation_Algebras
 
 imports Stone_Relation_Algebras.Relation_Algebras Kleene_Algebras
 
 begin
 
 text \<open>
 We first note that bounded distributive lattices can be expanded to Kleene algebras by reusing some of the operations.
 \<close>
 
 sublocale bounded_distrib_lattice < comp_inf: bounded_kleene_algebra where star = "\<lambda>x . top" and one = top and times = inf
   apply unfold_locales
   apply (simp add: inf.assoc)
   apply simp
   apply simp
   apply (simp add: le_infI2)
   apply (simp add: inf_sup_distrib2)
   apply simp
   apply simp
   apply simp
   apply simp
   apply simp
   apply (simp add: inf_sup_distrib1)
   apply simp
   apply simp
   by (simp add: inf_assoc)
 
 text \<open>
 We add the Kleene star operation to each of bounded distributive allegories, pseudocomplemented distributive allegories and Stone relation algebras.
 We start with single-object bounded distributive allegories.
 \<close>
 
 class bounded_distrib_kleene_allegory = bounded_distrib_allegory + kleene_algebra
 begin
 
 subclass bounded_kleene_algebra ..
 
 lemma conv_star_conv:
   "x\<^sup>\<star> \<le> x\<^sup>T\<^sup>\<star>\<^sup>T"
 proof -
   have "x\<^sup>T\<^sup>\<star> * x\<^sup>T \<le> x\<^sup>T\<^sup>\<star>"
     by (simp add: star.right_plus_below_circ)
   hence 1: "x * x\<^sup>T\<^sup>\<star>\<^sup>T \<le> x\<^sup>T\<^sup>\<star>\<^sup>T"
     using conv_dist_comp conv_isotone by fastforce
   have "1 \<le> x\<^sup>T\<^sup>\<star>\<^sup>T"
     by (simp add: reflexive_conv_closed star.circ_reflexive)
   hence "1 \<squnion> x * x\<^sup>T\<^sup>\<star>\<^sup>T \<le> x\<^sup>T\<^sup>\<star>\<^sup>T"
     using 1 by simp
   thus ?thesis
     using star_left_induct by fastforce
 qed
 
 text \<open>
 It follows that star and converse commute.
 \<close>
 
 lemma conv_star_commute:
   "x\<^sup>\<star>\<^sup>T = x\<^sup>T\<^sup>\<star>"
 proof (rule antisym)
   show "x\<^sup>\<star>\<^sup>T \<le> x\<^sup>T\<^sup>\<star>"
     using conv_star_conv conv_isotone by fastforce
 next
   show "x\<^sup>T\<^sup>\<star> \<le> x\<^sup>\<star>\<^sup>T"
     by (metis conv_star_conv conv_involutive)
 qed
 
 lemma conv_plus_commute:
   "x\<^sup>+\<^sup>T = x\<^sup>T\<^sup>+"
   by (simp add: conv_dist_comp conv_star_commute star_plus)
 
 text \<open>
 The following results are variants of a separation lemma of Kleene algebras.
 \<close>
 
 lemma cancel_separate_2:
   assumes "x * y \<le> 1"
     shows "((w \<sqinter> x) \<squnion> (z \<sqinter> y))\<^sup>\<star> = (z \<sqinter> y)\<^sup>\<star> * (w \<sqinter> x)\<^sup>\<star>"
 proof -
   have "(w \<sqinter> x) * (z \<sqinter> y) \<le> 1"
     by (meson assms comp_isotone order.trans inf.cobounded2)
   thus ?thesis
     using cancel_separate_1 sup_commute by simp
 qed
 
 lemma cancel_separate_3:
   assumes "x * y \<le> 1"
     shows "(w \<sqinter> x)\<^sup>\<star> * (z \<sqinter> y)\<^sup>\<star> = (w \<sqinter> x)\<^sup>\<star> \<squnion> (z \<sqinter> y)\<^sup>\<star>"
 proof -
   have "(w \<sqinter> x) * (z \<sqinter> y) \<le> 1"
     by (meson assms comp_isotone order.trans inf.cobounded2)
   thus ?thesis
     by (simp add: cancel_separate_eq)
 qed
 
 lemma cancel_separate_4:
   assumes "z * y \<le> 1"
       and "w \<le> y \<squnion> z"
       and "x \<le> y \<squnion> z"
     shows "w\<^sup>\<star> * x\<^sup>\<star> = (w \<sqinter> y)\<^sup>\<star> * ((w \<sqinter> z)\<^sup>\<star> \<squnion> (x \<sqinter> y)\<^sup>\<star>) * (x \<sqinter> z)\<^sup>\<star>"
 proof -
   have "w\<^sup>\<star> * x\<^sup>\<star> = ((w \<sqinter> y) \<squnion> (w \<sqinter> z))\<^sup>\<star> * ((x \<sqinter> y) \<squnion> (x \<sqinter> z))\<^sup>\<star>"
     by (metis assms(2,3) inf.orderE inf_sup_distrib1)
   also have "... = (w \<sqinter> y)\<^sup>\<star> * ((w \<sqinter> z)\<^sup>\<star> * (x \<sqinter> y)\<^sup>\<star>) * (x \<sqinter> z)\<^sup>\<star>"
     by (metis assms(1) cancel_separate_2 sup_commute mult_assoc)
   finally show ?thesis
     by (simp add: assms(1) cancel_separate_3)
 qed
 
 lemma cancel_separate_5:
   assumes "w * z\<^sup>T \<le> 1"
     shows "w \<sqinter> x * (y \<sqinter> z) \<le> y"
 proof -
   have "w \<sqinter> x * (y \<sqinter> z) \<le> (x \<sqinter> w * (y \<sqinter> z)\<^sup>T) * (y \<sqinter> z)"
     by (metis dedekind_2 inf_commute)
   also have "... \<le> w * z\<^sup>T * (y \<sqinter> z)"
     by (simp add: conv_dist_inf inf.coboundedI2 mult_left_isotone mult_right_isotone)
   also have "... \<le> y \<sqinter> z"
     by (metis assms mult_1_left mult_left_isotone)
   finally show ?thesis
     by simp
 qed
 
 lemma cancel_separate_6:
   assumes "z * y \<le> 1"
       and "w \<le> y \<squnion> z"
       and "x \<le> y \<squnion> z"
       and "v * z\<^sup>T \<le> 1"
       and "v \<sqinter> y\<^sup>\<star> = bot"
     shows "v \<sqinter> w\<^sup>\<star> * x\<^sup>\<star> \<le> x \<squnion> w"
 proof -
   have "v \<sqinter> (w \<sqinter> y)\<^sup>\<star> * (x \<sqinter> y)\<^sup>\<star> \<le> v \<sqinter> y\<^sup>\<star> * (x \<sqinter> y)\<^sup>\<star>"
     using comp_inf.mult_right_isotone mult_left_isotone star_isotone by simp
   also have "... \<le> v \<sqinter> y\<^sup>\<star>"
     by (simp add: inf.coboundedI2 star.circ_increasing star.circ_mult_upper_bound star_right_induct_mult)
   finally have 1: "v \<sqinter> (w \<sqinter> y)\<^sup>\<star> * (x \<sqinter> y)\<^sup>\<star> = bot"
     using assms(5) le_bot by simp
   have "v \<sqinter> w\<^sup>\<star> * x\<^sup>\<star> = v \<sqinter> (w \<sqinter> y)\<^sup>\<star> * ((w \<sqinter> z)\<^sup>\<star> \<squnion> (x \<sqinter> y)\<^sup>\<star>) * (x \<sqinter> z)\<^sup>\<star>"
     using assms(1-3) cancel_separate_4 by simp
   also have "... = (v \<sqinter> (w \<sqinter> y)\<^sup>\<star> * ((w \<sqinter> z)\<^sup>\<star> \<squnion> (x \<sqinter> y)\<^sup>\<star>) * (x \<sqinter> z)\<^sup>\<star> * (x \<sqinter> z)) \<squnion> (v \<sqinter> (w \<sqinter> y)\<^sup>\<star> * ((w \<sqinter> z)\<^sup>\<star> \<squnion> (x \<sqinter> y)\<^sup>\<star>))"
     by (metis inf_sup_distrib1 star.circ_back_loop_fixpoint)
   also have "... \<le> x \<squnion> (v \<sqinter> (w \<sqinter> y)\<^sup>\<star> * ((w \<sqinter> z)\<^sup>\<star> \<squnion> (x \<sqinter> y)\<^sup>\<star>))"
     using assms(4) cancel_separate_5 semiring.add_right_mono by simp
   also have "... = x \<squnion> (v \<sqinter> (w \<sqinter> y)\<^sup>\<star> * (w \<sqinter> z)\<^sup>\<star>)"
     using 1 by (simp add: inf_sup_distrib1 mult_left_dist_sup sup_monoid.add_assoc)
   also have "... = x \<squnion> (v \<sqinter> (w \<sqinter> y)\<^sup>\<star> * (w \<sqinter> z)\<^sup>\<star> * (w \<sqinter> z)) \<squnion> (v \<sqinter> (w \<sqinter> y)\<^sup>\<star>)"
     by (metis comp_inf.semiring.distrib_left star.circ_back_loop_fixpoint sup_assoc)
   also have "... \<le> x \<squnion> w \<squnion> (v \<sqinter> (w \<sqinter> y)\<^sup>\<star>)"
     using assms(4) cancel_separate_5 sup_left_isotone sup_right_isotone by simp
   also have "... \<le> x \<squnion> w \<squnion> (v \<sqinter> y\<^sup>\<star>)"
     using comp_inf.mult_right_isotone star_isotone sup_right_isotone by simp
   finally show ?thesis
     using assms(5) le_bot by simp
 qed
 
 text \<open>
 We show several results about the interaction of vectors and the Kleene star.
 \<close>
 
 lemma vector_star_1:
   assumes "vector x"
     shows "x\<^sup>T * (x * x\<^sup>T)\<^sup>\<star> \<le> x\<^sup>T"
 proof -
   have "x\<^sup>T * (x * x\<^sup>T)\<^sup>\<star> = (x\<^sup>T * x)\<^sup>\<star> * x\<^sup>T"
     by (simp add: star_slide)
   also have "... \<le> top * x\<^sup>T"
     by (simp add: mult_left_isotone)
   also have "... = x\<^sup>T"
     using assms vector_conv_covector by auto
   finally show ?thesis
     .
 qed
 
 lemma vector_star_2:
   "vector x \<Longrightarrow> x\<^sup>T * (x * x\<^sup>T)\<^sup>\<star> \<le> x\<^sup>T * bot\<^sup>\<star>"
   by (simp add: star_absorb vector_star_1)
 
 lemma vector_vector_star:
   "vector v \<Longrightarrow> (v * v\<^sup>T)\<^sup>\<star> = 1 \<squnion> v * v\<^sup>T"
   by (simp add: transitive_star vv_transitive)
 
 text \<open>
 The following equivalence relation characterises the component trees of a forest.
 This is a special case of undirected reachability in a directed graph.
 \<close>
 
 abbreviation "forest_components f \<equiv> f\<^sup>T\<^sup>\<star> * f\<^sup>\<star>"
 
 lemma forest_components_equivalence:
   "injective x \<Longrightarrow> equivalence (forest_components x)"
   apply (intro conjI)
   apply (simp add: reflexive_mult_closed star.circ_reflexive)
   apply (metis cancel_separate_1 eq_iff star.circ_transitive_equal)
   by (simp add: conv_dist_comp conv_star_commute)
 
 lemma forest_components_increasing:
   "x \<le> forest_components x"
   by (metis order.trans mult_left_isotone mult_left_one star.circ_increasing star.circ_reflexive)
 
 lemma forest_components_isotone:
   "x \<le> y \<Longrightarrow> forest_components x \<le> forest_components y"
   by (simp add: comp_isotone conv_isotone star_isotone)
 
 lemma forest_components_idempotent:
   "injective x \<Longrightarrow> forest_components (forest_components x) = forest_components x"
   by (metis forest_components_equivalence cancel_separate_1 star.circ_transitive_equal star_involutive)
 
 lemma forest_components_star:
   "injective x \<Longrightarrow> (forest_components x)\<^sup>\<star> = forest_components x"
   using forest_components_equivalence forest_components_idempotent star.circ_transitive_equal by simp
 
 text \<open>
 The following lemma shows that the nodes reachable in the graph can be reached by only using edges between reachable nodes.
 \<close>
 
 lemma reachable_restrict:
   assumes "vector r"
     shows "r\<^sup>T * g\<^sup>\<star> = r\<^sup>T * ((r\<^sup>T * g\<^sup>\<star>)\<^sup>T * (r\<^sup>T * g\<^sup>\<star>) \<sqinter> g)\<^sup>\<star>"
 proof -
   have 1: "r\<^sup>T \<le> r\<^sup>T * ((r\<^sup>T * g\<^sup>\<star>)\<^sup>T * (r\<^sup>T * g\<^sup>\<star>) \<sqinter> g)\<^sup>\<star>"
     using mult_right_isotone mult_1_right star.circ_reflexive by fastforce
   have 2: "covector (r\<^sup>T * g\<^sup>\<star>)"
     using assms covector_mult_closed vector_conv_covector by auto
   have "r\<^sup>T * ((r\<^sup>T * g\<^sup>\<star>)\<^sup>T * (r\<^sup>T * g\<^sup>\<star>) \<sqinter> g)\<^sup>\<star> * g \<le> r\<^sup>T * g\<^sup>\<star> * g"
     by (simp add: mult_left_isotone mult_right_isotone star_isotone)
   also have "... \<le> r\<^sup>T * g\<^sup>\<star>"
     by (simp add: mult_assoc mult_right_isotone star.left_plus_below_circ star_plus)
   finally have "r\<^sup>T * ((r\<^sup>T * g\<^sup>\<star>)\<^sup>T * (r\<^sup>T * g\<^sup>\<star>) \<sqinter> g)\<^sup>\<star> * g = r\<^sup>T * ((r\<^sup>T * g\<^sup>\<star>)\<^sup>T * (r\<^sup>T * g\<^sup>\<star>) \<sqinter> g)\<^sup>\<star> * g \<sqinter> r\<^sup>T * g\<^sup>\<star>"
     by (simp add: le_iff_inf)
   also have "... = r\<^sup>T * ((r\<^sup>T * g\<^sup>\<star>)\<^sup>T * (r\<^sup>T * g\<^sup>\<star>) \<sqinter> g)\<^sup>\<star> * (g \<sqinter> r\<^sup>T * g\<^sup>\<star>)"
     using assms covector_comp_inf covector_mult_closed vector_conv_covector by auto
   also have "... = (r\<^sup>T * ((r\<^sup>T * g\<^sup>\<star>)\<^sup>T * (r\<^sup>T * g\<^sup>\<star>) \<sqinter> g)\<^sup>\<star> \<sqinter> r\<^sup>T * g\<^sup>\<star>) * (g \<sqinter> r\<^sup>T * g\<^sup>\<star>)"
     by (simp add: inf.absorb2 inf_commute mult_right_isotone star_isotone)
   also have "... = r\<^sup>T * ((r\<^sup>T * g\<^sup>\<star>)\<^sup>T * (r\<^sup>T * g\<^sup>\<star>) \<sqinter> g)\<^sup>\<star> * (g \<sqinter> r\<^sup>T * g\<^sup>\<star> \<sqinter> (r\<^sup>T * g\<^sup>\<star>)\<^sup>T)"
     using 2 by (metis comp_inf_vector_1)
   also have "... = r\<^sup>T * ((r\<^sup>T * g\<^sup>\<star>)\<^sup>T * (r\<^sup>T * g\<^sup>\<star>) \<sqinter> g)\<^sup>\<star> * ((r\<^sup>T * g\<^sup>\<star>)\<^sup>T \<sqinter> r\<^sup>T * g\<^sup>\<star> \<sqinter> g)"
     using inf_commute inf_assoc by simp
   also have "... = r\<^sup>T * ((r\<^sup>T * g\<^sup>\<star>)\<^sup>T * (r\<^sup>T * g\<^sup>\<star>) \<sqinter> g)\<^sup>\<star> * ((r\<^sup>T * g\<^sup>\<star>)\<^sup>T * (r\<^sup>T * g\<^sup>\<star>) \<sqinter> g)"
     using 2 by (metis covector_conv_vector inf_top.right_neutral vector_inf_comp)
   also have "... \<le> r\<^sup>T * ((r\<^sup>T * g\<^sup>\<star>)\<^sup>T * (r\<^sup>T * g\<^sup>\<star>) \<sqinter> g)\<^sup>\<star>"
     by (simp add: mult_assoc mult_right_isotone star.left_plus_below_circ star_plus)
   finally have "r\<^sup>T * g\<^sup>\<star> \<le> r\<^sup>T * ((r\<^sup>T * g\<^sup>\<star>)\<^sup>T * (r\<^sup>T * g\<^sup>\<star>) \<sqinter> g)\<^sup>\<star>"
     using 1 star_right_induct by auto
   thus ?thesis
     by (simp add: inf.eq_iff mult_right_isotone star_isotone)
 qed
 
 lemma kruskal_acyclic_inv_1:
   assumes "injective f"
       and "e * forest_components f * e = bot"
     shows "(f \<sqinter> top * e * f\<^sup>T\<^sup>\<star>)\<^sup>T * f\<^sup>\<star> * e = bot"
 proof -
   let ?q = "top * e * f\<^sup>T\<^sup>\<star>"
   let ?F = "forest_components f"
   have "(f \<sqinter> ?q)\<^sup>T * f\<^sup>\<star> * e = ?q\<^sup>T \<sqinter> f\<^sup>T * f\<^sup>\<star> * e"
     by (metis (mono_tags) comp_associative conv_dist_inf covector_conv_vector inf_vector_comp vector_top_closed)
   also have "... \<le> ?q\<^sup>T \<sqinter> ?F * e"
     using comp_inf.mult_right_isotone mult_left_isotone star.circ_increasing by simp
   also have "... = f\<^sup>\<star> * e\<^sup>T * top \<sqinter> ?F * e"
     by (simp add: conv_dist_comp conv_star_commute mult_assoc)
   also have "... \<le> ?F * e\<^sup>T * top \<sqinter> ?F * e"
     by (metis conv_dist_comp conv_star_commute conv_top inf.sup_left_isotone star.circ_right_top star_outer_increasing mult_assoc)
   also have "... = ?F * (e\<^sup>T * top \<sqinter> ?F * e)"
     by (metis assms(1) forest_components_equivalence equivalence_comp_dist_inf mult_assoc)
   also have "... = (?F \<sqinter> top * e) * ?F * e"
     by (simp add: comp_associative comp_inf_vector_1 conv_dist_comp inf_vector_comp)
   also have "... \<le> top * e * ?F * e"
     by (simp add: mult_left_isotone)
   also have "... = bot"
     using assms(2) mult_assoc by simp
   finally show ?thesis
     by (simp add: bot_unique)
 qed
 
 lemma kruskal_forest_components_inf_1:
   assumes "f \<le> w \<squnion> w\<^sup>T"
       and "injective w"
       and "f \<le> forest_components g"
     shows "f * forest_components (forest_components g \<sqinter> w) \<le> forest_components (forest_components g \<sqinter> w)"
 proof -
   let ?f = "forest_components g"
   let ?w = "forest_components (?f \<sqinter> w)"
   have "f * ?w = (f \<sqinter> (w \<squnion> w\<^sup>T)) * ?w"
     by (simp add: assms(1) inf.absorb1)
   also have "... = (f \<sqinter> w) * ?w \<squnion> (f \<sqinter> w\<^sup>T) * ?w"
     by (simp add: inf_sup_distrib1 semiring.distrib_right)
   also have "... \<le> (?f \<sqinter> w) * ?w \<squnion> (f \<sqinter> w\<^sup>T) * ?w"
     using assms(3) inf.sup_left_isotone mult_left_isotone sup_left_isotone by simp
   also have "... \<le> (?f \<sqinter> w) * ?w \<squnion> (?f \<sqinter> w\<^sup>T) * ?w"
     using assms(3) inf.sup_left_isotone mult_left_isotone sup_right_isotone by simp
   also have "... = (?f \<sqinter> w) * ?w \<squnion> (?f \<sqinter> w)\<^sup>T * ?w"
     by (simp add: conv_dist_comp conv_dist_inf conv_star_commute)
   also have "... \<le> (?f \<sqinter> w) * ?w \<squnion> ?w"
     by (metis star.circ_loop_fixpoint sup_ge1 sup_right_isotone)
   also have "... = ?w \<squnion> (?f \<sqinter> w) * (?f \<sqinter> w)\<^sup>\<star> \<squnion> (?f \<sqinter> w) * (?f \<sqinter> w)\<^sup>T\<^sup>+ * (?f \<sqinter> w)\<^sup>\<star>"
     by (metis comp_associative mult_left_dist_sup star.circ_loop_fixpoint sup_commute sup_assoc)
   also have "... \<le> ?w \<squnion> (?f \<sqinter> w)\<^sup>\<star> \<squnion> (?f \<sqinter> w) * (?f \<sqinter> w)\<^sup>T\<^sup>+ * (?f \<sqinter> w)\<^sup>\<star>"
     using star.left_plus_below_circ sup_left_isotone sup_right_isotone by auto
   also have "... = ?w \<squnion> (?f \<sqinter> w) * (?f \<sqinter> w)\<^sup>T\<^sup>+ * (?f \<sqinter> w)\<^sup>\<star>"
     by (metis star.circ_loop_fixpoint sup.right_idem)
   also have "... \<le> ?w \<squnion> w * w\<^sup>T * ?w"
     using comp_associative conv_dist_inf mult_isotone sup_right_isotone by simp
   also have "... = ?w"
     by (metis assms(2) coreflexive_comp_top_inf inf.cobounded2 sup.orderE)
   finally show ?thesis
     by simp
 qed
 
 lemma kruskal_forest_components_inf:
   assumes "f \<le> w \<squnion> w\<^sup>T"
       and "injective w"
     shows "forest_components f \<le> forest_components (forest_components f \<sqinter> w)"
 proof -
   let ?f = "forest_components f"
   let ?w = "forest_components (?f \<sqinter> w)"
   have 1: "1 \<le> ?w"
     by (simp add: reflexive_mult_closed star.circ_reflexive)
   have "f * ?w \<le> ?w"
     using assms forest_components_increasing kruskal_forest_components_inf_1 by simp
   hence 2: "f\<^sup>\<star> \<le> ?w"
     using 1 star_left_induct by fastforce
   have "f\<^sup>T * ?w \<le> ?w"
     apply (rule kruskal_forest_components_inf_1)
     apply (metis assms(1) conv_dist_sup conv_involutive conv_isotone sup_commute)
     apply (simp add: assms(2))
     by (metis le_supI2 star.circ_back_loop_fixpoint star.circ_increasing)
   thus "?f \<le> ?w"
     using 2 star_left_induct by simp
 qed
 
 end
 
 text \<open>
 We next add the Kleene star to single-object pseudocomplemented distributive allegories.
 \<close>
 
 class pd_kleene_allegory = pd_allegory + bounded_distrib_kleene_allegory
 begin
 
 text \<open>
 The following definitions and results concern acyclic graphs and forests.
 \<close>
 
 abbreviation acyclic :: "'a \<Rightarrow> bool" where "acyclic x \<equiv> x\<^sup>+ \<le> -1"
 
 abbreviation forest :: "'a \<Rightarrow> bool" where "forest x \<equiv> injective x \<and> acyclic x"
 
 lemma forest_bot:
   "forest bot"
   by simp
 
 lemma acyclic_star_below_complement:
   "acyclic w \<longleftrightarrow> w\<^sup>T\<^sup>\<star> \<le> -w"
   by (simp add: conv_star_commute schroeder_4_p)
 
 lemma acyclic_star_below_complement_1:
   "acyclic w \<longleftrightarrow> w\<^sup>\<star> \<sqinter> w\<^sup>T = bot"
   using pseudo_complement schroeder_5_p by force
 
 lemma acyclic_star_inf_conv:
   assumes "acyclic w"
   shows "w\<^sup>\<star> \<sqinter> w\<^sup>T\<^sup>\<star> = 1"
 proof -
   have "w\<^sup>+ \<sqinter> w\<^sup>T\<^sup>\<star> \<le> (w \<sqinter> w\<^sup>T\<^sup>\<star>) * w\<^sup>\<star>"
     by (metis conv_star_commute dedekind_2 star.circ_transitive_equal)
   also have "... = bot"
     by (metis assms conv_star_commute p_antitone_iff pseudo_complement schroeder_4_p semiring.mult_not_zero star.circ_circ_mult star_involutive star_one)
   finally have "w\<^sup>\<star> \<sqinter> w\<^sup>T\<^sup>\<star> \<le> 1"
     by (metis eq_iff le_bot mult_left_zero star.circ_plus_one star.circ_zero star_left_unfold_equal sup_inf_distrib1)
   thus ?thesis
     by (simp add: inf.antisym star.circ_reflexive)
 qed
 
 lemma acyclic_asymmetric:
   "acyclic w \<Longrightarrow> asymmetric w"
   by (simp add: local.dual_order.trans local.pseudo_complement local.schroeder_5_p local.star.circ_increasing)
 
 lemma forest_separate:
   assumes "forest x"
     shows "x\<^sup>\<star> * x\<^sup>T\<^sup>\<star> \<sqinter> x\<^sup>T * x \<le> 1"
 proof -
   have "x\<^sup>\<star> * 1 \<le> -x\<^sup>T"
     using assms schroeder_5_p by force
   hence 1: "x\<^sup>\<star> \<sqinter> x\<^sup>T = bot"
     by (simp add: pseudo_complement)
   have "x\<^sup>\<star> \<sqinter> x\<^sup>T * x = (1 \<squnion> x\<^sup>\<star> * x) \<sqinter> x\<^sup>T * x"
     using star.circ_right_unfold_1 by simp
   also have "... = (1 \<sqinter> x\<^sup>T * x) \<squnion> (x\<^sup>\<star> * x \<sqinter> x\<^sup>T * x)"
     by (simp add: inf_sup_distrib2)
   also have "... \<le> 1 \<squnion> (x\<^sup>\<star> * x \<sqinter> x\<^sup>T * x)"
     using sup_left_isotone by simp
   also have "... = 1 \<squnion> (x\<^sup>\<star> \<sqinter> x\<^sup>T) * x"
     by (simp add: assms injective_comp_right_dist_inf)
   also have "... = 1"
     using 1 by simp
   finally have 2: "x\<^sup>\<star> \<sqinter> x\<^sup>T * x \<le> 1"
     .
   hence 3: "x\<^sup>T\<^sup>\<star> \<sqinter> x\<^sup>T * x \<le> 1"
     by (metis (mono_tags, lifting) conv_star_commute conv_dist_comp conv_dist_inf conv_involutive coreflexive_symmetric)
   have "x\<^sup>\<star> * x\<^sup>T\<^sup>\<star> \<sqinter> x\<^sup>T * x \<le> (x\<^sup>\<star> \<squnion> x\<^sup>T\<^sup>\<star>) \<sqinter> x\<^sup>T * x"
     using assms cancel_separate inf.sup_left_isotone by simp
   also have "... \<le> 1"
     using 2 3 by (simp add: inf_sup_distrib2)
   finally show ?thesis
     .
 qed
 
 text \<open>
 The following definition captures the components of undirected weighted graphs.
 \<close>
 
 abbreviation "components g \<equiv> (--g)\<^sup>\<star>"
 
 lemma components_equivalence:
   "symmetric x \<Longrightarrow> equivalence (components x)"
   by (simp add: conv_star_commute conv_complement star.circ_reflexive star.circ_transitive_equal)
 
 lemma components_increasing:
   "x \<le> components x"
   using order_trans pp_increasing star.circ_increasing by blast
 
 lemma components_isotone:
   "x \<le> y \<Longrightarrow> components x \<le> components y"
   by (simp add: pp_isotone star_isotone)
 
 lemma cut_reachable:
   assumes "v\<^sup>T = r\<^sup>T * t\<^sup>\<star>"
       and "t \<le> g"
     shows "v * -v\<^sup>T \<sqinter> g \<le> (r\<^sup>T * g\<^sup>\<star>)\<^sup>T * (r\<^sup>T * g\<^sup>\<star>)"
 proof -
   have "v * -v\<^sup>T \<sqinter> g \<le> v * top \<sqinter> g"
     using inf.sup_left_isotone mult_right_isotone top_greatest by blast
   also have "... = (r\<^sup>T * t\<^sup>\<star>)\<^sup>T * top \<sqinter> g"
     by (metis assms(1) conv_involutive)
   also have "... \<le> (r\<^sup>T * g\<^sup>\<star>)\<^sup>T * top \<sqinter> g"
     using assms(2) conv_isotone inf.sup_left_isotone mult_left_isotone mult_right_isotone star_isotone by auto
   also have "... \<le> (r\<^sup>T * g\<^sup>\<star>)\<^sup>T * ((r\<^sup>T * g\<^sup>\<star>) * g)"
     by (metis conv_involutive dedekind_1 inf_top.left_neutral)
   also have "... \<le> (r\<^sup>T * g\<^sup>\<star>)\<^sup>T * (r\<^sup>T * g\<^sup>\<star>)"
     by (simp add: mult_assoc mult_right_isotone star.left_plus_below_circ star_plus)
   finally show ?thesis
     .
 qed
 
 text \<open>
 The following lemma shows that the predecessors of visited nodes in the minimum spanning tree extending the current tree have all been visited.
 \<close>
 
 lemma predecessors_reachable:
   assumes "vector r"
       and "injective r"
       and "v\<^sup>T = r\<^sup>T * t\<^sup>\<star>"
       and "forest w"
       and "t \<le> w"
       and "w \<le> (r\<^sup>T * g\<^sup>\<star>)\<^sup>T * (r\<^sup>T * g\<^sup>\<star>) \<sqinter> g"
       and "r\<^sup>T * g\<^sup>\<star> \<le> r\<^sup>T * w\<^sup>\<star>"
     shows "w * v \<le> v"
 proof -
   have "w * r \<le> (r\<^sup>T * g\<^sup>\<star>)\<^sup>T * (r\<^sup>T * g\<^sup>\<star>) * r"
     using assms(6) mult_left_isotone by auto
   also have "... \<le> (r\<^sup>T * g\<^sup>\<star>)\<^sup>T * top"
     by (simp add: mult_assoc mult_right_isotone)
   also have "... = (r\<^sup>T * g\<^sup>\<star>)\<^sup>T"
     by (simp add: assms(1) comp_associative conv_dist_comp)
   also have "... \<le> (r\<^sup>T * w\<^sup>\<star>)\<^sup>T"
     by (simp add: assms(7) conv_isotone)
   also have "... = w\<^sup>T\<^sup>\<star> * r"
     by (simp add: conv_dist_comp conv_star_commute)
   also have "... \<le> -w * r"
     using assms(4) by (simp add: mult_left_isotone acyclic_star_below_complement)
   also have "... \<le> -(w * r)"
     by (simp add: assms(2) comp_injective_below_complement)
   finally have 1: "w * r = bot"
     by (simp add: le_iff_inf)
   have "v = t\<^sup>T\<^sup>\<star> * r"
     by (metis assms(3) conv_dist_comp conv_involutive conv_star_commute)
   also have "... = t\<^sup>T * v \<squnion> r"
     by (simp add: calculation star.circ_loop_fixpoint)
   also have "... \<le> w\<^sup>T * v \<squnion> r"
     using assms(5) comp_isotone conv_isotone semiring.add_right_mono by auto
   finally have "w * v \<le> w * w\<^sup>T * v \<squnion> w * r"
     by (simp add: comp_left_dist_sup mult_assoc mult_right_isotone)
   also have "... = w * w\<^sup>T * v"
     using 1 by simp
   also have "... \<le> v"
     using assms(4) by (simp add: star_left_induct_mult_iff star_sub_one)
   finally show ?thesis
     .
 qed
 
 subsection \<open>Prim's Algorithm\<close>
 
 text \<open>
 The following results are used for proving the correctness of Prim's minimum spanning tree algorithm.
 \<close>
 
 subsubsection \<open>Preservation of Invariant\<close>
 
 text \<open>
 We first treat the preservation of the invariant.
 The following lemma shows that the while-loop preserves that \<open>v\<close> represents the nodes of the constructed tree.
 The remaining lemmas in this section show that \<open>t\<close> is a spanning tree.
 The exchange property is treated in the following two sections.
 \<close>
 
 lemma reachable_inv:
   assumes "vector v"
       and "e \<le> v * -v\<^sup>T"
       and "e * t = bot"
       and "v\<^sup>T = r\<^sup>T * t\<^sup>\<star>"
     shows "(v \<squnion> e\<^sup>T * top)\<^sup>T = r\<^sup>T * (t \<squnion> e)\<^sup>\<star>"
 proof -
   have 1: "v\<^sup>T \<le> r\<^sup>T * (t \<squnion> e)\<^sup>\<star>"
     by (simp add: assms(4) mult_right_isotone star.circ_sub_dist)
   have 2: "(e\<^sup>T * top)\<^sup>T = top * e"
     by (simp add: conv_dist_comp)
   also have "... = top * (v * -v\<^sup>T \<sqinter> e)"
     by (simp add: assms(2) inf_absorb2)
   also have "... \<le> top * (v * top \<sqinter> e)"
     using inf.sup_left_isotone mult_right_isotone top_greatest by blast
   also have "... = top * v\<^sup>T * e"
     by (simp add: comp_inf_vector inf.sup_monoid.add_commute)
   also have "... = v\<^sup>T * e"
     using assms(1) vector_conv_covector by auto
   also have "... \<le> r\<^sup>T * (t \<squnion> e)\<^sup>\<star> * e"
     using 1 by (simp add: mult_left_isotone)
   also have "... \<le> r\<^sup>T * (t \<squnion> e)\<^sup>\<star> * (t \<squnion> e)"
     by (simp add: mult_right_isotone)
   also have "... \<le> r\<^sup>T * (t \<squnion> e)\<^sup>\<star>"
     by (simp add: comp_associative mult_right_isotone star.right_plus_below_circ)
   finally have 3: "(v \<squnion> e\<^sup>T * top)\<^sup>T \<le> r\<^sup>T * (t \<squnion> e)\<^sup>\<star>"
     using 1 by (simp add: conv_dist_sup)
   have "r\<^sup>T \<le> r\<^sup>T * t\<^sup>\<star>"
     using sup.bounded_iff star.circ_back_loop_prefixpoint by blast
   also have "... \<le> (v \<squnion> e\<^sup>T * top)\<^sup>T"
     by (metis assms(4) conv_isotone sup_ge1)
   finally have 4: "r\<^sup>T \<le> (v \<squnion> e\<^sup>T * top)\<^sup>T"
     .
   have "(v \<squnion> e\<^sup>T * top)\<^sup>T * (t \<squnion> e) = (v \<squnion> e\<^sup>T * top)\<^sup>T * t \<squnion> (v \<squnion> e\<^sup>T * top)\<^sup>T * e"
     by (simp add: mult_left_dist_sup)
   also have "... \<le> (v \<squnion> e\<^sup>T * top)\<^sup>T * t \<squnion> top * e"
     using comp_isotone semiring.add_left_mono by auto
   also have "... = v\<^sup>T * t \<squnion> top * e * t \<squnion> top * e"
     using 2 by (simp add: conv_dist_sup mult_right_dist_sup)
   also have "... = v\<^sup>T * t \<squnion> top * e"
     by (simp add: assms(3) comp_associative)
   also have "... \<le> r\<^sup>T * t\<^sup>\<star> \<squnion> top * e"
     by (metis assms(4) star.circ_back_loop_fixpoint sup_ge1 sup_left_isotone)
   also have "... = v\<^sup>T \<squnion> top * e"
     by (simp add: assms(4))
   finally have 5: "(v \<squnion> e\<^sup>T * top)\<^sup>T * (t \<squnion> e) \<le> (v \<squnion> e\<^sup>T * top)\<^sup>T"
     using 2 by (simp add: conv_dist_sup)
   have "r\<^sup>T * (t \<squnion> e)\<^sup>\<star> \<le> (v \<squnion> e\<^sup>T * top)\<^sup>T * (t \<squnion> e)\<^sup>\<star>"
     using 4 by (simp add: mult_left_isotone)
   also have "... \<le> (v \<squnion> e\<^sup>T * top)\<^sup>T"
     using 5 by (simp add: star_right_induct_mult)
   finally show ?thesis
     using 3 by (simp add: inf.eq_iff)
 qed
 
 text \<open>
 The next result is used to show that the while-loop preserves acyclicity of the constructed tree.
 \<close>
 
 lemma acyclic_inv:
   assumes "acyclic t"
       and "vector v"
       and "e \<le> v * -v\<^sup>T"
       and "t \<le> v * v\<^sup>T"
     shows "acyclic (t \<squnion> e)"
 proof -
   have "t\<^sup>+ * e \<le> t\<^sup>+ * v * -v\<^sup>T"
     by (simp add: assms(3) comp_associative mult_right_isotone)
   also have "... \<le> v * v\<^sup>T * t\<^sup>\<star> * v * -v\<^sup>T"
     by (simp add: assms(4) mult_left_isotone)
   also have "... \<le> v * top * -v\<^sup>T"
     by (metis mult_assoc mult_left_isotone mult_right_isotone top_greatest)
   also have "... = v * -v\<^sup>T"
     by (simp add: assms(2))
   also have "... \<le> -1"
     by (simp add: pp_increasing schroeder_3_p)
   finally have 1: "t\<^sup>+ * e \<le> -1"
     .
   have 2: "e * t\<^sup>\<star> = e"
     using assms(2-4) et(1) star_absorb by blast
   have "e\<^sup>\<star> = 1 \<squnion> e \<squnion> e * e * e\<^sup>\<star>"
     by (metis star.circ_loop_fixpoint star_square_2 sup_commute)
   also have "... = 1 \<squnion> e"
     using assms(2,3) ee comp_left_zero bot_least sup_absorb1 by simp
   finally have 3: "e\<^sup>\<star> = 1 \<squnion> e"
     .
   have "e \<le> v * -v\<^sup>T"
     by (simp add: assms(3))
   also have "... \<le> -1"
     by (simp add: pp_increasing schroeder_3_p)
   finally have 4: "t\<^sup>+ * e \<squnion> e \<le> -1"
     using 1 by simp
   have "(t \<squnion> e)\<^sup>+ = (t \<squnion> e) * t\<^sup>\<star> * (e * t\<^sup>\<star>)\<^sup>\<star>"
     using star_sup_1 mult_assoc by simp
   also have "... = (t \<squnion> e) * t\<^sup>\<star> * (1 \<squnion> e)"
     using 2 3 by simp
   also have "... = t\<^sup>+ * (1 \<squnion> e) \<squnion> e * t\<^sup>\<star> * (1 \<squnion> e)"
     by (simp add: comp_right_dist_sup)
   also have "... = t\<^sup>+ * (1 \<squnion> e) \<squnion> e * (1 \<squnion> e)"
     using 2 by simp
   also have "... = t\<^sup>+ * (1 \<squnion> e) \<squnion> e"
     using 3 by (metis star_absorb assms(2,3) ee)
   also have "... = t\<^sup>+ \<squnion> t\<^sup>+ * e \<squnion> e"
     by (simp add: mult_left_dist_sup)
   also have "... \<le> -1"
     using 4 by (metis assms(1) sup.absorb1 sup.orderI sup_assoc)
   finally show ?thesis
     .
 qed
 
 text \<open>
 The following lemma shows that the extended tree is in the component reachable from the root.
 \<close>
 
 lemma mst_subgraph_inv_2:
   assumes "regular (v * v\<^sup>T)"
       and "t \<le> v * v\<^sup>T \<sqinter> --g"
       and "v\<^sup>T = r\<^sup>T * t\<^sup>\<star>"
       and "e \<le> v * -v\<^sup>T \<sqinter> --g"
       and "vector v"
       and "regular ((v \<squnion> e\<^sup>T * top) * (v \<squnion> e\<^sup>T * top)\<^sup>T)"
     shows "t \<squnion> e \<le> (r\<^sup>T * (--((v \<squnion> e\<^sup>T * top) * (v \<squnion> e\<^sup>T * top)\<^sup>T \<sqinter> g))\<^sup>\<star>)\<^sup>T * (r\<^sup>T * (--((v \<squnion> e\<^sup>T * top) * (v \<squnion> e\<^sup>T * top)\<^sup>T \<sqinter> g))\<^sup>\<star>)"
 proof -
   let ?v = "v \<squnion> e\<^sup>T * top"
   let ?G = "?v * ?v\<^sup>T \<sqinter> g"
   let ?c = "r\<^sup>T * (--?G)\<^sup>\<star>"
   have "v\<^sup>T \<le> r\<^sup>T * (--(v * v\<^sup>T \<sqinter> g))\<^sup>\<star>"
     using assms(1-3) inf_pp_commute mult_right_isotone star_isotone by auto
   also have "... \<le> ?c"
     using comp_inf.mult_right_isotone comp_isotone conv_isotone inf.commute mult_right_isotone pp_isotone star_isotone sup.cobounded1 by presburger
   finally have 2: "v\<^sup>T \<le> ?c \<and> v \<le> ?c\<^sup>T"
     by (metis conv_isotone conv_involutive)
   have "t \<le> v * v\<^sup>T"
     using assms(2) by auto
   hence 3: "t \<le> ?c\<^sup>T * ?c"
     using 2 order_trans mult_isotone by blast
   have "e \<le> v * top \<sqinter> --g"
     by (metis assms(4,5) inf.bounded_iff inf.sup_left_divisibility mult_right_isotone top.extremum)
   hence "e \<le> v * top \<sqinter> top * e \<sqinter> --g"
     by (simp add: top_left_mult_increasing inf.boundedI)
   hence "e \<le> v * top * e \<sqinter> --g"
     by (metis comp_inf_covector inf.absorb2 mult_assoc top.extremum)
   hence "t \<squnion> e \<le> (v * v\<^sup>T \<sqinter> --g) \<squnion> (v * top * e \<sqinter> --g)"
     using assms(2) sup_mono by blast
   also have "... = v * ?v\<^sup>T \<sqinter> --g"
     by (simp add: inf_sup_distrib2 mult_assoc mult_left_dist_sup conv_dist_comp conv_dist_sup)
   also have "... \<le> --?G"
     using assms(6) comp_left_increasing_sup inf.sup_left_isotone pp_dist_inf by auto
   finally have 4: "t \<squnion> e \<le> --?G"
     .
   have "e \<le> e * e\<^sup>T * e"
     by (simp add: ex231c)
   also have "... \<le> v * -v\<^sup>T * -v * v\<^sup>T * e"
     by (metis assms(4) mult_left_isotone conv_isotone conv_dist_comp mult_assoc mult_isotone conv_involutive conv_complement inf.boundedE)
   also have "... \<le> v * top * v\<^sup>T * e"
     by (metis mult_assoc mult_left_isotone mult_right_isotone top.extremum)
   also have "... = v * r\<^sup>T * t\<^sup>\<star> * e"
     using assms(3,5) by (simp add: mult_assoc)
   also have "... \<le> v * r\<^sup>T * (t \<squnion> e)\<^sup>\<star>"
     by (simp add: comp_associative mult_right_isotone star.circ_mult_upper_bound star.circ_sub_dist_1 star_isotone sup_commute)
   also have "... \<le> v * ?c"
     using 4 by (simp add: mult_assoc mult_right_isotone star_isotone)
   also have "... \<le> ?c\<^sup>T * ?c"
     using 2 by (simp add: mult_left_isotone)
   finally show ?thesis
     using 3 by simp
 qed
 
 lemma span_inv:
   assumes "e \<le> v * -v\<^sup>T"
       and "vector v"
       and "arc e"
       and "t \<le> (v * v\<^sup>T) \<sqinter> g"
       and "g\<^sup>T = g"
       and "v\<^sup>T = r\<^sup>T * t\<^sup>\<star>"
       and "injective r"
       and "r\<^sup>T \<le> v\<^sup>T"
       and "r\<^sup>T * ((v * v\<^sup>T) \<sqinter> g)\<^sup>\<star> \<le> r\<^sup>T * t\<^sup>\<star>"
     shows "r\<^sup>T * (((v \<squnion> e\<^sup>T * top) * (v \<squnion> e\<^sup>T * top)\<^sup>T) \<sqinter> g)\<^sup>\<star> \<le> r\<^sup>T * (t \<squnion> e)\<^sup>\<star>"
 proof -
   let ?d = "(v * v\<^sup>T) \<sqinter> g"
   have 1: "(v \<squnion> e\<^sup>T * top) * (v \<squnion> e\<^sup>T * top)\<^sup>T = v * v\<^sup>T \<squnion> v * v\<^sup>T * e \<squnion> e\<^sup>T * v * v\<^sup>T \<squnion> e\<^sup>T * e"
     using assms(1-3) ve_dist by simp
   have "t\<^sup>T \<le> ?d\<^sup>T"
     using assms(4) conv_isotone by simp
   also have "... = (v * v\<^sup>T) \<sqinter> g\<^sup>T"
     by (simp add: conv_dist_comp conv_dist_inf)
   also have "... = ?d"
     by (simp add: assms(5))
   finally have 2: "t\<^sup>T \<le> ?d"
     .
   have "v * v\<^sup>T = (r\<^sup>T * t\<^sup>\<star>)\<^sup>T * (r\<^sup>T * t\<^sup>\<star>)"
     by (metis assms(6) conv_involutive)
   also have "... = t\<^sup>T\<^sup>\<star> * (r * r\<^sup>T) * t\<^sup>\<star>"
     by (simp add: comp_associative conv_dist_comp conv_star_commute)
   also have "... \<le> t\<^sup>T\<^sup>\<star> * 1 * t\<^sup>\<star>"
     by (simp add: assms(7) mult_left_isotone star_right_induct_mult_iff star_sub_one)
   also have "... = t\<^sup>T\<^sup>\<star> * t\<^sup>\<star>"
     by simp
   also have "... \<le> ?d\<^sup>\<star> * t\<^sup>\<star>"
     using 2 by (simp add: comp_left_isotone star.circ_isotone)
   also have "... \<le> ?d\<^sup>\<star> * ?d\<^sup>\<star>"
     using assms(4) mult_right_isotone star_isotone by simp
   also have 3: "... = ?d\<^sup>\<star>"
     by (simp add: star.circ_transitive_equal)
   finally have 4: "v * v\<^sup>T \<le> ?d\<^sup>\<star>"
     .
   have 5: "r\<^sup>T * ?d\<^sup>\<star> * (v * v\<^sup>T \<sqinter> g) \<le> r\<^sup>T * ?d\<^sup>\<star>"
     by (simp add: comp_associative mult_right_isotone star.circ_plus_same star.left_plus_below_circ)
   have "r\<^sup>T * ?d\<^sup>\<star> * (v * v\<^sup>T * e \<sqinter> g) \<le> r\<^sup>T * ?d\<^sup>\<star> * v * v\<^sup>T * e"
     by (simp add: comp_associative comp_right_isotone)
   also have "... \<le> r\<^sup>T * ?d\<^sup>\<star> * e"
     using 3 4 by (metis comp_associative comp_isotone eq_refl)
   finally have 6: "r\<^sup>T * ?d\<^sup>\<star> * (v * v\<^sup>T * e \<sqinter> g) \<le> r\<^sup>T * ?d\<^sup>\<star> * e"
     .
   have 7: "\<forall>x . r\<^sup>T * (1 \<squnion> v * v\<^sup>T) * e\<^sup>T * x = bot"
   proof
     fix x
     have "r\<^sup>T * (1 \<squnion> v * v\<^sup>T) * e\<^sup>T * x \<le> r\<^sup>T * (1 \<squnion> v * v\<^sup>T) * e\<^sup>T * top"
       by (simp add: mult_right_isotone)
     also have "... = r\<^sup>T * e\<^sup>T * top \<squnion> r\<^sup>T * v * v\<^sup>T * e\<^sup>T * top"
       by (simp add: comp_associative mult_left_dist_sup mult_right_dist_sup)
     also have "... = r\<^sup>T * e\<^sup>T * top"
       by (metis assms(1,2) mult_assoc mult_right_dist_sup mult_right_zero sup_bot_right vTeT)
     also have "... \<le> v\<^sup>T * e\<^sup>T * top"
       by (simp add: assms(8) comp_isotone)
     also have "... = bot"
       using vTeT assms(1,2) by simp
     finally show "r\<^sup>T * (1 \<squnion> v * v\<^sup>T) * e\<^sup>T * x = bot"
       by (simp add: le_bot)
   qed
   have "r\<^sup>T * ?d\<^sup>\<star> * (e\<^sup>T * v * v\<^sup>T \<sqinter> g) \<le> r\<^sup>T * ?d\<^sup>\<star> * e\<^sup>T * v * v\<^sup>T"
     by (simp add: comp_associative comp_right_isotone)
   also have "... \<le> r\<^sup>T * (1 \<squnion> v * v\<^sup>T) * e\<^sup>T * v * v\<^sup>T"
     by (metis assms(2) star.circ_isotone vector_vector_star inf_le1 comp_associative comp_right_isotone comp_left_isotone)
   also have "... = bot"
     using 7 by simp
   finally have 8: "r\<^sup>T * ?d\<^sup>\<star> * (e\<^sup>T * v * v\<^sup>T \<sqinter> g) = bot"
     by (simp add: le_bot)
   have "r\<^sup>T * ?d\<^sup>\<star> * (e\<^sup>T * e \<sqinter> g) \<le> r\<^sup>T * ?d\<^sup>\<star> * e\<^sup>T * e"
     by (simp add: comp_associative comp_right_isotone)
   also have "... \<le> r\<^sup>T * (1 \<squnion> v * v\<^sup>T) * e\<^sup>T * e"
     by (metis assms(2) star.circ_isotone vector_vector_star inf_le1 comp_associative comp_right_isotone comp_left_isotone)
   also have "... = bot"
     using 7 by simp
   finally have 9: "r\<^sup>T * ?d\<^sup>\<star> * (e\<^sup>T * e \<sqinter> g) = bot"
     by (simp add: le_bot)
   have "r\<^sup>T * ?d\<^sup>\<star> * ((v \<squnion> e\<^sup>T * top) * (v \<squnion> e\<^sup>T * top)\<^sup>T \<sqinter> g) = r\<^sup>T * ?d\<^sup>\<star> * ((v * v\<^sup>T \<squnion> v * v\<^sup>T * e \<squnion> e\<^sup>T * v * v\<^sup>T \<squnion> e\<^sup>T * e) \<sqinter> g)"
     using 1 by simp
   also have "... = r\<^sup>T * ?d\<^sup>\<star> * ((v * v\<^sup>T \<sqinter> g) \<squnion> (v * v\<^sup>T * e \<sqinter> g) \<squnion> (e\<^sup>T * v * v\<^sup>T \<sqinter> g) \<squnion> (e\<^sup>T * e \<sqinter> g))"
     by (simp add: inf_sup_distrib2)
   also have "... = r\<^sup>T * ?d\<^sup>\<star> * (v * v\<^sup>T \<sqinter> g) \<squnion> r\<^sup>T * ?d\<^sup>\<star> * (v * v\<^sup>T * e \<sqinter> g) \<squnion> r\<^sup>T * ?d\<^sup>\<star> * (e\<^sup>T * v * v\<^sup>T \<sqinter> g) \<squnion> r\<^sup>T * ?d\<^sup>\<star> * (e\<^sup>T * e \<sqinter> g)"
     by (simp add: comp_left_dist_sup)
   also have "... = r\<^sup>T * ?d\<^sup>\<star> * (v * v\<^sup>T \<sqinter> g) \<squnion> r\<^sup>T * ?d\<^sup>\<star> * (v * v\<^sup>T * e \<sqinter> g)"
     using 8 9 by simp
   also have "... \<le> r\<^sup>T * ?d\<^sup>\<star> \<squnion> r\<^sup>T * ?d\<^sup>\<star> * e"
     using 5 6 sup.mono by simp
   also have "... = r\<^sup>T * ?d\<^sup>\<star> * (1 \<squnion> e)"
     by (simp add: mult_left_dist_sup)
   finally have 10: "r\<^sup>T * ?d\<^sup>\<star> * ((v \<squnion> e\<^sup>T * top) * (v \<squnion> e\<^sup>T * top)\<^sup>T \<sqinter> g) \<le> r\<^sup>T * ?d\<^sup>\<star> * (1 \<squnion> e)"
     by simp
   have "r\<^sup>T * ?d\<^sup>\<star> * e * (v * v\<^sup>T \<sqinter> g) \<le> r\<^sup>T * ?d\<^sup>\<star> * e * v * v\<^sup>T"
     by (simp add: comp_associative comp_right_isotone)
   also have "... = bot"
     by (metis assms(1,2) comp_associative comp_right_zero ev comp_left_zero)
   finally have 11: "r\<^sup>T * ?d\<^sup>\<star> * e * (v * v\<^sup>T \<sqinter> g) = bot"
     by (simp add: le_bot)
   have "r\<^sup>T * ?d\<^sup>\<star> * e * (v * v\<^sup>T * e \<sqinter> g) \<le> r\<^sup>T * ?d\<^sup>\<star> * e * v * v\<^sup>T * e"
     by (simp add: comp_associative comp_right_isotone)
   also have "... = bot"
     by (metis assms(1,2) comp_associative comp_right_zero ev comp_left_zero)
   finally have 12: "r\<^sup>T * ?d\<^sup>\<star> * e * (v * v\<^sup>T * e \<sqinter> g) = bot"
     by (simp add: le_bot)
   have "r\<^sup>T * ?d\<^sup>\<star> * e * (e\<^sup>T * v * v\<^sup>T \<sqinter> g) \<le> r\<^sup>T * ?d\<^sup>\<star> * e * e\<^sup>T * v * v\<^sup>T"
     by (simp add: comp_associative comp_right_isotone)
   also have "... \<le> r\<^sup>T * ?d\<^sup>\<star> * 1 * v * v\<^sup>T"
     by (metis assms(3) arc_injective comp_associative comp_left_isotone comp_right_isotone)
   also have "... = r\<^sup>T * ?d\<^sup>\<star> * v * v\<^sup>T"
     by simp
   also have "... \<le> r\<^sup>T * ?d\<^sup>\<star> * ?d\<^sup>\<star>"
     using 4 by (simp add: mult_right_isotone mult_assoc)
   also have "... = r\<^sup>T * ?d\<^sup>\<star>"
     by (simp add: star.circ_transitive_equal comp_associative)
   finally have 13: "r\<^sup>T * ?d\<^sup>\<star> * e * (e\<^sup>T * v * v\<^sup>T \<sqinter> g) \<le> r\<^sup>T * ?d\<^sup>\<star>"
     .
   have "r\<^sup>T * ?d\<^sup>\<star> * e * (e\<^sup>T * e \<sqinter> g) \<le> r\<^sup>T * ?d\<^sup>\<star> * e * e\<^sup>T * e"
     by (simp add: comp_associative comp_right_isotone)
   also have "... \<le> r\<^sup>T * ?d\<^sup>\<star> * 1 * e"
     by (metis assms(3) arc_injective comp_associative comp_left_isotone comp_right_isotone)
   also have "... = r\<^sup>T * ?d\<^sup>\<star> * e"
     by simp
   finally have 14: "r\<^sup>T * ?d\<^sup>\<star> * e * (e\<^sup>T * e \<sqinter> g) \<le> r\<^sup>T * ?d\<^sup>\<star> * e"
     .
   have "r\<^sup>T * ?d\<^sup>\<star> * e * ((v \<squnion> e\<^sup>T * top) * (v \<squnion> e\<^sup>T * top)\<^sup>T \<sqinter> g) = r\<^sup>T * ?d\<^sup>\<star> * e * ((v * v\<^sup>T \<squnion> v * v\<^sup>T * e \<squnion> e\<^sup>T * v * v\<^sup>T \<squnion> e\<^sup>T * e) \<sqinter> g)"
     using 1 by simp
   also have "... = r\<^sup>T * ?d\<^sup>\<star> * e * ((v * v\<^sup>T \<sqinter> g) \<squnion> (v * v\<^sup>T * e \<sqinter> g) \<squnion> (e\<^sup>T * v * v\<^sup>T \<sqinter> g) \<squnion> (e\<^sup>T * e \<sqinter> g))"
     by (simp add: inf_sup_distrib2)
   also have "... = r\<^sup>T * ?d\<^sup>\<star> * e * (v * v\<^sup>T \<sqinter> g) \<squnion> r\<^sup>T * ?d\<^sup>\<star> * e * (v * v\<^sup>T * e \<sqinter> g) \<squnion> r\<^sup>T * ?d\<^sup>\<star> * e * (e\<^sup>T * v * v\<^sup>T \<sqinter> g) \<squnion> r\<^sup>T * ?d\<^sup>\<star> * e * (e\<^sup>T * e \<sqinter> g)"
     by (simp add: comp_left_dist_sup)
   also have "... = r\<^sup>T * ?d\<^sup>\<star> * e * (e\<^sup>T * v * v\<^sup>T \<sqinter> g) \<squnion> r\<^sup>T * ?d\<^sup>\<star> * e * (e\<^sup>T * e \<sqinter> g)"
     using 11 12 by simp
   also have "... \<le> r\<^sup>T * ?d\<^sup>\<star> \<squnion> r\<^sup>T * ?d\<^sup>\<star> * e"
     using 13 14 sup_mono by simp
   also have "... = r\<^sup>T * ?d\<^sup>\<star> * (1 \<squnion> e)"
     by (simp add: mult_left_dist_sup)
   finally have 15: "r\<^sup>T * ?d\<^sup>\<star> * e * ((v \<squnion> e\<^sup>T * top) * (v \<squnion> e\<^sup>T * top)\<^sup>T \<sqinter> g) \<le> r\<^sup>T * ?d\<^sup>\<star> * (1 \<squnion> e)"
     by simp
   have "r\<^sup>T \<le> r\<^sup>T * ?d\<^sup>\<star>"
     using mult_right_isotone star.circ_reflexive by fastforce
   also have "... \<le> r\<^sup>T * ?d\<^sup>\<star> * (1 \<squnion> e)"
     by (simp add: semiring.distrib_left)
   finally have 16: "r\<^sup>T \<le> r\<^sup>T * ?d\<^sup>\<star> * (1 \<squnion> e)"
     .
   have "r\<^sup>T * ?d\<^sup>\<star> * (1 \<squnion> e) * ((v \<squnion> e\<^sup>T * top) * (v \<squnion> e\<^sup>T * top)\<^sup>T \<sqinter> g) = r\<^sup>T * ?d\<^sup>\<star> * ((v \<squnion> e\<^sup>T * top) * (v \<squnion> e\<^sup>T * top)\<^sup>T \<sqinter> g) \<squnion> r\<^sup>T * ?d\<^sup>\<star> * e * ((v \<squnion> e\<^sup>T * top) * (v \<squnion> e\<^sup>T * top)\<^sup>T \<sqinter> g)"
     by (simp add: semiring.distrib_left semiring.distrib_right)
   also have "... \<le> r\<^sup>T * ?d\<^sup>\<star> * (1 \<squnion> e)"
     using 10 15 le_supI by simp
   finally have "r\<^sup>T * ?d\<^sup>\<star> * (1 \<squnion> e) * ((v \<squnion> e\<^sup>T * top) * (v \<squnion> e\<^sup>T * top)\<^sup>T \<sqinter> g) \<le> r\<^sup>T * ?d\<^sup>\<star> * (1 \<squnion> e)"
     .
   hence "r\<^sup>T \<squnion> r\<^sup>T * ?d\<^sup>\<star> * (1 \<squnion> e) * ((v \<squnion> e\<^sup>T * top) * (v \<squnion> e\<^sup>T * top)\<^sup>T \<sqinter> g) \<le> r\<^sup>T * ?d\<^sup>\<star> * (1 \<squnion> e)"
     using 16 sup_least by simp
   hence "r\<^sup>T * ((v \<squnion> e\<^sup>T * top) * (v \<squnion> e\<^sup>T * top)\<^sup>T \<sqinter> g)\<^sup>\<star> \<le> r\<^sup>T * ?d\<^sup>\<star> * (1 \<squnion> e)"
     by (simp add: star_right_induct)
   also have "... \<le> r\<^sup>T * t\<^sup>\<star> * (1 \<squnion> e)"
     by (simp add: assms(9) mult_left_isotone)
   also have "... \<le> r\<^sup>T * (t \<squnion> e)\<^sup>\<star>"
     by (simp add: star_one_sup_below)
   finally show ?thesis
     .
 qed
 
 subsubsection \<open>Exchange gives Spanning Trees\<close>
 
 text \<open>
 The following abbreviations are used in the spanning tree application using Prim's algorithm to construct the new tree for the exchange property.
 It is obtained by replacing an edge with one that has minimal weight and reversing the path connecting these edges.
 Here, w represents a weighted graph, v represents a set of nodes and e represents an edge.
 \<close>
 
 abbreviation prim_E :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" where "prim_E w v e \<equiv> w \<sqinter> --v * -v\<^sup>T \<sqinter> top * e * w\<^sup>T\<^sup>\<star>"
 abbreviation prim_P :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" where "prim_P w v e \<equiv> w \<sqinter> -v * -v\<^sup>T \<sqinter> top * e * w\<^sup>T\<^sup>\<star>"
 abbreviation prim_EP :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" where "prim_EP w v e \<equiv> w \<sqinter> -v\<^sup>T \<sqinter> top * e * w\<^sup>T\<^sup>\<star>"
 abbreviation prim_W :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" where "prim_W w v e \<equiv> (w \<sqinter> -(prim_EP w v e)) \<squnion> (prim_P w v e)\<^sup>T \<squnion> e"
 
 text \<open>
 The lemmas in this section are used to show that the relation after exchange represents a spanning tree.
 The results in the next section are used to show that it is a minimum spanning tree.
 \<close>
 
 lemma exchange_injective_3:
   assumes "e \<le> v * -v\<^sup>T"
       and "vector v"
     shows "(w \<sqinter> -(prim_EP w v e)) * e\<^sup>T = bot"
 proof -
   have 1: "top * e \<le> -v\<^sup>T"
     by (simp add: assms schroeder_4_p vTeT)
   have "top * e \<le> top * e * w\<^sup>T\<^sup>\<star>"
     using sup_right_divisibility star.circ_back_loop_fixpoint by blast
   hence "top * e \<le> -v\<^sup>T \<sqinter> top * e * w\<^sup>T\<^sup>\<star>"
     using 1 by simp
   hence "top * e \<le> -(w \<sqinter> -prim_EP w v e)"
     by (metis inf.assoc inf_import_p le_infI2 p_antitone p_antitone_iff)
   hence "(w \<sqinter> -(prim_EP w v e)) * e\<^sup>T \<le> bot"
     using p_top schroeder_4_p by blast
   thus ?thesis
     using le_bot by simp
 qed
 
 lemma exchange_injective_6:
   assumes "arc e"
       and "forest w"
     shows "(prim_P w v e)\<^sup>T * e\<^sup>T = bot"
 proof -
   have "e\<^sup>T * top * e \<le> --1"
     by (simp add: assms(1) local.p_antitone local.p_antitone_iff local.point_injective)
   hence 1: "e * -1 * e\<^sup>T \<le> bot"
     by (metis conv_involutive p_top triple_schroeder_p)
   have "(prim_P w v e)\<^sup>T * e\<^sup>T \<le> (w \<sqinter> top * e * w\<^sup>T\<^sup>\<star>)\<^sup>T * e\<^sup>T"
     using comp_inf.mult_left_isotone conv_dist_inf mult_left_isotone by simp
   also have "... = (w\<^sup>T \<sqinter> w\<^sup>T\<^sup>\<star>\<^sup>T * e\<^sup>T * top) * e\<^sup>T"
     by (simp add: comp_associative conv_dist_comp conv_dist_inf)
   also have "... = w\<^sup>\<star> * e\<^sup>T * top \<sqinter> w\<^sup>T * e\<^sup>T"
     by (simp add: conv_star_commute inf_vector_comp)
   also have "... \<le> (w\<^sup>T \<sqinter> w\<^sup>\<star> * e\<^sup>T * top * e) * (e\<^sup>T \<sqinter> w\<^sup>+ * e\<^sup>T * top)"
     by (metis dedekind mult_assoc conv_involutive inf_commute)
   also have "... \<le> (w\<^sup>\<star> * e\<^sup>T * top * e) * (w\<^sup>+ * e\<^sup>T * top)"
     by (simp add: mult_isotone)
   also have "... \<le> (top * e) * (w\<^sup>+ * e\<^sup>T * top)"
     by (simp add: mult_left_isotone)
   also have "... = top * e * w\<^sup>+ * e\<^sup>T * top"
     using mult_assoc by simp
   also have "... \<le> top * e * -1 * e\<^sup>T * top"
     using assms(2) mult_left_isotone mult_right_isotone by simp
   also have "... \<le> bot"
     using 1 by (metis le_bot semiring.mult_not_zero mult_assoc)
   finally show ?thesis
     using le_bot by simp
 qed
 
 text \<open>
 The graph after exchanging is injective.
 \<close>
 
 lemma exchange_injective:
   assumes "arc e"
       and "e \<le> v * -v\<^sup>T"
       and "forest w"
       and "vector v"
     shows "injective (prim_W w v e)"
 proof -
   have 1: "(w \<sqinter> -(prim_EP w v e)) * (w \<sqinter> -(prim_EP w v e))\<^sup>T \<le> 1"
   proof -
     have "(w \<sqinter> -(prim_EP w v e)) * (w \<sqinter> -(prim_EP w v e))\<^sup>T \<le> w * w\<^sup>T"
       by (simp add: comp_isotone conv_isotone)
     also have "... \<le> 1"
       by (simp add: assms(3))
     finally show ?thesis
       .
   qed
   have 2: "(w \<sqinter> -(prim_EP w v e)) * (prim_P w v e)\<^sup>T\<^sup>T \<le> 1"
   proof -
     have "top * (prim_P w v e)\<^sup>T = top * (w\<^sup>T \<sqinter> -v * -v\<^sup>T \<sqinter> w\<^sup>T\<^sup>\<star>\<^sup>T * e\<^sup>T * top)"
       by (simp add: comp_associative conv_complement conv_dist_comp conv_dist_inf)
     also have "... = top * e * w\<^sup>T\<^sup>\<star> * (w\<^sup>T \<sqinter> -v * -v\<^sup>T)"
       by (metis comp_inf_vector conv_dist_comp conv_involutive inf_top_left mult_assoc)
     also have "... \<le> top * e * w\<^sup>T\<^sup>\<star> * (w\<^sup>T \<sqinter> top * -v\<^sup>T)"
       using comp_inf.mult_right_isotone mult_left_isotone mult_right_isotone by simp
     also have "... = top * e * w\<^sup>T\<^sup>\<star> * w\<^sup>T \<sqinter> -v\<^sup>T"
       by (metis assms(4) comp_inf_covector vector_conv_compl)
     also have "... \<le> -v\<^sup>T \<sqinter> top * e * w\<^sup>T\<^sup>\<star>"
       by (simp add: comp_associative comp_isotone inf.coboundedI1 star.circ_plus_same star.left_plus_below_circ)
     finally have "top * (prim_P w v e)\<^sup>T \<le> -(w \<sqinter> -prim_EP w v e)"
       by (metis inf.assoc inf_import_p le_infI2 p_antitone p_antitone_iff)
     hence "(w \<sqinter> -(prim_EP w v e)) * (prim_P w v e)\<^sup>T\<^sup>T \<le> bot"
       using p_top schroeder_4_p by blast
     thus ?thesis
       by (simp add: bot_unique)
   qed
   have 3: "(w \<sqinter> -(prim_EP w v e)) * e\<^sup>T \<le> 1"
     by (metis assms(2,4) exchange_injective_3 bot_least)
   have 4: "(prim_P w v e)\<^sup>T * (w \<sqinter> -(prim_EP w v e))\<^sup>T \<le> 1"
     using 2 conv_dist_comp coreflexive_symmetric by fastforce
   have 5: "(prim_P w v e)\<^sup>T * (prim_P w v e)\<^sup>T\<^sup>T \<le> 1"
   proof -
     have "(prim_P w v e)\<^sup>T * (prim_P w v e)\<^sup>T\<^sup>T \<le> (top * e * w\<^sup>T\<^sup>\<star>)\<^sup>T * (top * e * w\<^sup>T\<^sup>\<star>)"
       by (simp add: conv_dist_inf mult_isotone)
     also have "... = w\<^sup>\<star> * e\<^sup>T * top * top * e * w\<^sup>T\<^sup>\<star>"
       using conv_star_commute conv_dist_comp conv_involutive conv_top mult_assoc by presburger
     also have "... = w\<^sup>\<star> * e\<^sup>T * top * e * w\<^sup>T\<^sup>\<star>"
       by (simp add: comp_associative)
     also have "... \<le> w\<^sup>\<star> * 1 * w\<^sup>T\<^sup>\<star>"
       by (metis comp_left_isotone comp_right_isotone mult_assoc assms(1) point_injective)
     finally have "(prim_P w v e)\<^sup>T * (prim_P w v e)\<^sup>T\<^sup>T \<le> w\<^sup>\<star> * w\<^sup>T\<^sup>\<star> \<sqinter> w\<^sup>T * w"
       by (simp add: conv_isotone inf.left_commute inf.sup_monoid.add_commute mult_isotone)
     also have "... \<le> 1"
       by (simp add: assms(3) forest_separate)
     finally show ?thesis
       .
   qed
   have 6: "(prim_P w v e)\<^sup>T * e\<^sup>T \<le> 1"
     using assms exchange_injective_6 bot_least by simp
   have 7: "e * (w \<sqinter> -(prim_EP w v e))\<^sup>T \<le> 1"
     using 3 by (metis conv_dist_comp conv_involutive coreflexive_symmetric)
   have 8: "e * (prim_P w v e)\<^sup>T\<^sup>T \<le> 1"
     using 6 conv_dist_comp coreflexive_symmetric by fastforce
   have 9: "e * e\<^sup>T \<le> 1"
     by (simp add: assms(1) arc_injective)
   have "(prim_W w v e) * (prim_W w v e)\<^sup>T = (w \<sqinter> -(prim_EP w v e)) * (w \<sqinter> -(prim_EP w v e))\<^sup>T \<squnion> (w \<sqinter> -(prim_EP w v e)) * (prim_P w v e)\<^sup>T\<^sup>T \<squnion> (w \<sqinter> -(prim_EP w v e)) * e\<^sup>T \<squnion> (prim_P w v e)\<^sup>T * (w \<sqinter> -(prim_EP w v e))\<^sup>T \<squnion> (prim_P w v e)\<^sup>T * (prim_P w v e)\<^sup>T\<^sup>T \<squnion> (prim_P w v e)\<^sup>T * e\<^sup>T  \<squnion> e * (w \<sqinter> -(prim_EP w v e))\<^sup>T \<squnion> e * (prim_P w v e)\<^sup>T\<^sup>T \<squnion> e * e\<^sup>T"
     using comp_left_dist_sup comp_right_dist_sup conv_dist_sup sup.assoc by simp
   also have "... \<le> 1"
     using 1 2 3 4 5 6 7 8 9 by simp
   finally show ?thesis
     .
 qed
 
 lemma pv:
   assumes "vector v"
     shows "(prim_P w v e)\<^sup>T * v = bot"
 proof -
   have "(prim_P w v e)\<^sup>T * v \<le> (-v * -v\<^sup>T)\<^sup>T * v"
     by (meson conv_isotone inf_le1 inf_le2 mult_left_isotone order_trans)
   also have "... = -v * -v\<^sup>T * v"
     by (simp add: conv_complement conv_dist_comp)
   also have "... = bot"
     by (simp add: assms covector_vector_comp mult_assoc)
   finally show ?thesis
     by (simp add: antisym)
 qed
 
 lemma vector_pred_inv:
   assumes "arc e"
       and "e \<le> v * -v\<^sup>T"
       and "forest w"
       and "vector v"
       and "w * v \<le> v"
     shows "(prim_W w v e) * (v \<squnion> e\<^sup>T * top) \<le> v \<squnion> e\<^sup>T * top"
 proof -
   have "(prim_W w v e) * e\<^sup>T * top = (w \<sqinter> -(prim_EP w v e)) * e\<^sup>T * top \<squnion> (prim_P w v e)\<^sup>T * e\<^sup>T * top \<squnion> e * e\<^sup>T * top"
     by (simp add: mult_right_dist_sup)
   also have "... = e * e\<^sup>T * top"
    using assms exchange_injective_3 exchange_injective_6 comp_left_zero by simp
   also have "... \<le> v * -v\<^sup>T * e\<^sup>T * top"
     by (simp add: assms(2) comp_isotone)
   also have "... \<le> v * top"
     by (simp add: comp_associative mult_right_isotone)
   also have "... = v"
     by (simp add: assms(4))
   finally have 1: "(prim_W w v e) * e\<^sup>T * top \<le> v"
     .
   have "(prim_W w v e) * v = (w \<sqinter> -(prim_EP w v e)) * v \<squnion> (prim_P w v e)\<^sup>T * v \<squnion> e * v"
     by (simp add: mult_right_dist_sup)
   also have "... = (w \<sqinter> -(prim_EP w v e)) * v"
     by (metis assms(2,4) pv ev sup_bot_right)
   also have "... \<le> w * v"
     by (simp add: mult_left_isotone)
   finally have 2: "(prim_W w v e) * v \<le> v"
     using assms(5) order_trans by blast
   have "(prim_W w v e) * (v \<squnion> e\<^sup>T * top) = (prim_W w v e) * v \<squnion> (prim_W w v e) * e\<^sup>T * top"
     by (simp add: semiring.distrib_left mult_assoc)
   also have "... \<le> v"
     using 1 2 by simp
   also have "... \<le> v \<squnion> e\<^sup>T * top"
     by simp
   finally show ?thesis
     .
 qed
 
 text \<open>
 The graph after exchanging is acyclic.
 \<close>
 
 lemma exchange_acyclic:
   assumes "vector v"
       and "e \<le> v * -v\<^sup>T"
       and "w * v \<le> v"
       and "acyclic w"
     shows "acyclic (prim_W w v e)"
 proof -
   have 1: "(prim_P w v e)\<^sup>T * e = bot"
   proof -
     have "(prim_P w v e)\<^sup>T * e \<le> (-v * -v\<^sup>T)\<^sup>T * e"
       by (meson conv_order dual_order.trans inf.cobounded1 inf.cobounded2 mult_left_isotone)
     also have "... = -v * -v\<^sup>T * e"
       by (simp add: conv_complement conv_dist_comp)
     also have "... \<le> -v * -v\<^sup>T * v * -v\<^sup>T"
       by (simp add: assms(2) comp_associative mult_right_isotone)
     also have "... = bot"
       by (simp add: assms(1) covector_vector_comp mult_assoc)
     finally show ?thesis
       by (simp add: bot_unique)
   qed
   have 2: "e * e = bot"
     using assms(1,2) ee by auto
   have 3: "(w \<sqinter> -(prim_EP w v e)) * (prim_P w v e)\<^sup>T = bot"
   proof -
     have "top * (prim_P w v e) \<le> top * (-v * -v\<^sup>T \<sqinter> top * e * w\<^sup>T\<^sup>\<star>)"
       using comp_inf.mult_semi_associative mult_right_isotone by auto
     also have "... \<le> top * -v * -v\<^sup>T \<sqinter> top * top * e * w\<^sup>T\<^sup>\<star>"
       by (simp add: comp_inf_covector mult_assoc)
     also have "... \<le> top * -v\<^sup>T \<sqinter> top * e * w\<^sup>T\<^sup>\<star>"
       using mult_left_isotone top.extremum local.inf_mono by presburger
     also have "... = -v\<^sup>T \<sqinter> top * e * w\<^sup>T\<^sup>\<star>"
       by (simp add: assms(1) vector_conv_compl)
     finally have "top * (prim_P w v e) \<le> -(w \<sqinter> -prim_EP w v e)"
       by (metis inf.assoc inf_import_p le_infI2 p_antitone p_antitone_iff)
     hence "(w \<sqinter> -(prim_EP w v e)) * (prim_P w v e)\<^sup>T \<le> bot"
       using p_top schroeder_4_p by blast
     thus ?thesis
       using bot_unique by blast
   qed
   hence 4: "(w \<sqinter> -(prim_EP w v e)) * (prim_P w v e)\<^sup>T\<^sup>\<star> = w \<sqinter> -(prim_EP w v e)"
     using star_absorb by blast
   hence 5: "(w \<sqinter> -(prim_EP w v e))\<^sup>+ * (prim_P w v e)\<^sup>T\<^sup>\<star> = (w \<sqinter> -(prim_EP w v e))\<^sup>+"
     by (metis star_plus mult_assoc)
   hence 6: "(w \<sqinter> -(prim_EP w v e))\<^sup>\<star> * (prim_P w v e)\<^sup>T\<^sup>\<star> = (w \<sqinter> -(prim_EP w v e))\<^sup>+ \<squnion> (prim_P w v e)\<^sup>T\<^sup>\<star>"
     by (metis star.circ_loop_fixpoint mult_assoc)
   have 7: "(w \<sqinter> -(prim_EP w v e))\<^sup>+ * e \<le> v * top"
   proof -
     have "e \<le> v * top"
       using assms(2) dual_order.trans mult_right_isotone top_greatest by blast
     hence 8: "e \<squnion> w * v * top \<le> v * top"
       by (simp add: assms(1,3) comp_associative)
     have "(w \<sqinter> -(prim_EP w v e))\<^sup>+ * e \<le> w\<^sup>+ * e"
       by (simp add: comp_isotone star_isotone)
     also have "... \<le> w\<^sup>\<star> * e"
       by (simp add: mult_left_isotone star.left_plus_below_circ)
     also have "... \<le> v * top"
       using 8 by (simp add: comp_associative star_left_induct)
     finally show ?thesis
       .
   qed
   have 9: "(prim_P w v e)\<^sup>T * (w \<sqinter> -(prim_EP w v e))\<^sup>+ * e = bot"
   proof -
     have "(prim_P w v e)\<^sup>T * (w \<sqinter> -(prim_EP w v e))\<^sup>+ * e \<le> (prim_P w v e)\<^sup>T * v * top"
       using 7 by (simp add: mult_assoc mult_right_isotone)
     also have "... = bot"
       by (simp add: assms(1) pv)
     finally show ?thesis
       using bot_unique by blast
   qed
   have 10: "e * (w \<sqinter> -(prim_EP w v e))\<^sup>+ * e = bot"
   proof -
     have "e * (w \<sqinter> -(prim_EP w v e))\<^sup>+ * e \<le> e * v * top"
       using 7 by (simp add: mult_assoc mult_right_isotone)
     also have "... \<le> v * -v\<^sup>T * v * top"
       by (simp add: assms(2) mult_left_isotone)
     also have "... = bot"
       by (simp add: assms(1) covector_vector_comp mult_assoc)
     finally show ?thesis
       using bot_unique by blast
   qed
   have 11: "e * (prim_P w v e)\<^sup>T\<^sup>\<star> * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star> \<le> v * -v\<^sup>T"
   proof -
     have 12: "-v\<^sup>T * w \<le> -v\<^sup>T"
       by (metis assms(3) conv_complement order_lesseq_imp pp_increasing schroeder_6_p)
     have "v * -v\<^sup>T * (w \<sqinter> -(prim_EP w v e)) \<le> v * -v\<^sup>T * w"
       by (simp add: comp_isotone star_isotone)
     also have "... \<le> v * -v\<^sup>T"
       using 12 by (simp add: comp_isotone comp_associative)
     finally have 13: "v * -v\<^sup>T * (w \<sqinter> -(prim_EP w v e)) \<le> v * -v\<^sup>T"
       .
     have 14: "(prim_P w v e)\<^sup>T \<le> -v * -v\<^sup>T"
       by (metis conv_complement conv_dist_comp conv_involutive conv_order inf_le1 inf_le2 order_trans)
     have "e * (prim_P w v e)\<^sup>T\<^sup>\<star> \<le> v * -v\<^sup>T * (prim_P w v e)\<^sup>T\<^sup>\<star>"
       by (simp add: assms(2) mult_left_isotone)
     also have "... = v * -v\<^sup>T \<squnion> v * -v\<^sup>T * (prim_P w v e)\<^sup>T\<^sup>+"
       by (metis mult_assoc star.circ_back_loop_fixpoint star_plus sup_commute)
     also have "... = v * -v\<^sup>T \<squnion> v * -v\<^sup>T * (prim_P w v e)\<^sup>T\<^sup>\<star> * (prim_P w v e)\<^sup>T"
       by (simp add: mult_assoc star_plus)
     also have "... \<le> v * -v\<^sup>T \<squnion> v * -v\<^sup>T * (prim_P w v e)\<^sup>T\<^sup>\<star> * -v * -v\<^sup>T"
       using 14 mult_assoc mult_right_isotone sup_right_isotone by simp
     also have "... \<le> v * -v\<^sup>T \<squnion> v * top * -v\<^sup>T"
       by (metis top_greatest mult_right_isotone mult_left_isotone mult_assoc sup_right_isotone)
     also have "... = v * -v\<^sup>T"
       by (simp add: assms(1))
     finally have "e * (prim_P w v e)\<^sup>T\<^sup>\<star> * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star> \<le> v * -v\<^sup>T * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star>"
       by (simp add: mult_left_isotone)
     also have "... \<le> v * -v\<^sup>T"
       using 13 by (simp add: star_right_induct_mult)
     finally show ?thesis
       .
   qed
   have 15: "(w \<sqinter> -(prim_EP w v e))\<^sup>+ * (prim_P w v e)\<^sup>T\<^sup>\<star> * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star> \<le> -1"
   proof -
     have "(w \<sqinter> -(prim_EP w v e))\<^sup>+ * (prim_P w v e)\<^sup>T\<^sup>\<star> * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star> = (w \<sqinter> -(prim_EP w v e))\<^sup>+ * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star>"
       using 5 by simp
     also have "... = (w \<sqinter> -(prim_EP w v e))\<^sup>+"
       by (simp add: mult_assoc star.circ_transitive_equal)
     also have "... \<le> w\<^sup>+"
       by (simp add: comp_isotone star_isotone)
     finally show ?thesis
       using assms(4) by simp
   qed
   have 16: "(prim_P w v e)\<^sup>T * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star> * (prim_P w v e)\<^sup>T\<^sup>\<star> * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star> \<le> -1"
   proof -
     have "(w \<sqinter> -(prim_EP w v e))\<^sup>+ * (prim_P w v e)\<^sup>T\<^sup>+ \<le> (w \<sqinter> -(prim_EP w v e))\<^sup>+ * (prim_P w v e)\<^sup>T\<^sup>\<star>"
       by (simp add: mult_right_isotone star.left_plus_below_circ)
     also have "... = (w \<sqinter> -(prim_EP w v e))\<^sup>+"
       using 5 by simp
     also have "... \<le> w\<^sup>+"
       by (simp add: comp_isotone star_isotone)
     finally have "(w \<sqinter> -(prim_EP w v e))\<^sup>+ * (prim_P w v e)\<^sup>T\<^sup>+ \<le> -1"
       using assms(4) by simp
     hence 17: "(prim_P w v e)\<^sup>T\<^sup>+ * (w \<sqinter> -(prim_EP w v e))\<^sup>+ \<le> -1"
       by (simp add: comp_commute_below_diversity)
     have "(prim_P w v e)\<^sup>T\<^sup>+ \<le> w\<^sup>T\<^sup>+"
       by (simp add: comp_isotone conv_dist_inf inf.left_commute inf.sup_monoid.add_commute star_isotone)
     also have "... = w\<^sup>+\<^sup>T"
       by (simp add: conv_dist_comp conv_star_commute star_plus)
     also have "... \<le> -1"
       using assms(4) conv_complement conv_isotone by force
     finally have 18: "(prim_P w v e)\<^sup>T\<^sup>+ \<le> -1"
       .
     have "(prim_P w v e)\<^sup>T * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star> * (prim_P w v e)\<^sup>T\<^sup>\<star> * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star> = (prim_P w v e)\<^sup>T * ((w \<sqinter> -(prim_EP w v e))\<^sup>+ \<squnion> (prim_P w v e)\<^sup>T\<^sup>\<star>) * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star>"
       using 6 by (simp add: comp_associative)
     also have "... = (prim_P w v e)\<^sup>T * (w \<sqinter> -(prim_EP w v e))\<^sup>+ * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star> \<squnion> (prim_P w v e)\<^sup>T\<^sup>+ * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star>"
       by (simp add: mult_left_dist_sup mult_right_dist_sup)
     also have "... = (prim_P w v e)\<^sup>T * (w \<sqinter> -(prim_EP w v e))\<^sup>+ \<squnion> (prim_P w v e)\<^sup>T\<^sup>+ * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star>"
       by (simp add: mult_assoc star.circ_transitive_equal)
     also have "... = (prim_P w v e)\<^sup>T * (w \<sqinter> -(prim_EP w v e))\<^sup>+ \<squnion> (prim_P w v e)\<^sup>T\<^sup>+ * (1 \<squnion> (w \<sqinter> -(prim_EP w v e))\<^sup>+)"
       using star_left_unfold_equal by simp
     also have "... = (prim_P w v e)\<^sup>T * (w \<sqinter> -(prim_EP w v e))\<^sup>+ \<squnion> (prim_P w v e)\<^sup>T\<^sup>+ * (w \<sqinter> -(prim_EP w v e))\<^sup>+ \<squnion> (prim_P w v e)\<^sup>T\<^sup>+"
       by (simp add: mult_left_dist_sup sup.left_commute sup_commute)
     also have "... = ((prim_P w v e)\<^sup>T \<squnion> (prim_P w v e)\<^sup>T\<^sup>+) * (w \<sqinter> -(prim_EP w v e))\<^sup>+ \<squnion> (prim_P w v e)\<^sup>T\<^sup>+"
       by (simp add: mult_right_dist_sup)
     also have "... = (prim_P w v e)\<^sup>T\<^sup>+ * (w \<sqinter> -(prim_EP w v e))\<^sup>+ \<squnion> (prim_P w v e)\<^sup>T\<^sup>+"
       using star.circ_mult_increasing by (simp add: le_iff_sup)
     also have "... \<le> -1"
       using 17 18 by simp
     finally show ?thesis
       .
   qed
   have 19: "e * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star> * (prim_P w v e)\<^sup>T\<^sup>\<star> * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star> \<le> -1"
   proof -
     have "e * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star> * (prim_P w v e)\<^sup>T\<^sup>\<star> * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star> = e * ((w \<sqinter> -(prim_EP w v e))\<^sup>+ \<squnion> (prim_P w v e)\<^sup>T\<^sup>\<star>) * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star>"
       using 6 by (simp add: mult_assoc)
     also have "... = e * (w \<sqinter> -(prim_EP w v e))\<^sup>+ * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star> \<squnion> e * (prim_P w v e)\<^sup>T\<^sup>\<star> * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star>"
       by (simp add: mult_left_dist_sup mult_right_dist_sup)
     also have "... = e * (w \<sqinter> -(prim_EP w v e))\<^sup>+ \<squnion> e * (prim_P w v e)\<^sup>T\<^sup>\<star> * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star>"
       by (simp add: mult_assoc star.circ_transitive_equal)
     also have "... \<le> e * (prim_P w v e)\<^sup>T\<^sup>\<star> * (w \<sqinter> -(prim_EP w v e))\<^sup>+ \<squnion> e * (prim_P w v e)\<^sup>T\<^sup>\<star> * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star>"
       by (metis mult_right_sub_dist_sup_right semiring.add_right_mono star.circ_back_loop_fixpoint)
     also have "... \<le> e * (prim_P w v e)\<^sup>T\<^sup>\<star> * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star>"
       using mult_right_isotone star.left_plus_below_circ by auto
     also have "... \<le> v * -v\<^sup>T"
       using 11 by simp
     also have "... \<le> -1"
       by (simp add: pp_increasing schroeder_3_p)
     finally show ?thesis
       .
   qed
   have 20: "(prim_W w v e) * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star> * (prim_P w v e)\<^sup>T\<^sup>\<star> * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star> \<le> -1"
     using 15 16 19 by (simp add: comp_right_dist_sup)
   have 21: "(w \<sqinter> -(prim_EP w v e))\<^sup>+ * e * (prim_P w v e)\<^sup>T\<^sup>\<star> * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star> \<le> -1"
   proof -
     have "(w \<sqinter> -(prim_EP w v e)) * v * -v\<^sup>T \<le> w * v * -v\<^sup>T"
       by (simp add: comp_isotone star_isotone)
     also have "... \<le> v * -v\<^sup>T"
       by (simp add: assms(3) mult_left_isotone)
     finally have 22: "(w \<sqinter> -(prim_EP w v e)) * v * -v\<^sup>T \<le> v * -v\<^sup>T"
       .
     have "(w \<sqinter> -(prim_EP w v e))\<^sup>+ * e * (prim_P w v e)\<^sup>T\<^sup>\<star> * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star> \<le> (w \<sqinter> -(prim_EP w v e))\<^sup>+ * v * -v\<^sup>T"
       using 11 by (simp add: mult_right_isotone mult_assoc)
     also have "... \<le> (w \<sqinter> -(prim_EP w v e))\<^sup>\<star> * v * -v\<^sup>T"
       using mult_left_isotone star.left_plus_below_circ by blast
     also have "... \<le> v * -v\<^sup>T"
       using 22 by (simp add: star_left_induct_mult mult_assoc)
     also have "... \<le> -1"
       by (simp add: pp_increasing schroeder_3_p)
     finally show ?thesis
       .
   qed
   have 23: "(prim_P w v e)\<^sup>T * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star> * e * (prim_P w v e)\<^sup>T\<^sup>\<star> * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star> \<le> -1"
   proof -
     have "(prim_P w v e)\<^sup>T * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star> * e = (prim_P w v e)\<^sup>T * e \<squnion> (prim_P w v e)\<^sup>T * (w \<sqinter> -(prim_EP w v e))\<^sup>+ * e"
       using comp_left_dist_sup mult_assoc star.circ_loop_fixpoint sup_commute by auto
     also have "... = bot"
       using 1 9 by simp
     finally show ?thesis
       by simp
   qed
   have 24: "e * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star> * e * (prim_P w v e)\<^sup>T\<^sup>\<star> * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star> \<le> -1"
   proof -
     have "e * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star> * e = e * e \<squnion> e * (w \<sqinter> -(prim_EP w v e))\<^sup>+ * e"
       using comp_left_dist_sup mult_assoc star.circ_loop_fixpoint sup_commute by auto
     also have "... = bot"
       using 2 10 by simp
     finally show ?thesis
       by simp
   qed
   have 25: "(prim_W w v e) * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star> * e * (prim_P w v e)\<^sup>T\<^sup>\<star> * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star> \<le> -1"
     using 21 23 24 by (simp add: comp_right_dist_sup)
   have "(prim_W w v e)\<^sup>\<star> = ((prim_P w v e)\<^sup>T \<squnion> e)\<^sup>\<star> * ((w \<sqinter> -(prim_EP w v e)) * ((prim_P w v e)\<^sup>T \<squnion> e)\<^sup>\<star>)\<^sup>\<star>"
     by (metis star_sup_1 sup.left_commute sup_commute)
   also have "... = ((prim_P w v e)\<^sup>T\<^sup>\<star> \<squnion> e * (prim_P w v e)\<^sup>T\<^sup>\<star>) * ((w \<sqinter> -(prim_EP w v e)) * ((prim_P w v e)\<^sup>T\<^sup>\<star> \<squnion> e * (prim_P w v e)\<^sup>T\<^sup>\<star>))\<^sup>\<star>"
     using 1 2 star_separate by auto
   also have "... = ((prim_P w v e)\<^sup>T\<^sup>\<star> \<squnion> e * (prim_P w v e)\<^sup>T\<^sup>\<star>) * ((w \<sqinter> -(prim_EP w v e)) * (1 \<squnion> e * (prim_P w v e)\<^sup>T\<^sup>\<star>))\<^sup>\<star>"
     using 4 mult_left_dist_sup by auto
   also have "... = (w \<sqinter> -(prim_EP w v e))\<^sup>\<star> * ((prim_P w v e)\<^sup>T\<^sup>\<star> \<squnion> e * (prim_P w v e)\<^sup>T\<^sup>\<star>) * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star>"
     using 3 9 10 star_separate_2 by blast
   also have "... = (w \<sqinter> -(prim_EP w v e))\<^sup>\<star> * (prim_P w v e)\<^sup>T\<^sup>\<star> * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star> \<squnion> (w \<sqinter> -(prim_EP w v e))\<^sup>\<star> * e * (prim_P w v e)\<^sup>T\<^sup>\<star> * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star>"
     by (simp add: semiring.distrib_left semiring.distrib_right mult_assoc)
   finally have "(prim_W w v e)\<^sup>+ = (prim_W w v e) * ((w \<sqinter> -(prim_EP w v e))\<^sup>\<star> * (prim_P w v e)\<^sup>T\<^sup>\<star> * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star> \<squnion> (w \<sqinter> -(prim_EP w v e))\<^sup>\<star> * e * (prim_P w v e)\<^sup>T\<^sup>\<star> * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star>)"
     by simp
   also have "... = (prim_W w v e) * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star> * (prim_P w v e)\<^sup>T\<^sup>\<star> * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star> \<squnion> (prim_W w v e) * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star> * e * (prim_P w v e)\<^sup>T\<^sup>\<star> * (w \<sqinter> -(prim_EP w v e))\<^sup>\<star>"
     by (simp add: comp_left_dist_sup comp_associative)
   also have "... \<le> -1"
     using 20 25 by simp
   finally show ?thesis
     .
 qed
 
 text \<open>
 The following lemma shows that an edge across the cut between visited nodes and unvisited nodes does not leave the component of visited nodes.
 \<close>
 
 lemma mst_subgraph_inv:
   assumes "e \<le> v * -v\<^sup>T \<sqinter> g"
       and "t \<le> g"
       and "v\<^sup>T = r\<^sup>T * t\<^sup>\<star>"
     shows "e \<le> (r\<^sup>T * g\<^sup>\<star>)\<^sup>T * (r\<^sup>T * g\<^sup>\<star>) \<sqinter> g"
 proof -
   have "e \<le> v * -v\<^sup>T \<sqinter> g"
     by (rule assms(1))
   also have "... \<le> v * (-v\<^sup>T \<sqinter> v\<^sup>T * g) \<sqinter> g"
     by (simp add: dedekind_1)
   also have "... \<le> v * v\<^sup>T * g \<sqinter> g"
     by (simp add: comp_associative comp_right_isotone inf_commute le_infI2)
   also have "... = v * (r\<^sup>T * t\<^sup>\<star>) * g \<sqinter> g"
     by (simp add: assms(3))
   also have "... = (r\<^sup>T * t\<^sup>\<star>)\<^sup>T * (r\<^sup>T * t\<^sup>\<star>) * g \<sqinter> g"
     by (metis assms(3) conv_involutive)
   also have "... \<le> (r\<^sup>T * t\<^sup>\<star>)\<^sup>T * (r\<^sup>T * g\<^sup>\<star>) * g \<sqinter> g"
     using assms(2) comp_inf.mult_left_isotone comp_isotone star_isotone by auto
   also have "... \<le> (r\<^sup>T * t\<^sup>\<star>)\<^sup>T * (r\<^sup>T * g\<^sup>\<star>) \<sqinter> g"
     using inf.sup_right_isotone inf_commute mult_assoc mult_right_isotone star.left_plus_below_circ star_plus by presburger
   also have "... \<le> (r\<^sup>T * g\<^sup>\<star>)\<^sup>T * (r\<^sup>T * g\<^sup>\<star>) \<sqinter> g"
     using assms(2) comp_inf.mult_left_isotone conv_dist_comp conv_isotone mult_left_isotone star_isotone by auto
   finally show ?thesis
     .
 qed
 
 text \<open>
 The following lemmas show that the tree after exchanging contains the currently constructed and tree and its extension by the chosen edge.
 \<close>
 
 lemma mst_extends_old_tree:
   assumes "t \<le> w"
       and "t \<le> v * v\<^sup>T"
       and "vector v"
     shows "t \<le> prim_W w v e"
 proof -
   have "t \<sqinter> prim_EP w v e \<le> t \<sqinter> -v\<^sup>T"
     by (simp add: inf.coboundedI2 inf.sup_monoid.add_assoc)
   also have "... \<le> v * v\<^sup>T \<sqinter> -v\<^sup>T"
     by (simp add: assms(2) inf.coboundedI1)
   also have "... \<le> bot"
     by (simp add: assms(3) covector_vector_comp eq_refl schroeder_2)
   finally have "t \<le> -(prim_EP w v e)"
     using le_bot pseudo_complement by blast
   hence "t \<le> w \<sqinter> -(prim_EP w v e)"
     using assms(1) by simp
   thus ?thesis
     using local.le_supI1 by blast
 qed
 
 lemma mst_extends_new_tree:
   "t \<le> w \<Longrightarrow> t \<le> v * v\<^sup>T \<Longrightarrow> vector v \<Longrightarrow> t \<squnion> e \<le> prim_W w v e"
   using mst_extends_old_tree by auto
 
 end
 
 text \<open>
 We finally add the Kleene star to Stone relation algebras.
 Kleene star and the relational operations are reasonably independent.
 The only additional axiom we need in the generalisation to Stone-Kleene relation algebras is that star distributes over double complement.
 \<close>
 
 class stone_kleene_relation_algebra = stone_relation_algebra + pd_kleene_allegory +
   assumes pp_dist_star: "--(x\<^sup>\<star>) = (--x)\<^sup>\<star>"
 begin
 
 lemma regular_closed_star:
   "regular x \<Longrightarrow> regular (x\<^sup>\<star>)"
   by (simp add: pp_dist_star)
 
 lemma components_idempotent:
   "components (components x) = components x"
   using pp_dist_star star_involutive by auto
 
 text \<open>
 The following lemma shows that the nodes reachable in the tree after exchange contain the nodes reachable in the tree before exchange.
 \<close>
 
 lemma mst_reachable_inv:
   assumes "regular (prim_EP w v e)"
       and "vector r"
       and "e \<le> v * -v\<^sup>T"
       and "vector v"
       and "v\<^sup>T = r\<^sup>T * t\<^sup>\<star>"
       and "t \<le> w"
       and "t \<le> v * v\<^sup>T"
       and "w * v \<le> v"
     shows "r\<^sup>T * w\<^sup>\<star> \<le> r\<^sup>T * (prim_W w v e)\<^sup>\<star>"
 proof -
   have 1: "r\<^sup>T \<le> r\<^sup>T * (prim_W w v e)\<^sup>\<star>"
     using sup.bounded_iff star.circ_back_loop_prefixpoint by blast
   have "top * e * (w\<^sup>T \<sqinter> -v\<^sup>T)\<^sup>\<star> * w\<^sup>T \<sqinter> -v\<^sup>T = top * e * (w\<^sup>T \<sqinter> -v\<^sup>T)\<^sup>\<star> * (w\<^sup>T \<sqinter> -v\<^sup>T)"
     by (simp add: assms(4) covector_comp_inf vector_conv_compl)
   also have "... \<le> top * e * (w\<^sup>T \<sqinter> -v\<^sup>T)\<^sup>\<star>"
     by (simp add: comp_isotone mult_assoc star.circ_plus_same star.left_plus_below_circ)
   finally have 2: "top * e * (w\<^sup>T \<sqinter> -v\<^sup>T)\<^sup>\<star> * w\<^sup>T \<le> top * e * (w\<^sup>T \<sqinter> -v\<^sup>T)\<^sup>\<star> \<squnion> --v\<^sup>T"
     by (simp add: shunting_var_p)
   have 3: "--v\<^sup>T * w\<^sup>T \<le> top * e * (w\<^sup>T \<sqinter> -v\<^sup>T)\<^sup>\<star> \<squnion> --v\<^sup>T"
     by (metis assms(8) conv_dist_comp conv_order mult_assoc order.trans pp_comp_semi_commute pp_isotone sup.coboundedI1 sup_commute)
   have 4: "top * e \<le> top * e * (w\<^sup>T \<sqinter> -v\<^sup>T)\<^sup>\<star> \<squnion> --v\<^sup>T"
     using sup_right_divisibility star.circ_back_loop_fixpoint le_supI1 by blast
   have "(top * e * (w\<^sup>T \<sqinter> -v\<^sup>T)\<^sup>\<star> \<squnion> --v\<^sup>T) * w\<^sup>T = top * e * (w\<^sup>T \<sqinter> -v\<^sup>T)\<^sup>\<star> * w\<^sup>T \<squnion> --v\<^sup>T * w\<^sup>T"
     by (simp add: comp_right_dist_sup)
   also have "... \<le> top * e * (w\<^sup>T \<sqinter> -v\<^sup>T)\<^sup>\<star> \<squnion> --v\<^sup>T"
     using 2 3 by simp
   finally have "top * e \<squnion> (top * e * (w\<^sup>T \<sqinter> -v\<^sup>T)\<^sup>\<star> \<squnion> --v\<^sup>T) * w\<^sup>T \<le> top * e * (w\<^sup>T \<sqinter> -v\<^sup>T)\<^sup>\<star> \<squnion> --v\<^sup>T"
     using 4 by simp
   hence 5: "top * e * w\<^sup>T\<^sup>\<star> \<le> top * e * (w\<^sup>T \<sqinter> -v\<^sup>T)\<^sup>\<star> \<squnion> --v\<^sup>T"
     by (simp add: star_right_induct)
   have 6: "top * e \<le> top * e * (w\<^sup>T \<sqinter> -v * -v\<^sup>T \<sqinter> w\<^sup>\<star> * e\<^sup>T * top)\<^sup>\<star>"
     using sup_right_divisibility star.circ_back_loop_fixpoint by blast
   have "(top * e * (w\<^sup>T \<sqinter> -v * -v\<^sup>T \<sqinter> w\<^sup>\<star> * e\<^sup>T * top)\<^sup>\<star>)\<^sup>T \<le> (top * e * w\<^sup>T\<^sup>\<star>)\<^sup>T"
     by (simp add: star_isotone mult_right_isotone conv_isotone inf_assoc)
   also have "... = w\<^sup>\<star> * e\<^sup>T * top"
     by (simp add: conv_dist_comp conv_star_commute mult_assoc)
   finally have 7: "(top * e * (w\<^sup>T \<sqinter> -v * -v\<^sup>T \<sqinter> w\<^sup>\<star> * e\<^sup>T * top)\<^sup>\<star>)\<^sup>T \<le> w\<^sup>\<star> * e\<^sup>T * top"
     .
   have "(top * e * (w\<^sup>T \<sqinter> -v * -v\<^sup>T \<sqinter> w\<^sup>\<star> * e\<^sup>T * top)\<^sup>\<star>)\<^sup>T \<le> (top * e * (-v * -v\<^sup>T)\<^sup>\<star>)\<^sup>T"
     by (simp add: conv_isotone inf_commute mult_right_isotone star_isotone le_infI2)
   also have "... \<le> (top * v * -v\<^sup>T * (-v * -v\<^sup>T)\<^sup>\<star>)\<^sup>T"
     by (metis assms(3) conv_isotone mult_left_isotone mult_right_isotone mult_assoc)
   also have "... = (top * v * (-v\<^sup>T * -v)\<^sup>\<star> * -v\<^sup>T)\<^sup>T"
     by (simp add: mult_assoc star_slide)
   also have "... \<le> (top * -v\<^sup>T)\<^sup>T"
     using conv_order mult_left_isotone by auto
   also have "... = -v"
     by (simp add: assms(4) conv_complement vector_conv_compl)
   finally have 8: "(top * e * (w\<^sup>T \<sqinter> -v * -v\<^sup>T \<sqinter> w\<^sup>\<star> * e\<^sup>T * top)\<^sup>\<star>)\<^sup>T \<le> w\<^sup>\<star> * e\<^sup>T * top \<sqinter> -v"
     using 7 by simp
   have "covector (top * e * (w\<^sup>T \<sqinter> -v * -v\<^sup>T \<sqinter> w\<^sup>\<star> * e\<^sup>T * top)\<^sup>\<star>)"
     by (simp add: covector_mult_closed)
   hence "top * e * (w\<^sup>T \<sqinter> -v * -v\<^sup>T \<sqinter> w\<^sup>\<star> * e\<^sup>T * top)\<^sup>\<star> * (w\<^sup>T \<sqinter> -v\<^sup>T) = top * e * (w\<^sup>T \<sqinter> -v * -v\<^sup>T \<sqinter> w\<^sup>\<star> * e\<^sup>T * top)\<^sup>\<star> * (w\<^sup>T \<sqinter> -v\<^sup>T \<sqinter> (top * e * (w\<^sup>T \<sqinter> -v * -v\<^sup>T \<sqinter> w\<^sup>\<star> * e\<^sup>T * top)\<^sup>\<star>)\<^sup>T)"
     by (metis comp_inf_vector_1 inf.idem)
   also have "... \<le> top * e * (w\<^sup>T \<sqinter> -v * -v\<^sup>T \<sqinter> w\<^sup>\<star> * e\<^sup>T * top)\<^sup>\<star> * (w\<^sup>T \<sqinter> -v\<^sup>T \<sqinter> w\<^sup>\<star> * e\<^sup>T * top \<sqinter> -v)"
     using 8 mult_right_isotone inf.sup_right_isotone inf_assoc by simp
   also have "... = top * e * (w\<^sup>T \<sqinter> -v * -v\<^sup>T \<sqinter> w\<^sup>\<star> * e\<^sup>T * top)\<^sup>\<star> * (w\<^sup>T \<sqinter> (-v \<sqinter> -v\<^sup>T) \<sqinter> w\<^sup>\<star> * e\<^sup>T * top)"
     using inf_assoc inf_commute by (simp add: inf_assoc)
   also have "... = top * e * (w\<^sup>T \<sqinter> -v * -v\<^sup>T \<sqinter> w\<^sup>\<star> * e\<^sup>T * top)\<^sup>\<star> * (w\<^sup>T \<sqinter> -v * -v\<^sup>T \<sqinter> w\<^sup>\<star> * e\<^sup>T * top)"
     using assms(4) conv_complement vector_complement_closed vector_covector by fastforce
   also have "... \<le> top * e * (w\<^sup>T \<sqinter> -v * -v\<^sup>T \<sqinter> w\<^sup>\<star> * e\<^sup>T * top)\<^sup>\<star>"
     by (simp add: comp_associative comp_isotone star.circ_plus_same star.left_plus_below_circ)
   finally have 9: "top * e \<squnion> top * e * (w\<^sup>T \<sqinter> -v * -v\<^sup>T \<sqinter> w\<^sup>\<star> * e\<^sup>T * top)\<^sup>\<star> * (w\<^sup>T \<sqinter> -v\<^sup>T) \<le> top * e * (w\<^sup>T \<sqinter> -v * -v\<^sup>T \<sqinter> w\<^sup>\<star> * e\<^sup>T * top)\<^sup>\<star>"
     using 6 by simp
   have "prim_EP w v e \<le> -v\<^sup>T \<sqinter> top * e * w\<^sup>T\<^sup>\<star>"
     using inf.sup_left_isotone by auto
   also have "... \<le> top * e * (w\<^sup>T \<sqinter> -v\<^sup>T)\<^sup>\<star>"
     using 5 by (metis inf_commute shunting_var_p)
   also have "... \<le> top * e * (w\<^sup>T \<sqinter> -v * -v\<^sup>T \<sqinter> w\<^sup>\<star> * e\<^sup>T * top)\<^sup>\<star>"
     using 9 by (simp add: star_right_induct)
   finally have 10: "prim_EP w v e \<le> top * e * (prim_P w v e)\<^sup>T\<^sup>\<star>"
     by (simp add: conv_complement conv_dist_comp conv_dist_inf conv_star_commute mult_assoc)
   have "top * e = top * (v * -v\<^sup>T \<sqinter> e)"
     by (simp add: assms(3) inf.absorb2)
   also have "... \<le> top * (v * top \<sqinter> e)"
     using inf.sup_right_isotone inf_commute mult_right_isotone top_greatest by presburger
   also have "... = (top \<sqinter> (v * top)\<^sup>T) * e"
     using assms(4) covector_inf_comp_3 by presburger
   also have "... = top * v\<^sup>T * e"
     by (simp add: conv_dist_comp)
   also have "... = top * r\<^sup>T * t\<^sup>\<star> * e"
     by (simp add: assms(5) comp_associative)
   also have "... \<le> top * r\<^sup>T * (prim_W w v e)\<^sup>\<star> * e"
     by (metis assms(4,6,7) mst_extends_old_tree star_isotone mult_left_isotone mult_right_isotone)
   finally have 11: "top * e \<le> top * r\<^sup>T * (prim_W w v e)\<^sup>\<star> * e"
     .
   have "r\<^sup>T * (prim_W w v e)\<^sup>\<star> * (prim_EP w v e) \<le> r\<^sup>T * (prim_W w v e)\<^sup>\<star> * (top * e * (prim_P w v e)\<^sup>T\<^sup>\<star>)"
     using 10 mult_right_isotone by blast
   also have "... = r\<^sup>T * (prim_W w v e)\<^sup>\<star> * top * e * (prim_P w v e)\<^sup>T\<^sup>\<star>"
     by (simp add: mult_assoc)
   also have "... \<le> top * e * (prim_P w v e)\<^sup>T\<^sup>\<star>"
     by (metis comp_associative comp_inf_covector inf.idem inf.sup_right_divisibility)
   also have "... \<le> top * r\<^sup>T * (prim_W w v e)\<^sup>\<star> * e * (prim_P w v e)\<^sup>T\<^sup>\<star>"
     using 11 by (simp add: mult_left_isotone)
   also have "... = r\<^sup>T * (prim_W w v e)\<^sup>\<star> * e * (prim_P w v e)\<^sup>T\<^sup>\<star>"
     using assms(2) vector_conv_covector by auto
   also have "... \<le> r\<^sup>T * (prim_W w v e)\<^sup>\<star> * (prim_W w v e) * (prim_P w v e)\<^sup>T\<^sup>\<star>"
     by (simp add: mult_left_isotone mult_right_isotone)
   also have "... \<le> r\<^sup>T * (prim_W w v e)\<^sup>\<star> * (prim_W w v e) * (prim_W w v e)\<^sup>\<star>"
     by (meson dual_order.trans mult_right_isotone star_isotone sup_ge1 sup_ge2)
   also have "... \<le> r\<^sup>T * (prim_W w v e)\<^sup>\<star>"
     by (metis mult_assoc mult_right_isotone star.circ_transitive_equal star.left_plus_below_circ)
   finally have 12: "r\<^sup>T * (prim_W w v e)\<^sup>\<star> * (prim_EP w v e) \<le> r\<^sup>T * (prim_W w v e)\<^sup>\<star>"
     .
   have "r\<^sup>T * (prim_W w v e)\<^sup>\<star> * w \<le> r\<^sup>T * (prim_W w v e)\<^sup>\<star> * (w \<squnion> prim_EP w v e)"
     by (simp add: inf_assoc)
   also have "... = r\<^sup>T * (prim_W w v e)\<^sup>\<star> * ((w \<squnion> prim_EP w v e) \<sqinter> (-(prim_EP w v e) \<squnion> prim_EP w v e))"
     by (metis assms(1) inf_top_right stone)
   also have "... = r\<^sup>T * (prim_W w v e)\<^sup>\<star> * ((w \<sqinter> -(prim_EP w v e)) \<squnion> prim_EP w v e)"
     by (simp add: sup_inf_distrib2)
   also have "... = r\<^sup>T * (prim_W w v e)\<^sup>\<star> * (w \<sqinter> -(prim_EP w v e)) \<squnion> r\<^sup>T * (prim_W w v e)\<^sup>\<star> * (prim_EP w v e)"
     by (simp add: comp_left_dist_sup)
   also have "... \<le> r\<^sup>T * (prim_W w v e)\<^sup>\<star> * (prim_W w v e) \<squnion> r\<^sup>T * (prim_W w v e)\<^sup>\<star> * (prim_EP w v e)"
     using mult_right_isotone sup_left_isotone by auto
   also have "... \<le> r\<^sup>T * (prim_W w v e)\<^sup>\<star> \<squnion> r\<^sup>T * (prim_W w v e)\<^sup>\<star> * (prim_EP w v e)"
     using mult_assoc mult_right_isotone star.circ_plus_same star.left_plus_below_circ sup_left_isotone by auto
   also have "... = r\<^sup>T * (prim_W w v e)\<^sup>\<star>"
     using 12 sup.absorb1 by blast
   finally have "r\<^sup>T \<squnion> r\<^sup>T * (prim_W w v e)\<^sup>\<star> * w \<le> r\<^sup>T * (prim_W w v e)\<^sup>\<star>"
     using 1 by simp
   thus ?thesis
     by (simp add: star_right_induct)
 qed
 
 text \<open>
 Some of the following lemmas already hold in pseudocomplemented distributive Kleene allegories.
 \<close>
 
 subsubsection \<open>Exchange gives Minimum Spanning Trees\<close>
 
 text \<open>
 The lemmas in this section are used to show that the after exchange we obtain a minimum spanning tree.
 The following lemmas show various interactions between the three constituents of the tree after exchange.
 \<close>
 
 lemma epm_1:
   "vector v \<Longrightarrow> prim_E w v e \<squnion> prim_P w v e = prim_EP w v e"
   by (metis inf_commute inf_sup_distrib1 mult_assoc mult_right_dist_sup regular_closed_p regular_complement_top vector_conv_compl)
 
 lemma epm_2:
   assumes "regular (prim_EP w v e)"
       and "vector v"
     shows "(w \<sqinter> -(prim_EP w v e)) \<squnion> prim_P w v e \<squnion> prim_E w v e = w"
 proof -
   have "(w \<sqinter> -(prim_EP w v e)) \<squnion> prim_P w v e \<squnion> prim_E w v e = (w \<sqinter> -(prim_EP w v e)) \<squnion> prim_EP w v e"
     using epm_1 sup_assoc sup_commute assms(2) by (simp add: inf_sup_distrib1)
   also have "... = w \<squnion> prim_EP w v e"
     by (metis assms(1) inf_top.right_neutral regular_complement_top sup_inf_distrib2)
   also have "... = w"
     by (simp add: sup_inf_distrib1)
   finally show ?thesis
     .
 qed
 
 lemma epm_4:
   assumes "e \<le> w"
       and "injective w"
       and "w * v \<le> v"
       and "e \<le> v * -v\<^sup>T"
     shows "top * e * w\<^sup>T\<^sup>+ \<le> top * v\<^sup>T"
 proof -
   have "w\<^sup>\<star> * v \<le> v"
     by (simp add: assms(3) star_left_induct_mult)
   hence 1: "v\<^sup>T * w\<^sup>T\<^sup>\<star> \<le> v\<^sup>T"
     using conv_star_commute conv_dist_comp conv_isotone by fastforce
   have "e * w\<^sup>T \<le> w * w\<^sup>T \<sqinter> e * w\<^sup>T"
     by (simp add: assms(1) mult_left_isotone)
   also have "... \<le> 1 \<sqinter> e * w\<^sup>T"
     using assms(2) inf.sup_left_isotone by auto
   also have "... = 1 \<sqinter> w * e\<^sup>T"
     using calculation conv_dist_comp conv_involutive coreflexive_symmetric by fastforce
   also have "... \<le> w * e\<^sup>T"
     by simp
   also have "... \<le> w * -v * v\<^sup>T"
     by (metis assms(4) conv_complement conv_dist_comp conv_involutive conv_order mult_assoc mult_right_isotone)
   also have "... \<le> top * v\<^sup>T"
     by (simp add: mult_left_isotone)
   finally have "top * e * w\<^sup>T\<^sup>+ \<le> top * v\<^sup>T * w\<^sup>T\<^sup>\<star>"
     by (metis antisym comp_associative comp_isotone dense_top_closed mult_left_isotone transitive_top_closed)
   also have "... \<le> top * v\<^sup>T"
     using 1 by (simp add: mult_assoc mult_right_isotone)
   finally show ?thesis
     .
 qed
 
 lemma epm_5:
   assumes "e \<le> w"
       and "injective w"
       and "w * v \<le> v"
       and "e \<le> v * -v\<^sup>T"
       and "vector v"
     shows "prim_P w v e = bot"
 proof -
   have 1: "e = w \<sqinter> top * e"
     by (simp add: assms(1,2) epm_3)
   have 2: "top * e * w\<^sup>T\<^sup>+ \<le> top * v\<^sup>T"
     by (simp add: assms(1-4) epm_4)
   have 3: "-v * -v\<^sup>T \<sqinter> top * v\<^sup>T = bot"
     by (simp add: assms(5) comp_associative covector_vector_comp inf.sup_monoid.add_commute schroeder_2)
   have "prim_P w v e = (w \<sqinter> -v * -v\<^sup>T \<sqinter> top * e) \<squnion> (w \<sqinter> -v * -v\<^sup>T \<sqinter> top * e * w\<^sup>T\<^sup>+)"
     by (metis inf_sup_distrib1 mult_assoc star.circ_back_loop_fixpoint star_plus sup_commute)
   also have "... \<le> (e \<sqinter> -v * -v\<^sup>T) \<squnion> (w \<sqinter> -v * -v\<^sup>T \<sqinter> top * e * w\<^sup>T\<^sup>+)"
     using 1 by (metis comp_inf.mult_semi_associative inf.sup_monoid.add_commute semiring.add_right_mono)
   also have "... \<le> (e \<sqinter> -v * -v\<^sup>T) \<squnion> (w \<sqinter> -v * -v\<^sup>T \<sqinter> top * v\<^sup>T)"
     using 2 by (metis sup_right_isotone inf.sup_right_isotone)
   also have "... \<le> (e \<sqinter> -v * -v\<^sup>T) \<squnion> (-v * -v\<^sup>T \<sqinter> top * v\<^sup>T)"
     using inf.assoc le_infI2 by auto
   also have "... \<le> v * -v\<^sup>T \<sqinter> -v * -v\<^sup>T"
     using 3 assms(4) inf.sup_left_isotone by auto
   also have "... \<le> v * top \<sqinter> -v * top"
     using inf.sup_mono mult_right_isotone top_greatest by blast
   also have "... = bot"
     using assms(5) inf_compl_bot vector_complement_closed by auto
   finally show ?thesis
     by (simp add: le_iff_inf)
 qed
 
 lemma epm_6:
   assumes "e \<le> w"
       and "injective w"
       and "w * v \<le> v"
       and "e \<le> v * -v\<^sup>T"
       and "vector v"
     shows "prim_E w v e = e"
 proof -
   have 1: "e \<le> --v * -v\<^sup>T"
     using assms(4) mult_isotone order_lesseq_imp pp_increasing by blast
   have 2: "top * e * w\<^sup>T\<^sup>+ \<le> top * v\<^sup>T"
     by (simp add: assms(1-4) epm_4)
   have 3: "e = w \<sqinter> top * e"
     by (simp add: assms(1,2) epm_3)
   hence "e \<le> top * e * w\<^sup>T\<^sup>\<star>"
     by (metis le_infI2 star.circ_back_loop_fixpoint sup.commute sup_ge1)
   hence 4: "e \<le> prim_E w v e"
     using 1 by (simp add: assms(1))
   have 5: "--v * -v\<^sup>T \<sqinter> top * v\<^sup>T = bot"
     by (simp add: assms(5) comp_associative covector_vector_comp inf.sup_monoid.add_commute schroeder_2)
   have "prim_E w v e = (w \<sqinter> --v * -v\<^sup>T \<sqinter> top * e) \<squnion> (w \<sqinter> --v * -v\<^sup>T \<sqinter> top * e * w\<^sup>T\<^sup>+)"
     by (metis inf_sup_distrib1 mult_assoc star.circ_back_loop_fixpoint star_plus sup_commute)
   also have "... \<le> (e \<sqinter> --v * -v\<^sup>T) \<squnion> (w \<sqinter> --v * -v\<^sup>T \<sqinter> top * e * w\<^sup>T\<^sup>+)"
     using 3 by (metis comp_inf.mult_semi_associative inf.sup_monoid.add_commute semiring.add_right_mono)
   also have "... \<le> (e \<sqinter> --v * -v\<^sup>T) \<squnion> (w \<sqinter> --v * -v\<^sup>T \<sqinter> top * v\<^sup>T)"
     using 2 by (metis sup_right_isotone inf.sup_right_isotone)
   also have "... \<le> (e \<sqinter> --v * -v\<^sup>T) \<squnion> (--v * -v\<^sup>T \<sqinter> top * v\<^sup>T)"
     using inf.assoc le_infI2 by auto
   also have "... \<le> e"
     by (simp add: "5")
   finally show ?thesis
     using 4 by (simp add: antisym)
 qed
 
 lemma epm_7:
   "regular (prim_EP w v e) \<Longrightarrow> e \<le> w \<Longrightarrow> injective w \<Longrightarrow> w * v \<le> v \<Longrightarrow> e \<le> v * -v\<^sup>T \<Longrightarrow> vector v \<Longrightarrow> prim_W w v e = w"
   by (metis conv_bot epm_2 epm_5 epm_6)
 
 lemma epm_8:
   assumes "acyclic w"
     shows "(w \<sqinter> -(prim_EP w v e)) \<sqinter> (prim_P w v e)\<^sup>T = bot"
 proof -
   have "(w \<sqinter> -(prim_EP w v e)) \<sqinter> (prim_P w v e)\<^sup>T \<le> w \<sqinter> w\<^sup>T"
     by (meson conv_isotone inf_le1 inf_mono order_trans)
   thus ?thesis
     by (metis assms acyclic_asymmetric inf.commute le_bot)
 qed
 
 lemma epm_9:
   assumes "e \<le> v * -v\<^sup>T"
       and "vector v"
     shows "(w \<sqinter> -(prim_EP w v e)) \<sqinter> e = bot"
 proof -
   have 1: "e \<le> -v\<^sup>T"
     by (metis assms complement_conv_sub vector_conv_covector ev p_antitone_iff p_bot)
   have "(w \<sqinter> -(prim_EP w v e)) \<sqinter> e = (w \<sqinter> --v\<^sup>T \<sqinter> e) \<squnion> (w \<sqinter> -(top * e * w\<^sup>T\<^sup>\<star>) \<sqinter> e)"
     by (simp add: inf_commute inf_sup_distrib1)
   also have "... \<le> (--v\<^sup>T \<sqinter> e) \<squnion> (-(top * e * w\<^sup>T\<^sup>\<star>) \<sqinter> e)"
     using comp_inf.mult_left_isotone inf.cobounded2 semiring.add_mono by blast
   also have "... = -(top * e * w\<^sup>T\<^sup>\<star>) \<sqinter> e"
     using 1 by (metis inf.sup_relative_same_increasing inf_commute inf_sup_distrib1 maddux_3_13 regular_closed_p)
   also have "... = bot"
     by (metis inf.sup_relative_same_increasing inf_bot_right inf_commute inf_p mult_left_isotone star_outer_increasing top_greatest)
   finally show ?thesis
     by (simp add: le_iff_inf)
 qed
 
 lemma epm_10:
   assumes "e \<le> v * -v\<^sup>T"
       and "vector v"
     shows "(prim_P w v e)\<^sup>T \<sqinter> e = bot"
 proof -
   have "(prim_P w v e)\<^sup>T \<le> -v * -v\<^sup>T"
     by (simp add: conv_complement conv_dist_comp conv_dist_inf inf.absorb_iff1 inf.left_commute inf_commute)
   hence "(prim_P w v e)\<^sup>T \<sqinter> e \<le> -v * -v\<^sup>T \<sqinter> v * -v\<^sup>T"
     using assms(1) inf_mono by blast
   also have "... \<le> -v * top \<sqinter> v * top"
     using inf.sup_mono mult_right_isotone top_greatest by blast
   also have "... = bot"
     using assms(2) inf_compl_bot vector_complement_closed by auto
   finally show ?thesis
     by (simp add: le_iff_inf)
 qed
 
 lemma epm_11:
   assumes "vector v"
     shows "(w \<sqinter> -(prim_EP w v e)) \<sqinter> prim_P w v e = bot"
 proof -
   have "prim_P w v e \<le> prim_EP w v e"
     by (metis assms comp_isotone inf.sup_left_isotone inf.sup_right_isotone order.refl top_greatest vector_conv_compl)
   thus ?thesis
     using inf_le2 order_trans p_antitone pseudo_complement by blast
 qed
 
 lemma epm_12:
   assumes "vector v"
     shows "(w \<sqinter> -(prim_EP w v e)) \<sqinter> prim_E w v e = bot"
 proof -
   have "prim_E w v e \<le> prim_EP w v e"
     by (metis assms comp_isotone inf.sup_left_isotone inf.sup_right_isotone order.refl top_greatest vector_conv_compl)
   thus ?thesis
     using inf_le2 order_trans p_antitone pseudo_complement by blast
 qed
 
 lemma epm_13:
   assumes "vector v"
     shows "prim_P w v e \<sqinter> prim_E w v e = bot"
 proof -
   have "prim_P w v e \<sqinter> prim_E w v e \<le> -v * -v\<^sup>T \<sqinter> --v * -v\<^sup>T"
     by (meson dual_order.trans inf.cobounded1 inf.sup_mono inf_le2)
   also have "... \<le> -v * top \<sqinter> --v * top"
     using inf.sup_mono mult_right_isotone top_greatest by blast
   also have "... = bot"
     using assms inf_compl_bot vector_complement_closed by auto
   finally show ?thesis
     by (simp add: le_iff_inf)
 qed
 
 text \<open>
 The following lemmas show that the relation characterising the edge across the cut is an arc.
 \<close>
 
 lemma arc_edge_1:
   assumes "e \<le> v * -v\<^sup>T \<sqinter> g"
       and "vector v"
       and "v\<^sup>T = r\<^sup>T * t\<^sup>\<star>"
       and "t \<le> g"
       and "r\<^sup>T * g\<^sup>\<star> \<le> r\<^sup>T * w\<^sup>\<star>"
     shows "top * e \<le> v\<^sup>T * w\<^sup>\<star>"
 proof -
   have "top * e \<le> top * (v * -v\<^sup>T \<sqinter> g)"
     using assms(1) mult_right_isotone by auto
   also have "... \<le> top * (v * top \<sqinter> g)"
     using inf.sup_right_isotone inf_commute mult_right_isotone top_greatest by presburger
   also have "... = v\<^sup>T * g"
     by (metis assms(2) covector_inf_comp_3 inf_top.left_neutral)
   also have "... = r\<^sup>T * t\<^sup>\<star> * g"
     by (simp add: assms(3))
   also have "... \<le> r\<^sup>T * g\<^sup>\<star> * g"
     by (simp add: assms(4) mult_left_isotone mult_right_isotone star_isotone)
   also have "... \<le> r\<^sup>T * g\<^sup>\<star>"
     by (simp add: mult_assoc mult_right_isotone star.right_plus_below_circ)
   also have "... \<le> r\<^sup>T * w\<^sup>\<star>"
     by (simp add: assms(5))
   also have "... \<le> v\<^sup>T * w\<^sup>\<star>"
     by (metis assms(3) mult_left_isotone mult_right_isotone mult_1_right star.circ_reflexive)
   finally show ?thesis
     .
 qed
 
 lemma arc_edge_2:
   assumes "e \<le> v * -v\<^sup>T \<sqinter> g"
       and "vector v"
       and "v\<^sup>T = r\<^sup>T * t\<^sup>\<star>"
       and "t \<le> g"
       and "r\<^sup>T * g\<^sup>\<star> \<le> r\<^sup>T * w\<^sup>\<star>"
       and "w * v \<le> v"
       and "injective w"
     shows "top * e * w\<^sup>T\<^sup>\<star> \<le> v\<^sup>T * w\<^sup>\<star>"
 proof -
   have 1: "top * e \<le> v\<^sup>T * w\<^sup>\<star>"
     using assms(1-5) arc_edge_1 by blast
   have "v\<^sup>T * w\<^sup>\<star> * w\<^sup>T = v\<^sup>T * w\<^sup>T \<squnion> v\<^sup>T * w\<^sup>+ * w\<^sup>T"
     by (metis mult_assoc mult_left_dist_sup star.circ_loop_fixpoint sup_commute)
   also have "... \<le> v\<^sup>T \<squnion> v\<^sup>T * w\<^sup>+ * w\<^sup>T"
     by (metis assms(6) conv_dist_comp conv_isotone sup_left_isotone)
   also have "... = v\<^sup>T \<squnion> v\<^sup>T * w\<^sup>\<star> * (w * w\<^sup>T)"
     by (metis mult_assoc star_plus)
   also have "... \<le> v\<^sup>T \<squnion> v\<^sup>T * w\<^sup>\<star>"
     by (metis assms(7) mult_right_isotone mult_1_right sup_right_isotone)
   also have "... = v\<^sup>T * w\<^sup>\<star>"
     by (metis star.circ_back_loop_fixpoint sup_absorb2 sup_ge2)
   finally show ?thesis
     using 1 star_right_induct by auto
 qed
 
 lemma arc_edge_3:
   assumes "e \<le> v * -v\<^sup>T \<sqinter> g"
       and "vector v"
       and "v\<^sup>T = r\<^sup>T * t\<^sup>\<star>"
       and "t \<le> g"
       and "r\<^sup>T * g\<^sup>\<star> \<le> r\<^sup>T * w\<^sup>\<star>"
       and "w * v \<le> v"
       and "injective w"
       and "prim_E w v e = bot"
     shows "e = bot"
 proof -
   have "bot = prim_E w v e"
     by (simp add: assms(8))
   also have "... = w \<sqinter> --v * top \<sqinter> top * -v\<^sup>T \<sqinter> top * e * w\<^sup>T\<^sup>\<star>"
     by (metis assms(2) comp_inf_covector inf.assoc inf_top.left_neutral vector_conv_compl)
   also have "... = w \<sqinter> top * e * w\<^sup>T\<^sup>\<star> \<sqinter> -v\<^sup>T \<sqinter> --v"
     using assms(2) inf.assoc inf.commute vector_conv_compl vector_complement_closed by (simp add: inf_assoc)
   finally have 1: "w \<sqinter> top * e * w\<^sup>T\<^sup>\<star> \<sqinter> -v\<^sup>T \<le> -v"
     using shunting_1_pp by force
   have "w\<^sup>\<star> * e\<^sup>T * top = (top * e * w\<^sup>T\<^sup>\<star>)\<^sup>T"
     by (simp add: conv_star_commute comp_associative conv_dist_comp)
   also have "... \<le> (v\<^sup>T * w\<^sup>\<star>)\<^sup>T"
     using assms(1-7) arc_edge_2 by (simp add: conv_isotone)
   also have "... = w\<^sup>T\<^sup>\<star> * v"
     by (simp add: conv_star_commute conv_dist_comp)
   finally have 2: "w\<^sup>\<star> * e\<^sup>T * top \<le> w\<^sup>T\<^sup>\<star> * v"
     .
   have "(w\<^sup>T \<sqinter> w\<^sup>\<star> * e\<^sup>T * top)\<^sup>T * -v = (w \<sqinter> top * e * w\<^sup>T\<^sup>\<star>) * -v"
     by (simp add: conv_dist_comp conv_dist_inf conv_star_commute mult_assoc)
   also have "... = (w \<sqinter> top * e * w\<^sup>T\<^sup>\<star> \<sqinter> -v\<^sup>T) * top"
     by (metis assms(2) conv_complement covector_inf_comp_3 inf_top.right_neutral vector_complement_closed)
   also have "... \<le> -v * top"
     using 1 by (simp add: comp_isotone)
   also have "... = -v"
     using assms(2) vector_complement_closed by auto
   finally have "(w\<^sup>T \<sqinter> w\<^sup>\<star> * e\<^sup>T * top) * --v \<le> --v"
     using p_antitone_iff schroeder_3_p by auto
   hence "w\<^sup>\<star> * e\<^sup>T * top \<sqinter> w\<^sup>T * --v \<le> --v"
     by (simp add: inf_vector_comp)
   hence 3: "w\<^sup>T * --v \<le> --v \<squnion> -(w\<^sup>\<star> * e\<^sup>T * top)"
     by (simp add: inf.commute shunting_p)
   have "w\<^sup>T * -(w\<^sup>\<star> * e\<^sup>T * top) \<le> -(w\<^sup>\<star> * e\<^sup>T * top)"
     by (metis mult_assoc p_antitone p_antitone_iff schroeder_3_p star.circ_loop_fixpoint sup_commute sup_right_divisibility)
   also have "... \<le> --v \<squnion> -(w\<^sup>\<star> * e\<^sup>T * top)"
     by simp
   finally have "w\<^sup>T * (--v \<squnion> -(w\<^sup>\<star> * e\<^sup>T * top)) \<le> --v \<squnion> -(w\<^sup>\<star> * e\<^sup>T * top)"
     using 3 by (simp add: mult_left_dist_sup)
   hence "w\<^sup>T\<^sup>\<star> * (--v \<squnion> -(w\<^sup>\<star> * e\<^sup>T * top)) \<le> --v \<squnion> -(w\<^sup>\<star> * e\<^sup>T * top)"
     using star_left_induct_mult_iff by blast
   hence "w\<^sup>T\<^sup>\<star> * --v \<le> --v \<squnion> -(w\<^sup>\<star> * e\<^sup>T * top)"
     by (simp add: semiring.distrib_left)
   hence "w\<^sup>\<star> * e\<^sup>T * top \<sqinter> w\<^sup>T\<^sup>\<star> * --v \<le> --v"
     by (simp add: inf_commute shunting_p)
   hence "w\<^sup>\<star> * e\<^sup>T * top \<le> --v"
     using 2 by (metis inf.absorb1 p_antitone_iff p_comp_pp vector_export_comp)
   hence 4: "e\<^sup>T * top \<le> --v"
     by (metis mult_assoc star.circ_loop_fixpoint sup.bounded_iff)
   have "e\<^sup>T * top \<le> (v * -v\<^sup>T)\<^sup>T * top"
     using assms(1) comp_isotone conv_isotone by auto
   also have "... \<le> -v * top"
     by (simp add: conv_complement conv_dist_comp mult_assoc mult_right_isotone)
   also have "... = -v"
     using assms(2) vector_complement_closed by auto
   finally have "e\<^sup>T * top \<le> bot"
     using 4 shunting_1_pp by auto
   hence "e\<^sup>T = bot"
     using antisym bot_least top_right_mult_increasing by blast
   thus ?thesis
     using conv_bot by fastforce
 qed
 
 lemma arc_edge_4:
   assumes "e \<le> v * -v\<^sup>T \<sqinter> g"
       and "vector v"
       and "v\<^sup>T = r\<^sup>T * t\<^sup>\<star>"
       and "t \<le> g"
       and "r\<^sup>T * g\<^sup>\<star> \<le> r\<^sup>T * w\<^sup>\<star>"
       and "arc e"
     shows "top * prim_E w v e * top = top"
 proof -
   have "--v\<^sup>T * w = (--v\<^sup>T * w \<sqinter> -v\<^sup>T) \<squnion> (--v\<^sup>T * w \<sqinter> --v\<^sup>T)"
     by (simp add: maddux_3_11_pp)
   also have "... \<le> (--v\<^sup>T * w \<sqinter> -v\<^sup>T) \<squnion> --v\<^sup>T"
     using sup_right_isotone by auto
   also have "... = --v\<^sup>T * (w \<sqinter> -v\<^sup>T) \<squnion> --v\<^sup>T"
     using assms(2) covector_comp_inf covector_complement_closed vector_conv_covector by auto
   also have "... \<le> --v\<^sup>T * (w \<sqinter> -v\<^sup>T) * w\<^sup>\<star> \<squnion> --v\<^sup>T"
     by (metis star.circ_back_loop_fixpoint sup.cobounded2 sup_left_isotone)
   finally have 1: "--v\<^sup>T * w \<le> --v\<^sup>T * (w \<sqinter> -v\<^sup>T) * w\<^sup>\<star> \<squnion> --v\<^sup>T"
     .
   have "--v\<^sup>T * (w \<sqinter> -v\<^sup>T) * w\<^sup>\<star> * w \<le> --v\<^sup>T * (w \<sqinter> -v\<^sup>T) * w\<^sup>\<star> \<squnion> --v\<^sup>T"
     by (simp add: le_supI1 mult_assoc mult_right_isotone star.circ_plus_same star.left_plus_below_circ)
   hence 2: "(--v\<^sup>T * (w \<sqinter> -v\<^sup>T) * w\<^sup>\<star> \<squnion> --v\<^sup>T) * w \<le> --v\<^sup>T * (w \<sqinter> -v\<^sup>T) * w\<^sup>\<star> \<squnion> --v\<^sup>T"
     using 1 by (simp add: inf.orderE mult_right_dist_sup)
   have "v\<^sup>T \<le> --v\<^sup>T * (w \<sqinter> -v\<^sup>T) * w\<^sup>\<star> \<squnion> --v\<^sup>T"
     by (simp add: pp_increasing sup.coboundedI2)
   hence "v\<^sup>T * w\<^sup>\<star> \<le> --v\<^sup>T * (w \<sqinter> -v\<^sup>T) * w\<^sup>\<star> \<squnion> --v\<^sup>T"
     using 2 by (simp add: star_right_induct)
   hence 3: "-v\<^sup>T \<sqinter> v\<^sup>T * w\<^sup>\<star> \<le> --v\<^sup>T * (w \<sqinter> -v\<^sup>T) * w\<^sup>\<star>"
     by (metis inf_commute shunting_var_p)
   have "top * e = top * e \<sqinter> v\<^sup>T * w\<^sup>\<star>"
     by (meson assms(1-5) arc_edge_1 inf.orderE)
   also have "... \<le> top * v * -v\<^sup>T \<sqinter> v\<^sup>T * w\<^sup>\<star>"
     using assms(1) inf.sup_left_isotone mult_assoc mult_right_isotone by auto
   also have "... \<le> top * -v\<^sup>T \<sqinter> v\<^sup>T * w\<^sup>\<star>"
     using inf.sup_left_isotone mult_left_isotone top_greatest by blast
   also have "... = -v\<^sup>T \<sqinter> v\<^sup>T * w\<^sup>\<star>"
     by (simp add: assms(2) vector_conv_compl)
   also have "... \<le> --v\<^sup>T * (w \<sqinter> -v\<^sup>T) * w\<^sup>\<star>"
     using 3 by simp
   also have "... = (top \<sqinter> (--v)\<^sup>T) * (w \<sqinter> -v\<^sup>T) * w\<^sup>\<star>"
     by (simp add: conv_complement)
   also have "... = top * (w \<sqinter> --v \<sqinter> -v\<^sup>T) * w\<^sup>\<star>"
     using assms(2) covector_inf_comp_3 inf_assoc inf_left_commute vector_complement_closed by presburger
   also have "... = top * (w \<sqinter> --v * -v\<^sup>T) * w\<^sup>\<star>"
     by (metis assms(2) vector_complement_closed conv_complement inf_assoc vector_covector)
   finally have "top * (e\<^sup>T * top)\<^sup>T \<le> top * (w \<sqinter> --v * -v\<^sup>T) * w\<^sup>\<star>"
     by (metis conv_dist_comp conv_involutive conv_top mult_assoc top_mult_top)
   hence "top \<le> top * (w \<sqinter> --v * -v\<^sup>T) * w\<^sup>\<star> * (e\<^sup>T * top)"
     using assms(6) shunt_bijective by blast
   also have "... = top * (w \<sqinter> --v * -v\<^sup>T) * (top * e * w\<^sup>\<star>\<^sup>T)\<^sup>T"
     by (simp add: conv_dist_comp mult_assoc)
   also have "... = top * (w \<sqinter> --v * -v\<^sup>T \<sqinter> top * e * w\<^sup>\<star>\<^sup>T) * top"
     by (simp add: comp_inf_vector_1 mult_assoc)
   finally show ?thesis
     by (simp add: conv_star_commute top_le)
 qed
 
 lemma arc_edge_5:
   assumes "vector v"
       and "w * v \<le> v"
       and "injective w"
       and "arc e"
     shows "(prim_E w v e)\<^sup>T * top * prim_E w v e \<le> 1"
 proof -
   have 1: "e\<^sup>T * top * e \<le> 1"
     by (simp add: assms(4) point_injective)
   have "prim_E w v e \<le> --v * top"
     by (simp add: inf_commute le_infI2 mult_right_isotone)
   hence 2: "prim_E w v e \<le> --v"
     by (simp add: assms(1) vector_complement_closed)
   have 3: "w * --v \<le> --v"
     by (simp add: assms(2) p_antitone p_antitone_iff)
   have "w \<sqinter> top * prim_E w v e \<le> w * (prim_E w v e)\<^sup>T * prim_E w v e"
     by (metis dedekind_2 inf.commute inf_top.left_neutral)
   also have "... \<le> w * w\<^sup>T * prim_E w v e"
     by (simp add: conv_isotone le_infI1 mult_left_isotone mult_right_isotone)
   also have "... \<le> prim_E w v e"
     by (metis assms(3) mult_left_isotone mult_left_one)
   finally have 4: "w \<sqinter> top * prim_E w v e \<le> prim_E w v e"
     .
   have "w\<^sup>+ \<sqinter> top * prim_E w v e = w\<^sup>\<star> * (w \<sqinter> top * prim_E w v e)"
     by (simp add: comp_inf_covector star_plus)
   also have "... \<le> w\<^sup>\<star> * prim_E w v e"
     using 4 by (simp add: mult_right_isotone)
   also have "... \<le> --v"
     using 2 3 star_left_induct sup.bounded_iff by blast
   finally have 5: "w\<^sup>+ \<sqinter> top * prim_E w v e \<sqinter> -v = bot"
     using shunting_1_pp by blast
   hence 6: "w\<^sup>+\<^sup>T \<sqinter> (prim_E w v e)\<^sup>T * top \<sqinter> -v\<^sup>T = bot"
     using conv_complement conv_dist_comp conv_dist_inf conv_top conv_bot by force
   have "(prim_E w v e)\<^sup>T * top * prim_E w v e \<le> (top * e * w\<^sup>T\<^sup>\<star>)\<^sup>T * top * (top * e * w\<^sup>T\<^sup>\<star>)"
     by (simp add: conv_isotone mult_isotone)
   also have "... = w\<^sup>\<star> * e\<^sup>T * top * e * w\<^sup>T\<^sup>\<star>"
     by (metis conv_star_commute conv_dist_comp conv_involutive conv_top mult_assoc top_mult_top)
   also have "... \<le> w\<^sup>\<star> * w\<^sup>T\<^sup>\<star>"
     using 1 by (metis mult_assoc mult_1_right mult_right_isotone mult_left_isotone)
   also have "... = w\<^sup>\<star> \<squnion> w\<^sup>T\<^sup>\<star>"
     by (metis assms(3) cancel_separate inf.eq_iff star.circ_sup_sub_sup_one_1 star.circ_plus_one star_involutive)
   also have "... = w\<^sup>+ \<squnion> w\<^sup>T\<^sup>+ \<squnion> 1"
     by (metis star.circ_plus_one star_left_unfold_equal sup.assoc sup.commute)
   finally have 7: "(prim_E w v e)\<^sup>T * top * prim_E w v e \<le> w\<^sup>+ \<squnion> w\<^sup>T\<^sup>+ \<squnion> 1"
     .
   have "prim_E w v e \<le> --v * -v\<^sup>T"
     by (simp add: le_infI1)
   also have "... \<le> top * -v\<^sup>T"
     by (simp add: mult_left_isotone)
   also have "... = -v\<^sup>T"
     by (simp add: assms(1) vector_conv_compl)
   finally have 8: "prim_E w v e \<le> -v\<^sup>T"
     .
   hence 9: "(prim_E w v e)\<^sup>T \<le> -v"
     by (metis conv_complement conv_involutive conv_isotone)
   have "(prim_E w v e)\<^sup>T * top * prim_E w v e = (w\<^sup>+ \<squnion> w\<^sup>T\<^sup>+ \<squnion> 1) \<sqinter> (prim_E w v e)\<^sup>T * top * prim_E w v e"
     using 7 by (simp add: inf.absorb_iff2)
   also have "... = (1 \<sqinter> (prim_E w v e)\<^sup>T * top * prim_E w v e) \<squnion> (w\<^sup>+ \<sqinter> (prim_E w v e)\<^sup>T * top * prim_E w v e) \<squnion> (w\<^sup>T\<^sup>+ \<sqinter> (prim_E w v e)\<^sup>T * top * prim_E w v e)"
     using comp_inf.mult_right_dist_sup sup_assoc sup_commute by auto
   also have "... \<le> 1 \<squnion> (w\<^sup>+ \<sqinter> (prim_E w v e)\<^sup>T * top * prim_E w v e) \<squnion> (w\<^sup>T\<^sup>+ \<sqinter> (prim_E w v e)\<^sup>T * top * prim_E w v e)"
     using inf_le1 sup_left_isotone by blast
   also have "... \<le> 1 \<squnion> (w\<^sup>+ \<sqinter> (prim_E w v e)\<^sup>T * top * prim_E w v e) \<squnion> (w\<^sup>T\<^sup>+ \<sqinter> (prim_E w v e)\<^sup>T * top * -v\<^sup>T)"
     using 8 inf.sup_right_isotone mult_right_isotone sup_right_isotone by blast
   also have "... \<le> 1 \<squnion> (w\<^sup>+ \<sqinter> -v * top * prim_E w v e) \<squnion> (w\<^sup>T\<^sup>+ \<sqinter> (prim_E w v e)\<^sup>T * top * -v\<^sup>T)"
     using 9 by (metis inf.sup_right_isotone mult_left_isotone sup.commute sup_right_isotone)
   also have "... = 1 \<squnion> (w\<^sup>+ \<sqinter> -v * top \<sqinter> top * prim_E w v e) \<squnion> (w\<^sup>T\<^sup>+ \<sqinter> (prim_E w v e)\<^sup>T * top \<sqinter> top * -v\<^sup>T)"
     by (metis (no_types) vector_export_comp inf_top_right inf_assoc)
   also have "... = 1 \<squnion> (w\<^sup>+ \<sqinter> -v \<sqinter> top * prim_E w v e) \<squnion> (w\<^sup>T\<^sup>+ \<sqinter> (prim_E w v e)\<^sup>T * top \<sqinter> -v\<^sup>T)"
     using assms(1) vector_complement_closed vector_conv_compl by auto
   also have "... = 1"
     using 5 6 by (simp add: conv_star_commute conv_dist_comp inf.commute inf_assoc star.circ_plus_same)
   finally show ?thesis
     .
 qed
 
 lemma arc_edge_6:
   assumes "vector v"
       and "w * v \<le> v"
       and "injective w"
       and "arc e"
     shows "prim_E w v e * top * (prim_E w v e)\<^sup>T \<le> 1"
 proof -
   have "prim_E w v e * 1 * (prim_E w v e)\<^sup>T \<le> w * w\<^sup>T"
     using comp_isotone conv_order inf.coboundedI1 mult_one_associative by auto
   also have "... \<le> 1"
     by (simp add: assms(3))
   finally have 1: "prim_E w v e * 1 * (prim_E w v e)\<^sup>T \<le> 1"
     .
   have "(prim_E w v e)\<^sup>T * top * prim_E w v e \<le> 1"
     by (simp add: assms arc_edge_5)
   also have "... \<le> --1"
     by (simp add: pp_increasing)
   finally have 2: "prim_E w v e * -1 * (prim_E w v e)\<^sup>T \<le> bot"
     by (metis conv_involutive regular_closed_bot regular_dense_top triple_schroeder_p)
   have "prim_E w v e * top * (prim_E w v e)\<^sup>T = prim_E w v e * 1 * (prim_E w v e)\<^sup>T \<squnion> prim_E w v e * -1 * (prim_E w v e)\<^sup>T"
     by (metis mult_left_dist_sup mult_right_dist_sup regular_complement_top regular_one_closed)
   also have "... \<le> 1"
     using 1 2 by (simp add: bot_unique)
   finally show ?thesis
     .
 qed
 
 lemma arc_edge:
   assumes "e \<le> v * -v\<^sup>T \<sqinter> g"
       and "vector v"
       and "v\<^sup>T = r\<^sup>T * t\<^sup>\<star>"
       and "t \<le> g"
       and "r\<^sup>T * g\<^sup>\<star> \<le> r\<^sup>T * w\<^sup>\<star>"
       and "w * v \<le> v"
       and "injective w"
       and "arc e"
     shows "arc (prim_E w v e)"
 proof (intro conjI)
   have "prim_E w v e * top * (prim_E w v e)\<^sup>T \<le> 1"
     using assms(2,6-8) arc_edge_6 by simp
   thus "injective (prim_E w v e * top)"
     by (metis conv_dist_comp conv_top mult_assoc top_mult_top)
 next
   show "surjective (prim_E w v e * top)"
     using assms(1-5,8) arc_edge_4 mult_assoc by simp
 next
   have "(prim_E w v e)\<^sup>T * top * prim_E w v e \<le> 1"
     using assms(2,6-8) arc_edge_5 by simp
   thus "injective ((prim_E w v e)\<^sup>T * top)"
     by (metis conv_dist_comp conv_involutive conv_top mult_assoc top_mult_top)
 next
   have "top * prim_E w v e * top = top"
     using assms(1-5,8) arc_edge_4 by simp
   thus "surjective ((prim_E w v e)\<^sup>T * top)"
     by (metis mult_assoc conv_dist_comp conv_top)
 qed
 
 subsubsection \<open>Invariant implies Postcondition\<close>
 
 text \<open>
 The lemmas in this section are used to show that the invariant implies the postcondition at the end of the algorithm.
 The following lemma shows that the nodes reachable in the graph are the same as those reachable in the constructed tree.
 \<close>
 
 lemma span_post:
   assumes "regular v"
       and "vector v"
       and "v\<^sup>T = r\<^sup>T * t\<^sup>\<star>"
       and "v * -v\<^sup>T \<sqinter> g = bot"
       and "t \<le> v * v\<^sup>T \<sqinter> g"
       and "r\<^sup>T * (v * v\<^sup>T \<sqinter> g)\<^sup>\<star> \<le> r\<^sup>T * t\<^sup>\<star>"
     shows "v\<^sup>T = r\<^sup>T * g\<^sup>\<star>"
 proof -
   let ?vv = "v * v\<^sup>T \<sqinter> g"
   have 1: "r\<^sup>T \<le> v\<^sup>T"
     using assms(3) mult_right_isotone mult_1_right star.circ_reflexive by fastforce
   have "v * top \<sqinter> g = (v * v\<^sup>T \<squnion> v * -v\<^sup>T) \<sqinter> g"
     by (metis assms(1) conv_complement mult_left_dist_sup regular_complement_top)
   also have "... = ?vv \<squnion> (v * -v\<^sup>T \<sqinter> g)"
     by (simp add: inf_sup_distrib2)
   also have "... = ?vv"
     by (simp add: assms(4))
   finally have 2: "v * top \<sqinter> g = ?vv"
     by simp
   have "r\<^sup>T * ?vv\<^sup>\<star> \<le> v\<^sup>T * ?vv\<^sup>\<star>"
     using 1 by (simp add: comp_left_isotone)
   also have "... \<le> v\<^sup>T * (v * v\<^sup>T)\<^sup>\<star>"
     by (simp add: comp_right_isotone star.circ_isotone)
   also have "... \<le> v\<^sup>T"
     by (simp add: assms(2) vector_star_1)
   finally have "r\<^sup>T * ?vv\<^sup>\<star> \<le> v\<^sup>T"
     by simp
   hence "r\<^sup>T * ?vv\<^sup>\<star> * g = (r\<^sup>T * ?vv\<^sup>\<star> \<sqinter> v\<^sup>T) * g"
     by (simp add: inf.absorb1)
   also have "... = r\<^sup>T * ?vv\<^sup>\<star> * (v * top \<sqinter> g)"
     by (simp add: assms(2) covector_inf_comp_3)
   also have "... = r\<^sup>T * ?vv\<^sup>\<star> * ?vv"
     using 2 by simp
   also have "... \<le> r\<^sup>T * ?vv\<^sup>\<star>"
     by (simp add: comp_associative comp_right_isotone star.left_plus_below_circ star_plus)
   finally have "r\<^sup>T \<squnion> r\<^sup>T * ?vv\<^sup>\<star> * g \<le> r\<^sup>T * ?vv\<^sup>\<star>"
     using star.circ_back_loop_prefixpoint by auto
   hence "r\<^sup>T * g\<^sup>\<star> \<le> r\<^sup>T * ?vv\<^sup>\<star>"
     using star_right_induct by blast
   hence "r\<^sup>T * g\<^sup>\<star> = r\<^sup>T * ?vv\<^sup>\<star>"
     by (simp add: antisym mult_right_isotone star_isotone)
   also have "... = r\<^sup>T * t\<^sup>\<star>"
     using assms(5,6) antisym mult_right_isotone star_isotone by auto
   also have "... = v\<^sup>T"
     by (simp add: assms(3))
   finally show ?thesis
     by simp
 qed
 
 text \<open>
 The following lemma shows that the minimum spanning tree extending a tree is the same as the tree at the end of the algorithm.
 \<close>
 
 lemma mst_post:
   assumes "vector r"
       and "injective r"
       and "v\<^sup>T = r\<^sup>T * t\<^sup>\<star>"
       and "forest w"
       and "t \<le> w"
       and "w \<le> v * v\<^sup>T"
     shows "w = t"
 proof -
   have 1: "vector v"
     using assms(1,3) covector_mult_closed vector_conv_covector by auto
   have "w * v \<le> v * v\<^sup>T * v"
     by (simp add: assms(6) mult_left_isotone)
   also have "... \<le> v"
     using 1 by (metis mult_assoc mult_right_isotone top_greatest)
   finally have 2: "w * v \<le> v"
     .
   have 3: "r \<le> v"
     by (metis assms(3) conv_order mult_right_isotone mult_1_right star.circ_reflexive)
   have 4: "v \<sqinter> -r = t\<^sup>T\<^sup>\<star> * r \<sqinter> -r"
     by (metis assms(3) conv_dist_comp conv_involutive conv_star_commute)
   also have "... = (r \<squnion> t\<^sup>T\<^sup>+ * r) \<sqinter> -r"
     using mult_assoc star.circ_loop_fixpoint sup_commute by auto
   also have "... \<le> t\<^sup>T\<^sup>+ * r"
     by (simp add: shunting)
   also have "... \<le> t\<^sup>T * top"
     by (simp add: comp_isotone mult_assoc)
   finally have "1 \<sqinter> (v \<sqinter> -r) * (v \<sqinter> -r)\<^sup>T \<le> 1 \<sqinter> t\<^sup>T * top * (t\<^sup>T * top)\<^sup>T"
     using conv_order inf.sup_right_isotone mult_isotone by auto
   also have "... = 1 \<sqinter> t\<^sup>T * top * t"
     by (metis conv_dist_comp conv_involutive conv_top mult_assoc top_mult_top)
   also have "... \<le> t\<^sup>T * (top * t \<sqinter> t * 1)"
     by (metis conv_involutive dedekind_1 inf.commute mult_assoc)
   also have "... \<le> t\<^sup>T * t"
     by (simp add: mult_right_isotone)
   finally have 5: "1 \<sqinter> (v \<sqinter> -r) * (v \<sqinter> -r)\<^sup>T \<le> t\<^sup>T * t"
     .
   have "w * w\<^sup>+ \<le> -1"
     by (metis assms(4) mult_right_isotone order_trans star.circ_increasing star.left_plus_circ)
   hence 6: "w\<^sup>T\<^sup>+ \<le> -w"
     by (metis conv_star_commute mult_assoc mult_1_left triple_schroeder_p)
   have "w * r \<sqinter> w\<^sup>T\<^sup>+ * r = (w \<sqinter> w\<^sup>T\<^sup>+) * r"
     using assms(2) by (simp add: injective_comp_right_dist_inf)
   also have "... = bot"
     using 6 p_antitone pseudo_complement_pp semiring.mult_not_zero by blast
   finally have 7: "w * r \<sqinter> w\<^sup>T\<^sup>+ * r = bot"
     .
   have "-1 * r \<le> -r"
     using assms(2) local.dual_order.trans local.pp_increasing local.schroeder_4_p by blast
   hence "-1 * r * top \<le> -r"
     by (simp add: assms(1) comp_associative)
   hence 8: "r\<^sup>T * -1 * r \<le> bot"
     by (simp add: mult_assoc schroeder_6_p)
   have "r\<^sup>T * w * r \<le> r\<^sup>T * w\<^sup>+ * r"
     by (simp add: mult_left_isotone mult_right_isotone star.circ_mult_increasing)
   also have "... \<le> r\<^sup>T * -1 * r"
     by (simp add: assms(4) comp_isotone)
   finally have "r\<^sup>T * w * r \<le> bot"
     using 8 by simp
   hence "w * r * top \<le> -r"
     by (simp add: mult_assoc schroeder_6_p)
   hence "w * r \<le> -r"
     by (simp add: assms(1) comp_associative)
   hence "w * r \<le> -r \<sqinter> w * v"
     using 3 by (simp add: mult_right_isotone)
   also have "... \<le> -r \<sqinter> v"
     using 2 by (simp add: le_infI2)
   also have "... = -r \<sqinter> t\<^sup>T\<^sup>\<star> * r"
     using 4 by (simp add: inf_commute)
   also have "... \<le> -r \<sqinter> w\<^sup>T\<^sup>\<star> * r"
     using assms(5) comp_inf.mult_right_isotone conv_isotone mult_left_isotone star_isotone by auto
   also have "... = -r \<sqinter> (r \<squnion> w\<^sup>T\<^sup>+ * r)"
     using mult_assoc star.circ_loop_fixpoint sup_commute by auto
   also have "... \<le> w\<^sup>T\<^sup>+ * r"
     using inf.commute maddux_3_13 by auto
   finally have "w * r = bot"
     using 7 by (simp add: le_iff_inf)
   hence "w = w \<sqinter> top * -r\<^sup>T"
     by (metis complement_conv_sub conv_dist_comp conv_involutive conv_bot inf.assoc inf.orderE regular_closed_bot regular_dense_top top_left_mult_increasing)
   also have "... = w \<sqinter> v * v\<^sup>T \<sqinter> top * -r\<^sup>T"
     by (simp add: assms(6) inf_absorb1)
   also have "... \<le> w \<sqinter> top * v\<^sup>T \<sqinter> top * -r\<^sup>T"
     using comp_inf.mult_left_isotone comp_inf.mult_right_isotone mult_left_isotone by auto
   also have "... = w \<sqinter> top * (v\<^sup>T \<sqinter> -r\<^sup>T)"
     using 1 assms(1) covector_inf_closed inf_assoc vector_conv_compl vector_conv_covector by auto
   also have "... = w * (1 \<sqinter> (v \<sqinter> -r) * top)"
     by (simp add: comp_inf_vector conv_complement conv_dist_inf)
   also have "... = w * (1 \<sqinter> (v \<sqinter> -r) * (v \<sqinter> -r)\<^sup>T)"
     by (metis conv_top dedekind_eq inf_commute inf_top_left mult_1_left mult_1_right)
   also have "... \<le> w * t\<^sup>T * t"
     using 5 by (simp add: comp_isotone mult_assoc)
   also have "... \<le> w * w\<^sup>T * t"
     by (simp add: assms(5) comp_isotone conv_isotone)
   also have "... \<le> t"
     using assms(4) mult_left_isotone mult_1_left by fastforce
   finally show ?thesis
     by (simp add: assms(5) antisym)
 qed
 
 subsection \<open>Kruskal's Algorithm\<close>
 
 text \<open>
 The following results are used for proving the correctness of Kruskal's minimum spanning tree algorithm.
 \<close>
 
 subsubsection \<open>Preservation of Invariant\<close>
 
 text \<open>
 We first treat the preservation of the invariant.
 The following lemmas show conditions necessary for preserving that \<open>f\<close> is a forest.
 \<close>
 
 lemma kruskal_injective_inv_2:
   assumes "arc e"
       and "acyclic f"
     shows "top * e * f\<^sup>T\<^sup>\<star> * f\<^sup>T \<le> -e"
 proof -
   have "f \<le> -f\<^sup>T\<^sup>\<star>"
     using assms(2) acyclic_star_below_complement p_antitone_iff by simp
   hence "e * f \<le> top * e * -f\<^sup>T\<^sup>\<star>"
     by (simp add: comp_isotone top_left_mult_increasing)
   also have "... = -(top * e * f\<^sup>T\<^sup>\<star>)"
     by (metis assms(1) comp_mapping_complement conv_dist_comp conv_involutive conv_top)
   finally show ?thesis
     using schroeder_4_p by simp
 qed
 
 lemma kruskal_injective_inv_3:
   assumes "arc e"
       and "forest f"
     shows "(top * e * f\<^sup>T\<^sup>\<star>)\<^sup>T * (top * e * f\<^sup>T\<^sup>\<star>) \<sqinter> f\<^sup>T * f \<le> 1"
 proof -
   have "(top * e * f\<^sup>T\<^sup>\<star>)\<^sup>T * (top * e * f\<^sup>T\<^sup>\<star>) = f\<^sup>\<star> * e\<^sup>T * top * e * f\<^sup>T\<^sup>\<star>"
     by (metis conv_dist_comp conv_involutive conv_star_commute conv_top vector_top_closed mult_assoc)
   also have "... \<le> f\<^sup>\<star> * f\<^sup>T\<^sup>\<star>"
     by (metis assms(1) arc_expanded mult_left_isotone mult_right_isotone mult_1_left mult_assoc)
   finally have "(top * e * f\<^sup>T\<^sup>\<star>)\<^sup>T * (top * e * f\<^sup>T\<^sup>\<star>) \<sqinter> f\<^sup>T * f \<le> f\<^sup>\<star> * f\<^sup>T\<^sup>\<star> \<sqinter> f\<^sup>T * f"
     using inf.sup_left_isotone by simp
   also have "... \<le> 1"
     using assms(2) forest_separate by simp
   finally show ?thesis
     by simp
 qed
 
 lemma kruskal_acyclic_inv:
   assumes "acyclic f"
       and "covector q"
       and "(f \<sqinter> q)\<^sup>T * f\<^sup>\<star> * e = bot"
       and "e * f\<^sup>\<star> * e = bot"
       and "f\<^sup>T\<^sup>\<star> * f\<^sup>\<star> \<le> -e"
     shows "acyclic ((f \<sqinter> -q) \<squnion> (f \<sqinter> q)\<^sup>T \<squnion> e)"
 proof -
   have "(f \<sqinter> -q) * (f \<sqinter> q)\<^sup>T = (f \<sqinter> -q) * (f\<^sup>T \<sqinter> q\<^sup>T)"
     by (simp add: conv_dist_inf)
   hence 1: "(f \<sqinter> -q) * (f \<sqinter> q)\<^sup>T = bot"
     by (metis assms(2) comp_inf.semiring.mult_zero_right comp_inf_vector_1 conv_bot covector_bot_closed inf.sup_monoid.add_assoc p_inf)
   hence 2: "(f \<sqinter> -q)\<^sup>\<star> * (f \<sqinter> q)\<^sup>T = (f \<sqinter> q)\<^sup>T"
     using mult_right_zero star_absorb star_simulation_right_equal by fastforce
   hence 3: "((f \<sqinter> -q) \<squnion> (f \<sqinter> q)\<^sup>T)\<^sup>+ = (f \<sqinter> q)\<^sup>T\<^sup>\<star> * (f \<sqinter> -q)\<^sup>+ \<squnion> (f \<sqinter> q)\<^sup>T\<^sup>+"
     by (simp add: plus_sup)
   have 4: "((f \<sqinter> -q) \<squnion> (f \<sqinter> q)\<^sup>T)\<^sup>\<star> = (f \<sqinter> q)\<^sup>T\<^sup>\<star> * (f \<sqinter> -q)\<^sup>\<star>"
     using 2 by (simp add: star.circ_sup_9)
   have "(f \<sqinter> q)\<^sup>T * (f \<sqinter> -q)\<^sup>\<star> * e \<le> (f \<sqinter> q)\<^sup>T * f\<^sup>\<star> * e"
     by (simp add: mult_left_isotone mult_right_isotone star_isotone)
   hence "(f \<sqinter> q)\<^sup>T * (f \<sqinter> -q)\<^sup>\<star> * e = bot"
     using assms(3) le_bot by simp
   hence 5: "(f \<sqinter> q)\<^sup>T\<^sup>\<star> * (f \<sqinter> -q)\<^sup>\<star> * e = (f \<sqinter> -q)\<^sup>\<star> * e"
     by (metis comp_associative conv_bot conv_dist_comp conv_involutive conv_star_commute star_absorb)
   have "e * (f \<sqinter> -q)\<^sup>\<star> * e \<le> e * f\<^sup>\<star> * e"
     by (simp add: mult_left_isotone mult_right_isotone star_isotone)
   hence "e * (f \<sqinter> -q)\<^sup>\<star> * e = bot"
     using assms(4) le_bot by simp
   hence 6: "((f \<sqinter> -q)\<^sup>\<star> * e)\<^sup>+ = (f \<sqinter> -q)\<^sup>\<star> * e"
     by (simp add: comp_associative star_absorb)
   have "f\<^sup>T\<^sup>\<star> * 1 * f\<^sup>T\<^sup>\<star> * f\<^sup>\<star> \<le> -e"
     by (simp add: assms(5) star.circ_transitive_equal)
   hence 7: "f\<^sup>\<star> * e * f\<^sup>T\<^sup>\<star> * f\<^sup>\<star> \<le> -1"
     by (metis comp_right_one conv_involutive conv_one conv_star_commute triple_schroeder_p)
   have "(f \<sqinter> -q)\<^sup>+ * (f \<sqinter> q)\<^sup>T\<^sup>+ \<le> -1"
     using 1 2 by (metis forest_bot mult_left_zero mult_assoc)
   hence 8: "(f \<sqinter> q)\<^sup>T\<^sup>+ * (f \<sqinter> -q)\<^sup>+ \<le> -1"
     using comp_commute_below_diversity by simp
   have 9: "f\<^sup>T\<^sup>+ \<le> -1"
     using assms(1) acyclic_star_below_complement schroeder_5_p by force
   have "((f \<sqinter> -q) \<squnion> (f \<sqinter> q)\<^sup>T \<squnion> e)\<^sup>+ = (((f \<sqinter> -q) \<squnion> (f \<sqinter> q)\<^sup>T)\<^sup>\<star> * e)\<^sup>\<star> * ((f \<sqinter> -q) \<squnion> (f \<sqinter> q)\<^sup>T)\<^sup>+ \<squnion> (((f \<sqinter> -q) \<squnion> (f \<sqinter> q)\<^sup>T)\<^sup>\<star> * e)\<^sup>+"
     by (simp add: plus_sup)
   also have "... = ((f \<sqinter> q)\<^sup>T\<^sup>\<star> * (f \<sqinter> -q)\<^sup>\<star> * e)\<^sup>\<star> * ((f \<sqinter> q)\<^sup>T\<^sup>\<star> * (f \<sqinter> -q)\<^sup>+ \<squnion> (f \<sqinter> q)\<^sup>T\<^sup>+) \<squnion> ((f \<sqinter> q)\<^sup>T\<^sup>\<star> * (f \<sqinter> -q)\<^sup>\<star> * e)\<^sup>+"
     using 3 4 by simp
   also have "... = ((f \<sqinter> -q)\<^sup>\<star> * e)\<^sup>\<star> * ((f \<sqinter> q)\<^sup>T\<^sup>\<star> * (f \<sqinter> -q)\<^sup>+ \<squnion> (f \<sqinter> q)\<^sup>T\<^sup>+) \<squnion> ((f \<sqinter> -q)\<^sup>\<star> * e)\<^sup>+"
     using 5 by simp
   also have "... = ((f \<sqinter> -q)\<^sup>\<star> * e \<squnion> 1) * ((f \<sqinter> q)\<^sup>T\<^sup>\<star> * (f \<sqinter> -q)\<^sup>+ \<squnion> (f \<sqinter> q)\<^sup>T\<^sup>+) \<squnion> (f \<sqinter> -q)\<^sup>\<star> * e"
     using 6 by (metis star_left_unfold_equal sup_monoid.add_commute)
   also have "... = (f \<sqinter> -q)\<^sup>\<star> * e \<squnion> (f \<sqinter> -q)\<^sup>\<star> * e * (f \<sqinter> q)\<^sup>T\<^sup>+ \<squnion> (f \<sqinter> -q)\<^sup>\<star> * e * (f \<sqinter> q)\<^sup>T\<^sup>\<star> * (f \<sqinter> -q)\<^sup>+ \<squnion> (f \<sqinter> q)\<^sup>T\<^sup>\<star> * (f \<sqinter> -q)\<^sup>+ \<squnion> (f \<sqinter> q)\<^sup>T\<^sup>+"
     using comp_associative mult_left_dist_sup mult_right_dist_sup sup_assoc sup_commute by simp
   also have "... = (f \<sqinter> -q)\<^sup>\<star> * e * (f \<sqinter> q)\<^sup>T\<^sup>\<star> * (f \<sqinter> -q)\<^sup>\<star> \<squnion> (f \<sqinter> q)\<^sup>T\<^sup>\<star> * (f \<sqinter> -q)\<^sup>+ \<squnion> (f \<sqinter> q)\<^sup>T\<^sup>+"
     by (metis star.circ_back_loop_fixpoint star_plus sup_monoid.add_commute mult_assoc)
   also have "... \<le> f\<^sup>\<star> * e * f\<^sup>T\<^sup>\<star> * (f \<sqinter> -q)\<^sup>\<star> \<squnion> (f \<sqinter> q)\<^sup>T\<^sup>\<star> * (f \<sqinter> -q)\<^sup>+ \<squnion> (f \<sqinter> q)\<^sup>T\<^sup>+"
     using mult_left_isotone mult_right_isotone star_isotone sup_left_isotone conv_isotone order_trans inf_le1 by meson
   also have "... \<le> f\<^sup>\<star> * e * f\<^sup>T\<^sup>\<star> * f\<^sup>\<star> \<squnion> (f \<sqinter> q)\<^sup>T\<^sup>\<star> * (f \<sqinter> -q)\<^sup>+ \<squnion> f\<^sup>T\<^sup>+"
     using mult_left_isotone mult_right_isotone star_isotone sup_left_isotone sup_right_isotone conv_isotone order_trans inf_le1 by meson
   also have "... = f\<^sup>\<star> * e * f\<^sup>T\<^sup>\<star> * f\<^sup>\<star> \<squnion> (f \<sqinter> q)\<^sup>T\<^sup>+ * (f \<sqinter> -q)\<^sup>+ \<squnion> (f \<sqinter> -q)\<^sup>+ \<squnion> f\<^sup>T\<^sup>+"
     by (simp add: star.circ_loop_fixpoint sup_monoid.add_assoc mult_assoc)
   also have "... \<le> f\<^sup>\<star> * e * f\<^sup>T\<^sup>\<star> * f\<^sup>\<star> \<squnion> (f \<sqinter> q)\<^sup>T\<^sup>+ * (f \<sqinter> -q)\<^sup>+ \<squnion> f\<^sup>+ \<squnion> f\<^sup>T\<^sup>+"
     using mult_left_isotone mult_right_isotone star_isotone sup_left_isotone sup_right_isotone order_trans inf_le1 by meson
   also have "... \<le> -1"
     using 7 8 9 assms(1) by simp
   finally show ?thesis
     by simp
 qed
 
 lemma kruskal_exchange_acyclic_inv_1:
   assumes "acyclic f"
       and "covector q"
     shows "acyclic ((f \<sqinter> -q) \<squnion> (f \<sqinter> q)\<^sup>T)"
   using kruskal_acyclic_inv[where e=bot] by (simp add: assms)
 
 lemma kruskal_exchange_acyclic_inv_2:
   assumes "acyclic w"
       and "injective w"
       and "d \<le> w"
       and "bijective (d\<^sup>T * top)"
       and "bijective (e * top)"
       and "d \<le> top * e\<^sup>T * w\<^sup>T\<^sup>\<star>"
       and "w * e\<^sup>T * top = bot"
     shows "acyclic ((w \<sqinter> -d) \<squnion> e)"
 proof -
   let ?v = "w \<sqinter> -d"
   let ?w = "?v \<squnion> e"
   have "d\<^sup>T * top \<le> w\<^sup>\<star> * e * top"
     by (metis assms(6) comp_associative comp_inf.star.circ_decompose_9 comp_inf.star_star_absorb comp_isotone conv_dist_comp conv_involutive conv_order conv_star_commute conv_top inf.cobounded1 vector_top_closed)
   hence 1: "e * top \<le> w\<^sup>T\<^sup>\<star> * d\<^sup>T * top"
     by (metis assms(4,5) bijective_reverse comp_associative conv_star_commute)
   have 2: "?v * d\<^sup>T * top = bot"
     by (simp add: assms(2,3) kruskal_exchange_acyclic_inv_3)
   have "?v * w\<^sup>T\<^sup>+ * d\<^sup>T * top \<le> w * w\<^sup>T\<^sup>+ * d\<^sup>T * top"
     by (simp add: mult_left_isotone)
   also have "... \<le> w\<^sup>T\<^sup>\<star> * d\<^sup>T * top"
     by (metis assms(2) mult_left_isotone mult_1_left mult_assoc)
   finally have "?v * w\<^sup>T\<^sup>\<star> * d\<^sup>T * top \<le> w\<^sup>T\<^sup>\<star> * d\<^sup>T * top"
     using 2 by (metis bot_least comp_associative mult_right_dist_sup star.circ_back_loop_fixpoint star.circ_plus_same sup_least)
   hence 3: "?v\<^sup>\<star> * e * top \<le> w\<^sup>T\<^sup>\<star> * d\<^sup>T * top"
     using 1 by (simp add: comp_associative star_left_induct sup_least)
   have "d * e\<^sup>T \<le> bot"
     by (metis assms(3,7) conv_bot conv_dist_comp conv_involutive conv_top order.trans inf.absorb2 inf.cobounded2 inf_commute le_bot p_antitone_iff p_top schroeder_4_p top_left_mult_increasing)
   hence 4: "e\<^sup>T * top \<le> -(d\<^sup>T * top)"
     by (metis (no_types) comp_associative inf.cobounded2 le_bot p_antitone_iff schroeder_3_p semiring.mult_zero_left)
   have "?v\<^sup>T * -(d\<^sup>T * top) \<le> -(d\<^sup>T * top)"
     using schroeder_3_p mult_assoc 2 by simp
   hence "?v\<^sup>T\<^sup>\<star> * e\<^sup>T * top \<le> -(d\<^sup>T * top)"
     using 4 by (simp add: comp_associative star_left_induct sup_least)
   hence 5: "d\<^sup>T * top \<le> -(?v\<^sup>T\<^sup>\<star> * e\<^sup>T * top)"
     by (simp add: p_antitone_iff)
   have "w * ?v\<^sup>T\<^sup>\<star> * e\<^sup>T * top = w * e\<^sup>T * top \<squnion> w * ?v\<^sup>T\<^sup>+ * e\<^sup>T * top"
     by (metis star_left_unfold_equal mult_right_dist_sup mult_left_dist_sup mult_1_right mult_assoc)
   also have "... = w * ?v\<^sup>T\<^sup>+ * e\<^sup>T * top"
     using assms(7) by simp
   also have "... \<le> w * w\<^sup>T * ?v\<^sup>T\<^sup>\<star> * e\<^sup>T * top"
     by (simp add: comp_associative conv_isotone mult_left_isotone mult_right_isotone)
   also have "... \<le> ?v\<^sup>T\<^sup>\<star> * e\<^sup>T * top"
     by (metis assms(2) mult_1_left mult_left_isotone)
   finally have "w * ?v\<^sup>T\<^sup>\<star> * e\<^sup>T * top \<le> --(?v\<^sup>T\<^sup>\<star> * e\<^sup>T * top)"
     by (simp add: p_antitone p_antitone_iff)
   hence "w\<^sup>T * -(?v\<^sup>T\<^sup>\<star> * e\<^sup>T * top) \<le> -(?v\<^sup>T\<^sup>\<star> * e\<^sup>T * top)"
     using comp_associative schroeder_3_p by simp
   hence 6: "w\<^sup>T\<^sup>\<star> * d\<^sup>T * top \<le> -(?v\<^sup>T\<^sup>\<star> * e\<^sup>T * top)"
     using 5 by (simp add: comp_associative star_left_induct sup_least)
   have "e * ?v\<^sup>\<star> * e \<le> e * ?v\<^sup>\<star> * e * top"
     by (simp add: top_right_mult_increasing)
   also have "... \<le> e * w\<^sup>T\<^sup>\<star> * d\<^sup>T * top"
     using 3 by (simp add: comp_associative mult_right_isotone)
   also have "... \<le> e * -(?v\<^sup>T\<^sup>\<star> * e\<^sup>T * top)"
     using 6 by (simp add: comp_associative mult_right_isotone)
   also have "... \<le> bot"
     by (metis conv_complement_sub_leq conv_dist_comp conv_involutive conv_star_commute le_bot mult_right_sub_dist_sup_right p_bot regular_closed_bot star.circ_back_loop_fixpoint)
   finally have 7: "e * ?v\<^sup>\<star> * e = bot"
     by (simp add: antisym)
   hence "?v\<^sup>\<star> * e \<le> -1"
     by (metis bot_least comp_associative comp_commute_below_diversity ex231d order_lesseq_imp semiring.mult_zero_left star.circ_left_top)
   hence 8: "?v\<^sup>\<star> * e * ?v\<^sup>\<star> \<le> -1"
     by (metis comp_associative comp_commute_below_diversity star.circ_transitive_equal)
   have "1 \<sqinter> ?w\<^sup>+ = 1 \<sqinter> ?w * ?v\<^sup>\<star> * (e * ?v\<^sup>\<star>)\<^sup>\<star>"
     by (simp add: star_sup_1 mult_assoc)
   also have "... = 1 \<sqinter> ?w * ?v\<^sup>\<star> * (e * ?v\<^sup>\<star> \<squnion> 1)"
     using 7 by (metis star.circ_mult_1 star_absorb sup_monoid.add_commute mult_assoc)
   also have "... = 1 \<sqinter> (?v\<^sup>+ * e * ?v\<^sup>\<star> \<squnion> ?v\<^sup>+ \<squnion> e * ?v\<^sup>\<star> * e * ?v\<^sup>\<star> \<squnion> e * ?v\<^sup>\<star>)"
     by (simp add: comp_associative mult_left_dist_sup mult_right_dist_sup sup_assoc sup_commute sup_left_commute)
   also have "... = 1 \<sqinter> (?v\<^sup>+ * e * ?v\<^sup>\<star> \<squnion> ?v\<^sup>+ \<squnion> e * ?v\<^sup>\<star>)"
     using 7 by simp
   also have "... = 1 \<sqinter> (?v\<^sup>\<star> * e * ?v\<^sup>\<star> \<squnion> ?v\<^sup>+)"
     by (metis (mono_tags, hide_lams) comp_associative star.circ_loop_fixpoint sup_assoc sup_commute)
   also have "... \<le> 1 \<sqinter> (?v\<^sup>\<star> * e * ?v\<^sup>\<star> \<squnion> w\<^sup>+)"
     using comp_inf.mult_right_isotone comp_isotone semiring.add_right_mono star_isotone sup_commute by simp
   also have "... = (1 \<sqinter> ?v\<^sup>\<star> * e * ?v\<^sup>\<star>) \<squnion> (1 \<sqinter> w\<^sup>+)"
     by (simp add: inf_sup_distrib1)
   also have "... = 1 \<sqinter> ?v\<^sup>\<star> * e * ?v\<^sup>\<star>"
     by (metis assms(1) inf_commute pseudo_complement sup_bot_right)
   also have "... = bot"
     using 8 p_antitone_iff pseudo_complement by simp
   finally show ?thesis
     using le_bot p_antitone_iff pseudo_complement by auto
 qed
 
 subsubsection \<open>Exchange gives Spanning Trees\<close>
 
 text \<open>
 The lemmas in this section are used to show that the relation after exchange represents a spanning tree.
 \<close>
 
 lemma inf_star_import:
   assumes "x \<le> z"
       and "univalent z"
       and "reflexive y"
       and "regular z"
     shows "x\<^sup>\<star> * y \<sqinter> z\<^sup>\<star> \<le> x\<^sup>\<star> * (y \<sqinter> z\<^sup>\<star>)"
 proof -
   have 1: "y \<le> x\<^sup>\<star> * (y \<sqinter> z\<^sup>\<star>) \<squnion> -z\<^sup>\<star>"
     by (metis assms(4) pp_dist_star shunting_var_p star.circ_loop_fixpoint sup.cobounded2)
   have "x * -z\<^sup>\<star> \<sqinter> z\<^sup>+ \<le> x * (-z\<^sup>\<star> \<sqinter> x\<^sup>T * z\<^sup>+)"
     by (simp add: dedekind_1)
   also have "... \<le> x * (-z\<^sup>\<star> \<sqinter> z\<^sup>T * z\<^sup>+)"
     using assms(1) comp_inf.mult_right_isotone conv_isotone mult_left_isotone mult_right_isotone by simp
   also have "... \<le> x * (-z\<^sup>\<star> \<sqinter> 1 * z\<^sup>\<star>)"
     by (metis assms(2) comp_associative comp_inf.mult_right_isotone mult_left_isotone mult_right_isotone)
   finally have 2: "x * -z\<^sup>\<star> \<sqinter> z\<^sup>+ = bot"
     by (simp add: antisym)
   have "x * -z\<^sup>\<star> \<sqinter> z\<^sup>\<star> = (x * -z\<^sup>\<star> \<sqinter> z\<^sup>+) \<squnion> (x * -z\<^sup>\<star> \<sqinter> 1)"
     by (metis comp_inf.semiring.distrib_left star_left_unfold_equal sup_commute)
   also have "... \<le> x\<^sup>\<star> * (y \<sqinter> z\<^sup>\<star>)"
     using 2 by (simp add: assms(3) inf.coboundedI2 reflexive_mult_closed star.circ_reflexive)
   finally have "x * -z\<^sup>\<star> \<le> x\<^sup>\<star> * (y \<sqinter> z\<^sup>\<star>) \<squnion> -z\<^sup>\<star>"
     by (metis assms(4) pp_dist_star shunting_var_p)
   hence "x * (x\<^sup>\<star> * (y \<sqinter> z\<^sup>\<star>) \<squnion> -z\<^sup>\<star>) \<le> x\<^sup>\<star> * (y \<sqinter> z\<^sup>\<star>) \<squnion> -z\<^sup>\<star>"
     by (metis le_supE le_supI mult_left_dist_sup star.circ_loop_fixpoint sup.cobounded1)
   hence "x\<^sup>\<star> * y \<le> x\<^sup>\<star> * (y \<sqinter> z\<^sup>\<star>) \<squnion> -z\<^sup>\<star>"
     using 1 by (simp add: star_left_induct)
   hence "x\<^sup>\<star> * y \<sqinter> --z\<^sup>\<star> \<le> x\<^sup>\<star> * (y \<sqinter> z\<^sup>\<star>)"
     using shunting_var_p by simp
   thus ?thesis
     using order.trans inf.sup_right_isotone pp_increasing by blast
 qed
 
 lemma kruskal_exchange_forest_components_inv:
   assumes "injective ((w \<sqinter> -d) \<squnion> e)"
       and "regular d"
       and "e * top * e = e"
       and "d \<le> top * e\<^sup>T * w\<^sup>T\<^sup>\<star>"
       and "w * e\<^sup>T * top = bot"
       and "injective w"
       and "d \<le> w"
       and "d \<le> (w \<sqinter> -d)\<^sup>T\<^sup>\<star> * e\<^sup>T * top"
     shows "forest_components w \<le> forest_components ((w \<sqinter> -d) \<squnion> e)"
 proof -
   let ?v = "w \<sqinter> -d"
   let ?w = "?v \<squnion> e"
   let ?f = "forest_components ?w"
   have 1: "?v * d\<^sup>T * top = bot"
     by (simp add: assms(6,7) kruskal_exchange_acyclic_inv_3)
   have 2: "d * e\<^sup>T \<le> bot"
     by (metis assms(5,7) conv_bot conv_dist_comp conv_involutive conv_top order.trans inf.absorb2 inf.cobounded2 inf_commute le_bot p_antitone_iff p_top schroeder_4_p top_left_mult_increasing)
   have "w\<^sup>\<star> * e\<^sup>T * top = e\<^sup>T * top"
     by (metis assms(5) conv_bot conv_dist_comp conv_involutive conv_star_commute star.circ_top star_absorb)
   hence "w\<^sup>\<star> * e\<^sup>T * top \<le> -(d\<^sup>T * top)"
     using 2 by (metis (no_types) comp_associative inf.cobounded2 le_bot p_antitone_iff schroeder_3_p semiring.mult_zero_left)
   hence 3: "e\<^sup>T * top \<le> -(w\<^sup>T\<^sup>\<star> * d\<^sup>T * top)"
     by (metis conv_star_commute p_antitone_iff schroeder_3_p mult_assoc)
   have "?v * w\<^sup>T\<^sup>\<star> * d\<^sup>T * top = ?v * d\<^sup>T * top \<squnion> ?v * w\<^sup>T\<^sup>+ * d\<^sup>T * top"
     by (metis comp_associative mult_left_dist_sup star.circ_loop_fixpoint sup_commute)
   also have "... \<le> w * w\<^sup>T\<^sup>+ * d\<^sup>T * top"
     using 1 by (simp add: mult_left_isotone)
   also have "... \<le> w\<^sup>T\<^sup>\<star> * d\<^sup>T * top"
     by (metis assms(6) mult_assoc mult_1_left mult_left_isotone)
   finally have "?v * w\<^sup>T\<^sup>\<star> * d\<^sup>T * top \<le> --(w\<^sup>T\<^sup>\<star> * d\<^sup>T * top)"
     using p_antitone p_antitone_iff by auto
   hence 4: "?v\<^sup>T * -(w\<^sup>T\<^sup>\<star> * d\<^sup>T * top) \<le> -(w\<^sup>T\<^sup>\<star> * d\<^sup>T * top)"
     using comp_associative schroeder_3_p by simp
   have 5: "injective ?v"
     using assms(1) conv_dist_sup mult_left_dist_sup mult_right_dist_sup by simp
   have "?v * ?v\<^sup>T\<^sup>\<star> * e\<^sup>T * top = ?v * e\<^sup>T * top \<squnion> ?v * ?v\<^sup>T\<^sup>+ * e\<^sup>T * top"
     by (metis comp_associative mult_left_dist_sup star.circ_loop_fixpoint sup_commute)
   also have "... \<le> w * e\<^sup>T * top \<squnion> ?v * ?v\<^sup>T\<^sup>+ * e\<^sup>T * top"
     using mult_left_isotone sup_left_isotone by simp
   also have "... \<le> w * e\<^sup>T * top \<squnion> ?v\<^sup>T\<^sup>\<star> * e\<^sup>T * top"
     using 5 by (metis mult_assoc mult_1_left mult_left_isotone sup_right_isotone)
   finally have "?v * ?v\<^sup>T\<^sup>\<star> * e\<^sup>T * top \<le> ?v\<^sup>T\<^sup>\<star> * e\<^sup>T * top"
     by (simp add: assms(5))
   hence "?v\<^sup>\<star> * d * top \<le> ?v\<^sup>T\<^sup>\<star> * e\<^sup>T * top"
     by (metis assms(8) star_left_induct sup_least comp_associative mult_right_sub_dist_sup_right sup.orderE vector_top_closed)
   also have "... \<le> -(w\<^sup>T\<^sup>\<star> * d\<^sup>T * top)"
     using 3 4 by (simp add: comp_associative star_left_induct)
   also have "... \<le> -(d\<^sup>T * top)"
     by (metis p_antitone star.circ_left_top star_outer_increasing mult_assoc)
   finally have 6: "?v\<^sup>\<star> * d * top \<le> -(d\<^sup>T * top)"
     by simp
   have "d\<^sup>T * top \<le> w\<^sup>\<star> * e * top"
     by (metis assms(4) comp_associative comp_inf.star.circ_sup_2 comp_isotone conv_dist_comp conv_involutive conv_order conv_star_commute conv_top vector_top_closed)
   also have "... \<le> (?v \<squnion> d)\<^sup>\<star> * e * top"
     by (metis assms(2) comp_inf.semiring.distrib_left maddux_3_11_pp mult_left_isotone star_isotone sup.cobounded2 sup_commute sup_inf_distrib1)
   also have "... = ?v\<^sup>\<star> * (d * ?v\<^sup>\<star>)\<^sup>\<star> * e * top"
     by (simp add: star_sup_1)
   also have "... = ?v\<^sup>\<star> * e * top \<squnion> ?v\<^sup>\<star> * d * ?v\<^sup>\<star> * (d * ?v\<^sup>\<star>)\<^sup>\<star> * e * top"
     by (metis semiring.distrib_right star.circ_unfold_sum star_decompose_1 star_decompose_3 mult_assoc)
   also have "... \<le> ?v\<^sup>\<star> * e * top \<squnion> ?v\<^sup>\<star> * d * top"
     by (metis comp_associative comp_isotone le_supI mult_left_dist_sup mult_right_dist_sup mult_right_isotone star.circ_decompose_5 star_decompose_3 sup.cobounded1 sup_commute top.extremum)
   finally have "d\<^sup>T * top \<le> ?v\<^sup>\<star> * e * top \<squnion> (d\<^sup>T * top \<sqinter> ?v\<^sup>\<star> * d * top)"
     using sup_inf_distrib2 sup_monoid.add_commute by simp
   hence "d\<^sup>T * top \<le> ?v\<^sup>\<star> * e * top"
     using 6 by (metis inf_commute pseudo_complement sup_monoid.add_0_right)
   hence 7: "d \<le> top * e\<^sup>T * ?v\<^sup>T\<^sup>\<star>"
     by (metis comp_associative conv_dist_comp conv_involutive conv_isotone conv_star_commute conv_top order.trans top_right_mult_increasing)
   have 8: "?v \<le> ?f"
     using forest_components_increasing le_supE by blast
   have "d \<le> ?v\<^sup>T\<^sup>\<star> * e\<^sup>T * top \<sqinter> top * e\<^sup>T * ?v\<^sup>T\<^sup>\<star>"
     using 7 assms(8) by simp
   also have "... = ?v\<^sup>T\<^sup>\<star> * e\<^sup>T * top * e\<^sup>T * ?v\<^sup>T\<^sup>\<star>"
     by (metis inf_top_right vector_inf_comp vector_top_closed mult_assoc)
   also have "... = ?v\<^sup>T\<^sup>\<star> * e\<^sup>T * ?v\<^sup>T\<^sup>\<star>"
     by (metis assms(3) comp_associative conv_dist_comp conv_top)
   also have "... \<le> ?v\<^sup>T\<^sup>\<star> * e\<^sup>T * ?f"
     using 8 by (metis assms(1) forest_components_equivalence cancel_separate_1 conv_dist_comp conv_order mult_left_isotone star_involutive star_isotone)
   also have "... \<le> ?v\<^sup>T\<^sup>\<star> * ?f * ?f"
     by (metis assms(1) forest_components_equivalence forest_components_increasing conv_isotone le_supE mult_left_isotone mult_right_isotone)
   also have "... \<le> ?f * ?f * ?f"
     by (metis comp_associative comp_isotone conv_dist_sup star.circ_loop_fixpoint star_isotone sup.cobounded1 sup.cobounded2)
   also have "... = ?f"
     by (simp add: assms(1) forest_components_equivalence preorder_idempotent)
   finally have "w \<le> ?f"
     using 8 by (metis assms(2) shunting_var_p sup.orderE)
   thus ?thesis
     using assms(1) forest_components_idempotent forest_components_isotone by fastforce
 qed
 
 lemma kruskal_spanning_inv:
   assumes "injective ((f \<sqinter> -q) \<squnion> (f \<sqinter> q)\<^sup>T \<squnion> e)"
       and "regular q"
       and "regular e"
       and "(-h \<sqinter> --g)\<^sup>\<star> \<le> forest_components f"
     shows "components (-(h \<sqinter> -e \<sqinter> -e\<^sup>T) \<sqinter> g) \<le> forest_components ((f \<sqinter> -q) \<squnion> (f \<sqinter> q)\<^sup>T \<squnion> e)"
 proof -
   let ?f = "(f \<sqinter> -q) \<squnion> (f \<sqinter> q)\<^sup>T \<squnion> e"
   let ?h = "h \<sqinter> -e \<sqinter> -e\<^sup>T"
   let ?F = "forest_components f"
   let ?FF = "forest_components ?f"
   have 1: "equivalence ?FF"
     using assms(1) forest_components_equivalence by simp
   hence 2: "?f * ?FF \<le> ?FF"
     using order.trans forest_components_increasing mult_left_isotone by blast
   have 3: "?f\<^sup>T * ?FF \<le> ?FF"
     using 1 by (metis forest_components_increasing mult_left_isotone conv_isotone preorder_idempotent)
   have "(f \<sqinter> q) * ?FF \<le> ?f\<^sup>T * ?FF"
     using conv_dist_sup conv_involutive sup_assoc sup_left_commute mult_left_isotone by simp
   hence 4: "(f \<sqinter> q) * ?FF \<le> ?FF"
     using 3 order.trans by blast
   have "(f \<sqinter> -q) * ?FF \<le> ?f * ?FF"
     using le_supI1 mult_left_isotone by simp
   hence "(f \<sqinter> -q) * ?FF \<le> ?FF"
     using 2 order.trans by blast
   hence "((f \<sqinter> q) \<squnion> (f \<sqinter> -q)) * ?FF \<le> ?FF"
     using 4 mult_right_dist_sup by simp
   hence "f * ?FF \<le> ?FF"
     by (metis assms(2) maddux_3_11_pp)
   hence 5: "f\<^sup>\<star> * ?FF \<le> ?FF"
     using star_left_induct_mult_iff by simp
   have "(f \<sqinter> -q)\<^sup>T * ?FF \<le> ?f\<^sup>T * ?FF"
     by (meson conv_isotone order.trans mult_left_isotone sup.cobounded1)
   hence 6: "(f \<sqinter> -q)\<^sup>T * ?FF \<le> ?FF"
     using 3 order.trans by blast
   have "(f \<sqinter> q)\<^sup>T * ?FF \<le> ?f * ?FF"
     by (simp add: mult_left_isotone sup.left_commute sup_assoc)
   hence "(f \<sqinter> q)\<^sup>T * ?FF \<le> ?FF"
     using 2 order.trans by blast
   hence "((f \<sqinter> -q)\<^sup>T \<squnion> (f \<sqinter> q)\<^sup>T) * ?FF \<le> ?FF"
     using 6 mult_right_dist_sup by simp
   hence "f\<^sup>T * ?FF \<le> ?FF"
     by (metis assms(2) conv_dist_sup maddux_3_11_pp)
   hence 7: "?F * ?FF \<le> ?FF"
     using 5 star_left_induct mult_assoc by simp
   have 8: "e * ?FF \<le> ?FF"
     using 2 by (simp add: mult_right_dist_sup mult_left_isotone)
   have "e\<^sup>T * ?FF \<le> ?f\<^sup>T * ?FF"
     by (simp add: mult_left_isotone conv_isotone)
   also have "... \<le> ?FF * ?FF"
     using 1 by (metis forest_components_increasing mult_left_isotone conv_isotone)
   finally have "e\<^sup>T * ?FF \<le> ?FF"
     using 1 preorder_idempotent by auto
   hence 9: "(?F \<squnion> e \<squnion> e\<^sup>T) * ?FF \<le> ?FF"
     using 7 8 mult_right_dist_sup by simp
   have "components (-?h \<sqinter> g) \<le> ((-h \<sqinter> --g) \<squnion> e \<squnion> e\<^sup>T)\<^sup>\<star>"
     by (metis assms(3) comp_inf.mult_left_sub_dist_sup_left conv_complement p_dist_inf pp_dist_inf regular_closed_p star_isotone sup_inf_distrib2 sup_monoid.add_assoc)
   also have "... \<le> ((-h \<sqinter> --g)\<^sup>\<star> \<squnion> e \<squnion> e\<^sup>T)\<^sup>\<star>"
     using star.circ_increasing star_isotone sup_left_isotone by simp
   also have "... \<le> (?F \<squnion> e \<squnion> e\<^sup>T)\<^sup>\<star>"
     using assms(4) sup_left_isotone star_isotone by simp
   also have "... \<le> ?FF"
     using 1 9 star_left_induct by force
   finally show ?thesis
     by simp
 qed
 
 lemma kruskal_exchange_spanning_inv_1:
   assumes "injective ((w \<sqinter> -q) \<squnion> (w \<sqinter> q)\<^sup>T)"
       and "regular (w \<sqinter> q)"
       and "components g \<le> forest_components w"
     shows "components g \<le> forest_components ((w \<sqinter> -q) \<squnion> (w \<sqinter> q)\<^sup>T)"
 proof -
   let ?p = "w \<sqinter> q"
   let ?w = "(w \<sqinter> -q) \<squnion> ?p\<^sup>T"
   have 1: "w \<sqinter> -?p \<le> forest_components ?w"
     by (metis forest_components_increasing inf_import_p le_supE)
   have "w \<sqinter> ?p \<le> ?w\<^sup>T"
     by (simp add: conv_dist_sup)
   also have "... \<le> forest_components ?w"
     by (metis assms(1) conv_isotone forest_components_equivalence forest_components_increasing)
   finally have "w \<sqinter> (?p \<squnion> -?p) \<le> forest_components ?w"
     using 1 inf_sup_distrib1 by simp
   hence "w \<le> forest_components ?w"
     by (metis assms(2) inf_top_right stone)
   hence 2: "w\<^sup>\<star> \<le> forest_components ?w"
     using assms(1) star_isotone forest_components_star by force
   hence 3: "w\<^sup>T\<^sup>\<star> \<le> forest_components ?w"
     using assms(1) conv_isotone conv_star_commute forest_components_equivalence by force
   have "components g \<le> forest_components w"
     using assms(3) by simp
   also have "... \<le> forest_components ?w * forest_components ?w"
     using 2 3 mult_isotone by simp
   also have "... = forest_components ?w"
     using assms(1) forest_components_equivalence preorder_idempotent by simp
   finally show ?thesis
     by simp
 qed
 
 lemma kruskal_exchange_spanning_inv_2:
   assumes "injective w"
       and "w\<^sup>\<star> * e\<^sup>T = e\<^sup>T"
       and "f \<squnion> f\<^sup>T \<le> (w \<sqinter> -d \<sqinter> -d\<^sup>T) \<squnion> (w\<^sup>T \<sqinter> -d \<sqinter> -d\<^sup>T)"
       and "d \<le> forest_components f * e\<^sup>T * top"
     shows "d \<le> (w \<sqinter> -d)\<^sup>T\<^sup>\<star> * e\<^sup>T * top"
 proof -
   have 1: "(w \<sqinter> -d \<sqinter> -d\<^sup>T) * (w\<^sup>T \<sqinter> -d \<sqinter> -d\<^sup>T) \<le> 1"
     using assms(1) comp_isotone order.trans inf.cobounded1 by blast
   have "d \<le> forest_components f * e\<^sup>T * top"
     using assms(4) by simp
   also have "... \<le> (f \<squnion> f\<^sup>T)\<^sup>\<star> * (f \<squnion> f\<^sup>T)\<^sup>\<star> * e\<^sup>T * top"
     by (simp add: comp_isotone star_isotone)
   also have "... = (f \<squnion> f\<^sup>T)\<^sup>\<star> * e\<^sup>T * top"
     by (simp add: star.circ_transitive_equal)
   also have "... \<le> ((w \<sqinter> -d \<sqinter> -d\<^sup>T) \<squnion> (w\<^sup>T \<sqinter> -d \<sqinter> -d\<^sup>T))\<^sup>\<star> * e\<^sup>T * top"
     using assms(3) by (simp add: comp_isotone star_isotone)
   also have "... = (w\<^sup>T \<sqinter> -d \<sqinter> -d\<^sup>T)\<^sup>\<star> * (w \<sqinter> -d \<sqinter> -d\<^sup>T)\<^sup>\<star> * e\<^sup>T * top"
     using 1 cancel_separate_1 by simp
   also have "... \<le> (w\<^sup>T \<sqinter> -d \<sqinter> -d\<^sup>T)\<^sup>\<star> * w\<^sup>\<star> * e\<^sup>T * top"
     by (simp add: inf_assoc mult_left_isotone mult_right_isotone star_isotone)
   also have "... = (w\<^sup>T \<sqinter> -d \<sqinter> -d\<^sup>T)\<^sup>\<star> * e\<^sup>T * top"
     using assms(2) mult_assoc by simp
   also have "... \<le> (w\<^sup>T \<sqinter> -d\<^sup>T)\<^sup>\<star> * e\<^sup>T * top"
     using mult_left_isotone conv_isotone star_isotone comp_inf.mult_right_isotone inf.cobounded2 inf.left_commute inf.sup_monoid.add_commute by presburger
   also have "... = (w \<sqinter> -d)\<^sup>T\<^sup>\<star> * e\<^sup>T * top"
     using conv_complement conv_dist_inf by presburger
   finally show ?thesis
     by simp
 qed
 
 lemma kruskal_spanning_inv_1:
   assumes "e \<le> F"
       and "regular e"
       and "components (-h \<sqinter> g) \<le> F"
       and "equivalence F"
     shows "components (-(h \<sqinter> -e \<sqinter> -e\<^sup>T) \<sqinter> g) \<le> F"
 proof -
   have 1: "F * F \<le> F"
     using assms(4) by simp
   hence 2: "e * F \<le> F"
     using assms(1) mult_left_isotone order_lesseq_imp by blast
   have "e\<^sup>T * F \<le> F"
     by (metis assms(1,4) conv_isotone mult_left_isotone preorder_idempotent)
   hence 3: "(F \<squnion> e \<squnion> e\<^sup>T) * F \<le> F"
     using 1 2 mult_right_dist_sup by simp
   have "components (-(h \<sqinter> -e \<sqinter> -e\<^sup>T) \<sqinter> g) \<le> ((-h \<sqinter> --g) \<squnion> e \<squnion> e\<^sup>T)\<^sup>\<star>"
     by (metis assms(2) comp_inf.mult_left_sub_dist_sup_left conv_complement p_dist_inf pp_dist_inf regular_closed_p star_isotone sup_inf_distrib2 sup_monoid.add_assoc)
   also have "... \<le> ((-h \<sqinter> --g)\<^sup>\<star> \<squnion> e \<squnion> e\<^sup>T)\<^sup>\<star>"
     using sup_left_isotone star.circ_increasing star_isotone by simp
   also have "... \<le> (F \<squnion> e \<squnion> e\<^sup>T)\<^sup>\<star>"
     using assms(3) sup_left_isotone star_isotone by simp
   also have "... \<le> F"
     using 3 assms(4) star_left_induct by force
   finally show ?thesis
     by simp
 qed
 
 lemma kruskal_reroot_edge:
   assumes "injective (e\<^sup>T * top)"
       and "acyclic w"
     shows "((w \<sqinter> -(top * e * w\<^sup>T\<^sup>\<star>)) \<squnion> (w \<sqinter> top * e * w\<^sup>T\<^sup>\<star>)\<^sup>T) * e\<^sup>T = bot"
 proof -
   let ?q = "top * e * w\<^sup>T\<^sup>\<star>"
   let ?p = "w \<sqinter> ?q"
   let ?w = "(w \<sqinter> -?q) \<squnion> ?p\<^sup>T"
   have "(w \<sqinter> -?q) * e\<^sup>T * top = w * (e\<^sup>T * top \<sqinter> -?q\<^sup>T)"
     by (metis comp_associative comp_inf_vector_1 conv_complement covector_complement_closed vector_top_closed)
   also have "... = w * (e\<^sup>T * top \<sqinter> -(w\<^sup>\<star> * e\<^sup>T * top))"
     by (simp add: conv_dist_comp conv_star_commute mult_assoc)
   also have "... = bot"
     by (metis comp_associative comp_inf.semiring.mult_not_zero inf.sup_relative_same_increasing inf_p mult_right_zero star.circ_loop_fixpoint sup_commute sup_left_divisibility)
   finally have 1: "(w \<sqinter> -?q) * e\<^sup>T * top = bot"
     by simp
   have "?p\<^sup>T * e\<^sup>T * top = (w\<^sup>T \<sqinter> w\<^sup>\<star> * e\<^sup>T * top) * e\<^sup>T * top"
     by (simp add: conv_dist_comp conv_star_commute mult_assoc conv_dist_inf)
   also have "... = w\<^sup>\<star> * e\<^sup>T * top \<sqinter> w\<^sup>T * e\<^sup>T * top"
     by (simp add: inf_vector_comp vector_export_comp)
   also have "... = (w\<^sup>\<star> \<sqinter> w\<^sup>T) * e\<^sup>T * top"
     using assms(1) injective_comp_right_dist_inf mult_assoc by simp
   also have "... = bot"
     using assms(2) acyclic_star_below_complement_1 semiring.mult_not_zero by blast
   finally have "?w * e\<^sup>T * top = bot"
     using 1 mult_right_dist_sup by simp
   thus ?thesis
     by (metis star.circ_top star_absorb)
 qed
 
 subsubsection \<open>Exchange gives Minimum Spanning Trees\<close>
 
 text \<open>
 The lemmas in this section are used to show that the after exchange we obtain a minimum spanning tree.
 The following lemmas show that the relation characterising the edge across the cut is an arc.
 \<close>
 
 lemma kruskal_edge_arc:
   assumes "equivalence F"
       and "forest w"
       and "arc e"
       and "regular F"
       and "F \<le> forest_components (F \<sqinter> w)"
       and "regular w"
       and "w * e\<^sup>T = bot"
       and "e * F * e = bot"
       and "e\<^sup>T \<le> w\<^sup>\<star>"
     shows "arc (w \<sqinter> top * e\<^sup>T * w\<^sup>T\<^sup>\<star> \<sqinter> F * e\<^sup>T * top \<sqinter> top * e * -F)"
 proof (unfold arc_expanded, intro conjI)
   let ?E = "top * e\<^sup>T * w\<^sup>T\<^sup>\<star>"
   let ?F = "F * e\<^sup>T * top"
   let ?G = "top * e * -F"
   let ?FF = "F * e\<^sup>T * e * F"
   let ?GG = "-F * e\<^sup>T * e * -F"
   let ?w = "forest_components (F \<sqinter> w)"
   have "F \<sqinter> w\<^sup>T\<^sup>\<star> \<le> forest_components (F \<sqinter> w) \<sqinter> w\<^sup>T\<^sup>\<star>"
     by (simp add: assms(5) inf.coboundedI1)
   also have "... \<le> (F \<sqinter> w)\<^sup>T\<^sup>\<star> * ((F \<sqinter> w)\<^sup>\<star> \<sqinter> w\<^sup>T\<^sup>\<star>)"
     apply (rule inf_star_import)
     apply (simp add: conv_isotone)
     apply (simp add: assms(2))
     apply (simp add: star.circ_reflexive)
     by (metis assms(6) conv_complement)
   also have "... \<le> (F \<sqinter> w)\<^sup>T\<^sup>\<star> * (w\<^sup>\<star> \<sqinter> w\<^sup>T\<^sup>\<star>)"
     using comp_inf.mult_left_isotone mult_right_isotone star_isotone by simp
   also have "... = (F \<sqinter> w)\<^sup>T\<^sup>\<star>"
     by (simp add: assms(2) acyclic_star_inf_conv)
   finally have "w * (F \<sqinter> w\<^sup>T\<^sup>\<star>) * e\<^sup>T * e \<le> w * (F \<sqinter> w)\<^sup>T\<^sup>\<star> * e\<^sup>T * e"
     by (simp add: mult_left_isotone mult_right_isotone)
   also have "... = w * e\<^sup>T * e \<squnion> w * (F \<sqinter> w)\<^sup>T\<^sup>+ * e\<^sup>T * e"
     by (metis comp_associative mult_left_dist_sup star.circ_loop_fixpoint sup_commute)
   also have "... = w * (F \<sqinter> w)\<^sup>T\<^sup>+ * e\<^sup>T * e"
     by (simp add: assms(7))
   also have "... \<le> w * (F \<sqinter> w)\<^sup>T\<^sup>+"
     by (metis assms(3) arc_univalent mult_assoc mult_1_right mult_right_isotone)
   also have "... \<le> w * w\<^sup>T * (F \<sqinter> w)\<^sup>T\<^sup>\<star>"
     by (simp add: comp_associative conv_isotone mult_left_isotone mult_right_isotone)
   also have "... \<le> (F \<sqinter> w)\<^sup>T\<^sup>\<star>"
     using assms(2) coreflexive_comp_top_inf inf.sup_right_divisibility by auto
   also have "... \<le> F\<^sup>T\<^sup>\<star>"
     by (simp add: conv_dist_inf star_isotone)
   finally have 1: "w * (F \<sqinter> w\<^sup>T\<^sup>\<star>) * e\<^sup>T * e \<le> F"
     by (metis assms(1) antisym mult_1_left mult_left_isotone star.circ_plus_same star.circ_reflexive star.left_plus_below_circ star_left_induct_mult_iff)
   have "F * e\<^sup>T * e \<le> forest_components (F \<sqinter> w) * e\<^sup>T * e"
     by (simp add: assms(5) mult_left_isotone)
   also have "... \<le> forest_components w * e\<^sup>T * e"
     by (simp add: comp_isotone conv_dist_inf star_isotone)
   also have "... = w\<^sup>T\<^sup>\<star> * e\<^sup>T * e"
     by (metis (no_types) assms(7) comp_associative conv_bot conv_dist_comp conv_involutive conv_star_commute star_absorb)
   also have "... \<le> w\<^sup>T\<^sup>\<star>"
     by (metis assms(3) arc_univalent mult_assoc mult_1_right mult_right_isotone)
   finally have 2: "F * e\<^sup>T * e \<le> w\<^sup>T\<^sup>\<star>"
     by simp
   have "w * F * e\<^sup>T * e \<le> w * F * e\<^sup>T * e * e\<^sup>T * e"
     using comp_associative ex231c mult_right_isotone by simp
   also have "... = w * (F * e\<^sup>T * e \<sqinter> w\<^sup>T\<^sup>\<star>) * e\<^sup>T * e"
     using 2 by (simp add: comp_associative inf.absorb1)
   also have "... \<le> w * (F \<sqinter> w\<^sup>T\<^sup>\<star>) * e\<^sup>T * e"
     by (metis assms(3) arc_univalent mult_assoc mult_1_right mult_right_isotone mult_left_isotone inf.sup_left_isotone)
   also have "... \<le> F"
     using 1 by simp
   finally have 3: "w * F * e\<^sup>T * e \<le> F"
     by simp
   hence "e\<^sup>T * e * F * w\<^sup>T \<le> F"
     by (metis assms(1) conv_dist_comp conv_dist_inf conv_involutive inf.absorb_iff1 mult_assoc)
   hence "e\<^sup>T * e * F * w\<^sup>T \<le> e\<^sup>T * top \<sqinter> F"
     by (simp add: comp_associative mult_right_isotone)
   also have "... \<le> e\<^sup>T * e * F"
     by (metis conv_involutive dedekind_1 inf_top_left mult_assoc)
   finally have 4: "e\<^sup>T * e * F * w\<^sup>T \<le> e\<^sup>T * e * F"
     by simp
   have "(top * e)\<^sup>T * (?F \<sqinter> w\<^sup>T\<^sup>\<star>) = e\<^sup>T * top * e * F * w\<^sup>T\<^sup>\<star>"
     by (metis assms(1) comp_inf.star.circ_decompose_9 comp_inf.star_star_absorb conv_dist_comp conv_involutive conv_top covector_inf_comp_3 vector_top_closed mult_assoc)
   also have "... = e\<^sup>T * e * F * w\<^sup>T\<^sup>\<star>"
     by (simp add: assms(3) arc_top_edge)
   also have "... \<le> e\<^sup>T * e * F"
     using 4 star_right_induct_mult by simp
   also have "... \<le> F"
     by (metis assms(3) arc_injective conv_involutive mult_1_left mult_left_isotone)
   finally have 5: "(top * e)\<^sup>T * (?F \<sqinter> w\<^sup>T\<^sup>\<star>) \<le> F"
     by simp
   have "(?F \<sqinter> w) * w\<^sup>T\<^sup>+ = ?F \<sqinter> w * w\<^sup>T\<^sup>+"
     by (simp add: vector_export_comp)
   also have "... \<le> ?F \<sqinter> w\<^sup>T\<^sup>\<star>"
     by (metis assms(2) comp_associative inf.sup_right_isotone mult_left_isotone star.circ_transitive_equal star_left_unfold_equal sup.absorb_iff2 sup_monoid.add_assoc)
   also have 6: "... \<le> top * e * F"
     using 5 by (metis assms(3) shunt_mapping conv_dist_comp conv_involutive conv_top)
   finally have 7: "(?F \<sqinter> w) * w\<^sup>T\<^sup>+ \<le> top * e * F"
     by simp
   have "e\<^sup>T * top * e \<le> 1"
     by (simp add: assms(3) point_injective)
   also have "... \<le> F"
     by (simp add: assms(1))
   finally have 8: "e * -F * e\<^sup>T \<le> bot"
     by (metis p_antitone p_antitone_iff p_bot regular_closed_bot schroeder_3_p schroeder_4_p mult_assoc)
   have "?FF \<sqinter> w * (w\<^sup>T\<^sup>+ \<sqinter> ?GG) * w\<^sup>T \<le> ?F \<sqinter> w * (w\<^sup>T\<^sup>+ \<sqinter> ?GG) * w\<^sup>T"
     using comp_inf.mult_left_isotone mult_isotone mult_assoc by simp
   also have "... \<le> ?F \<sqinter> w * (w\<^sup>T\<^sup>+ \<sqinter> ?G) * w\<^sup>T"
     by (metis assms(3) arc_top_edge comp_inf.star.circ_decompose_9 comp_inf_covector inf.sup_right_isotone inf_le2 mult_left_isotone mult_right_isotone vector_top_closed mult_assoc)
   also have "... = (?F \<sqinter> w) * (w\<^sup>T\<^sup>+ \<sqinter> ?G) * w\<^sup>T"
     by (simp add: vector_export_comp)
   also have "... = (?F \<sqinter> w) * w\<^sup>T\<^sup>+ * (?G\<^sup>T \<sqinter> w\<^sup>T)"
     by (simp add: covector_comp_inf covector_comp_inf_1 covector_mult_closed)
   also have "... \<le> top * e * F * (?G\<^sup>T \<sqinter> w\<^sup>T)"
     using 7 mult_left_isotone by simp
   also have "... \<le> top * e * F * ?G\<^sup>T"
     by (simp add: mult_right_isotone)
   also have "... = top * e * -F * e\<^sup>T * top"
     by (metis assms(1) conv_complement conv_dist_comp conv_top equivalence_comp_left_complement mult_assoc)
   finally have 9: "?FF \<sqinter> w * (w\<^sup>T\<^sup>+ \<sqinter> ?GG) * w\<^sup>T = bot"
     using 8 by (metis comp_associative covector_bot_closed le_bot vector_bot_closed)
   hence 10: "?FF \<sqinter> w * (w\<^sup>+ \<sqinter> ?GG) * w\<^sup>T = bot"
     using assms(1) comp_associative conv_bot conv_complement conv_dist_comp conv_dist_inf conv_star_commute star.circ_plus_same by fastforce
   have "(w \<sqinter> ?E \<sqinter> ?F \<sqinter> ?G) * top * (w \<sqinter> ?E \<sqinter> ?F \<sqinter> ?G)\<^sup>T = (?F \<sqinter> (w \<sqinter> ?E \<sqinter> ?G)) * top * ((w \<sqinter> ?E \<sqinter> ?G)\<^sup>T \<sqinter> ?F\<^sup>T)"
     by (simp add: conv_dist_inf inf_commute inf_left_commute)
   also have "... = (?F \<sqinter> (w \<sqinter> ?E \<sqinter> ?G)) * top * (w \<sqinter> ?E \<sqinter> ?G)\<^sup>T \<sqinter> ?F\<^sup>T"
     using covector_comp_inf vector_conv_covector vector_mult_closed vector_top_closed by simp
   also have "... = ?F \<sqinter> (w \<sqinter> ?E \<sqinter> ?G) * top * (w \<sqinter> ?E \<sqinter> ?G)\<^sup>T \<sqinter> ?F\<^sup>T"
     by (simp add: vector_export_comp)
   also have "... = ?F \<sqinter> top * e * F \<sqinter> (w \<sqinter> ?E \<sqinter> ?G) * top * (w \<sqinter> ?E \<sqinter> ?G)\<^sup>T"
     by (simp add: assms(1) conv_dist_comp inf_assoc inf_commute mult_assoc)
   also have "... = ?F * e * F \<sqinter> (w \<sqinter> ?E \<sqinter> ?G) * top * (w \<sqinter> ?E \<sqinter> ?G)\<^sup>T"
     by (metis comp_associative comp_inf_covector inf_top.left_neutral)
   also have "... = ?FF \<sqinter> (w \<sqinter> ?E \<sqinter> ?G) * (top * (w \<sqinter> ?E \<sqinter> ?G)\<^sup>T)"
     using assms(3) arc_top_edge comp_associative by simp
   also have "... = ?FF \<sqinter> (w \<sqinter> ?E \<sqinter> ?G) * (top * (?G\<^sup>T \<sqinter> (?E\<^sup>T \<sqinter> w\<^sup>T)))"
     by (simp add: conv_dist_inf inf_assoc inf_commute inf_left_commute)
   also have "... = ?FF \<sqinter> (w \<sqinter> ?E \<sqinter> ?G) * (?G * (?E\<^sup>T \<sqinter> w\<^sup>T))"
     by (metis covector_comp_inf_1 covector_top_closed covector_mult_closed inf_top_left)
   also have "... = ?FF \<sqinter> (w \<sqinter> ?E \<sqinter> ?G) * (?G \<sqinter> ?E) * w\<^sup>T"
     by (metis covector_comp_inf_1 covector_top_closed mult_assoc)
   also have "... = ?FF \<sqinter> (w \<sqinter> ?E) * (?G\<^sup>T \<sqinter> ?G \<sqinter> ?E) * w\<^sup>T"
     by (metis covector_comp_inf_1 covector_mult_closed inf.sup_monoid.add_assoc vector_top_closed)
   also have "... = ?FF \<sqinter> w * (?E\<^sup>T \<sqinter> ?G\<^sup>T \<sqinter> ?G \<sqinter> ?E) * w\<^sup>T"
     by (metis covector_comp_inf_1 covector_mult_closed inf.sup_monoid.add_assoc vector_top_closed)
   also have "... = ?FF \<sqinter> w * (?E\<^sup>T \<sqinter> ?E \<sqinter> (?G\<^sup>T \<sqinter> ?G)) * w\<^sup>T"
     by (simp add: inf_commute inf_left_commute)
   also have "... = ?FF \<sqinter> w * (?E\<^sup>T \<sqinter> ?E \<sqinter> (-F * e\<^sup>T * top \<sqinter> ?G)) * w\<^sup>T"
     by (simp add: assms(1) conv_complement conv_dist_comp mult_assoc)
   also have "... = ?FF \<sqinter> w * (?E\<^sup>T \<sqinter> ?E \<sqinter> (-F * e\<^sup>T * ?G)) * w\<^sup>T"
     by (metis comp_associative comp_inf_covector inf_top.left_neutral)
   also have "... = ?FF \<sqinter> w * (?E\<^sup>T \<sqinter> ?E \<sqinter> ?GG) * w\<^sup>T"
     by (metis assms(3) arc_top_edge comp_associative)
   also have "... = ?FF \<sqinter> w * (w\<^sup>\<star> * e * top \<sqinter> ?E \<sqinter> ?GG) * w\<^sup>T"
     by (simp add: comp_associative conv_dist_comp conv_star_commute)
   also have "... = ?FF \<sqinter> w * (w\<^sup>\<star> * e * ?E \<sqinter> ?GG) * w\<^sup>T"
     by (metis comp_associative comp_inf_covector inf_top.left_neutral)
   also have "... \<le> ?FF \<sqinter> w * (w\<^sup>\<star> * w\<^sup>T\<^sup>\<star> \<sqinter> ?GG) * w\<^sup>T"
     by (metis assms(3) mult_assoc mult_1_right mult_left_isotone mult_right_isotone inf.sup_left_isotone inf.sup_right_isotone arc_expanded)
   also have "... = ?FF \<sqinter> w * ((w\<^sup>+ \<squnion> 1 \<squnion> w\<^sup>T\<^sup>\<star>) \<sqinter> ?GG) * w\<^sup>T"
     by (simp add: assms(2) cancel_separate_eq star_left_unfold_equal sup_monoid.add_commute)
   also have "... = ?FF \<sqinter> w * ((w\<^sup>+ \<squnion> 1 \<squnion> w\<^sup>T\<^sup>+) \<sqinter> ?GG) * w\<^sup>T"
     using star.circ_plus_one star_left_unfold_equal sup_assoc by presburger
   also have "... = (?FF \<sqinter> w * (w\<^sup>+ \<sqinter> ?GG) * w\<^sup>T) \<squnion> (?FF \<sqinter> w * (1 \<sqinter> ?GG) * w\<^sup>T) \<squnion> (?FF \<sqinter> w * (w\<^sup>T\<^sup>+ \<sqinter> ?GG) * w\<^sup>T)"
     by (simp add: inf_sup_distrib1 inf_sup_distrib2 semiring.distrib_left semiring.distrib_right)
   also have "... \<le> w * (1 \<sqinter> ?GG) * w\<^sup>T"
     using 9 10 by simp
   also have "... \<le> w * w\<^sup>T"
     by (metis inf.cobounded1 mult_1_right mult_left_isotone mult_right_isotone)
   also have "... \<le> 1"
     by (simp add: assms(2))
   finally show "(w \<sqinter> ?E \<sqinter> ?F \<sqinter> ?G) * top * (w \<sqinter> ?E \<sqinter> ?F \<sqinter> ?G)\<^sup>T \<le> 1"
     by simp
   have "w\<^sup>T\<^sup>+ \<sqinter> -F * e\<^sup>T * e * -F \<sqinter> w\<^sup>T * F * e\<^sup>T * e * F * w \<le> w\<^sup>T\<^sup>+ \<sqinter> ?G \<sqinter> w\<^sup>T * F * e\<^sup>T * e * F * w"
     using top_greatest inf.sup_left_isotone inf.sup_right_isotone mult_left_isotone by simp
   also have "... \<le> w\<^sup>T\<^sup>+ \<sqinter> ?G \<sqinter> w\<^sup>T * ?F"
     using comp_associative inf.sup_right_isotone mult_right_isotone top.extremum by presburger
   also have "... = w\<^sup>T * (w\<^sup>T\<^sup>\<star> \<sqinter> ?F) \<sqinter> ?G"
     using assms(2) inf_assoc inf_commute inf_left_commute univalent_comp_left_dist_inf by simp
   also have "... \<le> w\<^sup>T * (top * e * F) \<sqinter> ?G"
     using 6 by (metis inf.sup_monoid.add_commute inf.sup_right_isotone mult_right_isotone)
   also have "... \<le> top * e * F \<sqinter> ?G"
     by (metis comp_associative comp_inf_covector mult_left_isotone top.extremum)
   also have "... = bot"
     by (metis assms(3) conv_dist_comp conv_involutive conv_top inf_p mult_right_zero univalent_comp_left_dist_inf)
   finally have 11: "w\<^sup>T\<^sup>+ \<sqinter> -F * e\<^sup>T * e * -F \<sqinter> w\<^sup>T * F * e\<^sup>T * e * F * w = bot"
     by (simp add: antisym)
   hence 12: "w\<^sup>+ \<sqinter> -F * e\<^sup>T * e * -F \<sqinter> w\<^sup>T * F * e\<^sup>T * e * F * w = bot"
     using assms(1) comp_associative conv_bot conv_complement conv_dist_comp conv_dist_inf conv_star_commute star.circ_plus_same by fastforce
   have "(w \<sqinter> ?E \<sqinter> ?F \<sqinter> ?G)\<^sup>T * top * (w \<sqinter> ?E \<sqinter> ?F \<sqinter> ?G) = ((w \<sqinter> ?E \<sqinter> ?G)\<^sup>T \<sqinter> ?F\<^sup>T) * top * (?F \<sqinter> (w \<sqinter> ?E \<sqinter> ?G))"
     by (simp add: conv_dist_inf inf_commute inf_left_commute)
   also have "... = (w \<sqinter> ?E \<sqinter> ?G)\<^sup>T * ?F * (?F \<sqinter> (w \<sqinter> ?E \<sqinter> ?G))"
     by (simp add: covector_inf_comp_3 vector_mult_closed)
   also have "... = (w \<sqinter> ?E \<sqinter> ?G)\<^sup>T * (?F \<sqinter> ?F\<^sup>T) * (w \<sqinter> ?E \<sqinter> ?G)"
     using covector_comp_inf covector_inf_comp_3 vector_conv_covector vector_mult_closed by simp
   also have "... = (w \<sqinter> ?E \<sqinter> ?G)\<^sup>T * (?F \<sqinter> ?F\<^sup>T) * (w \<sqinter> ?E) \<sqinter> ?G"
     by (simp add: comp_associative comp_inf_covector)
   also have "... = (w \<sqinter> ?E \<sqinter> ?G)\<^sup>T * (?F \<sqinter> ?F\<^sup>T) * w \<sqinter> ?E \<sqinter> ?G"
     by (simp add: comp_associative comp_inf_covector)
   also have "... = (?G\<^sup>T \<sqinter> (?E\<^sup>T \<sqinter> w\<^sup>T)) * (?F \<sqinter> ?F\<^sup>T) * w \<sqinter> ?E \<sqinter> ?G"
     by (simp add: conv_dist_inf inf.left_commute inf.sup_monoid.add_commute)
   also have "... = ?G\<^sup>T \<sqinter> (?E\<^sup>T \<sqinter> w\<^sup>T) * (?F \<sqinter> ?F\<^sup>T) * w \<sqinter> ?E \<sqinter> ?G"
     by (metis (no_types) comp_associative conv_dist_comp conv_top vector_export_comp)
   also have "... = ?G\<^sup>T \<sqinter> ?E\<^sup>T \<sqinter> w\<^sup>T * (?F \<sqinter> ?F\<^sup>T) * w \<sqinter> ?E \<sqinter> ?G"
     by (metis (no_types) comp_associative inf_assoc conv_dist_comp conv_top vector_export_comp)
   also have "... = ?E\<^sup>T \<sqinter> ?E \<sqinter> (?G\<^sup>T \<sqinter> ?G) \<sqinter> w\<^sup>T * (?F \<sqinter> ?F\<^sup>T) * w"
     by (simp add: inf_assoc inf.left_commute inf.sup_monoid.add_commute)
   also have "... = w\<^sup>\<star> * e * top \<sqinter> ?E \<sqinter> (?G\<^sup>T \<sqinter> ?G) \<sqinter> w\<^sup>T * (?F \<sqinter> ?F\<^sup>T) * w"
     by (simp add: comp_associative conv_dist_comp conv_star_commute)
   also have "... = w\<^sup>\<star> * e * ?E \<sqinter> (?G\<^sup>T \<sqinter> ?G) \<sqinter> w\<^sup>T * (?F \<sqinter> ?F\<^sup>T) * w"
     by (metis comp_associative comp_inf_covector inf_top.left_neutral)
   also have "... \<le> w\<^sup>\<star> * w\<^sup>T\<^sup>\<star> \<sqinter> (?G\<^sup>T \<sqinter> ?G) \<sqinter> w\<^sup>T * (?F \<sqinter> ?F\<^sup>T) * w"
     by (metis assms(3) mult_assoc mult_1_right mult_left_isotone mult_right_isotone inf.sup_left_isotone arc_expanded)
   also have "... = w\<^sup>\<star> * w\<^sup>T\<^sup>\<star> \<sqinter> (-F * e\<^sup>T * top \<sqinter> ?G) \<sqinter> w\<^sup>T * (?F \<sqinter> ?F\<^sup>T) * w"
     by (simp add: assms(1) conv_complement conv_dist_comp mult_assoc)
   also have "... = w\<^sup>\<star> * w\<^sup>T\<^sup>\<star> \<sqinter> -F * e\<^sup>T * ?G \<sqinter> w\<^sup>T * (?F \<sqinter> ?F\<^sup>T) * w"
     by (metis comp_associative comp_inf_covector inf_top.left_neutral)
   also have "... = w\<^sup>\<star> * w\<^sup>T\<^sup>\<star> \<sqinter> -F * e\<^sup>T * e * -F \<sqinter> w\<^sup>T * (?F \<sqinter> ?F\<^sup>T) * w"
     by (metis assms(3) arc_top_edge mult_assoc)
   also have "... = w\<^sup>\<star> * w\<^sup>T\<^sup>\<star> \<sqinter> -F * e\<^sup>T * e * -F \<sqinter> w\<^sup>T * (?F \<sqinter> top * e * F) * w"
     by (simp add: assms(1) conv_dist_comp mult_assoc)
   also have "... = w\<^sup>\<star> * w\<^sup>T\<^sup>\<star> \<sqinter> -F * e\<^sup>T * e * -F \<sqinter> w\<^sup>T * (?F * e * F) * w"
     by (metis comp_associative comp_inf_covector inf_top.left_neutral)
   also have "... = w\<^sup>\<star> * w\<^sup>T\<^sup>\<star> \<sqinter> -F * e\<^sup>T * e * -F \<sqinter> w\<^sup>T * F * e\<^sup>T * e * F * w"
     by (metis assms(3) arc_top_edge mult_assoc)
   also have "... = (w\<^sup>+ \<squnion> 1 \<squnion> w\<^sup>T\<^sup>\<star>) \<sqinter> -F * e\<^sup>T * e * -F \<sqinter> w\<^sup>T * F * e\<^sup>T * e * F * w"
     by (simp add: assms(2) cancel_separate_eq star_left_unfold_equal sup_monoid.add_commute)
   also have "... = (w\<^sup>+ \<squnion> 1 \<squnion> w\<^sup>T\<^sup>+) \<sqinter> -F * e\<^sup>T * e * -F \<sqinter> w\<^sup>T * F * e\<^sup>T * e * F * w"
     using star.circ_plus_one star_left_unfold_equal sup_assoc by presburger
   also have "... = (w\<^sup>+ \<sqinter> -F * e\<^sup>T * e * -F \<sqinter> w\<^sup>T * F * e\<^sup>T * e * F * w) \<squnion> (1 \<sqinter> -F * e\<^sup>T * e * -F \<sqinter> w\<^sup>T * F * e\<^sup>T * e * F * w) \<squnion> (w\<^sup>T\<^sup>+ \<sqinter> -F * e\<^sup>T * e * -F \<sqinter> w\<^sup>T * F * e\<^sup>T * e * F * w)"
     by (simp add: inf_sup_distrib2)
   also have "... \<le> 1"
     using 11 12 by (simp add: inf.coboundedI1)
   finally show "(w \<sqinter> ?E \<sqinter> ?F \<sqinter> ?G)\<^sup>T * top * (w \<sqinter> ?E \<sqinter> ?F \<sqinter> ?G) \<le> 1"
     by simp
   have "(w \<sqinter> -F) * (F \<sqinter> w\<^sup>T) \<le> w * w\<^sup>T \<sqinter> -F * F"
     by (simp add: mult_isotone)
   also have "... \<le> 1 \<sqinter> -F"
     using assms(1,2) comp_inf.comp_isotone equivalence_comp_right_complement by auto
   also have "... = bot"
     using assms(1) bot_unique pp_isotone pseudo_complement_pp by blast
   finally have 13: "(w \<sqinter> -F) * (F \<sqinter> w\<^sup>T) = bot"
     by (simp add: antisym)
   have "w \<sqinter> ?G \<le> F * (w \<sqinter> ?G)"
     by (metis assms(1) mult_1_left mult_right_dist_sup sup.absorb_iff2)
   also have "... \<le> F * (w \<sqinter> ?G) * w\<^sup>\<star>"
     by (metis eq_refl le_supE star.circ_back_loop_fixpoint)
   finally have 14: "w \<sqinter> ?G \<le> F * (w \<sqinter> ?G) * w\<^sup>\<star>"
     by simp
   have "w \<sqinter> top * e * F \<le> w * (e * F)\<^sup>T * e * F"
     by (metis (no_types) comp_inf.star_slide dedekind_2 inf_left_commute inf_top_right mult_assoc)
   also have "... \<le> F"
     using 3 assms(1) by (metis comp_associative conv_dist_comp mult_left_isotone preorder_idempotent)
   finally have "w \<sqinter> -F \<le> -(top * e * F)"
     using order.trans p_shunting_swap pp_increasing by blast
   also have "... = ?G"
     by (metis assms(3) comp_mapping_complement conv_dist_comp conv_involutive conv_top)
   finally have "(w \<sqinter> -F) * F * (w \<sqinter> ?G) = (w \<sqinter> -F \<sqinter> ?G) * F * (w \<sqinter> ?G)"
     by (simp add: inf.absorb1)
   also have "... \<le> (w \<sqinter> -F \<sqinter> ?G) * F * w"
     by (simp add: comp_isotone)
   also have "... \<le> (w \<sqinter> -F \<sqinter> ?G) * forest_components (F \<sqinter> w) * w"
     by (simp add: assms(5) mult_left_isotone mult_right_isotone)
   also have "... \<le> (w \<sqinter> -F \<sqinter> ?G) * (F \<sqinter> w)\<^sup>T\<^sup>\<star> * w\<^sup>\<star> * w"
     by (simp add: mult_left_isotone mult_right_isotone star_isotone mult_assoc)
   also have "... \<le> (w \<sqinter> -F \<sqinter> ?G) * (F \<sqinter> w)\<^sup>T\<^sup>\<star> * w\<^sup>\<star>"
     by (simp add: comp_associative mult_right_isotone star.circ_plus_same star.left_plus_below_circ)
   also have "... = (w \<sqinter> -F \<sqinter> ?G) * w\<^sup>\<star> \<squnion> (w \<sqinter> -F \<sqinter> ?G) * (F \<sqinter> w)\<^sup>T\<^sup>+ * w\<^sup>\<star>"
     by (metis comp_associative inf.sup_monoid.add_assoc mult_left_dist_sup star.circ_loop_fixpoint sup_commute)
   also have "... \<le> (w \<sqinter> -F \<sqinter> ?G) * w\<^sup>\<star> \<squnion> (w \<sqinter> -F \<sqinter> ?G) * (F \<sqinter> w)\<^sup>T * top"
     by (metis mult_assoc top_greatest mult_right_isotone sup_right_isotone)
   also have "... \<le> (w \<sqinter> -F \<sqinter> ?G) * w\<^sup>\<star> \<squnion> (w \<sqinter> -F) * (F \<sqinter> w)\<^sup>T * top"
     using inf.cobounded1 mult_left_isotone sup_right_isotone by blast
   also have "... \<le> (w \<sqinter> ?G) * w\<^sup>\<star> \<squnion> (w \<sqinter> -F) * (F \<sqinter> w)\<^sup>T * top"
     using inf.sup_monoid.add_assoc inf.sup_right_isotone mult_left_isotone sup_commute sup_right_isotone by simp
   also have "... = (w \<sqinter> ?G) * w\<^sup>\<star> \<squnion> (w \<sqinter> -F) * (F \<sqinter> w\<^sup>T) * top"
     by (simp add: assms(1) conv_dist_inf)
   also have "... \<le> 1 * (w \<sqinter> ?G) * w\<^sup>\<star>"
     using 13 by simp
   also have "... \<le> F * (w \<sqinter> ?G) * w\<^sup>\<star>"
     using assms(1) mult_left_isotone by blast
   finally have 15: "(w \<sqinter> -F) * F * (w \<sqinter> ?G) \<le> F * (w \<sqinter> ?G) * w\<^sup>\<star>"
     by simp
   have "(w \<sqinter> F) * F * (w \<sqinter> ?G) \<le> F * F * (w \<sqinter> ?G)"
     by (simp add: mult_left_isotone)
   also have "... = F * (w \<sqinter> ?G)"
     by (simp add: assms(1) preorder_idempotent)
   also have "... \<le> F * (w \<sqinter> ?G) * w\<^sup>\<star>"
     by (metis eq_refl le_supE star.circ_back_loop_fixpoint)
   finally have "(w \<sqinter> F) * F * (w \<sqinter> ?G) \<le> F * (w \<sqinter> ?G) * w\<^sup>\<star>"
     by simp
   hence "((w \<sqinter> F) \<squnion> (w \<sqinter> -F)) * F * (w \<sqinter> ?G) \<le> F * (w \<sqinter> ?G) * w\<^sup>\<star>"
     using 15 by (simp add: semiring.distrib_right)
   hence "w * F * (w \<sqinter> ?G) \<le> F * (w \<sqinter> ?G) * w\<^sup>\<star>"
     by (metis assms(4) maddux_3_11_pp)
   hence "w * F * (w \<sqinter> ?G) * w\<^sup>\<star> \<le> F * (w \<sqinter> ?G) * w\<^sup>\<star>"
     by (metis (full_types) comp_associative mult_left_isotone star.circ_transitive_equal)
   hence "w\<^sup>\<star> * (w \<sqinter> ?G) \<le> F * (w \<sqinter> ?G) * w\<^sup>\<star>"
     using 14 by (simp add: mult_assoc star_left_induct)
   hence 16: "w\<^sup>+ \<sqinter> ?G \<le> F * (w \<sqinter> ?G) * w\<^sup>\<star>"
     by (simp add: covector_comp_inf covector_mult_closed star.circ_plus_same)
   have 17: "e\<^sup>T * top * e\<^sup>T \<le> -F"
     using assms(8) le_bot triple_schroeder_p by simp
   hence "(top * e)\<^sup>T * e\<^sup>T \<le> -F"
     by (simp add: conv_dist_comp)
   hence 18: "e\<^sup>T \<le> ?G"
     by (metis assms(3) shunt_mapping conv_dist_comp conv_involutive conv_top)
   have "e\<^sup>T \<le> -F"
     using 17 by (simp add: assms(3) arc_top_arc)
   also have "... \<le> -1"
     by (simp add: assms(1) p_antitone)
   finally have "e\<^sup>T \<le> w\<^sup>\<star> \<sqinter> -1"
     using assms(9) by simp
   also have "... \<le> w\<^sup>+"
     using shunting_var_p star_left_unfold_equal sup_commute by simp
   finally have "e\<^sup>T \<le> w\<^sup>+ \<sqinter> ?G"
     using 18 by simp
   hence "e\<^sup>T \<le> F * (w \<sqinter> ?G) * w\<^sup>\<star>"
     using 16 order_trans by blast
   also have "... = (F * w \<sqinter> ?G) * w\<^sup>\<star>"
     by (simp add: comp_associative comp_inf_covector)
   finally have "e\<^sup>T * top * e\<^sup>T \<le> (F * w \<sqinter> ?G) * w\<^sup>\<star>"
     by (simp add: assms(3) arc_top_arc)
   hence "e\<^sup>T * top * (e * top)\<^sup>T \<le> (F * w \<sqinter> ?G) * w\<^sup>\<star>"
     by (metis conv_dist_comp conv_top vector_top_closed mult_assoc)
   hence "e\<^sup>T * top \<le> (F * w \<sqinter> ?G) * w\<^sup>\<star> * e * top"
     by (metis assms(3) shunt_bijective mult_assoc)
   hence "(top * e)\<^sup>T * top \<le> (F * w \<sqinter> ?G) * w\<^sup>\<star> * e * top"
     by (simp add: conv_dist_comp mult_assoc)
   hence "top \<le> top * e * (F * w \<sqinter> ?G) * w\<^sup>\<star> * e * top"
     by (metis assms(3) shunt_mapping conv_dist_comp conv_involutive conv_top mult_assoc)
   also have "... = top * e * F * w * (w\<^sup>\<star> * e * top \<sqinter> ?G\<^sup>T)"
     by (metis comp_associative comp_inf_vector_1)
   also have "... = top * (w \<sqinter> (top * e * F)\<^sup>T) * (w\<^sup>\<star> * e * top \<sqinter> ?G\<^sup>T)"
     by (metis comp_inf_vector_1 inf_top.left_neutral)
   also have "... = top * (w \<sqinter> ?F) * (w\<^sup>\<star> * e * top \<sqinter> ?G\<^sup>T)"
     by (simp add: assms(1) conv_dist_comp mult_assoc)
   also have "... = top * (w \<sqinter> ?F) * (?E\<^sup>T \<sqinter> ?G\<^sup>T)"
     by (simp add: comp_associative conv_dist_comp conv_star_commute)
   also have "... = top * (w \<sqinter> ?F \<sqinter> ?G) * ?E\<^sup>T"
     by (simp add: comp_associative comp_inf_vector_1)
   also have "... = top * (w \<sqinter> ?F \<sqinter> ?G \<sqinter> ?E) * top"
     using comp_inf_vector_1 mult_assoc by simp
   finally show "top * (w \<sqinter> ?E \<sqinter> ?F \<sqinter> ?G) * top = top"
     by (simp add: inf_commute inf_left_commute top_le)
 qed
 
 lemma kruskal_edge_arc_1:
   assumes "e \<le> --h"
       and "h \<le> g"
-      and "symmetric h"
+      and "symmetric g"
       and "components g \<le> forest_components w"
       and "w * e\<^sup>T = bot"
     shows "e\<^sup>T \<le> w\<^sup>\<star>"
 proof -
   have "w\<^sup>T * top \<le> -(e\<^sup>T * top)"
     using assms(5) schroeder_3_p vector_bot_closed mult_assoc by fastforce
   hence 1: "w\<^sup>T * top \<sqinter> e\<^sup>T * top = bot"
     using pseudo_complement by simp
   have "e\<^sup>T \<le> e\<^sup>T * top \<sqinter> --h\<^sup>T"
     using assms(1) conv_complement conv_isotone top_right_mult_increasing by fastforce
   also have "... \<le> e\<^sup>T * top \<sqinter> --g"
-    using assms(2,3) inf.sup_right_isotone pp_isotone by simp
+    by (metis assms(2,3) inf.sup_right_isotone pp_isotone conv_isotone)
   also have "... \<le> e\<^sup>T * top \<sqinter> components g"
     using inf.sup_right_isotone star.circ_increasing by simp
   also have "... \<le> e\<^sup>T * top \<sqinter> forest_components w"
     using assms(4) comp_inf.mult_right_isotone by simp
   also have "... = (e\<^sup>T * top \<sqinter> w\<^sup>T\<^sup>\<star>) * w\<^sup>\<star>"
     by (simp add: inf_assoc vector_export_comp)
   also have "... = (e\<^sup>T * top \<sqinter> 1) * w\<^sup>\<star> \<squnion> (e\<^sup>T * top \<sqinter> w\<^sup>T\<^sup>+) * w\<^sup>\<star>"
     by (metis inf_sup_distrib1 semiring.distrib_right star_left_unfold_equal)
   also have "... \<le> w\<^sup>\<star> \<squnion> (e\<^sup>T * top \<sqinter> w\<^sup>T\<^sup>+) * w\<^sup>\<star>"
     by (metis inf_le2 mult_1_left mult_left_isotone sup_left_isotone)
   also have "... \<le> w\<^sup>\<star> \<squnion> (e\<^sup>T * top \<sqinter> w\<^sup>T) * top"
     using comp_associative comp_inf.mult_right_isotone sup_right_isotone mult_right_isotone top.extremum vector_export_comp by presburger
   also have "... = w\<^sup>\<star>"
     using 1 inf.sup_monoid.add_commute inf_vector_comp by simp
   finally show ?thesis
     by simp
 qed
 
 lemma kruskal_edge_between_components_1:
   assumes "equivalence F"
       and "mapping (top * e)"
     shows "F \<le> -(w \<sqinter> top * e\<^sup>T * w\<^sup>T\<^sup>\<star> \<sqinter> F * e\<^sup>T * top \<sqinter> top * e * -F)"
 proof -
   let ?d = "w \<sqinter> top * e\<^sup>T * w\<^sup>T\<^sup>\<star> \<sqinter> F * e\<^sup>T * top \<sqinter> top * e * -F"
   have "?d \<sqinter> F \<le> F * e\<^sup>T * top \<sqinter> F"
     by (meson inf_le1 inf_le2 le_infI order_trans)
   also have "... \<le> (F * e\<^sup>T * top)\<^sup>T * F"
     by (simp add: mult_assoc vector_restrict_comp_conv)
   also have "... = top * e * F * F"
     by (simp add: assms(1) comp_associative conv_dist_comp conv_star_commute)
   also have "... = top * e * F"
     using assms(1) preorder_idempotent mult_assoc by fastforce
   finally have "?d \<sqinter> F \<le> top * e * F \<sqinter> top * e * -F"
     by (simp add: le_infI1)
   also have "... = top * e * F \<sqinter> -(top * e * F)"
     using assms(2) conv_dist_comp total_conv_surjective comp_mapping_complement by simp
   finally show ?thesis
     by (metis inf_p le_bot p_antitone_iff pseudo_complement)
 qed
 
 lemma kruskal_edge_between_components_2:
   assumes "forest_components f \<le> -d"
       and "injective f"
       and "f \<squnion> f\<^sup>T \<le> w \<squnion> w\<^sup>T"
     shows "f \<squnion> f\<^sup>T \<le> (w \<sqinter> -d \<sqinter> -d\<^sup>T) \<squnion> (w\<^sup>T \<sqinter> -d \<sqinter> -d\<^sup>T)"
 proof -
   let ?F = "forest_components f"
   have "?F\<^sup>T \<le> -d\<^sup>T"
     using assms(1) conv_complement conv_order by fastforce
   hence 1: "?F \<le> -d\<^sup>T"
     by (simp add: conv_dist_comp conv_star_commute)
   have "equivalence ?F"
     using assms(2) forest_components_equivalence by simp
   hence "f \<squnion> f\<^sup>T \<le> ?F"
     by (metis conv_dist_inf forest_components_increasing inf.absorb_iff2 sup.boundedI)
   also have "... \<le> -d \<sqinter> -d\<^sup>T"
     using 1 assms(1) by simp
   finally have "f \<squnion> f\<^sup>T \<le> -d \<sqinter> -d\<^sup>T"
     by simp
   thus ?thesis
     by (metis assms(3) inf_sup_distrib2 le_inf_iff)
 qed
 
 end
 
 subsection \<open>Related Structures\<close>
 
 text \<open>
 Stone algebras can be expanded to Stone-Kleene relation algebras by reusing some operations.
 \<close>
 
 sublocale stone_algebra < comp_inf: stone_kleene_relation_algebra where star = "\<lambda>x . top" and one = top and times = inf and conv = id
   apply unfold_locales
   by simp
 
 text \<open>
 Every bounded linear order can be expanded to a Stone algebra, which can be expanded to a Stone relation algebra, which can be expanded to a Stone-Kleene relation algebra.
 \<close>
 
 class linorder_stone_kleene_relation_algebra_expansion = linorder_stone_relation_algebra_expansion + star +
   assumes star_def [simp]: "x\<^sup>\<star> = top"
 begin
 
 subclass kleene_algebra
   apply unfold_locales
   apply simp
   apply (simp add: min.coboundedI1 min.commute)
   by (simp add: min.coboundedI1)
 
 subclass stone_kleene_relation_algebra
   apply unfold_locales
   by simp
 
 end
 
 text \<open>
 A Kleene relation algebra is based on a relation algebra.
 \<close>
 
 class kleene_relation_algebra = relation_algebra + stone_kleene_relation_algebra
 
 end