diff --git a/thys/Aggregation_Algebras/M_Choose_Component.thy b/thys/Aggregation_Algebras/M_Choose_Component.thy
new file mode 100644
--- /dev/null
+++ b/thys/Aggregation_Algebras/M_Choose_Component.thy
@@ -0,0 +1,149 @@
+(* Title:      An Operation to Select Components in Algebras with Minimisation
+   Author:     Nicolas Robinson-O'Brien
+   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
+*)
+
+section \<open>An Operation to Select Components in Algebras with Minimisation\<close>
+
+text \<open>
+In this theory we show that an operation to select components of a graph can be defined in m-Kleene Algebras.
+This work is by Nicolas Robinson-O'Brien.
+\<close>
+
+theory M_Choose_Component
+
+imports
+  Stone_Relation_Algebras.Choose_Component
+  Matrix_Aggregation_Algebras
+
+begin
+
+text \<open>
+Every \<open>m_kleene_algebra\<close> is an instance of \<open>choose_component_algebra\<close> when the \<open>choose_component\<close> operation is defined as follows:
+\<close>
+
+context m_kleene_algebra
+begin
+
+definition "m_choose_component e v \<equiv>
+  if vector_classes e v then
+    e * minarc(v) * top
+  else
+    bot"
+
+sublocale m_choose_component_algebra: choose_component_algebra where choose_component = m_choose_component
+proof
+  fix e v
+  show "m_choose_component e v \<le> -- v"
+  proof (cases "vector_classes e v")
+    case True
+    hence "m_choose_component e v = e * minarc(v) * top"
+      by (simp add: m_choose_component_def)
+    also have "... \<le> e * --v * top"
+      by (simp add: comp_isotone minarc_below)
+    also have "... = e * v * top"
+      using True vector_classes_def by auto
+    also have "... \<le> v * top"
+      using True vector_classes_def mult_assoc by auto
+    finally show ?thesis
+      using True vector_classes_def by auto
+  next
+    case False
+    hence "m_choose_component e v = bot"
+      using False m_choose_component_def by auto
+    thus ?thesis
+      by simp
+  qed
+next
+  fix e v
+  show "vector (m_choose_component e v)"
+  proof (cases "vector_classes e v")
+    case True
+    thus ?thesis
+      by (simp add: mult_assoc m_choose_component_def)
+  next
+    case False
+    thus ?thesis
+      by (simp add: m_choose_component_def)
+  qed
+next
+  fix e v
+  show "regular (m_choose_component e v)"
+    using minarc_regular regular_mult_closed vector_classes_def m_choose_component_def by auto
+next
+  fix e v
+  show "m_choose_component e v * (m_choose_component e v)\<^sup>T \<le> e"
+  proof (cases "vector_classes e v")
+    case True
+    assume 1: "vector_classes e v"
+    hence "m_choose_component e v * (m_choose_component e v)\<^sup>T = e * minarc(v) * top * (e * minarc(v) * top)\<^sup>T"
+      by (simp add: m_choose_component_def)
+    also have "... = e * minarc(v) * top * top\<^sup>T * minarc(v)\<^sup>T * e\<^sup>T"
+      by (metis comp_associative conv_dist_comp)
+    also have "... = e * minarc(v) * top * top * minarc(v)\<^sup>T * e"
+      using True vector_classes_def by auto
+    also have "... = e * minarc(v) * top * minarc(v)\<^sup>T * e"
+      by (simp add: comp_associative)
+    also have "... \<le> e"
+    proof (cases "v = bot")
+      case True
+      thus ?thesis
+        by (simp add: True minarc_bot)
+    next
+      case False
+      assume 3: "v \<noteq> bot"
+      hence "e * minarc(v) * top * minarc(v)\<^sup>T \<le> e * 1"
+        using 3 minarc_arc arc_expanded comp_associative mult_right_isotone by fastforce
+      hence "e * minarc(v) * top * minarc(v)\<^sup>T * e \<le> e * 1 * e"
+        using mult_left_isotone by auto
+      also have "... = e"
+        using True preorder_idempotent vector_classes_def by auto
+      thus ?thesis
+        using calculation by auto
+    qed
+    thus ?thesis
+      by (simp add: calculation)
+  next
+    case False
+    thus ?thesis
+      by (simp add: m_choose_component_def)
+  qed
+next
+  fix e v
+  show "e * m_choose_component e v \<le> m_choose_component e v"
+  proof (cases "vector_classes e v")
+    case True
+    thus ?thesis
+      using comp_right_one dual_order.eq_iff mult_isotone vector_classes_def m_choose_component_def mult_assoc by metis
+  next
+    case False
+    thus ?thesis
+      by (simp add: m_choose_component_def)
+  qed
+next
+  fix e v
+  show "vector_classes e v \<longrightarrow> m_choose_component e v \<noteq> bot"
+  proof (cases "vector_classes e v")
+    case True
+    hence "m_choose_component e v \<ge> minarc(v) * top"
+      using vector_classes_def m_choose_component_def comp_associative minarc_arc shunt_bijective by fastforce
+    also have "... \<ge> minarc(v)"
+      using calculation dual_order.trans top_right_mult_increasing by blast
+    thus ?thesis
+      using le_bot minarc_bot_iff vector_classes_def by fastforce
+  next
+    case False
+    thus ?thesis
+      by blast
+  qed
+qed
+
+sublocale m_choose_component_algebra_tarski: choose_component_algebra_tarski where choose_component = m_choose_component
+  ..
+
+end
+
+class m_kleene_algebra_choose_component = m_kleene_algebra + choose_component_algebra
+
+end
+
diff --git a/thys/Aggregation_Algebras/Matrix_Aggregation_Algebras.thy b/thys/Aggregation_Algebras/Matrix_Aggregation_Algebras.thy
--- a/thys/Aggregation_Algebras/Matrix_Aggregation_Algebras.thy
+++ b/thys/Aggregation_Algebras/Matrix_Aggregation_Algebras.thy
@@ -1,1017 +1,1046 @@
 (* Title:      Matrix Algebras for Aggregation and Minimisation
    Author:     Walter Guttmann
    Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
 *)
 
 section \<open>Matrix Algebras for Aggregation and Minimisation\<close>
 
 text \<open>
 This theory formalises aggregation orders and lattices as introduced in \<^cite>\<open>"Guttmann2018a"\<close>.
 Aggregation in these algebras is an associative and commutative operation satisfying additional properties related to the partial order and its least element.
 We apply the aggregation operation to finite matrices over the aggregation algebras, which shows that they form an s-algebra.
 By requiring the aggregation algebras to be linearly ordered, we also obtain that the matrices form an m-algebra.
 
 This is an intermediate step in demonstrating that weighted graphs form an s-algebra and an m-algebra.
 The present theory specifies abstract properties for the edge weights and shows that matrices over such weights form an instance of s-algebras and m-algebras.
 A second step taken in a separate theory gives concrete instances of edge weights satisfying the abstract properties introduced here.
 
 Lifting the aggregation to matrices requires finite sums over elements taken from commutative semigroups with an element that is a unit on the image of the semigroup operation.
 Because standard sums assume a commutative monoid we have to derive a number of properties of these generalised sums as their statements or proofs are different.
 \<close>
 
 theory Matrix_Aggregation_Algebras
 
 imports Stone_Kleene_Relation_Algebras.Matrix_Kleene_Algebras Aggregation_Algebras Semigroups_Big
 
 begin
 
 no_notation
   inf (infixl "\<sqinter>" 70)
   and uminus ("- _" [81] 80)
 
 subsection \<open>Aggregation Orders and Finite Sums\<close>
 
 text \<open>
 An aggregation order is a partial order with a least element and an associative commutative operation satisfying certain properties.
 Axiom \<open>add_add_bot\<close> introduces almost a commutative monoid; we require that \<open>bot\<close> is a unit only on the image of the aggregation operation.
 This is necessary since it is not a unit of a number of aggregation operations we are interested in.
 Axiom \<open>add_right_isotone\<close> states that aggregation is $\leq$-isotone on the image of the aggregation operation.
 Its assumption $x \neq bot$ is necessary because the introduction of new edges can decrease the aggregated value.
 Axiom \<open>add_bot\<close> expresses that aggregation is zero-sum-free.
 \<close>
 
 class aggregation_order = order_bot + ab_semigroup_add +
   assumes add_right_isotone: "x \<noteq> bot \<and> x + bot \<le> y + bot \<longrightarrow> x + z \<le> y + z"
   assumes add_add_bot [simp]: "x + y + bot = x + y"
   assumes add_bot: "x + y = bot \<longrightarrow> x = bot"
 begin
 
 abbreviation "zero \<equiv> bot + bot"
 
 sublocale aggregation: ab_semigroup_add_0 where plus = plus and zero = zero
   apply unfold_locales
   using add_assoc add_add_bot by auto
 
 lemma add_bot_bot_bot:
   "x + bot + bot + bot = x + bot"
   by simp
 
 end
 
 text \<open>
 We introduce notation for finite sums over aggregation orders.
 The index variable of the summation ranges over the finite universe of its type.
 Finite sums are defined recursively using the binary aggregation and $\bot + \bot$ for the empty sum.
 \<close>
 
 syntax (xsymbols)
   "_sum_ab_semigroup_add_0" :: "idt \<Rightarrow> 'a::bounded_semilattice_sup_bot \<Rightarrow> 'a" ("(\<Sum>\<^sub>_ _)" [0,10] 10)
 
 translations
   "\<Sum>\<^sub>x t" => "XCONST ab_semigroup_add_0.sum_0 XCONST plus (XCONST plus XCONST bot XCONST bot) (\<lambda>x . t) { x . CONST True }"
 
 text \<open>
 The following are basic properties of such sums.
 \<close>
 
 lemma agg_sum_bot:
   "(\<Sum>\<^sub>k bot::'a::aggregation_order) = bot + bot"
 proof (induct rule: infinite_finite_induct)
   case (infinite A)
   thus ?case
     by simp
 next
   case empty
   thus ?case
     by simp
 next
   case (insert x F)
   thus ?case
     by (metis add.commute add_add_bot aggregation.sum_0.insert)
 qed
 
 lemma agg_sum_bot_bot:
   "(\<Sum>\<^sub>k bot + bot::'a::aggregation_order) = bot + bot"
   by (rule aggregation.sum_0.neutral_const)
 
 lemma agg_sum_not_bot_1:
   fixes f :: "'a::finite \<Rightarrow> 'b::aggregation_order"
   assumes "f i \<noteq> bot"
     shows "(\<Sum>\<^sub>k f k) \<noteq> bot"
   by (metis assms add_bot aggregation.sum_0.remove finite_code mem_Collect_eq)
 
 lemma agg_sum_not_bot:
   fixes f :: "('a::finite,'b::aggregation_order) square"
   assumes "f (i,j) \<noteq> bot"
     shows "(\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l)) \<noteq> bot"
   by (metis assms agg_sum_not_bot_1)
 
 lemma agg_sum_distrib:
   fixes f g :: "'a \<Rightarrow> 'b::aggregation_order"
   shows "(\<Sum>\<^sub>k f k + g k) = (\<Sum>\<^sub>k f k) + (\<Sum>\<^sub>k g k)"
   by (rule aggregation.sum_0.distrib)
 
 lemma agg_sum_distrib_2:
   fixes f g :: "('a,'b::aggregation_order) square"
   shows "(\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l) + g (k,l)) = (\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l)) + (\<Sum>\<^sub>k \<Sum>\<^sub>l g (k,l))"
 proof -
   have "(\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l) + g (k,l)) = (\<Sum>\<^sub>k (\<Sum>\<^sub>l f (k,l)) + (\<Sum>\<^sub>l g (k,l)))"
     by (metis (no_types) aggregation.sum_0.distrib)
   also have "... = (\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l)) + (\<Sum>\<^sub>k \<Sum>\<^sub>l g (k,l))"
     by (metis (no_types) aggregation.sum_0.distrib)
   finally show ?thesis
     .
 qed
 
 lemma agg_sum_add_bot:
   fixes f :: "'a \<Rightarrow> 'b::aggregation_order"
   shows "(\<Sum>\<^sub>k f k) = (\<Sum>\<^sub>k f k) + bot"
   by (metis (no_types) add_add_bot aggregation.sum_0.F_one)
 
 lemma agg_sum_add_bot_2:
   fixes f :: "'a \<Rightarrow> 'b::aggregation_order"
   shows "(\<Sum>\<^sub>k f k + bot) = (\<Sum>\<^sub>k f k)"
 proof -
   have "(\<Sum>\<^sub>k f k + bot) = (\<Sum>\<^sub>k f k) + (\<Sum>\<^sub>k::'a bot::'b)"
     using agg_sum_distrib by simp
   also have "... = (\<Sum>\<^sub>k f k) + (bot + bot)"
     by (metis agg_sum_bot)
   also have "... = (\<Sum>\<^sub>k f k)"
     by simp
   finally show ?thesis
     by simp
 qed
 
 lemma agg_sum_commute:
   fixes f :: "('a,'b::aggregation_order) square"
   shows "(\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l)) = (\<Sum>\<^sub>l \<Sum>\<^sub>k f (k,l))"
   by (rule aggregation.sum_0.swap)
 
 lemma agg_delta:
   fixes f :: "'a::finite \<Rightarrow> 'b::aggregation_order"
   shows "(\<Sum>\<^sub>l if l = j then f l else zero) = f j + bot"
   apply (subst aggregation.sum_0.delta)
   apply simp
   by (metis add.commute add.left_commute add_add_bot mem_Collect_eq)
 
 lemma agg_delta_1:
   fixes f :: "'a::finite \<Rightarrow> 'b::aggregation_order"
   shows "(\<Sum>\<^sub>l if l = j then f l else bot) = f j + bot"
 proof -
   let ?f = "(\<lambda>l . if l = j then f l else bot)"
   let ?S = "{l::'a . True}"
   show ?thesis
   proof (cases "j \<in> ?S")
     case False
     thus ?thesis by simp
   next
     case True
     let ?A = "?S - {j}"
     let ?B = "{j}"
     from True have eq: "?S = ?A \<union> ?B"
       by blast
     have dj: "?A \<inter> ?B = {}"
       by simp
     have fAB: "finite ?A" "finite ?B"
       by auto
     have "aggregation.sum_0 ?f ?S = aggregation.sum_0 ?f ?A + aggregation.sum_0 ?f ?B"
       using aggregation.sum_0.union_disjoint[OF fAB dj, of ?f, unfolded eq [symmetric]] by simp
     also have "... = aggregation.sum_0 (\<lambda>l . bot) ?A + aggregation.sum_0 ?f ?B"
       by (subst aggregation.sum_0.cong[where ?B="?A"]) simp_all
     also have "... = zero + aggregation.sum_0 ?f ?B"
       by (metis (no_types, lifting) add.commute add_add_bot aggregation.sum_0.F_g_one aggregation.sum_0.neutral)
     also have "... = zero + (f j + zero)"
       by simp
     also have "... = f j + bot"
       by (metis add.commute add.left_commute add_add_bot)
     finally show ?thesis
       .
   qed
 qed
 
 lemma agg_delta_2:
   fixes f :: "('a::finite,'b::aggregation_order) square"
   shows "(\<Sum>\<^sub>k \<Sum>\<^sub>l if k = i \<and> l = j then f (k,l) else bot) = f (i,j) + bot"
 proof -
   have "\<forall>k . (\<Sum>\<^sub>l if k = i \<and> l = j then f (k,l) else bot) = (if k = i then f (k,j) + bot else zero)"
   proof
     fix k
     have "(\<Sum>\<^sub>l if k = i \<and> l = j then f (k,l) else bot) = (\<Sum>\<^sub>l if l = j then if k = i then f (k,l) else bot else bot)"
       by meson
     also have "... = (if k = i then f (k,j) else bot) + bot"
       by (rule agg_delta_1)
     finally show "(\<Sum>\<^sub>l if k = i \<and> l = j then f (k,l) else bot) = (if k = i then f (k,j) + bot else zero)"
       by simp
   qed
   hence "(\<Sum>\<^sub>k \<Sum>\<^sub>l if k = i \<and> l = j then f (k,l) else bot) = (\<Sum>\<^sub>k if k = i then f (k,j) + bot else zero)"
     using aggregation.sum_0.cong by auto
   also have "... = f (i,j) + bot"
     apply (subst agg_delta)
     by simp
   finally show ?thesis
     .
 qed
 
 subsection \<open>Matrix Aggregation\<close>
 
 text \<open>
 The following definitions introduce the matrix of unit elements, componentwise aggregation and aggregation on matrices.
 The aggregation of a matrix is a single value, but because s-algebras are single-sorted the result has to be encoded as a matrix of the same type (size) as the input.
 We store the aggregated matrix value in the `first' entry of a matrix, setting all other entries to the unit value.
 The first entry is determined by requiring an enumeration of indices.
 It does not have to be the first entry; any fixed location in the matrix would work as well.
 \<close>
 
 definition zero_matrix :: "('a,'b::{plus,bot}) square" ("mzero") where "mzero = (\<lambda>e . bot + bot)"
 
 definition plus_matrix :: "('a,'b::plus) square \<Rightarrow> ('a,'b) square \<Rightarrow> ('a,'b) square" (infixl "\<oplus>\<^sub>M" 65) where "plus_matrix f g = (\<lambda>e . f e + g e)"
 
 definition sum_matrix :: "('a::enum,'b::{plus,bot}) square \<Rightarrow> ('a,'b) square" ("sum\<^sub>M _" [80] 80) where "sum_matrix f = (\<lambda>(i,j) . if i = hd enum_class.enum \<and> j = i then \<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l) else bot + bot)"
 
 text \<open>
 Basic properties of these operations are given in the following.
 \<close>
 
 lemma bot_plus_bot:
   "mbot \<oplus>\<^sub>M mbot = mzero"
   by (simp add: plus_matrix_def bot_matrix_def zero_matrix_def)
 
 lemma sum_bot:
   "sum\<^sub>M (mbot :: ('a::enum,'b::aggregation_order) square) = mzero"
 proof (rule ext, rule prod_cases)
   fix i j :: "'a"
   have "(sum\<^sub>M mbot :: ('a,'b) square) (i,j) = (if i = hd enum_class.enum \<and> j = i then \<Sum>\<^sub>(k::'a) \<Sum>\<^sub>(l::'a) bot else bot + bot)"
     by (unfold sum_matrix_def bot_matrix_def) simp
   also have "... = bot + bot"
     using agg_sum_bot aggregation.sum_0.neutral by fastforce
   also have "... = mzero (i,j)"
     by (simp add: zero_matrix_def)
   finally show "(sum\<^sub>M mbot :: ('a,'b) square) (i,j) = mzero (i,j)"
     .
 qed
 
 lemma sum_plus_bot:
   fixes f :: "('a::enum,'b::aggregation_order) square"
   shows "sum\<^sub>M f \<oplus>\<^sub>M mbot = sum\<^sub>M f"
 proof (rule ext, rule prod_cases)
   let ?h = "hd enum_class.enum"
   fix i j
   have "(sum\<^sub>M f \<oplus>\<^sub>M mbot) (i,j) = (if i = ?h \<and> j = i then (\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l)) + bot else zero + bot)"
     by (simp add: plus_matrix_def bot_matrix_def sum_matrix_def)
   also have "... = (if i = ?h \<and> j = i then \<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l) else zero)"
     by (metis (no_types, lifting) add_add_bot aggregation.sum_0.F_one)
   also have "... = (sum\<^sub>M f) (i,j)"
     by (simp add: sum_matrix_def)
   finally show "(sum\<^sub>M f \<oplus>\<^sub>M mbot) (i,j) = (sum\<^sub>M f) (i,j)"
     by simp
 qed
 
 lemma sum_plus_zero:
   fixes f :: "('a::enum,'b::aggregation_order) square"
   shows "sum\<^sub>M f \<oplus>\<^sub>M mzero = sum\<^sub>M f"
   by (rule ext, rule prod_cases) (simp add: plus_matrix_def zero_matrix_def sum_matrix_def)
 
 lemma agg_matrix_bot:
   fixes f :: "('a,'b::aggregation_order) square"
   assumes "\<forall>i j . f (i,j) = bot"
     shows "f = mbot"
   apply (unfold bot_matrix_def)
   using assms by auto
 
 text \<open>
 We consider a different implementation of matrix aggregation which stores the aggregated value in all entries of the matrix instead of a particular one.
 This does not require an enumeration of the indices.
 All results continue to hold using this alternative implementation.
 \<close>
 
 definition sum_matrix_2 :: "('a,'b::{plus,bot}) square \<Rightarrow> ('a,'b) square" ("sum2\<^sub>M _" [80] 80) where "sum_matrix_2 f = (\<lambda>e . \<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l))"
 
 lemma sum_bot_2:
   "sum2\<^sub>M (mbot :: ('a,'b::aggregation_order) square) = mzero"
 proof
   fix e
   have "(sum2\<^sub>M mbot :: ('a,'b) square) e = (\<Sum>\<^sub>(k::'a) \<Sum>\<^sub>(l::'a) bot)"
     by (unfold sum_matrix_2_def bot_matrix_def) simp
   also have "... = bot + bot"
     using agg_sum_bot aggregation.sum_0.neutral by fastforce
   also have "... = mzero e"
     by (simp add: zero_matrix_def)
   finally show "(sum2\<^sub>M mbot :: ('a,'b) square) e = mzero e"
     .
 qed
 
 lemma sum_plus_bot_2:
   fixes f :: "('a,'b::aggregation_order) square"
   shows "sum2\<^sub>M f \<oplus>\<^sub>M mbot = sum2\<^sub>M f"
 proof
   fix e
   have "(sum2\<^sub>M f \<oplus>\<^sub>M mbot) e = (\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l)) + bot"
     by (simp add: plus_matrix_def bot_matrix_def sum_matrix_2_def)
   also have "... = (\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l))"
     by (metis (no_types, lifting) add_add_bot aggregation.sum_0.F_one)
   also have "... = (sum2\<^sub>M f) e"
     by (simp add: sum_matrix_2_def)
   finally show "(sum2\<^sub>M f \<oplus>\<^sub>M mbot) e = (sum2\<^sub>M f) e"
     by simp
 qed
 
 lemma sum_plus_zero_2:
   fixes f :: "('a,'b::aggregation_order) square"
   shows "sum2\<^sub>M f \<oplus>\<^sub>M mzero = sum2\<^sub>M f"
   by (simp add: plus_matrix_def zero_matrix_def sum_matrix_2_def)
 
 subsection \<open>Aggregation Lattices\<close>
 
 text \<open>
 We extend aggregation orders to dense bounded distributive lattices.
 Axiom \<open>add_lattice\<close> implements the inclusion-exclusion principle at the level of edge weights.
 \<close>
 
 class aggregation_lattice = bounded_distrib_lattice + dense_lattice + aggregation_order +
   assumes add_lattice: "x + y = (x \<squnion> y) + (x \<sqinter> y)"
 
 text \<open>
 Aggregation lattices form a Stone relation algebra by reusing the meet operation as composition, using identity as converse and a standard implementation of pseudocomplement.
 \<close>
 
 class aggregation_algebra = aggregation_lattice + uminus + one + times + conv +
   assumes uminus_def [simp]: "-x = (if x = bot then top else bot)"
   assumes one_def [simp]: "1 = top"
   assumes times_def [simp]: "x * y = x \<sqinter> y"
   assumes conv_def [simp]: "x\<^sup>T = x"
 begin
 
 subclass stone_algebra
   apply unfold_locales
   using bot_meet_irreducible bot_unique by auto
 
 subclass stone_relation_algebra
   apply unfold_locales
   prefer 9 using bot_meet_irreducible apply auto[1]
   by (simp_all add: inf.assoc le_infI2 inf_sup_distrib1 inf_sup_distrib2 inf.commute inf.left_commute)
 
 end
 
 text \<open>
 We show that matrices over aggregation lattices form an s-algebra using the above operations.
 \<close>
 
 interpretation agg_square_s_algebra: s_algebra where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix::('a::enum,'b::aggregation_algebra) square" and top = top_matrix and uminus = uminus_matrix and one = one_matrix and times = times_matrix and conv = conv_matrix and plus = plus_matrix and sum = sum_matrix
 proof
   fix f g h :: "('a,'b) square"
   show "f \<noteq> mbot \<and> sum\<^sub>M f \<preceq> sum\<^sub>M g \<longrightarrow> h \<oplus>\<^sub>M sum\<^sub>M f \<preceq> h \<oplus>\<^sub>M sum\<^sub>M g"
   proof
     let ?h = "hd enum_class.enum"
     assume 1: "f \<noteq> mbot \<and> sum\<^sub>M f \<preceq> sum\<^sub>M g"
     hence "\<exists>k l . f (k,l) \<noteq> bot"
       by (meson agg_matrix_bot)
     hence 2: "(\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l)) \<noteq> bot"
       using agg_sum_not_bot by blast
     have "(\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l)) = (sum\<^sub>M f) (?h,?h)"
       by (simp add: sum_matrix_def)
     also have "... \<le> (sum\<^sub>M g) (?h,?h)"
       using 1 by (simp add: less_eq_matrix_def)
     also have "... = (\<Sum>\<^sub>k \<Sum>\<^sub>l g (k,l))"
       by (simp add: sum_matrix_def)
     finally have "(\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l)) \<le> (\<Sum>\<^sub>k \<Sum>\<^sub>l g (k,l))"
       by simp
     hence 3: "(\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l)) + bot \<le> (\<Sum>\<^sub>k \<Sum>\<^sub>l g (k,l)) + bot"
       by (metis (no_types, lifting) add_add_bot aggregation.sum_0.F_one)
     show "h \<oplus>\<^sub>M sum\<^sub>M f \<preceq> h \<oplus>\<^sub>M sum\<^sub>M g"
     proof (unfold less_eq_matrix_def, rule allI, rule prod_cases, unfold plus_matrix_def)
       fix i j
       have 4: "h (i,j) + (\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l)) \<le> h (i,j) + (\<Sum>\<^sub>k \<Sum>\<^sub>l g (k,l))"
         using 2 3 by (metis (no_types, lifting) add_right_isotone add.commute)
       have "h (i,j) + (sum\<^sub>M f) (i,j) = h (i,j) + (if i = ?h \<and> j = i then \<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l) else zero)"
         by (simp add: sum_matrix_def)
       also have "... = (if i = ?h \<and> j = i then h (i,j) + (\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l)) else h (i,j) + zero)"
         by simp
       also have "... \<le> (if i = ?h \<and> j = i then h (i,j) + (\<Sum>\<^sub>k \<Sum>\<^sub>l g (k,l)) else h (i,j) + zero)"
         using 4 order.eq_iff by auto
       also have "... = h (i,j) + (if i = ?h \<and> j = i then \<Sum>\<^sub>k \<Sum>\<^sub>l g (k,l) else zero)"
         by simp
       finally show "h (i,j) + (sum\<^sub>M f) (i,j) \<le> h (i,j) + (sum\<^sub>M g) (i,j)"
         by (simp add: sum_matrix_def)
     qed
   qed
 next
   fix f :: "('a,'b) square"
   show "sum\<^sub>M f \<oplus>\<^sub>M sum\<^sub>M mbot = sum\<^sub>M f"
     by (simp add: sum_bot sum_plus_zero)
 next
   fix f g :: "('a,'b) square"
   show "sum\<^sub>M f \<oplus>\<^sub>M sum\<^sub>M g = sum\<^sub>M (f \<oplus> g) \<oplus>\<^sub>M sum\<^sub>M (f \<otimes> g)"
   proof (rule ext, rule prod_cases)
     fix i j
     let ?h = "hd enum_class.enum"
     have "(sum\<^sub>M f \<oplus>\<^sub>M sum\<^sub>M g) (i,j) = (sum\<^sub>M f) (i,j) + (sum\<^sub>M g) (i,j)"
       by (simp add: plus_matrix_def)
     also have "... = (if i = ?h \<and> j = i then \<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l) else zero) + (if i = ?h \<and> j = i then \<Sum>\<^sub>k \<Sum>\<^sub>l g (k,l) else zero)"
       by (simp add: sum_matrix_def)
     also have "... = (if i = ?h \<and> j = i then (\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l)) + (\<Sum>\<^sub>k \<Sum>\<^sub>l g (k,l)) else zero)"
       by simp
     also have "... = (if i = ?h \<and> j = i then \<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l) + g (k,l) else zero)"
       using agg_sum_distrib_2 by (metis (no_types))
     also have "... = (if i = ?h \<and> j = i then \<Sum>\<^sub>k \<Sum>\<^sub>l (f (k,l) \<squnion> g (k,l)) + (f (k,l) \<sqinter> g (k,l)) else zero)"
       using add_lattice aggregation.sum_0.cong by (metis (no_types, lifting))
     also have "... = (if i = ?h \<and> j = i then \<Sum>\<^sub>k \<Sum>\<^sub>l (f \<oplus> g) (k,l) + (f \<otimes> g) (k,l) else zero)"
       by (simp add: sup_matrix_def inf_matrix_def)
     also have "... = (if i = ?h \<and> j = i then (\<Sum>\<^sub>k \<Sum>\<^sub>l (f \<oplus> g) (k,l)) + (\<Sum>\<^sub>k \<Sum>\<^sub>l (f \<otimes> g) (k,l)) else zero)"
       using agg_sum_distrib_2 by (metis (no_types))
     also have "... = (if i = ?h \<and> j = i then \<Sum>\<^sub>k \<Sum>\<^sub>l (f \<oplus> g) (k,l) else zero) + (if i = ?h \<and> j = i then \<Sum>\<^sub>k \<Sum>\<^sub>l (f \<otimes> g) (k,l) else zero)"
       by simp
     also have "... = (sum\<^sub>M (f \<oplus> g)) (i,j) + (sum\<^sub>M (f \<otimes> g)) (i,j)"
       by (simp add: sum_matrix_def)
     also have "... = (sum\<^sub>M (f \<oplus> g) \<oplus>\<^sub>M sum\<^sub>M (f \<otimes> g)) (i,j)"
       by (simp add: plus_matrix_def)
     finally show "(sum\<^sub>M f \<oplus>\<^sub>M sum\<^sub>M g) (i,j) = (sum\<^sub>M (f \<oplus> g) \<oplus>\<^sub>M sum\<^sub>M (f \<otimes> g)) (i,j)"
       .
   qed
 next
   fix f :: "('a,'b) square"
   show "sum\<^sub>M (f\<^sup>t) = sum\<^sub>M f"
   proof (rule ext, rule prod_cases)
     fix i j
     let ?h = "hd enum_class.enum"
     have "(sum\<^sub>M (f\<^sup>t)) (i,j) = (if i = ?h \<and> j = i then \<Sum>\<^sub>k \<Sum>\<^sub>l (f\<^sup>t) (k,l) else zero)"
       by (simp add: sum_matrix_def)
     also have "... = (if i = ?h \<and> j = i then \<Sum>\<^sub>k \<Sum>\<^sub>l (f (l,k))\<^sup>T else zero)"
       by (simp add: conv_matrix_def)
     also have "... = (if i = ?h \<and> j = i then \<Sum>\<^sub>k \<Sum>\<^sub>l f (l,k) else zero)"
       by simp
     also have "... = (if i = ?h \<and> j = i then \<Sum>\<^sub>l \<Sum>\<^sub>k f (l,k) else zero)"
       by (metis agg_sum_commute)
     also have "... = (sum\<^sub>M f) (i,j)"
       by (simp add: sum_matrix_def)
     finally show "(sum\<^sub>M (f\<^sup>t)) (i,j) = (sum\<^sub>M f) (i,j)"
       .
   qed
 qed
 
 text \<open>
 We show the same for the alternative implementation that stores the result of aggregation in all elements of the matrix.
 \<close>
 
 interpretation agg_square_s_algebra_2: s_algebra where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix::('a::finite,'b::aggregation_algebra) square" and top = top_matrix and uminus = uminus_matrix and one = one_matrix and times = times_matrix and conv = conv_matrix and plus = plus_matrix and sum = sum_matrix_2
 proof
   fix f g h :: "('a,'b) square"
   show "f \<noteq> mbot \<and> sum2\<^sub>M f \<preceq> sum2\<^sub>M g \<longrightarrow> h \<oplus>\<^sub>M sum2\<^sub>M f \<preceq> h \<oplus>\<^sub>M sum2\<^sub>M g"
   proof
     assume 1: "f \<noteq> mbot \<and> sum2\<^sub>M f \<preceq> sum2\<^sub>M g"
     hence "\<exists>k l . f (k,l) \<noteq> bot"
       by (meson agg_matrix_bot)
     hence 2: "(\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l)) \<noteq> bot"
       using agg_sum_not_bot by blast
     obtain c :: 'a where True
       by simp
     have "(\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l)) = (sum2\<^sub>M f) (c,c)"
       by (simp add: sum_matrix_2_def)
     also have "... \<le> (sum2\<^sub>M g) (c,c)"
       using 1 by (simp add: less_eq_matrix_def)
     also have "... = (\<Sum>\<^sub>k \<Sum>\<^sub>l g (k,l))"
       by (simp add: sum_matrix_2_def)
     finally have "(\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l)) \<le> (\<Sum>\<^sub>k \<Sum>\<^sub>l g (k,l))"
       by simp
     hence 3: "(\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l)) + bot \<le> (\<Sum>\<^sub>k \<Sum>\<^sub>l g (k,l)) + bot"
       by (metis (no_types, lifting) add_add_bot aggregation.sum_0.F_one)
     show "h \<oplus>\<^sub>M sum2\<^sub>M f \<preceq> h \<oplus>\<^sub>M sum2\<^sub>M g"
     proof (unfold less_eq_matrix_def, rule allI, unfold plus_matrix_def)
       fix e
       have "h e + (sum2\<^sub>M f) e = h e + (\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l))"
         by (simp add: sum_matrix_2_def)
       also have "... \<le> h e + (\<Sum>\<^sub>k \<Sum>\<^sub>l g (k,l))"
         using 2 3 by (metis (no_types, lifting) add_right_isotone add.commute)
       finally show "h e + (sum2\<^sub>M f) e \<le> h e + (sum2\<^sub>M g) e"
         by (simp add: sum_matrix_2_def)
     qed
   qed
 next
   fix f :: "('a,'b) square"
   show "sum2\<^sub>M f \<oplus>\<^sub>M sum2\<^sub>M mbot = sum2\<^sub>M f"
     by (simp add: sum_bot_2 sum_plus_zero_2)
 next
   fix f g :: "('a,'b) square"
   show "sum2\<^sub>M f \<oplus>\<^sub>M sum2\<^sub>M g = sum2\<^sub>M (f \<oplus> g) \<oplus>\<^sub>M sum2\<^sub>M (f \<otimes> g)"
   proof
     fix e
     have "(sum2\<^sub>M f \<oplus>\<^sub>M sum2\<^sub>M g) e = (sum2\<^sub>M f) e + (sum2\<^sub>M g) e"
       by (simp add: plus_matrix_def)
     also have "... = (\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l)) + (\<Sum>\<^sub>k \<Sum>\<^sub>l g (k,l))"
       by (simp add: sum_matrix_2_def)
     also have "... = (\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l) + g (k,l))"
       using agg_sum_distrib_2 by (metis (no_types))
     also have "... = (\<Sum>\<^sub>k \<Sum>\<^sub>l (f (k,l) \<squnion> g (k,l)) + (f (k,l) \<sqinter> g (k,l)))"
       using add_lattice aggregation.sum_0.cong by (metis (no_types, lifting))
     also have "... = (\<Sum>\<^sub>k \<Sum>\<^sub>l (f \<oplus> g) (k,l) + (f \<otimes> g) (k,l))"
       by (simp add: sup_matrix_def inf_matrix_def)
     also have "... = (\<Sum>\<^sub>k \<Sum>\<^sub>l (f \<oplus> g) (k,l)) + (\<Sum>\<^sub>k \<Sum>\<^sub>l (f \<otimes> g) (k,l))"
       using agg_sum_distrib_2 by (metis (no_types))
     also have "... = (sum2\<^sub>M (f \<oplus> g)) e + (sum2\<^sub>M (f \<otimes> g)) e"
       by (simp add: sum_matrix_2_def)
     also have "... = (sum2\<^sub>M (f \<oplus> g) \<oplus>\<^sub>M sum2\<^sub>M (f \<otimes> g)) e"
       by (simp add: plus_matrix_def)
     finally show "(sum2\<^sub>M f \<oplus>\<^sub>M sum2\<^sub>M g) e = (sum2\<^sub>M (f \<oplus> g) \<oplus>\<^sub>M sum2\<^sub>M (f \<otimes> g)) e"
       .
   qed
 next
   fix f :: "('a,'b) square"
   show "sum2\<^sub>M (f\<^sup>t) = sum2\<^sub>M f"
   proof
     fix e
     have "(sum2\<^sub>M (f\<^sup>t)) e = (\<Sum>\<^sub>k \<Sum>\<^sub>l (f\<^sup>t) (k,l))"
       by (simp add: sum_matrix_2_def)
     also have "... = (\<Sum>\<^sub>k \<Sum>\<^sub>l (f (l,k))\<^sup>T)"
       by (simp add: conv_matrix_def)
     also have "... = (\<Sum>\<^sub>k \<Sum>\<^sub>l f (l,k))"
       by simp
     also have "... = (\<Sum>\<^sub>l \<Sum>\<^sub>k f (l,k))"
       by (metis agg_sum_commute)
     also have "... = (sum2\<^sub>M f) e"
       by (simp add: sum_matrix_2_def)
     finally show "(sum2\<^sub>M (f\<^sup>t)) e = (sum2\<^sub>M f) e"
       .
   qed
 qed
 
 subsection \<open>Matrix Minimisation\<close>
 
 text \<open>
 We construct an operation that finds the minimum entry of a matrix.
 Because a matrix can have several entries with the same minimum value, we introduce a lexicographic order on the indices to make the operation deterministic.
 The order is obtained by enumerating the universe of the index.
 \<close>
 
 primrec enum_pos' :: "'a list \<Rightarrow> 'a::enum \<Rightarrow> nat" where
   "enum_pos' Nil x = 0"
 | "enum_pos' (y#ys) x = (if x = y then 0 else 1 + enum_pos' ys x)"
 
 lemma enum_pos'_inverse:
   "List.member xs x \<Longrightarrow> xs!(enum_pos' xs x) = x"
   apply (induct xs)
   apply (simp add: member_rec(2))
   by (metis diff_add_inverse enum_pos'.simps(2) less_one member_rec(1) not_add_less1 nth_Cons')
 
 text \<open>
 The following function finds the position of an index in the enumerated universe.
 \<close>
 
 fun enum_pos :: "'a::enum \<Rightarrow> nat" where "enum_pos x = enum_pos' (enum_class.enum::'a list) x"
 
 lemma enum_pos_inverse [simp]:
   "enum_class.enum!(enum_pos x) = x"
   apply (unfold enum_pos.simps)
   apply (rule enum_pos'_inverse)
   by (metis in_enum List.member_def)
 
 lemma enum_pos_injective [simp]:
   "enum_pos x = enum_pos y \<Longrightarrow> x = y"
   by (metis enum_pos_inverse)
 
 text \<open>
 The position in the enumerated universe determines the order.
 \<close>
 
 abbreviation enum_pos_less_eq :: "'a::enum \<Rightarrow> 'a \<Rightarrow> bool" where "enum_pos_less_eq x y \<equiv> (enum_pos x \<le> enum_pos y)"
 abbreviation enum_pos_less :: "'a::enum \<Rightarrow> 'a \<Rightarrow> bool" where "enum_pos_less x y \<equiv> (enum_pos x < enum_pos y)"
 
 sublocale enum < enum_order: order where less_eq = "\<lambda>x y . enum_pos_less_eq x y" and less = "\<lambda>x y . enum_pos x < enum_pos y"
   apply unfold_locales
   by auto
 
 text \<open>
 Based on this, a lexicographic order is defined on pairs, which represent locations in a matrix.
 \<close>
 
 abbreviation enum_lex_less :: "'a::enum \<times> 'a \<Rightarrow> 'a \<times> 'a \<Rightarrow> bool" where "enum_lex_less \<equiv> (\<lambda>(i,j) (k,l) . enum_pos_less i k \<or> (i = k \<and> enum_pos_less j l))"
 abbreviation enum_lex_less_eq :: "'a::enum \<times> 'a \<Rightarrow> 'a \<times> 'a \<Rightarrow> bool" where "enum_lex_less_eq \<equiv> (\<lambda>(i,j) (k,l) . enum_pos_less i k \<or> (i = k \<and> enum_pos_less_eq j l))"
 
 text \<open>
 The $m$-operation determines the location of the non-$\bot$ minimum element which is first in the lexicographic order.
 The result is returned as a regular matrix with $\top$ at that location and $\bot$ everywhere else.
 In the weighted-graph model, this represents a single unweighted edge of the graph.
 \<close>
 
 definition minarc_matrix :: "('a::enum,'b::{bot,ord,plus,top}) square \<Rightarrow> ('a,'b) square" ("minarc\<^sub>M _" [80] 80) where "minarc_matrix f = (\<lambda>e . if f e \<noteq> bot \<and> (\<forall>d . (f d \<noteq> bot \<longrightarrow> (f e + bot \<le> f d + bot \<and> (enum_lex_less d e \<longrightarrow> f e + bot \<noteq> f d + bot)))) then top else bot)"
 
 lemma minarc_at_most_one:
   fixes f :: "('a::enum,'b::{aggregation_order,top}) square"
   assumes "(minarc\<^sub>M f) e \<noteq> bot"
       and "(minarc\<^sub>M f) d \<noteq> bot"
     shows "e = d"
 proof -
   have 1: "f e + bot \<le> f d + bot"
     by (metis assms minarc_matrix_def)
   have "f d + bot \<le> f e + bot"
     by (metis assms minarc_matrix_def)
   hence "f e + bot = f d + bot"
     using 1 by simp
   hence "\<not> enum_lex_less d e \<and> \<not> enum_lex_less e d"
     using assms by (unfold minarc_matrix_def) (metis (lifting))
   thus ?thesis
     using enum_pos_injective less_linear by auto
 qed
 
 subsection \<open>Linear Aggregation Lattices\<close>
 
 text \<open>
 We now assume that the aggregation order is linear and forms a bounded lattice.
 It follows that these structures are aggregation lattices.
 A linear order on matrix entries is necessary to obtain a unique minimum entry.
 \<close>
 
 class linear_aggregation_lattice = linear_bounded_lattice + aggregation_order
 begin
 
 subclass aggregation_lattice
   apply unfold_locales
   by (metis add_commute sup_inf_selective)
 
 sublocale heyting: bounded_heyting_lattice where implies = "\<lambda>x y . if x \<le> y then top else y"
   apply unfold_locales
   by (simp add: inf_less_eq)
 
 end
 
 text \<open>
 Every non-empty set with a transitive total relation has a least element with respect to this relation.
 \<close>
 
 lemma least_order:
   assumes transitive: "\<forall>x y z . le x y \<and> le y z \<longrightarrow> le x z"
       and total: "\<forall>x y . le x y \<or> le y x"
     shows "finite A \<Longrightarrow> A \<noteq> {} \<Longrightarrow> \<exists>x . x \<in> A \<and> (\<forall>y . y \<in> A \<longrightarrow> le x y)"
 proof (induct A rule: finite_ne_induct)
   case singleton
   thus ?case
     using total by auto
 next
   case insert
   thus ?case
     by (metis insert_iff transitive total)
 qed
 
 lemma minarc_at_least_one:
   fixes f :: "('a::enum,'b::linear_aggregation_lattice) square"
   assumes "f \<noteq> mbot"
     shows "\<exists>e . (minarc\<^sub>M f) e = top"
 proof -
   let ?nbe = "{ (e,f e) | e . f e \<noteq> bot }"
   have 1: "finite ?nbe"
     using finite_code finite_image_set by blast
   have 2: "?nbe \<noteq> {}"
     using assms agg_matrix_bot by fastforce
   let ?le = "\<lambda>(e::'a \<times> 'a,fe::'b) (d::'a \<times> 'a,fd) . fe + bot \<le> fd + bot"
   have 3: "\<forall>x y z . ?le x y \<and> ?le y z \<longrightarrow> ?le x z"
     by auto
   have 4: "\<forall>x y . ?le x y \<or> ?le y x"
     by (simp add: linear)
   have "\<exists>x . x \<in> ?nbe \<and> (\<forall>y . y \<in> ?nbe \<longrightarrow> ?le x y)"
     by (rule least_order, rule 3, rule 4, rule 1, rule 2)
   then obtain e fe where 5: "(e,fe) \<in> ?nbe \<and> (\<forall>y . y \<in> ?nbe \<longrightarrow> ?le (e,fe) y)"
     by auto
   let ?me = "{ e . f e \<noteq> bot \<and> f e + bot = fe + bot }"
   have 6: "finite ?me"
     using finite_code finite_image_set by blast
   have 7: "?me \<noteq> {}"
     using 5 by auto
   have 8: "\<forall>x y z . enum_lex_less_eq x y \<and> enum_lex_less_eq y z \<longrightarrow> enum_lex_less_eq x z"
     by auto
   have 9: "\<forall>x y . enum_lex_less_eq x y \<or> enum_lex_less_eq y x"
     by auto
   have "\<exists>x . x \<in> ?me \<and> (\<forall>y . y \<in> ?me \<longrightarrow> enum_lex_less_eq x y)"
     by (rule least_order, rule 8, rule 9, rule 6, rule 7)
   then obtain m where 10: "m \<in> ?me \<and> (\<forall>y . y \<in> ?me \<longrightarrow> enum_lex_less_eq m y)"
     by auto
   have 11: "f m \<noteq> bot"
     using 10 5 by auto
   have 12: "\<forall>d. f d \<noteq> bot \<longrightarrow> f m + bot \<le> f d + bot"
     using 10 5 by simp
   have "\<forall>d. f d \<noteq> bot \<and> enum_lex_less d m \<longrightarrow> f m + bot \<noteq> f d + bot"
     using 10 by fastforce
   hence "(minarc\<^sub>M f) m = top"
     using 11 12 by (simp add: minarc_matrix_def)
   thus ?thesis
     by blast
 qed
 
 text \<open>
 Linear aggregation lattices form a Stone relation algebra by reusing the meet operation as composition, using identity as converse and a standard implementation of pseudocomplement.
 \<close>
 
 class linear_aggregation_algebra = linear_aggregation_lattice + uminus + one + times + conv +
   assumes uminus_def_2 [simp]: "-x = (if x = bot then top else bot)"
   assumes one_def_2 [simp]: "1 = top"
   assumes times_def_2 [simp]: "x * y = x \<sqinter> y"
   assumes conv_def_2 [simp]: "x\<^sup>T = x"
 begin
 
 subclass aggregation_algebra
   apply unfold_locales
   using inf_dense by auto
 
 lemma regular_bot_top_2:
   "regular x \<longleftrightarrow> x = bot \<or> x = top"
   by simp
 
 sublocale heyting: heyting_stone_algebra where implies = "\<lambda>x y . if x \<le> y then top else y"
   apply unfold_locales
   apply (simp add: order.antisym)
   by auto
 
 end
 
 text \<open>
 We show that matrices over linear aggregation lattices form an m-algebra using the above operations.
 \<close>
 
 interpretation agg_square_m_algebra: m_algebra where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix::('a::enum,'b::linear_aggregation_algebra) square" and top = top_matrix and uminus = uminus_matrix and one = one_matrix and times = times_matrix and conv = conv_matrix and plus = plus_matrix and sum = sum_matrix and minarc = minarc_matrix
 proof
   fix f :: "('a,'b) square"
   show "minarc\<^sub>M f \<preceq> \<ominus>\<ominus>f"
   proof (unfold less_eq_matrix_def, rule allI)
     fix e :: "'a \<times> 'a"
     have "(minarc\<^sub>M f) e \<le> (if f e \<noteq> bot then top else --(f e))"
       by (simp add: minarc_matrix_def)
     also have "... = --(f e)"
       by simp
     also have "... = (\<ominus>\<ominus>f) e"
       by (simp add: uminus_matrix_def)
     finally show "(minarc\<^sub>M f) e \<le> (\<ominus>\<ominus>f) e"
       .
   qed
 next
   fix f :: "('a,'b) square"
   let ?at = "bounded_distrib_allegory_signature.arc mone times_matrix less_eq_matrix mtop conv_matrix"
   show "f \<noteq> mbot \<longrightarrow> ?at (minarc\<^sub>M f)"
   proof
     assume 1: "f \<noteq> mbot"
     have "minarc\<^sub>M f \<odot> mtop \<odot> (minarc\<^sub>M f \<odot> mtop)\<^sup>t = minarc\<^sub>M f \<odot> mtop \<odot> (minarc\<^sub>M f)\<^sup>t"
       by (metis matrix_bounded_idempotent_semiring.surjective_top_closed matrix_monoid.mult_assoc matrix_stone_relation_algebra.conv_dist_comp matrix_stone_relation_algebra.conv_top)
     also have "... \<preceq> mone"
     proof (unfold less_eq_matrix_def, rule allI, rule prod_cases)
       fix i j
       have "(minarc\<^sub>M f \<odot> mtop \<odot> (minarc\<^sub>M f)\<^sup>t) (i,j) = (\<Squnion>\<^sub>l (\<Squnion>\<^sub>k (minarc\<^sub>M f) (i,k) * mtop (k,l)) * ((minarc\<^sub>M f)\<^sup>t) (l,j))"
         by (simp add: times_matrix_def)
       also have "... = (\<Squnion>\<^sub>l (\<Squnion>\<^sub>k (minarc\<^sub>M f) (i,k) * top) * ((minarc\<^sub>M f) (j,l))\<^sup>T)"
         by (simp add: top_matrix_def conv_matrix_def)
       also have "... = (\<Squnion>\<^sub>l \<Squnion>\<^sub>k (minarc\<^sub>M f) (i,k) * top * ((minarc\<^sub>M f) (j,l))\<^sup>T)"
         by (metis comp_right_dist_sum)
       also have "... = (\<Squnion>\<^sub>l \<Squnion>\<^sub>k if i = j \<and> l = k then (minarc\<^sub>M f) (i,k) * top * ((minarc\<^sub>M f) (j,l))\<^sup>T else bot)"
         apply (rule sup_monoid.sum.cong)
         apply simp
         by (metis (no_types, lifting) comp_left_zero comp_right_zero conv_bot prod.inject minarc_at_most_one)
       also have "... = (if i = j then (\<Squnion>\<^sub>l \<Squnion>\<^sub>k if l = k then (minarc\<^sub>M f) (i,k) * top * ((minarc\<^sub>M f) (j,l))\<^sup>T else bot) else bot)"
         by auto
       also have "... \<le> (if i = j then top else bot)"
         by simp
       also have "... = mone (i,j)"
         by (simp add: one_matrix_def)
       finally show "(minarc\<^sub>M f \<odot> mtop \<odot> (minarc\<^sub>M f)\<^sup>t) (i,j) \<le> mone (i,j)"
         .
     qed
     finally have 2: "minarc\<^sub>M f \<odot> mtop \<odot> (minarc\<^sub>M f \<odot> mtop)\<^sup>t \<preceq> mone"
       .
     have 3: "mtop \<odot> (minarc\<^sub>M f \<odot> mtop) = mtop"
     proof (rule ext, rule prod_cases)
       fix i j
       from minarc_at_least_one obtain ei ej where "(minarc\<^sub>M f) (ei,ej) = top"
         using 1 by force
       hence 4: "top * top \<le> (\<Squnion>\<^sub>l (minarc\<^sub>M f) (ei,l) * top)"
         by (metis comp_inf.ub_sum)
       have "top * (\<Squnion>\<^sub>l (minarc\<^sub>M f) (ei,l) * top) \<le> (\<Squnion>\<^sub>k top * (\<Squnion>\<^sub>l (minarc\<^sub>M f) (k,l) * top))"
         by (rule comp_inf.ub_sum)
       hence "top \<le> (\<Squnion>\<^sub>k top * (\<Squnion>\<^sub>l (minarc\<^sub>M f) (k,l) * top))"
         using 4 by auto
       also have "... = (\<Squnion>\<^sub>k mtop (i,k) * (\<Squnion>\<^sub>l (minarc\<^sub>M f) (k,l) * mtop (l,j)))"
         by (simp add: top_matrix_def)
       also have "... = (mtop \<odot> (minarc\<^sub>M f \<odot> mtop)) (i,j)"
         by (simp add: times_matrix_def)
       finally show "(mtop \<odot> (minarc\<^sub>M f \<odot> mtop)) (i,j) = mtop (i,j)"
         by (simp add: eq_iff top_matrix_def)
     qed
     have "(minarc\<^sub>M f)\<^sup>t \<odot> mtop \<odot> ((minarc\<^sub>M f)\<^sup>t \<odot> mtop)\<^sup>t = (minarc\<^sub>M f)\<^sup>t \<odot> mtop \<odot> (minarc\<^sub>M f)"
       by (metis matrix_stone_relation_algebra.comp_associative matrix_stone_relation_algebra.conv_dist_comp matrix_stone_relation_algebra.conv_involutive matrix_stone_relation_algebra.conv_top matrix_bounded_idempotent_semiring.surjective_top_closed)
     also have "... \<preceq> mone"
     proof (unfold less_eq_matrix_def, rule allI, rule prod_cases)
       fix i j
       have "((minarc\<^sub>M f)\<^sup>t \<odot> mtop \<odot> minarc\<^sub>M f) (i,j) = (\<Squnion>\<^sub>l (\<Squnion>\<^sub>k ((minarc\<^sub>M f)\<^sup>t) (i,k) * mtop (k,l)) * (minarc\<^sub>M f) (l,j))"
         by (simp add: times_matrix_def)
       also have "... = (\<Squnion>\<^sub>l (\<Squnion>\<^sub>k ((minarc\<^sub>M f) (k,i))\<^sup>T * top) * (minarc\<^sub>M f) (l,j))"
         by (simp add: top_matrix_def conv_matrix_def)
       also have "... = (\<Squnion>\<^sub>l \<Squnion>\<^sub>k ((minarc\<^sub>M f) (k,i))\<^sup>T * top * (minarc\<^sub>M f) (l,j))"
         by (metis comp_right_dist_sum)
       also have "... = (\<Squnion>\<^sub>l \<Squnion>\<^sub>k if i = j \<and> l = k then ((minarc\<^sub>M f) (k,i))\<^sup>T * top * (minarc\<^sub>M f) (l,j) else bot)"
         apply (rule sup_monoid.sum.cong)
         apply simp
         by (metis (no_types, lifting) comp_left_zero comp_right_zero conv_bot prod.inject minarc_at_most_one)
       also have "... = (if i = j then (\<Squnion>\<^sub>l \<Squnion>\<^sub>k if l = k then ((minarc\<^sub>M f) (k,i))\<^sup>T * top * (minarc\<^sub>M f) (l,j) else bot) else bot)"
         by auto
       also have "... \<le> (if i = j then top else bot)"
         by simp
       also have "... = mone (i,j)"
         by (simp add: one_matrix_def)
       finally show "((minarc\<^sub>M f)\<^sup>t \<odot> mtop \<odot> (minarc\<^sub>M f)) (i,j) \<le> mone (i,j)"
         .
     qed
     finally have 5: "(minarc\<^sub>M f)\<^sup>t \<odot> mtop \<odot> ((minarc\<^sub>M f)\<^sup>t \<odot> mtop)\<^sup>t \<preceq> mone"
       .
     have "mtop \<odot> ((minarc\<^sub>M f)\<^sup>t \<odot> mtop) = mtop"
       using 3 by (metis matrix_monoid.mult_assoc matrix_stone_relation_algebra.conv_dist_comp matrix_stone_relation_algebra.conv_top)
     thus "?at (minarc\<^sub>M f)"
       using 2 3 5 by blast
   qed
 next
   fix f g :: "('a,'b) square"
   let ?at = "bounded_distrib_allegory_signature.arc mone times_matrix less_eq_matrix mtop conv_matrix"
   show "?at g \<and> g \<otimes> f \<noteq> mbot \<longrightarrow> sum\<^sub>M (minarc\<^sub>M f \<otimes> f) \<preceq> sum\<^sub>M (g \<otimes> f)"
   proof
     assume 1: "?at g \<and> g \<otimes> f \<noteq> mbot"
     hence 2: "g = \<ominus>\<ominus>g"
       using matrix_stone_relation_algebra.arc_regular by blast
     show "sum\<^sub>M (minarc\<^sub>M f \<otimes> f) \<preceq> sum\<^sub>M (g \<otimes> f)"
     proof (unfold less_eq_matrix_def, rule allI, rule prod_cases)
       fix i j
       from minarc_at_least_one obtain ei ej where 3: "(minarc\<^sub>M f) (ei,ej) = top"
         using 1 by force
       hence 4: "\<forall>k l . \<not>(k = ei \<and> l = ej) \<longrightarrow> (minarc\<^sub>M f) (k,l) = bot"
         by (metis (mono_tags, opaque_lifting) bot.extremum inf.bot_unique prod.inject minarc_at_most_one)
       from agg_matrix_bot obtain di dj where 5: "(g \<otimes> f) (di,dj) \<noteq> bot"
         using 1 by force
       hence 6: "g (di,dj) \<noteq> bot"
         by (metis inf_bot_left inf_matrix_def)
       hence 7: "g (di,dj) = top"
         using 2 by (metis uminus_matrix_def uminus_def)
       hence 8: "(g \<otimes> f) (di,dj) = f (di,dj)"
         by (metis inf_matrix_def inf_top.left_neutral)
       have 9: "\<forall>k l . k \<noteq> di \<longrightarrow> g (k,l) = bot"
       proof (intro allI, rule impI)
         fix k l
         assume 10: "k \<noteq> di"
         have "top * (g (k,l))\<^sup>T = g (di,dj) * top * (g\<^sup>t) (l,k)"
           using 7 by (simp add: conv_matrix_def)
         also have "... \<le> (\<Squnion>\<^sub>n g (di,n) * top) * (g\<^sup>t) (l,k)"
           by (metis comp_inf.ub_sum comp_right_dist_sum)
         also have "... \<le> (\<Squnion>\<^sub>m (\<Squnion>\<^sub>n g (di,n) * top) * (g\<^sup>t) (m,k))"
           by (metis comp_inf.ub_sum)
         also have "... = (g \<odot> mtop \<odot> g\<^sup>t) (di,k)"
           by (simp add: times_matrix_def top_matrix_def)
         also have "... \<le> mone (di,k)"
           using 1 by (metis matrix_stone_relation_algebra.arc_expanded less_eq_matrix_def)
         also have "... = bot"
           apply (unfold one_matrix_def)
           using 10 by auto
         finally have "g (k,l) \<noteq> top"
           using 5 by (metis bot.extremum conv_def inf.bot_unique mult.left_neutral one_def)
         thus "g (k,l) = bot"
           using 2 by (metis uminus_def uminus_matrix_def)
       qed
       have "\<forall>k l . l \<noteq> dj \<longrightarrow> g (k,l) = bot"
       proof (intro allI, rule impI)
         fix k l
         assume 11: "l \<noteq> dj"
         have "(g (k,l))\<^sup>T * top = (g\<^sup>t) (l,k) * top * g (di,dj)"
           using 7 by (simp add: comp_associative conv_matrix_def)
         also have "... \<le> (\<Squnion>\<^sub>n (g\<^sup>t) (l,n) * top) * g (di,dj)"
           by (metis comp_inf.ub_sum comp_right_dist_sum)
         also have "... \<le> (\<Squnion>\<^sub>m (\<Squnion>\<^sub>n (g\<^sup>t) (l,n) * top) * g (m,dj))"
           by (metis comp_inf.ub_sum)
         also have "... = (g\<^sup>t \<odot> mtop \<odot> g) (l,dj)"
           by (simp add: times_matrix_def top_matrix_def)
         also have "... \<le> mone (l,dj)"
           using 1 by (metis matrix_stone_relation_algebra.arc_expanded less_eq_matrix_def)
         also have "... = bot"
           apply (unfold one_matrix_def)
           using 11 by auto
         finally have "g (k,l) \<noteq> top"
           using 5 by (metis bot.extremum comp_right_one conv_def one_def top.extremum_unique)
         thus "g (k,l) = bot"
           using 2 by (metis uminus_def uminus_matrix_def)
       qed
       hence 12: "\<forall>k l . \<not>(k = di \<and> l = dj) \<longrightarrow> (g \<otimes> f) (k,l) = bot"
         using 9 by (metis inf_bot_left inf_matrix_def)
       have "(\<Sum>\<^sub>k \<Sum>\<^sub>l (minarc\<^sub>M f \<otimes> f) (k,l)) = (\<Sum>\<^sub>k \<Sum>\<^sub>l if k = ei \<and> l = ej then (minarc\<^sub>M f \<otimes> f) (k,l) else (minarc\<^sub>M f \<otimes> f) (k,l))"
         by simp
       also have "... = (\<Sum>\<^sub>k \<Sum>\<^sub>l if k = ei \<and> l = ej then (minarc\<^sub>M f \<otimes> f) (k,l) else (minarc\<^sub>M f) (k,l) \<sqinter> f (k,l))"
         by (unfold inf_matrix_def) simp
       also have "... = (\<Sum>\<^sub>k \<Sum>\<^sub>l if k = ei \<and> l = ej then (minarc\<^sub>M f \<otimes> f) (k,l) else bot)"
         apply (rule aggregation.sum_0.cong)
         apply simp
         using 4 by (metis inf_bot_left)
       also have "... = (minarc\<^sub>M f \<otimes> f) (ei,ej) + bot"
         by (unfold agg_delta_2) simp
       also have "... = f (ei,ej) + bot"
         using 3 by (simp add: inf_matrix_def)
       also have "... \<le> (g \<otimes> f) (di,dj) + bot"
         using 3 5 6 7 8 by (metis minarc_matrix_def)
       also have "... = (\<Sum>\<^sub>k \<Sum>\<^sub>l if k = di \<and> l = dj then (g \<otimes> f) (k,l) else bot)"
         by (unfold agg_delta_2) simp
       also have "... = (\<Sum>\<^sub>k \<Sum>\<^sub>l if k = di \<and> l = dj then (g \<otimes> f) (k,l) else (g \<otimes> f) (k,l))"
         apply (rule aggregation.sum_0.cong)
         apply simp
         using 12 by metis
       also have "... = (\<Sum>\<^sub>k \<Sum>\<^sub>l (g \<otimes> f) (k,l))"
         by simp
       finally show "(sum\<^sub>M (minarc\<^sub>M f \<otimes> f)) (i,j) \<le> (sum\<^sub>M (g \<otimes> f)) (i,j)"
         by (simp add: sum_matrix_def)
     qed
   qed
 next
   fix f g :: "('a,'b) square"
   let ?h = "hd enum_class.enum"
   show "sum\<^sub>M f \<preceq> sum\<^sub>M g \<or> sum\<^sub>M g \<preceq> sum\<^sub>M f"
   proof (cases "(sum\<^sub>M f) (?h,?h) \<le> (sum\<^sub>M g) (?h,?h)")
     case 1: True
     have "sum\<^sub>M f \<preceq> sum\<^sub>M g"
       apply (unfold less_eq_matrix_def, rule allI, rule prod_cases)
       using 1 by (unfold sum_matrix_def) auto
     thus ?thesis
       by simp
   next
     case False
     hence 2: "(sum\<^sub>M g) (?h,?h) \<le> (sum\<^sub>M f) (?h,?h)"
       by (simp add: linear)
     have "sum\<^sub>M g \<preceq> sum\<^sub>M f"
       apply (unfold less_eq_matrix_def, rule allI, rule prod_cases)
       using 2 by (unfold sum_matrix_def) auto
     thus ?thesis
       by simp
   qed
 next
   have "finite { f :: ('a,'b) square . (\<forall>e . regular (f e)) }"
     by (unfold regular_bot_top_2, rule finite_set_of_finite_funs_pred) auto
   thus "finite { f :: ('a,'b) square . matrix_p_algebra.regular f }"
     by (unfold uminus_matrix_def) meson
 qed
 
 text \<open>
 We show the same for the alternative implementation that stores the result of aggregation in all elements of the matrix.
 \<close>
 
 interpretation agg_square_m_algebra_2: m_algebra where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix::('a::enum,'b::linear_aggregation_algebra) square" and top = top_matrix and uminus = uminus_matrix and one = one_matrix and times = times_matrix and conv = conv_matrix and plus = plus_matrix and sum = sum_matrix_2 and minarc = minarc_matrix
 proof
   fix f :: "('a,'b) square"
   show "minarc\<^sub>M f \<preceq> \<ominus>\<ominus>f"
     by (simp add: agg_square_m_algebra.minarc_below)
 next
   fix f :: "('a,'b) square"
   let ?at = "bounded_distrib_allegory_signature.arc mone times_matrix less_eq_matrix mtop conv_matrix"
   show "f \<noteq> mbot \<longrightarrow> ?at (minarc\<^sub>M f)"
     by (simp add: agg_square_m_algebra.minarc_arc)
 next
   fix f g :: "('a,'b) square"
   let ?at = "bounded_distrib_allegory_signature.arc mone times_matrix less_eq_matrix mtop conv_matrix"
   show "?at g \<and> g \<otimes> f \<noteq> mbot \<longrightarrow> sum2\<^sub>M (minarc\<^sub>M f \<otimes> f) \<preceq> sum2\<^sub>M (g \<otimes> f)"
   proof
     let ?h = "hd enum_class.enum"
     assume "?at g \<and> g \<otimes> f \<noteq> mbot"
     hence "sum\<^sub>M (minarc\<^sub>M f \<otimes> f) \<preceq> sum\<^sub>M (g \<otimes> f)"
       by (simp add: agg_square_m_algebra.minarc_min)
     hence "(sum\<^sub>M (minarc\<^sub>M f \<otimes> f)) (?h,?h) \<le> (sum\<^sub>M (g \<otimes> f)) (?h,?h)"
       by (simp add: less_eq_matrix_def)
     thus "sum2\<^sub>M (minarc\<^sub>M f \<otimes> f) \<preceq> sum2\<^sub>M (g \<otimes> f)"
       by (simp add: sum_matrix_def sum_matrix_2_def less_eq_matrix_def)
   qed
 next
   fix f g :: "('a,'b) square"
   let ?h = "hd enum_class.enum"
   have "sum\<^sub>M f \<preceq> sum\<^sub>M g \<or> sum\<^sub>M g \<preceq> sum\<^sub>M f"
     by (simp add: agg_square_m_algebra.sum_linear)
   hence "(sum\<^sub>M f) (?h,?h) \<le> (sum\<^sub>M g) (?h,?h) \<or> (sum\<^sub>M g) (?h,?h) \<le> (sum\<^sub>M f) (?h,?h)"
     using less_eq_matrix_def by auto
   thus "sum2\<^sub>M f \<preceq> sum2\<^sub>M g \<or> sum2\<^sub>M g \<preceq> sum2\<^sub>M f"
     by (simp add: sum_matrix_def sum_matrix_2_def less_eq_matrix_def)
 next
   show "finite { f :: ('a,'b) square . matrix_p_algebra.regular f }"
     by (simp add: agg_square_m_algebra.finite_regular)
 qed
 
 text \<open>
 By defining the Kleene star as $\top$ aggregation lattices form a Kleene algebra.
 \<close>
 
 class aggregation_kleene_algebra = aggregation_algebra + star +
   assumes star_def [simp]: "x\<^sup>\<star> = top"
 begin
 
 subclass stone_kleene_relation_algebra
   apply unfold_locales
   by (simp_all add: inf.assoc le_infI2 inf_sup_distrib1 inf_sup_distrib2)
 
 end
 
 class linear_aggregation_kleene_algebra = linear_aggregation_algebra + star +
   assumes star_def_2 [simp]: "x\<^sup>\<star> = top"
 begin
 
 subclass aggregation_kleene_algebra
   apply unfold_locales
   by simp
 
 end
 
 interpretation agg_square_m_kleene_algebra: m_kleene_algebra where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix::('a::enum,'b::linear_aggregation_kleene_algebra) square" and top = top_matrix and uminus = uminus_matrix and one = one_matrix and times = times_matrix and conv = conv_matrix and star = star_matrix and plus = plus_matrix and sum = sum_matrix and minarc = minarc_matrix ..
 
 interpretation agg_square_m_kleene_algebra_2: m_kleene_algebra where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix::('a::enum,'b::linear_aggregation_kleene_algebra) square" and top = top_matrix and uminus = uminus_matrix and one = one_matrix and times = times_matrix and conv = conv_matrix and star = star_matrix and plus = plus_matrix and sum = sum_matrix_2 and minarc = minarc_matrix ..
 
+class linorder_stone_relation_algebra_plus_expansion = linorder_stone_relation_algebra_expansion + plus +
+  assumes plus_def: "plus = sup"
+begin
+
+subclass linear_aggregation_algebra
+  apply unfold_locales
+  using plus_def sup_monoid.add_assoc apply blast
+  using plus_def sup_monoid.add_commute apply blast
+  using comp_inf.semiring.add_mono plus_def apply auto[1]
+  using plus_def apply force
+  using bot_eq_sup_iff plus_def apply blast
+  apply simp
+  apply simp
+  using times_inf apply presburger
+  by simp
+
 end
 
+class linorder_stone_kleene_relation_algebra_plus_expansion = linorder_stone_kleene_relation_algebra_expansion + linorder_stone_relation_algebra_plus_expansion
+begin
+
+subclass linear_aggregation_kleene_algebra
+  apply unfold_locales
+  by simp
+
+end
+
+class linorder_stone_kleene_relation_algebra_tarski_consistent_plus_expansion = linorder_stone_kleene_relation_algebra_tarski_consistent_expansion + linorder_stone_kleene_relation_algebra_plus_expansion
+
+end
+
diff --git a/thys/Aggregation_Algebras/ROOT b/thys/Aggregation_Algebras/ROOT
--- a/thys/Aggregation_Algebras/ROOT
+++ b/thys/Aggregation_Algebras/ROOT
@@ -1,12 +1,13 @@
 chapter AFP
 
 session Aggregation_Algebras = Stone_Kleene_Relation_Algebras +
   options [timeout = 600]
   theories
     Semigroups_Big
     Aggregation_Algebras
     Matrix_Aggregation_Algebras
     Linear_Aggregation_Algebras
+    M_Choose_Component
   document_files
     "root.tex"
     "root.bib"
diff --git a/thys/Aggregation_Algebras/document/root.tex b/thys/Aggregation_Algebras/document/root.tex
--- a/thys/Aggregation_Algebras/document/root.tex
+++ b/thys/Aggregation_Algebras/document/root.tex
@@ -1,53 +1,55 @@
 \documentclass[11pt,a4paper]{article}
 \usepackage[T1]{fontenc}
 \usepackage{isabelle,isabellesym}
 \usepackage{amssymb,ragged2e}
 \usepackage{pdfsetup}
 
 \isabellestyle{it}
 \renewenvironment{isamarkuptext}{\par\isastyletext\begin{isapar}\justifying\color{blue}}{\end{isapar}}
 \renewcommand\labelitemi{$*$}
 
 \begin{document}
 
 \title{Aggregation Algebras}
 \author{Walter Guttmann}
 \maketitle
 
 \begin{abstract}
   We develop algebras for aggregation and minimisation for weight matrices and for edge weights in graphs.
   We show numerous instances of these algebras based on linearly ordered commutative semigroups.
 \end{abstract}
 
 \tableofcontents
 
 \section{Overview}
 
 This document describes the following four theory files:
 \begin{itemize}
 \item Big sums over semigroups generalises parts of Isabelle/HOL's theory of finite summation \texttt{Groups\_Big.thy} from commutative monoids to commutative semigroups with a unit element only on the image of the semigroup operation.
 \item Aggregation Algebras introduces s-algebras, m-algebras and m-Kleene-algebras with operations for aggregating the elements of a weight matrix and finding the edge with minimal weight.
 \item Matrix Aggregation Algebras introduces aggregation orders, aggregation lattices and linear aggregation lattices.
       Matrices over these structures form s-algebras and m-algebras.
 \item Linear Aggregation Algebras shows numerous instances based on linearly ordered commutative semigroups.
       They include aggregations used for the minimum weight spanning tree problem and for the minimum bottleneck spanning tree problem, as well as arbitrary t-norms and t-conorms.
 \end{itemize}
 Three theory files, which were originally part of this entry, have been moved elsewhere:
 \begin{itemize}
 \item A theory for total-correctness proofs in Hoare logic became part of Isabelle/HOL's theory \texttt{Hoare/Hoare\_Logic.thy}.
 \item A theory with simple total-correctness proof examples became Isabelle/HOL's theory \texttt{Hoare/ExamplesTC.thy}.
 \item A theory proving total correctness of Kruskal's and Prim's minimum spanning tree algorithms based on m-Kleene-algebras using Hoare logic was split into two theories that became part of AFP entry \cite{GuttmannRobinsonOBrien2020}.
 \end{itemize}
+Following a refactoring, the selection of components of graphs in m-Kleene-algebras, which was originally part of Nicolas Robinson-O'Brien's theory \texttt{Relational\_Minimum\_Spanning\_Trees/Boruvka.thy}, has been moved into a new theory in this entry.
+
 The development is based on Stone-Kleene relation algebras \cite{Guttmann2017b,Guttmann2017c}.
 The algebras for aggregation and minimisation, their application to weighted graphs and the verification of Prim's and Kruskal's minimum spanning tree algorithms, and various instances of aggregation are described in \cite{Guttmann2016c,Guttmann2018a,Guttmann2018b}.
 Related work is discussed in these papers.
 
 \begin{flushleft}
 \input{session}
 \end{flushleft}
 
 \bibliographystyle{abbrv}
 \bibliography{root}
 
 \end{document}
 
diff --git a/thys/Relational_Disjoint_Set_Forests/Matrix_Peano_Algebras.thy b/thys/Relational_Disjoint_Set_Forests/Matrix_Peano_Algebras.thy
new file mode 100644
--- /dev/null
+++ b/thys/Relational_Disjoint_Set_Forests/Matrix_Peano_Algebras.thy
@@ -0,0 +1,498 @@
+(* Title:      Matrix Peano Algebras
+   Author:     Walter Guttmann
+   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
+*)
+
+section \<open>Matrix Peano Algebras\<close>
+
+text \<open>
+We define a Boolean matrix representation of natural numbers up to \<open>n\<close>, where \<open>n\<close> the size of an enumeration type \<open>'a::enum\<close>.
+Numbers (obtained by \<open>Z_matrix\<close> for \<open>0\<close> and \<open>N_matrix n\<close> for \<open>n\<close>) are represented as relational vectors.
+The total successor function (\<open>S_matrix\<close>, modulo \<open>n\<close>) and the partial successor function (\<open>S'_matrix\<close>, for numbers up to \<open>n-1\<close>) are relations that are (partial) functions.
+
+We show that this representation satisfies the Peano axioms.
+We also implement a function \<open>CP_matrix\<close> that chooses a number in a non-empty set.
+\<close>
+
+theory Matrix_Peano_Algebras
+
+imports Aggregation_Algebras.M_Choose_Component Relational_Disjoint_Set_Forests.More_Disjoint_Set_Forests
+
+begin
+
+definition Z_matrix :: "('a::enum,'b::{bot,top}) square" ("mZero") where "mZero = (\<lambda>(i,j) . if i = hd enum_class.enum then top else bot)"
+definition S_matrix :: "('a::enum,'b::{bot,top}) square" ("msuccmod") where "msuccmod = (\<lambda>(i,j) . let e = (enum_class.enum :: 'a list) in if (\<exists>k . Suc k<length e \<and> i = e ! k \<and> j = e ! Suc k) \<or> (i = e ! minus_class.minus (length e) 1 \<and> j = hd e) then top else bot)"
+definition S'_matrix :: "('a::enum,'b::{bot,top}) square" ("msucc") where "msucc = (\<lambda>(i,j) . let e = (enum_class.enum :: 'a list) in if \<exists>k . Suc k<length e \<and> i = e ! k \<and> j = e ! Suc k then top else bot)"
+definition N_matrix :: "nat \<Rightarrow> ('a::enum,'b::{bot,top}) square" ("mnat") where "mnat n = (\<lambda>(i,j) . if i = enum_class.enum ! n then top else bot)"
+definition CP_matrix  :: "('a::enum,'b::{bot,uminus}) square \<Rightarrow> ('a,'b) square" ("mcp") where "mcp f = (\<lambda>(i,j) . if Some i = find (\<lambda>x . f (x,x) \<noteq> bot) enum_class.enum then uminus_class.uminus (uminus_class.uminus (f (i,j))) else bot)"
+
+lemma N_matrix_power_S:
+  "n < length (enum_class.enum :: 'a list) \<longrightarrow> mnat n = (matrix_monoid.power (msuccmod\<^sup>t) n) \<odot> (mZero :: ('a::enum,'b::stone_relation_algebra) square)"
+proof (induct n)
+  let ?z = "mZero :: ('a,'b) square"
+  let ?s = "msuccmod :: ('a,'b) square"
+  let ?e = "enum_class.enum :: 'a list"
+  let ?h = "hd ?e"
+  let ?l = "length ?e"
+  let ?g = "?e ! minus_class.minus ?l 1"
+  let ?p = "matrix_monoid.power (?s\<^sup>t)"
+  case 0
+  have "(UNIV :: 'a set) \<noteq> {}"
+    by simp
+  hence "?h = ?e ! 0"
+    by (simp add: hd_conv_nth UNIV_enum)
+  thus ?case
+    by (simp add: N_matrix_def Z_matrix_def)
+  case (Suc n)
+  assume 1: "n < ?l \<longrightarrow> mnat n = ?p n \<odot> ?z"
+  show "Suc n < ?l \<longrightarrow> mnat (Suc n) = ?p (Suc n) \<odot> ?z"
+  proof
+    assume 2: "Suc n < ?l"
+    hence "n < ?l"
+      by simp
+    hence "\<forall>l<?l . (?e ! l = ?e ! n \<longrightarrow> l = n)"
+      using nth_eq_iff_index_eq enum_distinct by auto
+    hence 3: "\<And>i . (\<exists>l<?l . ?e ! n = ?e ! l \<and> i = ?e ! Suc l) \<longrightarrow> (i = ?e ! Suc n)"
+      by auto
+    have 4: "\<And>i . (\<exists>l . Suc l<?l \<and> ?e ! n = ?e ! l \<and> i = ?e ! Suc l) \<longleftrightarrow> (i = ?e ! Suc n)"
+      apply (rule iffI)
+      using 3 apply (metis Suc_lessD)
+      using 2 by auto
+    show "mnat (Suc n) = ?p (Suc n) \<odot> ?z"
+    proof (rule ext, rule prod_cases)
+      fix i j :: 'a
+      have "(?p (Suc n) \<odot> ?z) (i,j) = (?s\<^sup>t \<odot> mnat n) (i,j)"
+        using 1 2 by (simp add: matrix_monoid.mult_assoc)
+      also have "... = (\<Squnion>\<^sub>k ((?s (k,i))\<^sup>T * mnat n (k,j)))"
+        by (simp add: times_matrix_def conv_matrix_def)
+      also have "... = (\<Squnion>\<^sub>k ((if (\<exists>l . Suc l<length ?e \<and> k = ?e ! l \<and> i = ?e ! Suc l) \<or> (k = ?g \<and> i = ?h) then top else bot)\<^sup>T * (if k = ?e ! n then top else bot)))"
+        by (simp add: S_matrix_def N_matrix_def)
+      also have "... = (\<Squnion>\<^sub>k ((if (\<exists>l . Suc l<length ?e \<and> k = ?e ! l \<and> i = ?e ! Suc l) \<or> (k = ?g \<and> i = ?h) then top else bot) * (if k = ?e ! n then top else bot)))"
+        by (smt (verit, best) sup_monoid.sum.cong symmetric_bot_closed symmetric_top_closed)
+      also have "... = (\<Squnion>\<^sub>k (if (\<exists>l . Suc l<length ?e \<and> k = ?e ! l \<and> i = ?e ! Suc l \<and> k = ?e ! n) \<or> (k = ?g \<and> i = ?h \<and> k = ?e ! n) then top else bot))"
+        by (smt (verit, best) covector_bot_closed idempotent_bot_closed sup_monoid.sum.cong surjective_top_closed vector_bot_closed)
+      also have "... = (if \<exists>l . Suc l<length ?e \<and> ?e ! n = ?e ! l \<and> i = ?e ! Suc l then top else bot)"
+      proof -
+        have "\<And>k . \<not>(k = ?g \<and> i = ?h \<and> k = ?e ! n)"
+          using 2 distinct_conv_nth[of ?e] enum_distinct by auto
+        thus ?thesis
+          by (smt (verit, del_insts) comp_inf.ub_sum sup.order_iff sup_monoid.sum.neutral sup_top_right)
+      qed
+      also have "... = (if i = ?e ! Suc n then top else bot)"
+        using 4 by simp
+      also have "... = mnat (Suc n) (i,j)"
+        by (simp add: N_matrix_def)
+      finally show "mnat (Suc n) (i,j) = (?p (Suc n) \<odot> ?z) (i,j)"
+        by simp
+    qed
+  qed
+qed
+
+lemma N_matrix_power_S':
+  "n < length (enum_class.enum :: 'a list) \<longrightarrow> mnat n = (matrix_monoid.power (msucc\<^sup>t) n) \<odot> (mZero :: ('a::enum,'b::stone_relation_algebra) square)"
+proof (induct n)
+  let ?z = "mZero :: ('a,'b) square"
+  let ?s = "msucc :: ('a,'b) square"
+  let ?e = "enum_class.enum :: 'a list"
+  let ?h = "hd ?e"
+  let ?l = "length ?e"
+  let ?p = "matrix_monoid.power (?s\<^sup>t)"
+  case 0
+  have "(UNIV :: 'a set) \<noteq> {}"
+    by simp
+  hence "?h = ?e ! 0"
+    by (simp add: hd_conv_nth UNIV_enum)
+  thus ?case
+    by (simp add: N_matrix_def Z_matrix_def)
+  case (Suc n)
+  assume 1: "n < ?l \<longrightarrow> mnat n = ?p n \<odot> ?z"
+  show "Suc n < ?l \<longrightarrow> mnat (Suc n) = ?p (Suc n) \<odot> ?z"
+  proof
+    assume 2: "Suc n < ?l"
+    hence "n < ?l"
+      by simp
+    hence "\<forall>l<?l . (?e ! l = ?e ! n \<longrightarrow> l = n)"
+      using nth_eq_iff_index_eq enum_distinct by auto
+    hence 3: "\<And>i . (\<exists>l<?l . ?e ! n = ?e ! l \<and> i = ?e ! Suc l) \<longrightarrow> (i = ?e ! Suc n)"
+      by auto
+    have 4: "\<And>i . (\<exists>l . Suc l<?l \<and> ?e ! n = ?e ! l \<and> i = ?e ! Suc l) \<longleftrightarrow> (i = ?e ! Suc n)"
+      apply (rule iffI)
+      using 3 apply (metis Suc_lessD)
+      using 2 by auto
+    show "mnat (Suc n) = ?p (Suc n) \<odot> ?z"
+    proof (rule ext, rule prod_cases)
+      fix i j :: 'a
+      have "(?p (Suc n) \<odot> ?z) (i,j) = (?s\<^sup>t \<odot> mnat n) (i,j)"
+        using 1 2 by (simp add: matrix_monoid.mult_assoc)
+      also have "... = (\<Squnion>\<^sub>k ((?s (k,i))\<^sup>T * mnat n (k,j)))"
+        by (simp add: times_matrix_def conv_matrix_def)
+      also have "... = (\<Squnion>\<^sub>k ((if \<exists>l . Suc l<length ?e \<and> k = ?e ! l \<and> i = ?e ! Suc l then top else bot)\<^sup>T * (if k = ?e ! n then top else bot)))"
+        by (simp add: S'_matrix_def N_matrix_def)
+      also have "... = (\<Squnion>\<^sub>k ((if \<exists>l . Suc l<length ?e \<and> k = ?e ! l \<and> i = ?e ! Suc l then top else bot) * (if k = ?e ! n then top else bot)))"
+        by (smt (verit, best) sup_monoid.sum.cong symmetric_bot_closed symmetric_top_closed)
+      also have "... = (\<Squnion>\<^sub>k (if \<exists>l . Suc l<length ?e \<and> k = ?e ! l \<and> i = ?e ! Suc l \<and> k = ?e ! n then top else bot))"
+        by (smt (verit, best) covector_bot_closed idempotent_bot_closed sup_monoid.sum.cong surjective_top_closed vector_bot_closed)
+      also have "... = (if \<exists>l . Suc l<length ?e \<and> ?e ! n = ?e ! l \<and> i = ?e ! Suc l then top else bot)"
+        by (smt (verit, del_insts) comp_inf.ub_sum sup.order_iff sup_monoid.sum.neutral sup_top_right)
+      also have "... = (if i = ?e ! Suc n then top else bot)"
+        using 4 by simp
+      also have "... = mnat (Suc n) (i,j)"
+        by (simp add: N_matrix_def)
+      finally show "mnat (Suc n) (i,j) = (?p (Suc n) \<odot> ?z) (i,j)"
+        by simp
+    qed
+  qed
+qed
+
+syntax
+  "_sum_sup_monoid" :: "idt \<Rightarrow> nat \<Rightarrow> 'a::bounded_semilattice_sup_bot \<Rightarrow> 'a" ("(\<Squnion>_<_ . _)" [0,51,10] 10)
+translations
+  "\<Squnion>x<y . t" => "XCONST sup_monoid.sum (\<lambda>x . t) { x . x < y }"
+
+context bounded_semilattice_sup_bot
+begin
+
+lemma ub_sum_nat:
+  fixes f :: "nat \<Rightarrow> 'a"
+  assumes "i < l"
+    shows "f i \<le> (\<Squnion>k<l . f k)"
+  by (metis (no_types, lifting) assms finite_Collect_less_nat sup_ge1 sup_monoid.sum.remove mem_Collect_eq)
+
+lemma lub_sum_nat:
+  fixes f :: "nat \<Rightarrow> 'a"
+  assumes "\<forall>k<l . f k \<le> x"
+    shows "(\<Squnion>k<l . f k) \<le> x"
+  apply (rule finite_subset_induct[where A="{k . k < l}"])
+  by (simp_all add: assms)
+
+end
+
+lemma ext_sum_nat:
+  fixes l :: nat
+  shows "(\<Squnion>k<l . f k x) = (\<Squnion>k<l . f k) x"
+  apply (rule finite_subset_induct[where A="{k . k < l}"])
+  apply simp
+  apply simp
+  apply (metis (no_types, lifting) bot_apply sup_monoid.sum.empty)
+  by (metis (mono_tags, lifting) sup_apply sup_monoid.sum.insert)
+
+interpretation matrix_skra_peano_1: skra_peano_1 where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a::enum,'b::linorder_stone_kleene_relation_algebra_tarski_consistent_expansion) square" and top = top_matrix and uminus = uminus_matrix and one = one_matrix and times = times_matrix and conv = conv_matrix and star = star_matrix and Z = Z_matrix and S = S_matrix
+proof
+  let ?z = "mZero :: ('a,'b) square"
+  let ?s = "msuccmod :: ('a,'b) square"
+  let ?e = "enum_class.enum :: 'a list"
+  let ?h = "hd ?e"
+  let ?l = "length ?e"
+  let ?g = "?e ! minus_class.minus ?l 1"
+  let ?p = "matrix_monoid.power (?s\<^sup>t)"
+  have 1: "?z \<odot> mtop = ?z"
+  proof (rule ext, rule prod_cases)
+    fix i j :: 'a
+    have "(?z \<odot> mtop) (i,j) = (\<Squnion>\<^sub>k (?z (i,k) * top))"
+      by (simp add: times_matrix_def top_matrix_def)
+    also have "... = (\<Squnion>\<^sub>k::'a (if i = ?h then top else bot) * top)"
+      by (simp add: Z_matrix_def)
+    also have "... = (if i = ?h then top else bot) * (top :: 'b)"
+      using sum_const by blast
+    also have "... = ?z (i,j)"
+      by (simp add: Z_matrix_def)
+    finally show "(?z \<odot> mtop) (i,j) = ?z (i,j)"
+      .
+  qed
+  have 2: "?z \<odot> ?z\<^sup>t \<preceq> mone"
+  proof (unfold less_eq_matrix_def, rule allI, rule prod_cases)
+    fix i j :: 'a
+    have "(?z \<odot> ?z\<^sup>t) (i,j) = (\<Squnion>\<^sub>k (?z (i,k) * (?z (j,k))\<^sup>T))"
+      by (simp add: times_matrix_def conv_matrix_def)
+    also have "... = (\<Squnion>\<^sub>k::'a (if i = ?h then top else bot) * (if j = ?h then top else bot))"
+      by (simp add: Z_matrix_def)
+    also have "... = (if i = ?h then top else bot) * (if j = ?h then top else bot)"
+      using sum_const by blast
+    also have "... \<le> mone (i,j)"
+      by (simp add: one_matrix_def)
+    finally show "(?z \<odot> ?z\<^sup>t) (i,j) \<le> mone (i,j)"
+      .
+  qed
+  have 3: "mtop \<odot> ?z = mtop"
+  proof (rule ext, rule prod_cases)
+    fix i j :: 'a
+    have "mtop (i,j) = (top::'b) * (if ?h = ?h then top else bot)"
+      by (simp add: top_matrix_def)
+    also have "... \<le> (\<Squnion>\<^sub>k::'a (top * (if k = ?h then top else bot)))"
+      by (rule ub_sum)
+    also have "... = (\<Squnion>\<^sub>k (top * ?z (k,j)))"
+      by (simp add: Z_matrix_def)
+    also have "... = (mtop \<odot> ?z) (i,j)"
+      by (simp add: times_matrix_def top_matrix_def)
+    finally show "(mtop \<odot> ?z) (i,j) = mtop (i,j)"
+      by (simp add: inf.le_bot top_matrix_def)
+  qed
+  show "matrix_stone_relation_algebra.point ?z"
+    using 1 2 3 by simp
+  have "\<forall>i (j::'a) (k::'a) . (\<exists>l<?l . \<exists>m<?l . k = ?e ! l \<and> i = ?e ! Suc l \<and> k = ?e ! m \<and> j = ?e ! Suc m) \<longrightarrow> i = j"
+    using distinct_conv_nth enum_distinct by auto
+  hence 4: "\<forall>i (j::'a) (k::'a) . (\<exists>l m . Suc l<?l \<and> Suc m<?l \<and> k = ?e ! l \<and> i = ?e ! Suc l \<and> k = ?e ! m \<and> j = ?e ! Suc m) \<longrightarrow> i = j"
+    by (metis Suc_lessD)
+  show "?s\<^sup>t \<odot> ?s \<preceq> mone"
+  proof (unfold less_eq_matrix_def, rule allI, rule prod_cases)
+    fix i j :: 'a
+    have "(?s\<^sup>t \<odot> ?s) (i,j) = (\<Squnion>\<^sub>k (?s (k,i) * ?s (k,j)))"
+      by (simp add: times_matrix_def conv_matrix_def)
+    also have "... = (\<Squnion>\<^sub>k::'a ((if (\<exists>l . Suc l<?l \<and> k = ?e ! l \<and> i = ?e ! Suc l) \<or> (k = ?g \<and> i = ?h) then top else bot) * (if (\<exists>m . Suc m<?l \<and> k = ?e ! m \<and> j = ?e ! Suc m) \<or> (k = ?g \<and> j = ?h) then top else bot)))"
+      by (simp add: S_matrix_def)
+    also have "... = (\<Squnion>\<^sub>k::'a (if (\<exists>l m . Suc l<?l \<and> Suc m<?l \<and> k = ?e ! l \<and> i = ?e ! Suc l \<and> k = ?e ! m \<and> j = ?e ! Suc m) \<or> (k = ?g \<and> i = ?h \<and> j = ?h) then top else bot))"
+    proof -
+      have 5: "\<And>k . \<not>((\<exists>l . Suc l<?l \<and> k = ?e ! l \<and> i = ?e ! Suc l) \<and> (k = ?g \<and> j = ?h))"
+        using distinct_conv_nth[of ?e] enum_distinct by auto
+      have "\<And>k . \<not>((k = ?g \<and> i = ?h) \<and> (\<exists>m . Suc m<?l \<and> k = ?e ! m \<and> j = ?e ! Suc m))"
+        using distinct_conv_nth[of ?e] enum_distinct by auto
+      thus ?thesis
+        using 5 by (smt (verit) covector_bot_closed idempotent_bot_closed sup_monoid.sum.cong surjective_top_closed vector_bot_closed)
+    qed
+    also have "... \<le> (\<Squnion>\<^sub>k::'a (if i = j then top else bot))"
+      using 4 by (smt (verit, best) comp_inf.ub_sum order_top_class.top_greatest sup_monoid.sum.not_neutral_contains_not_neutral top.extremum_uniqueI)
+    also have "... \<le> (if i = j then top else bot)"
+      by (simp add: sum_const)
+    also have "... = mone (i,j)"
+      by (simp add: one_matrix_def)
+    finally show "(?s\<^sup>t \<odot> ?s) (i,j) \<le> mone (i,j)"
+      .
+  qed
+  have 6: "\<forall>i (j::'a) (k::'a) . (\<exists>l m . Suc l<?l \<and> Suc m<?l \<and> i = ?e ! l \<and> k = ?e ! Suc l \<and> j = ?e ! m \<and> k = ?e ! Suc m) \<longrightarrow> i = j"
+    using distinct_conv_nth enum_distinct by auto
+  show "?s \<odot> ?s\<^sup>t \<preceq> mone"
+  proof (unfold less_eq_matrix_def, rule allI, rule prod_cases)
+    fix i j :: 'a
+    have "(?s \<odot> ?s\<^sup>t) (i,j) = (\<Squnion>\<^sub>k (?s (i,k) * ?s (j,k)))"
+      by (simp add: times_matrix_def conv_matrix_def)
+    also have "... = (\<Squnion>\<^sub>k::'a ((if (\<exists>l . Suc l<?l \<and> i = ?e ! l \<and> k = ?e ! Suc l) \<or> (i = ?g \<and> k = ?h) then top else bot) * (if (\<exists>m . Suc m<?l \<and> j = ?e ! m \<and> k = ?e ! Suc m) \<or> (j = ?g \<and> k = ?h) then top else bot)))"
+      by (simp add: S_matrix_def)
+    also have "... = (\<Squnion>\<^sub>k::'a (if (\<exists>l m . Suc l<?l \<and> Suc m<?l \<and> i = ?e ! l \<and> k = ?e ! Suc l \<and> j = ?e ! m \<and> k = ?e ! Suc m) \<or> (i = ?g \<and> k = ?h \<and> j = ?g) then top else bot))"
+    proof -
+      have 7: "\<And>l . Suc l<?l \<longrightarrow> 0<?l"
+        by auto
+      have 8: "?h = ?e ! 0"
+      proof (rule hd_conv_nth, rule)
+        assume "?e = []"
+        hence "(UNIV::'a set) = {}"
+          by (auto simp add: UNIV_enum)
+        thus "False"
+          by simp
+      qed
+      have 9: "\<And>k . \<not>((\<exists>l . Suc l<?l \<and> i = ?e ! l \<and> k = ?e ! Suc l) \<and> (j = ?g \<and> k = ?h))"
+        using 7 8 distinct_conv_nth[of ?e] enum_distinct by auto
+      have "\<And>k . \<not>((i = ?g \<and> k = ?h) \<and> (\<exists>m . Suc m<?l \<and> j = ?e ! m \<and> k = ?e ! Suc m))"
+        using 7 8 distinct_conv_nth[of ?e] enum_distinct by auto
+      thus ?thesis
+        using 9 by (smt (verit) covector_bot_closed idempotent_bot_closed sup_monoid.sum.cong surjective_top_closed vector_bot_closed)
+    qed
+    also have "... \<le> (\<Squnion>\<^sub>k::'a (if i = j then top else bot))"
+      using 6 by (smt (verit, best) comp_inf.ub_sum order_top_class.top_greatest sup_monoid.sum.not_neutral_contains_not_neutral top.extremum_uniqueI)
+    also have "... \<le> (if i = j then top else bot)"
+      by simp
+    also have "... = mone (i,j)"
+      by (simp add: one_matrix_def)
+    finally show "(?s \<odot> ?s\<^sup>t) (i,j) \<le> mone (i,j)"
+      .
+  qed
+  have "(mtop :: ('a,'b) square) = (\<Squnion>k<?l . mnat k)"
+  proof (rule ext, rule prod_cases)
+    fix i j :: 'a
+    have "mtop (i,j) = (top :: 'b)"
+      by (simp add: top_matrix_def)
+    also have "... = (\<Squnion>k<?l . (if i = ?e ! k then top else bot))"
+    proof -
+      have "i \<in> set ?e"
+        using UNIV_enum by auto
+      from this obtain k where 6: "k < ?l \<and> i = ?e ! k"
+        by (metis in_set_conv_nth)
+      hence "(\<lambda>k . if i = ?e ! k then top else bot) k \<le> (\<Squnion>k<?l . (if i = ?e ! k then top else bot :: 'b))"
+        by (metis ub_sum_nat)
+      hence "top \<le> (\<Squnion>k<?l . (if i = ?e ! k then top else bot :: 'b))"
+        using 6 by simp
+      thus ?thesis
+        using top.extremum_uniqueI by force
+    qed
+    also have "... = (\<Squnion>k<?l . mnat k (i,j))"
+      by (simp add: N_matrix_def)
+    also have "... = (\<Squnion>k<?l . mnat k) (i,j)"
+      by (simp add: ext_sum_nat)
+    finally show "(mtop (i,j) :: 'b) = (\<Squnion>k<?l . mnat k) (i,j)"
+      .
+  qed
+  also have "... = (\<Squnion>k<?l . ?p k \<odot> ?z)"
+  proof -
+    have "\<And>k . k<?l \<longrightarrow> mnat k = ?p k \<odot> ?z"
+      using N_matrix_power_S by auto
+    thus ?thesis
+      by (metis (no_types, lifting) mem_Collect_eq sup_monoid.sum.cong)
+  qed
+  also have "... \<preceq> ?s\<^sup>t\<^sup>\<odot> \<odot> ?z"
+  proof (unfold less_eq_matrix_def, rule allI, rule prod_cases)
+    fix i j :: 'a
+    have "(\<Squnion>k<?l . ?p k \<odot> ?z) (i,j) = (\<Squnion>k<?l . (?p k \<odot> ?z) (i,j))"
+      by (metis ext_sum_nat)
+    also have "... \<le> (?s\<^sup>t\<^sup>\<odot> \<odot> ?z) (i,j)"
+      apply (rule lub_sum_nat)
+      by (metis less_eq_matrix_def matrix_idempotent_semiring.mult_left_isotone matrix_kleene_algebra.star.power_below_circ)
+    finally show "(\<Squnion>k<?l . ?p k \<odot> ?z) (i,j) \<le> (?s\<^sup>t\<^sup>\<odot> \<odot> ?z) (i,j)"
+      .
+  qed
+  finally show "?s\<^sup>t\<^sup>\<odot> \<odot> ?z = mtop"
+    by (simp add: matrix_order.antisym_conv)
+qed
+
+interpretation matrix_skra_peano_2: skra_peano_2 where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a::enum,'b::linorder_stone_kleene_relation_algebra_tarski_consistent_expansion) square" and top = top_matrix and uminus = uminus_matrix and one = one_matrix and times = times_matrix and conv = conv_matrix and star = star_matrix and Z = Z_matrix and S = S_matrix
+proof
+  let ?s = "msuccmod :: ('a,'b) square"
+  let ?e = "enum_class.enum :: 'a list"
+  let ?h = "hd ?e"
+  let ?l = "length ?e"
+  let ?g = "?e ! minus_class.minus ?l 1"
+  show "matrix_bounded_idempotent_semiring.total ?s"
+  proof (rule ext, rule prod_cases)
+    fix i j :: 'a
+    have "(?s \<odot> mtop) (i,j) = (\<Squnion>\<^sub>k (?s (i,k) * top))"
+      by (simp add: times_matrix_def top_matrix_def)
+    also have "... = (\<Squnion>\<^sub>k::'a if (\<exists>l . Suc l<?l \<and> i = ?e ! l \<and> k = ?e ! Suc l) \<or> (i = ?g \<and> k = ?h) then top else bot)"
+      by (simp add: S_matrix_def)
+    also have "... = top"
+    proof -
+      have "\<And>i . (\<exists>l . Suc l<?l \<and> i = ?e ! l) \<or> i = ?g"
+        by (metis in_set_conv_nth in_enum Suc_lessI diff_Suc_1)
+      hence "\<And>i . \<exists>k . (\<exists>l . Suc l<?l \<and> i = ?e ! l \<and> k = ?e ! Suc l) \<or> (i = ?g \<and> k = ?h)"
+        by blast
+      thus ?thesis
+        by (smt (verit, ccfv_threshold) comp_inf.ub_sum top.extremum_uniqueI)
+    qed
+    finally show "(?s \<odot> mtop) (i,j) = mtop (i,j)"
+      by (simp add: top_matrix_def)
+  qed
+qed
+
+interpretation matrix_skra_peano_3: skra_peano_3 where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a::enum,'b::linorder_stone_kleene_relation_algebra_tarski_consistent_expansion) square" and top = top_matrix and uminus = uminus_matrix and one = one_matrix and times = times_matrix and conv = conv_matrix and star = star_matrix and Z = Z_matrix and S = S_matrix
+proof (unfold_locales, rule finite_surj)
+  show "finite (UNIV :: 'a rel set)"
+    by simp
+  let ?f = "\<lambda>R p . if p \<in> R then top else bot"
+  show "{ f :: ('a,'b) square . matrix_p_algebra.regular f } \<subseteq> range ?f"
+  proof
+    fix f :: "('a,'b) square"
+    let ?R = "{ (x,y) . f (x,y) = top }"
+    assume "f \<in> { f . matrix_p_algebra.regular f }"
+    hence "matrix_p_algebra.regular f"
+      by simp
+    hence "\<And>p . f p \<noteq> top \<longrightarrow> f p = bot"
+      by (metis linorder_stone_algebra_expansion_class.uminus_def uminus_matrix_def)
+    hence "f = ?f ?R"
+      by fastforce
+    thus "f \<in> range ?f"
+      by blast
+  qed
+qed
+
+interpretation matrix_skra_peano_4: skra_peano_4 where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a::enum,'b::linorder_stone_kleene_relation_algebra_tarski_consistent_plus_expansion) square" and top = top_matrix and uminus = uminus_matrix and one = one_matrix and times = times_matrix and conv = conv_matrix and star = star_matrix and Z = Z_matrix and S = S_matrix and choose_point = agg_square_m_kleene_algebra_2.m_choose_component_algebra_tarski.choose_component_point
+  apply unfold_locales
+  apply (simp add: agg_square_m_kleene_algebra_2.m_choose_component_algebra_tarski.choose_component_point_point)
+  by (simp add: agg_square_m_kleene_algebra_2.m_choose_component_algebra_tarski.choose_component_point_decreasing)
+
+interpretation matrix'_skra_peano_1: skra_peano_1 where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a::enum,'b::linorder_stone_kleene_relation_algebra_tarski_consistent_expansion) square" and top = top_matrix and uminus = uminus_matrix and one = one_matrix and times = times_matrix and conv = conv_matrix and star = star_matrix and Z = Z_matrix and S = S'_matrix
+proof
+  let ?z = "mZero :: ('a,'b) square"
+  let ?s = "msucc :: ('a,'b) square"
+  let ?e = "enum_class.enum :: 'a list"
+  let ?l = "length ?e"
+  let ?p = "matrix_monoid.power (?s\<^sup>t)"
+  show "matrix_stone_relation_algebra.point ?z"
+    using matrix_skra_peano_1.Z_point by auto
+  have "\<forall>i (j::'a) (k::'a) . (\<exists>l<?l . \<exists>m<?l . k = ?e ! l \<and> i = ?e ! Suc l \<and> k = ?e ! m \<and> j = ?e ! Suc m) \<longrightarrow> i = j"
+    using distinct_conv_nth enum_distinct by auto
+  hence 4: "\<forall>i (j::'a) (k::'a) . (\<exists>l m . Suc l<?l \<and> Suc m<?l \<and> k = ?e ! l \<and> i = ?e ! Suc l \<and> k = ?e ! m \<and> j = ?e ! Suc m) \<longrightarrow> i = j"
+    by (metis Suc_lessD)
+  show "?s\<^sup>t \<odot> ?s \<preceq> mone"
+  proof (unfold less_eq_matrix_def, rule allI, rule prod_cases)
+    fix i j :: 'a
+    have "(?s\<^sup>t \<odot> ?s) (i,j) = (\<Squnion>\<^sub>k (?s (k,i) * ?s (k,j)))"
+      by (simp add: times_matrix_def conv_matrix_def)
+    also have "... = (\<Squnion>\<^sub>k::'a ((if \<exists>l . Suc l<?l \<and> k = ?e ! l \<and> i = ?e ! Suc l then top else bot) * (if \<exists>m . Suc m<?l \<and> k = ?e ! m \<and> j = ?e ! Suc m then top else bot)))"
+      by (simp add: S'_matrix_def)
+    also have "... = (\<Squnion>\<^sub>k::'a (if (\<exists>l m . Suc l<?l \<and> Suc m<?l \<and> k = ?e ! l \<and> i = ?e ! Suc l \<and> k = ?e ! m \<and> j = ?e ! Suc m) then top else bot))"
+      by (smt (verit) covector_bot_closed idempotent_bot_closed sup_monoid.sum.cong surjective_top_closed vector_bot_closed)
+    also have "... \<le> (\<Squnion>\<^sub>k::'a (if i = j then top else bot))"
+      using 4 by (smt (verit, best) comp_inf.ub_sum order_top_class.top_greatest sup_monoid.sum.not_neutral_contains_not_neutral top.extremum_uniqueI)
+    also have "... \<le> (if i = j then top else bot)"
+      by (simp add: sum_const)
+    also have "... = mone (i,j)"
+      by (simp add: one_matrix_def)
+    finally show "(?s\<^sup>t \<odot> ?s) (i,j) \<le> mone (i,j)"
+      .
+  qed
+  have 5: "\<forall>i (j::'a) (k::'a) . (\<exists>l m . Suc l<?l \<and> Suc m<?l \<and> i = ?e ! l \<and> k = ?e ! Suc l \<and> j = ?e ! m \<and> k = ?e ! Suc m) \<longrightarrow> i = j"
+    using distinct_conv_nth enum_distinct by auto
+  show "?s \<odot> ?s\<^sup>t \<preceq> mone"
+  proof (unfold less_eq_matrix_def, rule allI, rule prod_cases)
+    fix i j :: 'a
+    have "(?s \<odot> ?s\<^sup>t) (i,j) = (\<Squnion>\<^sub>k (?s (i,k) * ?s (j,k)))"
+      by (simp add: times_matrix_def conv_matrix_def)
+    also have "... = (\<Squnion>\<^sub>k::'a ((if \<exists>l . Suc l<?l \<and> i = ?e ! l \<and> k = ?e ! Suc l then top else bot) * (if \<exists>m . Suc m<?l \<and> j = ?e ! m \<and> k = ?e ! Suc m then top else bot)))"
+      by (simp add: S'_matrix_def)
+    also have "... = (\<Squnion>\<^sub>k::'a (if (\<exists>l m . Suc l<?l \<and> Suc m<?l \<and> i = ?e ! l \<and> k = ?e ! Suc l \<and> j = ?e ! m \<and> k = ?e ! Suc m) then top else bot))"
+      by (smt (verit) covector_bot_closed idempotent_bot_closed sup_monoid.sum.cong surjective_top_closed vector_bot_closed)
+    also have "... \<le> (\<Squnion>\<^sub>k::'a (if i = j then top else bot))"
+      using 5 by (smt (verit, best) comp_inf.ub_sum order_top_class.top_greatest sup_monoid.sum.not_neutral_contains_not_neutral top.extremum_uniqueI)
+    also have "... \<le> (if i = j then top else bot)"
+      by simp
+    also have "... = mone (i,j)"
+      by (simp add: one_matrix_def)
+    finally show "(?s \<odot> ?s\<^sup>t) (i,j) \<le> mone (i,j)"
+      .
+  qed
+  have "(mtop :: ('a,'b) square) = (\<Squnion>k<?l . mnat k)"
+  proof (rule ext, rule prod_cases)
+    fix i j :: 'a
+    have "mtop (i,j) = (top :: 'b)"
+      by (simp add: top_matrix_def)
+    also have "... = (\<Squnion>k<?l . (if i = ?e ! k then top else bot))"
+    proof -
+      have "i \<in> set ?e"
+        using UNIV_enum by auto
+      from this obtain k where 6: "k < ?l \<and> i = ?e ! k"
+        by (metis in_set_conv_nth)
+      hence "(\<lambda>k . if i = ?e ! k then top else bot) k \<le> (\<Squnion>k<?l . (if i = ?e ! k then top else bot :: 'b))"
+        by (metis ub_sum_nat)
+      hence "top \<le> (\<Squnion>k<?l . (if i = ?e ! k then top else bot :: 'b))"
+        using 6 by simp
+      thus ?thesis
+        using top.extremum_uniqueI by force
+    qed
+    also have "... = (\<Squnion>k<?l . mnat k (i,j))"
+      by (simp add: N_matrix_def)
+    also have "... = (\<Squnion>k<?l . mnat k) (i,j)"
+      by (simp add: ext_sum_nat)
+    finally show "(mtop (i,j) :: 'b) = (\<Squnion>k<?l . mnat k) (i,j)"
+      .
+  qed
+  also have "... = (\<Squnion>k<?l . ?p k \<odot> ?z)"
+  proof -
+    have "\<And>k . k<?l \<longrightarrow> mnat k = ?p k \<odot> ?z"
+      using N_matrix_power_S' by auto
+    thus ?thesis
+      by (metis (no_types, lifting) mem_Collect_eq sup_monoid.sum.cong)
+  qed
+  also have "... \<preceq> ?s\<^sup>t\<^sup>\<odot> \<odot> ?z"
+  proof (unfold less_eq_matrix_def, rule allI, rule prod_cases)
+    fix i j :: 'a
+    have "(\<Squnion>k<?l . ?p k \<odot> ?z) (i,j) = (\<Squnion>k<?l . (?p k \<odot> ?z) (i,j))"
+      by (metis ext_sum_nat)
+    also have "... \<le> (?s\<^sup>t\<^sup>\<odot> \<odot> ?z) (i,j)"
+      apply (rule lub_sum_nat)
+      by (metis less_eq_matrix_def matrix_idempotent_semiring.mult_left_isotone matrix_kleene_algebra.star.power_below_circ)
+    finally show "(\<Squnion>k<?l . ?p k \<odot> ?z) (i,j) \<le> (?s\<^sup>t\<^sup>\<odot> \<odot> ?z) (i,j)"
+      .
+  qed
+  finally show "?s\<^sup>t\<^sup>\<odot> \<odot> ?z = mtop"
+    by (simp add: matrix_order.antisym_conv)
+qed
+
+end
+
diff --git a/thys/Relational_Disjoint_Set_Forests/More_Disjoint_Set_Forests.thy b/thys/Relational_Disjoint_Set_Forests/More_Disjoint_Set_Forests.thy
--- a/thys/Relational_Disjoint_Set_Forests/More_Disjoint_Set_Forests.thy
+++ b/thys/Relational_Disjoint_Set_Forests/More_Disjoint_Set_Forests.thy
@@ -1,3187 +1,3187 @@
 (* Title:      More on Disjoint-Set Forests
    Author:     Walter Guttmann
    Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
 *)
 
 theory More_Disjoint_Set_Forests
 
 imports Disjoint_Set_Forests
 
 begin
 
 section \<open>More on Array Access and Disjoint-Set Forests\<close>
 
 text \<open>
 This section contains further results about directed acyclic graphs and relational array operations.
 \<close>
 
 context stone_relation_algebra
 begin
 
 text \<open>Theorem 6.4\<close>
 
 lemma update_square:
   assumes "point y"
     shows "x[y\<longmapsto>x[[x[[y]]]]] \<le> x * x \<squnion> x"
 proof -
   have "x[y\<longmapsto>x[[x[[y]]]]] = (y \<sqinter> y\<^sup>T * x * x) \<squnion> (-y \<sqinter> x)"
     by (simp add: conv_dist_comp)
   also have "... \<le> (y \<sqinter> y\<^sup>T) * x * x \<squnion> x"
     by (smt assms inf.eq_refl inf.sup_monoid.add_commute inf_le1 sup_mono vector_inf_comp)
   also have "... \<le> x * x \<squnion> x"
     by (smt (z3) assms comp_associative conv_dist_comp coreflexive_comp_top_inf inf.cobounded2 sup_left_isotone symmetric_top_closed)
   finally show ?thesis
     .
 qed
 
 text \<open>Theorem 2.13\<close>
 
 lemma update_ub:
   "x[y\<longmapsto>z] \<le> x \<squnion> z\<^sup>T"
   by (meson dual_order.trans inf.cobounded2 le_supI sup.cobounded1 sup_ge2)
 
 text \<open>Theorem 6.7\<close>
 
 lemma update_square_ub:
   "x[y\<longmapsto>(x * x)\<^sup>T] \<le> x \<squnion> x * x"
   by (metis conv_involutive update_ub)
 
 text \<open>Theorem 2.14\<close>
 
 lemma update_same_sub:
   assumes "u \<sqinter> x = u \<sqinter> z"
       and "y \<le> u"
       and "regular y"
     shows "x[y\<longmapsto>z\<^sup>T] = x"
   by (smt (z3) assms conv_involutive inf.sup_monoid.add_commute inf.sup_relative_same_increasing maddux_3_11_pp)
 
 text \<open>Theorem 2.15\<close>
 
 lemma update_point_get:
   "point y \<Longrightarrow> x[y\<longmapsto>z[[y]]] = x[y\<longmapsto>z\<^sup>T]"
   by (metis conv_involutive get_put inf_commute update_inf_same)
 
 text \<open>Theorem 2.11\<close>
 
 lemma update_bot:
   "x[bot\<longmapsto>z] = x"
   by simp
 
 text \<open>Theorem 2.12\<close>
 
 lemma update_top:
   "x[top\<longmapsto>z] = z\<^sup>T"
   by simp
 
 text \<open>Theorem 2.6\<close>
 
 lemma update_same:
   assumes "regular u"
     shows "(x[y\<longmapsto>z])[u\<longmapsto>z] = x[y \<squnion> u\<longmapsto>z]"
 proof -
   have "(x[y\<longmapsto>z])[u\<longmapsto>z] = (u \<sqinter> z\<^sup>T) \<squnion> (-u \<sqinter> y \<sqinter> z\<^sup>T) \<squnion> (-u \<sqinter> -y \<sqinter> x)"
     using inf.sup_monoid.add_assoc inf_sup_distrib1 sup_assoc by force
   also have "... = (u \<sqinter> z\<^sup>T) \<squnion> (y \<sqinter> z\<^sup>T) \<squnion> (-(u \<squnion> y) \<sqinter> x)"
     by (metis assms inf_sup_distrib2 maddux_3_21_pp p_dist_sup)
   also have "... = x[y \<squnion> u\<longmapsto>z]"
     using comp_inf.mult_right_dist_sup sup_commute by auto
   finally show ?thesis
     .
 qed
 
 lemma update_same_3:
   assumes "regular u"
       and "regular v"
     shows "((x[y\<longmapsto>z])[u\<longmapsto>z])[v\<longmapsto>z] = x[y \<squnion> u \<squnion> v\<longmapsto>z]"
   by (metis assms update_same)
 
 text \<open>Theorem 2.7\<close>
 
 lemma update_split:
   assumes "regular w"
     shows "x[y\<longmapsto>z] = (x[y - w\<longmapsto>z])[y \<sqinter> w\<longmapsto>z]"
   by (smt (z3) assms comp_inf.semiring.distrib_left inf.left_commute inf.sup_monoid.add_commute inf_import_p maddux_3_11_pp maddux_3_12 p_dist_inf sup_assoc)
 
 text \<open>Theorem 2.8\<close>
 
 lemma update_injective_swap:
   assumes "injective x"
       and "point y"
       and "injective z"
       and "vector z"
     shows "injective ((x[y\<longmapsto>x[[z]]])[z\<longmapsto>x[[y]]])"
 proof -
   have 1: "(z \<sqinter> y\<^sup>T * x) * (z \<sqinter> y\<^sup>T * x)\<^sup>T \<le> 1"
     using assms(3) injective_inf_closed by auto
   have "(z \<sqinter> y\<^sup>T * x) * (-z \<sqinter> y \<sqinter> z\<^sup>T * x)\<^sup>T \<le> (z \<sqinter> y\<^sup>T * x) * (y\<^sup>T \<sqinter> x\<^sup>T * z)"
     by (metis conv_dist_comp conv_involutive conv_order inf.boundedE inf.boundedI inf.cobounded1 inf.cobounded2 mult_right_isotone)
   also have "... = (z \<sqinter> z\<^sup>T * x) * (y\<^sup>T \<sqinter> x\<^sup>T * y)"
     by (smt (z3) assms(2,4) covector_inf_comp_3 inf.left_commute inf.sup_monoid.add_commute comp_associative conv_dist_comp conv_involutive)
   also have "... = (z \<sqinter> z\<^sup>T) * x * x\<^sup>T * (y \<sqinter> y\<^sup>T)"
     by (smt (z3) assms(2,4) comp_associative inf.sup_monoid.add_commute vector_covector vector_inf_comp)
   also have "... \<le> x * x\<^sup>T"
     by (metis assms(2-4) comp_associative comp_right_one coreflexive_comp_top_inf inf.coboundedI2 mult_right_isotone vector_covector)
   also have "... \<le> 1"
     by (simp add: assms(1))
   finally have 2: "(z \<sqinter> y\<^sup>T * x) * (-z \<sqinter> y \<sqinter> z\<^sup>T * x)\<^sup>T \<le> 1"
     .
   have "(z \<sqinter> y\<^sup>T * x) * (-z \<sqinter> -y \<sqinter> x)\<^sup>T \<le> y\<^sup>T * x * (-y\<^sup>T \<sqinter> x\<^sup>T)"
     by (smt comp_isotone conv_complement conv_dist_inf inf.cobounded2 inf.sup_monoid.add_assoc)
   also have "... = y\<^sup>T * x * x\<^sup>T \<sqinter> -y\<^sup>T"
     by (simp add: inf.commute assms(2) covector_comp_inf vector_conv_compl)
   also have "... \<le> y\<^sup>T \<sqinter> -y\<^sup>T"
     by (metis assms(1) comp_associative comp_inf.mult_left_isotone comp_isotone comp_right_one mult_sub_right_one)
   finally have 3: "(z \<sqinter> y\<^sup>T * x) * (-z \<sqinter> -y \<sqinter> x)\<^sup>T \<le> 1"
     using pseudo_complement by fastforce
   have 4: "(-z \<sqinter> y \<sqinter> z\<^sup>T * x) * (z \<sqinter> y\<^sup>T * x)\<^sup>T \<le> 1"
     using 2 conv_dist_comp conv_order by force
   have 5: "(-z \<sqinter> y \<sqinter> z\<^sup>T * x) * (-z \<sqinter> y \<sqinter> z\<^sup>T * x)\<^sup>T \<le> 1"
     by (simp add: assms(2) inf_assoc inf_left_commute injective_inf_closed)
   have "(-z \<sqinter> y \<sqinter> z\<^sup>T * x) * (-z \<sqinter> -y \<sqinter> x)\<^sup>T \<le> z\<^sup>T * x * (-z\<^sup>T \<sqinter> x\<^sup>T)"
     using comp_inf.mult_left_isotone comp_isotone conv_complement conv_dist_inf inf.cobounded1 inf.cobounded2 by auto
   also have "... = z\<^sup>T * x * x\<^sup>T \<sqinter> -z\<^sup>T"
     by (metis assms(4) covector_comp_inf inf.sup_monoid.add_commute vector_conv_compl)
   also have "... \<le> z\<^sup>T \<sqinter> -z\<^sup>T"
     by (metis assms(1) comp_associative comp_inf.mult_left_isotone comp_isotone comp_right_one mult_sub_right_one)
   finally have 6: "(-z \<sqinter> y \<sqinter> z\<^sup>T * x) * (-z \<sqinter> -y \<sqinter> x)\<^sup>T \<le> 1"
     using pseudo_complement by fastforce
   have 7: "(-z \<sqinter> -y \<sqinter> x) * (z \<sqinter> y\<^sup>T * x)\<^sup>T \<le> 1"
     using 3 conv_dist_comp coreflexive_symmetric by fastforce
   have 8: "(-z \<sqinter> -y \<sqinter> x) * (-z \<sqinter> y \<sqinter> z\<^sup>T * x)\<^sup>T \<le> 1"
     using 6 conv_dist_comp coreflexive_symmetric by fastforce
   have 9: "(-z \<sqinter> -y \<sqinter> x) * (-z \<sqinter> -y \<sqinter> x)\<^sup>T \<le> 1"
     using assms(1) inf.sup_monoid.add_commute injective_inf_closed by auto
   have "(x[y\<longmapsto>x[[z]]])[z\<longmapsto>x[[y]]] = (z \<sqinter> y\<^sup>T * x) \<squnion> (-z \<sqinter> y \<sqinter> z\<^sup>T * x) \<squnion> (-z \<sqinter> -y \<sqinter> x)"
     by (simp add: comp_inf.comp_left_dist_sup conv_dist_comp inf_assoc sup_monoid.add_assoc)
   hence "((x[y\<longmapsto>x[[z]]])[z\<longmapsto>x[[y]]]) * ((x[y\<longmapsto>x[[z]]])[z\<longmapsto>x[[y]]])\<^sup>T = ((z \<sqinter> y\<^sup>T * x) \<squnion> (-z \<sqinter> y \<sqinter> z\<^sup>T * x) \<squnion> (-z \<sqinter> -y \<sqinter> x)) * ((z \<sqinter> y\<^sup>T * x)\<^sup>T \<squnion> (-z \<sqinter> y \<sqinter> z\<^sup>T * x)\<^sup>T \<squnion> (-z \<sqinter> -y \<sqinter> x)\<^sup>T)"
     by (simp add: conv_dist_sup)
   also have "... = (z \<sqinter> y\<^sup>T * x) * ((z \<sqinter> y\<^sup>T * x)\<^sup>T \<squnion> (-z \<sqinter> y \<sqinter> z\<^sup>T * x)\<^sup>T \<squnion> (-z \<sqinter> -y \<sqinter> x)\<^sup>T) \<squnion>
                    (-z \<sqinter> y \<sqinter> z\<^sup>T * x) * ((z \<sqinter> y\<^sup>T * x)\<^sup>T \<squnion> (-z \<sqinter> y \<sqinter> z\<^sup>T * x)\<^sup>T \<squnion> (-z \<sqinter> -y \<sqinter> x)\<^sup>T) \<squnion>
                    (-z \<sqinter> -y \<sqinter> x) * ((z \<sqinter> y\<^sup>T * x)\<^sup>T \<squnion> (-z \<sqinter> y \<sqinter> z\<^sup>T * x)\<^sup>T \<squnion> (-z \<sqinter> -y \<sqinter> x)\<^sup>T)"
     using mult_right_dist_sup by auto
   also have "... = (z \<sqinter> y\<^sup>T * x) * (z \<sqinter> y\<^sup>T * x)\<^sup>T \<squnion> (z \<sqinter> y\<^sup>T * x) * (-z \<sqinter> y \<sqinter> z\<^sup>T * x)\<^sup>T \<squnion> (z \<sqinter> y\<^sup>T * x) * (-z \<sqinter> -y \<sqinter> x)\<^sup>T \<squnion>
                    (-z \<sqinter> y \<sqinter> z\<^sup>T * x) * (z \<sqinter> y\<^sup>T * x)\<^sup>T \<squnion> (-z \<sqinter> y \<sqinter> z\<^sup>T * x) * (-z \<sqinter> y \<sqinter> z\<^sup>T * x)\<^sup>T \<squnion> (-z \<sqinter> y \<sqinter> z\<^sup>T * x) * (-z \<sqinter> -y \<sqinter> x)\<^sup>T \<squnion>
                    (-z \<sqinter> -y \<sqinter> x) * (z \<sqinter> y\<^sup>T * x)\<^sup>T \<squnion> (-z \<sqinter> -y \<sqinter> x) * (-z \<sqinter> y \<sqinter> z\<^sup>T * x)\<^sup>T \<squnion> (-z \<sqinter> -y \<sqinter> x) * (-z \<sqinter> -y \<sqinter> x)\<^sup>T"
     using mult_left_dist_sup sup.left_commute sup_commute by auto
   also have "... \<le> 1"
     using 1 2 3 4 5 6 7 8 9 by simp_all
   finally show ?thesis
     .
 qed
 
 lemma update_injective_swap_2:
   assumes "injective x"
     shows "injective ((x[y\<longmapsto>x[[bot]]])[bot\<longmapsto>x[[y]]])"
   by (simp add: assms inf.sup_monoid.add_commute injective_inf_closed)
 
 text \<open>Theorem 2.9\<close>
 
 lemma update_univalent_swap:
   assumes "univalent x"
       and "injective y"
       and "vector y"
       and "injective z"
       and "vector z"
     shows "univalent ((x[y\<longmapsto>x[[z]]])[z\<longmapsto>x[[y]]])"
   by (simp add: assms read_injective update_univalent)
 
 text \<open>Theorem 2.10\<close>
 
 lemma update_mapping_swap:
   assumes "mapping x"
       and "point y"
       and "point z"
     shows "mapping ((x[y\<longmapsto>x[[z]]])[z\<longmapsto>x[[y]]])"
   by (simp add: assms bijective_regular read_injective read_surjective update_total update_univalent)
 
 text \<open>Theorem 2.16 \<open>mapping_inf_point_arc\<close> has been moved to theory \<open>Relation_Algebras\<close> in entry \<open>Stone_Relation_Algebras\<close>\<close>
 
 end
 
 context stone_kleene_relation_algebra
 begin
 
 lemma omit_redundant_points_2:
   assumes "point p"
   shows "p \<sqinter> x\<^sup>\<star> = (p \<sqinter> 1) \<squnion> (p \<sqinter> x \<sqinter> -p\<^sup>T) * (x \<sqinter> -p\<^sup>T)\<^sup>\<star>"
 proof -
   let ?p = "p \<sqinter> 1"
   let ?np = "-p \<sqinter> 1"
   have 1: "p \<sqinter> x\<^sup>\<star> \<sqinter> 1 = p \<sqinter> 1"
     by (metis inf.le_iff_sup inf.left_commute inf.sup_monoid.add_commute star.circ_reflexive)
   have 2: "p \<sqinter> 1 \<sqinter> -p\<^sup>T = bot"
     by (smt (z3) inf_bot_right inf_commute inf_left_commute one_inf_conv p_inf)
   have "p \<sqinter> x\<^sup>\<star> \<sqinter> -1 = p \<sqinter> x\<^sup>\<star> \<sqinter> -p\<^sup>T"
     by (metis assms antisymmetric_inf_diversity inf.cobounded1 inf.sup_relative_same_increasing vector_covector)
   also have "... = (p \<sqinter> 1 \<sqinter> -p\<^sup>T) \<squnion> ((p \<sqinter> x) * (-p \<sqinter> x)\<^sup>\<star> \<sqinter> -p\<^sup>T)"
     by (simp add: assms omit_redundant_points comp_inf.semiring.distrib_right)
   also have "... = (p \<sqinter> x) * (-p \<sqinter> x)\<^sup>\<star> \<sqinter> -p\<^sup>T"
     using 2 by simp
   also have "... = ?p * x * (-p \<sqinter> x)\<^sup>\<star> \<sqinter> -p\<^sup>T"
     by (metis assms vector_export_comp_unit)
   also have "... = ?p * x * (?np * x)\<^sup>\<star> \<sqinter> -p\<^sup>T"
     by (metis assms vector_complement_closed vector_export_comp_unit)
   also have "... = ?p * x * (?np * x)\<^sup>\<star> * ?np"
     by (metis assms conv_complement covector_comp_inf inf.sup_monoid.add_commute mult_1_right one_inf_conv vector_conv_compl)
   also have "... = ?p * x * ?np * (x * ?np)\<^sup>\<star>"
     using star_slide mult_assoc by auto
   also have "... = (?p * x \<sqinter> -p\<^sup>T) * (x * ?np)\<^sup>\<star>"
     by (metis assms conv_complement covector_comp_inf inf.sup_monoid.add_commute mult_1_right one_inf_conv vector_conv_compl)
   also have "... = (?p * x \<sqinter> -p\<^sup>T) * (x \<sqinter> -p\<^sup>T)\<^sup>\<star>"
     by (metis assms conv_complement covector_comp_inf inf.sup_monoid.add_commute mult_1_right one_inf_conv vector_conv_compl)
   also have "... = (p \<sqinter> x \<sqinter> -p\<^sup>T) * (x \<sqinter> -p\<^sup>T)\<^sup>\<star>"
     by (metis assms vector_export_comp_unit)
   finally show ?thesis
     using 1 by (metis maddux_3_11_pp regular_one_closed)
 qed
 
 text \<open>Theorem 5.3\<close>
 
 lemma omit_redundant_points_3:
   assumes "point p"
   shows "p \<sqinter> x\<^sup>\<star> = (p \<sqinter> 1) \<squnion> (p \<sqinter> (x \<sqinter> -p\<^sup>T)\<^sup>+)"
   by (simp add: assms inf_assoc vector_inf_comp omit_redundant_points_2)
 
 text \<open>Theorem 6.1\<close>
 
 lemma even_odd_root:
   assumes "acyclic (x - 1)"
       and "regular x"
       and "univalent x"
     shows "(x * x)\<^sup>T\<^sup>\<star> \<sqinter> x\<^sup>T * (x * x)\<^sup>T\<^sup>\<star> = (1 \<sqinter> x) * ((x * x)\<^sup>T\<^sup>\<star> \<sqinter> x\<^sup>T * (x * x)\<^sup>T\<^sup>\<star>)"
 proof -
   have 1: "univalent (x * x)"
     by (simp add: assms(3) univalent_mult_closed)
   have "x \<sqinter> 1 \<le> top * (x \<sqinter> 1)"
     by (simp add: top_left_mult_increasing)
   hence "x \<sqinter> -(top * (x \<sqinter> 1)) \<le> x - 1"
     using assms(2) p_shunting_swap pp_dist_comp by auto
   hence "x\<^sup>\<star> * (x \<sqinter> -(top * (x \<sqinter> 1))) \<le> (x - 1)\<^sup>\<star> * (x - 1)"
     using mult_right_isotone reachable_without_loops by auto
   also have "... \<le> -1"
     by (simp add: assms(1) star_plus)
   finally have "(x \<sqinter> -(top * (x \<sqinter> 1)))\<^sup>T \<le> -x\<^sup>\<star>"
     using schroeder_4_p by force
   hence "x\<^sup>T \<sqinter> x\<^sup>\<star> \<le> (top * (x \<sqinter> 1))\<^sup>T"
     by (smt (z3) assms(2) conv_complement conv_dist_inf p_shunting_swap regular_closed_inf regular_closed_top regular_mult_closed regular_one_closed)
   also have "... = (1 \<sqinter> x) * top"
     by (metis conv_dist_comp conv_dist_inf inf_commute one_inf_conv symmetric_one_closed symmetric_top_closed)
   finally have 2: "(x\<^sup>T \<sqinter> x\<^sup>\<star>) * top \<le> (1 \<sqinter> x) * top"
     by (metis inf.orderE inf.orderI inf_commute inf_vector_comp)
   have "1 \<sqinter> x\<^sup>T\<^sup>+ \<le> (x\<^sup>T \<sqinter> 1 * x\<^sup>\<star>) * x\<^sup>T\<^sup>\<star>"
     by (metis conv_involutive conv_star_commute dedekind_2 inf_commute)
   also have "... \<le> (x\<^sup>T \<sqinter> x\<^sup>\<star>) * top"
     by (simp add: mult_right_isotone)
   also have "... \<le> (1 \<sqinter> x) * top"
     using 2 by simp
   finally have 3: "1 \<sqinter> x\<^sup>T\<^sup>+ \<le> (1 \<sqinter> x) * top"
     .
   have "x\<^sup>T \<sqinter> (x\<^sup>T * x\<^sup>T)\<^sup>+ = 1 * x\<^sup>T \<sqinter> (x\<^sup>T * x\<^sup>T)\<^sup>\<star> * x\<^sup>T * x\<^sup>T"
     using star_plus mult_assoc by auto
   also have "... = (1 \<sqinter> (x\<^sup>T * x\<^sup>T)\<^sup>\<star> * x\<^sup>T) * x\<^sup>T"
     using assms(3) injective_comp_right_dist_inf by force
   also have "... \<le> (1 \<sqinter> x\<^sup>T\<^sup>\<star> * x\<^sup>T) * x\<^sup>T"
     by (meson comp_inf.mult_right_isotone comp_isotone inf.eq_refl star.circ_square)
   also have "... \<le> (1 \<sqinter> x) * top * x\<^sup>T"
     using 3 by (simp add: mult_left_isotone star_plus)
   also have "... \<le> (1 \<sqinter> x) * top"
     by (simp add: comp_associative mult_right_isotone)
   finally have 4: "x\<^sup>T \<sqinter> (x\<^sup>T * x\<^sup>T)\<^sup>+ \<le> (1 \<sqinter> x) * top"
     .
   have "x\<^sup>T \<sqinter> (x\<^sup>T * x\<^sup>T)\<^sup>\<star> = (x\<^sup>T \<sqinter> 1) \<squnion> (x\<^sup>T \<sqinter> (x\<^sup>T * x\<^sup>T)\<^sup>+)"
     by (metis inf_sup_distrib1 star_left_unfold_equal)
   also have "... \<le> (1 \<sqinter> x) * top"
     using 4 by (metis inf.sup_monoid.add_commute le_supI one_inf_conv top_right_mult_increasing)
   finally have 4: "x\<^sup>T \<sqinter> (x\<^sup>T * x\<^sup>T)\<^sup>\<star> \<le> (1 \<sqinter> x) * top"
     .
   have "x\<^sup>T \<sqinter> (x * x)\<^sup>\<star> \<sqinter> -1 \<le> x\<^sup>T \<sqinter> x\<^sup>\<star> \<sqinter> -1"
     by (simp add: inf.coboundedI2 inf.sup_monoid.add_commute star.circ_square)
   also have "... = (x - 1)\<^sup>\<star> \<sqinter> (x - 1)\<^sup>T"
     using conv_complement conv_dist_inf inf_assoc inf_left_commute reachable_without_loops symmetric_one_closed by auto
   also have "... = bot"
     using assms(1) acyclic_star_below_complement_1 by auto
   finally have 5: "x\<^sup>T \<sqinter> (x * x)\<^sup>\<star> \<sqinter> -1 = bot"
     by (simp add: le_bot)
   have "x\<^sup>T \<sqinter> (x * x)\<^sup>\<star> = (x\<^sup>T \<sqinter> (x * x)\<^sup>\<star> \<sqinter> 1) \<squnion> (x\<^sup>T \<sqinter> (x * x)\<^sup>\<star> \<sqinter> -1)"
     by (metis maddux_3_11_pp regular_one_closed)
   also have "... = x\<^sup>T \<sqinter> (x * x)\<^sup>\<star> \<sqinter> 1"
     using 5 by simp
   also have "... = x\<^sup>T \<sqinter> 1"
     by (metis calculation comp_inf.semiring.distrib_left inf.sup_monoid.add_commute star.circ_transitive_equal star_involutive star_left_unfold_equal sup_inf_absorb)
   finally have "(x\<^sup>T \<sqinter> (x * x)\<^sup>\<star>) \<squnion> (x\<^sup>T \<sqinter> (x\<^sup>T * x\<^sup>T)\<^sup>\<star>) \<le> (1 \<sqinter> x) * top"
     using 4 inf.sup_monoid.add_commute one_inf_conv top_right_mult_increasing by auto
   hence "x\<^sup>T \<sqinter> ((x * x)\<^sup>\<star> \<squnion> (x * x)\<^sup>T\<^sup>\<star>) \<le> (1 \<sqinter> x) * top"
     by (simp add: comp_inf.semiring.distrib_left conv_dist_comp)
   hence 6: "x\<^sup>T \<sqinter> (x * x)\<^sup>T\<^sup>\<star> * (x * x)\<^sup>\<star> \<le> (1 \<sqinter> x) * top"
     using 1 by (simp add: cancel_separate_eq sup_commute)
   have "(x * x)\<^sup>T\<^sup>\<star> \<sqinter> x\<^sup>T * (x * x)\<^sup>T\<^sup>\<star> \<le> (x\<^sup>T \<sqinter> (x * x)\<^sup>T\<^sup>\<star> * (x * x)\<^sup>\<star>) * (x * x)\<^sup>T\<^sup>\<star>"
     by (metis conv_involutive conv_star_commute dedekind_2 inf_commute)
   also have "... \<le> (1 \<sqinter> x) * top * (x * x)\<^sup>T\<^sup>\<star>"
     using 6 by (simp add: mult_left_isotone)
   also have "... = (1 \<sqinter> x) * top"
     by (simp add: comp_associative star.circ_left_top)
   finally have "(x * x)\<^sup>T\<^sup>\<star> \<sqinter> x\<^sup>T * (x * x)\<^sup>T\<^sup>\<star> = (x * x)\<^sup>T\<^sup>\<star> \<sqinter> x\<^sup>T * (x * x)\<^sup>T\<^sup>\<star> \<sqinter> (1 \<sqinter> x) * top"
     using inf.order_iff by auto
   also have "... = (1 \<sqinter> x) * ((x * x)\<^sup>T\<^sup>\<star> \<sqinter> x\<^sup>T * (x * x)\<^sup>T\<^sup>\<star>)"
     by (metis coreflexive_comp_top_inf inf.cobounded1 inf.sup_monoid.add_commute)
   finally show ?thesis
     .
 qed
 
 lemma update_square_plus:
   "point y \<Longrightarrow> x[y\<longmapsto>x[[x[[y]]]]] \<le> x\<^sup>+"
   by (meson update_square comp_isotone dual_order.trans le_supI order_refl star.circ_increasing star.circ_mult_increasing)
 
 lemma update_square_ub_plus:
   "x[y\<longmapsto>(x * x)\<^sup>T] \<le> x\<^sup>+"
   by (simp add: comp_isotone inf.coboundedI2 star.circ_increasing star.circ_mult_increasing)
 
 text \<open>Theorem 6.2\<close>
 
 lemma acyclic_square:
   assumes "acyclic (x - 1)"
     shows "x * x \<sqinter> 1 = x \<sqinter> 1"
 proof (rule order.antisym)
   have "1 \<sqinter> x * x = 1 \<sqinter> ((x - 1) * x \<squnion> (x \<sqinter> 1) * x)"
     by (metis maddux_3_11_pp regular_one_closed semiring.distrib_right)
   also have "... \<le> 1 \<sqinter> ((x - 1) * x \<squnion> x)"
     by (metis inf.cobounded2 mult_1_left mult_left_isotone inf.sup_right_isotone semiring.add_left_mono)
   also have "... = 1 \<sqinter> ((x - 1) * (x - 1) \<squnion> (x - 1) * (x \<sqinter> 1) \<squnion> x)"
     by (metis maddux_3_11_pp mult_left_dist_sup regular_one_closed)
   also have "... \<le> (1 \<sqinter> (x - 1) * (x - 1)) \<squnion> (x - 1) * (x \<sqinter> 1) \<squnion> x"
     by (metis inf_le2 inf_sup_distrib1 semiring.add_left_mono sup_monoid.add_assoc)
   also have "... \<le> (1 \<sqinter> (x - 1)\<^sup>+) \<squnion> (x - 1) * (x \<sqinter> 1) \<squnion> x"
     by (metis comp_isotone inf.eq_refl inf.sup_right_isotone star.circ_increasing sup_monoid.add_commute sup_right_isotone)
   also have "... = (x - 1) * (x \<sqinter> 1) \<squnion> x"
     by (metis assms inf.le_iff_sup inf.sup_monoid.add_commute inf_import_p inf_p regular_one_closed sup_inf_absorb sup_monoid.add_commute)
   also have "... = x"
     by (metis comp_isotone inf.cobounded1 inf_le2 mult_1_right sup.absorb2)
   finally show "x * x \<sqinter> 1 \<le> x \<sqinter> 1"
     by (simp add: inf.sup_monoid.add_commute)
   show "x \<sqinter> 1 \<le> x * x \<sqinter> 1"
     by (metis coreflexive_idempotent inf_le1 inf_le2 le_infI mult_isotone)
 qed
 
 lemma diagonal_update_square_aux:
   assumes "acyclic (x - 1)"
       and "point y"
     shows "1 \<sqinter> y \<sqinter> y\<^sup>T * x * x = 1 \<sqinter> y \<sqinter> x"
 proof -
   have 1: "1 \<sqinter> y \<sqinter> x \<le> y\<^sup>T * x * x"
     by (metis comp_isotone coreflexive_idempotent inf.boundedE inf.cobounded1 inf.cobounded2 one_inf_conv)
   have "1 \<sqinter> y \<sqinter> y\<^sup>T * x * x = 1 \<sqinter> (y \<sqinter> y\<^sup>T) * x * x"
     by (simp add: assms(2) inf.sup_monoid.add_assoc vector_inf_comp)
   also have "... = 1 \<sqinter> (y \<sqinter> 1) * x * x"
     by (metis assms(2) inf.cobounded1 inf.sup_monoid.add_commute inf.sup_same_context one_inf_conv vector_covector)
   also have "... \<le> 1 \<sqinter> x * x"
     by (metis comp_left_subdist_inf inf.sup_right_isotone le_infE mult_left_isotone mult_left_one)
   also have "... \<le> x"
     using assms(1) acyclic_square inf.sup_monoid.add_commute by auto
   finally show ?thesis
     using 1 by (metis inf.absorb2 inf.left_commute inf.sup_monoid.add_commute)
 qed
 
 text \<open>Theorem 6.5\<close>
 
 lemma diagonal_update_square:
   assumes "acyclic (x - 1)"
       and "point y"
     shows "(x[y\<longmapsto>x[[x[[y]]]]]) \<sqinter> 1 = x \<sqinter> 1"
 proof -
   let ?xy = "x[[y]]"
   let ?xxy = "x[[?xy]]"
   let ?xyxxy = "x[y\<longmapsto>?xxy]"
   have "?xyxxy \<sqinter> 1 = ((y \<sqinter> y\<^sup>T * x * x) \<squnion> (-y \<sqinter> x)) \<sqinter> 1"
     by (simp add: conv_dist_comp)
   also have "... = (y \<sqinter> y\<^sup>T * x * x \<sqinter> 1) \<squnion> (-y \<sqinter> x \<sqinter> 1)"
     by (simp add: inf_sup_distrib2)
   also have "... = (y \<sqinter> x \<sqinter> 1) \<squnion> (-y \<sqinter> x \<sqinter> 1)"
     using assms by (smt (verit, ccfv_threshold) diagonal_update_square_aux find_set_precondition_def inf_assoc inf_commute)
   also have "... = x \<sqinter> 1"
     by (metis assms(2) bijective_regular comp_inf.mult_right_dist_sup inf.sup_monoid.add_commute maddux_3_11_pp)
   finally show ?thesis
     .
 qed
 
 text \<open>Theorem 6.6\<close>
 
 lemma fc_update_square:
   assumes "mapping x"
       and "point y"
     shows "fc (x[y\<longmapsto>x[[x[[y]]]]]) = fc x"
 proof (rule order.antisym)
   let ?xy = "x[[y]]"
   let ?xxy = "x[[?xy]]"
   let ?xyxxy = "x[y\<longmapsto>?xxy]"
   have 1: "y \<sqinter> y\<^sup>T * x * x \<le> x * x"
     by (smt (z3) assms(2) inf.cobounded2 inf.sup_monoid.add_commute inf.sup_same_context mult_1_left one_inf_conv vector_covector vector_inf_comp)
   have 2: "?xyxxy = (y \<sqinter> y\<^sup>T * x * x) \<squnion> (-y \<sqinter> x)"
     by (simp add: conv_dist_comp)
   also have "... \<le> x * x \<squnion> x"
     using 1 inf_le2 sup_mono by blast
   also have "... \<le> x\<^sup>\<star>"
     by (simp add: star.circ_increasing star.circ_mult_upper_bound)
   finally show "fc ?xyxxy \<le> fc x"
     by (metis comp_isotone conv_order conv_star_commute star_involutive star_isotone)
   have 3: "y \<sqinter> x \<sqinter> 1 \<le> fc ?xyxxy"
     using inf.coboundedI1 inf.sup_monoid.add_commute reflexive_mult_closed star.circ_reflexive by auto
   have 4: "y - 1 \<le> -y\<^sup>T"
     using assms(2) p_shunting_swap regular_one_closed vector_covector by auto
   have "y \<sqinter> x \<le> y\<^sup>T * x"
     by (simp add: assms(2) vector_restrict_comp_conv)
   also have "... \<le> y\<^sup>T * x * x * x\<^sup>T"
     by (metis assms(1) comp_associative mult_1_right mult_right_isotone total_var)
   finally have "y \<sqinter> x \<sqinter> -1 \<le> y \<sqinter> -y\<^sup>T \<sqinter> y\<^sup>T * x * x * x\<^sup>T"
     using 4 by (smt (z3) inf.cobounded1 inf.coboundedI2 inf.sup_monoid.add_assoc inf.sup_monoid.add_commute inf_greatest)
   also have "... = (y \<sqinter> y\<^sup>T * x * x) * x\<^sup>T \<sqinter> -y\<^sup>T"
     by (metis assms(2) inf.sup_monoid.add_assoc inf.sup_monoid.add_commute vector_inf_comp)
   also have "... = (y \<sqinter> y\<^sup>T * x * x) * (x\<^sup>T \<sqinter> -y\<^sup>T)"
     using assms(2) covector_comp_inf vector_conv_compl by auto
   also have "... = (y \<sqinter> y\<^sup>T * x * x) * (-y \<sqinter> x)\<^sup>T"
     by (simp add: conv_complement conv_dist_inf inf_commute)
   also have "... \<le> ?xyxxy * (-y \<sqinter> x)\<^sup>T"
     using 2 by (simp add: comp_left_increasing_sup)
   also have "... \<le> ?xyxxy * ?xyxxy\<^sup>T"
     by (simp add: conv_isotone mult_right_isotone)
   also have "... \<le> fc ?xyxxy"
     using comp_isotone star.circ_increasing by blast
   finally have 5: "y \<sqinter> x \<le> fc ?xyxxy"
     using 3 by (smt (z3) comp_inf.semiring.distrib_left inf.le_iff_sup maddux_3_11_pp regular_one_closed)
   have "x = (y \<sqinter> x) \<squnion> (-y \<sqinter> x)"
     by (metis assms(2) bijective_regular inf.sup_monoid.add_commute maddux_3_11_pp)
   also have "... \<le> fc ?xyxxy"
     using 5 dual_order.trans fc_increasing sup.cobounded2 sup_least by blast
   finally show "fc x \<le> fc ?xyxxy"
     by (smt (z3) assms fc_equivalence fc_isotone fc_wcc read_injective star.circ_decompose_9 star_decompose_1 update_univalent)
 qed
 
 text \<open>Theorem 6.2\<close>
 
 lemma acyclic_plus_loop:
   assumes "acyclic (x - 1)"
   shows "x\<^sup>+ \<sqinter> 1 = x \<sqinter> 1"
 proof -
   let ?r = "x \<sqinter> 1"
   let ?i = "x - 1"
   have "x\<^sup>+ \<sqinter> 1 = (?i \<squnion> ?r)\<^sup>+ \<sqinter> 1"
     by (metis maddux_3_11_pp regular_one_closed)
   also have "... = ((?i\<^sup>\<star> * ?r)\<^sup>\<star> * ?i\<^sup>+ \<squnion> (?i\<^sup>\<star> * ?r)\<^sup>+) \<sqinter> 1"
     using plus_sup by auto
   also have "... \<le> (?i\<^sup>+ \<squnion> (?i\<^sup>\<star> * ?r)\<^sup>+) \<sqinter> 1"
     by (metis comp_associative dual_order.eq_iff maddux_3_11_pp reachable_without_loops regular_one_closed star.circ_plus_same star.circ_sup_9)
   also have "... = (?i\<^sup>\<star> * ?r)\<^sup>+ \<sqinter> 1"
     by (smt (z3) assms comp_inf.mult_right_dist_sup inf.absorb2 inf.sup_monoid.add_commute inf_le2 maddux_3_11_pp pseudo_complement regular_one_closed)
   also have "... \<le> ?i\<^sup>\<star> * ?r \<sqinter> 1"
     by (metis comp_associative dual_order.eq_iff maddux_3_11_pp reachable_without_loops regular_one_closed star.circ_sup_9 star_slide)
   also have "... = (?r \<squnion> ?i\<^sup>+ * ?r) \<sqinter> 1"
     using comp_associative star.circ_loop_fixpoint sup_commute by force
   also have "... \<le> x \<squnion> (?i\<^sup>+ * ?r \<sqinter> 1)"
     by (metis comp_inf.mult_right_dist_sup inf.absorb1 inf.cobounded1 inf.cobounded2)
   also have "... \<le> x \<squnion> (-1 * ?r \<sqinter> 1)"
     by (meson assms comp_inf.comp_isotone mult_left_isotone order.refl semiring.add_left_mono)
   also have "... = x"
     by (metis comp_inf.semiring.mult_not_zero comp_right_one inf.cobounded2 inf_sup_absorb mult_right_isotone pseudo_complement sup.idem sup_inf_distrib1)
   finally show ?thesis
     by (meson inf.sup_same_context inf_le1 order_trans star.circ_mult_increasing)
 qed
 
 lemma star_irreflexive_part_eq:
   "x\<^sup>\<star> - 1 = (x - 1)\<^sup>+ - 1"
   by (metis reachable_without_loops star_plus_without_loops)
 
 text \<open>Theorem 6.3\<close>
 
 lemma star_irreflexive_part:
   "x\<^sup>\<star> - 1 \<le> (x - 1)\<^sup>+"
   using star_irreflexive_part_eq by auto
 
 lemma square_irreflexive_part:
   "x * x - 1 \<le> (x - 1)\<^sup>+"
 proof -
   have "x * x = (x \<sqinter> 1) * x \<squnion> (x - 1) * x"
     by (metis maddux_3_11_pp mult_right_dist_sup regular_one_closed)
   also have "... \<le> 1 * x \<squnion> (x - 1) * x"
     using comp_isotone inf.cobounded2 semiring.add_right_mono by blast
   also have "... \<le> 1 \<squnion> (x - 1) \<squnion> (x - 1) * x"
     by (metis inf.cobounded2 maddux_3_11_pp mult_1_left regular_one_closed sup_left_isotone)
   also have "... = (x - 1) * (x \<squnion> 1) \<squnion> 1"
     by (simp add: mult_left_dist_sup sup_assoc sup_commute)
   finally have "x * x - 1 \<le> (x - 1) * (x \<squnion> 1)"
     using shunting_var_p by auto
   also have "... = (x - 1) * (x - 1) \<squnion> (x - 1)"
     by (metis comp_right_one inf.sup_monoid.add_commute maddux_3_21_pp mult_left_dist_sup regular_one_closed sup_commute)
   also have "... \<le> (x - 1)\<^sup>+"
     by (metis mult_left_isotone star.circ_increasing star.circ_mult_increasing star.circ_plus_same sup.bounded_iff)
   finally show ?thesis
     .
 qed
 
 text \<open>Theorem 6.3\<close>
 
 lemma square_irreflexive_part_2:
   "x * x - 1 \<le> x\<^sup>\<star> - 1"
   using comp_inf.mult_left_isotone star.circ_increasing star.circ_mult_upper_bound by blast
 
 text \<open>Theorem 6.8\<close>
 
 lemma acyclic_update_square:
   assumes "acyclic (x - 1)"
   shows "acyclic ((x[y\<longmapsto>(x * x)\<^sup>T]) - 1)"
 proof -
   have "((x[y\<longmapsto>(x * x)\<^sup>T]) - 1)\<^sup>+ \<le> ((x \<squnion> x * x) - 1)\<^sup>+"
     by (metis comp_inf.mult_right_isotone comp_isotone inf.sup_monoid.add_commute star_isotone update_square_ub)
   also have "... = ((x - 1) \<squnion> (x * x - 1))\<^sup>+"
     using comp_inf.semiring.distrib_right by auto
   also have "... \<le> ((x - 1)\<^sup>+)\<^sup>+"
     by (smt (verit, del_insts) comp_isotone reachable_without_loops star.circ_mult_increasing star.circ_plus_same star.circ_right_slide star.circ_separate_5 star.circ_square star.circ_transitive_equal star.left_plus_circ sup.bounded_iff sup_ge1 square_irreflexive_part)
   also have "... \<le> -1"
     using assms by (simp add: acyclic_plus)
   finally show ?thesis
     .
 qed
 
 text \<open>Theorem 6.9\<close>
 
 lemma disjoint_set_forest_update_square:
   assumes "disjoint_set_forest x"
       and "vector y"
       and "regular y"
     shows "disjoint_set_forest (x[y\<longmapsto>(x * x)\<^sup>T])"
 proof (intro conjI)
   show "univalent (x[y\<longmapsto>(x * x)\<^sup>T])"
     using assms update_univalent mapping_mult_closed univalent_conv_injective by blast
   show "total (x[y\<longmapsto>(x * x)\<^sup>T])"
     using assms update_total total_conv_surjective total_mult_closed by blast
   show "acyclic ((x[y\<longmapsto>(x * x)\<^sup>T]) - 1)"
     using acyclic_update_square assms(1) by blast
 qed
 
 lemma disjoint_set_forest_update_square_point:
   assumes "disjoint_set_forest x"
       and "point y"
     shows "disjoint_set_forest (x[y\<longmapsto>(x * x)\<^sup>T])"
   using assms disjoint_set_forest_update_square bijective_regular by blast
 
 end
 
 section \<open>Verifying Further Operations on Disjoint-Set Forests\<close>
 
 text \<open>
 In this section we verify the init-sets, path-halving and path-splitting operations of disjoint-set forests.
 \<close>
 
 class choose_point =
   fixes choose_point :: "'a \<Rightarrow> 'a"
 
 text \<open>
 Using the \<open>choose_point\<close> operation we define a simple for-each-loop abstraction as syntactic sugar translated to a while-loop.
 Regular vector \<open>h\<close> describes the set of all elements that are yet to be processed.
 It is made explicit so that the invariant can refer to it.
 \<close>
 
 syntax
   "_Foreach" :: "idt \<Rightarrow> idt \<Rightarrow> 'assn \<Rightarrow> 'com \<Rightarrow> 'com"  ("(1FOREACH _/ USING _/ INV {_} //DO _ /OD)" [0,0,0,0] 61)
 translations "FOREACH x USING h INV { i } DO c OD" =>
   "h := CONST top;
    WHILE h \<noteq> CONST bot
      INV { CONST regular h \<and> CONST vector h \<and> i }
      VAR { h\<down> }
       DO x := CONST choose_point h;
          c;
          h[x] := CONST bot
       OD"
 
 class stone_kleene_relation_algebra_choose_point_finite_regular = stone_kleene_relation_algebra + finite_regular_p_algebra + choose_point +
   assumes choose_point_point: "vector x \<Longrightarrow> x \<noteq> bot \<Longrightarrow> point (choose_point x)"
   assumes choose_point_decreasing: "choose_point x \<le> --x"
 begin
 
 subclass stone_kleene_relation_algebra_tarski_finite_regular
 proof unfold_locales
   fix x
   let ?p = "choose_point (x * top)"
   let ?q = "choose_point ((?p \<sqinter> x)\<^sup>T * top)"
   let ?y = "?p \<sqinter> ?q\<^sup>T"
   assume 1: "regular x" "x \<noteq> bot"
   hence 2: "x * top \<noteq> bot"
     using le_bot top_right_mult_increasing by auto
   hence 3: "point ?p"
     by (simp add: choose_point_point comp_associative)
   hence 4: "?p \<noteq> bot"
     using 2 mult_right_zero by force
   have "?p \<sqinter> x \<noteq> bot"
   proof
     assume "?p \<sqinter> x = bot"
     hence 5: "x \<le> -?p"
       using p_antitone_iff pseudo_complement by auto
     have "?p \<le> --(x * top)"
       by (simp add: choose_point_decreasing)
     also have "... \<le> --(-?p * top)"
       using 5 by (simp add: comp_isotone pp_isotone)
     also have "... = -?p * top"
       using regular_mult_closed by auto
     also have "... = -?p"
       using 3 vector_complement_closed by auto
     finally have "?p = bot"
       using inf_absorb2 by fastforce
     thus False
       using 4 by auto
   qed
   hence "(?p \<sqinter> x)\<^sup>T * top \<noteq> bot"
     by (metis comp_inf.semiring.mult_zero_left comp_right_one inf.sup_monoid.add_commute inf_top.left_neutral schroeder_1)
   hence "point ?q"
     using choose_point_point vector_top_closed mult_assoc by auto
   hence 6: "arc ?y"
     using 3 by (smt bijective_conv_mapping inf.sup_monoid.add_commute mapping_inf_point_arc)
   have "?q \<le> --((?p \<sqinter> x)\<^sup>T * top)"
     by (simp add: choose_point_decreasing)
   hence "?y \<le> ?p \<sqinter> --((?p \<sqinter> x)\<^sup>T * top)\<^sup>T"
     by (metis conv_complement conv_isotone inf.sup_right_isotone)
   also have "... = ?p \<sqinter> --(top * (?p \<sqinter> x))"
     by (simp add: conv_dist_comp)
   also have "... = ?p \<sqinter> top * (?p \<sqinter> x)"
     using 1 3 bijective_regular pp_dist_comp by auto
   also have "... = ?p \<sqinter> ?p\<^sup>T * x"
     using 3 by (metis comp_inf_vector conv_dist_comp inf.sup_monoid.add_commute inf_top_right symmetric_top_closed)
   also have "... = (?p \<sqinter> ?p\<^sup>T) * x"
     using 3 by (simp add: vector_inf_comp)
   also have "... \<le> 1 * x"
     using 3 point_antisymmetric mult_left_isotone by blast
   finally have "?y \<le> x"
     by simp
   thus "top * x * top = top"
     using 6 by (smt (verit, ccfv_SIG) mult_assoc le_iff_sup mult_left_isotone semiring.distrib_left sup.orderE top.extremum)
 qed
 
 subsection \<open>Init-Sets\<close>
 
 text \<open>
 A disjoint-set forest is initialised by applying \<open>make_set\<close> to each node.
 We prove that the resulting disjoint-set forest is the identity relation.
 \<close>
 
 theorem init_sets:
   "VARS h p x
   [ True ]
   FOREACH x
     USING h
       INV { p - h = 1 - h }
        DO p := make_set p x
        OD
   [ p = 1 \<and> disjoint_set_forest p \<and> h = bot ]"
 proof vcg_tc_simp
   fix h p
   let ?x = "choose_point h"
   let ?m = "make_set p ?x"
   assume 1: "regular h \<and> vector h \<and> p - h = 1 - h \<and> h \<noteq> bot"
   show "vector (-?x \<sqinter> h) \<and>
         ?m \<sqinter> (--?x \<squnion> -h) = 1 \<sqinter> (--?x \<squnion> -h) \<and>
         card { x . regular x \<and> x \<le> -?x \<and> x \<le> h } < h\<down>"
   proof (intro conjI)
     show "vector (-?x \<sqinter> h)"
       using 1 choose_point_point vector_complement_closed vector_inf_closed by blast
     have 2: "point ?x \<and> regular ?x"
       using 1 bijective_regular choose_point_point by blast
     have 3: "-h \<le> -?x"
       using choose_point_decreasing p_antitone_iff by auto
     have 4: "?x \<sqinter> ?m = ?x * ?x\<^sup>T \<and> -?x \<sqinter> ?m = -?x \<sqinter> p"
       using 1 choose_point_point make_set_function make_set_postcondition_def by auto
     have "?m \<sqinter> (--?x \<squnion> -h) = (?m \<sqinter> ?x) \<squnion> (?m - h)"
       using 2 comp_inf.comp_left_dist_sup by auto
     also have "... = ?x * ?x\<^sup>T \<squnion> (?m \<sqinter> -?x \<sqinter> -h)"
       using 3 4 by (smt (z3) inf_absorb2 inf_assoc inf_commute)
     also have "... = ?x * ?x\<^sup>T \<squnion> (1 - h)"
       using 1 3 4 inf.absorb2 inf.sup_monoid.add_assoc inf_commute by auto
     also have "... = (1 \<sqinter> ?x) \<squnion> (1 - h)"
       using 2 by (metis inf.cobounded2 inf.sup_same_context one_inf_conv vector_covector)
     also have "... = 1 \<sqinter> (--?x \<squnion> -h)"
       using 2 comp_inf.semiring.distrib_left by auto
     finally show "?m \<sqinter> (--?x \<squnion> -h) = 1 \<sqinter> (--?x \<squnion> -h)"
       .
     have 5: "\<not> ?x \<le> -?x"
       using 1 2 by (metis comp_commute_below_diversity conv_order inf.cobounded2 inf_absorb2 pseudo_complement strict_order_var top.extremum)
     have 6: "?x \<le> h"
       using 1 by (metis choose_point_decreasing)
     show "card { x . regular x \<and> x \<le> -?x \<and> x \<le> h } < h\<down>"
       apply (rule psubset_card_mono)
       using finite_regular apply simp
       using 2 5 6 by auto
   qed
 qed
 
 end
 
 subsection \<open>Path Halving\<close>
 
 text \<open>
 Path halving is a variant of the path compression technique.
 Similarly to path compression, we implement path halving independently of find-set, using a second while-loop which iterates over the same path to the root.
 We prove that path halving preserves the equivalence-relational semantics of the disjoint-set forest and also preserves the roots of the component trees.
 Additionally we prove the exact effect of path halving, which is to replace every other parent pointer with a pointer to the respective grandparent.
 \<close>
 
 context stone_kleene_relation_algebra_tarski_finite_regular
 begin
 
 definition "path_halving_invariant p x y p0 \<equiv> 
   find_set_precondition p x \<and> point y \<and> y \<le> p\<^sup>T\<^sup>\<star> * x \<and> y \<le> (p0 * p0)\<^sup>T\<^sup>\<star> * x \<and>
   p0[(p0 * p0)\<^sup>T\<^sup>\<star> * x - p0\<^sup>T\<^sup>\<star> * y\<longmapsto>(p0 * p0)\<^sup>T] = p \<and>
   disjoint_set_forest p0"
 definition "path_halving_postcondition p x y p0 \<equiv> 
   path_compression_precondition p x y \<and> p \<sqinter> 1 = p0 \<sqinter> 1 \<and> fc p = fc p0 \<and>
   p0[(p0 * p0)\<^sup>T\<^sup>\<star> * x\<longmapsto>(p0 * p0)\<^sup>T] = p"
 
 lemma path_halving_invariant_aux_1:
   assumes "point x"
       and "point y"
       and "disjoint_set_forest p0"
   shows "p0 \<le> wcc (p0[(p0 * p0)\<^sup>T\<^sup>\<star> * x - p0\<^sup>T\<^sup>\<star> * y\<longmapsto>(p0 * p0)\<^sup>T])"
 proof -
   let ?p2 = "p0 * p0"
   let ?p2t = "?p2\<^sup>T"
   let ?p2ts = "?p2t\<^sup>\<star>"
   let ?px = "?p2ts * x"
   let ?py = "-(p0\<^sup>T\<^sup>\<star> * y)"
   let ?pxy = "?px \<sqinter> ?py"
   let ?p = "p0[?pxy\<longmapsto>?p2t]"
   have 1: "regular ?pxy"
     using assms(1,3) bijective_regular find_set_precondition_def mapping_regular pp_dist_comp regular_closed_star regular_conv_closed path_halving_invariant_def by auto
   have 2: "vector x \<and> vector ?px \<and> vector ?py"
     using assms(1,2) find_set_precondition_def vector_complement_closed vector_mult_closed path_halving_invariant_def by auto
   have 3: "?pxy \<sqinter> p0 \<sqinter> -?p2 \<le> -?px\<^sup>T"
   proof -
     have 4: "injective x \<and> univalent ?p2 \<and> regular p0"
       using assms(1,3) find_set_precondition_def mapping_regular univalent_mult_closed path_halving_invariant_def by auto
     have "?p2\<^sup>\<star> * p0 \<sqinter> 1 \<le> p0\<^sup>+ \<sqinter> 1"
       using comp_inf.mult_left_isotone comp_isotone comp_right_one mult_sub_right_one star.circ_square star_slide by auto
     also have "... \<le> p0"
       using acyclic_plus_loop assms(3) path_halving_invariant_def by auto
     finally have 5: "?p2\<^sup>\<star> * p0 \<sqinter> 1 \<le> p0"
       .
     hence 6: "?p2ts * (1 - p0) \<le> -p0"
       by (smt (verit, ccfv_SIG) conv_star_commute dual_order.trans inf.sup_monoid.add_assoc order.refl p_antitone_iff pseudo_complement schroeder_4_p schroeder_6_p)
     have "?p2t\<^sup>+ * p0 \<sqinter> 1 = ?p2ts * p0\<^sup>T * (p0\<^sup>T * p0) \<sqinter> 1"
       by (metis conv_dist_comp star_plus mult_assoc)
     also have "... \<le> ?p2ts * p0\<^sup>T \<sqinter> 1"
       by (metis assms(3) comp_inf.mult_left_isotone comp_isotone comp_right_one mult_sub_right_one)
     also have "... \<le> p0"
       using 5 by (metis conv_dist_comp conv_star_commute inf_commute one_inf_conv star_slide)
     finally have "?p2t\<^sup>+ * p0 \<le> -1 \<squnion> p0"
       by (metis regular_one_closed shunting_var_p sup_commute)
     hence 7: "?p2\<^sup>+ * (1 - p0) \<le> -p0"
       by (smt (z3) conv_dist_comp conv_star_commute half_shunting inf.sup_monoid.add_assoc inf.sup_monoid.add_commute pseudo_complement schroeder_4_p schroeder_6_p star.circ_plus_same)
     have "(1 \<sqinter> ?px) * top * (1 \<sqinter> ?px \<sqinter> -p0) = ?px \<sqinter> top * (1 \<sqinter> ?px \<sqinter> -p0)"
       using 2 by (metis inf_commute vector_inf_one_comp mult_assoc)
     also have "... = ?px \<sqinter> ?px\<^sup>T * (1 - p0)"
       using 2 by (smt (verit, ccfv_threshold) covector_inf_comp_3 inf.sup_monoid.add_assoc inf.sup_monoid.add_commute inf_top.left_neutral)
     also have "... = ?px \<sqinter> x\<^sup>T * ?p2\<^sup>\<star> * (1 - p0)"
       by (simp add: conv_dist_comp conv_star_commute)
     also have "... = (?px \<sqinter> x\<^sup>T) * ?p2\<^sup>\<star> * (1 - p0)"
       using 2 vector_inf_comp by auto
     also have "... = ?p2ts * (x * x\<^sup>T) * ?p2\<^sup>\<star> * (1 - p0)"
       using 2 vector_covector mult_assoc by auto
     also have "... \<le> ?p2ts * ?p2\<^sup>\<star> * (1 - p0)"
       using 4 by (metis inf.order_lesseq_imp mult_left_isotone star.circ_mult_upper_bound star.circ_reflexive)
     also have "... = (?p2ts \<squnion> ?p2\<^sup>\<star>) * (1 - p0)"
       using 4 by (simp add: cancel_separate_eq)
     also have "... = (?p2ts \<squnion> ?p2\<^sup>+) * (1 - p0)"
       by (metis star.circ_plus_one star_plus_loops sup_assoc sup_commute)
     also have "... \<le> -p0"
       using 6 7 by (simp add: mult_right_dist_sup)
     finally have "(1 \<sqinter> ?px)\<^sup>T * p0 * (1 \<sqinter> ?px \<sqinter> -p0)\<^sup>T \<le> bot"
       by (smt (z3) inf.boundedI inf_p top.extremum triple_schroeder_p)
     hence 8: "(1 \<sqinter> ?px) * p0 * (1 \<sqinter> ?px \<sqinter> -p0) = bot"
       by (simp add: coreflexive_inf_closed coreflexive_symmetric le_bot)
     have "?px \<sqinter> p0 \<sqinter> ?px\<^sup>T = (1 \<sqinter> ?px) * p0 \<sqinter> ?px\<^sup>T"
       using 2 inf_commute vector_inf_one_comp by fastforce
     also have "... = (1 \<sqinter> ?px) * p0 * (1 \<sqinter> ?px)"
       using 2 by (metis comp_inf_vector mult_1_right vector_conv_covector)
     also have "... = (1 \<sqinter> ?px) * p0 * (1 \<sqinter> ?px \<sqinter> p0) \<squnion> (1 \<sqinter> ?px) * p0 * (1 \<sqinter> ?px \<sqinter> -p0)"
       using 4 by (metis maddux_3_11_pp mult_left_dist_sup)
     also have "... = (1 \<sqinter> ?px) * p0 * (1 \<sqinter> ?px \<sqinter> p0)"
       using 8 by simp
     also have "... \<le> ?p2"
       by (metis comp_isotone coreflexive_comp_top_inf inf.cobounded1 inf.cobounded2)
     finally have "?px \<sqinter> p0 \<sqinter> -?p2 \<le> -?px\<^sup>T"
       using 4 p_shunting_swap regular_mult_closed by fastforce
     thus ?thesis
       by (meson comp_inf.mult_left_isotone dual_order.trans inf.cobounded1)
   qed
   have "p0 \<le> ?p2 * p0\<^sup>T"
     by (metis assms(3) comp_associative comp_isotone comp_right_one eq_refl total_var)
   hence "?pxy \<sqinter> p0 \<sqinter> -?p2 \<le> ?p2 * p0\<^sup>T"
     by (metis inf.coboundedI1 inf.sup_monoid.add_commute)
   hence "?pxy \<sqinter> p0 \<sqinter> -?p2 \<le> ?pxy \<sqinter> ?p2 * p0\<^sup>T \<sqinter> -?px\<^sup>T"
     using 3 by (meson dual_order.trans inf.boundedI inf.cobounded1)
   also have "... = (?pxy \<sqinter> ?p2) * p0\<^sup>T \<sqinter> -?px\<^sup>T"
     using 2 vector_inf_comp by auto
   also have "... = (?pxy \<sqinter> ?p2) * (-?px \<sqinter> p0)\<^sup>T"
     using 2 by (simp add: covector_comp_inf inf.sup_monoid.add_commute vector_conv_compl conv_complement conv_dist_inf)
   also have "... \<le> ?p * (-?px \<sqinter> p0)\<^sup>T"
     using comp_left_increasing_sup by auto
   also have "... \<le> ?p * ?p\<^sup>T"
     by (metis comp_inf.mult_right_isotone comp_isotone conv_isotone inf.eq_refl inf.sup_monoid.add_commute le_supI1 p_antitone_inf sup_commute)
   also have "... \<le> wcc ?p"
     using star.circ_sub_dist_2 by auto
   finally have 9: "?pxy \<sqinter> p0 \<sqinter> -?p2 \<le> wcc ?p"
     .
   have "p0 = (?pxy \<sqinter> p0) \<squnion> (-?pxy \<sqinter> p0)"
     using 1 by (metis inf.sup_monoid.add_commute maddux_3_11_pp)
   also have "... \<le> (?pxy \<sqinter> p0) \<squnion> ?p"
     using sup_right_isotone by auto
   also have "... = (?pxy \<sqinter> p0 \<sqinter> -?p2) \<squnion> (?pxy \<sqinter> p0 \<sqinter> ?p2) \<squnion> ?p"
     by (smt (z3) assms(3) maddux_3_11_pp mapping_regular pp_dist_comp path_halving_invariant_def)
   also have "... \<le> (?pxy \<sqinter> p0 \<sqinter> -?p2) \<squnion> (?pxy \<sqinter> ?p2) \<squnion> ?p"
     by (meson comp_inf.comp_left_subdist_inf inf.boundedE semiring.add_left_mono semiring.add_right_mono)
   also have "... = (?pxy \<sqinter> p0 \<sqinter> -?p2) \<squnion> ?p"
     using sup_assoc by auto
   also have "... \<le> wcc ?p \<squnion> ?p"
     using 9 sup_left_isotone by blast
   also have "... \<le> wcc ?p"
     by (simp add: star.circ_sub_dist_1)
   finally show ?thesis
     .
 qed
 
 lemma path_halving_invariant_aux:
   assumes "path_halving_invariant p x y p0"
   shows "p[[y]] = p0[[y]]"
     and "p[[p[[y]]]] = p0[[p0[[y]]]]"
     and "p[[p[[p[[y]]]]]] = p0[[p0[[p0[[y]]]]]]"
     and "p \<sqinter> 1 = p0 \<sqinter> 1"
     and "fc p = fc p0"
 proof -
   let ?p2 = "p0 * p0"
   let ?p2t = "?p2\<^sup>T"
   let ?p2ts = "?p2t\<^sup>\<star>"
   let ?px = "?p2ts * x"
   let ?py = "-(p0\<^sup>T\<^sup>\<star> * y)"
   let ?pxy = "?px \<sqinter> ?py"
   let ?p = "p0[?pxy\<longmapsto>?p2t]"
   have "?p[[y]] = p0[[y]]"
     apply (rule put_get_different_vector)
     using assms find_set_precondition_def vector_complement_closed vector_inf_closed vector_mult_closed path_halving_invariant_def apply force
     by (meson inf.cobounded2 order_lesseq_imp p_antitone_iff path_compression_1b)
   thus 1: "p[[y]] = p0[[y]]"
     using assms path_halving_invariant_def by auto
   have "?p[[p0[[y]]]] = p0[[p0[[y]]]]"
     apply (rule put_get_different_vector)
     using assms find_set_precondition_def vector_complement_closed vector_inf_closed vector_mult_closed path_halving_invariant_def apply force
     by (metis comp_isotone inf.boundedE inf.coboundedI2 inf.eq_refl p_antitone_iff selection_closed_id star.circ_increasing)
   thus 2: "p[[p[[y]]]] = p0[[p0[[y]]]]"
     using 1 assms path_halving_invariant_def by auto
   have "?p[[p0[[p0[[y]]]]]] = p0[[p0[[p0[[y]]]]]]"
     apply (rule put_get_different_vector)
     using assms find_set_precondition_def vector_complement_closed vector_inf_closed vector_mult_closed path_halving_invariant_def apply force
     by (metis comp_associative comp_isotone conv_dist_comp conv_involutive conv_order inf.coboundedI2 inf.le_iff_sup mult_left_isotone p_antitone_iff p_antitone_inf star.circ_increasing star.circ_transitive_equal)
   thus "p[[p[[p[[y]]]]]] = p0[[p0[[p0[[y]]]]]]"
     using 2 assms path_halving_invariant_def by auto
   have 3: "regular ?pxy"
     using assms bijective_regular find_set_precondition_def mapping_regular pp_dist_comp regular_closed_star regular_conv_closed path_halving_invariant_def by auto
   have "p \<sqinter> 1 = ?p \<sqinter> 1"
     using assms path_halving_invariant_def by auto
   also have "... = (?pxy \<sqinter> ?p2 \<sqinter> 1) \<squnion> (-?pxy \<sqinter> p0 \<sqinter> 1)"
     using comp_inf.semiring.distrib_right conv_involutive by auto
   also have "... = (?pxy \<sqinter> p0 \<sqinter> 1) \<squnion> (-?pxy \<sqinter> p0 \<sqinter> 1)"
     using assms acyclic_square path_halving_invariant_def inf.sup_monoid.add_assoc by auto
   also have "... = (?pxy \<squnion> -?pxy) \<sqinter> p0 \<sqinter> 1"
     using inf_sup_distrib2 by auto
   also have "... = p0 \<sqinter> 1"
     using 3 by (metis inf.sup_monoid.add_commute inf_sup_distrib1 maddux_3_11_pp)
   finally show "p \<sqinter> 1 = p0 \<sqinter> 1"
     .
   have "p \<le> p0\<^sup>+"
     by (metis assms path_halving_invariant_def update_square_ub_plus)
   hence 4: "fc p \<le> fc p0"
     using conv_plus_commute fc_isotone star.left_plus_circ by fastforce
   have "wcc p0 \<le> wcc ?p"
     by (meson assms wcc_below_wcc path_halving_invariant_aux_1 path_halving_invariant_def find_set_precondition_def)
   hence "fc p0 \<le> fc ?p"
     using assms find_set_precondition_def path_halving_invariant_def fc_wcc by auto
   thus "fc p = fc p0"
     using 4 assms path_halving_invariant_def by auto
 qed
 
 lemma path_halving_1:
   "find_set_precondition p0 x \<Longrightarrow> path_halving_invariant p0 x x p0"
 proof -
   assume 1: "find_set_precondition p0 x"
   show "path_halving_invariant p0 x x p0"
   proof (unfold path_halving_invariant_def, intro conjI)
     show "find_set_precondition p0 x"
       using 1 by simp
     show "vector x" "injective x" "surjective x"
       using 1 find_set_precondition_def by auto
     show "x \<le> p0\<^sup>T\<^sup>\<star> * x"
       by (simp add: path_compression_1b)
     show "x \<le> (p0 * p0)\<^sup>T\<^sup>\<star> * x"
       by (simp add: path_compression_1b)
     have "(p0 * p0)\<^sup>T\<^sup>\<star> * x \<le> p0\<^sup>T\<^sup>\<star> * x"
       by (simp add: conv_dist_comp mult_left_isotone star.circ_square)
     thus "p0[(p0 * p0)\<^sup>T\<^sup>\<star> * x - p0\<^sup>T\<^sup>\<star> * x\<longmapsto>(p0 * p0)\<^sup>T] = p0"
       by (smt (z3) inf.le_iff_sup inf_commute maddux_3_11_pp p_antitone_inf pseudo_complement)
     show "univalent p0" "total p0" "acyclic (p0 - 1)"
       using 1 find_set_precondition_def by auto
   qed
 qed
 
 lemma path_halving_2:
   "path_halving_invariant p x y p0 \<and> y \<noteq> p[[y]] \<Longrightarrow> path_halving_invariant (p[y\<longmapsto>p[[p[[y]]]]]) x ((p[y\<longmapsto>p[[p[[y]]]]])[[y]]) p0 \<and> ((p[y\<longmapsto>p[[p[[y]]]]])\<^sup>T\<^sup>\<star> * ((p[y\<longmapsto>p[[p[[y]]]]])[[y]]))\<down> < (p\<^sup>T\<^sup>\<star> * y)\<down>"
 proof -
   let ?py = "p[[y]]"
   let ?ppy = "p[[?py]]"
   let ?pyppy = "p[y\<longmapsto>?ppy]"
   let ?p2 = "p0 * p0"
   let ?p2t = "?p2\<^sup>T"
   let ?p2ts = "?p2t\<^sup>\<star>"
   let ?px = "?p2ts * x"
   let ?py2 = "-(p0\<^sup>T\<^sup>\<star> * y)"
   let ?pxy = "?px \<sqinter> ?py2"
   let ?p = "p0[?pxy\<longmapsto>?p2t]"
   let ?pty = "p0\<^sup>T * y"
   let ?pt2y = "p0\<^sup>T * p0\<^sup>T * y"
   let ?pt2sy = "p0\<^sup>T\<^sup>\<star> * p0\<^sup>T * p0\<^sup>T * y"
   assume 1: "path_halving_invariant p x y p0 \<and> y \<noteq> ?py"
   have 2: "point ?pty \<and> point ?pt2y"
     using 1 by (smt (verit) comp_associative read_injective read_surjective path_halving_invariant_def)
   show "path_halving_invariant ?pyppy x (?pyppy[[y]]) p0 \<and> (?pyppy\<^sup>T\<^sup>\<star> * (?pyppy[[y]]))\<down> < (p\<^sup>T\<^sup>\<star> * y)\<down>"
   proof
     show "path_halving_invariant ?pyppy x (?pyppy[[y]]) p0"
     proof (unfold path_halving_invariant_def, intro conjI)
       show 3: "find_set_precondition ?pyppy x"
       proof (unfold find_set_precondition_def, intro conjI)
         show "univalent ?pyppy"
           using 1 find_set_precondition_def read_injective update_univalent path_halving_invariant_def by auto
         show "total ?pyppy"
           using 1 bijective_regular find_set_precondition_def read_surjective update_total path_halving_invariant_def by force
         show "acyclic (?pyppy - 1)"
           apply (rule update_acyclic_3)
           using 1 find_set_precondition_def path_halving_invariant_def apply blast
           using 1 2 comp_associative path_halving_invariant_aux(2) apply force
           using 1 path_halving_invariant_def apply blast
           by (metis inf.order_lesseq_imp mult_isotone star.circ_increasing star.circ_square mult_assoc)
         show "vector x" "injective x" "surjective x"
           using 1 find_set_precondition_def path_halving_invariant_def by auto
       qed
       show "vector (?pyppy[[y]])"
         using 1 comp_associative path_halving_invariant_def by auto
       show "injective (?pyppy[[y]])"
         using 1 3 read_injective path_halving_invariant_def find_set_precondition_def by auto
       show "surjective (?pyppy[[y]])"
         using 1 3 read_surjective path_halving_invariant_def find_set_precondition_def by auto
       show "?pyppy[[y]] \<le> ?pyppy\<^sup>T\<^sup>\<star> * x"
       proof -
         have "y = (y \<sqinter> p\<^sup>T\<^sup>\<star>) * x"
           using 1 le_iff_inf vector_inf_comp path_halving_invariant_def by auto
         also have "... = ((y \<sqinter> 1) \<squnion> (y \<sqinter> (p\<^sup>T \<sqinter> -y\<^sup>T)\<^sup>+)) * x"
           using 1 omit_redundant_points_3 path_halving_invariant_def by auto
         also have "... \<le> (1 \<squnion> (y \<sqinter> (p\<^sup>T \<sqinter> -y\<^sup>T)\<^sup>+)) * x"
           using 1 sup_inf_distrib2 vector_inf_comp path_halving_invariant_def by auto
         also have "... \<le> (1 \<squnion> (p\<^sup>T \<sqinter> -y\<^sup>T)\<^sup>+) * x"
           by (simp add: inf.coboundedI2 mult_left_isotone)
         also have "... = (p \<sqinter> -y)\<^sup>T\<^sup>\<star> * x"
           by (simp add: conv_complement conv_dist_inf star_left_unfold_equal)
         also have "... \<le> ?pyppy\<^sup>T\<^sup>\<star> * x"
           by (simp add: conv_isotone inf.sup_monoid.add_commute mult_left_isotone star_isotone)
         finally show ?thesis
           by (metis mult_isotone star.circ_increasing star.circ_transitive_equal mult_assoc)
       qed
       show "?pyppy[[y]] \<le> ?px"
       proof -
         have "?pyppy[[y]] = p[[?py]]"
           using 1 put_get vector_mult_closed path_halving_invariant_def by force
         also have "... = p0[[p0[[y]]]]"
           using 1 path_halving_invariant_aux(2) by blast
         also have "... = ?p2t * y"
           by (simp add: conv_dist_comp mult_assoc)
         also have "... \<le> ?p2t * ?px"
           using 1 path_halving_invariant_def comp_associative mult_right_isotone by force
         also have "... \<le> ?px"
           by (metis comp_associative mult_left_isotone star.left_plus_below_circ)
         finally show ?thesis
           .
       qed
       show "p0[?px - p0\<^sup>T\<^sup>\<star> * (?pyppy[[y]])\<longmapsto>?p2t] = ?pyppy"
       proof -
         have "?px \<sqinter> ?pty = ?px \<sqinter> p0\<^sup>T * ?px \<sqinter> ?pty"
           using 1 inf.absorb2 inf.sup_monoid.add_assoc mult_right_isotone path_halving_invariant_def by force
         also have "... = (?p2ts \<sqinter> p0\<^sup>T * ?p2ts) * x \<sqinter> ?pty"
           using 3 comp_associative find_set_precondition_def injective_comp_right_dist_inf by auto
         also have "... = (1 \<sqinter> p0) * (?p2ts \<sqinter> p0\<^sup>T * ?p2ts) * x \<sqinter> ?pty"
           using 1 even_odd_root mapping_regular path_halving_invariant_def by auto
         also have "... \<le> (1 \<sqinter> p0) * top \<sqinter> ?pty"
           by (metis comp_associative comp_inf.mult_left_isotone comp_inf.star.circ_sub_dist_2 comp_left_subdist_inf dual_order.trans mult_right_isotone)
         also have 4: "... = (1 \<sqinter> p0\<^sup>T) * ?pty"
           using coreflexive_comp_top_inf one_inf_conv by auto
         also have "... \<le> ?pt2y"
           by (simp add: mult_assoc mult_left_isotone)
         finally have 5: "?px \<sqinter> ?pty \<le> ?pt2y"
           .
         have 6: "p[?px \<sqinter> -?pt2sy \<sqinter> ?pty\<longmapsto>?p2t] = p"
         proof (cases "?pty \<le> ?px \<sqinter> -?pt2sy")
           case True
           hence "?pty \<le> ?pt2y"
             using 5 conv_dist_comp inf.absorb2 by auto
           hence 7: "?pty = ?pt2y"
             using 2 epm_3 by fastforce
           have "p[?px \<sqinter> -?pt2sy \<sqinter> ?pty\<longmapsto>?p2t] = p[?pty\<longmapsto>?p2t]"
             using True inf.absorb2 by auto
           also have "... = p[?pty\<longmapsto>?p2[[?pty]]]"
             using 2 update_point_get by auto
           also have "... = p[?pty\<longmapsto>p0\<^sup>T * p0\<^sup>T * p0\<^sup>T * y]"
             using comp_associative conv_dist_comp by auto
           also have "... = p[?pty\<longmapsto>?pt2y]"
             using 7 mult_assoc by simp
           also have "... = p[?pty\<longmapsto>p[[?pty]]]"
             using 1 path_halving_invariant_aux(1,2) mult_assoc by force
           also have "... = p"
             using 2 get_put by auto
           finally show ?thesis
             .
         next
           case False
           have "mapping ?p2"
             using 1 mapping_mult_closed path_halving_invariant_def by blast
           hence 8: "regular (?px \<sqinter> -?pt2sy)"
             using 1 bijective_regular find_set_precondition_def mapping_regular pp_dist_comp regular_closed_star regular_conv_closed path_halving_invariant_def by auto
           have "vector (?px \<sqinter> -?pt2sy)"
             using 1 find_set_precondition_def vector_complement_closed vector_inf_closed vector_mult_closed path_halving_invariant_def by force
           hence "?pty \<le> -(?px \<sqinter> -?pt2sy)"
             using 2 8 point_in_vector_or_complement False by blast
           hence "?px \<sqinter> -?pt2sy \<sqinter> ?pty = bot"
             by (simp add: p_antitone_iff pseudo_complement)
           thus ?thesis
             by simp
         qed
         have 9: "p[?px \<sqinter> -?pt2sy \<sqinter> y\<longmapsto>?p2t] = ?pyppy"
         proof (cases "y \<le> -?pt2sy")
           case True
           hence "p[?px \<sqinter> -?pt2sy \<sqinter> y\<longmapsto>?p2t] = p[y\<longmapsto>?p2t]"
             using 1 inf.absorb2 path_halving_invariant_def by auto
           also have "... = ?pyppy"
             using 1 by (metis comp_associative conv_dist_comp path_halving_invariant_aux(2) path_halving_invariant_def update_point_get)
           finally show ?thesis
             .
         next
           case False
           have "vector (-?pt2sy)"
             using 1 vector_complement_closed vector_mult_closed path_halving_invariant_def by blast
           hence 10: "y \<le> ?pt2sy"
             using 1 by (smt (verit, del_insts) False bijective_regular point_in_vector_or_complement regular_closed_star regular_mult_closed total_conv_surjective univalent_conv_injective path_halving_invariant_def)
           hence "?px \<sqinter> -?pt2sy \<sqinter> y = bot"
             by (simp add: inf.coboundedI2 p_antitone pseudo_complement)
           hence 11: "p[?px \<sqinter> -?pt2sy \<sqinter> y\<longmapsto>?p2t] = p"
             by simp
           have "y \<le> p0\<^sup>T\<^sup>+ * y"
             using 10 by (metis mult_left_isotone order_lesseq_imp star.circ_plus_same star.left_plus_below_circ)
           hence 12: "y = root p0 y"
             using 1 loop_root_2 path_halving_invariant_def by blast
           have "?pyppy = p[y\<longmapsto>p0[[p0[[y]]]]]"
             using 1 path_halving_invariant_aux(2) by force
           also have "... = p[y\<longmapsto>p0[[y]]]"
             using 1 12 by (metis root_successor_loop path_halving_invariant_def)
           also have "... = p[y\<longmapsto>?py]"
             using 1 path_halving_invariant_aux(1) by force
           also have "... = p"
             using 1 get_put path_halving_invariant_def by blast
           finally show ?thesis
             using 11 by simp
         qed
         have 13: "-?pt2sy = -(p0\<^sup>T\<^sup>\<star> * y) \<squnion> (-?pt2sy \<sqinter> ?pty) \<squnion> (-?pt2sy \<sqinter> y)"
         proof (rule order.antisym)
           have 14: "regular (p0\<^sup>T\<^sup>\<star> * y) \<and> regular ?pt2sy"
             using 1 by (metis order.antisym conv_complement conv_dist_comp conv_involutive conv_star_commute forest_components_increasing mapping_regular pp_dist_star regular_mult_closed top.extremum path_halving_invariant_def)
           have "p0\<^sup>T\<^sup>\<star> = p0\<^sup>T\<^sup>\<star> * p0\<^sup>T * p0\<^sup>T \<squnion> p0\<^sup>T \<squnion> 1"
             using star.circ_back_loop_fixpoint star.circ_plus_same star_left_unfold_equal sup_commute by auto
           hence "p0\<^sup>T\<^sup>\<star> * y \<le> ?pt2sy \<squnion> ?pty \<squnion> y"
             by (metis inf.eq_refl mult_1_left mult_right_dist_sup)
           also have "... = ?pt2sy \<squnion> (-?pt2sy \<sqinter> ?pty) \<squnion> y"
             using 14 by (metis maddux_3_21_pp)
           also have "... = ?pt2sy \<squnion> (-?pt2sy \<sqinter> ?pty) \<squnion> (-?pt2sy \<sqinter> y)"
             using 14 by (smt (z3) maddux_3_21_pp sup.left_commute sup_assoc)
           hence "p0\<^sup>T\<^sup>\<star> * y \<sqinter> -?pt2sy \<le> (-?pt2sy \<sqinter> ?pty) \<squnion> (-?pt2sy \<sqinter> y)"
             using calculation half_shunting sup_assoc sup_commute by auto
           thus "-?pt2sy \<le> -(p0\<^sup>T\<^sup>\<star> * y) \<squnion> (-?pt2sy \<sqinter> ?pty) \<squnion> (-?pt2sy \<sqinter> y)"
             using 14 by (smt (z3) inf.sup_monoid.add_commute shunting_var_p sup.left_commute sup_commute)
           have "-(p0\<^sup>T\<^sup>\<star> * y) \<le> -?pt2sy"
             by (meson mult_left_isotone order.trans p_antitone star.right_plus_below_circ)
           thus "-(p0\<^sup>T\<^sup>\<star> * y) \<squnion> (-?pt2sy \<sqinter> ?pty) \<squnion> (-?pt2sy \<sqinter> y) \<le> -?pt2sy"
             by simp
         qed
         have "regular ?px" "regular ?pty" "regular y"
           using 1 bijective_regular find_set_precondition_def mapping_regular pp_dist_comp regular_closed_star regular_conv_closed path_halving_invariant_def by auto
         hence 15: "regular (?px \<sqinter> -?pt2sy \<sqinter> ?pty)" "regular (?px \<sqinter> -?pt2sy \<sqinter> y)"
           by auto
         have "p0[?px - p0\<^sup>T\<^sup>\<star> * (?pyppy[[y]])\<longmapsto>?p2t] = p0[?px - p0\<^sup>T\<^sup>\<star> * (p[[?py]])\<longmapsto>?p2t]"
           using 1 put_get vector_mult_closed path_halving_invariant_def by auto
         also have "... = p0[?px - ?pt2sy\<longmapsto>?p2t]"
           using 1 comp_associative path_halving_invariant_aux(2) by force
         also have "... = p0[?pxy \<squnion> (?px \<sqinter> -?pt2sy \<sqinter> ?pty) \<squnion> (?px \<sqinter> -?pt2sy \<sqinter> y)\<longmapsto>?p2t]"
           using 13 by (metis comp_inf.semiring.distrib_left inf.sup_monoid.add_assoc)
         also have "... = (?p[?px \<sqinter> -?pt2sy \<sqinter> ?pty\<longmapsto>?p2t])[?px \<sqinter> -?pt2sy \<sqinter> y\<longmapsto>?p2t]"
           using 15 by (smt (z3) update_same_3 comp_inf.semiring.mult_not_zero inf.sup_monoid.add_assoc inf.sup_monoid.add_commute)
         also have "... = (p[?px \<sqinter> -?pt2sy \<sqinter> ?pty\<longmapsto>?p2t])[?px \<sqinter> -?pt2sy \<sqinter> y\<longmapsto>?p2t]"
           using 1 path_halving_invariant_def by auto
         also have "... = p[?px \<sqinter> -?pt2sy \<sqinter> y\<longmapsto>?p2t]"
           using 6 by simp
         also have "... = ?pyppy"
           using 9 by auto
         finally show ?thesis
           .
       qed
       show "univalent p0" "total p0" "acyclic (p0 - 1)"
         using 1 path_halving_invariant_def by auto
     qed
     let ?s = "{ z . regular z \<and> z \<le> p\<^sup>T\<^sup>\<star> * y }"
     let ?t = "{ z . regular z \<and> z \<le> ?pyppy\<^sup>T\<^sup>\<star> * (?pyppy[[y]]) }"
     have "?pyppy\<^sup>T\<^sup>\<star> * (?pyppy[[y]]) = ?pyppy\<^sup>T\<^sup>\<star> * (p[[?py]])"
       using 1 put_get vector_mult_closed path_halving_invariant_def by force
     also have "... \<le> p\<^sup>+\<^sup>T\<^sup>\<star> * (p[[?py]])"
       using 1 path_halving_invariant_def update_square_plus conv_order mult_left_isotone star_isotone by force
     also have "... = p\<^sup>T\<^sup>\<star> * p\<^sup>T * p\<^sup>T * y"
       by (simp add: conv_plus_commute star.left_plus_circ mult_assoc)
     also have "... \<le> p\<^sup>T\<^sup>+ * y"
       by (metis mult_left_isotone star.left_plus_below_circ star_plus)
     finally have 16: "?pyppy\<^sup>T\<^sup>\<star> * (?pyppy[[y]]) \<le> p\<^sup>T\<^sup>+ * y"
       .
     hence "?pyppy\<^sup>T\<^sup>\<star> * (?pyppy[[y]]) \<le> p\<^sup>T\<^sup>\<star> * y"
       using mult_left_isotone order_lesseq_imp star.left_plus_below_circ by blast
     hence 17: "?t \<subseteq> ?s"
       using order_trans by auto
     have 18: "y \<in> ?s"
       using 1 bijective_regular path_compression_1b path_halving_invariant_def by force
     have 19: "\<not> y \<in> ?t"
     proof
       assume "y \<in> ?t"
       hence "y \<le> ?pyppy\<^sup>T\<^sup>\<star> * (?pyppy[[y]])"
         by simp
       hence "y \<le> p\<^sup>T\<^sup>+ * y"
         using 16 dual_order.trans by blast
       hence "y = root p y"
         using 1 find_set_precondition_def loop_root_2 path_halving_invariant_def by blast
       hence "y = ?py"
         using 1 by (metis find_set_precondition_def root_successor_loop path_halving_invariant_def)
       thus False
         using 1 by simp
     qed
     show "card ?t < card ?s"
       apply (rule psubset_card_mono)
       subgoal using finite_regular by simp
       subgoal using 17 18 19 by auto
       done
   qed
 qed
 
 lemma path_halving_3:
   "path_halving_invariant p x y p0 \<and> y = p[[y]] \<Longrightarrow> path_halving_postcondition p x y p0"
 proof -
   assume 1: "path_halving_invariant p x y p0 \<and> y = p[[y]]"
   show "path_halving_postcondition p x y p0"
   proof (unfold path_halving_postcondition_def path_compression_precondition_def, intro conjI)
     show "univalent p" "total p" "acyclic (p - 1)"
       using 1 find_set_precondition_def path_halving_invariant_def by blast+
     show "vector x" "injective x" "surjective x"
       using 1 find_set_precondition_def path_halving_invariant_def by blast+
     show 2: "vector y" "injective y" "surjective y"
       using 1 path_halving_invariant_def by blast+
     have "find_set_invariant p x y"
       using 1 find_set_invariant_def path_halving_invariant_def by blast
     thus "y = root p x"
       using 1 find_set_3 find_set_postcondition_def by blast
     show "p \<sqinter> 1 = p0 \<sqinter> 1"
       using 1 path_halving_invariant_aux(4) by blast
     show "fc p = fc p0"
       using 1 path_halving_invariant_aux(5) by blast
     have 3: "y = p0[[y]]"
       using 1 path_halving_invariant_aux(1) by auto
     hence "p0\<^sup>T\<^sup>\<star> * y = y"
       using order.antisym path_compression_1b star_left_induct_mult_equal by auto
     hence 4: "p0[(p0 * p0)\<^sup>T\<^sup>\<star> * x - y\<longmapsto>(p0 * p0)\<^sup>T] = p"
       using 1 path_halving_invariant_def by auto
     have "(p0 * p0)\<^sup>T * y = y"
       using 3 mult_assoc conv_dist_comp by auto
     hence "y \<sqinter> p0 * p0 = y \<sqinter> p0"
       using 2 3 by (metis update_postcondition)
     hence 5: "y \<sqinter> p = y \<sqinter> p0 * p0"
       using 1 2 3 by (smt update_postcondition)
     have "p0[(p0 * p0)\<^sup>T\<^sup>\<star> * x\<longmapsto>(p0 * p0)\<^sup>T] = (p0[(p0 * p0)\<^sup>T\<^sup>\<star> * x - y\<longmapsto>(p0 * p0)\<^sup>T])[(p0 * p0)\<^sup>T\<^sup>\<star> * x \<sqinter> y\<longmapsto>(p0 * p0)\<^sup>T]"
       using 1 bijective_regular path_halving_invariant_def update_split by blast
     also have "... = p[(p0 * p0)\<^sup>T\<^sup>\<star> * x \<sqinter> y\<longmapsto>(p0 * p0)\<^sup>T]"
       using 4 by simp
     also have "... = p"
       apply (rule update_same_sub)
       using 5 apply simp
       apply simp
       using 1 bijective_regular inf.absorb2 path_halving_invariant_def by auto
     finally show "p0[(p0 * p0)\<^sup>T\<^sup>\<star> * x\<longmapsto>(p0 * p0)\<^sup>T] = p"
       .
   qed
 qed
 
 theorem find_path_halving:
   "VARS p y
   [ find_set_precondition p x \<and> p0 = p ]
   y := x;
   WHILE y \<noteq> p[[y]]
     INV { path_halving_invariant p x y p0 }
     VAR { (p\<^sup>T\<^sup>\<star> * y)\<down> }
      DO p[y] := p[[p[[y]]]];
         y := p[[y]]
      OD
   [ path_halving_postcondition p x y p0 ]"
   apply vcg_tc_simp
     apply (fact path_halving_1)
    apply (fact path_halving_2)
   by (fact path_halving_3)
 
 subsection \<open>Path Splitting\<close>
 
 text \<open>
 Path splitting is another variant of the path compression technique.
 We implement it again independently of find-set, using a second while-loop which iterates over the same path to the root.
 We prove that path splitting preserves the equivalence-relational semantics of the disjoint-set forest and also preserves the roots of the component trees.
 Additionally we prove the exact effect of path splitting, which is to replace every parent pointer with a pointer to the respective grandparent.
 \<close>
 
 definition "path_splitting_invariant p x y p0 \<equiv> 
   find_set_precondition p x \<and> point y \<and> y \<le> p0\<^sup>T\<^sup>\<star> * x \<and>
   p0[p0\<^sup>T\<^sup>\<star> * x - p0\<^sup>T\<^sup>\<star> * y\<longmapsto>(p0 * p0)\<^sup>T] = p \<and>
   disjoint_set_forest p0"
 definition "path_splitting_postcondition p x y p0 \<equiv> 
   path_compression_precondition p x y \<and> p \<sqinter> 1 = p0 \<sqinter> 1 \<and> fc p = fc p0 \<and>
   p0[p0\<^sup>T\<^sup>\<star> * x\<longmapsto>(p0 * p0)\<^sup>T] = p"
 
 lemma path_splitting_invariant_aux_1:
   assumes "point x"
       and "point y"
       and "disjoint_set_forest p0"
     shows "(p0[p0\<^sup>T\<^sup>\<star> * x - p0\<^sup>T\<^sup>\<star> * y\<longmapsto>(p0 * p0)\<^sup>T]) \<sqinter> 1 = p0 \<sqinter> 1"
       and "fc (p0[p0\<^sup>T\<^sup>\<star> * x - p0\<^sup>T\<^sup>\<star> * y\<longmapsto>(p0 * p0)\<^sup>T]) = fc p0"
       and "p0\<^sup>T\<^sup>\<star> * x \<le> p0\<^sup>\<star> * root p0 x"
 proof -
   let ?p2 = "p0 * p0"
   let ?p2t = "?p2\<^sup>T"
   let ?px = "p0\<^sup>T\<^sup>\<star> * x"
   let ?py = "-(p0\<^sup>T\<^sup>\<star> * y)"
   let ?pxy = "?px \<sqinter> ?py"
   let ?q1 = "?pxy \<sqinter> p0"
   let ?q2 = "-?pxy \<sqinter> p0"
   let ?q3 = "?pxy \<sqinter> ?p2"
   let ?q4 = "-?pxy \<sqinter> ?p2"
   let ?p = "p0[?pxy\<longmapsto>?p2t]"
   let ?r0 = "root p0 x"
   let ?rp = "root ?p x"
   have 1: "regular ?px \<and> regular (p0\<^sup>T\<^sup>\<star> * y) \<and> regular ?pxy"
     using assms bijective_regular find_set_precondition_def mapping_regular pp_dist_comp regular_closed_star regular_conv_closed path_halving_invariant_def regular_closed_inf by auto
   have 2: "vector x \<and> vector ?px \<and> vector ?py \<and> vector ?pxy"
     using assms(1,2) find_set_precondition_def vector_complement_closed vector_mult_closed path_halving_invariant_def vector_inf_closed by auto
   have 3: "?r0 \<le> p0 * ?r0"
     by (metis assms(3) dedekind_1 inf.le_iff_sup root_successor_loop top_greatest)
   hence "?pxy \<sqinter> p0 * ?r0 \<le> ?pxy \<sqinter> ?p2 * ?r0"
     by (metis comp_associative inf.eq_refl inf.sup_right_isotone mult_isotone)
   hence 4: "?q1 * ?r0 \<le> ?q3 * ?r0"
     using 2 by (simp add: vector_inf_comp)
   have 5: "?q1 * ?q2 \<le> ?q3"
     using 2 by (smt (z3) comp_isotone inf.cobounded1 inf.cobounded2 inf_greatest vector_export_comp)
   have "?q1 * ?q2\<^sup>\<star> * ?r0 = ?q1 * ?r0 \<squnion> ?q1 * ?q2 * ?q2\<^sup>\<star> * ?r0"
     by (metis comp_associative semiring.distrib_left star.circ_loop_fixpoint sup_commute)
   also have "... \<le> ?q1 * ?r0 \<squnion> ?q3 * ?q2\<^sup>\<star> * ?r0"
     using 5 by (meson mult_left_isotone sup_right_isotone)
   also have "... \<le> ?q3 * ?r0 \<squnion> ?q3 * ?q2\<^sup>\<star> * ?r0"
     using 4 sup_left_isotone by blast
   also have "... = ?q3 * ?q2\<^sup>\<star> * ?r0"
     by (smt (verit, del_insts) comp_associative semiring.distrib_left star.circ_loop_fixpoint star.circ_transitive_equal star_involutive sup_commute)
   finally have 6: "?q1 * ?q2\<^sup>\<star> * ?r0 \<le> ?q3 * ?q2\<^sup>\<star> * ?r0"
     .
   have "?q1 * (-?pxy \<sqinter> p0\<^sup>+) * ?pxy \<le> (?px \<sqinter> p0) * (-?pxy \<sqinter> p0\<^sup>+) * ?pxy"
     by (meson comp_inf.comp_left_subdist_inf inf.boundedE mult_left_isotone)
   also have "... \<le> (?px \<sqinter> p0) * (-?pxy \<sqinter> p0\<^sup>+) * ?py"
     by (simp add: mult_right_isotone)
   also have "... \<le> ?px\<^sup>T * (-?pxy \<sqinter> p0\<^sup>+) * ?py"
   proof -
     have "?px \<sqinter> p0 \<le> ?px\<^sup>T * p0"
       using 2 by (simp add: vector_restrict_comp_conv)
     also have "... \<le> ?px\<^sup>T"
       by (metis comp_associative conv_dist_comp conv_involutive conv_star_commute mult_right_isotone star.circ_increasing star.circ_transitive_equal)
     finally show ?thesis
       using mult_left_isotone by auto
   qed
   also have "... = top * (?px \<sqinter> -?pxy \<sqinter> p0\<^sup>+) * ?py"
     using 2 by (smt (z3) comp_inf.star_plus conv_dist_inf covector_inf_comp_3 inf_top.right_neutral vector_complement_closed vector_inf_closed)
   also have "... \<le> top * (-?py \<sqinter> p0\<^sup>+) * ?py"
     by (metis comp_inf.comp_isotone comp_isotone inf.cobounded2 inf.eq_refl inf_import_p)
   also have "... = top * (-?py \<sqinter> p0\<^sup>+ \<sqinter> ?py\<^sup>T) * top"
     using 2 by (simp add: comp_associative covector_inf_comp_3)
   also have "... = bot"
   proof -
     have "p0\<^sup>T\<^sup>\<star> * y - y\<^sup>T * p0\<^sup>\<star> = p0\<^sup>T\<^sup>\<star> * y * y\<^sup>T * -p0\<^sup>\<star>"
       using 2 by (metis assms(2) bijective_conv_mapping comp_mapping_complement vector_covector vector_export_comp vector_mult_closed)
     also have "... \<le> p0\<^sup>T\<^sup>\<star> * -p0\<^sup>\<star>"
       by (meson assms(2) mult_left_isotone order_refl shunt_bijective)
     also have "... \<le> -p0\<^sup>\<star>"
       by (simp add: conv_complement conv_star_commute pp_increasing schroeder_6_p star.circ_transitive_equal)
     also have "... \<le> -p0\<^sup>+"
       by (simp add: p_antitone star.left_plus_below_circ)
     finally have "-?py \<sqinter> p0\<^sup>+ \<sqinter> ?py\<^sup>T = bot"
       by (metis comp_inf.p_pp_comp conv_complement conv_dist_comp conv_involutive conv_star_commute p_shunting_swap pp_isotone pseudo_complement_pp regular_closed_p)
     thus ?thesis
       by simp
   qed
   finally have 7: "?q1 * (-?pxy \<sqinter> p0\<^sup>+) * ?pxy = bot"
     using le_bot by blast
   have "?q2\<^sup>+ \<le> -?pxy"
     using 2 by (smt (z3) comp_isotone complement_conv_sub inf.order_trans inf.sup_right_divisibility inf_commute symmetric_top_closed top_greatest)
   hence "?q2\<^sup>+ \<le> -?pxy \<sqinter> p0\<^sup>+"
     by (simp add: comp_isotone star_isotone)
   hence 8: "?q1 * ?q2\<^sup>+ * ?pxy = bot"
     using 7 mult_left_isotone mult_right_isotone le_bot by auto
   have "?q1 * ?q2\<^sup>+ * ?q3\<^sup>\<star> = ?q1 * ?q2\<^sup>+ \<squnion> ?q1 * ?q2\<^sup>+ * ?q3\<^sup>+"
     by (smt (z3) comp_associative star.circ_back_loop_fixpoint star.circ_plus_same sup_commute)
   also have "... \<le> ?q1 * ?q2\<^sup>+ \<squnion> ?q1 * ?q2\<^sup>+ * ?pxy"
     using 2 by (smt (z3) inf.cobounded1 mult_right_isotone sup_right_isotone vector_inf_comp)
   finally have 9: "?q1 * ?q2\<^sup>+ * ?q3\<^sup>\<star> \<le> ?q1 * ?q2\<^sup>+"
     using 8 by simp
   have 10: "?q1 * ?q4 * ?pxy = bot"
   proof -
     have "?p2 \<le> p0\<^sup>+"
       by (simp add: mult_right_isotone star.circ_increasing)
     thus ?thesis
       using 7 by (metis mult_left_isotone mult_right_isotone le_bot comp_inf.comp_isotone eq_refl)
   qed
   have 11: "?q1 * ?q2 * ?pxy = bot"
   proof -
     have "p0 \<le> p0\<^sup>+"
       by (simp add: star.circ_mult_increasing)
     thus ?thesis
       using 7 by (metis mult_left_isotone mult_right_isotone le_bot comp_inf.comp_isotone eq_refl)
   qed
   have 12: "?q2 \<le> p0 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star>"
     by (smt (verit, del_insts) conv_dist_comp conv_order conv_star_commute inf.coboundedI1 inf.orderE inf.sup_monoid.add_commute path_compression_1b)
   have "?q3 * p0 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> = ?q1 * p0 * p0 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star>"
     using 2 vector_inf_comp by auto
   also have "... = ?q1 * (?q3 \<squnion> ?q4) * ?q3\<^sup>\<star> * ?q2\<^sup>\<star>"
     using 1 by (smt (z3) comp_associative comp_inf.mult_right_dist_sup comp_inf.star_slide inf_top.right_neutral regular_complement_top)
   also have "... = ?q1 * ?q3 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> \<squnion> ?q1 * ?q4 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star>"
     using mult_left_dist_sup mult_right_dist_sup by auto
   also have "... \<le> ?q1 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> \<squnion> ?q1 * ?q4 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star>"
     by (smt (z3) mult_left_isotone mult_left_sub_dist_sup_right sup_left_isotone sup_right_divisibility mult_assoc star.left_plus_below_circ)
   also have "... = ?q1 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> \<squnion> ?q1 * ?q4 * ?q2\<^sup>\<star> \<squnion> ?q1 * ?q4 * ?q3\<^sup>+ * ?q2\<^sup>\<star>"
     by (smt (z3) semiring.combine_common_factor star.circ_back_loop_fixpoint star_plus sup_monoid.add_commute mult_assoc)
   also have "... \<le> ?q1 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> \<squnion> ?q1 * ?q4 * ?q2\<^sup>\<star> \<squnion> ?q1 * ?q4 * ?pxy * ?q3\<^sup>\<star> * ?q2\<^sup>\<star>"
     by (smt (verit, ccfv_threshold) comp_isotone inf.sup_right_divisibility inf_commute order.refl semiring.add_left_mono mult_assoc)
   also have "... = ?q1 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> \<squnion> ?q1 * ?q4 * ?q2\<^sup>\<star>"
     using 10 by simp
   also have "... = ?q1 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> \<squnion> ?q1 * ?q2 * p0 * ?q2\<^sup>\<star>"
     using 2 by (smt vector_complement_closed vector_inf_comp mult_assoc)
   also have "... = ?q1 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> \<squnion> ?q1 * ?q2 * (?q2 \<squnion> ?q1) * ?q2\<^sup>\<star>"
     using 1 by (smt (z3) comp_associative comp_inf.mult_right_dist_sup comp_inf.star_slide inf_top.right_neutral regular_complement_top)
   also have "... = ?q1 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> \<squnion> ?q1 * ?q2 * ?q2 * ?q2\<^sup>\<star> \<squnion> ?q1 * ?q2 * ?q1 * ?q2\<^sup>\<star>"
     using mult_left_dist_sup mult_right_dist_sup sup_commute sup_left_commute by auto
   also have "... \<le> ?q1 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> \<squnion> ?q1 * ?q2 * ?q2 * ?q2\<^sup>\<star> \<squnion> ?q1 * ?q2 * ?pxy * ?q2\<^sup>\<star>"
     by (smt (verit, ccfv_threshold) comp_isotone inf.sup_right_divisibility inf_commute order.refl semiring.add_left_mono mult_assoc)
   also have "... = ?q1 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> \<squnion> ?q1 * ?q2 * ?q2 * ?q2\<^sup>\<star>"
     using 11 by simp
   also have "... \<le> ?q1 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> \<squnion> ?q1 * ?q2\<^sup>\<star>"
     by (smt comp_associative comp_isotone mult_right_isotone star.circ_increasing star.circ_transitive_equal star.left_plus_below_circ sup_right_isotone)
   also have "... = ?q1 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star>"
     by (smt (verit, best) comp_associative semiring.distrib_left star.circ_loop_fixpoint star.circ_transitive_equal star_involutive)
   finally have 13: "?q3 * p0 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> \<le> p0 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star>"
     by (meson inf.cobounded2 mult_left_isotone order_lesseq_imp)
   hence "?q3 * p0 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> \<squnion> ?q2 \<le> p0 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star>"
     using 12 by simp
   hence "?q3\<^sup>\<star> * ?q2 \<le> p0 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star>"
     by (simp add: star_left_induct mult_assoc)
   hence "?q1 * ?q3\<^sup>\<star> * ?q2 \<le> ?q1 * p0 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star>"
     by (simp add: comp_associative mult_right_isotone)
   hence "?q1 * ?q3\<^sup>\<star> * ?q2 \<le> ?q3\<^sup>+ * ?q2\<^sup>\<star>"
     using 2 by (simp add: vector_inf_comp)
   hence 14: "?q1 * ?q3\<^sup>\<star> * ?q2 \<le> ?q3\<^sup>\<star> * ?q2\<^sup>\<star>"
     using mult_left_isotone order_lesseq_imp star.left_plus_below_circ by blast
   have "p0 * ?r0 \<le> p0 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     by (metis comp_associative mult_1_right mult_left_isotone mult_right_isotone reflexive_mult_closed star.circ_reflexive)
   hence 15: "?r0 \<le> p0 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     using 3 dual_order.trans by blast
   have "?q3 * p0 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0 \<le> p0 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     using 13 mult_left_isotone by blast
   hence "?q3 * p0 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0 \<squnion> ?r0 \<le> p0 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     using 15 by simp
   hence "?q3\<^sup>\<star> * ?r0 \<le> p0 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     by (simp add: star_left_induct mult_assoc)
   hence "?q1 * ?q3\<^sup>\<star> * ?r0 \<le> ?q1 * p0 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     by (simp add: comp_associative mult_right_isotone)
   hence "?q1 * ?q3\<^sup>\<star> * ?r0 \<le> ?q3\<^sup>+ * ?q2\<^sup>\<star> * ?r0"
     using 2 by (simp add: vector_inf_comp)
   hence 16: "?q1 * ?q3\<^sup>\<star> * ?r0 \<le> ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     using mult_left_isotone order_lesseq_imp star.left_plus_below_circ by blast
   have "?q1 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0 = ?q1 * ?q3\<^sup>\<star> * ?r0 \<squnion> ?q1 * ?q3\<^sup>\<star> * ?q2\<^sup>+ * ?r0"
     by (smt (z3) comp_associative mult_right_dist_sup star.circ_back_loop_fixpoint star.circ_plus_same sup_commute)
   also have "... \<le> ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0 \<squnion> ?q1 * ?q3\<^sup>\<star> * ?q2\<^sup>+ * ?r0"
     using 16 sup_left_isotone by blast
   also have "... \<le> ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0 \<squnion> ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     using 14 by (smt (z3) inf.eq_refl semiring.distrib_right star.circ_transitive_equal sup.absorb2 sup_monoid.add_commute mult_assoc)
   also have "... = ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     by (simp add: comp_associative star.circ_transitive_equal)
   finally have 17: "?q1 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0 \<le> ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     .
   have "?r0 \<le> ?q2\<^sup>\<star> * ?r0"
     using star.circ_loop_fixpoint sup_right_divisibility by auto
   also have "... \<le> ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     using comp_associative star.circ_loop_fixpoint sup_right_divisibility by force
   also have "... \<le> ?q2\<^sup>\<star> * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     using comp_associative star.circ_loop_fixpoint sup_right_divisibility by force
   finally have 18: "?r0 \<le> ?q2\<^sup>\<star> * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     .
   have "p0 * ?q2\<^sup>\<star> * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0 = (?q2 \<squnion> ?q1) * ?q2\<^sup>\<star> * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     using 1 by (smt (z3) comp_inf.mult_right_dist_sup comp_inf.star_plus inf_top.right_neutral regular_complement_top)
   also have "... = ?q2 * ?q2\<^sup>\<star> * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0 \<squnion> ?q1 * ?q2\<^sup>\<star> * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     using mult_right_dist_sup by auto
   also have "... \<le> ?q2\<^sup>\<star> * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0 \<squnion> ?q1 * ?q2\<^sup>\<star> * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     by (smt (z3) comp_left_increasing_sup star.circ_loop_fixpoint sup_left_isotone mult_assoc)
   also have "... = ?q2\<^sup>\<star> * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0 \<squnion> ?q1 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0 \<squnion> ?q1 * ?q2\<^sup>+ * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     by (smt (z3) mult_left_dist_sup semiring.combine_common_factor star.circ_loop_fixpoint sup_monoid.add_commute mult_assoc)
   also have "... \<le> ?q2\<^sup>\<star> * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0 \<squnion> ?q1 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0 \<squnion> ?q1 * ?q2\<^sup>+ * ?q2\<^sup>\<star> * ?r0"
     using 9 mult_left_isotone sup_right_isotone by auto
   also have "... \<le> ?q2\<^sup>\<star> * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0 \<squnion> ?q1 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0 \<squnion> ?q1 * ?q2\<^sup>\<star> * ?r0"
     by (smt (z3) comp_associative comp_isotone inf.eq_refl semiring.add_right_mono star.circ_transitive_equal star.left_plus_below_circ sup_commute)
   also have "... \<le> ?q2\<^sup>\<star> * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0 \<squnion> ?q1 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0 \<squnion> ?q3 * ?q2\<^sup>\<star> * ?r0"
     using 6 sup_right_isotone by blast
   also have "... = ?q2\<^sup>\<star> * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0 \<squnion> ?q3 * ?q2\<^sup>\<star> * ?r0"
     using 17 by (smt (z3) le_iff_sup semiring.combine_common_factor semiring.distrib_right star.circ_loop_fixpoint sup_monoid.add_commute)
   also have "... \<le> ?q2\<^sup>\<star> * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0 \<squnion> ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     by (meson mult_left_isotone star.circ_increasing sup_right_isotone)
   also have "... = ?q2\<^sup>\<star> * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     by (smt (z3) comp_associative star.circ_loop_fixpoint star.circ_transitive_equal star_involutive)
   finally have "p0 * ?q2\<^sup>\<star> * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0 \<squnion> ?r0 \<le> ?q2\<^sup>\<star> * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     using 18 sup.boundedI by blast
   hence "p0\<^sup>\<star> * ?r0 \<le> ?q2\<^sup>\<star> * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     by (simp add: comp_associative star_left_induct)
   also have "... \<le> ?p\<^sup>\<star> * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     by (metis mult_left_isotone star.circ_sub_dist sup_commute)
   also have "... \<le> ?p\<^sup>\<star> * ?p\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     by (simp add: mult_left_isotone mult_right_isotone star_isotone)
   also have "... \<le> ?p\<^sup>\<star> * ?p\<^sup>\<star> * ?p\<^sup>\<star> * ?r0"
     by (metis mult_isotone order.refl star.circ_sub_dist sup_commute)
   finally have 19: "p0\<^sup>\<star> * ?r0 \<le> ?p\<^sup>\<star> * ?r0"
     by (simp add: star.circ_transitive_equal)
   have 20: "?p\<^sup>\<star> \<le> p0\<^sup>\<star>"
     by (metis star.left_plus_circ star_isotone update_square_ub_plus)
   hence 21: "p0\<^sup>\<star> * ?r0 = ?p\<^sup>\<star> * ?r0"
     using 19 order.antisym mult_left_isotone by auto
   have "?p \<sqinter> 1 = (?q3 \<sqinter> 1) \<squnion> (?q2 \<sqinter> 1)"
     using comp_inf.semiring.distrib_right conv_involutive by auto
   also have "... = (?q1 \<sqinter> 1) \<squnion> (?q2 \<sqinter> 1)"
     using assms(3) acyclic_square path_splitting_invariant_def inf.sup_monoid.add_assoc by auto
   also have "... = (?pxy \<squnion> -?pxy) \<sqinter> p0 \<sqinter> 1"
     using inf_sup_distrib2 by auto
   also have "... = p0 \<sqinter> 1"
     using 1 by (metis inf.sup_monoid.add_commute inf_sup_distrib1 maddux_3_11_pp)
   finally show 22: "?p \<sqinter> 1 = p0 \<sqinter> 1"
     .
   have "?p\<^sup>T\<^sup>\<star> * x \<le> p0\<^sup>T\<^sup>\<star> * x"
     using 20 by (metis conv_isotone conv_star_commute mult_left_isotone)
   hence 23: "?rp \<le> ?r0"
     using 22 comp_inf.mult_left_isotone by auto
   have 24: "disjoint_set_forest ?p"
     using 1 2 assms(3) disjoint_set_forest_update_square by blast
   hence 25: "point ?rp"
     using root_point assms(1) by auto
   have "?r0 * ?rp\<^sup>T = ?r0 * x\<^sup>T * ?p\<^sup>\<star> * (?p \<sqinter> 1)"
     by (smt (z3) comp_associative conv_dist_comp conv_dist_inf conv_involutive conv_star_commute inf.sup_monoid.add_commute one_inf_conv root_var star_one star_sup_one wcc_one)
   also have "... \<le> (p0 \<sqinter> 1) * p0\<^sup>T\<^sup>\<star> * 1 * ?p\<^sup>\<star> * (?p \<sqinter> 1)"
     by (smt (z3) assms(1) comp_associative mult_left_isotone mult_right_isotone root_var)
   also have "... \<le> (p0 \<sqinter> 1) * p0\<^sup>T\<^sup>\<star> * p0\<^sup>\<star> * (p0 \<sqinter> 1)"
     using 20 22 comp_isotone by force
   also have "... = (p0 \<sqinter> 1) * p0\<^sup>\<star> * (p0 \<sqinter> 1) \<squnion> (p0 \<sqinter> 1) * p0\<^sup>T\<^sup>\<star> * (p0 \<sqinter> 1)"
     by (simp add: assms(3) cancel_separate_eq sup_monoid.add_commute mult_assoc mult_left_dist_sup semiring.distrib_right)
   also have "... = (p0 \<sqinter> 1) * (p0 \<sqinter> 1) \<squnion> (p0 \<sqinter> 1) * p0\<^sup>T\<^sup>\<star> * (p0 \<sqinter> 1)"
     using univalent_root_successors assms(3) by simp
   also have "... = (p0 \<sqinter> 1) * (p0 \<sqinter> 1) \<squnion> (p0 \<sqinter> 1) * ((p0 \<sqinter> 1) * p0\<^sup>\<star>)\<^sup>T"
     by (smt (z3) comp_associative conv_dist_comp conv_dist_inf conv_star_commute inf.sup_monoid.add_commute one_inf_conv star_one star_sup_one wcc_one)
   also have "... = (p0 \<sqinter> 1) * (p0 \<sqinter> 1)"
     by (metis univalent_root_successors assms(3) conv_dist_inf inf.sup_monoid.add_commute one_inf_conv sup_idem symmetric_one_closed)
   also have "... \<le> 1"
     by (simp add: coreflexive_mult_closed)
   finally have "?r0 * ?rp\<^sup>T \<le> 1"
     .
   hence "?r0 \<le> 1 * ?rp"
     using 25 shunt_bijective by blast
   hence 26: "?r0 = ?rp"
     using 23 order.antisym by simp
   have "?px * ?r0\<^sup>T = ?px * x\<^sup>T * p0\<^sup>\<star> * (p0 \<sqinter> 1)"
     by (smt (z3) comp_associative conv_dist_comp conv_dist_inf conv_involutive conv_star_commute inf.sup_monoid.add_commute one_inf_conv root_var star_one star_sup_one wcc_one)
   also have "... \<le> p0\<^sup>T\<^sup>\<star> * 1 * p0\<^sup>\<star> * (p0 \<sqinter> 1)"
     by (smt (z3) assms(1) comp_associative mult_left_isotone mult_right_isotone root_var)
   also have "... = p0\<^sup>\<star> * (p0 \<sqinter> 1) \<squnion> p0\<^sup>T\<^sup>\<star> * (p0 \<sqinter> 1)"
     by (simp add: assms(3) cancel_separate_eq sup_monoid.add_commute mult_right_dist_sup)
   also have "... = p0\<^sup>\<star> * (p0 \<sqinter> 1) \<squnion> ((p0 \<sqinter> 1) * p0\<^sup>\<star>)\<^sup>T"
     by (smt (z3) conv_dist_comp conv_dist_inf conv_star_commute inf.sup_monoid.add_commute one_inf_conv star_one star_sup_one wcc_one)
   also have "... = p0\<^sup>\<star> * (p0 \<sqinter> 1) \<squnion> (p0 \<sqinter> 1)"
     by (metis univalent_root_successors assms(3) conv_dist_inf inf.sup_monoid.add_commute one_inf_conv symmetric_one_closed)
   also have "... = p0\<^sup>\<star> * (p0 \<sqinter> 1)"
     by (metis conv_involutive path_compression_1b sup.absorb2 sup_commute)
   also have "... \<le> p0\<^sup>\<star>"
     by (simp add: inf.coboundedI1 star.circ_increasing star.circ_mult_upper_bound)
   finally have 27: "?px * ?r0\<^sup>T \<le> p0\<^sup>\<star>"
     .
   thus 28: "?px \<le> p0\<^sup>\<star> * ?r0"
     by (simp add: assms(1,3) root_point shunt_bijective)
   have 29: "point ?r0"
     using root_point assms(1,3) by auto
   hence 30: "mapping (?r0\<^sup>T)"
     using bijective_conv_mapping by blast
   have "?r0 * (?px \<sqinter> p0) = ?r0 * top * (?px \<sqinter> p0)"
     using 29 by force
   also have "... = ?r0 * ?px\<^sup>T * p0"
     using 29 by (metis assms(1) covector_inf_comp_3 vector_covector vector_mult_closed)
   also have "... = ?r0 * x\<^sup>T * p0\<^sup>\<star> * p0"
     using comp_associative conv_dist_comp conv_star_commute by auto
   also have "... \<le> ?r0 * x\<^sup>T * p0\<^sup>\<star>"
     by (simp add: comp_associative mult_right_isotone star.circ_plus_same star.left_plus_below_circ)
   also have "... = ?r0 * ?px\<^sup>T"
     by (simp add: comp_associative conv_dist_comp conv_star_commute)
   also have "... = (?px * ?r0\<^sup>T)\<^sup>T"
     by (simp add: conv_dist_comp)
   also have "... \<le> p0\<^sup>T\<^sup>\<star>"
     using 27 conv_isotone conv_star_commute by fastforce
   finally have "?r0 * (?px \<sqinter> p0) \<le> p0\<^sup>T\<^sup>\<star>"
     .
   hence "?px \<sqinter> p0 \<le> ?r0\<^sup>T * p0\<^sup>T\<^sup>\<star>"
     using 30 shunt_mapping by auto
   hence "?px \<sqinter> p0 \<le> p0\<^sup>\<star> * ?r0 \<sqinter> ?r0\<^sup>T * p0\<^sup>T\<^sup>\<star>"
     using 28 inf.coboundedI2 inf.sup_monoid.add_commute by fastforce
   also have "... = p0\<^sup>\<star> * ?r0 * ?r0\<^sup>T * p0\<^sup>T\<^sup>\<star>"
     using 29 by (smt (z3) vector_covector vector_inf_comp vector_mult_closed)
   also have "... = ?p\<^sup>\<star> * ?r0 * ?r0\<^sup>T * ?p\<^sup>T\<^sup>\<star>"
     using 21 by (smt comp_associative conv_dist_comp conv_star_commute)
   also have "... = ?p\<^sup>\<star> * ?rp * ?rp\<^sup>T * ?p\<^sup>T\<^sup>\<star>"
     using 26 by auto
   also have "... \<le> ?p\<^sup>\<star> * 1 * ?p\<^sup>T\<^sup>\<star>"
     using 25 by (smt (z3) comp_associative mult_left_isotone mult_right_isotone)
   finally have 31: "?px \<sqinter> p0 \<le> fc ?p"
     by auto
   have "-?px \<sqinter> p0 \<le> ?p"
     by (simp add: inf.sup_monoid.add_commute le_supI1 sup_commute)
   also have "... \<le> fc ?p"
     using fc_increasing by auto
   finally have "p0 \<le> fc ?p"
     using 1 31 by (smt (z3) inf.sup_monoid.add_commute maddux_3_11_pp semiring.add_left_mono sup.orderE sup_commute)
   also have "... \<le> wcc ?p"
     using star.circ_sub_dist_3 by auto
   finally have 32: "wcc p0 \<le> wcc ?p"
     using wcc_below_wcc by blast
   have "?p \<le> wcc p0"
     by (simp add: inf.coboundedI1 inf.sup_monoid.add_commute star.circ_mult_upper_bound star.circ_sub_dist_1)
   hence "wcc ?p \<le> wcc p0"
     using wcc_below_wcc by blast
   hence "wcc ?p = wcc p0"
     using 32 order.antisym by blast
   thus "fc ?p = fc p0"
     using 24 assms(3) fc_wcc by auto
 qed
 
 lemma path_splitting_invariant_aux:
   assumes "path_splitting_invariant p x y p0"
   shows "p[[y]] = p0[[y]]"
     and "p[[p[[y]]]] = p0[[p0[[y]]]]"
     and "p[[p[[p[[y]]]]]] = p0[[p0[[p0[[y]]]]]]"
     and "p \<sqinter> 1 = p0 \<sqinter> 1"
     and "fc p = fc p0"
 proof -
   let ?p2 = "p0 * p0"
   let ?p2t = "?p2\<^sup>T"
   let ?px = "p0\<^sup>T\<^sup>\<star> * x"
   let ?py = "-(p0\<^sup>T\<^sup>\<star> * y)"
   let ?pxy = "?px \<sqinter> ?py"
   let ?p = "p0[?pxy\<longmapsto>?p2t]"
   have "?p[[y]] = p0[[y]]"
     apply (rule put_get_different_vector)
     using assms find_set_precondition_def vector_complement_closed vector_inf_closed vector_mult_closed path_splitting_invariant_def apply force
     by (meson inf.cobounded2 order_lesseq_imp p_antitone_iff path_compression_1b)
   thus 1: "p[[y]] = p0[[y]]"
     using assms path_splitting_invariant_def by auto
   have "?p[[p0[[y]]]] = p0[[p0[[y]]]]"
     apply (rule put_get_different_vector)
     using assms find_set_precondition_def vector_complement_closed vector_inf_closed vector_mult_closed path_splitting_invariant_def apply force
     by (metis comp_isotone inf.boundedE inf.coboundedI2 inf.eq_refl p_antitone_iff selection_closed_id star.circ_increasing)
   thus 2: "p[[p[[y]]]] = p0[[p0[[y]]]]"
     using 1 assms path_splitting_invariant_def by auto
   have "?p[[p0[[p0[[y]]]]]] = p0[[p0[[p0[[y]]]]]]"
     apply (rule put_get_different_vector)
     using assms find_set_precondition_def vector_complement_closed vector_inf_closed vector_mult_closed path_splitting_invariant_def apply force
     by (metis comp_associative comp_isotone conv_dist_comp conv_involutive conv_order inf.coboundedI2 inf.le_iff_sup mult_left_isotone p_antitone_iff p_antitone_inf star.circ_increasing star.circ_transitive_equal)
   thus "p[[p[[p[[y]]]]]] = p0[[p0[[p0[[y]]]]]]"
     using 2 assms path_splitting_invariant_def by auto
   show "p \<sqinter> 1 = p0 \<sqinter> 1"
     using assms path_splitting_invariant_aux_1(1) path_splitting_invariant_def find_set_precondition_def by auto
   show "fc p = fc p0"
     using assms path_splitting_invariant_aux_1(2) path_splitting_invariant_def find_set_precondition_def by auto
 qed
 
 lemma path_splitting_1:
   "find_set_precondition p0 x \<Longrightarrow> path_splitting_invariant p0 x x p0"
 proof -
   assume 1: "find_set_precondition p0 x"
   show "path_splitting_invariant p0 x x p0"
   proof (unfold path_splitting_invariant_def, intro conjI)
     show "find_set_precondition p0 x"
       using 1 by simp
     show "vector x" "injective x" "surjective x"
       using 1 find_set_precondition_def by auto
     show "x \<le> p0\<^sup>T\<^sup>\<star> * x"
       by (simp add: path_compression_1b)
     have "(p0 * p0)\<^sup>T\<^sup>\<star> * x \<le> p0\<^sup>T\<^sup>\<star> * x"
       by (simp add: conv_dist_comp mult_left_isotone star.circ_square)
     thus "p0[p0\<^sup>T\<^sup>\<star> * x - p0\<^sup>T\<^sup>\<star> * x\<longmapsto>(p0 * p0)\<^sup>T] = p0"
       by (smt (z3) inf.le_iff_sup inf_commute maddux_3_11_pp p_antitone_inf pseudo_complement)
     show "univalent p0" "total p0" "acyclic (p0 - 1)"
       using 1 find_set_precondition_def by auto
   qed
 qed
 
 lemma path_splitting_2:
   "path_splitting_invariant p x y p0 \<and> y \<noteq> p[[y]] \<Longrightarrow> path_splitting_invariant (p[y\<longmapsto>p[[p[[y]]]]]) x (p[[y]]) p0 \<and> ((p[y\<longmapsto>p[[p[[y]]]]])\<^sup>T\<^sup>\<star> * (p[[y]]))\<down> < (p\<^sup>T\<^sup>\<star> * y)\<down>"
 proof -
   let ?py = "p[[y]]"
   let ?ppy = "p[[?py]]"
   let ?pyppy = "p[y\<longmapsto>?ppy]"
   let ?p2 = "p0 * p0"
   let ?p2t = "?p2\<^sup>T"
   let ?p2ts = "?p2t\<^sup>\<star>"
   let ?px = "p0\<^sup>T\<^sup>\<star> * x"
   let ?py2 = "-(p0\<^sup>T\<^sup>\<star> * y)"
   let ?pxy = "?px \<sqinter> ?py2"
   let ?p = "p0[?pxy\<longmapsto>?p2t]"
   let ?pty = "p0\<^sup>T * y"
   let ?pt2y = "p0\<^sup>T * p0\<^sup>T * y"
   let ?pt2sy = "p0\<^sup>T\<^sup>\<star> * p0\<^sup>T * p0\<^sup>T * y"
   let ?ptpy = "p0\<^sup>T\<^sup>+ * y"
   assume 1: "path_splitting_invariant p x y p0 \<and> y \<noteq> ?py"
   have 2: "point ?pty \<and> point ?pt2y"
     using 1 by (smt (verit) comp_associative read_injective read_surjective path_splitting_invariant_def)
   show "path_splitting_invariant ?pyppy x (p[[y]]) p0 \<and> (?pyppy\<^sup>T\<^sup>\<star> * (p[[y]]))\<down> < (p\<^sup>T\<^sup>\<star> * y)\<down>"
   proof
     show "path_splitting_invariant ?pyppy x (p[[y]]) p0"
     proof (unfold path_splitting_invariant_def, intro conjI)
       show 3: "find_set_precondition ?pyppy x"
       proof (unfold find_set_precondition_def, intro conjI)
         show "univalent ?pyppy"
           using 1 find_set_precondition_def read_injective update_univalent path_splitting_invariant_def by auto
         show "total ?pyppy"
           using 1 bijective_regular find_set_precondition_def read_surjective update_total path_splitting_invariant_def by force
         show "acyclic (?pyppy - 1)"
           apply (rule update_acyclic_3)
           using 1 find_set_precondition_def path_splitting_invariant_def apply blast
           using 1 2 comp_associative path_splitting_invariant_aux(2) apply force
           using 1 path_splitting_invariant_def apply blast
           by (metis inf.order_lesseq_imp mult_isotone star.circ_increasing star.circ_square mult_assoc)
         show "vector x" "injective x" "surjective x"
           using 1 find_set_precondition_def path_splitting_invariant_def by auto
       qed
       show "vector (p[[y]])"
         using 1 comp_associative path_splitting_invariant_def by auto
       show "injective (p[[y]])"
         using 1 3 read_injective path_splitting_invariant_def find_set_precondition_def by auto
       show "surjective (p[[y]])"
         using 1 3 read_surjective path_splitting_invariant_def find_set_precondition_def by auto
       show "p[[y]] \<le> ?px"
       proof -
         have "p[[y]] = p0[[y]]"
           using 1 path_splitting_invariant_aux(1) by blast
         also have "... \<le> p0\<^sup>T * ?px"
           using 1 path_splitting_invariant_def mult_right_isotone by force
         also have "... \<le> ?px"
           by (metis comp_associative mult_left_isotone star.left_plus_below_circ)
         finally show ?thesis
           .
       qed
       show "p0[?px - p0\<^sup>T\<^sup>\<star> * (p[[y]])\<longmapsto>?p2t] = ?pyppy"
       proof -
         have 4: "p[?px \<sqinter> -?ptpy \<sqinter> y\<longmapsto>?p2t] = ?pyppy"
         proof (cases "y \<le> -?ptpy")
           case True
           hence "p[?px \<sqinter> -?ptpy \<sqinter> y\<longmapsto>?p2t] = p[y\<longmapsto>?p2t]"
             using 1 inf.absorb2 path_splitting_invariant_def by auto
           also have "... = ?pyppy"
             using 1 by (metis comp_associative conv_dist_comp path_splitting_invariant_aux(2) path_splitting_invariant_def update_point_get)
           finally show ?thesis
             .
         next
           case False
           have "vector (-?ptpy)"
             using 1 vector_complement_closed vector_mult_closed path_splitting_invariant_def by blast
           hence 5: "y \<le> ?ptpy"
             using 1 by (smt (verit, del_insts) False bijective_regular point_in_vector_or_complement regular_closed_star regular_mult_closed total_conv_surjective univalent_conv_injective path_splitting_invariant_def)
           hence "?px \<sqinter> -?ptpy \<sqinter> y = bot"
             by (simp add: inf.coboundedI2 p_antitone pseudo_complement)
           hence 6: "p[?px \<sqinter> -?ptpy \<sqinter> y\<longmapsto>?p2t] = p"
             by simp
           have 7: "y = root p0 y"
             using 1 5 loop_root_2 path_splitting_invariant_def by blast
           have "?pyppy = p[y\<longmapsto>p0[[p0[[y]]]]]"
             using 1 path_splitting_invariant_aux(2) by force
           also have "... = p[y\<longmapsto>p0[[y]]]"
             using 1 7 by (metis root_successor_loop path_splitting_invariant_def)
           also have "... = p[y\<longmapsto>?py]"
             using 1 path_splitting_invariant_aux(1) by force
           also have "... = p"
             using 1 get_put path_splitting_invariant_def by blast
           finally show ?thesis
             using 6 by simp
         qed
         have 8: "-?ptpy = ?py2 \<squnion> (-?ptpy \<sqinter> y)"
         proof (rule order.antisym)
           have 9: "regular (p0\<^sup>T\<^sup>\<star> * y) \<and> regular ?ptpy"
             using 1 bijective_regular mapping_conv_bijective pp_dist_star regular_mult_closed path_splitting_invariant_def by auto
           have "p0\<^sup>T\<^sup>\<star> * y \<le> ?ptpy \<squnion> y"
             by (simp add: star.circ_loop_fixpoint mult_assoc)
           also have "... = ?ptpy \<squnion> (-?ptpy \<sqinter> y)"
             using 9 by (metis maddux_3_21_pp)
           hence "p0\<^sup>T\<^sup>\<star> * y \<sqinter> -?ptpy \<le> -?ptpy \<sqinter> y"
             using calculation half_shunting sup_commute by auto
           thus "-?ptpy \<le> ?py2 \<squnion> (-?ptpy \<sqinter> y)"
             using 9 by (smt (z3) inf.sup_monoid.add_commute shunting_var_p sup.left_commute sup_commute)
           have "-(p0\<^sup>T\<^sup>\<star> * y) \<le> -?ptpy"
             by (simp add: comp_isotone p_antitone star.left_plus_below_circ)
           thus "-(p0\<^sup>T\<^sup>\<star> * y) \<squnion> (-?ptpy \<sqinter> y) \<le> -?ptpy"
             by simp
         qed
         have "regular ?px" "regular y"
           using 1 bijective_regular find_set_precondition_def mapping_regular pp_dist_comp regular_closed_star regular_conv_closed path_splitting_invariant_def by auto
         hence 10: "regular (?px \<sqinter> -?ptpy \<sqinter> y)"
           by auto
         have "p0[?px \<sqinter> -(p0\<^sup>T\<^sup>\<star> * (p[[y]]))\<longmapsto>?p2t] = p0[?px \<sqinter> -?ptpy\<longmapsto>?p2t]"
           using 1 by (smt comp_associative path_splitting_invariant_aux(1) star_plus)
         also have "... = p0[?pxy \<squnion> (?px \<sqinter> -?ptpy \<sqinter> y)\<longmapsto>?p2t]"
           using 8 by (metis comp_inf.semiring.distrib_left inf.sup_monoid.add_assoc)
         also have "... = ?p[?px \<sqinter> -?ptpy \<sqinter> y\<longmapsto>?p2t]"
           using 10 by (smt (z3) update_same comp_inf.semiring.mult_not_zero inf.sup_monoid.add_assoc inf.sup_monoid.add_commute)
         also have "... = p[?px \<sqinter> -?ptpy \<sqinter> y\<longmapsto>?p2t]"
           using 1 path_splitting_invariant_def by auto
         also have "... = ?pyppy"
           using 4 by auto
         finally show ?thesis
           .
       qed
       show "univalent p0" "total p0" "acyclic (p0 - 1)"
         using 1 path_splitting_invariant_def by auto
     qed
     let ?s = "{ z . regular z \<and> z \<le> p\<^sup>T\<^sup>\<star> * y }"
     let ?t = "{ z . regular z \<and> z \<le> ?pyppy\<^sup>T\<^sup>\<star> * (p[[y]]) }"
     have "?pyppy\<^sup>T\<^sup>\<star> * (p[[y]]) \<le> p\<^sup>+\<^sup>T\<^sup>\<star> * (p[[y]])"
       using 1 path_splitting_invariant_def update_square_plus conv_order mult_left_isotone star_isotone by force
     also have "... = p\<^sup>T\<^sup>\<star> * p\<^sup>T * y"
       by (simp add: conv_plus_commute star.left_plus_circ mult_assoc)
     also have "... = p\<^sup>T\<^sup>+ * y"
       by (simp add: star_plus)
     finally have 11: "?pyppy\<^sup>T\<^sup>\<star> * (p[[y]]) \<le> p\<^sup>T\<^sup>+ * y"
       .
     hence "?pyppy\<^sup>T\<^sup>\<star> * (p[[y]]) \<le> p\<^sup>T\<^sup>\<star> * y"
       using mult_left_isotone order_lesseq_imp star.left_plus_below_circ by blast
     hence 12: "?t \<subseteq> ?s"
       using order_trans by auto
     have 13: "y \<in> ?s"
       using 1 bijective_regular path_compression_1b path_splitting_invariant_def by force
     have 14: "\<not> y \<in> ?t"
     proof
       assume "y \<in> ?t"
       hence "y \<le> ?pyppy\<^sup>T\<^sup>\<star> * (p[[y]])"
         by simp
       hence "y \<le> p\<^sup>T\<^sup>+ * y"
         using 11 dual_order.trans by blast
       hence "y = root p y"
         using 1 find_set_precondition_def loop_root_2 path_splitting_invariant_def by blast
       hence "y = ?py"
         using 1 by (metis find_set_precondition_def root_successor_loop path_splitting_invariant_def)
       thus False
         using 1 by simp
     qed
     show "card ?t < card ?s"
       apply (rule psubset_card_mono)
       subgoal using finite_regular by simp
       subgoal using 12 13 14 by auto
       done
   qed
 qed
 
 lemma path_splitting_3:
   "path_splitting_invariant p x y p0 \<and> y = p[[y]] \<Longrightarrow> path_splitting_postcondition p x y p0"
 proof -
   assume 1: "path_splitting_invariant p x y p0 \<and> y = p[[y]]"
   show "path_splitting_postcondition p x y p0"
   proof (unfold path_splitting_postcondition_def path_compression_precondition_def, intro conjI)
     show "univalent p" "total p" "acyclic (p - 1)"
       using 1 find_set_precondition_def path_splitting_invariant_def by blast+
     show "vector x" "injective x" "surjective x"
       using 1 find_set_precondition_def path_splitting_invariant_def by blast+
     show 2: "vector y" "injective y" "surjective y"
       using 1 path_splitting_invariant_def by blast+
     show 3: "p \<sqinter> 1 = p0 \<sqinter> 1"
       using 1 path_splitting_invariant_aux(4) by blast
     show 4: "fc p = fc p0"
       using 1 path_splitting_invariant_aux(5) by blast
     have "y \<le> p0\<^sup>T\<^sup>\<star> * x"
       using 1 path_splitting_invariant_def by simp
     hence 5: "y * x\<^sup>T \<le> fc p0"
       using 1 by (metis dual_order.trans fc_wcc find_set_precondition_def shunt_bijective star.circ_decompose_11 star_decompose_1 star_outer_increasing path_splitting_invariant_def)
     have 6: "y = p0[[y]]"
       using 1 path_splitting_invariant_aux(1) by auto
     hence "y = root p0 y"
       using 2 loop_root by auto
     also have "... = root p0 x"
       using 1 2 5 find_set_precondition_def path_splitting_invariant_def same_component_same_root by auto
     also have "... = root p x"
       using 1 3 4 by (metis find_set_precondition_def path_splitting_invariant_def same_root)
     finally show "y = root p x"
       .
     have "p0\<^sup>T\<^sup>\<star> * y = y"
       using 6 order.antisym path_compression_1b star_left_induct_mult_equal by auto
     hence 7: "p0[p0\<^sup>T\<^sup>\<star> * x - y\<longmapsto>(p0 * p0)\<^sup>T] = p"
       using 1 path_splitting_invariant_def by auto
     have "(p0 * p0)\<^sup>T * y = y"
       using 6 mult_assoc conv_dist_comp by auto
     hence "y \<sqinter> p0 * p0 = y \<sqinter> p0"
       using 2 6 by (metis update_postcondition)
     hence 8: "y \<sqinter> p = y \<sqinter> p0 * p0"
       using 1 2 6 by (smt update_postcondition)
     have "p0[p0\<^sup>T\<^sup>\<star> * x\<longmapsto>(p0 * p0)\<^sup>T] = (p0[p0\<^sup>T\<^sup>\<star> * x - y\<longmapsto>(p0 * p0)\<^sup>T])[p0\<^sup>T\<^sup>\<star> * x \<sqinter> y\<longmapsto>(p0 * p0)\<^sup>T]"
       using 1 bijective_regular path_splitting_invariant_def update_split by blast
     also have "... = p[p0\<^sup>T\<^sup>\<star> * x \<sqinter> y\<longmapsto>(p0 * p0)\<^sup>T]"
       using 7 by simp
     also have "... = p"
       apply (rule update_same_sub)
       using 8 apply simp
       apply simp
       using 1 bijective_regular inf.absorb2 path_splitting_invariant_def by auto
     finally show "p0[p0\<^sup>T\<^sup>\<star> * x\<longmapsto>(p0 * p0)\<^sup>T] = p"
       .
   qed
 qed
 
 theorem find_path_splitting:
   "VARS p t y
   [ find_set_precondition p x \<and> p0 = p ]
   y := x;
   WHILE y \<noteq> p[[y]]
     INV { path_splitting_invariant p x y p0 }
     VAR { (p\<^sup>T\<^sup>\<star> * y)\<down> }
      DO t := p[[y]];
         p[y] := p[[p[[y]]]];
         y := t
      OD
   [ path_splitting_postcondition p x y p0 ]"
   apply vcg_tc_simp
     apply (fact path_splitting_1)
    apply (fact path_splitting_2)
   by (fact path_splitting_3)
 
 end
 
 section \<open>Verifying Union by Rank\<close>
 
 text \<open>
 In this section we verify the union-by-rank operation of disjoint-set forests.
 The rank of a node is an upper bound of the height of the subtree rooted at that node.
 The rank array of a disjoint-set forest maps each node to its rank.
 This can be represented as a homogeneous relation since the possible rank values are $0, \dots, n-1$ where $n$ is the number of nodes of the disjoint-set forest.
 \<close>
 
 subsection \<open>Peano structures\<close>
 
 text \<open>
 Since ranks are natural numbers we start by introducing basic Peano arithmetic.
 Numbers are represented as (relational) points.
 Constant \<open>Z\<close> represents the number $0$.
 Constant \<open>S\<close> represents the successor function.
 The successor of a number $x$ is obtained by the relational composition \<open>S\<^sup>T * x\<close>.
 The composition \<open>S * x\<close> results in the predecessor of $x$.
 \<close>
 
 class peano_signature =
   fixes Z :: "'a"
   fixes S :: "'a"
 
 text \<open>
 The numbers will be used in arrays, which are represented by homogeneous finite relations.
 Such relations can only represent finitely many numbers.
 This means that we weaken the Peano axioms, which are usually used to obtain (infinitely many) natural numbers.
 Axiom \<open>Z_point\<close> specifies that $0$ is a number.
 Axiom \<open>S_univalent\<close> specifies that every number has at most one `successor'.
 Together with axiom \<open>S_total\<close>, which is added later, this means that every number has exactly one `successor'.
 Axiom \<open>S_injective\<close> specifies that numbers with the same successor are equal.
 Axiom \<open>S_star_Z_top\<close> specifies that every number can be obtained from $0$ by finitely many applications of the successor.
 We omit the Peano axiom \<open>S * Z = bot\<close> which would specify that $0$ is not the successor of any number.
 Since only finitely many numbers will be represented, the remaining axioms will model successor modulo $m$ for some $m$ depending on the carrier of the algebra.
 That is, the algebra will be able to represent numbers $0, \dots, m-1$ where the successor of $m-1$ is $0$.
 \<close>
 
-class skra_peano_1 = stone_kleene_relation_algebra + stone_relation_algebra_tarski_consistent + peano_signature +
+class skra_peano_1 = stone_kleene_relation_algebra_tarski_consistent + peano_signature +
   assumes Z_point: "point Z"
   assumes S_univalent: "univalent S"
   assumes S_injective: "injective S"
   assumes S_star_Z_top: "S\<^sup>T\<^sup>\<star> * Z = top"
 begin
 
 lemma conv_Z_Z:
   "Z\<^sup>T * Z = top"
   by (simp add: Z_point point_conv_comp)
 
 text \<open>Theorem 9.2\<close>
 
 lemma Z_below_S_star:
   "Z \<le> S\<^sup>\<star>"
 proof -
   have "top * Z\<^sup>T \<le> S\<^sup>T\<^sup>\<star>"
     using S_star_Z_top Z_point shunt_bijective by blast
   thus ?thesis
     using Z_point conv_order conv_star_commute vector_conv_covector by force
 qed
 
 text \<open>Theorem 9.3\<close>
 
 lemma S_connected:
   "S\<^sup>T\<^sup>\<star> * S\<^sup>\<star> = top"
   by (metis Z_below_S_star S_star_Z_top mult_left_dist_sup sup.orderE sup_commute top.extremum)
 
 text \<open>Theorem 9.4\<close>
 
 lemma S_star_connex:
   "S\<^sup>\<star> \<squnion> S\<^sup>T\<^sup>\<star> = top"
   using S_connected S_univalent cancel_separate_eq sup_commute by auto
 
 text \<open>Theorem 9.5\<close>
 
 lemma Z_sup_conv_S_top:
   "Z \<squnion> S\<^sup>T * top = top"
   using S_star_Z_top star.circ_loop_fixpoint sup_commute by auto
 
 lemma top_S_sup_conv_Z:
   "top * S \<squnion> Z\<^sup>T = top"
   by (metis S_star_Z_top conv_dist_comp conv_involutive conv_star_commute star.circ_back_loop_fixpoint symmetric_top_closed)
 
 text \<open>Theorem 9.1\<close>
 
 lemma S_inf_1_below_Z:
   "S \<sqinter> 1 \<le> Z"
 proof -
   have "(S \<sqinter> 1) * S\<^sup>T \<le> S \<sqinter> 1"
     by (metis S_injective conv_dist_comp coreflexive_symmetric inf.boundedI inf.cobounded1 inf.cobounded2 injective_codomain)
   hence "(S \<sqinter> 1) * S\<^sup>T\<^sup>\<star> \<le> S \<sqinter> 1"
     using star_right_induct_mult by blast
   hence "(S \<sqinter> 1) * S\<^sup>T\<^sup>\<star> * Z \<le> (S \<sqinter> 1) * Z"
     by (simp add: mult_left_isotone)
   also have "... \<le> Z"
     by (metis comp_left_subdist_inf inf.boundedE mult_1_left)
   finally show ?thesis
     using S_star_Z_top inf.order_trans top_right_mult_increasing mult_assoc by auto
 qed
 
 lemma S_inf_1_below_conv_Z:
   "S \<sqinter> 1 \<le> Z\<^sup>T"
   using S_inf_1_below_Z conv_order coreflexive_symmetric by fastforce
 
 text \<open>
 The successor operation provides a convenient way to compare two natural numbers.
 Namely, $k < m$ if $m$ can be reached from $k$ by finitely many applications of the successor, formally \<open>m \<le> S\<^sup>T\<^sup>\<star> * k\<close> or \<open>k \<le> S\<^sup>\<star> * m\<close>.
 This does not work for numbers modulo $m$ since comparison depends on the chosen representative.
 We therefore work with a modified successor relation \<open>S'\<close>, which is a partial function that computes the successor for all numbers except $m-1$.
 If $S$ is surjective, the point \<open>M\<close> representing the greatest number $m-1$ is the predecessor of $0$ under \<open>S\<close>.
 If $S$ is not surjective (like for the set of all natural numbers), \<open>M = bot\<close>.
 \<close>
 
 abbreviation "S' \<equiv> S - Z\<^sup>T"
 abbreviation "M \<equiv> S * Z"
 
 text \<open>Theorem 11.1\<close>
 
 lemma M_point_iff_S_surjective:
   "point M \<longleftrightarrow> surjective S"
 proof
   assume 1: "point M"
   hence "1 \<le> Z\<^sup>T * S\<^sup>T * S * Z"
     using comp_associative conv_dist_comp surjective_var by auto
   hence "Z \<le> S\<^sup>T * S * Z"
     using 1 Z_point bijective_reverse mult_assoc by auto
   also have "... \<le> S\<^sup>T * top"
     by (simp add: comp_isotone mult_assoc)
   finally have "S\<^sup>T * S\<^sup>T * top \<squnion> Z \<le> S\<^sup>T * top"
     using mult_isotone mult_assoc by force
   hence "S\<^sup>T\<^sup>\<star> * Z \<le> S\<^sup>T * top"
     by (simp add: star_left_induct mult_assoc)
   thus "surjective S"
     by (simp add: S_star_Z_top order.antisym surjective_conv_total)
 next
   assume "surjective S"
   thus "point M"
     by (metis S_injective Z_point comp_associative injective_mult_closed)
 qed
 
 text \<open>Theorem 10.1\<close>
 
 lemma S'_univalent:
   "univalent S'"
   by (simp add: S_univalent univalent_inf_closed)
 
 text \<open>Theorem 10.2\<close>
 
 lemma S'_injective:
   "injective S'"
   by (simp add: S_injective injective_inf_closed)
 
 text \<open>Theorem 10.9\<close>
 
 lemma S'_Z:
   "S' * Z = bot"
   by (simp add: Z_point covector_vector_comp injective_comp_right_dist_inf)
 
 text \<open>Theorem 10.4\<close>
 
 lemma S'_irreflexive:
   "irreflexive S'"
   using S_inf_1_below_conv_Z order_lesseq_imp p_shunting_swap pp_increasing by blast
 
 end
 
 class skra_peano_2 = skra_peano_1 +
   assumes S_total: "total S"
 begin
 
 lemma S_mapping:
   "mapping S"
   by (simp add: S_total S_univalent)
 
 text \<open>Theorem 11.2\<close>
 
 lemma M_bot_iff_S_not_surjective:
   "M \<noteq> bot \<longleftrightarrow> surjective S"
 proof
   assume "M \<noteq> bot"
   hence "top * S * Z = top"
     by (metis S_mapping Z_point bijective_regular comp_associative mapping_regular regular_mult_closed tarski)
   hence "Z\<^sup>T \<le> top * S"
     using M_point_iff_S_surjective S_injective Z_point comp_associative injective_mult_closed by auto
   thus "surjective S"
     using sup.orderE top_S_sup_conv_Z by fastforce
 next
   assume "surjective S"
   thus "M \<noteq> bot"
     using M_point_iff_S_surjective consistent covector_bot_closed by force
 qed
 
 text \<open>Theorem 11.3\<close>
 
 lemma M_point_or_bot:
   "point M \<or> M = bot"
   using M_bot_iff_S_not_surjective M_point_iff_S_surjective by blast
 
 text \<open>Alternative way to express \<open>S'\<close>\<close>
 
 text \<open>Theorem 12.1\<close>
 
 lemma S'_var:
   "S' = S - M"
 proof -
   have "S' = S * (1 - Z\<^sup>T)"
     by (simp add: Z_point covector_comp_inf vector_conv_compl)
   also have "... = S * (1 - Z)"
     by (metis conv_complement one_inf_conv)
   also have "... = S * 1 \<sqinter> S * -Z"
     by (simp add: S_mapping univalent_comp_left_dist_inf)
   also have "... = S - M"
     by (simp add: comp_mapping_complement S_mapping)
   finally show ?thesis
     .
 qed
 
 text \<open>Special case of just $1$ number\<close>
 
 text \<open>Theorem 12.2\<close>
 
 lemma M_is_Z_iff_1_is_top:
   "M = Z \<longleftrightarrow> 1 = top"
 proof
   assume "M = Z"
   hence "Z = S\<^sup>T * Z"
     by (metis S_mapping Z_point order.antisym bijective_reverse inf.eq_refl shunt_mapping)
   thus "1 = top"
     by (metis S_star_Z_top Z_point inf.eq_refl star_left_induct sup.absorb2 symmetric_top_closed top_le)
 next
   assume "1 = top"
   thus "M = Z"
     using S_mapping comp_right_one mult_1_left by auto
 qed
 
 text \<open>Theorem 12.3\<close>
 
 lemma S_irreflexive:
   assumes "M \<noteq> Z"
   shows "irreflexive S"
 proof -
   have "(S \<sqinter> 1) * S\<^sup>T \<le> S \<sqinter> 1"
     by (smt (z3) S_injective S_mapping coreflexive_comp_top_inf dual_order.eq_iff inf.cobounded1 inf.sup_monoid.add_commute inf.sup_same_context mult_left_isotone one_inf_conv top_right_mult_increasing total_var)
   hence "(S \<sqinter> 1) * S\<^sup>T\<^sup>\<star> \<le> S \<sqinter> 1"
     using star_right_induct_mult by blast
   hence "(S \<sqinter> 1) * S\<^sup>T\<^sup>\<star> * Z \<le> (S \<sqinter> 1) * Z"
     by (simp add: mult_left_isotone)
   also have "... = M \<sqinter> Z"
     by (simp add: Z_point injective_comp_right_dist_inf)
   also have "... = bot"
     by (smt (verit, ccfv_threshold) M_point_or_bot assms Z_point bijective_one_closed bijective_regular comp_associative conv_complement coreflexive_comp_top_inf epm_3 inf.sup_monoid.add_commute one_inf_conv regular_mult_closed star.circ_increasing star.circ_zero tarski vector_conv_covector vector_export_comp_unit)
   finally have "S \<sqinter> 1 \<le> bot"
     using S_star_Z_top comp_associative le_bot top_right_mult_increasing by fastforce
   thus ?thesis
     using le_bot pseudo_complement by blast
 qed
 
 text \<open>
 We show that \<open>S'\<close> satisfies most properties of \<open>S\<close>.
 \<close>
 
 lemma M_regular:
   "regular M"
   using S_mapping Z_point bijective_regular mapping_regular regular_mult_closed by blast
 
 lemma S'_regular:
   "regular S'"
   using S_mapping mapping_regular by auto
 
 text \<open>Theorem 10.3\<close>
 
 lemma S'_star_Z_top:
   "S'\<^sup>T\<^sup>\<star> * Z = top"
 proof -
   have "S\<^sup>T\<^sup>\<star> * Z = (S' \<squnion> (S \<sqinter> M))\<^sup>T\<^sup>\<star> * Z"
     by (metis M_regular maddux_3_11_pp S'_var)
   also have "... \<le> S'\<^sup>T\<^sup>\<star> * Z"
   proof (cases "M = bot")
     case True
     thus ?thesis
       by simp
   next
     case False
     hence "point M"
       using M_point_or_bot by auto
     hence "arc (S \<sqinter> M)"
       using S_mapping mapping_inf_point_arc by blast
     hence 1: "arc ((S \<sqinter> M)\<^sup>T)"
       using conv_involutive by auto
     have 2: "S \<sqinter> M \<le> Z\<^sup>T"
       by (metis S'_var Z_point bijective_regular conv_complement inf.cobounded2 p_shunting_swap)
     have "(S' \<squnion> (S \<sqinter> M))\<^sup>T\<^sup>\<star> * Z = (S'\<^sup>T \<squnion> (S \<sqinter> M)\<^sup>T)\<^sup>\<star> * Z"
       by (simp add: S'_var conv_dist_sup)
     also have "... = (S'\<^sup>T\<^sup>\<star> * (S \<sqinter> M)\<^sup>T * S'\<^sup>T\<^sup>\<star> \<squnion> S'\<^sup>T\<^sup>\<star>) * Z"
       using 1 star_arc_decompose sup_commute by auto
     also have "... = S'\<^sup>T\<^sup>\<star> * (S \<sqinter> M)\<^sup>T * S'\<^sup>T\<^sup>\<star> * Z \<squnion> S'\<^sup>T\<^sup>\<star> * Z"
       using mult_right_dist_sup by auto
     also have "... \<le> S'\<^sup>T\<^sup>\<star> * Z\<^sup>T\<^sup>T * S'\<^sup>T\<^sup>\<star> * Z \<squnion> S'\<^sup>T\<^sup>\<star> * Z"
       using 2 by (meson comp_isotone conv_isotone inf.eq_refl semiring.add_mono)
     also have "... \<le> S'\<^sup>T\<^sup>\<star> * Z"
       by (metis Z_point comp_associative conv_involutive le_supI mult_right_isotone top.extremum)
     finally show ?thesis
       .
   qed
   finally show ?thesis
     using S_star_Z_top top_le by auto
 qed
 
 text \<open>Theorem 10.5\<close>
 
 lemma Z_below_S'_star:
   "Z \<le> S'\<^sup>\<star>"
   by (metis S'_star_Z_top Z_point comp_associative comp_right_one conv_order conv_star_commute mult_right_isotone vector_conv_covector)
 
 text \<open>Theorem 10.6\<close>
 
 lemma S'_connected:
   "S'\<^sup>T\<^sup>\<star> * S'\<^sup>\<star> = top"
   by (metis Z_below_S'_star S'_star_Z_top mult_left_dist_sup sup.orderE sup_commute top.extremum)
 
 text \<open>Theorem 10.7\<close>
 
 lemma S'_star_connex:
   "S'\<^sup>\<star> \<squnion> S'\<^sup>T\<^sup>\<star> = top"
   using S'_connected S'_univalent cancel_separate_eq sup_commute by auto
 
 text \<open>Theorem 10.8\<close>
 
 lemma Z_sup_conv_S'_top:
   "Z \<squnion> S'\<^sup>T * top = top"
   using S'_star_Z_top star.circ_loop_fixpoint sup_commute by auto
 
 lemma top_S'_sup_conv_Z:
   "top * S' \<squnion> Z\<^sup>T = top"
   by (metis S'_star_Z_top conv_dist_comp conv_involutive conv_star_commute star.circ_back_loop_fixpoint symmetric_top_closed)
 
 end
 
 subsection \<open>Initialising Ranks\<close>
 
 text \<open>
 We show that the rank array satisfies three properties which are established/preserved by the union-find operations.
 First, every node has a rank, that is, the rank array is a mapping.
 Second, the rank of a node is strictly smaller than the rank of its parent, except if the node is a root.
 This implies that the rank of a node is an upper bound on the height of its subtree.
 Third, the number of roots in the disjoint-set forest (the number of disjoint sets) is not larger than $m-k$ where $m$ is the total number of nodes and $k$ is the maximum rank of any node.
 The third property is useful to show that ranks never overflow (exceed $m-1$).
 To compare the number of roots and $m-k$ we use the existence of an injective univalent relation between the set of roots and the set of $m-k$ largest numbers, both represented as vectors.
 The three properties are captured in \<open>rank_property\<close>.
 \<close>
 
 class skra_peano_3 = stone_kleene_relation_algebra_tarski_finite_regular + skra_peano_2
 begin
 
 definition "card_less_eq v w \<equiv> \<exists>i . injective i \<and> univalent i \<and> regular i \<and> v \<le> i * w"
 definition "rank_property p rank \<equiv> mapping rank \<and> (p - 1) * rank \<le> rank * S'\<^sup>+ \<and> card_less_eq (roots p) (-(S'\<^sup>+ * rank\<^sup>T * top))"
 
 end
 
 class skra_peano_4 = stone_kleene_relation_algebra_choose_point_finite_regular + skra_peano_2
 begin
 
 subclass skra_peano_3 ..
 
 text \<open>
 The initialisation loop is augmented by setting the rank of each node to $0$.
 The resulting rank array satisfies the desired properties explained above.
 \<close>
 
 theorem init_ranks:
   "VARS h p x rank
   [ True ]
   FOREACH x
     USING h
       INV { p - h = 1 - h \<and> rank - h = Z\<^sup>T - h }
        DO p := make_set p x;
           rank[x] := Z
        OD
   [ p = 1 \<and> disjoint_set_forest p \<and> rank = Z\<^sup>T \<and> rank_property p rank \<and> h = bot ]"
 proof vcg_tc_simp
   fix h p rank
   let ?x = "choose_point h"
   let ?m = "make_set p ?x"
   let ?rank = "rank[?x\<longmapsto>Z]"
   assume 1: "regular h \<and> vector h \<and> p - h = 1 - h \<and> rank - h = Z\<^sup>T - h \<and> h \<noteq> bot"
   show "vector (-?x \<sqinter> h) \<and>
         ?m \<sqinter> (--?x \<squnion> -h) = 1 \<sqinter> (--?x \<squnion> -h) \<and>
         ?rank \<sqinter> (--?x \<squnion> -h) = Z\<^sup>T \<sqinter> (--?x \<squnion> -h) \<and>
         card { x . regular x \<and> x \<le> -?x \<and> x \<le> h } < h\<down>"
   proof (intro conjI)
     show "vector (-?x \<sqinter> h)"
       using 1 choose_point_point vector_complement_closed vector_inf_closed by blast
     have 2: "point ?x \<and> regular ?x"
       using 1 bijective_regular choose_point_point by blast
     have 3: "-h \<le> -?x"
       using choose_point_decreasing p_antitone_iff by auto
     have 4: "?x \<sqinter> ?m = ?x * ?x\<^sup>T \<and> -?x \<sqinter> ?m = -?x \<sqinter> p"
       using 1 choose_point_point make_set_function make_set_postcondition_def by auto
     have "?m \<sqinter> (--?x \<squnion> -h) = (?m \<sqinter> ?x) \<squnion> (?m - h)"
       using 2 comp_inf.comp_left_dist_sup by auto
     also have "... = ?x * ?x\<^sup>T \<squnion> (?m \<sqinter> -?x \<sqinter> -h)"
       using 3 4 by (smt (z3) inf_absorb2 inf_assoc inf_commute)
     also have "... = ?x * ?x\<^sup>T \<squnion> (1 - h)"
       using 1 3 4 inf.absorb2 inf.sup_monoid.add_assoc inf_commute by auto
     also have "... = (1 \<sqinter> ?x) \<squnion> (1 - h)"
       using 2 by (metis inf.cobounded2 inf.sup_same_context one_inf_conv vector_covector)
     also have "... = 1 \<sqinter> (--?x \<squnion> -h)"
       using 2 comp_inf.semiring.distrib_left by auto
     finally show "?m \<sqinter> (--?x \<squnion> -h) = 1 \<sqinter> (--?x \<squnion> -h)"
       .
     have 5: "?x \<sqinter> ?rank = ?x \<sqinter> Z\<^sup>T \<and> -?x \<sqinter> ?rank = -?x \<sqinter> rank"
       by (smt (z3) inf_commute order_refl update_inf_different update_inf_same)
     have "?rank \<sqinter> (--?x \<squnion> -h) = (?rank \<sqinter> ?x) \<squnion> (?rank - h)"
       using 2 comp_inf.comp_left_dist_sup by auto
     also have "... = (?x \<sqinter> Z\<^sup>T) \<squnion> (?rank \<sqinter> -?x \<sqinter> -h)"
       using 3 5 by (smt (z3) inf_absorb2 inf_assoc inf_commute)
     also have "... = (Z\<^sup>T \<sqinter> ?x) \<squnion> (Z\<^sup>T - h)"
       using 1 3 5 inf.absorb2 inf.sup_monoid.add_assoc inf_commute by auto
     also have "... = Z\<^sup>T \<sqinter> (--?x \<squnion> -h)"
       using 2 comp_inf.semiring.distrib_left by auto
     finally show "?rank \<sqinter> (--?x \<squnion> -h) = Z\<^sup>T \<sqinter> (--?x \<squnion> -h)"
       .
     have 5: "\<not> ?x \<le> -?x"
       using 1 2 by (metis comp_commute_below_diversity conv_order inf.cobounded2 inf_absorb2 pseudo_complement strict_order_var top.extremum)
     have 6: "?x \<le> h"
       using 1 by (metis choose_point_decreasing)
     show "card { x . regular x \<and> x \<le> -?x \<and> x \<le> h } < h\<down>"
       apply (rule psubset_card_mono)
       using finite_regular apply simp
       using 2 5 6 by auto
   qed
 next
   show "rank_property 1 (Z\<^sup>T)"
   proof (unfold rank_property_def, intro conjI)
     show "univalent (Z\<^sup>T)" "total (Z\<^sup>T)"
       using Z_point surjective_conv_total by auto
     show "(1 - 1) * (Z\<^sup>T) \<le> (Z\<^sup>T) * S'\<^sup>+"
       by simp
     have "top \<le> 1 * -(S'\<^sup>+ * Z * top)"
       by (simp add: S'_Z comp_associative star_simulation_right_equal)
     thus "card_less_eq (roots 1) (-(S'\<^sup>+ * Z\<^sup>T\<^sup>T * top))"
       by (metis conv_involutive inf.idem mapping_one_closed regular_one_closed card_less_eq_def bijective_one_closed)
   qed
 qed
 
 end
 
 subsection \<open>Union by Rank\<close>
 
 text \<open>
 We show that path compression and union-by-rank preserve the rank property.
 \<close>
 
 context stone_kleene_relation_algebra_tarski_finite_regular
 begin
 
 lemma union_sets_1_swap:
   assumes "union_sets_precondition p0 x y"
     and "path_compression_postcondition p1 x r p0"
     and "path_compression_postcondition p2 y s p1"
   shows "union_sets_postcondition (p2[s\<longmapsto>r]) x y p0"
 proof (unfold union_sets_postcondition_def union_sets_precondition_def, intro conjI)
   let ?p = "p2[s\<longmapsto>r]"
   have 1: "disjoint_set_forest p1 \<and> point r \<and> r = root p1 x \<and> p1 \<sqinter> 1 = p0 \<sqinter> 1 \<and> fc p1 = fc p0"
     using assms(2) path_compression_precondition_def path_compression_postcondition_def by auto
   have 2: "disjoint_set_forest p2 \<and> point s \<and> s = root p2 y \<and> p2 \<sqinter> 1 = p1 \<sqinter> 1 \<and> fc p2 = fc p1"
     using assms(3) path_compression_precondition_def path_compression_postcondition_def by auto
   hence 3: "fc p2 = fc p0"
     using 1 by simp
   show 4: "univalent ?p"
     using 1 2 update_univalent by blast
   show "total ?p"
     using 1 2 bijective_regular update_total by blast
   show "acyclic (?p - 1)"
   proof (cases "r = s")
     case True
     thus ?thesis
       using 2 update_acyclic_5 by fastforce
   next
     case False
     hence "bot = s \<sqinter> r"
       using 1 2 distinct_points inf_commute by blast
     also have "... = s \<sqinter> p1\<^sup>T\<^sup>\<star> * r"
       using 1 by (smt root_transitive_successor_loop)
     also have "... = s \<sqinter> p2\<^sup>T\<^sup>\<star> * r"
       using 1 2 by (smt (z3) inf_assoc inf_commute same_root)
     finally have "r \<sqinter> p2\<^sup>\<star> * s = bot"
       using schroeder_1 conv_star_commute inf.sup_monoid.add_commute by fastforce
     thus ?thesis
       using 1 2 update_acyclic_4 by blast
   qed
   show "vector x"
     using assms(1) by (simp add: union_sets_precondition_def)
   show "injective x"
     using assms(1) by (simp add: union_sets_precondition_def)
   show "surjective x"
     using assms(1) by (simp add: union_sets_precondition_def)
   show "vector y"
     using assms(1) by (simp add: union_sets_precondition_def)
   show "injective y"
     using assms(1) by (simp add: union_sets_precondition_def)
   show "surjective y"
     using assms(1) by (simp add: union_sets_precondition_def)
   show "fc ?p = wcc (p0 \<squnion> x * y\<^sup>T)"
   proof (rule order.antisym)
     have "s = p2[[s]]"
       using 2 by (metis root_successor_loop)
     hence "s * s\<^sup>T \<le> p2\<^sup>T"
       using 2 eq_refl shunt_bijective by blast
     hence "s * s\<^sup>T \<le> p2"
       using 2 conv_order coreflexive_symmetric by fastforce
     hence "s \<le> p2 * s"
       using 2 shunt_bijective by blast
     hence 5: "p2[[s]] \<le> s"
       using 2 shunt_mapping by blast
     have "s \<sqinter> p2 \<le> s * (top \<sqinter> s\<^sup>T * p2)"
       using 2 by (metis dedekind_1)
     also have "... = s * s\<^sup>T * p2"
       by (simp add: mult_assoc)
     also have "... \<le> s * s\<^sup>T"
       using 5 by (metis comp_associative conv_dist_comp conv_involutive conv_order mult_right_isotone)
     also have "... \<le> 1"
       using 2 by blast
     finally have 6: "s \<sqinter> p2 \<le> 1"
       by simp
     have "p0 \<le> wcc p0"
       by (simp add: star.circ_sub_dist_1)
     also have "... = wcc p2"
       using 3 by (simp add: star_decompose_1)
     also have 7: "... \<le> wcc ?p"
     proof -
       have "wcc p2 = wcc ((-s \<sqinter> p2) \<squnion> (s \<sqinter> p2))"
         using 2 by (metis bijective_regular inf.sup_monoid.add_commute maddux_3_11_pp)
       also have "... \<le> wcc ((-s \<sqinter> p2) \<squnion> 1)"
         using 6 wcc_isotone sup_right_isotone by simp
       also have "... = wcc (-s \<sqinter> p2)"
         using wcc_with_loops by simp
       also have "... \<le> wcc ?p"
         using wcc_isotone sup_ge2 by blast
       finally show ?thesis
         by simp
     qed
     finally have 8: "p0 \<le> wcc ?p"
       by force
     have "s \<le> p2\<^sup>T\<^sup>\<star> * y"
       using 2 by (metis inf_le1)
     hence 9: "s * y\<^sup>T \<le> p2\<^sup>T\<^sup>\<star>"
       using assms(1) shunt_bijective union_sets_precondition_def by blast
     hence "y * s\<^sup>T \<le> p2\<^sup>\<star>"
       using conv_dist_comp conv_order conv_star_commute by force
     also have "... \<le> wcc p2"
       by (simp add: star.circ_sub_dist)
     also have "... \<le> wcc ?p"
       using 7 by simp
     finally have 10: "y * s\<^sup>T \<le> wcc ?p"
       by simp
     have 11: "s * r\<^sup>T \<le> wcc ?p"
       using 1 2 star.circ_sub_dist_1 sup_assoc vector_covector by auto
     have "r \<le> p1\<^sup>T\<^sup>\<star> * x"
       using 1 by (metis inf_le1)
     hence 12: "r * x\<^sup>T \<le> p1\<^sup>T\<^sup>\<star>"
       using assms(1) shunt_bijective union_sets_precondition_def by blast
     also have "... \<le> wcc p1"
       using star_isotone sup_ge2 by blast
     also have "... = wcc p2"
       using 2 by (simp add: star_decompose_1)
     also have "... \<le> wcc ?p"
       using 7 by simp
     finally have 13: "r * x\<^sup>T \<le> wcc ?p"
       by simp
     have "x \<le> x * r\<^sup>T * r \<and> y \<le> y * s\<^sup>T * s"
       using 1 2 shunt_bijective by blast
     hence "y * x\<^sup>T \<le> y * s\<^sup>T * s * (x * r\<^sup>T * r)\<^sup>T"
       using comp_isotone conv_isotone by blast
     also have "... = y * s\<^sup>T * s * r\<^sup>T * r * x\<^sup>T"
       by (simp add: comp_associative conv_dist_comp)
     also have "... \<le> wcc ?p * (s * r\<^sup>T) * (r * x\<^sup>T)"
       using 10 by (metis mult_left_isotone mult_assoc)
     also have "... \<le> wcc ?p * wcc ?p * (r * x\<^sup>T)"
       using 11 by (metis mult_left_isotone mult_right_isotone)
     also have "... \<le> wcc ?p * wcc ?p * wcc ?p"
       using 13 by (metis mult_right_isotone)
     also have "... = wcc ?p"
       by (simp add: star.circ_transitive_equal)
     finally have "x * y\<^sup>T \<le> wcc ?p"
       by (metis conv_dist_comp conv_involutive conv_order wcc_equivalence)
     hence "p0 \<squnion> x * y\<^sup>T \<le> wcc ?p"
       using 8 by simp
     hence "wcc (p0 \<squnion> x * y\<^sup>T) \<le> wcc ?p"
       using wcc_below_wcc by simp
     thus "wcc (p0 \<squnion> x * y\<^sup>T) \<le> fc ?p"
       using 4 fc_wcc by simp
     have "-s \<sqinter> p2 \<le> wcc p2"
       by (simp add: inf.coboundedI2 star.circ_sub_dist_1)
     also have "... = wcc p0"
       using 3 by (simp add: star_decompose_1)
     also have "... \<le> wcc (p0 \<squnion> y * x\<^sup>T)"
       by (simp add: wcc_isotone)
     finally have 14: "-s \<sqinter> p2 \<le> wcc (p0 \<squnion> y * x\<^sup>T)"
       by simp
     have "s * y\<^sup>T \<le> wcc p2"
       using 9 inf.order_trans star.circ_sub_dist sup_commute by fastforce
     also have "... = wcc p0"
       using 1 2 by (simp add: star_decompose_1)
     also have "... \<le> wcc (p0 \<squnion> y * x\<^sup>T)"
       by (simp add: wcc_isotone)
     finally have 15: "s * y\<^sup>T \<le> wcc (p0 \<squnion> y * x\<^sup>T)"
       by simp
     have 16: "y * x\<^sup>T \<le> wcc (p0 \<squnion> y * x\<^sup>T)"
       using le_supE star.circ_sub_dist_1 by blast
     have "x * r\<^sup>T \<le> p1\<^sup>\<star>"
       using 12 conv_dist_comp conv_order conv_star_commute by fastforce
     also have "... \<le> wcc p1"
       using star.circ_sub_dist sup_commute by fastforce
     also have "... = wcc p0"
       using 1 by (simp add: star_decompose_1)
     also have "... \<le> wcc (p0 \<squnion> y * x\<^sup>T)"
       by (simp add: wcc_isotone)
     finally have 17: "x * r\<^sup>T \<le> wcc (p0 \<squnion> y * x\<^sup>T)"
       by simp
     have "r \<le> r * x\<^sup>T * x \<and> s \<le> s * y\<^sup>T * y"
       using assms(1) shunt_bijective union_sets_precondition_def by blast
     hence "s * r\<^sup>T \<le> s * y\<^sup>T * y * (r * x\<^sup>T * x)\<^sup>T"
       using comp_isotone conv_isotone by blast
     also have "... = s * y\<^sup>T * y * x\<^sup>T * x * r\<^sup>T"
       by (simp add: comp_associative conv_dist_comp)
     also have "... \<le> wcc (p0 \<squnion> y * x\<^sup>T) * (y * x\<^sup>T) * (x * r\<^sup>T)"
       using 15 by (metis mult_left_isotone mult_assoc)
     also have "... \<le> wcc (p0 \<squnion> y * x\<^sup>T) * wcc (p0 \<squnion> y * x\<^sup>T) * (x * r\<^sup>T)"
       using 16 by (metis mult_left_isotone mult_right_isotone)
     also have "... \<le> wcc (p0 \<squnion> y * x\<^sup>T) * wcc (p0 \<squnion> y * x\<^sup>T) * wcc (p0 \<squnion> y * x\<^sup>T)"
       using 17 by (metis mult_right_isotone)
     also have "... = wcc (p0 \<squnion> y * x\<^sup>T)"
       by (simp add: star.circ_transitive_equal)
     finally have "?p \<le> wcc (p0 \<squnion> y * x\<^sup>T)"
       using 1 2 14 vector_covector by auto
     hence "wcc ?p \<le> wcc (p0 \<squnion> y * x\<^sup>T)"
       using wcc_below_wcc by blast
     also have "... = wcc (p0 \<squnion> x * y\<^sup>T)"
       using conv_dist_comp conv_dist_sup sup_assoc sup_commute by auto
     finally show "fc ?p \<le> wcc (p0 \<squnion> x * y\<^sup>T)"
       using 4 fc_wcc by simp
   qed
 qed
 
 lemma union_sets_1_skip:
   assumes "union_sets_precondition p0 x y"
     and "path_compression_postcondition p1 x r p0"
     and "path_compression_postcondition p2 y r p1"
   shows "union_sets_postcondition p2 x y p0"
 proof (unfold union_sets_postcondition_def union_sets_precondition_def, intro conjI)
   have 1: "point r \<and> r = root p1 x \<and> fc p1 = fc p0 \<and> disjoint_set_forest p2 \<and> r = root p2 y \<and> fc p2 = fc p1"
     using assms(2,3) path_compression_precondition_def path_compression_postcondition_def by auto
   thus "univalent p2" "total p2" "acyclic (p2 - 1)"
     by auto
   show "vector x" "injective x" "surjective x" "vector y" "injective y" "surjective y"
     using assms(1) union_sets_precondition_def by auto
   have "r \<le> p1\<^sup>T\<^sup>\<star> * x"
     using 1 by (metis inf_le1)
   hence "r * x\<^sup>T \<le> p1\<^sup>T\<^sup>\<star>"
     using assms(1) shunt_bijective union_sets_precondition_def by blast
   hence 2: "x * r\<^sup>T \<le> p1\<^sup>\<star>"
     using conv_dist_comp conv_order conv_star_commute by force
   have "r \<le> p2\<^sup>T\<^sup>\<star> * y"
     using 1 by (metis inf_le1)
   hence 3: "r * y\<^sup>T \<le> p2\<^sup>T\<^sup>\<star>"
     using assms(1) shunt_bijective union_sets_precondition_def by blast
   have "x * y\<^sup>T \<le> x * r\<^sup>T * r * y\<^sup>T"
     using 1 mult_left_isotone shunt_bijective by blast
   also have "... \<le> p1\<^sup>\<star> * p2\<^sup>T\<^sup>\<star>"
     using 2 3 by (metis comp_associative comp_isotone)
   also have "... \<le> wcc p0"
     using 1 by (metis star.circ_mult_upper_bound star_decompose_1 star_isotone sup_ge2 star.circ_sub_dist)
   finally show "fc p2 = wcc (p0 \<squnion> x * y\<^sup>T)"
     using 1 by (smt (z3) fc_star star_decompose_1 sup_absorb1 wcc_sup_wcc star.circ_sub_dist_3 sup_commute wcc_equivalence)
 qed
 
 end
 
 syntax
   "_Cond1" :: "'bexp \<Rightarrow> 'com \<Rightarrow> 'com"  ("(1IF _/ THEN _/ FI)" [0,0] 61)
 translations "IF b THEN c FI" == "IF b THEN c ELSE SKIP FI"
 
 context skra_peano_3
 begin
 
 lemma path_compression_preserves_rank_property:
   assumes "path_compression_postcondition p x y p0"
       and "disjoint_set_forest p0"
       and "rank_property p0 rank"
     shows "rank_property p rank"
 proof (unfold rank_property_def, intro conjI)
   let ?px = "p0\<^sup>T\<^sup>\<star> * x"
   have 1: "point y"
     using assms(1,2) path_compression_postcondition_def path_compression_precondition_def root_point by auto
   have 2: "vector ?px"
     using assms(1) comp_associative path_compression_postcondition_def path_compression_precondition_def by auto
   have "root p0 x = root p x"
     by (smt (verit) assms(1,2) path_compression_postcondition_def path_compression_precondition_def same_root)
   hence "root p0 x = y"
     using assms(1) path_compression_postcondition_def path_compression_precondition_def by auto
   hence "?px \<le> p0\<^sup>\<star> * y"
     by (meson assms(1,2) path_splitting_invariant_aux_1(3) path_compression_precondition_def path_compression_postcondition_def)
   hence "?px * y\<^sup>T \<le> p0\<^sup>\<star>"
     using 1 shunt_bijective by blast
   hence "?px \<sqinter> y\<^sup>T \<le> p0\<^sup>\<star>"
     using 1 2 by (simp add: vector_covector)
   also have "... = (p0 - 1)\<^sup>+ \<squnion> 1"
     using reachable_without_loops star_left_unfold_equal sup_commute by fastforce
   finally have 3: "?px \<sqinter> y\<^sup>T \<sqinter> -1 \<le> (p0 - 1)\<^sup>+"
     using half_shunting by blast
   have "p0[?px\<longmapsto>y] = p"
     using assms(1) path_compression_postcondition_def by simp
   hence "(p - 1) * rank = (?px \<sqinter> y\<^sup>T \<sqinter> -1) * rank \<squnion> (-?px \<sqinter> p0 \<sqinter> -1) * rank"
     using inf_sup_distrib2 mult_right_dist_sup by force
   also have "... \<le> (?px \<sqinter> y\<^sup>T \<sqinter> -1) * rank \<squnion> (p0 - 1) * rank"
     by (meson comp_inf.mult_semi_associative le_infE mult_left_isotone sup_right_isotone)
   also have "... \<le> (?px \<sqinter> y\<^sup>T \<sqinter> -1) * rank \<squnion> rank * S'\<^sup>+"
     using assms(3) rank_property_def sup_right_isotone by auto
   also have "... \<le> (p0 - 1)\<^sup>+ * rank \<squnion> rank * S'\<^sup>+"
     using 3 mult_left_isotone sup_left_isotone by blast
   also have "... \<le> rank * S'\<^sup>+"
   proof -
     have "(p0 - 1)\<^sup>\<star> * rank \<le> rank * S'\<^sup>\<star>"
       using assms(3) rank_property_def star_simulation_left star.left_plus_circ by fastforce
     hence "(p0 - 1)\<^sup>+ * rank \<le> (p0 - 1) * rank * S'\<^sup>\<star>"
       by (simp add: comp_associative mult_right_isotone)
     also have "... \<le> rank * S'\<^sup>+"
       by (smt (z3) assms(3) rank_property_def comp_associative comp_left_subdist_inf inf.boundedE inf.sup_right_divisibility star.circ_transitive_equal)
     finally show ?thesis
       by simp
   qed
   finally show "(p - 1) * rank \<le> rank * S'\<^sup>+"
     .
   show "univalent rank" "total rank"
     using rank_property_def assms(3) by auto
   show "card_less_eq (roots p) (-(S'\<^sup>+ * rank\<^sup>T * top))"
     using assms(1,3) path_compression_postcondition_def rank_property_def by auto
 qed
 
 theorem union_sets_by_rank:
   "VARS p r s rank
   [ union_sets_precondition p x y \<and> rank_property p rank \<and> p0 = p ]
   r := find_set p x;
   p := path_compression p x r;
   s := find_set p y;
   p := path_compression p y s;
   IF r \<noteq> s THEN
     IF rank[[r]] \<le> S'\<^sup>+ * (rank[[s]]) THEN
       p[r] := s
     ELSE
       p[s] := r;
       IF rank[[r]] = rank[[s]] THEN
         rank[r] := S'\<^sup>T * (rank[[r]])
       FI
     FI
   FI
   [ union_sets_postcondition p x y p0 \<and> rank_property p rank ]"
 proof vcg_tc_simp
   fix rank
   let ?r = "find_set p0 x"
   let ?p1 = "path_compression p0 x ?r"
   let ?s = "find_set ?p1 y"
   let ?p2 = "path_compression ?p1 y ?s"
   let ?p5 = "path_compression ?p1 y ?r"
   let ?rr = "rank[[?r]]"
   let ?rs = "rank[[?s]]"
   let ?rank = "rank[?r\<longmapsto>S'\<^sup>T * ?rs]"
   let ?p3 = "?p2[?r\<longmapsto>?s]"
   let ?p4 = "?p2[?s\<longmapsto>?r]"
   assume 1: "union_sets_precondition p0 x y \<and> rank_property p0 rank"
   hence 2: "path_compression_postcondition ?p1 x ?r p0"
     using find_set_function find_set_postcondition_def find_set_precondition_def path_compression_function path_compression_precondition_def union_sets_precondition_def by auto
   hence 3: "path_compression_postcondition ?p2 y ?s ?p1"
     using 1 find_set_function find_set_postcondition_def find_set_precondition_def path_compression_function path_compression_precondition_def union_sets_precondition_def path_compression_postcondition_def by meson
   have "rank_property ?p1 rank"
     using 1 2 path_compression_preserves_rank_property union_sets_precondition_def by blast
   hence 4: "rank_property ?p2 rank"
     using 1 2 3 by (meson path_compression_preserves_rank_property path_compression_postcondition_def path_compression_precondition_def)
   have 5: "point ?r" "point ?s"
     using 2 3 path_compression_postcondition_def path_compression_precondition_def by auto
   hence 6: "point ?rr" "point ?rs"
     using 1 comp_associative read_injective read_surjective rank_property_def by auto
   have "top \<le> S'\<^sup>\<star> \<squnion> S'\<^sup>+\<^sup>T"
     by (metis S'_star_connex conv_dist_comp conv_star_commute eq_refl star.circ_reflexive star_left_unfold_equal star_simulation_right_equal sup.orderE sup_monoid.add_assoc)
   hence 7: "-S'\<^sup>+\<^sup>T \<le> S'\<^sup>\<star>"
     by (metis comp_inf.case_split_left comp_inf.star.circ_plus_one comp_inf.star.circ_sup_2 half_shunting)
   show "(?r \<noteq> ?s \<longrightarrow> (?rr \<le> S'\<^sup>+ * ?rs \<longrightarrow> union_sets_postcondition ?p3 x y p0 \<and> rank_property ?p3 rank) \<and>
                       (\<not> ?rr \<le> S'\<^sup>+ * ?rs \<longrightarrow> ((?rr = ?rs \<longrightarrow> union_sets_postcondition ?p4 x y p0 \<and> rank_property ?p4 ?rank) \<and>
                                               (?rr \<noteq> ?rs \<longrightarrow> union_sets_postcondition ?p4 x y p0 \<and> rank_property ?p4 rank)))) \<and>
         (?r = ?s \<longrightarrow> union_sets_postcondition ?p5 x y p0 \<and> rank_property ?p5 rank)"
   proof
     show "?r \<noteq> ?s \<longrightarrow> (?rr \<le> S'\<^sup>+ * ?rs \<longrightarrow> union_sets_postcondition ?p3 x y p0 \<and> rank_property ?p3 rank) \<and>
                       (\<not> ?rr \<le> S'\<^sup>+ * ?rs \<longrightarrow> ((?rr = ?rs \<longrightarrow> union_sets_postcondition ?p4 x y p0 \<and> rank_property ?p4 ?rank) \<and>
                                               (?rr \<noteq> ?rs \<longrightarrow> union_sets_postcondition ?p4 x y p0 \<and> rank_property ?p4 rank)))"
     proof
       assume 8: "?r \<noteq> ?s"
       show "(?rr \<le> S'\<^sup>+ * ?rs \<longrightarrow> union_sets_postcondition ?p3 x y p0 \<and> rank_property ?p3 rank) \<and>
             (\<not> ?rr \<le> S'\<^sup>+ * ?rs \<longrightarrow> ((?rr = ?rs \<longrightarrow> union_sets_postcondition ?p4 x y p0 \<and> rank_property ?p4 ?rank) \<and>
                                     (?rr \<noteq> ?rs \<longrightarrow> union_sets_postcondition ?p4 x y p0 \<and> rank_property ?p4 rank)))"
       proof
         show "?rr \<le> S'\<^sup>+ * ?rs \<longrightarrow> union_sets_postcondition ?p3 x y p0 \<and> rank_property ?p3 rank"
         proof
           assume 9: "?rr \<le> S'\<^sup>+ * ?rs"
           show "union_sets_postcondition ?p3 x y p0 \<and> rank_property ?p3 rank"
           proof
             show "union_sets_postcondition ?p3 x y p0"
               using 1 2 3 by (simp add: union_sets_1)
             show "rank_property ?p3 rank"
             proof (unfold rank_property_def, intro conjI)
               show "univalent rank" "total rank"
                 using 1 rank_property_def by auto
               have "?s \<le> -?r"
                 using 5 8 by (meson order.antisym bijective_regular point_in_vector_or_complement point_in_vector_or_complement_2)
               hence "?r \<sqinter> ?s\<^sup>T \<sqinter> 1 = bot"
                 by (metis (full_types) bot_least inf.left_commute inf.sup_monoid.add_commute one_inf_conv pseudo_complement)
               hence "?p3 \<sqinter> 1 \<le> ?p2"
                 by (smt half_shunting inf.cobounded2 pseudo_complement regular_one_closed semiring.add_mono sup_commute)
               hence "roots ?p3 \<le> roots ?p2"
                 by (simp add: mult_left_isotone)
               thus "card_less_eq (roots ?p3) (-(S'\<^sup>+ * rank\<^sup>T * top))"
                 using 4 by (meson rank_property_def card_less_eq_def order_trans)
               have "(?p3 - 1) * rank = (?r \<sqinter> ?s\<^sup>T \<sqinter> -1) * rank \<squnion> (-?r \<sqinter> ?p2 \<sqinter> -1) * rank"
                 using comp_inf.semiring.distrib_right mult_right_dist_sup by auto
               also have "... \<le> (?r \<sqinter> ?s\<^sup>T \<sqinter> -1) * rank \<squnion> (?p2 - 1) * rank"
                 using comp_inf.mult_semi_associative mult_left_isotone sup_right_isotone by auto
               also have "... \<le> (?r \<sqinter> ?s\<^sup>T \<sqinter> -1) * rank \<squnion> rank * S'\<^sup>+"
                 using 4 sup_right_isotone rank_property_def by blast
               also have "... \<le> (?r \<sqinter> ?s\<^sup>T) * rank \<squnion> rank * S'\<^sup>+"
                 using inf_le1 mult_left_isotone sup_left_isotone by blast
               also have "... = ?r * ?s\<^sup>T * rank \<squnion> rank * S'\<^sup>+"
                 using 5 by (simp add: vector_covector)
               also have "... = rank * S'\<^sup>+"
               proof -
                 have "rank\<^sup>T * ?r \<le> S'\<^sup>+ * rank\<^sup>T * ?s"
                   using 9 comp_associative by auto
                 hence "?r \<le> rank * S'\<^sup>+ * rank\<^sup>T * ?s"
                   using 4 shunt_mapping comp_associative rank_property_def by auto
                 hence "?r * ?s\<^sup>T \<le> rank * S'\<^sup>+ * rank\<^sup>T"
                   using 5 shunt_bijective by blast
                 hence "?r * ?s\<^sup>T * rank \<le> rank * S'\<^sup>+"
                   using 4 shunt_bijective rank_property_def mapping_conv_bijective by auto
                 thus ?thesis
                   using sup_absorb2 by blast
               qed
               finally show "(?p3 - 1) * rank \<le> rank * S'\<^sup>+"
                 .
             qed
           qed
         qed
         show "\<not> ?rr \<le> S'\<^sup>+ * ?rs \<longrightarrow> ((?rr = ?rs \<longrightarrow> union_sets_postcondition ?p4 x y p0 \<and> rank_property ?p4 ?rank) \<and>
                                      (?rr \<noteq> ?rs \<longrightarrow> union_sets_postcondition ?p4 x y p0 \<and> rank_property ?p4 rank))"
         proof
           assume "\<not> ?rr \<le> S'\<^sup>+ * ?rs"
           hence "?rr \<le> -(S'\<^sup>+ * ?rs)"
             using 6 by (meson point_in_vector_or_complement S'_regular bijective_regular regular_closed_star regular_mult_closed vector_mult_closed)
           also have "... = -S'\<^sup>+ * ?rs"
             using 6 comp_bijective_complement by simp
           finally have "?rs \<le> -S'\<^sup>+\<^sup>T * ?rr"
             using 6 by (metis bijective_reverse conv_complement)
           also have "... \<le> S'\<^sup>\<star> * ?rr"
             using 7 by (simp add: mult_left_isotone)
           also have "... = S'\<^sup>+ * ?rr \<squnion> ?rr"
             using star.circ_loop_fixpoint mult_assoc by auto
           finally have 10: "?rs - ?rr \<le> S'\<^sup>+ * ?rr"
             using half_shunting by blast
           show "((?rr = ?rs \<longrightarrow> union_sets_postcondition ?p4 x y p0 \<and> rank_property ?p4 ?rank) \<and>
                  (?rr \<noteq> ?rs \<longrightarrow> union_sets_postcondition ?p4 x y p0 \<and> rank_property ?p4 rank))"
           proof
             show "?rr = ?rs \<longrightarrow> union_sets_postcondition ?p4 x y p0 \<and> rank_property ?p4 ?rank"
             proof
               assume 11: "?rr = ?rs"
               show "union_sets_postcondition ?p4 x y p0 \<and> rank_property ?p4 ?rank"
               proof
                 show "union_sets_postcondition ?p4 x y p0"
                   using 1 2 3 by (simp add: union_sets_1_swap)
                 show "rank_property ?p4 ?rank"
                 proof (unfold rank_property_def, intro conjI)
                   show "univalent ?rank"
                     using 4 5 6 by (meson S'_univalent read_injective update_univalent rank_property_def)
                   have "card_less_eq (roots ?p2) (-(S'\<^sup>+ * rank\<^sup>T * top))"
                     using 4 rank_property_def by blast
                   from this obtain i where 12: "injective i \<and> univalent i \<and> regular i \<and> roots ?p2 \<le> i * -(S'\<^sup>+ * rank\<^sup>T * top)"
                     using card_less_eq_def by blast
                   let ?i = "(i[?s\<longmapsto>i[[i * ?rr]]])[i * ?rr\<longmapsto>i[[?s]]]"
                   have 13: "?i = (i * ?rr \<sqinter> ?s\<^sup>T * i) \<squnion> (-(i * ?rr) \<sqinter> ?s \<sqinter> ?rr\<^sup>T * i\<^sup>T * i) \<squnion> (-(i * ?rr) \<sqinter> -?s \<sqinter> i)"
                     by (smt (z3) conv_dist_comp conv_involutive inf.sup_monoid.add_assoc inf_sup_distrib1 sup_assoc)
                   have 14: "injective ?i"
                     apply (rule update_injective_swap)
                     subgoal using 12 by simp
                     subgoal using 5 by simp
                     subgoal using 6 12 injective_mult_closed by simp
                     subgoal using 5 comp_associative by simp
                     done
                   have 15: "univalent ?i"
                     apply (rule update_univalent_swap)
                     subgoal using 12 by simp
                     subgoal using 5 by simp
                     subgoal using 5 by simp
                     subgoal using 6 12 injective_mult_closed by simp
                     subgoal using 5 comp_associative by simp
                     done
                   have 16: "regular ?i"
                     using 5 6 12 by (smt (z3) bijective_regular p_dist_inf p_dist_sup pp_dist_comp regular_closed_inf regular_conv_closed)
                   have 17: "regular (i * ?rr)"
                     using 6 12 bijective_regular regular_mult_closed by blast
                   have 18: "find_set_precondition ?p1 y"
                     using 2 3 find_set_precondition_def path_compression_postcondition_def path_compression_precondition_def by blast
                   hence "?s = root ?p1 y"
                     by (meson find_set_function find_set_postcondition_def)
                   also have "... = root ?p2 y"
                     using 3 18 by (smt (z3) find_set_precondition_def path_compression_postcondition_def path_compression_precondition_def same_root)
                   also have "... \<le> roots ?p2"
                     by simp
                   also have "... \<le> i * -(S'\<^sup>+ * rank\<^sup>T * top)"
                     using 12 by simp
                   finally have 19: "?s \<le> i * -(S'\<^sup>+ * rank\<^sup>T * top)"
                     .
                   have "roots ?p4 \<le> ?i * -(S'\<^sup>+ * ?rank\<^sup>T * top)"
                   proof -
                     have "?r \<le> -?s"
                       using 5 8 by (meson order.antisym bijective_regular point_in_vector_or_complement point_in_vector_or_complement_2)
                     hence "?s \<sqinter> ?r\<^sup>T \<sqinter> 1 = bot"
                       by (metis (full_types) bot_least inf.left_commute inf.sup_monoid.add_commute one_inf_conv pseudo_complement)
                     hence "?p4 \<sqinter> 1 \<le> -?s \<sqinter> ?p2"
                       by (smt (z3) bot_least comp_inf.semiring.distrib_left inf.cobounded2 inf.sup_monoid.add_commute le_supI)
                     hence "roots ?p4 \<le> roots (-?s \<sqinter> ?p2)"
                       by (simp add: mult_left_isotone)
                     also have "... = -?s \<sqinter> roots ?p2"
                       using 5 inf_assoc vector_complement_closed vector_inf_comp by auto
                     also have "... = (i * ?rr \<sqinter> -?s \<sqinter> roots ?p2) \<squnion> (-(i * ?rr) \<sqinter> -?s \<sqinter> roots ?p2)"
                       using 17 by (smt (z3) comp_inf.star_plus inf_sup_distrib2 inf_top.right_neutral regular_complement_top)
                     also have "... \<le> ?i * (-(S'\<^sup>+ * ?rank\<^sup>T * top))"
                     proof (rule sup_least)
                       have "?rank\<^sup>T * top = (?r \<sqinter> (S'\<^sup>T * ?rs)\<^sup>T)\<^sup>T * top \<squnion> (-?r \<sqinter> rank)\<^sup>T * top"
                         using conv_dist_sup mult_right_dist_sup by auto
                       also have "... = (?r\<^sup>T \<sqinter> S'\<^sup>T * ?rs) * top \<squnion> (-?r\<^sup>T \<sqinter> rank\<^sup>T) * top"
                         using conv_complement conv_dist_inf conv_involutive by auto
                       also have "... = S'\<^sup>T * ?rs * (?r \<sqinter> top) \<squnion> (-?r\<^sup>T \<sqinter> rank\<^sup>T) * top"
                         using 5 by (smt (z3) covector_inf_comp_3 inf_commute)
                       also have "... = S'\<^sup>T * ?rs * (?r \<sqinter> top) \<squnion> rank\<^sup>T * (-?r \<sqinter> top)"
                         using 5 by (smt (z3) conv_complement vector_complement_closed covector_inf_comp_3 inf_commute)
                       also have "... = S'\<^sup>T * ?rs * ?r \<squnion> rank\<^sup>T * -?r"
                         by simp
                       also have "... \<le> S'\<^sup>T * ?rs * ?r \<squnion> rank\<^sup>T * top"
                         using mult_right_isotone sup_right_isotone by force
                       also have "... \<le> S'\<^sup>T * ?rs \<squnion> rank\<^sup>T * top"
                         using 5 6 by (metis inf.eq_refl mult_assoc)
                       finally have "S'\<^sup>+ * ?rank\<^sup>T * top \<le> S'\<^sup>+ * S'\<^sup>T * ?rs \<squnion> S'\<^sup>+ * rank\<^sup>T * top"
                         by (smt comp_associative mult_left_dist_sup mult_right_isotone)
                       also have "... = S'\<^sup>\<star> * (S' * S'\<^sup>T) * ?rs \<squnion> S'\<^sup>+ * rank\<^sup>T * top"
                         by (smt star_plus mult_assoc)
                       also have "... \<le> S'\<^sup>\<star> * ?rs \<squnion> S'\<^sup>+ * rank\<^sup>T * top"
                         by (metis S'_injective comp_right_one mult_left_isotone mult_right_isotone sup_left_isotone)
                       also have "... = ?rs \<squnion> S'\<^sup>+ * ?rs \<squnion> S'\<^sup>+ * rank\<^sup>T * top"
                         using comp_associative star.circ_loop_fixpoint sup_commute by fastforce
                       also have "... = ?rs \<squnion> S'\<^sup>+ * rank\<^sup>T * top"
                         by (smt (verit, del_insts) comp_associative mult_left_dist_sup sup.orderE sup_assoc sup_commute top.extremum)
                       finally have 20: "S'\<^sup>+ * ?rank\<^sup>T * top \<le> ?rs \<squnion> S'\<^sup>+ * rank\<^sup>T * top"
                         .
                       have "?s * ?s\<^sup>T = (?s \<sqinter> i * -(S'\<^sup>+ * rank\<^sup>T * top)) * ?s\<^sup>T"
                         using 19 inf.orderE by fastforce
                       also have "... = (?s \<sqinter> i * -(S'\<^sup>+ * rank\<^sup>T * top)) * top \<sqinter> ?s\<^sup>T"
                         using 5 by (smt (z3) covector_comp_inf vector_conv_covector vector_covector vector_top_closed)
                       also have "... = ?s \<sqinter> i * -(S'\<^sup>+ * rank\<^sup>T * top) * top \<sqinter> ?s\<^sup>T"
                         using 5 vector_inf_comp by auto
                       also have "... \<le> 1 \<sqinter> i * -(S'\<^sup>+ * rank\<^sup>T * top) * top"
                         using 5 by (smt (verit, ccfv_SIG) inf.cobounded1 inf.cobounded2 inf_greatest order_trans vector_covector)
                       also have "... = 1 \<sqinter> i * -(S'\<^sup>+ * rank\<^sup>T * top)"
                         using comp_associative vector_complement_closed vector_top_closed by auto
                       also have "... \<le> 1 \<sqinter> i * -(S'\<^sup>+ * rank\<^sup>T)"
                         by (meson comp_inf.mult_right_isotone mult_right_isotone p_antitone top_right_mult_increasing)
                       also have "... \<le> 1 \<sqinter> i * S'\<^sup>\<star>\<^sup>T * rank\<^sup>T"
                       proof -
                         have "S'\<^sup>\<star>\<^sup>T * rank\<^sup>T \<squnion> S'\<^sup>+ * rank\<^sup>T = (S'\<^sup>T\<^sup>\<star> \<squnion> S'\<^sup>+) * rank\<^sup>T"
                           by (simp add: conv_star_commute mult_right_dist_sup)
                         also have "... = (S'\<^sup>T\<^sup>\<star> \<squnion> S'\<^sup>\<star>) * rank\<^sup>T"
                           by (smt (z3) comp_associative semiring.distrib_right star.circ_loop_fixpoint sup.left_commute sup_commute sup_idem)
                         also have "... = top * rank\<^sup>T"
                           by (simp add: S'_star_connex sup_commute)
                         also have "... = top"
                           using 4 rank_property_def total_conv_surjective by blast
                         finally have "-(S'\<^sup>+ * rank\<^sup>T) \<le> S'\<^sup>\<star>\<^sup>T * rank\<^sup>T"
                           by (metis half_shunting inf.idem top_greatest)
                         thus ?thesis
                           using comp_associative inf.sup_right_isotone mult_right_isotone by auto
                       qed
                       also have "... = 1 \<sqinter> rank * S'\<^sup>\<star> * i\<^sup>T"
                         by (metis comp_associative conv_dist_comp conv_involutive one_inf_conv)
                       also have "... \<le> rank * S'\<^sup>\<star> * i\<^sup>T"
                         by simp
                       finally have "?s \<le> rank * S'\<^sup>\<star> * i\<^sup>T * ?s"
                         using 5 shunt_bijective by auto
                       hence "?rs \<le> S'\<^sup>\<star> * i\<^sup>T * ?s"
                         using 4 shunt_mapping comp_associative rank_property_def by auto
                       hence "?s * (i * ?rr \<sqinter> -?s \<sqinter> roots ?p2) \<le> ?s * (i * S'\<^sup>\<star> * i\<^sup>T * ?s \<sqinter> -?s \<sqinter> roots ?p2)"
                         using 11 comp_associative comp_inf.mult_left_isotone comp_isotone inf.eq_refl by auto
                       also have "... = ?s * ((i * S'\<^sup>+ * i\<^sup>T * ?s \<squnion> i * i\<^sup>T * ?s) \<sqinter> -?s \<sqinter> roots ?p2)"
                         by (metis comp_associative mult_left_dist_sup star.circ_loop_fixpoint)
                       also have "... \<le> ?s * ((i * S'\<^sup>+ * i\<^sup>T * ?s \<squnion> 1 * ?s) \<sqinter> -?s \<sqinter> roots ?p2)"
                         using 12 by (metis mult_left_isotone sup_right_isotone comp_inf.mult_left_isotone mult_right_isotone)
                       also have "... = ?s * (i * S'\<^sup>+ * i\<^sup>T * ?s \<sqinter> -?s \<sqinter> roots ?p2)"
                         using comp_inf.comp_right_dist_sup by simp
                       also have "... \<le> ?s * (i * S'\<^sup>+ * i\<^sup>T * ?s \<sqinter> roots ?p2)"
                         using comp_inf.mult_left_isotone inf.cobounded1 mult_right_isotone by blast
                       also have "... \<le> ?s * (i * S'\<^sup>+ * i\<^sup>T * ?s \<sqinter> i * -(S'\<^sup>+ * rank\<^sup>T * top))"
                         using 12 comp_inf.mult_right_isotone mult_right_isotone by auto
                       also have "... = ?s * (i * S'\<^sup>+ * i\<^sup>T * ?s \<sqinter> i) * -(S'\<^sup>+ * rank\<^sup>T * top)"
                         using 5 by (simp add: comp_associative vector_inf_comp)
                       also have "... = (?s \<sqinter> (i * S'\<^sup>+ * i\<^sup>T * ?s)\<^sup>T) * i * -(S'\<^sup>+ * rank\<^sup>T * top)"
                         using 5 covector_inf_comp_3 mult_assoc by auto
                       also have "... = (?s \<sqinter> ?s\<^sup>T * i * S'\<^sup>+\<^sup>T * i\<^sup>T) * i * -(S'\<^sup>+ * rank\<^sup>T * top)"
                         using conv_dist_comp conv_involutive mult_assoc by auto
                       also have "... = (?s \<sqinter> ?s\<^sup>T) * i * S'\<^sup>+\<^sup>T * i\<^sup>T * i * -(S'\<^sup>+ * rank\<^sup>T * top)"
                         using 5 vector_inf_comp by auto
                       also have "... \<le> i * S'\<^sup>+\<^sup>T * i\<^sup>T * i * -(S'\<^sup>+ * rank\<^sup>T * top)"
                         using 5 by (metis point_antisymmetric mult_left_isotone mult_left_one)
                       also have "... \<le> i * S'\<^sup>+\<^sup>T * -(S'\<^sup>+ * rank\<^sup>T * top)"
                         using 12 by (smt mult_left_isotone mult_right_isotone mult_assoc comp_right_one)
                       also have "... \<le> i * -(S'\<^sup>\<star> * rank\<^sup>T * top)"
                       proof -
                         have "S'\<^sup>+ * S'\<^sup>\<star> * rank\<^sup>T * top \<le> S'\<^sup>+ * rank\<^sup>T * top"
                           by (simp add: comp_associative star.circ_transitive_equal)
                         hence "S'\<^sup>+\<^sup>T * -(S'\<^sup>+ * rank\<^sup>T * top) \<le> -(S'\<^sup>\<star> * rank\<^sup>T * top)"
                           by (smt (verit, ccfv_SIG) comp_associative conv_complement_sub_leq mult_right_isotone order.trans p_antitone)
                         thus ?thesis
                           by (simp add: comp_associative mult_right_isotone)
                       qed
                       also have "... \<le> i * -(S'\<^sup>+ * ?rank\<^sup>T * top)"
                       proof -
                         have "S'\<^sup>+ * ?rank\<^sup>T * top \<le> ?rs \<squnion> S'\<^sup>+ * rank\<^sup>T * top"
                           using 20 by simp
                         also have "... \<le> rank\<^sup>T * top \<squnion> S'\<^sup>+ * rank\<^sup>T * top"
                           using mult_right_isotone sup_left_isotone top.extremum by blast
                         also have "... = S'\<^sup>\<star> * rank\<^sup>T * top"
                           using comp_associative star.circ_loop_fixpoint sup_commute by auto
                         finally show ?thesis
                           using mult_right_isotone p_antitone by blast
                       qed
                       finally have "?s * (i * ?rr \<sqinter> -?s \<sqinter> roots ?p2) \<le> i * -(S'\<^sup>+ * ?rank\<^sup>T * top)"
                         .
                       hence "i * ?rr \<sqinter> -?s \<sqinter> roots ?p2 \<le> ?s\<^sup>T * i * -(S'\<^sup>+ * ?rank\<^sup>T * top)"
                         using 5 shunt_mapping bijective_conv_mapping mult_assoc by auto
                       hence "i * ?rr \<sqinter> -?s \<sqinter> roots ?p2 \<le> i * ?rr \<sqinter> ?s\<^sup>T * i * -(S'\<^sup>+ * ?rank\<^sup>T * top)"
                         by (simp add: inf.sup_monoid.add_assoc)
                       also have "... = (i * ?rr \<sqinter> ?s\<^sup>T * i) * -(S'\<^sup>+ * ?rank\<^sup>T * top)"
                         using 6 vector_inf_comp vector_mult_closed by simp
                       also have "... \<le> ?i * -(S'\<^sup>+ * ?rank\<^sup>T * top)"
                         using 13 comp_left_increasing_sup sup_assoc by auto
                       finally show "i * ?rr \<sqinter> -?s \<sqinter> roots ?p2 \<le> ?i * -(S'\<^sup>+ * ?rank\<^sup>T * top)"
                         .
                       have "-(i * ?rr) \<sqinter> roots ?p2 \<le> -(i * ?rr) \<sqinter> i * -(S'\<^sup>+ * rank\<^sup>T * top)"
                         using 12 inf.sup_right_isotone by auto
                       also have "... \<le> -(i * ?rr) \<sqinter> i * -(?rs \<squnion> S'\<^sup>+ * rank\<^sup>T * top)"
                       proof -
                         have 21: "regular (?rs \<squnion> S'\<^sup>+ * rank\<^sup>T * top)"
                           using 4 6 rank_property_def mapping_regular S'_regular pp_dist_star regular_conv_closed regular_mult_closed bijective_regular regular_closed_sup by auto
                         have "?rs \<squnion> S'\<^sup>+ * rank\<^sup>T * top \<le> S'\<^sup>+ * rank\<^sup>T * top \<squnion> ?rr"
                           using 11 by simp
                         hence "(?rs \<squnion> S'\<^sup>+ * rank\<^sup>T * top) - S'\<^sup>+ * rank\<^sup>T * top \<le> ?rr"
                           using half_shunting sup_commute by auto
                         hence "-(S'\<^sup>+ * rank\<^sup>T * top) \<le> -(?rs \<squnion> S'\<^sup>+ * rank\<^sup>T * top) \<squnion> ?rr"
                           using 21 by (metis inf.sup_monoid.add_commute shunting_var_p sup_commute)
                         hence "i * -(S'\<^sup>+ * rank\<^sup>T * top) \<le> i * -(?rs \<squnion> S'\<^sup>+ * rank\<^sup>T * top) \<squnion> i * ?rr"
                           by (metis mult_left_dist_sup mult_right_isotone)
                         hence "-(i * ?rr) \<sqinter> i * -(S'\<^sup>+ * rank\<^sup>T * top) \<le> i * -(?rs \<squnion> S'\<^sup>+ * rank\<^sup>T * top)"
                           using half_shunting inf.sup_monoid.add_commute by fastforce
                         thus ?thesis
                           using inf.le_sup_iff by blast
                       qed
                       also have "... \<le> -(i * ?rr) \<sqinter> i * -(S'\<^sup>+ * ?rank\<^sup>T * top)"
                         using 20 by (meson comp_inf.mult_right_isotone mult_right_isotone p_antitone)
                       finally have "-(i * ?rr) \<sqinter> -?s \<sqinter> roots ?p2 \<le> -(i * ?rr) \<sqinter> -?s \<sqinter> i * -(S'\<^sup>+ * ?rank\<^sup>T * top)"
                         by (smt (z3) inf.boundedI inf.cobounded1 inf.coboundedI2 inf.sup_monoid.add_assoc inf.sup_monoid.add_commute)
                       also have "... \<le> ?i * (-(S'\<^sup>+ * ?rank\<^sup>T * top))"
                         using 5 6 13 by (smt (z3) sup_commute vector_complement_closed vector_inf_comp vector_mult_closed comp_left_increasing_sup)
                       finally show "-(i * ?rr) \<sqinter> -?s \<sqinter> roots ?p2 \<le> ?i * -(S'\<^sup>+ * ?rank\<^sup>T * top)"
                         .
                     qed
                     finally show ?thesis
                       .
                   qed
                   thus "card_less_eq (roots ?p4) (-(S'\<^sup>+ * ?rank\<^sup>T * top))"
                     using 14 15 16 card_less_eq_def by auto
                   have "?s \<le> i * -(S'\<^sup>+ * rank\<^sup>T * top)"
                     using 19 by simp
                   also have "... \<le> i * -(S'\<^sup>+ * ?rr)"
                     using mult_right_isotone p_antitone top.extremum mult_assoc by auto
                   also have "... = i * -S'\<^sup>+ * ?rr"
                     using 6 comp_bijective_complement mult_assoc by fastforce
                   finally have "?rr \<le> -S'\<^sup>T\<^sup>+ * i\<^sup>T * ?s"
                     using 5 6 by (metis conv_complement conv_dist_comp conv_plus_commute bijective_reverse)
                   also have "... \<le> S'\<^sup>\<star> * i\<^sup>T * ?s"
                     using 7 conv_plus_commute mult_left_isotone by auto
                   finally have 22: "?rr \<le> S'\<^sup>\<star> * i\<^sup>T * ?s"
                     .
                   have "?r = root ?p1 x"
                     using 2 path_compression_postcondition_def path_compression_precondition_def by blast
                   also have "... = root ?p2 x"
                     using 3 18 by (smt (z3) find_set_precondition_def path_compression_postcondition_def path_compression_precondition_def same_root)
                   also have "... \<le> roots ?p2"
                     by simp
                   also have "... \<le> i * -(S'\<^sup>+ * rank\<^sup>T * top)"
                     using 12 by simp
                   also have "... \<le> i * -(S'\<^sup>+ * ?rr)"
                     using mult_right_isotone p_antitone top.extremum mult_assoc by auto
                   also have "... = i * -S'\<^sup>+ * ?rr"
                     using 6 comp_bijective_complement mult_assoc by fastforce
                   finally have "?rr \<le> -S'\<^sup>T\<^sup>+ * i\<^sup>T * ?r"
                     using 5 6 by (metis conv_complement conv_dist_comp conv_plus_commute bijective_reverse)
                   also have "... \<le> S'\<^sup>\<star> * i\<^sup>T * ?r"
                     using 7 conv_plus_commute mult_left_isotone by auto
                   finally have "?rr \<le> S'\<^sup>\<star> * i\<^sup>T * ?r"
                     .
                   hence "?rr \<le> S'\<^sup>\<star> * i\<^sup>T * ?r \<sqinter> S'\<^sup>\<star> * i\<^sup>T * ?s"
                     using 22 inf.boundedI by blast
                   also have "... = (S'\<^sup>+ * i\<^sup>T * ?r \<squnion> i\<^sup>T * ?r) \<sqinter> S'\<^sup>\<star> * i\<^sup>T * ?s"
                     by (simp add: star.circ_loop_fixpoint mult_assoc)
                   also have "... \<le> S'\<^sup>+ * i\<^sup>T * ?r \<squnion> (i\<^sup>T * ?r \<sqinter> S'\<^sup>\<star> * i\<^sup>T * ?s)"
                     by (metis comp_inf.mult_right_dist_sup eq_refl inf.cobounded1 semiring.add_mono)
                   also have "... \<le> S' * top \<squnion> (i\<^sup>T * ?r \<sqinter> S'\<^sup>\<star> * i\<^sup>T * ?s)"
                     using comp_associative mult_right_isotone sup_left_isotone top.extremum by auto
                   also have "... = S' * top \<squnion> (i\<^sup>T * ?r \<sqinter> (S'\<^sup>+ * i\<^sup>T * ?s \<squnion> i\<^sup>T * ?s))"
                     by (simp add: star.circ_loop_fixpoint mult_assoc)
                   also have "... \<le> S' * top \<squnion> S'\<^sup>+ * i\<^sup>T * ?s \<squnion> (i\<^sup>T * ?r \<sqinter> i\<^sup>T * ?s)"
                     by (smt (z3) comp_inf.semiring.distrib_left inf.sup_right_divisibility star.circ_loop_fixpoint sup_assoc sup_commute sup_inf_distrib1)
                   also have "... \<le> S' * top \<squnion> (i\<^sup>T * ?r \<sqinter> i\<^sup>T * ?s)"
                     by (metis comp_associative mult_right_isotone order.refl sup.orderE top.extremum)
                   also have "... = S' * top \<squnion> i\<^sup>T * (?r \<sqinter> ?s)"
                     using 12 conv_involutive univalent_comp_left_dist_inf by auto
                   also have "... = S' * top"
                     using 5 8 distinct_points by auto
                   finally have "top \<le> ?rr\<^sup>T * S' * top"
                     using 6 by (smt conv_involutive shunt_mapping bijective_conv_mapping mult_assoc)
                   hence "surjective (S'\<^sup>T * ?rs)"
                     using 6 11 by (smt conv_dist_comp conv_involutive point_conv_comp top_le)
                   thus "total ?rank"
                     using 4 5 bijective_regular update_total rank_property_def by blast
                   show "(?p4 - 1) * ?rank \<le> ?rank * S'\<^sup>+"
                   proof -
                     have 23: "univalent ?p2"
                       using 3 path_compression_postcondition_def path_compression_precondition_def by blast
                     have 24: "?r \<sqinter> (?p4 - 1) * ?rank \<le> ?s\<^sup>T * rank * S' * S'\<^sup>+"
                     proof -
                       have "?r \<sqinter> (?p4 - 1) * ?rank = (?r \<sqinter> ?p4 \<sqinter> -1) * ?rank"
                         using 5 vector_complement_closed vector_inf_comp inf_assoc by auto
                       also have "... = (?r \<sqinter> -?s \<sqinter> ?p4 \<sqinter> -1) * ?rank"
                           using 5 8 by (smt (z3) order.antisym bijective_regular point_in_vector_or_complement point_in_vector_or_complement_2 inf_absorb1)
                       also have "... = (?r \<sqinter> -?s \<sqinter> ?p2 \<sqinter> -1) * ?rank"
                         by (simp add: inf.left_commute inf.sup_monoid.add_commute inf_sup_distrib1 inf_assoc)
                       also have "... \<le> (?r \<sqinter> ?p2 \<sqinter> -1) * ?rank"
                         using inf.sup_left_isotone inf_le1 mult_left_isotone by blast
                       also have "... = bot"
                       proof -
                         have "?r = root ?p1 x"
                           using 2 path_compression_postcondition_def path_compression_precondition_def by blast
                         also have "... = root ?p2 x"
                           using 3 18 by (smt (z3) find_set_precondition_def path_compression_postcondition_def path_compression_precondition_def same_root)
                         also have "... \<le> roots ?p2"
                           by simp
                         finally have "?r \<sqinter> ?p2 \<le> roots ?p2 \<sqinter> ?p2"
                           using inf.sup_left_isotone by blast
                         also have "... \<le> (?p2 \<sqinter> 1) * (?p2 \<sqinter> 1)\<^sup>T * ?p2"
                           by (smt (z3) comp_associative comp_inf.star_plus dedekind_1 inf_top_right order_lesseq_imp)
                         also have "... = (?p2 \<sqinter> 1) * (?p2 \<sqinter> 1) * ?p2"
                           using coreflexive_symmetric by force
                         also have "... \<le> (?p2 \<sqinter> 1) * ?p2"
                           by (metis coreflexive_comp_top_inf inf.cobounded2 mult_left_isotone)
                         also have "... \<le> ?p2 \<sqinter> 1"
                           by (smt 23 comp_inf.mult_semi_associative conv_dist_comp conv_dist_inf conv_order equivalence_one_closed inf.absorb1 inf.sup_monoid.add_assoc injective_codomain)
                         also have "... \<le> 1"
                           by simp
                         finally have "?r \<sqinter> ?p2 \<le> 1"
                           .
                         thus ?thesis
                           by (metis pseudo_complement regular_one_closed semiring.mult_not_zero)
                       qed
                       finally show ?thesis
                         using bot_least le_bot by blast
                     qed
                     have 25: "-?r \<sqinter> (?p4 - 1) * ?rank \<le> rank * S'\<^sup>+"
                     proof -
                       have "-?r \<sqinter> (?p4 - 1) * ?rank = (-?r \<sqinter> ?p4 \<sqinter> -1) * ?rank"
                         using 5 vector_complement_closed vector_inf_comp inf_assoc by auto
                       also have "... = (-?r \<sqinter> (?s \<squnion> -?s) \<sqinter> ?p4 \<sqinter> -1) * ?rank"
                         using 5 bijective_regular inf_top_right regular_complement_top by auto
                       also have "... = (-?r \<sqinter> ?s \<sqinter> ?p4 \<sqinter> -1) * ?rank \<squnion> (-?r \<sqinter> -?s \<sqinter> ?p4 \<sqinter> -1) * ?rank"
                         by (smt (z3) inf_sup_distrib1 inf_sup_distrib2 mult_right_dist_sup)
                       also have "... = (-?r \<sqinter> ?s \<sqinter> ?r\<^sup>T \<sqinter> -1) * ?rank \<squnion> (-?r \<sqinter> -?s \<sqinter> ?p2 \<sqinter> -1) * ?rank"
                         using 5 by (smt (z3) bijective_regular comp_inf.comp_left_dist_sup inf_assoc inf_commute inf_top_right mult_right_dist_sup regular_complement_top)
                       also have "... \<le> (?s \<sqinter> ?r\<^sup>T \<sqinter> -1) * ?rank \<squnion> (-?s \<sqinter> ?p2 \<sqinter> -1) * ?rank"
                         by (smt (z3) comp_inf.semiring.distrib_left inf.cobounded2 inf.sup_monoid.add_assoc mult_left_isotone mult_right_dist_sup)
                       also have "... \<le> (?s \<sqinter> ?r\<^sup>T) * ?rank \<squnion> (?p2 - 1) * ?rank"
                         by (smt (z3) inf.cobounded1 inf.cobounded2 inf.sup_monoid.add_assoc mult_left_isotone semiring.add_mono)
                       also have "... = ?s * (?r \<sqinter> ?rank) \<squnion> (?p2 - 1) * ?rank"
                         using 5 by (simp add: covector_inf_comp_3)
                       also have "... = ?s * (?r \<sqinter> (S'\<^sup>T * ?rs)\<^sup>T) \<squnion> (?p2 - 1) * ?rank"
                         using inf_commute update_inf_same mult_assoc by force
                       also have "... = ?s * (?r \<sqinter> ?s\<^sup>T * rank * S') \<squnion> (?p2 - 1) * ?rank"
                         using comp_associative conv_dist_comp conv_involutive by auto
                       also have "... \<le> ?s * ?s\<^sup>T * rank * S' \<squnion> (?p2 - 1) * ?rank"
                         using comp_associative inf.cobounded2 mult_right_isotone semiring.add_right_mono by auto
                       also have "... \<le> 1 * rank * S' \<squnion> (?p2 - 1) * ?rank"
                         using 5 by (meson mult_left_isotone order.refl semiring.add_mono)
                       also have "... = rank * S' \<squnion> (?p2 - 1) * (?r \<sqinter> (S'\<^sup>T * ?rr)\<^sup>T) \<squnion> (?p2 - 1) * (-?r \<sqinter> rank)"
                         using 11 comp_associative mult_1_left mult_left_dist_sup sup_assoc by auto
                       also have "... \<le> rank * S' \<squnion> (?p2 - 1) * (?r \<sqinter> ?r\<^sup>T * rank * S') \<squnion> (?p2 - 1) * rank"
                         using comp_associative conv_dist_comp conv_involutive inf.cobounded1 inf.sup_monoid.add_commute mult_right_isotone semiring.add_left_mono by auto
                       also have "... = rank * S' \<squnion> (?p2 - 1) * (?r \<sqinter> ?r\<^sup>T) * rank * S' \<squnion> (?p2 - 1) * rank"
                         using 5 comp_associative vector_inf_comp by auto
                       also have "... \<le> rank * S' \<squnion> (?p2 - 1) * rank * S' \<squnion> (?p2 - 1) * rank"
                         using 5 by (metis point_antisymmetric mult_left_isotone mult_right_isotone sup_left_isotone sup_right_isotone comp_right_one)
                       also have "... \<le> rank * S' \<squnion> rank * S'\<^sup>+ * S' \<squnion> (?p2 - 1) * rank"
                         using 4 by (metis rank_property_def mult_left_isotone sup_left_isotone sup_right_isotone)
                       also have "... \<le> rank * S' \<squnion> rank * S'\<^sup>+ * S' \<squnion> rank * S'\<^sup>+"
                         using 4 by (metis rank_property_def sup_right_isotone)
                       also have "... \<le> rank * S'\<^sup>+"
                         using comp_associative eq_refl le_sup_iff mult_right_isotone star.circ_mult_increasing star.circ_plus_same star.left_plus_below_circ by auto
                       finally show ?thesis
                         .
                     qed
                     have "(?p4 - 1) * ?rank = (?r \<sqinter> (?p4 - 1) * ?rank) \<squnion> (-?r \<sqinter> (?p4 - 1) * ?rank)"
                       using 5 by (smt (verit, ccfv_threshold) bijective_regular inf_commute inf_sup_distrib2 inf_top_right regular_complement_top)
                     also have "... \<le> (?r \<sqinter> ?s\<^sup>T * rank * S' * S'\<^sup>+) \<squnion> (-?r \<sqinter> rank * S'\<^sup>+)"
                       using 24 25 by (meson inf.boundedI inf.cobounded1 semiring.add_mono)
                     also have "... = (?r \<sqinter> ?s\<^sup>T * rank * S') * S'\<^sup>+ \<squnion> (-?r \<sqinter> rank) * S'\<^sup>+"
                       using 5 vector_complement_closed vector_inf_comp by auto
                     also have "... = ?rank * S'\<^sup>+"
                       using conv_dist_comp mult_right_dist_sup by auto
                     finally show ?thesis
                       .
                   qed
                 qed
               qed
             qed
             show "?rr \<noteq> ?rs \<longrightarrow> union_sets_postcondition ?p4 x y p0 \<and> rank_property ?p4 rank"
             proof
               assume "?rr \<noteq> ?rs"
               hence "?rs \<sqinter> ?rr = bot"
                 using 6 by (meson bijective_regular dual_order.eq_iff point_in_vector_or_complement point_in_vector_or_complement_2 pseudo_complement)
               hence 26: "?rs \<le> S'\<^sup>+ * ?rr"
                 using 10 le_iff_inf pseudo_complement by auto
               show "union_sets_postcondition ?p4 x y p0 \<and> rank_property ?p4 rank"
               proof
                 show "union_sets_postcondition ?p4 x y p0"
                   using 1 2 3 by (simp add: union_sets_1_swap)
                 show "rank_property ?p4 rank"
                 proof (unfold rank_property_def, intro conjI)
                   show "univalent rank" "total rank"
                     using 1 rank_property_def by auto
                   have "?r \<le> -?s"
                     using 5 8 by (meson order.antisym bijective_regular point_in_vector_or_complement point_in_vector_or_complement_2)
                   hence "?s \<sqinter> ?r\<^sup>T \<sqinter> 1 = bot"
                     by (metis (full_types) bot_least inf.left_commute inf.sup_monoid.add_commute one_inf_conv pseudo_complement)
                   hence "?p4 \<sqinter> 1 \<le> ?p2"
                     by (smt half_shunting inf.cobounded2 pseudo_complement regular_one_closed semiring.add_mono sup_commute)
                   hence "roots ?p4 \<le> roots ?p2"
                     by (simp add: mult_left_isotone)
                   thus "card_less_eq (roots ?p4) (-(S'\<^sup>+ * rank\<^sup>T * top))"
                     using 4 by (meson rank_property_def card_less_eq_def order_trans)
                   have "(?p4 - 1) * rank = (?s \<sqinter> ?r\<^sup>T \<sqinter> -1) * rank \<squnion> (-?s \<sqinter> ?p2 \<sqinter> -1) * rank"
                     using comp_inf.semiring.distrib_right mult_right_dist_sup by auto
                   also have "... \<le> (?s \<sqinter> ?r\<^sup>T \<sqinter> -1) * rank \<squnion> (?p2 - 1) * rank"
                     using comp_inf.mult_semi_associative mult_left_isotone sup_right_isotone by auto
                   also have "... \<le> (?s \<sqinter> ?r\<^sup>T \<sqinter> -1) * rank \<squnion> rank * S'\<^sup>+"
                     using 4 sup_right_isotone rank_property_def by blast
                   also have "... \<le> (?s \<sqinter> ?r\<^sup>T) * rank \<squnion> rank * S'\<^sup>+"
                     using inf_le1 mult_left_isotone sup_left_isotone by blast
                   also have "... = ?s * ?r\<^sup>T * rank \<squnion> rank * S'\<^sup>+"
                     using 5 by (simp add: vector_covector)
                   also have "... = rank * S'\<^sup>+"
                   proof -
                     have "rank\<^sup>T * ?s \<le> S'\<^sup>+ * rank\<^sup>T * ?r"
                       using 26 comp_associative by auto
                     hence "?s \<le> rank * S'\<^sup>+ * rank\<^sup>T * ?r"
                       using 4 shunt_mapping comp_associative rank_property_def by auto
                     hence "?s * ?r\<^sup>T \<le> rank * S'\<^sup>+ * rank\<^sup>T"
                       using 5 shunt_bijective by blast
                     hence "?s * ?r\<^sup>T * rank \<le> rank * S'\<^sup>+"
                       using 4 shunt_bijective rank_property_def mapping_conv_bijective by auto
                     thus ?thesis
                       using sup_absorb2 by blast
                   qed
                   finally show "(?p4 - 1) * rank \<le> rank * S'\<^sup>+"
                     .
                 qed
               qed
             qed
           qed
         qed
       qed
     qed
     show "?r = ?s \<longrightarrow> union_sets_postcondition ?p5 x y p0 \<and> rank_property ?p5 rank"
     proof
       assume 27: "?r = ?s"
       show "union_sets_postcondition ?p5 x y p0 \<and> rank_property ?p5 rank"
       proof
         show "union_sets_postcondition ?p5 x y p0"
           using 1 2 3 27 by (simp add: union_sets_1_skip)
         show "rank_property ?p5 rank"
           using 4 27 by simp
       qed
     qed
   qed
 qed
 
 end
 
 end
 
diff --git a/thys/Relational_Disjoint_Set_Forests/ROOT b/thys/Relational_Disjoint_Set_Forests/ROOT
--- a/thys/Relational_Disjoint_Set_Forests/ROOT
+++ b/thys/Relational_Disjoint_Set_Forests/ROOT
@@ -1,17 +1,18 @@
 chapter AFP
 
-session Relational_Disjoint_Set_Forests = Stone_Kleene_Relation_Algebras +
+session Relational_Disjoint_Set_Forests = Aggregation_Algebras +
 
   options [timeout = 600]
 
   sessions
     "HOL-Hoare"
 
   theories
     Disjoint_Set_Forests
     More_Disjoint_Set_Forests
+    Matrix_Peano_Algebras
 
   document_files
     "root.tex"
     "root.bib"
 
diff --git a/thys/Relational_Disjoint_Set_Forests/document/root.bib b/thys/Relational_Disjoint_Set_Forests/document/root.bib
--- a/thys/Relational_Disjoint_Set_Forests/document/root.bib
+++ b/thys/Relational_Disjoint_Set_Forests/document/root.bib
@@ -1,199 +1,209 @@
 @STRING{afp		= {Archive of Formal Proofs}}
+@STRING{arxiv		= {arXiv}}
 @STRING{fac		= {Formal Aspects of Computing}}
 @STRING{is		= {Information Sciences}}
 @STRING{jlamp		= {Journal of Logical and Algebraic Methods in Programming}}
 @STRING{lncs		= {Lecture Notes in Computer Science}}
 @STRING{mitp		= {MIT Press}}
 @STRING{sv		= {Springer}}
 
 @Book{BackWright1998,
 	author		= {Back, R.-J. and von Wright, J.},
 	title		= {Refinement Calculus},
 	publisher	= sv,
 	address		= {New York},
 	year		= 1998,
 	note		= {}
 }
 
 @Article{BackhouseCarre1975,
 	author		= {Backhouse, R. C. and Carr{\'e}, B. A.},
 	title		= {Regular Algebra Applied to Path-finding Problems},
 	journal		= {Journal of the Institute of Mathematics and its Applications},
 	volume		= 15,
 	number		= 2,
 	pages		= {161--186},
 	year		= 1975,
 	note		= {}
 }
 
 @Article{Berghammer1999,
 	author		= {Berghammer, R.},
 	title		= {Combining relational calculus and the {Dijkstra--Gries} method for deriving relational programs},
 	journal		= is,
 	volume		= 119,
 	number		= {3--4},
 	pages		= {155--171},
 	year		= 1999,
 	note		= {}
 }
 
 @InProceedings{BerghammerKargerWolf1998,
 	author		= {Berghammer, R. and von Karger, B. and Wolf, A.},
 	title		= {Relation-Algebraic Derivation of Spanning Tree Algorithms},
 	editor		= {Jeuring, J.},
 	booktitle	= {Mathematics of Program Construction (MPC 1998)},
 	publisher	= sv,
 	series		= lncs,
 	volume		= 1422,
 	pages		= {23--43},
 	year		= 1998,
 	note		= {}
 }
 
 @InProceedings{BerghammerStruth2010,
 	author		= {Berghammer, R. and Struth, G.},
 	title		= {On Automated Program Construction and Verification},
 	editor		= {Bolduc, C. and Desharnais, J. and Ktari, B.},
 	booktitle	= {Mathematics of Program Construction (MPC 2010)},
 	publisher	= sv,
 	series		= lncs,
 	volume		= 6120,
 	pages		= {22--41},
 	year		= 2010,
 	note		= {}
 }
 
 @Book{CormenLeisersonRivest1990,
 	author		= {Cormen, T. H. and Leiserson, C. E. and Rivest, R. L.},
 	title		= {Introduction to Algorithms},
 	publisher	= mitp,
 	year		= 1990,
 	note		= {}
 }
 
 @Article{FosterGreenwaldMoorePierceSchmitt2007,
 	author		= {Foster, J. N. and Greenwald, M. B. and Moore, J. T. and Pierce, B. C. and Schmitt, A.},
 	title		= {Combinators for Bidirectional Tree Transformations: A Linguistic Approach to the View-Update Problem},
 	journal		= toplas,
 	volume		= 29,
 	number		= {3:17},
 	pages		= {1--65},
 	year		= 2007,
 	note		= {}
 }
 
 @Article{GallerFisher1964,
 	author		= {Galler, B. A. and Fisher, M. J.},
 	title		= {An Improved Equivalence Algorithm},
 	journal		= cacm,
 	volume		= 7,
 	number		= 5,
 	pages		= {301--303},
 	year		= 1964,
 	note		= {}
 }
 
 @Book{GondranMinoux2008,
 	author		= {Gondran, M. and Minoux, M.},
 	title		= {Graphs, Dioids and Semirings},
 	publisher	= sv,
 	year		= 2008,
 	note		= {}
 }
 
 @Article{Guttmann2018c,
 	author		= {Guttmann, W.},
 	title		= {Verifying Minimum Spanning Tree Algorithms with {Stone} Relation Algebras},
 	journal		= jlamp,
 	volume		= 101,
 	pages		= {132--150},
 	year		= 2018,
 	note		= {}
 }
 
 @InProceedings{Guttmann2020b,
 	author		= {Guttmann, W.},
 	title		= {Verifying the Correctness of Disjoint-Set Forests with {Kleene} Relation Algebras},
 	editor		= {Fahrenberg, U. and Jipsen, P. and Winter, M.},
 	booktitle	= {Relational and Algebraic Methods in Computer Science (RAMiCS 2020)},
 	publisher	= sv,
 	series		= lncs,
 	volume		= 12062,
 	pages		= {134--151},
 	year		= 2020,
 	note		= {}
 }
 
+@Article{Guttmann2023,
+	author		= {Guttmann, W.},
+	title		= {Relation-Algebraic Verification of Disjoint-Set Forests},
+	journal		= arxiv,
+	volume		= {2301.10311},
+	year		= 2023,
+	note		= {\url{https://arxiv.org/abs/2301.10311}}
+}
+
 @Article{HoefnerMoeller2012,
 	author		= {H{\"o}fner, P. and M{\"o}ller, B.},
 	title		= {Dijkstra, {Floyd} and {Warshall} meet {Kleene}},
 	journal		= fac,
 	volume		= 24,
 	number		= 4,
 	pages		= {459--476},
 	year		= 2012,
 	note		= {}
 }
 
 @Article{Kozen1994,
 	author		= {Kozen, D.},
 	title		= {A completeness theorem for {Kleene} algebras and the algebra of regular events},
 	journal		= {Information and Computation},
 	volume		= 110,
 	number		= 2,
 	pages		= {366--390},
 	year		= 1994,
 	note		= {}
 }
 
 @Article{LammichMeis2012,
 	author		= {Lammich, P. and Meis, R.},
 	title		= {A Separation Logic Framework for {I}mperative {HOL}},
 	journal		= afp,
 	year		= 2012,
 	note		= {}
 }
 
 @InProceedings{Moeller1993,
 	author		= {M{\"o}ller, B.},
 	title		= {Derivation of Graph and Pointer Algorithms},
 	editor		= {M{\"o}ller, B. and Partsch, H. A. and Schuman, S. A.},
 	booktitle	= {Formal Program Development},
 	publisher	= sv,
 	series		= lncs,
 	volume		= 755,
 	pages		= {123--160},
 	year		= 1993,
 	note		= {}
 }
 
 @Article{Tarjan1975,
 	author		= {Tarjan, R. E.},
 	title		= {Efficiency of a Good But Not Linear Set Union Algorithm},
 	journal		= jacm,
 	volume		= 22,
 	number		= 2,
 	pages		= {215--225},
 	year		= 1975,
 	note		= {}
 }
 
 @Article{Tarski1941,
 	author		= {Tarski, A.},
 	title		= {On the calculus of relations},
 	journal		= {The Journal of Symbolic Logic},
 	volume		= 6,
 	number		= 3,
 	pages		= {73--89},
 	year		= 1941,
 	note		= {}
 }
 
 @Article{Zhan2018,
 	author		= {Zhan, B.},
 	title		= {Verifying Imperative Programs using {Auto2}},
 	journal		= afp,
 	year		= 2018,
 	note		= {}
 }
 
diff --git a/thys/Relational_Disjoint_Set_Forests/document/root.tex b/thys/Relational_Disjoint_Set_Forests/document/root.tex
--- a/thys/Relational_Disjoint_Set_Forests/document/root.tex
+++ b/thys/Relational_Disjoint_Set_Forests/document/root.tex
@@ -1,64 +1,65 @@
 \documentclass[11pt,a4paper]{article}
 \usepackage[T1]{fontenc}
 \usepackage{isabelle,isabellesym}
 \usepackage{amssymb,ragged2e}
 \usepackage{pdfsetup}
 
 \isabellestyle{it}
 \renewenvironment{isamarkuptext}{\par\isastyletext\begin{isapar}\justifying\color{blue}}{\end{isapar}}
 \renewcommand\labelitemi{$*$}
-%\urlstyle{rm}
+\urlstyle{rm}
 
 \begin{document}
 
 \title{Relational Disjoint-Set Forests}
 \author{Walter Guttmann}
 \maketitle
 
 \begin{abstract}
   We give a simple relation-algebraic semantics of read and write operations on associative arrays.
   The array operations seamlessly integrate with assignments in the Hoare-logic library.
   Using relation algebras and Kleene algebras we verify the correctness of an array-based implementation of disjoint-set forests using the union-by-rank strategy and find operations with path compression, path splitting and path halving.
 \end{abstract}
 
 \tableofcontents
 
 \section{Overview}
 
 Relation algebras and Kleene algebras have previously been used to reason about graphs and graph algorithms \cite{BackhouseCarre1975,Berghammer1999,BerghammerStruth2010,BerghammerKargerWolf1998,GondranMinoux2008,HoefnerMoeller2012,Moeller1993}.
 The operations of these algebras manipulate entire graphs, which is useful for specification but not directly intended for implementation.
 Low-level array access is a key ingredient for efficient algorithms \cite{CormenLeisersonRivest1990}.
 We give a relation-algebraic semantics for such read/write access to associative arrays.
 This allows us to extend relation-algebraic verification methods to a lower level of more efficient implementations.
 
 In this theory we focus on arrays with the same index and value sets, which can be modelled as homogeneous relations and therefore as elements of relation algebras and Kleene algebras \cite{Kozen1994,Tarski1941}.
 We implement and verify the correctness of disjoint-set forests with path compression strategies and union-by-rank \cite{CormenLeisersonRivest1990,GallerFisher1964,Tarjan1975}.
 
 In order to prepare this theory for future applications with weighted graphs, the verification uses Stone relation algebras, which have weaker axioms than relation algebras \cite{Guttmann2018c}.
 
 Section 2 contains the simple relation-algebraic semantics of associative array read and write and basic properties of these access operations.
 In Section 3 we give a Kleene-relation-algebraic semantics of disjoint-set forests.
 The make-set operation, find-set with path compression and the naive union-sets operation are implemented and verified in Section 4.
 Section 5 presents further results on disjoint-set forests and relational array access.
 The initialisation of disjoint-set forests, path halving and path splitting are implemented and verified in Section 6.
 In Section 7 we study relational Peano structures and implement and verify union-by-rank.
+Section 8 instantiates the Peano axioms by Boolean matrices.
 
-This Isabelle/HOL theory formally verifies results in \cite{Guttmann2020b} and in an extended version of that paper.
+This Isabelle/HOL theory formally verifies results in \cite{Guttmann2020b} and an extended version of that paper \cite{Guttmann2023}.
 Theorem numbers from the extended version of the paper are mentioned in the theories for reference.
 See the paper for further details and related work.
 
 Several Isabelle/HOL theories are related to disjoint sets.
 The theory \texttt{HOL/Library/Disjoint\_Sets.thy} contains results about partitions and sets of disjoint sets and does not consider their implementation.
 An implementation of disjoint-set forests with path compression and a size-based heuristic in the Imperative/HOL framework is verified in Archive of Formal Proofs entry \cite{LammichMeis2012}.
 Improved automation of this proof is considered in Archive of Formal Proofs entry \cite{Zhan2018}.
 These approaches are based on logical specifications whereas the present theory uses relation algebras and Kleene algebras.
 
 \begin{flushleft}
 \input{session}
 \end{flushleft}
 
 \bibliographystyle{abbrv}
 \bibliography{root}
 
 \end{document}
 
diff --git a/thys/Relational_Minimum_Spanning_Trees/Boruvka.thy b/thys/Relational_Minimum_Spanning_Trees/Boruvka.thy
--- a/thys/Relational_Minimum_Spanning_Trees/Boruvka.thy
+++ b/thys/Relational_Minimum_Spanning_Trees/Boruvka.thy
@@ -1,3819 +1,3655 @@
 (* Title:      Borůvka's Minimum Spanning Tree Algorithm
    Author:     Nicolas Robinson-O'Brien
    Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
 *)
 
 section \<open>Bor\r{u}vka's Minimum Spanning Tree Algorithm\<close>
 
 text \<open>
 In this theory we prove partial correctness of Bor\r{u}vka's minimum spanning tree algorithm.
 \<close>
 
 theory Boruvka
 
 imports
+  Aggregation_Algebras.M_Choose_Component
   Relational_Disjoint_Set_Forests.Disjoint_Set_Forests
   Kruskal
 
 begin
 
 subsection \<open>General results\<close>
 
 text \<open>
 The proof is carried out in $m$-$k$-Stone-Kleene relation algebras.
 In this section we give results that hold more generally.
 \<close>
 
 context stone_kleene_relation_algebra
 begin
 
 lemma He_eq_He_THe_star:
   assumes "arc e"
     and "equivalence H"
   shows "H * e = H * e * (top * H * e)\<^sup>\<star>"
 proof -
   let ?x = "H * e"
   have 1: "H * e \<le> H * e * (top * H * e)\<^sup>\<star>"
     using comp_isotone star.circ_reflexive by fastforce
   have "H * e * (top * H * e)\<^sup>\<star> = H * e * (top * e)\<^sup>\<star>"
     by (metis assms(2) preorder_idempotent surjective_var)
   also have "... \<le> H * e * (1 \<squnion> top * (e * top)\<^sup>\<star> * e)"
     by (metis eq_refl star.circ_mult_1)
   also have "... \<le> H * e * (1 \<squnion> top * top * e)"
     by (simp add: star.circ_left_top)
   also have "... = H * e \<squnion> H * e * top * e"
     by (simp add: mult.semigroup_axioms semiring.distrib_left semigroup.assoc)
   finally have 2: "H * e * (top * H * e)\<^sup>\<star> \<le> H * e"
     using assms arc_top_arc mult_assoc by auto
   thus ?thesis
     using 1 2 by simp
 qed
 
 lemma path_through_components:
   assumes "equivalence H"
     and "arc e"
   shows "(H * (d \<squnion> e))\<^sup>\<star> = (H * d)\<^sup>\<star> \<squnion> (H * d)\<^sup>\<star> * H * e * (H * d)\<^sup>\<star>"
 proof -
   have "H * e * (H * d)\<^sup>\<star> * H * e \<le> H * e * top * H * e"
     by (simp add: comp_isotone)
   also have "... = H * e * top * e"
     by (metis assms(1) preorder_idempotent surjective_var mult_assoc)
   also have "... = H * e"
     using assms(2) arc_top_arc mult_assoc by auto
   finally have 1: "H * e * (H * d)\<^sup>\<star> * H * e \<le> H * e"
     by simp
   have "(H * (d \<squnion> e))\<^sup>\<star> = (H * d \<squnion> H * e)\<^sup>\<star>"
     by (simp add: comp_left_dist_sup)
   also have "... = (H * d)\<^sup>\<star> \<squnion> (H * d)\<^sup>\<star> * H * e * (H * d)\<^sup>\<star>"
     using 1 star_separate_3 by (simp add: mult_assoc)
   finally show ?thesis
     by simp
 qed
 
 lemma simplify_f:
   assumes "regular p"
     and "regular e"
   shows "(f \<sqinter> - e\<^sup>T \<sqinter> - p) \<squnion> (f \<sqinter> - e\<^sup>T \<sqinter> p) \<squnion> (f \<sqinter> - e\<^sup>T \<sqinter> p)\<^sup>T \<squnion> (f \<sqinter> - e\<^sup>T \<sqinter> - p)\<^sup>T \<squnion> e\<^sup>T \<squnion> e = f \<squnion> f\<^sup>T \<squnion> e \<squnion> e\<^sup>T"
 proof -
   have "(f \<sqinter> - e\<^sup>T \<sqinter> - p) \<squnion> (f \<sqinter> - e\<^sup>T \<sqinter> p) \<squnion> (f \<sqinter> - e\<^sup>T \<sqinter> p)\<^sup>T \<squnion> (f \<sqinter> - e\<^sup>T \<sqinter> - p)\<^sup>T \<squnion> e\<^sup>T \<squnion> e
     = (f \<sqinter> - e\<^sup>T \<sqinter> - p) \<squnion> (f \<sqinter> - e\<^sup>T \<sqinter> p) \<squnion> (f\<^sup>T \<sqinter> - e \<sqinter> p\<^sup>T) \<squnion> (f\<^sup>T \<sqinter> - e \<sqinter> - p\<^sup>T) \<squnion> e\<^sup>T \<squnion> e"
     by (simp add: conv_complement conv_dist_inf)
   also have "... =
       ((f \<squnion> (f \<sqinter> - e\<^sup>T \<sqinter> p)) \<sqinter> (- e\<^sup>T \<squnion> (f \<sqinter> - e\<^sup>T \<sqinter> p)) \<sqinter> (- p \<squnion> (f \<sqinter> - e\<^sup>T \<sqinter> p)))
     \<squnion> ((f\<^sup>T \<squnion> (f\<^sup>T \<sqinter> - e \<sqinter> - p\<^sup>T)) \<sqinter> (- e \<squnion> (f\<^sup>T \<sqinter> - e \<sqinter> - p\<^sup>T)) \<sqinter> (p\<^sup>T \<squnion> (f\<^sup>T \<sqinter> - e \<sqinter> - p\<^sup>T)))
     \<squnion> e\<^sup>T \<squnion> e"
     by (metis sup_inf_distrib2 sup_assoc)
   also have "... =
       ((f \<squnion> f) \<sqinter> (f \<squnion> - e\<^sup>T) \<sqinter> (f \<squnion> p) \<sqinter> (- e\<^sup>T \<squnion> f) \<sqinter> (- e\<^sup>T \<squnion> - e\<^sup>T) \<sqinter> (- e\<^sup>T \<squnion> p) \<sqinter> (- p \<squnion> f) \<sqinter> (- p \<squnion> - e\<^sup>T) \<sqinter> (- p \<squnion> p))
     \<squnion> ((f\<^sup>T \<squnion> f\<^sup>T) \<sqinter> (f\<^sup>T \<squnion> - e) \<sqinter> (f\<^sup>T \<squnion> - p\<^sup>T) \<sqinter> (- e \<squnion> f\<^sup>T) \<sqinter> (- e \<squnion> - e) \<sqinter> (- e \<squnion> - p\<^sup>T) \<sqinter> (p\<^sup>T \<squnion> f\<^sup>T) \<sqinter> (p\<^sup>T \<squnion> - e) \<sqinter> (p\<^sup>T \<squnion> - p\<^sup>T))
     \<squnion> e\<^sup>T \<squnion> e"
     using sup_inf_distrib1 sup_assoc inf_assoc sup_inf_distrib1 by simp
   also have "... =
       ((f \<squnion> f) \<sqinter> (f \<squnion> - e\<^sup>T) \<sqinter> (f \<squnion> p) \<sqinter> (f \<squnion> - p) \<sqinter> (- e\<^sup>T \<squnion> f) \<sqinter> (- e\<^sup>T \<squnion> - e\<^sup>T) \<sqinter> (- e\<^sup>T \<squnion> p) \<sqinter> (- e\<^sup>T \<squnion> - p) \<sqinter> (- p \<squnion> p))
     \<squnion> ((f\<^sup>T \<squnion> f\<^sup>T) \<sqinter> (f\<^sup>T \<squnion> - e) \<sqinter> (f\<^sup>T \<squnion> - p\<^sup>T) \<sqinter> (- e \<squnion> f\<^sup>T) \<sqinter> (f\<^sup>T \<squnion> p\<^sup>T) \<sqinter> (- e \<squnion> - e) \<sqinter> (- e \<squnion> - p\<^sup>T) \<sqinter> (- e \<squnion> p\<^sup>T) \<sqinter> (p\<^sup>T \<squnion> - p\<^sup>T))
     \<squnion> e\<^sup>T \<squnion> e"
     by (smt abel_semigroup.commute inf.abel_semigroup_axioms inf.left_commute sup.abel_semigroup_axioms)
   also have "... = (f \<sqinter> - e\<^sup>T \<sqinter> (- p \<squnion> p)) \<squnion> (f\<^sup>T \<sqinter> - e \<sqinter> (p\<^sup>T \<squnion> - p\<^sup>T)) \<squnion> e\<^sup>T \<squnion> e"
     by (smt inf.sup_monoid.add_assoc inf.sup_monoid.add_commute inf_sup_absorb sup.idem)
   also have "... = (f \<sqinter> - e\<^sup>T) \<squnion> (f\<^sup>T \<sqinter> - e) \<squnion> e\<^sup>T \<squnion> e"
     by (metis assms(1) conv_complement inf_top_right stone)
   also have "... = (f \<squnion> e\<^sup>T) \<sqinter> (- e\<^sup>T \<squnion> e\<^sup>T) \<squnion> (f\<^sup>T \<squnion> e) \<sqinter> (- e \<squnion> e)"
     by (metis sup.left_commute sup_assoc sup_inf_distrib2)
   finally show ?thesis
     by (metis abel_semigroup.commute assms(2) conv_complement inf_top_right stone sup.abel_semigroup_axioms sup_assoc)
 qed
 
 lemma simplify_forest_components_f:
   assumes "regular p"
     and "regular e"
     and "injective (f \<sqinter> - e\<^sup>T \<sqinter> - p \<squnion> (f \<sqinter> - e\<^sup>T \<sqinter> p)\<^sup>T \<squnion> e)"
     and "injective f"
   shows "forest_components ((f \<sqinter> - e\<^sup>T \<sqinter> - p) \<squnion> (f \<sqinter> -e\<^sup>T \<sqinter> p)\<^sup>T \<squnion> e) = (f \<squnion> f\<^sup>T \<squnion> e \<squnion> e\<^sup>T)\<^sup>\<star>"
 proof -
   have "forest_components ((f \<sqinter> - e\<^sup>T \<sqinter> - p) \<squnion> (f \<sqinter> -e\<^sup>T \<sqinter> p)\<^sup>T \<squnion> e) = wcc ((f \<sqinter> - e\<^sup>T \<sqinter> - p) \<squnion> (f \<sqinter> - e\<^sup>T \<sqinter> p)\<^sup>T \<squnion> e)"
     by (simp add: assms(3) forest_components_wcc)
   also have "... = ((f \<sqinter> - e\<^sup>T \<sqinter> - p) \<squnion> (f \<sqinter> - e\<^sup>T \<sqinter> p)\<^sup>T \<squnion> e \<squnion> (f \<sqinter> - e\<^sup>T \<sqinter> - p)\<^sup>T \<squnion> (f \<sqinter> - e\<^sup>T \<sqinter> p) \<squnion> e\<^sup>T)\<^sup>\<star>"
     using conv_dist_sup sup_assoc by auto
   also have "... = ((f \<sqinter> - e\<^sup>T \<sqinter> - p) \<squnion> (f \<sqinter> - e\<^sup>T \<sqinter> p) \<squnion> (f \<sqinter> - e\<^sup>T \<sqinter> p)\<^sup>T \<squnion> (f \<sqinter> - e\<^sup>T \<sqinter> - p)\<^sup>T \<squnion> e\<^sup>T \<squnion> e)\<^sup>\<star>"
     using sup_assoc sup_commute by auto
   also have "... = (f \<squnion> f\<^sup>T \<squnion> e \<squnion> e\<^sup>T)\<^sup>\<star>"
     using assms(1, 2, 3, 4) simplify_f by auto
   finally show ?thesis
     by simp
 qed
 
 lemma components_disj_increasing:
   assumes "regular p"
     and "regular e"
     and "injective (f \<sqinter> - e\<^sup>T \<sqinter> - p \<squnion> (f \<sqinter> - e\<^sup>T \<sqinter> p)\<^sup>T \<squnion> e)"
     and "injective f"
   shows "forest_components f \<le> forest_components (f \<sqinter> - e\<^sup>T \<sqinter> - p \<squnion> (f \<sqinter> - e\<^sup>T \<sqinter> p)\<^sup>T \<squnion> e)"
 proof -
   have 1: "forest_components ((f \<sqinter> - e\<^sup>T \<sqinter> - p) \<squnion> (f \<sqinter> -e\<^sup>T \<sqinter> p)\<^sup>T \<squnion> e) = (f \<squnion> f\<^sup>T \<squnion> e \<squnion> e\<^sup>T)\<^sup>\<star>"
     using simplify_forest_components_f assms(1, 2, 3, 4) by blast
   have "forest_components f = wcc f"
     by (simp add: assms(4) forest_components_wcc)
   also have "... \<le> (f \<squnion> f\<^sup>T \<squnion> e\<^sup>T \<squnion> e)\<^sup>\<star>"
     by (simp add: le_supI2 star_isotone sup_commute)
   finally show ?thesis
     using 1 sup.left_commute sup_commute by simp
 qed
 
 lemma fch_equivalence:
   assumes "forest h"
   shows "equivalence (forest_components h)"
   by (simp add: assms forest_components_equivalence)
 
 lemma forest_modulo_equivalence_path_split_1:
   assumes "arc a"
     and "equivalence H"
   shows "(H * d)\<^sup>\<star> * H * a * top = (H * (d \<sqinter> - a))\<^sup>\<star> * H * a * top"
 proof -
   let ?H = "H"
   let ?x = "?H * (d \<sqinter> -a)"
   let ?y = "?H * a"
   let ?a = "?H * a * top"
   let ?d = "?H * d"
   have 1: "?d\<^sup>\<star> * ?a \<le> ?x\<^sup>\<star> * ?a"
   proof -
     have "?x\<^sup>\<star> *?y * ?x\<^sup>\<star> * ?a \<le> ?x\<^sup>\<star> * ?a * ?a"
       by (smt mult_left_isotone star.circ_right_top top_right_mult_increasing mult_assoc)
     also have "... = ?x\<^sup>\<star> * ?a * a * top"
       by (metis ex231e mult_assoc)
     also have "... = ?x\<^sup>\<star> * ?a"
       by (simp add: assms(1) mult_assoc)
     finally have 11: "?x\<^sup>\<star> *?y * ?x\<^sup>\<star> * ?a \<le> ?x\<^sup>\<star> * ?a"
       by simp
     have "?d\<^sup>\<star> * ?a = (?H * (d \<sqinter> a) \<squnion> ?H * (d \<sqinter> -a))\<^sup>\<star> * ?a"
     proof -
       have 12: "regular a"
         using assms(1) arc_regular by simp
       have "?H * ((d \<sqinter> a) \<squnion> (d \<sqinter> - a)) = ?H * (d \<sqinter> top)"
         using 12 by (metis inf_top_right maddux_3_11_pp)
       thus ?thesis
         using mult_left_dist_sup by auto
     qed
     also have "... \<le> (?y \<squnion> ?x)\<^sup>\<star> * ?a"
       by (metis comp_inf.coreflexive_idempotent comp_isotone inf.cobounded1 inf.sup_monoid.add_commute semiring.add_mono star_isotone top.extremum)
     also have "... = (?x \<squnion> ?y)\<^sup>\<star> * ?a"
       by (simp add: sup_commute mult_assoc)
     also have "... = ?x\<^sup>\<star> * ?a \<squnion> (?x\<^sup>\<star> * ?y * (?x\<^sup>\<star> * ?y)\<^sup>\<star> * ?x\<^sup>\<star>) * ?a"
       by (smt mult_right_dist_sup star.circ_sup_9 star.circ_unfold_sum mult_assoc)
     also have "... \<le> ?x\<^sup>\<star> * ?a \<squnion> (?x\<^sup>\<star> * ?y * (top * ?y)\<^sup>\<star> * ?x\<^sup>\<star>) * ?a"
     proof -
       have "(?x\<^sup>\<star> * ?y)\<^sup>\<star> \<le> (top * ?y)\<^sup>\<star>"
         by (simp add: mult_left_isotone star_isotone)
       thus ?thesis
         by (metis comp_inf.coreflexive_idempotent comp_inf.transitive_star eq_refl mult_left_dist_sup top.extremum mult_assoc)
     qed
     also have "... = ?x\<^sup>\<star> * ?a \<squnion> (?x\<^sup>\<star> * ?y * ?x\<^sup>\<star>) * ?a"
       using assms(1, 2) He_eq_He_THe_star arc_regular mult_assoc by auto
     finally have 13: "(?H * d)\<^sup>\<star> * ?a \<le> ?x\<^sup>\<star> * ?a \<squnion> ?x\<^sup>\<star> * ?y * ?x\<^sup>\<star> * ?a"
       by (simp add: mult_assoc)
     have 14: "?x\<^sup>\<star> * ?y * ?x\<^sup>\<star> * ?a \<le> ?x\<^sup>\<star> * ?a"
       using 11 mult_assoc by auto
     thus ?thesis
       using 13 14 sup.absorb1 by auto
   qed
   have 2: "?d\<^sup>\<star> * ?a \<ge> ?x\<^sup>\<star> *?a"
     by (simp add: comp_isotone star_isotone)
   thus ?thesis
     using 1 2 order.antisym mult_assoc by simp
 qed
 
 lemma dTransHd_le_1:
   assumes "equivalence H"
     and "univalent (H * d)"
   shows "d\<^sup>T * H * d \<le> 1"
 proof -
   have "d\<^sup>T * H\<^sup>T * H * d \<le> 1"
     using assms(2) conv_dist_comp mult_assoc by auto
   thus ?thesis
     using assms(1) mult_assoc by (simp add: preorder_idempotent)
 qed
 
 lemma HcompaT_le_compHaT:
   assumes "equivalence H"
     and "injective (a * top)"
   shows "-H * a * top \<le> - (H * a * top)"
 proof -
   have "a * top * a\<^sup>T \<le> 1"
     by (metis assms(2) conv_dist_comp symmetric_top_closed vector_top_closed mult_assoc)
   hence "a * top * a\<^sup>T * H \<le> H"
     using assms(1) comp_isotone order_trans by blast
   hence "a * top * top * a\<^sup>T * H \<le> H"
     by (simp add: vector_mult_closed)
   hence "a * top * (H * a * top)\<^sup>T \<le> H"
     by (metis assms(1) conv_dist_comp symmetric_top_closed vector_top_closed mult_assoc)
   thus ?thesis
     using assms(2) comp_injective_below_complement mult_assoc by auto
 qed
 
 subsection \<open>Forests modulo an equivalence\<close>
 
 text \<open>
 In the graphical interpretation, the arcs of d are directed towards the root(s) of the \<open>forest_modulo_equivalence\<close>.
 \<close>
 
 definition "forest_modulo_equivalence x d \<equiv> equivalence x \<and> univalent (x * d) \<and> x \<sqinter> d * d\<^sup>T \<le> 1 \<and> (x * d)\<^sup>+ \<sqinter> x \<le> bot"
 
 definition "forest_modulo_equivalence_path a b H d \<equiv> arc a \<and> arc b \<and> a\<^sup>T * top \<le> (H * d)\<^sup>\<star> * H * b * top"
 
 lemma d_separates_forest_modulo_equivalence_1:
   assumes "forest_modulo_equivalence x d"
   shows "x * d \<le> -x"
 proof -
   have "x * d \<le> (x * d)\<^sup>+"
     using star.circ_mult_increasing by simp
   also have "... \<le> -x"
     using assms(1) forest_modulo_equivalence_def le_bot pseudo_complement by blast
   finally show ?thesis
     by simp
 qed
 
 lemma d_separates_forest_modulo_equivalence_2:
   shows "forest_modulo_equivalence x d \<Longrightarrow> d * x \<le> -x"
   using forest_modulo_equivalence_def schroeder_6_p d_separates_forest_modulo_equivalence_1 by metis
 
 lemma d_separates_forest_modulo_equivalence_3:
   assumes "forest_modulo_equivalence x d"
   shows "d \<le> -x"
 proof -
   have "1 \<le> x"
     using assms(1) forest_modulo_equivalence_def by auto
   then have "d \<le> x * d"
     using mult_left_isotone by fastforce
   also have "... \<le> (x * d)\<^sup>+"
     using star.circ_mult_increasing by simp
   also have "... \<le> -x"
     using assms(1) forest_modulo_equivalence_def le_bot pseudo_complement by blast
   finally show ?thesis
     by simp
 qed
 
 lemma d_separates_forest_modulo_equivalence_4:
   shows "forest_modulo_equivalence x d \<Longrightarrow> d\<^sup>T \<le> -x"
   using d_separates_forest_modulo_equivalence_3 forest_modulo_equivalence_def conv_isotone symmetric_complement_closed by metis
 
 lemma d_separates_forest_modulo_equivalence_5:
   shows "forest_modulo_equivalence x d \<Longrightarrow> d \<squnion> d\<^sup>T \<le> -x"
   using d_separates_forest_modulo_equivalence_3 d_separates_forest_modulo_equivalence_4 sup_least by blast
 
 lemma d_separates_forest_modulo_equivalence_6:
   shows "forest_modulo_equivalence x d \<Longrightarrow> d * x \<squnion> x * d \<le> -x"
   using d_separates_forest_modulo_equivalence_1 d_separates_forest_modulo_equivalence_2 sup_least by blast
 
 lemma d_separates_forest_modulo_equivalence_7:
   shows "forest_modulo_equivalence x d \<Longrightarrow> x * (d \<squnion> d\<^sup>T) * x \<le> -x"
   using d_separates_forest_modulo_equivalence_5 forest_modulo_equivalence_def inf.sup_monoid.add_commute preorder_idempotent pseudo_complement triple_schroeder_p by metis
 
 lemma d_separates_forest_modulo_equivalence_8:
   shows "forest_modulo_equivalence x d \<Longrightarrow> (d * x)\<^sup>T \<le> -x"
   using d_separates_forest_modulo_equivalence_2 forest_modulo_equivalence_def conv_isotone symmetric_complement_closed by metis
 
 lemma d_separates_forest_modulo_equivalence_9:
   shows "forest_modulo_equivalence x d \<Longrightarrow> (x * d)\<^sup>T \<le> -x"
   by (metis d_separates_forest_modulo_equivalence_1 forest_modulo_equivalence_def conv_isotone symmetric_complement_closed)
 
 lemma d_separates_forest_modulo_equivalence_10:
   shows "forest_modulo_equivalence x d \<Longrightarrow> (d * x)\<^sup>+ \<le> -x"
   using forest_modulo_equivalence_def le_bot pseudo_complement schroeder_5_p star_slide mult_assoc by metis
 
 lemma d_separates_forest_modulo_equivalence_11:
   shows "forest_modulo_equivalence x d \<Longrightarrow> (x * d)\<^sup>+ \<le> -x"
   using forest_modulo_equivalence_def le_bot pseudo_complement by blast
 
 lemma d_separates_forest_modulo_equivalence_12:
   shows "forest_modulo_equivalence x d \<Longrightarrow> (d * x)\<^sup>T\<^sup>+ \<le> -x"
   using d_separates_forest_modulo_equivalence_10 forest_modulo_equivalence_def conv_isotone conv_plus_commute symmetric_complement_closed by metis
 
 lemma d_separates_x_in_forest_13:
   shows "forest_modulo_equivalence x d \<Longrightarrow> (x * d)\<^sup>T\<^sup>+ \<le> -x"
   using d_separates_forest_modulo_equivalence_11 forest_modulo_equivalence_def conv_isotone conv_plus_commute symmetric_complement_closed by metis
 
 lemma irreflexive_d_in_forest_modulo_equivalence:
   shows "forest_modulo_equivalence x d \<Longrightarrow> irreflexive d"
   by (metis d_separates_forest_modulo_equivalence_3 forest_modulo_equivalence_def inf.cobounded2 inf.left_commute inf.orderE pseudo_complement)
 
 lemma univalent_d_in_forest_modulo_equivalence:
   assumes "forest_modulo_equivalence x d"
   shows "univalent d"
 proof -
   have "d\<^sup>T * d \<le> d\<^sup>T * x\<^sup>T * x * d"
     using assms(1) forest_modulo_equivalence_def comp_isotone comp_right_one mult_sub_right_one by metis
   also have "... \<le> 1"
     using assms(1) forest_modulo_equivalence_def comp_associative conv_dist_comp by auto
   finally show ?thesis
     by simp
 qed
 
 lemma acyclic_d_in_forest_modulo_equivalence:
   assumes "forest_modulo_equivalence x d"
   shows "acyclic d"
 proof -
   have "d\<^sup>\<star> \<le> (x * d)\<^sup>\<star>"
     using assms(1) forest_modulo_equivalence_def mult_left_isotone star.circ_circ_mult star.circ_circ_mult_1 star.circ_extra_circ star.left_plus_circ star_involutive star_isotone star_one star_slide mult_assoc by metis
   then have "d * d\<^sup>\<star> \<le> d * (x * d)\<^sup>\<star>"
     using mult_right_isotone by blast
   also have "... \<le> x * d * (x * d)\<^sup>\<star>"
     using assms(1) forest_modulo_equivalence_def eq_refl inf.order_trans mult_isotone star.circ_circ_mult_1 star_involutive star_one star_outer_increasing mult_assoc by metis
   also have "... \<le> -x"
     using assms d_separates_forest_modulo_equivalence_11 by blast
   also have "... \<le> -1"
     using assms(1) forest_modulo_equivalence_def p_antitone by blast
   finally show ?thesis
     by simp
 qed
 
 lemma acyclic_dt_d_in_forest_modulo_equivalence:
   shows "forest_modulo_equivalence x d \<Longrightarrow> acyclic (d\<^sup>T)"
   using acyclic_d_in_forest_modulo_equivalence conv_plus_commute irreflexive_conv_closed by fastforce
 
 lemma dt_forest_modulo_equivalence_forest:
   shows "forest_modulo_equivalence x d \<Longrightarrow> forest (d\<^sup>T)"
   using acyclic_dt_d_in_forest_modulo_equivalence univalent_d_in_forest_modulo_equivalence by simp
 
 lemma var_forest_modulo_equivalence_axiom:
   shows "forest_modulo_equivalence x d \<Longrightarrow> d\<^sup>T * x * d \<le> 1"
   using forest_modulo_equivalence_def comp_associative conv_dist_comp preorder_idempotent by metis
 
 lemma forest_modulo_equivalence_wcc:
   assumes "forest_modulo_equivalence x d"
   shows "(x * d)\<^sup>\<star> * (x * d)\<^sup>T\<^sup>\<star> = ((x * d) \<squnion> (x * d)\<^sup>T)\<^sup>\<star>"
   using assms(1) forest_modulo_equivalence_def fc_wcc by force
 
 lemma forest_modulo_equivalence_direction_1:
   assumes "forest_modulo_equivalence x d"
   shows "(x * d)\<^sup>\<star> \<sqinter> (x * d)\<^sup>T = bot"
   using assms(1) d_separates_forest_modulo_equivalence_11 forest_modulo_equivalence_def acyclic_star_below_complement_1 order_lesseq_imp p_antitone_iff by meson
 
 lemma forest_modulo_equivalence_direction_2:
   assumes "forest_modulo_equivalence x d"
   shows "(x * d)\<^sup>T\<^sup>\<star> \<sqinter> (x * d) \<le> bot"
   using assms(1) forest_modulo_equivalence_direction_1 comp_inf.idempotent_bot_closed conv_inf_bot_iff conv_star_commute inf.sup_left_divisibility by metis
 
 lemma forest_modulo_equivalence_separate:
   assumes "forest_modulo_equivalence x d"
   shows "(x * d)\<^sup>\<star> * (x * d)\<^sup>T\<^sup>\<star> \<sqinter> (x * d)\<^sup>T * (x * d) \<le> 1"
 proof -
   have "(x * d)\<^sup>\<star> \<sqinter> (x * d)\<^sup>T * (x * d) = (1 \<squnion> (x * d)\<^sup>+) \<sqinter> (x * d)\<^sup>T * (x * d)"
     using star_left_unfold_equal by simp
   also have "... = (1 \<sqinter> (x * d)\<^sup>T * (x * d)) \<squnion> ((x * d)\<^sup>+ \<sqinter> (x * d)\<^sup>T * (x * d))"
     using comp_inf.semiring.distrib_right by simp
   also have "... \<le> 1 \<squnion> ((x * d)\<^sup>+ \<sqinter> (x * d)\<^sup>T * (x * d))"
     using inf.cobounded1 semiring.add_right_mono by blast
   also have "... = 1 \<squnion> ((x * d)\<^sup>\<star> \<sqinter> (x * d)\<^sup>T) * (x * d)"
     using assms(1) forest_modulo_equivalence_def forest_modulo_equivalence_direction_1 comp_inf.semiring.mult_zero_right inf.sup_left_divisibility le_infI2 semiring.mult_not_zero sup.orderE by metis
   also have "... \<le> 1 \<squnion> bot"
     using assms(1) forest_modulo_equivalence_direction_1 by simp
   finally have 2: "(x * d)\<^sup>\<star> \<sqinter> (x * d)\<^sup>T * (x * d) \<le> 1"
     by simp
   then have 3: "(x * d)\<^sup>T\<^sup>\<star> \<sqinter> (x * d)\<^sup>T * (x * d) \<le> 1"
     using assms(1) forest_modulo_equivalence_def conv_dist_comp conv_dist_inf conv_involutive conv_star_commute coreflexive_symmetric by metis
   have "((x * d)\<^sup>\<star> \<squnion> (x * d)\<^sup>T\<^sup>\<star>) \<sqinter> ((x * d)\<^sup>T * (x * d)) \<le> 1"
     using 2 3 inf_sup_distrib2 by simp
   thus ?thesis
     using assms(1) le_infI2 forest_modulo_equivalence_def by blast
 qed
 
 lemma forest_modulo_equivalence_path_trans_closure:
   assumes "forest_modulo_equivalence x d"
   shows "(x * d\<^sup>T)\<^sup>+ * x * d * x * d\<^sup>T \<le> (x * d\<^sup>T)\<^sup>+"
 proof -
   have "(x * d\<^sup>T)\<^sup>+ * x * d * x * d\<^sup>T = (x * d\<^sup>T)\<^sup>\<star> * x * d\<^sup>T * x * d * x * d\<^sup>T"
     using comp_associative star.circ_plus_same by metis
   also have "... \<le> (x * d\<^sup>T)\<^sup>\<star> * x * 1 * x * d\<^sup>T"
     using assms(1) forest_modulo_equivalence_def var_forest_modulo_equivalence_axiom comp_associative mult_left_isotone mult_right_isotone by metis
   also have "... \<le> (x * d\<^sup>T)\<^sup>\<star> * x * d\<^sup>T"
     using assms(1) forest_modulo_equivalence_def by (simp add: preorder_idempotent mult_assoc)
   finally show ?thesis
     using star.circ_plus_same mult_assoc by simp
 qed
 
 text \<open>
 The \<open>forest_modulo_equivalence\<close> structure is preserved if d is decreased.
 \<close>
 
 lemma forest_modulo_equivalence_decrease_d:
   assumes "forest_modulo_equivalence x d"
   shows "forest_modulo_equivalence x (d \<sqinter> c)"
 proof (unfold forest_modulo_equivalence_def, intro conjI)
   show "reflexive x"
     using assms(1) forest_modulo_equivalence_def by blast
 next
   show "transitive x"
     using assms(1) forest_modulo_equivalence_def by blast
 next
   show "symmetric x"
     using assms(1) forest_modulo_equivalence_def by blast
 next
   show "univalent (x * (d \<sqinter> c))"
   proof -
     have "(x * (d \<sqinter> c))\<^sup>T * x * (d \<sqinter> c) \<le> (x * d)\<^sup>T * x * d"
       using conv_order mult_isotone by auto
     also have "... \<le> 1"
       using assms(1) forest_modulo_equivalence_def mult_assoc by auto
     finally show ?thesis
       using mult_assoc by auto
   qed
 next
   show "coreflexive (x \<sqinter> ((d \<sqinter> c) * (d \<sqinter> c)\<^sup>T))"
   proof -
     have "x \<sqinter> (d \<sqinter> c) * (d \<sqinter> c)\<^sup>T \<le> x \<sqinter> d * d\<^sup>T"
       using conv_dist_inf inf.sup_right_isotone mult_isotone by auto
     thus ?thesis
       using assms(1) forest_modulo_equivalence_def order_lesseq_imp by blast
   qed
 next
   show "(x * (d \<sqinter> c))\<^sup>+ \<sqinter> x \<le> bot"
   proof -
     have "(x * (d \<sqinter> c))\<^sup>+ \<le> (x * d)\<^sup>+"
       using comp_isotone star_isotone by simp
     thus ?thesis
       using assms d_separates_forest_modulo_equivalence_11 dual_order.eq_iff dual_order.trans pseudo_complement by blast
   qed
 qed
 
 lemma expand_forest_modulo_equivalence:
   assumes "forest_modulo_equivalence H d"
   shows "(d\<^sup>T * H)\<^sup>\<star> * (H * d)\<^sup>\<star> = (d\<^sup>T * H)\<^sup>\<star> \<squnion> (H * d)\<^sup>\<star>"
 proof -
   have "(H * d)\<^sup>T * H * d \<le> 1"
     using assms forest_modulo_equivalence_def mult_assoc by auto
   hence "d\<^sup>T * H * H * d \<le> 1"
     using assms forest_modulo_equivalence_def conv_dist_comp by auto
   thus ?thesis
     by (simp add: cancel_separate_eq comp_associative)
 qed
 
 lemma forest_modulo_equivalence_path_bot:
   assumes "arc a"
     and "a \<le> d"
     and "forest_modulo_equivalence H d"
   shows "(d \<sqinter> - a)\<^sup>T * (H * a * top) \<le> bot"
 proof -
   have 1: "d\<^sup>T * H * d \<le> 1"
     using assms(3) forest_modulo_equivalence_def dTransHd_le_1 by blast
   hence "d * - 1 * d\<^sup>T \<le> - H"
     using triple_schroeder_p by force
   hence "d * - 1 * d\<^sup>T \<le> 1 \<squnion> - H"
     by (simp add: le_supI2)
   hence "d * d\<^sup>T \<squnion> d * - 1 * d\<^sup>T \<le> 1 \<squnion> - H"
     by (metis assms(3) forest_modulo_equivalence_def inf_commute regular_one_closed shunting_p le_supI)
   hence "d * 1 * d\<^sup>T \<squnion> d * - 1 * d\<^sup>T \<le> 1 \<squnion> - H"
     by simp
   hence "d * (1 \<squnion> - 1) * d\<^sup>T \<le> 1 \<squnion> - H"
     using comp_associative mult_right_dist_sup by (simp add: mult_left_dist_sup)
   hence "d * top * d\<^sup>T \<le> 1 \<squnion> - H"
     using regular_complement_top by auto
   hence "d * top * a\<^sup>T \<le> 1 \<squnion> - H"
     using assms(2) conv_isotone dual_order.trans mult_right_isotone by blast
   hence "d * (a * top)\<^sup>T \<le> 1 \<squnion> - H"
     by (simp add: comp_associative conv_dist_comp)
   hence "d \<le> (1 \<squnion> - H) * (a * top)"
     by (simp add: assms(1) shunt_bijective)
   hence "d \<le> a * top \<squnion> - H * a * top"
     by (simp add: comp_associative mult_right_dist_sup)
   also have "... \<le> a * top \<squnion> - (H * a * top)"
     using assms(1, 3) HcompaT_le_compHaT forest_modulo_equivalence_def sup_right_isotone by auto
   finally have "d \<le> a * top \<squnion> - (H * a * top)"
     by simp
   hence "d \<sqinter> --( H * a * top) \<le> a * top"
     using shunting_var_p by auto
   hence 2:"d \<sqinter> H * a * top \<le> a * top"
     using inf.sup_right_isotone order.trans pp_increasing by blast
   have 3:"d \<sqinter> H * a * top \<le> top * a"
   proof -
     have "d \<sqinter> H * a * top \<le> (H * a \<sqinter> d * top\<^sup>T) * (top \<sqinter> (H * a)\<^sup>T * d)"
       by (metis dedekind inf_commute)
     also have "... = d * top \<sqinter> H * a * a\<^sup>T * H\<^sup>T * d"
       by (simp add: conv_dist_comp inf_vector_comp mult_assoc)
     also have "... \<le> d * top \<sqinter> H * a * d\<^sup>T * H\<^sup>T * d"
       using assms(2) mult_right_isotone mult_left_isotone conv_isotone inf.sup_right_isotone by auto
     also have "... = d * top \<sqinter> H * a * d\<^sup>T * H * d"
       using assms(3) forest_modulo_equivalence_def by auto
     also have "... \<le> d * top \<sqinter> H * a * 1"
       using 1 by (metis inf.sup_right_isotone mult_right_isotone mult_assoc)
     also have "... \<le> H * a"
       by simp
     also have "... \<le> top * a"
       by (simp add: mult_left_isotone)
     finally have "d \<sqinter> H * a * top \<le> top * a"
       by simp
     thus ?thesis
       by simp
   qed
   have "d \<sqinter> H * a * top \<le> a * top \<sqinter> top * a"
     using 2 3 by simp
   also have "... = a * top * top * a"
     by (metis comp_associative comp_inf.star.circ_decompose_9 comp_inf.star_star_absorb comp_inf_covector vector_inf_comp vector_top_closed)
   also have "... = a * top * a"
     by (simp add: vector_mult_closed)
   finally have 4:"d \<sqinter> H * a * top \<le> a"
     by (simp add: assms(1) arc_top_arc)
   hence "d \<sqinter> - a \<le> -(H * a * top)"
     using assms(1) arc_regular p_shunting_swap by fastforce
   hence "(d \<sqinter> - a) * top \<le> -(H * a * top)"
     using mult.semigroup_axioms p_antitone_iff schroeder_4_p semigroup.assoc by fastforce
   thus ?thesis
     by (simp add: schroeder_3_p)
 qed
 
 lemma forest_modulo_equivalence_path_split_2:
   assumes "arc a"
     and "a \<le> d"
     and "forest_modulo_equivalence H d"
   shows "(H * (d \<sqinter> - a))\<^sup>\<star> * H * a * top = (H * ((d \<sqinter> - a) \<squnion> (d \<sqinter> - a)\<^sup>T))\<^sup>\<star> * H * a * top"
 proof -
   let ?lhs = "(H * (d \<sqinter> - a))\<^sup>\<star> * H * a * top"
   have 1: "d\<^sup>T * H * d \<le> 1"
     using assms(3) forest_modulo_equivalence_def dTransHd_le_1 by blast
   have 2: "H * a * top \<le> ?lhs"
     by (metis le_iff_sup star.circ_loop_fixpoint star.circ_transitive_equal star_involutive sup_commute mult_assoc)
   have "(d \<sqinter> - a)\<^sup>T * (H * (d \<sqinter> - a))\<^sup>\<star> * (H * a * top) = (d \<sqinter> - a)\<^sup>T * H * (d \<sqinter> - a) * (H * (d \<sqinter> - a))\<^sup>\<star> * (H * a * top)"
   proof -
     have "(d \<sqinter> - a)\<^sup>T * (H * (d \<sqinter> - a))\<^sup>\<star> * (H * a * top) = (d \<sqinter> - a)\<^sup>T * (1 \<squnion> H * (d \<sqinter> - a) * (H * (d \<sqinter> - a))\<^sup>\<star>) * (H * a * top)"
       by (simp add: star_left_unfold_equal)
     also have "... = (d \<sqinter> - a)\<^sup>T * H * a * top \<squnion> (d \<sqinter> - a)\<^sup>T * H * (d \<sqinter> - a) * (H * (d \<sqinter> - a))\<^sup>\<star> * (H * a * top)"
       by (smt mult_left_dist_sup star.circ_loop_fixpoint star.circ_mult_1 star_slide sup_commute mult_assoc)
     also have "... = bot \<squnion> (d \<sqinter> - a)\<^sup>T * H * (d \<sqinter> - a) * (H * (d \<sqinter> - a))\<^sup>\<star> * (H * a * top)"
       by (metis assms(1, 2, 3) forest_modulo_equivalence_path_bot mult_assoc le_bot)
     thus ?thesis
       by (simp add: calculation)
   qed
   also have "... \<le> d\<^sup>T * H * d * (H * (d \<sqinter> - a))\<^sup>\<star> * (H * a * top)"
     using conv_isotone inf.cobounded1 mult_isotone by auto
   also have "... \<le> 1 * (H * (d \<sqinter> - a))\<^sup>\<star> * (H * a * top)"
     using 1 by (metis le_iff_sup mult_right_dist_sup)
   finally have 3: "(d \<sqinter> - a)\<^sup>T * (H * (d \<sqinter> - a))\<^sup>\<star> * (H * a * top) \<le> ?lhs"
     using mult_assoc by auto
   hence 4: "H * (d \<sqinter> - a)\<^sup>T * (H * (d \<sqinter> - a))\<^sup>\<star> * (H * a * top) \<le> ?lhs"
   proof -
     have "H * (d \<sqinter> - a)\<^sup>T * (H * (d \<sqinter> - a))\<^sup>\<star> * (H * a * top) \<le> H * (H * (d \<sqinter> - a))\<^sup>\<star> * H * a * top"
       using 3 mult_right_isotone mult_assoc by auto
     also have "... = H * H * ((d \<sqinter> - a) * H)\<^sup>\<star> * H * a * top"
       by (metis assms(3) forest_modulo_equivalence_def star_slide mult_assoc preorder_idempotent)
     also have "... = H * ((d \<sqinter> - a) * H)\<^sup>\<star> * H * a * top"
       using assms(3) forest_modulo_equivalence_def preorder_idempotent by fastforce
     finally show ?thesis
       by (metis assms(3) forest_modulo_equivalence_def preorder_idempotent star_slide mult_assoc)
   qed
   have 5: "(H * (d \<sqinter> - a) \<squnion> H * (d \<sqinter> - a)\<^sup>T) * (H * (d \<sqinter> - a))\<^sup>\<star> * H * a * top \<le> ?lhs"
   proof -
     have 51: "H * (d \<sqinter> - a) * (H * (d \<sqinter> - a))\<^sup>\<star> * H * a * top \<le> (H * (d \<sqinter> - a))\<^sup>\<star> * H * a * top"
       using star.left_plus_below_circ mult_left_isotone by simp
     have 52: "(H * (d \<sqinter> - a) \<squnion> H * (d \<sqinter> - a)\<^sup>T) * (H * (d \<sqinter> - a))\<^sup>\<star> * H * a * top = H * (d \<sqinter> - a) * (H * (d \<sqinter> - a))\<^sup>\<star> * H * a * top \<squnion> H * (d \<sqinter> - a)\<^sup>T * (H * (d \<sqinter> - a))\<^sup>\<star> * H * a * top"
       using mult_right_dist_sup by auto
     hence "... \<le> (H * (d \<sqinter> - a))\<^sup>\<star> * H * a * top \<squnion> H * (d \<sqinter> - a)\<^sup>T * (H * (d \<sqinter> - a))\<^sup>\<star> * H * a * top"
       using star.left_plus_below_circ mult_left_isotone sup_left_isotone by auto
     thus ?thesis
       using 4 51 52 mult_assoc by auto
   qed
   hence "(H * (d \<sqinter> - a) \<squnion> H * (d \<sqinter> - a)\<^sup>T)\<^sup>\<star> * H * a * top \<le> ?lhs"
   proof -
     have "(H * (d \<sqinter> - a) \<squnion> H * (d \<sqinter> - a)\<^sup>T)\<^sup>\<star> * (H * (d \<sqinter> - a))\<^sup>\<star> * H * a * top \<le> ?lhs"
       using 5 star_left_induct_mult_iff mult_assoc by auto
     thus ?thesis
       using star.circ_decompose_11 star_decompose_1 by auto
   qed
   hence 6: "(H * ((d \<sqinter> - a) \<squnion> (d \<sqinter> - a)\<^sup>T))\<^sup>\<star> * H * a * top \<le> ?lhs"
     using mult_left_dist_sup by auto
   have 7: "(H * (d \<sqinter> - a))\<^sup>\<star> * H * a * top \<le> (H * ((d \<sqinter> - a) \<squnion> (d \<sqinter> - a)\<^sup>T))\<^sup>\<star> * H * a * top"
     by (simp add: mult_left_isotone semiring.distrib_left star_isotone)
   thus ?thesis
     using 6 7 by (simp add: mult_assoc)
 qed
 
 end
 
-context stone_relation_algebra
-begin
-
-text \<open>
-A \<open>vector_classes\<close> corresponds to one or more equivalence classes and a \<open>unique_vector_class\<close> corresponds to a single equivalence class.
-\<close>
-
-definition vector_classes        :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where "vector_classes x v \<equiv> regular x \<and> regular v \<and> equivalence x \<and> vector v \<and> x * v \<le> v \<and> v \<noteq> bot"
-definition unique_vector_class   :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where "unique_vector_class x v \<equiv> vector_classes x v \<and> v * v\<^sup>T \<le> x"
-
-end
-
 subsection \<open>An operation to select components\<close>
 
 text \<open>
-We introduce the operation \<open>choose_component\<close>.
-\begin{itemize}
-  \item Axiom \<open>component_in_v\<close> expresses that the result of \<open>choose_component\<close> is contained in the set of vertices, $v$, we are selecting from, ignoring the weights.
-  \item Axiom \<open>component_is_vector\<close> states that the result of \<open>choose_component\<close> is a vector.
-  \item Axiom \<open>component_is_regular\<close> states that the result of \<open>choose_component\<close> is regular.
-  \item Axiom \<open>component_is_connected\<close> states that any two vertices from the result of \<open>choose_component\<close> are connected in $e$.
-  \item Axiom \<open>component_single\<close> states that the result of \<open>choose_component\<close> is closed under being connected in $e$.
-  \item Finally, axiom \<open>component_not_bot_when_v_bot_bot\<close> expresses that the operation \<open>choose_component\<close> returns a non-empty component if the input satisfies the given criteria.
-\end{itemize}
-\<close>
-
-class choose_component =
-  fixes choose_component :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
-
-class choose_component_algebra = choose_component + stone_relation_algebra +
-  assumes component_is_vector:              "vector (choose_component e v)"
-  assumes component_is_regular:             "regular (choose_component e v)"
-  assumes component_in_v:                   "choose_component e v \<le> --v"
-  assumes component_is_connected:           "choose_component e v * (choose_component e v)\<^sup>T \<le> e"
-  assumes component_single:                 "e * choose_component e v \<le> choose_component e v"
-  assumes component_not_bot_when_v_bot_bot: "vector_classes e v \<longrightarrow> choose_component e v \<noteq> bot"
-
-text \<open>
-Every \<open>m_kleene_algebra\<close> is an instance of \<open>choose_component_algebra\<close> when the \<open>choose_component\<close> operation is defined as follows:
+This section has been moved to theories \<open>Stone_Relation_Algebras.Choose_Component\<close> and \<open>Aggregation_Algebras.M_Choose_Component\<close>.
 \<close>
 
-context m_kleene_algebra
-begin
-
-definition "m_choose_component e v \<equiv>
-  if vector_classes e v then
-    e * minarc(v) * top
-  else
-    bot"
-
-sublocale m_choose_component_algebra: choose_component_algebra where choose_component = m_choose_component
-proof
-  fix e v
-  show "m_choose_component e v \<le> -- v"
-  proof (cases "vector_classes e v")
-    case True
-    hence "m_choose_component e v = e * minarc(v) * top"
-      by (simp add: m_choose_component_def)
-    also have "... \<le> e * --v * top"
-      by (simp add: comp_isotone minarc_below)
-    also have "... = e * v * top"
-      using True vector_classes_def by auto
-    also have "... \<le> v * top"
-      using True vector_classes_def mult_assoc by auto
-    finally show ?thesis
-      using True vector_classes_def by auto
-  next
-    case False
-    hence "m_choose_component e v = bot"
-      using False m_choose_component_def by auto
-    thus ?thesis
-      by simp
-  qed
-next
-  fix e v
-  show "vector (m_choose_component e v)"
-  proof (cases "vector_classes e v")
-    case True
-    thus ?thesis
-      by (simp add: mult_assoc m_choose_component_def)
-  next
-    case False
-    thus ?thesis
-      by (simp add: m_choose_component_def)
-  qed
-next
-  fix e v
-  show "regular (m_choose_component e v)"
-    using minarc_regular regular_mult_closed vector_classes_def m_choose_component_def by auto
-next
-  fix e v
-  show "m_choose_component e v * (m_choose_component e v)\<^sup>T \<le> e"
-  proof (cases "vector_classes e v")
-    case True
-    assume 1: "vector_classes e v"
-    hence "m_choose_component e v * (m_choose_component e v)\<^sup>T = e * minarc(v) * top * (e * minarc(v) * top)\<^sup>T"
-      by (simp add: m_choose_component_def)
-    also have "... = e * minarc(v) * top * top\<^sup>T * minarc(v)\<^sup>T * e\<^sup>T"
-      by (metis comp_associative conv_dist_comp)
-    also have "... = e * minarc(v) * top * top * minarc(v)\<^sup>T * e"
-      using True vector_classes_def by auto
-    also have "... = e * minarc(v) * top * minarc(v)\<^sup>T * e"
-      by (simp add: comp_associative)
-    also have "... \<le> e"
-    proof (cases "v = bot")
-      case True
-      thus ?thesis
-        by (simp add: True minarc_bot)
-    next
-      case False
-      assume 3: "v \<noteq> bot"
-      hence "e * minarc(v) * top * minarc(v)\<^sup>T \<le> e * 1"
-        using 3 minarc_arc arc_expanded comp_associative mult_right_isotone by fastforce
-      hence "e * minarc(v) * top * minarc(v)\<^sup>T * e \<le> e * 1 * e"
-        using mult_left_isotone by auto
-      also have "... = e"
-        using True preorder_idempotent vector_classes_def by auto
-      thus ?thesis
-        using calculation by auto
-    qed
-    thus ?thesis
-      by (simp add: calculation)
-  next
-    case False
-    thus ?thesis
-      by (simp add: m_choose_component_def)
-  qed
-next
-  fix e v
-  show "e * m_choose_component e v \<le> m_choose_component e v"
-  proof (cases "vector_classes e v")
-    case True
-    thus ?thesis
-      using comp_right_one dual_order.eq_iff mult_isotone vector_classes_def m_choose_component_def mult_assoc by metis
-  next
-    case False
-    thus ?thesis
-      by (simp add: m_choose_component_def)
-  qed
-next
-  fix e v
-  show "vector_classes e v \<longrightarrow> m_choose_component e v \<noteq> bot"
-  proof (cases "vector_classes e v")
-    case True
-    hence "m_choose_component e v \<ge> minarc(v) * top"
-      using vector_classes_def m_choose_component_def comp_associative minarc_arc shunt_bijective by fastforce
-    also have "... \<ge> minarc(v)"
-      using calculation dual_order.trans top_right_mult_increasing by blast
-    thus ?thesis
-      using le_bot minarc_bot_iff vector_classes_def by fastforce
-  next
-    case False
-    thus ?thesis
-      by blast
-  qed
-qed
-
-end
-
 subsection \<open>m-k-Stone-Kleene relation algebras\<close>
 
 text \<open>
 $m$-$k$-Stone-Kleene relation algebras are an extension of $m$-Kleene algebras where the \<open>choose_component\<close> operation has been added.
 \<close>
 
-class m_kleene_algebra_choose_component =
-  m_kleene_algebra
-  + choose_component_algebra
+context m_kleene_algebra_choose_component
 begin
 
 text \<open>
 A \<open>selected_edge\<close> is a minimum-weight edge whose source is in a component, with respect to $h$, $j$ and $g$, and whose target is not in that component.
 \<close>
 
 abbreviation "selected_edge h j g \<equiv> minarc (choose_component (forest_components h) j * - choose_component (forest_components h) j\<^sup>T \<sqinter> g)"
 
 text \<open>
 A \<open>path\<close> is any sequence of edges in the forest, $f$, of the graph, $g$, backwards from the target of the \<open>selected_edge\<close> to a root in $f$.
 \<close>
 
 abbreviation "path f h j g \<equiv> top * selected_edge h j g * (f \<sqinter> - selected_edge h j g\<^sup>T)\<^sup>T\<^sup>\<star>"
 
 definition "boruvka_outer_invariant f g \<equiv>
     symmetric g
   \<and> forest f
   \<and> f \<le> --g
   \<and> regular f
   \<and> (\<exists>w . minimum_spanning_forest w g \<and> f \<le> w \<squnion> w\<^sup>T)"
 
 definition "boruvka_inner_invariant j f h g d \<equiv>
     boruvka_outer_invariant f g
   \<and> g \<noteq> bot
   \<and> regular d
   \<and> regular j \<and> vector j
   \<and> regular h \<and> forest h
   \<and> forest_components h * j = j
   \<and> forest_modulo_equivalence (forest_components h) d
   \<and> d * top \<le> - j
   \<and> f \<squnion> f\<^sup>T = h \<squnion> h\<^sup>T \<squnion> d \<squnion> d\<^sup>T
   \<and> (\<forall> a b . forest_modulo_equivalence_path a b (forest_components h) d \<and> a \<le> -(forest_components h) \<sqinter> -- g \<and> b \<le> d \<longrightarrow> sum(b \<sqinter> g) \<le> sum(a \<sqinter> g))"
 
 lemma F_is_H_and_d:
   assumes "f \<squnion> f\<^sup>T = h \<squnion> h\<^sup>T \<squnion> d \<squnion> d\<^sup>T"
     and "injective f"
     and "injective h"
   shows "forest_components f = (forest_components h * (d \<squnion> d\<^sup>T))\<^sup>\<star> * forest_components h"
 proof -
   have "forest_components f = (f \<squnion> f\<^sup>T)\<^sup>\<star>"
     using assms(2) cancel_separate_1 by simp
   also have "... = (h \<squnion> h\<^sup>T \<squnion> d \<squnion> d\<^sup>T)\<^sup>\<star>"
     using assms(1) by auto
   also have "... = ((h \<squnion> h\<^sup>T)\<^sup>\<star> * (d \<squnion> d\<^sup>T))\<^sup>\<star> * (h \<squnion> h\<^sup>T)\<^sup>\<star>"
     using star.circ_sup_9 sup_assoc by metis
   also have "... = (forest_components h * (d \<squnion> d\<^sup>T))\<^sup>\<star> * forest_components h"
     using assms(3) forest_components_wcc by simp
   finally show ?thesis
     by simp
 qed
 
 lemma H_below_F:
   assumes "f \<squnion> f\<^sup>T = h \<squnion> h\<^sup>T \<squnion> d \<squnion> d\<^sup>T"
     and "injective f"
     and "injective h"
   shows "forest_components h \<le> forest_components f"
   using assms(1, 2, 3) cancel_separate_1 dual_order.trans star.circ_sub_dist by metis
 
 lemma H_below_regular_g:
   assumes "f \<squnion> f\<^sup>T = h \<squnion> h\<^sup>T \<squnion> d \<squnion> d\<^sup>T"
     and "f \<le> --g"
     and "symmetric g"
   shows "h \<le> --g"
 proof -
   have "h \<le> f \<squnion> f\<^sup>T"
     using assms(1) sup_assoc by simp
   also have "... \<le> --g"
     using assms(2, 3) conv_complement conv_isotone by fastforce
   finally show ?thesis
     using order_trans by blast
 qed
 
 lemma expression_equivalent_without_e_complement:
   assumes "selected_edge h j g \<le> - forest_components f"
   shows "f \<sqinter> - (selected_edge h j g)\<^sup>T \<sqinter> - (path f h j g) \<squnion> (f \<sqinter> - (selected_edge h j g)\<^sup>T \<sqinter> (path f h j g))\<^sup>T \<squnion> (selected_edge h j g)
          = f \<sqinter> - (path f h j g) \<squnion> (f \<sqinter> (path f h j g))\<^sup>T \<squnion> (selected_edge h j g)"
 proof -
   let ?p = "path f h j g"
   let ?e = "selected_edge h j g"
   let ?F = "forest_components f"
   have 1: "?e \<le> - ?F"
     by (simp add: assms)
   have "f\<^sup>T \<le> ?F"
     by (metis conv_dist_comp conv_involutive conv_order conv_star_commute forest_components_increasing)
   hence "- ?F \<le> - f\<^sup>T"
     using p_antitone by auto
   hence "?e \<le> - f\<^sup>T"
     using 1 dual_order.trans by blast
   hence "f\<^sup>T \<le> - ?e"
     by (simp add: p_antitone_iff)
   hence "f\<^sup>T\<^sup>T \<le> - ?e\<^sup>T"
     by (metis conv_complement conv_dist_inf inf.orderE inf.orderI)
   hence "f \<le> - ?e\<^sup>T"
     by auto
   hence "f = f \<sqinter> - ?e\<^sup>T"
     using inf.orderE by blast
   hence "f \<sqinter> - ?e\<^sup>T \<sqinter> - ?p \<squnion> (f \<sqinter> - ?e\<^sup>T \<sqinter> ?p)\<^sup>T \<squnion> ?e = f \<sqinter> - ?p \<squnion> (f \<sqinter> ?p)\<^sup>T \<squnion> ?e"
     by auto
   thus ?thesis by auto
 qed
 
 text \<open>
 The source of the \<open>selected_edge\<close> is contained in $j$, the vector describing those vertices still to be processed in the inner loop of Bor\r{u}vka's algorithm.
 \<close>
 
 lemma et_below_j:
   assumes "vector j"
     and "regular j"
     and "j \<noteq> bot"
   shows "selected_edge h j g * top \<le> j"
 proof -
   let ?e = "selected_edge h j g"
   let ?c = "choose_component (forest_components h) j"
   have "?e * top \<le> --(?c * -?c\<^sup>T \<sqinter> g) * top"
     using comp_isotone minarc_below by blast
   also have "... = (--(?c * -?c\<^sup>T) \<sqinter> --g) * top"
     by simp
   also have "... = (?c * -?c\<^sup>T \<sqinter> --g) * top"
     using component_is_regular regular_mult_closed by auto
   also have "... = (?c \<sqinter> -?c\<^sup>T \<sqinter> --g) * top"
     by (metis component_is_vector conv_complement vector_complement_closed vector_covector)
   also have "... \<le> ?c * top"
     using inf.cobounded1 mult_left_isotone order_trans by blast
   also have "... \<le> j * top"
     by (metis assms(2) comp_inf.star.circ_sup_2 comp_isotone component_in_v)
   also have "... = j"
     by (simp add: assms(1))
   finally show ?thesis
     by simp
 qed
 
 subsubsection \<open>Components of forests and forests modulo an equivalence\<close>
 
 text \<open>
 We prove a number of properties about \<open>forest_modulo_equivalence\<close> and \<open>forest_components\<close>.
 \<close>
 
-lemma component_single_eq:
-  assumes "equivalence x"
-  shows "choose_component x v = x * choose_component x v"
-proof -
-  have 1: "choose_component x v \<le> x * choose_component x v"
-    by (meson component_is_connected ex231c mult_isotone order_lesseq_imp)
-  thus ?thesis
-    by (simp add: component_single order.antisym)
-qed
-
 lemma fc_j_eq_j_inv:
   assumes "forest h"
     and "forest_components h * j = j"
   shows "forest_components h * (j \<sqinter> - choose_component (forest_components h) j) = j \<sqinter> - choose_component (forest_components h) j"
 proof -
   let ?c = "choose_component (forest_components h) j"
   let ?H = "forest_components h"
   have 1:"equivalence ?H"
     by (simp add: assms(1) forest_components_equivalence)
   have "?H * (j \<sqinter> - ?c) = ?H * j \<sqinter> ?H * - ?c"
     using 1 by (metis assms(2) equivalence_comp_dist_inf inf.sup_monoid.add_commute)
   hence 2: "?H * (j \<sqinter> - ?c) = j \<sqinter> ?H * - ?c"
     by (simp add: assms(2))
   have 3: "j \<sqinter> - ?c \<le> ?H * - ?c"
     using 1 by (metis assms(2) dedekind_1 dual_order.trans equivalence_comp_dist_inf inf.cobounded2)
   have "?H * ?c \<le> ?c"
     using component_single by auto
   hence "?H\<^sup>T * ?c \<le> ?c"
     using 1 by simp
   hence "?H * - ?c \<le> - ?c"
     using component_is_regular schroeder_3_p by force
   hence "j \<sqinter> ?H * - ?c \<le> j \<sqinter> - ?c"
     using inf.sup_right_isotone by auto
   thus ?thesis
     using 2 3 order.antisym by simp
 qed
 
 text \<open>
 There is a path in the \<open>forest_modulo_equivalence\<close> between edges $a$ and $b$ if and only if there is either a path in the \<open>forest_modulo_equivalence\<close> from $a$ to $b$ or one from $a$ to $c$ and one from $c$ to $b$.
 \<close>
 
 lemma forest_modulo_equivalence_path_split_disj:
   assumes "equivalence H"
     and "arc c"
     and "regular a \<and> regular b \<and> regular c \<and> regular d \<and> regular H"
   shows "forest_modulo_equivalence_path a b H (d \<squnion> c) \<longleftrightarrow> forest_modulo_equivalence_path a b H d \<or> (forest_modulo_equivalence_path a c H d \<and> forest_modulo_equivalence_path c b H d)"
 proof -
   have 1: "forest_modulo_equivalence_path a b H (d \<squnion> c) \<longrightarrow> forest_modulo_equivalence_path a b H d \<or> (forest_modulo_equivalence_path a c H d \<and> forest_modulo_equivalence_path c b H d)"
   proof (rule impI)
     assume 11: "forest_modulo_equivalence_path a b H (d \<squnion> c)"
     hence "a\<^sup>T * top \<le> (H * (d \<squnion> c))\<^sup>\<star> * H * b * top"
       by (simp add: forest_modulo_equivalence_path_def)
     also have "... = ((H * d)\<^sup>\<star> \<squnion> (H * d)\<^sup>\<star> * H * c * (H * d)\<^sup>\<star>) * H * b * top"
       using assms(1, 2) path_through_components by simp
     also have "... = (H * d)\<^sup>\<star> * H * b * top \<squnion> (H * d)\<^sup>\<star> * H * c * (H * d)\<^sup>\<star> * H * b * top"
       by (simp add: mult_right_dist_sup)
     finally have 12:"a\<^sup>T * top \<le> (H * d)\<^sup>\<star> * H * b * top \<squnion> (H * d)\<^sup>\<star> * H * c * (H * d)\<^sup>\<star> * H * b * top"
       by simp
     have 13: "a\<^sup>T * top \<le> (H * d)\<^sup>\<star> * H * b * top \<or> a\<^sup>T * top \<le> (H * d)\<^sup>\<star> * H * c * (H * d)\<^sup>\<star> * H * b * top"
     proof (rule point_in_vector_sup)
       show "point (a\<^sup>T * top)"
         using 11 forest_modulo_equivalence_path_def mult_assoc by auto
     next
       show "vector ((H * d)\<^sup>\<star> * H * b * top)"
         using vector_mult_closed by simp
     next
       show "regular ((H * d)\<^sup>\<star> * H * b * top)"
         using assms(3) pp_dist_comp pp_dist_star by auto
     next
       show "a\<^sup>T * top \<le> (H * d)\<^sup>\<star> * H * b * top \<squnion> (H * d)\<^sup>\<star> * H * c * (H * d)\<^sup>\<star> * H * b * top"
         using 12 by simp
     qed
     thus "forest_modulo_equivalence_path a b H d \<or> (forest_modulo_equivalence_path a c H d \<and> forest_modulo_equivalence_path c b H d)"
     proof (cases "a\<^sup>T * top \<le> (H * d)\<^sup>\<star> * H * b * top")
       case True
       assume "a\<^sup>T * top \<le> (H * d)\<^sup>\<star> * H * b * top"
       hence "forest_modulo_equivalence_path a b H d"
         using 11 forest_modulo_equivalence_path_def by auto
       thus ?thesis
         by simp
     next
       case False
       have 14: "a\<^sup>T * top \<le> (H * d)\<^sup>\<star> * H * c * (H * d)\<^sup>\<star> * H * b * top"
         using 13 by (simp add: False)
       hence 15: "a\<^sup>T * top \<le> (H * d)\<^sup>\<star> * H * c * top"
         by (metis mult_right_isotone order_lesseq_imp top_greatest mult_assoc)
       have "c\<^sup>T * top \<le> (H * d)\<^sup>\<star> * H * b * top"
       proof (rule ccontr)
         assume "\<not> c\<^sup>T * top \<le> (H * d)\<^sup>\<star> * H * b * top"
         hence "c\<^sup>T * top \<le> -((H * d)\<^sup>\<star> * H * b * top)"
           by (meson assms(2, 3) point_in_vector_or_complement regular_closed_star regular_closed_top regular_mult_closed vector_mult_closed vector_top_closed)
         hence "c * (H * d)\<^sup>\<star> * H * b * top \<le> bot"
           using schroeder_3_p mult_assoc by auto
         thus "False"
           using 13 False sup.absorb_iff1 mult_assoc by auto
       qed
       hence "forest_modulo_equivalence_path a c H d \<and> forest_modulo_equivalence_path c b H d"
         using 11 15 assms(2) forest_modulo_equivalence_path_def by auto
       thus ?thesis
         by simp
     qed
   qed
   have 2: "forest_modulo_equivalence_path a b H d \<or> (forest_modulo_equivalence_path a c H d \<and> forest_modulo_equivalence_path c b H d) \<longrightarrow> forest_modulo_equivalence_path a b H (d \<squnion> c)"
   proof -
     have 21: "forest_modulo_equivalence_path a b H d \<longrightarrow> forest_modulo_equivalence_path a b H (d \<squnion> c)"
     proof (rule impI)
       assume 22:"forest_modulo_equivalence_path a b H d"
       hence "a\<^sup>T * top \<le> (H * d)\<^sup>\<star> * H * b * top"
         using forest_modulo_equivalence_path_def by blast
       hence "a\<^sup>T * top \<le> (H * (d \<squnion> c))\<^sup>\<star> * H * b * top"
         by (simp add: mult_left_isotone mult_right_dist_sup mult_right_isotone order.trans star_isotone star_slide)
       thus "forest_modulo_equivalence_path a b H (d \<squnion> c)"
         using 22 forest_modulo_equivalence_path_def by blast
     qed
     have "forest_modulo_equivalence_path a c H d \<and> forest_modulo_equivalence_path c b H d \<longrightarrow> forest_modulo_equivalence_path a b H (d \<squnion> c)"
     proof (rule impI)
       assume 23: "forest_modulo_equivalence_path a c H d \<and> forest_modulo_equivalence_path c b H d"
       hence "a\<^sup>T * top \<le> (H * d)\<^sup>\<star> * H * c * top"
         using forest_modulo_equivalence_path_def by blast
       also have "... \<le> (H * d)\<^sup>\<star> * H * c * c\<^sup>T * c * top"
         by (metis ex231c comp_inf.star.circ_sup_2 mult_isotone mult_right_isotone mult_assoc)
       also have "... \<le> (H * d)\<^sup>\<star> * H * c * c\<^sup>T * top"
         by (simp add: mult_right_isotone mult_assoc)
       also have "... \<le> (H * d)\<^sup>\<star> * H * c * (H * d)\<^sup>\<star> * H * b * top"
         using 23 mult_right_isotone mult_assoc by (simp add: forest_modulo_equivalence_path_def)
       also have "... \<le> (H * d)\<^sup>\<star> * H * b * top \<squnion> (H * d)\<^sup>\<star> * H * c * (H * d)\<^sup>\<star> * H * b * top"
         by (simp add: forest_modulo_equivalence_path_def)
       finally have "a\<^sup>T * top \<le> (H * (d \<squnion> c))\<^sup>\<star> * H * b * top"
         using assms(1, 2) path_through_components mult_right_dist_sup by simp
       thus "forest_modulo_equivalence_path a b H (d \<squnion> c)"
         using 23 forest_modulo_equivalence_path_def by blast
     qed
     thus ?thesis
       using 21 by auto
   qed
   thus ?thesis
     using 1 2 by blast
 qed
 
 lemma dT_He_eq_bot:
   assumes "vector j"
     and "regular j"
     and "d * top \<le> - j"
     and "forest_components h * j = j"
     and "j \<noteq> bot"
   shows "d\<^sup>T * forest_components h * selected_edge h j g \<le> bot"
 proof -
   let ?e = "selected_edge h j g"
   let ?H = "forest_components h"
   have 1: "?e * top \<le> j"
     using assms(1, 2, 5) et_below_j by auto
   have "d\<^sup>T * ?H * ?e \<le> (d * top)\<^sup>T * ?H * (?e * top)"
     by (simp add: comp_isotone conv_isotone top_right_mult_increasing)
   also have "... \<le> (d * top)\<^sup>T * ?H * j"
     using 1 mult_right_isotone by auto
   also have "... \<le> (- j)\<^sup>T * ?H * j"
     by (simp add: assms(3) conv_isotone mult_left_isotone)
   also have "... = (- j)\<^sup>T * j"
     using assms(4) comp_associative by auto
   also have "... = bot"
     by (simp add: assms(1) conv_complement covector_vector_comp)
   finally show ?thesis
     using coreflexive_bot_closed le_bot by blast
 qed
 
 lemma forest_modulo_equivalence_d_U_e:
   assumes "forest f"
     and "vector j"
     and "regular j"
     and "forest h"
     and "forest_modulo_equivalence (forest_components h) d"
     and "d * top \<le> - j"
     and "forest_components h * j = j"
     and "f \<squnion> f\<^sup>T = h \<squnion> h\<^sup>T \<squnion> d \<squnion> d\<^sup>T"
     and "selected_edge h j g \<le> - forest_components f"
     and "j \<noteq> bot"
   shows "forest_modulo_equivalence (forest_components h) (d \<squnion> selected_edge h j g)"
 proof (cases "selected_edge h j g = bot")
   let ?e = "selected_edge h j g"
   case True
   assume "?e = bot"
   thus ?thesis
     by (simp add: True assms(5))
 next
   let ?H = "forest_components h"
   let ?F = "forest_components f"
   let ?e = "selected_edge h j g"
   let ?d' = "d \<squnion> ?e"
   case False
   assume e_not_bot: "?e \<noteq> bot"
   have "forest_modulo_equivalence (forest_components h) (d \<squnion> selected_edge h j g)"
   proof (unfold forest_modulo_equivalence_def, intro conjI)
     show 01: "reflexive ?H"
       by (simp add: assms(4) forest_components_equivalence)
     show 02: "transitive ?H"
       by (simp add: assms(4) forest_components_equivalence)
     show 03: "symmetric ?H"
       by (simp add: assms(4) forest_components_equivalence)
     have 04: "equivalence ?H"
       by (simp add: 01 02 03)
     show "univalent (?H * ?d')"
     proof -
       have "(?H * ?d')\<^sup>T * (?H * ?d') = ?d'\<^sup>T * ?H\<^sup>T * ?H * ?d'"
         using conv_dist_comp mult_assoc by auto
       also have "... = ?d'\<^sup>T * ?H * ?H * ?d'"
         by (simp add: conv_dist_comp conv_star_commute)
       also have "... = ?d'\<^sup>T * ?H * ?d'"
         using 01 02 by (metis preorder_idempotent mult_assoc)
       finally have 21: "univalent (?H * ?d') \<longleftrightarrow> ?e\<^sup>T * ?H * d \<squnion> d\<^sup>T * ?H * ?e \<squnion> ?e\<^sup>T * ?H * ?e \<squnion> d\<^sup>T * ?H * d \<le> 1"
         using conv_dist_sup semiring.distrib_left semiring.distrib_right by auto
       have 22: "?e\<^sup>T * ?H * ?e \<le> 1"
       proof -
         have 221: "?e\<^sup>T * ?H * ?e \<le> ?e\<^sup>T * top * ?e"
           by (simp add: mult_left_isotone mult_right_isotone)
         have "arc ?e"
           using e_not_bot minarc_arc minarc_bot_iff by blast
         hence "?e\<^sup>T * top * ?e \<le> 1"
           using arc_expanded by blast
         thus ?thesis
           using 221 dual_order.trans by blast
       qed
       have 24: "d\<^sup>T * ?H * ?e \<le> 1"
         by (metis assms(2, 3, 6, 7, 10) dT_He_eq_bot coreflexive_bot_closed le_bot)
       hence "(d\<^sup>T * ?H * ?e)\<^sup>T \<le> 1\<^sup>T"
         using conv_isotone by blast
       hence "?e\<^sup>T * ?H\<^sup>T * d\<^sup>T\<^sup>T \<le> 1"
         by (simp add: conv_dist_comp mult_assoc)
       hence 25: "?e\<^sup>T * ?H * d \<le> 1"
         using assms(4) fch_equivalence by auto
       have 8: "d\<^sup>T * ?H * d \<le> 1"
         using 04 assms(5) dTransHd_le_1 forest_modulo_equivalence_def by blast
       thus ?thesis
         using 21 22 24 25 by simp
     qed
     show "coreflexive (?H \<sqinter> ?d' * ?d'\<^sup>T)"
     proof -
       have "coreflexive (?H \<sqinter> ?d' * ?d'\<^sup>T) \<longleftrightarrow> ?H \<sqinter> (d \<squnion> ?e) * (d\<^sup>T \<squnion> ?e\<^sup>T) \<le> 1"
         by (simp add: conv_dist_sup)
       also have "... \<longleftrightarrow> ?H \<sqinter> (d * d\<^sup>T \<squnion> d * ?e\<^sup>T \<squnion> ?e * d\<^sup>T \<squnion> ?e * ?e\<^sup>T) \<le> 1"
         by (metis mult_left_dist_sup mult_right_dist_sup sup.left_commute sup_commute)
       finally have 1: "coreflexive (?H \<sqinter> ?d' * ?d'\<^sup>T) \<longleftrightarrow> ?H \<sqinter> d * d\<^sup>T \<squnion> ?H \<sqinter> d * ?e\<^sup>T \<squnion> ?H \<sqinter> ?e * d\<^sup>T \<squnion> ?H \<sqinter> ?e * ?e\<^sup>T \<le> 1"
         by (simp add: inf_sup_distrib1)
       have 31: "?H \<sqinter> d * d\<^sup>T \<le> 1"
         using assms(5) forest_modulo_equivalence_def by blast
       have 32: "?H \<sqinter> ?e * d\<^sup>T \<le> 1"
       proof -
         have "?e * d\<^sup>T \<le> ?e * top * (d * top)\<^sup>T"
           by (simp add: conv_isotone mult_isotone top_right_mult_increasing)
         also have "... \<le> ?e * top * - j\<^sup>T"
           by (metis assms(6) conv_complement conv_isotone mult_right_isotone)
         also have "... \<le> j * - j\<^sup>T"
           using assms(2, 3, 10) et_below_j mult_left_isotone by auto
         also have "... \<le> - ?H"
           using 03 by (metis assms(2, 3, 7) conv_complement conv_dist_comp equivalence_top_closed mult_left_isotone schroeder_3_p vector_top_closed)
         finally have "?e * d\<^sup>T \<le> - ?H"
           by simp
         thus ?thesis
           by (metis inf.coboundedI1 p_antitone_iff p_shunting_swap regular_one_closed)
       qed
       have 33: "?H \<sqinter> d * ?e\<^sup>T \<le> 1"
       proof -
         have 331: "injective h"
           by (simp add: assms(4))
         have "(?H \<sqinter> ?e * d\<^sup>T)\<^sup>T \<le> 1"
           using 32 coreflexive_conv_closed by auto
         hence "?H \<sqinter> (?e * d\<^sup>T)\<^sup>T \<le> 1"
           using 331 conv_dist_inf forest_components_equivalence by auto
         thus ?thesis
           using conv_dist_comp by auto
       qed
       have 34: "?H \<sqinter> ?e * ?e\<^sup>T \<le> 1"
       proof -
         have 341:"arc ?e \<and> arc (?e\<^sup>T)"
           using e_not_bot minarc_arc minarc_bot_iff by auto
         have "?H \<sqinter> ?e * ?e\<^sup>T \<le> ?e * ?e\<^sup>T"
           by auto
         thus ?thesis
           using 341 arc_injective le_infI2 by blast
       qed
       thus ?thesis
         using 1 31 32 33 34 by simp
     qed
     show 4:"(?H * (d \<squnion> ?e))\<^sup>+ \<sqinter> ?H \<le> bot"
     proof -
       have 40: "(?H * d)\<^sup>+ \<le> -?H"
         using assms(5) forest_modulo_equivalence_def bot_unique pseudo_complement by blast
       have "?e \<le> - ?F"
         by (simp add: assms(9))
       hence "?F \<le> - ?e"
         by (simp add: p_antitone_iff)
       hence "?F\<^sup>T * ?F \<le> - ?e"
         using assms(1) fch_equivalence by fastforce
       hence "?F\<^sup>T * ?F * ?F\<^sup>T \<le> - ?e"
         by (metis assms(1) fch_equivalence forest_components_star star.circ_decompose_9)
       hence 41: "?F * ?e * ?F \<le> - ?F"
         using triple_schroeder_p by blast
       hence 42:"(?F * ?F)\<^sup>\<star> * ?F * ?e * (?F * ?F)\<^sup>\<star> \<le> - ?F"
       proof -
         have 43: "?F * ?F = ?F"
           using assms(1) forest_components_equivalence preorder_idempotent by auto
         hence "?F * ?e * ?F = ?F * ?F * ?e * ?F"
           by simp
         also have "... = (?F)\<^sup>\<star> * ?F * ?e * (?F)\<^sup>\<star>"
           by (simp add: assms(1) forest_components_star)
         also have "... = (?F * ?F)\<^sup>\<star> * ?F * ?e * (?F * ?F)\<^sup>\<star>"
           using 43 by simp
         finally show ?thesis
           using 41 by simp
       qed
       hence 44: "(?H * d)\<^sup>\<star> * ?H * ?e * (?H * d)\<^sup>\<star> \<le> - ?H"
       proof -
         have 45: "?H \<le> ?F"
           using assms(1, 4, 8) H_below_F by blast
         hence 46:"?H * ?e \<le> ?F * ?e"
           by (simp add: mult_left_isotone)
         have "d \<le> f \<squnion> f\<^sup>T"
           using assms(8) sup.left_commute sup_commute by auto
         also have "... \<le> ?F"
           by (metis forest_components_increasing le_supI2 star.circ_back_loop_fixpoint star.circ_increasing sup.bounded_iff)
         finally have "d \<le> ?F"
           by simp
         hence "?H * d \<le> ?F * ?F"
           using 45 mult_isotone by auto
         hence 47: "(?H * d)\<^sup>\<star> \<le> (?F * ?F)\<^sup>\<star>"
           by (simp add: star_isotone)
         hence "(?H * d)\<^sup>\<star> * ?H * ?e * (?H * d)\<^sup>\<star> \<le> (?H * d)\<^sup>\<star> * ?F * ?e * (?H * d)\<^sup>\<star>"
           using 46 by (metis mult_left_isotone mult_right_isotone mult_assoc)
         also have "... \<le> (?F * ?F)\<^sup>\<star> * ?F * ?e * (?F * ?F)\<^sup>\<star>"
           using 47 mult_left_isotone mult_right_isotone by (simp add: comp_isotone)
         also have "... \<le> - ?F"
           using 42 by simp
         also have "... \<le> - ?H"
           using 45 by (simp add: p_antitone)
         finally show ?thesis
           by simp
       qed
       have "(?H * (d \<squnion> ?e))\<^sup>+ = (?H * (d \<squnion> ?e))\<^sup>\<star> * (?H * (d \<squnion> ?e))"
         using star.circ_plus_same by auto
       also have "... = ((?H * d)\<^sup>\<star> \<squnion> (?H * d)\<^sup>\<star> * ?H * ?e * (?H * d)\<^sup>\<star>) * (?H * (d \<squnion> ?e))"
         using assms(4) e_not_bot forest_components_equivalence minarc_arc minarc_bot_iff path_through_components by auto
       also have "... = (?H * d)\<^sup>\<star> * (?H * (d \<squnion> ?e)) \<squnion> (?H * d)\<^sup>\<star> * ?H * ?e * (?H * d)\<^sup>\<star> * (?H * (d \<squnion> ?e))"
         using mult_right_dist_sup by auto
       also have "... = (?H * d)\<^sup>\<star> * (?H * d \<squnion> ?H * ?e) \<squnion> (?H * d)\<^sup>\<star> * ?H * ?e * (?H * d)\<^sup>\<star> * (?H * d \<squnion> ?H * ?e)"
         by (simp add: mult_left_dist_sup)
       also have "... = (?H * d)\<^sup>\<star> * ?H * d \<squnion> (?H * d)\<^sup>\<star> * ?H * ?e \<squnion> (?H * d)\<^sup>\<star> * ?H * ?e * (?H * d)\<^sup>\<star> * (?H * d \<squnion> ?H * ?e)"
         using mult_left_dist_sup mult_assoc by auto
       also have "... = (?H * d)\<^sup>+ \<squnion> (?H * d)\<^sup>\<star> * ?H * ?e \<squnion> (?H * d)\<^sup>\<star> * ?H * ?e * (?H * d)\<^sup>\<star> * (?H * d \<squnion> ?H * ?e)"
         by (simp add: star.circ_plus_same mult_assoc)
       also have "... = (?H * d)\<^sup>+ \<squnion> (?H * d)\<^sup>\<star> * ?H * ?e \<squnion> (?H * d)\<^sup>\<star> * ?H * ?e * (?H * d)\<^sup>\<star> * ?H * d \<squnion> (?H * d)\<^sup>\<star> * ?H * ?e * (?H * d)\<^sup>\<star> * ?H * ?e"
         by (simp add: mult.semigroup_axioms semiring.distrib_left sup.semigroup_axioms semigroup.assoc)
       also have "... \<le> (?H * d)\<^sup>+ \<squnion> (?H * d)\<^sup>\<star> * ?H * ?e \<squnion> (?H * d)\<^sup>\<star> * ?H * ?e * (?H * d)\<^sup>\<star> * ?H * d \<squnion> (?H * d)\<^sup>\<star> * ?H * ?e"
       proof -
         have "?e * (?H * d)\<^sup>\<star> * ?H * ?e \<le> ?e * top * ?e"
           by (metis comp_associative comp_inf.coreflexive_idempotent comp_inf.coreflexive_transitive comp_isotone top.extremum)
         also have "... \<le> ?e"
           using e_not_bot arc_top_arc minarc_arc minarc_bot_iff by auto
         finally have "?e * (?H * d)\<^sup>\<star> * ?H * ?e \<le> ?e"
           by simp
         hence "(?H * d)\<^sup>\<star> * ?H * ?e * (?H * d)\<^sup>\<star> * ?H * ?e \<le> (?H * d)\<^sup>\<star> * ?H * ?e"
           by (simp add: comp_associative comp_isotone)
         thus ?thesis
           using sup_right_isotone by blast
       qed
       also have "... = (?H * d)\<^sup>+ \<squnion> (?H * d)\<^sup>\<star> * ?H * ?e \<squnion> (?H * d)\<^sup>\<star> * ?H * ?e * (?H * d)\<^sup>\<star> * ?H * d"
         by (simp add: order.eq_iff ac_simps)
       also have "... = (?H * d)\<^sup>+ \<squnion> (?H * d)\<^sup>\<star> * ?H * ?e \<squnion> (?H * d)\<^sup>\<star> * ?H * ?e * (?H * d)\<^sup>+"
         using star.circ_plus_same mult_assoc by auto
       also have "... = (?H * d)\<^sup>+ \<squnion> (?H * d)\<^sup>\<star> * ?H * ?e * (1 \<squnion> (?H * d)\<^sup>+)"
         by (simp add: mult_left_dist_sup sup_assoc)
       also have "... = (?H * d)\<^sup>+ \<squnion> (?H * d)\<^sup>\<star> * ?H * ?e * (?H * d)\<^sup>\<star>"
         by (simp add: star_left_unfold_equal)
       also have "... \<le> - ?H"
         using 40 44 assms(5) sup.boundedI by blast
       finally show ?thesis
         using pseudo_complement by force
     qed
   qed
   thus ?thesis
     by blast
 qed
 
 subsubsection \<open>Identifying arcs\<close>
 
 text \<open>
 The expression $d \sqcap \top e^\top H \sqcap (H d^\top)^* H a^\top \top$ identifies the edge incoming to the component that the \<open>selected_edge\<close>, $e$, is outgoing from and which is on the path from edge $a$ to $e$.
 Here, we prove this expression is an \<open>arc\<close>.
 \<close>
 
 lemma shows_arc_x:
   assumes "forest_modulo_equivalence H d"
     and "forest_modulo_equivalence_path a e H d"
     and "H * d * (H * d)\<^sup>\<star> \<le> - H"
     and "\<not> a\<^sup>T * top \<le> H * e * top"
     and "regular a"
     and "regular e"
     and "regular H"
     and "regular d"
   shows "arc (d \<sqinter> top * e\<^sup>T * H \<sqinter> (H * d\<^sup>T)\<^sup>\<star> * H * a\<^sup>T * top)"
 proof -
   let ?x = "d \<sqinter> top * e\<^sup>T * H \<sqinter> (H * d\<^sup>T)\<^sup>\<star> * H * a\<^sup>T * top"
   have 1:"regular ?x"
     using assms(5, 6, 7, 8) regular_closed_star regular_conv_closed regular_mult_closed by auto
   have 2: "a\<^sup>T * top * a \<le> 1"
     using arc_expanded assms(2) forest_modulo_equivalence_path_def by auto
   have 3: "e * top * e\<^sup>T \<le> 1"
     using assms(2) forest_modulo_equivalence_path_def arc_expanded by blast
   have 4: "top * ?x * top = top"
   proof -
     have "a\<^sup>T * top \<le> (H * d)\<^sup>\<star> * H * e * top"
       using assms(2) forest_modulo_equivalence_path_def by blast
     also have "... = H * e * top \<squnion> (H * d)\<^sup>\<star> * H * d * H * e * top"
       by (metis star.circ_loop_fixpoint star.circ_plus_same sup_commute mult_assoc)
     finally have "a\<^sup>T * top \<le> H * e * top \<squnion> (H * d)\<^sup>\<star> * H * d * H * e * top"
       by simp
     hence "a\<^sup>T * top \<le> H * e * top \<or> a\<^sup>T * top \<le> (H * d)\<^sup>\<star> * H * d * H * e * top"
       using assms(2, 6, 7) point_in_vector_sup forest_modulo_equivalence_path_def regular_mult_closed vector_mult_closed by auto
     hence "a\<^sup>T * top \<le> (H * d)\<^sup>\<star> * H * d * H * e * top"
       using assms(4) by blast
     also have "... = (H * d)\<^sup>\<star> * H * d * (H * e * top \<sqinter> H * e * top)"
       by (simp add: mult_assoc)
     also have "... = (H * d)\<^sup>\<star> * H * (d \<sqinter> (H * e * top)\<^sup>T) * H * e * top"
       by (metis comp_associative covector_inf_comp_3 star.circ_left_top star.circ_top)
     also have "... = (H * d)\<^sup>\<star> * H * (d \<sqinter> top\<^sup>T * e\<^sup>T * H\<^sup>T) * H * e * top"
       using conv_dist_comp mult_assoc by auto
     also have "... = (H * d)\<^sup>\<star> * H * (d \<sqinter> top * e\<^sup>T * H) * H * e * top"
       using assms(1) by (simp add: forest_modulo_equivalence_def)
     finally have 2: "a\<^sup>T * top \<le> (H * d)\<^sup>\<star> * H * (d \<sqinter> top * e\<^sup>T * H) * H * e * top"
       by simp
     hence "e * top \<le> ((H * d)\<^sup>\<star> * H * (d \<sqinter> top * e\<^sup>T * H) * H)\<^sup>T * a\<^sup>T * top"
     proof -
       have "bijective (e * top) \<and> bijective (a\<^sup>T * top)"
         using assms(2) forest_modulo_equivalence_path_def by auto
       thus ?thesis
         using 2 by (metis bijective_reverse mult_assoc)
     qed
     also have "... = H\<^sup>T * (d \<sqinter> top * e\<^sup>T * H)\<^sup>T * H\<^sup>T * (H * d)\<^sup>\<star>\<^sup>T * a\<^sup>T * top"
       by (simp add: conv_dist_comp mult_assoc)
     also have "... = H * (d \<sqinter> top * e\<^sup>T * H)\<^sup>T * H * (H * d)\<^sup>\<star>\<^sup>T * a\<^sup>T * top"
       using assms(1) forest_modulo_equivalence_def by auto
     also have "... = H * (d \<sqinter> top * e\<^sup>T * H)\<^sup>T * H * (d\<^sup>T * H)\<^sup>\<star> * a\<^sup>T * top"
       using assms(1) forest_modulo_equivalence_def conv_dist_comp conv_star_commute by auto
     also have "... = H * (d\<^sup>T \<sqinter> H * e * top) * H * (d\<^sup>T * H)\<^sup>\<star> * a\<^sup>T * top"
       using assms(1) conv_dist_comp forest_modulo_equivalence_def comp_associative conv_dist_inf by auto
     also have "... = H * (d\<^sup>T \<sqinter> H * e * top) * (H * d\<^sup>T)\<^sup>\<star> * H * a\<^sup>T * top"
       by (simp add: comp_associative star_slide)
     also have "... = H * (d\<^sup>T \<sqinter> H * e * top) * ((H * d\<^sup>T)\<^sup>\<star> * H * a\<^sup>T * top \<sqinter> (H * d\<^sup>T)\<^sup>\<star> * H * a\<^sup>T * top)"
       using mult_assoc by auto
     also have "... = H * (d\<^sup>T \<sqinter> H * e * top \<sqinter> ((H * d\<^sup>T)\<^sup>\<star> * H * a\<^sup>T * top)\<^sup>T) * (H * d\<^sup>T)\<^sup>\<star> * H * a\<^sup>T * top"
       by (smt comp_inf_vector covector_comp_inf vector_conv_covector vector_top_closed mult_assoc)
     also have "... = H * (d\<^sup>T \<sqinter> (top * e\<^sup>T * H)\<^sup>T \<sqinter> ((H * d\<^sup>T)\<^sup>\<star> * H * a\<^sup>T * top)\<^sup>T) * (H * d\<^sup>T)\<^sup>\<star> * H * a\<^sup>T * top"
       using assms(1) forest_modulo_equivalence_def conv_dist_comp mult_assoc by auto
     also have "... = H * (d \<sqinter> top * e\<^sup>T * H \<sqinter> (H * d\<^sup>T)\<^sup>\<star> * H * a\<^sup>T * top)\<^sup>T * (H * d\<^sup>T)\<^sup>\<star> * H * a\<^sup>T * top"
       by (simp add: conv_dist_inf)
     finally have 3: "e * top \<le> H * ?x\<^sup>T * (H * d\<^sup>T)\<^sup>\<star> * H * a\<^sup>T * top"
       by auto
     have "?x \<noteq> bot"
     proof (rule ccontr)
       assume "\<not> ?x \<noteq> bot"
       hence "e * top = bot"
         using 3 le_bot by auto
       thus "False"
         using assms(2, 4) forest_modulo_equivalence_path_def mult_assoc semiring.mult_zero_right by auto
     qed
     thus ?thesis
       using 1 using tarski by blast
   qed
   have 5: "?x * top * ?x\<^sup>T \<le> 1"
   proof -
     have 51: "H * (d * H)\<^sup>\<star> \<sqinter> d * H * d\<^sup>T \<le> 1"
     proof -
       have 511: "d * (H * d)\<^sup>\<star> \<le> - H"
         using assms(1, 3) forest_modulo_equivalence_def preorder_idempotent schroeder_4_p triple_schroeder_p by fastforce
       hence "(d * H)\<^sup>\<star> * d \<le> - H"
         using star_slide by auto
       hence "H * (d\<^sup>T * H)\<^sup>\<star> \<le> - d"
         by (smt assms(1) forest_modulo_equivalence_def conv_dist_comp conv_star_commute schroeder_4_p star_slide)
       hence "H * (d * H)\<^sup>\<star> \<le> - d\<^sup>T"
         using 511 by (metis assms(1) forest_modulo_equivalence_def schroeder_5_p star_slide)
       hence "H * (d * H)\<^sup>\<star> \<le> - (H * d\<^sup>T)"
         by (metis assms(3) p_antitone_iff schroeder_4_p star_slide mult_assoc)
       hence "H * (d * H)\<^sup>\<star> \<sqinter> H * d\<^sup>T \<le> bot"
         by (simp add: bot_unique pseudo_complement)
       hence "H * d * (H * (d * H)\<^sup>\<star> \<sqinter> H * d\<^sup>T) \<le> 1"
         by (simp add: bot_unique)
       hence 512: "H * d * H * (d * H)\<^sup>\<star> \<sqinter> H * d * H * d\<^sup>T \<le> 1"
         using univalent_comp_left_dist_inf assms(1) forest_modulo_equivalence_def mult_assoc by fastforce
       hence 513: "H * d * H * (d * H)\<^sup>\<star> \<sqinter> d * H * d\<^sup>T \<le> 1"
       proof -
         have "d * H * d\<^sup>T \<le> H * d * H * d\<^sup>T"
           by (metis assms(1) forest_modulo_equivalence_def conv_dist_comp conv_involutive mult_1_right mult_left_isotone)
         thus ?thesis
           using 512 by (smt dual_order.trans p_antitone p_shunting_swap regular_one_closed)
       qed
       have "d\<^sup>T * H * d \<le> 1 \<squnion> - H"
         using assms(1) forest_modulo_equivalence_def dTransHd_le_1 le_supI1 by blast
       hence "(- 1 \<sqinter> H) * d\<^sup>T * H \<le> - d\<^sup>T"
         by (metis assms(1) forest_modulo_equivalence_def dTransHd_le_1 inf.sup_monoid.add_commute le_infI2 p_antitone_iff regular_one_closed schroeder_4_p mult_assoc)
       hence "d * (- 1 \<sqinter> H) * d\<^sup>T \<le> - H"
         by (metis assms(1) forest_modulo_equivalence_def conv_dist_comp schroeder_3_p triple_schroeder_p)
       hence "H \<sqinter> d * (- 1 \<sqinter> H) * d\<^sup>T \<le> 1"
         by (metis inf.coboundedI1 p_antitone_iff p_shunting_swap regular_one_closed)
       hence "H \<sqinter> d * d\<^sup>T \<squnion> H \<sqinter> d * (- 1 \<sqinter> H) * d\<^sup>T \<le> 1"
         using assms(1) forest_modulo_equivalence_def le_supI by blast
       hence "H \<sqinter> (d * 1 * d\<^sup>T \<squnion> d * (- 1 \<sqinter> H) * d\<^sup>T) \<le> 1"
         using comp_inf.semiring.distrib_left by auto
       hence "H \<sqinter> (d * (1 \<squnion> (- 1 \<sqinter> H)) * d\<^sup>T) \<le> 1"
         by (simp add: mult_left_dist_sup mult_right_dist_sup)
       hence 514: "H \<sqinter> d * H * d\<^sup>T \<le> 1"
         by (metis assms(1) forest_modulo_equivalence_def comp_inf.semiring.distrib_left inf.le_iff_sup inf.sup_monoid.add_commute inf_top_right regular_one_closed stone)
       thus ?thesis
       proof -
         have "H \<sqinter> d * H * d\<^sup>T \<squnion> H * d * H * (d * H)\<^sup>\<star> \<sqinter> d * H * d\<^sup>T \<le> 1"
           using 513 514 by simp
         hence "d * H * d\<^sup>T \<sqinter> (H \<squnion> H * d * H * (d * H)\<^sup>\<star>) \<le> 1"
           by (simp add: comp_inf.semiring.distrib_left inf.sup_monoid.add_commute)
         hence "d * H * d\<^sup>T \<sqinter> H * (1 \<squnion> d * H * (d * H)\<^sup>\<star>) \<le> 1"
           by (simp add: mult_left_dist_sup mult_assoc)
         thus ?thesis
           by (simp add: inf.sup_monoid.add_commute star_left_unfold_equal)
       qed
     qed
     have "?x * top * ?x\<^sup>T = (d \<sqinter> top * e\<^sup>T * H \<sqinter> (H * d\<^sup>T)\<^sup>\<star> * H * a\<^sup>T * top) * top * (d\<^sup>T \<sqinter> H\<^sup>T * e\<^sup>T\<^sup>T * top\<^sup>T \<sqinter> top\<^sup>T * a\<^sup>T\<^sup>T * H\<^sup>T * (d\<^sup>T\<^sup>T * H\<^sup>T)\<^sup>\<star>)"
       by (simp add: conv_dist_comp conv_dist_inf conv_star_commute mult_assoc)
     also have "... = (d \<sqinter> top * e\<^sup>T * H \<sqinter> (H * d\<^sup>T)\<^sup>\<star> * H * a\<^sup>T * top) * top * (d\<^sup>T \<sqinter> H * e * top \<sqinter> top * a * H * (d * H)\<^sup>\<star>)"
       using assms(1) forest_modulo_equivalence_def by auto
     also have "... = (H * d\<^sup>T)\<^sup>\<star> * H * a\<^sup>T * top \<sqinter> (d \<sqinter> top * e\<^sup>T * H) * top * (d\<^sup>T \<sqinter> H * e * top \<sqinter> top * a * H * (d * H)\<^sup>\<star>)"
       by (metis inf_vector_comp vector_export_comp)
     also have "... = (H * d\<^sup>T)\<^sup>\<star> * H * a\<^sup>T * top \<sqinter> (d \<sqinter> top * e\<^sup>T * H) * top * top * (d\<^sup>T \<sqinter> H * e * top \<sqinter> top * a * H * (d * H)\<^sup>\<star>)"
       by (simp add: vector_mult_closed)
     also have "... = (H * d\<^sup>T)\<^sup>\<star> * H * a\<^sup>T * top \<sqinter> d * ((top * e\<^sup>T * H)\<^sup>T \<sqinter> top) * top * (d\<^sup>T \<sqinter> H * e * top \<sqinter> top * a * H * (d * H)\<^sup>\<star>)"
       by (simp add: covector_comp_inf_1 covector_mult_closed)
     also have "... = (H * d\<^sup>T)\<^sup>\<star> * H * a\<^sup>T * top \<sqinter> d * ((top * e\<^sup>T * H)\<^sup>T \<sqinter> (H * e * top)\<^sup>T) * d\<^sup>T \<sqinter> top * a * H * (d * H)\<^sup>\<star>"
       by (smt comp_associative comp_inf.star_star_absorb comp_inf_vector conv_star_commute covector_comp_inf covector_conv_vector fc_top star.circ_top total_conv_surjective vector_conv_covector vector_inf_comp)
     also have "... = (H * d\<^sup>T)\<^sup>\<star> * H * a\<^sup>T * top \<sqinter> top * a * H * (d * H)\<^sup>\<star> \<sqinter> d * ((top * e\<^sup>T * H)\<^sup>T \<sqinter> (H * e * top)\<^sup>T) * d\<^sup>T"
       using inf.sup_monoid.add_assoc inf.sup_monoid.add_commute by auto
     also have "... = (H * d\<^sup>T)\<^sup>\<star> * H * a\<^sup>T * top * top * a * H * (d * H)\<^sup>\<star> \<sqinter> d * ((top * e\<^sup>T * H)\<^sup>T \<sqinter> (H * e * top)\<^sup>T) * d\<^sup>T"
       by (smt comp_inf.star.circ_decompose_9 comp_inf.star_star_absorb comp_inf_covector fc_top star.circ_decompose_11 star.circ_top vector_export_comp)
     also have "... = (H * d\<^sup>T)\<^sup>\<star> * H * a\<^sup>T * top * a * H * (d * H)\<^sup>\<star> \<sqinter> d * (H * e * top \<sqinter> top * e\<^sup>T * H) * d\<^sup>T"
       using assms(1) forest_modulo_equivalence_def conv_dist_comp mult_assoc by auto
     also have "... = (H * d\<^sup>T)\<^sup>\<star> * H * a\<^sup>T * top * a * H * (d * H)\<^sup>\<star> \<sqinter> d * H * e * top * e\<^sup>T * H * d\<^sup>T"
       by (metis comp_inf_covector inf_top.left_neutral mult_assoc)
     also have "... \<le> (H * d\<^sup>T)\<^sup>\<star> * (H * d)\<^sup>\<star> * H \<sqinter> d * H * e * top * e\<^sup>T * H * d\<^sup>T"
     proof -
       have "(H * d\<^sup>T)\<^sup>\<star> * H * a\<^sup>T * top * a * H * (d * H)\<^sup>\<star> \<le> (H * d\<^sup>T)\<^sup>\<star> * H * 1 * H * (d * H)\<^sup>\<star>"
         using 2 by (metis comp_associative comp_isotone mult_left_isotone mult_semi_associative star.circ_transitive_equal)
       also have "... = (H * d\<^sup>T)\<^sup>\<star> * H * (d * H)\<^sup>\<star>"
         using assms(1) forest_modulo_equivalence_def mult.semigroup_axioms preorder_idempotent semigroup.assoc by fastforce
       also have "... = (H * d\<^sup>T)\<^sup>\<star> * (H * d)\<^sup>\<star> * H"
         by (metis star_slide mult_assoc)
       finally show ?thesis
         using inf.sup_left_isotone by auto
     qed
     also have "... \<le> (H * d\<^sup>T)\<^sup>\<star> * (H * d)\<^sup>\<star> * H \<sqinter> d * H * d\<^sup>T"
     proof -
       have "d * H * e * top * e\<^sup>T * H * d\<^sup>T \<le> d * H * 1 * H * d\<^sup>T"
         using 3 by (metis comp_isotone idempotent_one_closed mult_left_isotone mult_sub_right_one mult_assoc)
       also have "... \<le> d * H * d\<^sup>T"
         by (metis assms(1) forest_modulo_equivalence_def mult_left_isotone mult_one_associative mult_semi_associative preorder_idempotent)
       finally show ?thesis
         using inf.sup_right_isotone by auto
     qed
     also have "... = H * (d\<^sup>T * H)\<^sup>\<star> * (H * d)\<^sup>\<star> * H \<sqinter> d * H * d\<^sup>T"
       by (metis assms(1) forest_modulo_equivalence_def comp_associative preorder_idempotent star_slide)
     also have "... = H * ((d\<^sup>T * H)\<^sup>\<star> \<squnion> (H * d)\<^sup>\<star>) * H \<sqinter> d * H * d\<^sup>T"
       by (simp add: assms(1) expand_forest_modulo_equivalence mult.semigroup_axioms semigroup.assoc)
     also have "... = (H * (d\<^sup>T * H)\<^sup>\<star> * H \<squnion> H * (H * d)\<^sup>\<star> * H) \<sqinter> d * H * d\<^sup>T"
       by (simp add: mult_left_dist_sup mult_right_dist_sup)
     also have "... = (H * d\<^sup>T)\<^sup>\<star> * H \<sqinter> d * H * d\<^sup>T \<squnion> H * (d * H)\<^sup>\<star> \<sqinter> d * H * d\<^sup>T"
       by (smt assms(1) forest_modulo_equivalence_def inf_sup_distrib2 mult.semigroup_axioms preorder_idempotent star_slide semigroup.assoc)
     also have "... \<le> (H * d\<^sup>T)\<^sup>\<star> * H \<sqinter> d * H * d\<^sup>T \<squnion> 1"
       using 51 comp_inf.semiring.add_left_mono by blast
     finally have "?x * top * ?x\<^sup>T \<le> 1"
       using 51 by (smt assms(1) forest_modulo_equivalence_def conv_dist_comp conv_dist_inf conv_dist_sup conv_involutive conv_star_commute equivalence_one_closed mult.semigroup_axioms sup.absorb2 semigroup.assoc conv_isotone conv_order)
     thus ?thesis
       by simp
   qed
   have 6: "?x\<^sup>T * top * ?x \<le> 1"
   proof -
     have "?x\<^sup>T * top * ?x = (d\<^sup>T \<sqinter> H\<^sup>T * e\<^sup>T\<^sup>T * top\<^sup>T \<sqinter> top\<^sup>T * a\<^sup>T\<^sup>T * H\<^sup>T * (d\<^sup>T\<^sup>T * H\<^sup>T)\<^sup>\<star>) * top * (d \<sqinter> top * e\<^sup>T * H \<sqinter> (H * d\<^sup>T)\<^sup>\<star> * H * a\<^sup>T * top)"
       by (simp add: conv_dist_comp conv_dist_inf conv_star_commute mult_assoc)
     also have "... = (d\<^sup>T \<sqinter> H * e * top \<sqinter> top * a * H * (d * H)\<^sup>\<star>) * top * (d \<sqinter> top * e\<^sup>T * H \<sqinter> (H * d\<^sup>T)\<^sup>\<star> * H * a\<^sup>T * top)"
       using assms(1) forest_modulo_equivalence_def by auto
     also have "... = H * e * top \<sqinter> (d\<^sup>T \<sqinter> top * a * H * (d * H)\<^sup>\<star>) * top * (d \<sqinter> top * e\<^sup>T * H \<sqinter> (H * d\<^sup>T)\<^sup>\<star> * H * a\<^sup>T * top)"
       by (smt comp_associative inf.sup_monoid.add_assoc inf.sup_monoid.add_commute star.circ_left_top star.circ_top vector_inf_comp)
     also have "... = H * e * top \<sqinter> d\<^sup>T * ((top * a * H * (d * H)\<^sup>\<star>)\<^sup>T \<sqinter> top) * (d \<sqinter> top * e\<^sup>T * H \<sqinter> (H * d\<^sup>T)\<^sup>\<star> * H * a\<^sup>T * top)"
       by (simp add: covector_comp_inf_1 covector_mult_closed)
     also have "... = H * e * top \<sqinter> d\<^sup>T * (d * H)\<^sup>\<star>\<^sup>T * H * a\<^sup>T * top * (d \<sqinter> top * e\<^sup>T * H \<sqinter> (H * d\<^sup>T)\<^sup>\<star> * H * a\<^sup>T * top)"
       using assms(1) forest_modulo_equivalence_def comp_associative conv_dist_comp by auto
     also have "... = H * e * top \<sqinter> d\<^sup>T * (d * H)\<^sup>\<star>\<^sup>T * H * a\<^sup>T * top * (d \<sqinter> (H * d\<^sup>T)\<^sup>\<star> * H * a\<^sup>T * top) \<sqinter> top * e\<^sup>T * H"
       by (smt comp_associative comp_inf_covector inf.sup_monoid.add_assoc inf.sup_monoid.add_commute)
     also have "... = H * e * top \<sqinter> d\<^sup>T * (d * H)\<^sup>\<star>\<^sup>T * H * a\<^sup>T * (top \<sqinter> ((H * d\<^sup>T)\<^sup>\<star> * H * a\<^sup>T * top)\<^sup>T) * d \<sqinter> top * e\<^sup>T * H"
       by (metis comp_associative comp_inf_vector vector_conv_covector vector_top_closed)
     also have "... = H * e * top \<sqinter> (H * e * top)\<^sup>T \<sqinter> d\<^sup>T * (d * H)\<^sup>\<star>\<^sup>T * H * a\<^sup>T * ((H * d\<^sup>T)\<^sup>\<star> * H * a\<^sup>T * top)\<^sup>T * d"
       by (smt assms(1) forest_modulo_equivalence_def conv_dist_comp inf.left_commute inf.sup_monoid.add_commute symmetric_top_closed mult_assoc inf_top.left_neutral)
     also have "... = H * e * top * (H * e * top)\<^sup>T \<sqinter> d\<^sup>T * (d * H)\<^sup>\<star>\<^sup>T * H * a\<^sup>T * ((H * d\<^sup>T)\<^sup>\<star> * H * a\<^sup>T * top)\<^sup>T * d"
       using vector_covector vector_mult_closed by auto
     also have "... = H * e * top * top\<^sup>T * e\<^sup>T * H\<^sup>T \<sqinter> d\<^sup>T * (d * H)\<^sup>\<star>\<^sup>T * H * a\<^sup>T * top\<^sup>T * a\<^sup>T\<^sup>T * H\<^sup>T * (H * d\<^sup>T)\<^sup>\<star>\<^sup>T * d"
       by (smt conv_dist_comp mult.semigroup_axioms symmetric_top_closed semigroup.assoc)
     also have "... = H * e * top * top * e\<^sup>T * H \<sqinter> d\<^sup>T * (H * d\<^sup>T)\<^sup>\<star> * H * a\<^sup>T * top * a * H * (d * H)\<^sup>\<star> * d"
       using assms(1) forest_modulo_equivalence_def conv_dist_comp conv_star_commute by auto
     also have "... = H * e * top * e\<^sup>T * H \<sqinter> d\<^sup>T * (H * d\<^sup>T)\<^sup>\<star> * H * a\<^sup>T * top * a * H * (d * H)\<^sup>\<star> * d"
       using vector_top_closed mult_assoc by auto
     also have "... \<le> H \<sqinter> d\<^sup>T * (H * d\<^sup>T)\<^sup>\<star> * H * (d * H)\<^sup>\<star> * d"
     proof -
       have "H * e * top * e\<^sup>T * H \<le> H * 1 * H"
         using 3 by (metis comp_associative mult_left_isotone mult_right_isotone)
       also have "... = H"
         using assms(1) forest_modulo_equivalence_def preorder_idempotent by auto
       finally have 611: "H * e * top * e\<^sup>T * H \<le> H"
         by simp
       have "d\<^sup>T * (H * d\<^sup>T)\<^sup>\<star> * H * a\<^sup>T * top * a * H * (d * H)\<^sup>\<star> * d \<le> d\<^sup>T * (H * d\<^sup>T)\<^sup>\<star> * H * 1 * H * (d * H)\<^sup>\<star> * d"
         using 2 by (metis comp_associative mult_left_isotone mult_right_isotone)
       also have "... = d\<^sup>T * (H * d\<^sup>T)\<^sup>\<star> * H * (d * H)\<^sup>\<star> * d"
         using assms(1) forest_modulo_equivalence_def mult.semigroup_axioms preorder_idempotent semigroup.assoc by fastforce
       finally have "d\<^sup>T * (H * d\<^sup>T)\<^sup>\<star> * H * a\<^sup>T * top * a * H * (d * H)\<^sup>\<star> * d \<le> d\<^sup>T * (H * d\<^sup>T)\<^sup>\<star> * H * (d * H)\<^sup>\<star> * d"
         by simp
       thus ?thesis
         using 611 comp_inf.comp_isotone by blast
     qed
     also have "... = H \<sqinter> (d\<^sup>T * H)\<^sup>\<star> * d\<^sup>T * H * d * (H * d)\<^sup>\<star>"
       using star_slide mult_assoc by auto
     also have "... \<le> H \<sqinter> (d\<^sup>T * H)\<^sup>\<star> * (H * d)\<^sup>\<star>"
     proof -
       have "(d\<^sup>T * H)\<^sup>\<star> * d\<^sup>T * H * d * (H * d)\<^sup>\<star> \<le> (d\<^sup>T * H)\<^sup>\<star> * 1 * (H * d)\<^sup>\<star>"
         by (smt assms(1) forest_modulo_equivalence_def conv_dist_comp mult_left_isotone mult_right_isotone preorder_idempotent mult_assoc)
       also have "... = (d\<^sup>T * H)\<^sup>\<star> * (H * d)\<^sup>\<star>"
         by simp
       finally show ?thesis
         using inf.sup_right_isotone by blast
     qed
     also have "... = H \<sqinter> ((d\<^sup>T * H)\<^sup>\<star> \<squnion> (H * d)\<^sup>\<star>)"
       by (simp add: assms(1) expand_forest_modulo_equivalence)
     also have "... = H \<sqinter> (d\<^sup>T * H)\<^sup>\<star> \<squnion> H \<sqinter> (H * d)\<^sup>\<star>"
       by (simp add: comp_inf.semiring.distrib_left)
     also have "... = 1 \<squnion> H \<sqinter> (d\<^sup>T * H)\<^sup>+ \<squnion> H \<sqinter> (H * d)\<^sup>+"
     proof -
       have 612: "H \<sqinter> (H * d)\<^sup>\<star> = 1 \<squnion> H \<sqinter> (H * d)\<^sup>+"
         using assms(1) forest_modulo_equivalence_def reflexive_inf_star by blast
       have "H \<sqinter> (d\<^sup>T * H)\<^sup>\<star> = 1 \<squnion> H \<sqinter> (d\<^sup>T * H)\<^sup>+"
         using assms(1) forest_modulo_equivalence_def reflexive_inf_star by auto
       thus ?thesis
         using 612 sup_assoc sup_commute by auto
     qed
     also have "... \<le> 1"
     proof -
       have 613: "H \<sqinter> (H * d)\<^sup>+ \<le> 1"
         by (metis assms(3) inf.coboundedI1 p_antitone_iff p_shunting_swap regular_one_closed)
       hence "H \<sqinter> (d\<^sup>T * H)\<^sup>+ \<le> 1"
         by (metis assms(1) forest_modulo_equivalence_def conv_dist_comp conv_dist_inf conv_plus_commute coreflexive_symmetric)
       thus ?thesis
         by (simp add: 613)
     qed
     finally show ?thesis
       by simp
   qed
   have 7:"bijective (?x * top)"
     using 4 5 6 arc_expanded by blast
   have "bijective (?x\<^sup>T * top)"
     using 4 5 6 arc_expanded by blast
   thus ?thesis
     using 7 by simp
 qed
 
 text \<open>
 To maintain that $f$ can be extended to a minimum spanning forest we identify an edge, $i = v \sqcap \overline{F}e\top \sqcap \top e^\top F$, that may be exchanged with the \<open>selected_edge\<close>, $e$.
 Here, we show that $i$ is an \<open>arc\<close>.
 \<close>
 
 lemma boruvka_edge_arc:
   assumes "equivalence F"
     and "forest v"
     and "arc e"
     and "regular F"
     and "F \<le> forest_components (F \<sqinter> v)"
     and "regular v"
     and "v * e\<^sup>T = bot"
     and "e * F * e = bot"
     and "e\<^sup>T \<le> v\<^sup>\<star>"
     and "e \<noteq> bot"
   shows "arc (v \<sqinter> -F * e * top \<sqinter> top * e\<^sup>T * F)"
 proof -
   let ?i = "v \<sqinter> -F * e * top \<sqinter> top * e\<^sup>T * F"
   have 1: "?i\<^sup>T * top * ?i \<le> 1"
   proof -
     have "?i\<^sup>T * top * ?i = (v\<^sup>T \<sqinter> top * e\<^sup>T * -F \<sqinter> F * e * top) * top * (v \<sqinter> -F * e * top \<sqinter> top * e\<^sup>T * F)"
       using assms(1) conv_complement conv_dist_comp conv_dist_inf mult.semigroup_axioms semigroup.assoc by fastforce
     also have "... = F * e * top \<sqinter> (v\<^sup>T \<sqinter> top * e\<^sup>T * -F) * top * (v \<sqinter> -F * e * top) \<sqinter> top * e\<^sup>T * F"
       by (smt covector_comp_inf covector_mult_closed inf_vector_comp vector_export_comp vector_top_closed)
     also have "... = F * e * top \<sqinter> (v\<^sup>T \<sqinter> top * e\<^sup>T * -F) * top * top * (v \<sqinter> -F * e * top) \<sqinter> top * e\<^sup>T * F"
       by (simp add: comp_associative)
     also have "... = F * e * top \<sqinter> v\<^sup>T * (top \<sqinter> (top * e\<^sup>T * -F)\<^sup>T) * top * (v \<sqinter> -F * e * top) \<sqinter> top * e\<^sup>T * F"
       using comp_associative comp_inf_vector_1 by auto
     also have "... = F * e * top \<sqinter> v\<^sup>T * (top \<sqinter> (top * e\<^sup>T * -F)\<^sup>T) * (top \<sqinter> (-F * e * top)\<^sup>T) * v \<sqinter> top * e\<^sup>T * F"
       by (smt comp_inf_vector conv_dist_comp mult.semigroup_axioms symmetric_top_closed semigroup.assoc)
     also have "... = F * e * top \<sqinter> v\<^sup>T * (top * e\<^sup>T * -F)\<^sup>T * (-F * e * top)\<^sup>T * v \<sqinter> top * e\<^sup>T * F"
       by simp
     also have "... = F * e * top \<sqinter> v\<^sup>T * -F\<^sup>T * e\<^sup>T\<^sup>T * top\<^sup>T * top\<^sup>T * e\<^sup>T * -F\<^sup>T * v \<sqinter> top * e\<^sup>T * F"
       by (metis comp_associative conv_complement conv_dist_comp)
     also have "... = F * e * top \<sqinter> v\<^sup>T * -F * e * top * top * e\<^sup>T * -F * v \<sqinter> top * e\<^sup>T * F"
       by (simp add: assms(1))
     also have "... = F * e * top \<sqinter> v\<^sup>T * -F * e * top \<sqinter> top * e\<^sup>T * -F * v \<sqinter> top * e\<^sup>T * F"
       by (metis comp_associative comp_inf_covector inf.sup_monoid.add_assoc inf_top.left_neutral vector_top_closed)
     also have "... = (F \<sqinter> v\<^sup>T * -F) * e * top \<sqinter> top * e\<^sup>T * -F * v \<sqinter> top * e\<^sup>T * F"
       using assms(3) injective_comp_right_dist_inf mult_assoc by auto
     also have "... = (F \<sqinter> v\<^sup>T * -F) * e * top \<sqinter> top * e\<^sup>T * (F \<sqinter> -F * v)"
       using assms(3) conv_dist_comp inf.sup_monoid.add_assoc inf.sup_monoid.add_commute mult.semigroup_axioms univalent_comp_left_dist_inf semigroup.assoc by fastforce
     also have "... = (F \<sqinter> v\<^sup>T * -F) * e * top * top * e\<^sup>T * (F \<sqinter> -F * v)"
       by (metis comp_associative comp_inf_covector inf_top.left_neutral vector_top_closed)
     also have "... = (F \<sqinter> v\<^sup>T * -F) * e * top * e\<^sup>T * (F \<sqinter> -F * v)"
       by (simp add: comp_associative)
     also have "... \<le> (F \<sqinter> v\<^sup>T * -F) * (F \<sqinter> -F * v)"
       by (smt assms(3) conv_dist_comp mult_left_isotone shunt_bijective symmetric_top_closed top_right_mult_increasing mult_assoc)
     also have "... \<le> (F \<sqinter> v\<^sup>T * -F) * (F \<sqinter> -F * v) \<sqinter> F"
       by (metis assms(1) inf.absorb1 inf.cobounded1 mult_isotone preorder_idempotent)
     also have "... \<le> (F \<sqinter> v\<^sup>T * -F) * (F \<sqinter> -F * v) \<sqinter> (F \<sqinter> v)\<^sup>T\<^sup>\<star> * (F \<sqinter> v)\<^sup>\<star>"
       using assms(5) comp_inf.mult_right_isotone by auto
     also have "... \<le> (-F \<sqinter> v\<^sup>T) * -F * -F * (-F \<sqinter> v) \<sqinter> (F \<sqinter> v)\<^sup>T\<^sup>\<star> * (F \<sqinter> v)\<^sup>\<star>"
     proof -
       have "F \<sqinter> v\<^sup>T * -F \<le> (v\<^sup>T \<sqinter> F * -F\<^sup>T) * -F"
         by (metis conv_complement dedekind_2 inf_commute)
       also have "... = (v\<^sup>T \<sqinter> -F\<^sup>T) * -F"
         using assms(1) equivalence_comp_left_complement by simp
       finally have "F \<sqinter> v\<^sup>T * -F \<le> F \<sqinter> (v\<^sup>T \<sqinter> -F) * -F"
         using assms(1) by auto
       hence 11: "F \<sqinter> v\<^sup>T * -F = F \<sqinter> (-F \<sqinter> v\<^sup>T) * -F"
         by (metis inf.antisym_conv inf.sup_monoid.add_commute comp_left_subdist_inf inf.boundedE inf.sup_right_isotone)
       hence "F\<^sup>T \<sqinter> -F\<^sup>T * v\<^sup>T\<^sup>T = F\<^sup>T \<sqinter> -F\<^sup>T * (-F\<^sup>T \<sqinter> v\<^sup>T\<^sup>T)"
         by (metis (full_types) assms(1) conv_complement conv_dist_comp conv_dist_inf)
       hence 12: "F \<sqinter> -F * v = F \<sqinter> -F * (-F \<sqinter> v)"
         using assms(1) by (simp add: abel_semigroup.commute inf.abel_semigroup_axioms)
       have "(F \<sqinter> v\<^sup>T * -F) * (F \<sqinter> -F * v) = (F \<sqinter> (-F \<sqinter> v\<^sup>T) * -F) * (F \<sqinter> -F * (-F \<sqinter> v))"
         using 11 12 by auto
       also have "... \<le> (-F \<sqinter> v\<^sup>T) * -F * -F * (-F \<sqinter> v)"
         by (metis comp_associative comp_isotone inf.cobounded2)
       finally show ?thesis
         using comp_inf.mult_left_isotone by blast
     qed
     also have "... = ((-F \<sqinter> v\<^sup>T) * -F * -F * (-F \<sqinter> v) \<sqinter> (F \<sqinter> v)\<^sup>T * (F \<sqinter> v)\<^sup>T\<^sup>\<star> * (F \<sqinter> v)\<^sup>\<star>) \<squnion> ((-F \<sqinter> v\<^sup>T) * -F * -F * (-F \<sqinter> v) \<sqinter> (F \<sqinter> v)\<^sup>\<star>)"
       by (metis comp_associative inf_sup_distrib1 star.circ_loop_fixpoint)
     also have "... = ((-F \<sqinter> v\<^sup>T) * -F * -F * (-F \<sqinter> v) \<sqinter> (F \<sqinter> v\<^sup>T) * (F \<sqinter> v)\<^sup>T\<^sup>\<star> * (F \<sqinter> v)\<^sup>\<star>) \<squnion> ((-F \<sqinter> v\<^sup>T) * -F * -F * (-F \<sqinter> v) \<sqinter> (F \<sqinter> v)\<^sup>\<star>)"
       using assms(1) conv_dist_inf by auto
     also have "... = bot \<squnion> ((-F \<sqinter> v\<^sup>T) * -F * -F * (-F \<sqinter> v) \<sqinter> (F \<sqinter> v)\<^sup>\<star>)"
     proof -
       have "(-F \<sqinter> v\<^sup>T) * -F * -F * (-F \<sqinter> v) \<sqinter> (F \<sqinter> v\<^sup>T) * (F \<sqinter> v)\<^sup>T\<^sup>\<star> * (F \<sqinter> v)\<^sup>\<star> \<le> bot"
         using assms(1, 2) forests_bot_2 by (simp add: comp_associative)
       thus ?thesis
         using le_bot by blast
     qed
     also have "... = (-F \<sqinter> v\<^sup>T) * -F * -F * (-F \<sqinter> v) \<sqinter> (1 \<squnion> (F \<sqinter> v)\<^sup>\<star> * (F \<sqinter> v))"
       by (simp add: star.circ_plus_same star_left_unfold_equal)
     also have "... = ((-F \<sqinter> v\<^sup>T) * -F * -F * (-F \<sqinter> v) \<sqinter> 1) \<squnion> ((-F \<sqinter> v\<^sup>T) * -F * -F * (-F \<sqinter> v) \<sqinter> (F \<sqinter> v)\<^sup>\<star> * (F \<sqinter> v))"
       by (simp add: comp_inf.semiring.distrib_left)
     also have "... \<le> 1 \<squnion> ((-F \<sqinter> v\<^sup>T) * -F * -F * (-F \<sqinter> v) \<sqinter> (F \<sqinter> v)\<^sup>\<star> * (F \<sqinter> v))"
       using sup_left_isotone by auto
     also have "... \<le> 1 \<squnion> bot"
       using assms(1, 2) forests_bot_3 comp_inf.semiring.add_left_mono by simp
     finally show ?thesis
       by simp
   qed
   have 2: "?i * top * ?i\<^sup>T \<le> 1"
   proof -
     have "?i * top * ?i\<^sup>T = (v \<sqinter> -F * e * top \<sqinter> top * e\<^sup>T * F) * top * (v\<^sup>T \<sqinter> (-F * e * top)\<^sup>T \<sqinter> (top * e\<^sup>T * F)\<^sup>T)"
       by (simp add: conv_dist_inf)
     also have "... = (v \<sqinter> -F * e * top \<sqinter> top * e\<^sup>T * F) * top * (v\<^sup>T \<sqinter> top\<^sup>T * e\<^sup>T * -F\<^sup>T \<sqinter> F\<^sup>T * e\<^sup>T\<^sup>T * top\<^sup>T)"
       by (simp add: conv_complement conv_dist_comp mult_assoc)
     also have "... = (v \<sqinter> -F * e * top \<sqinter> top * e\<^sup>T * F) * top * (v\<^sup>T \<sqinter> top * e\<^sup>T * -F \<sqinter> F * e * top)"
       by (simp add: assms(1))
     also have "... = -F * e * top \<sqinter> (v \<sqinter> top * e\<^sup>T * F) * top * (v\<^sup>T \<sqinter> top * e\<^sup>T * -F \<sqinter> F * e * top)"
       by (smt inf.left_commute inf.sup_monoid.add_assoc vector_export_comp)
     also have "... = -F * e * top \<sqinter> (v \<sqinter> top * e\<^sup>T * F) * top * (v\<^sup>T \<sqinter> F * e * top) \<sqinter> top * e\<^sup>T * -F"
       by (smt comp_inf_covector inf.sup_monoid.add_assoc inf.sup_monoid.add_commute mult_assoc)
     also have "... = -F * e * top \<sqinter> (v \<sqinter> top * e\<^sup>T * F) * top * top * (v\<^sup>T \<sqinter> F * e * top) \<sqinter> top * e\<^sup>T * -F"
       by (simp add: mult_assoc)
     also have "... = -F * e * top \<sqinter> v * ((top * e\<^sup>T * F)\<^sup>T \<sqinter> top) * top * (v\<^sup>T \<sqinter> F * e * top) \<sqinter> top * e\<^sup>T * -F"
       by (simp add: comp_inf_vector_1 mult.semigroup_axioms semigroup.assoc)
     also have "... = -F * e * top \<sqinter> v * ((top * e\<^sup>T * F)\<^sup>T \<sqinter> top) * (top \<sqinter> (F * e * top)\<^sup>T) * v\<^sup>T \<sqinter> top * e\<^sup>T * -F"
       by (smt comp_inf_vector covector_comp_inf vector_conv_covector vector_mult_closed vector_top_closed)
     also have "... = -F * e * top \<sqinter> v * (top * e\<^sup>T * F)\<^sup>T * (F * e * top)\<^sup>T * v\<^sup>T \<sqinter> top * e\<^sup>T * -F"
       by simp
     also have "... = -F * e * top \<sqinter> v * F\<^sup>T * e\<^sup>T\<^sup>T * top\<^sup>T * top\<^sup>T * e\<^sup>T * F\<^sup>T * v\<^sup>T \<sqinter> top * e\<^sup>T * -F"
       by (metis comp_associative conv_dist_comp)
     also have "... = -F * e * top \<sqinter> v * F * e * top * top * e\<^sup>T * F * v\<^sup>T \<sqinter> top * e\<^sup>T * -F"
       using assms(1) by auto
     also have "... = -F * e * top \<sqinter> v * F * e * top \<sqinter> top * e\<^sup>T * F * v\<^sup>T \<sqinter> top * e\<^sup>T * -F"
       by (smt comp_associative comp_inf_covector inf.sup_monoid.add_assoc inf_top.left_neutral vector_top_closed)
     also have "... = (-F \<sqinter> v * F) * e * top \<sqinter> top * e\<^sup>T * F * v\<^sup>T \<sqinter> top * e\<^sup>T * -F"
       using injective_comp_right_dist_inf assms(3) mult.semigroup_axioms semigroup.assoc by fastforce
     also have "... = (-F \<sqinter> v * F) * e * top \<sqinter> top * e\<^sup>T * (F * v\<^sup>T \<sqinter> -F)"
       using injective_comp_right_dist_inf assms(3) conv_dist_comp inf.sup_monoid.add_assoc mult.semigroup_axioms univalent_comp_left_dist_inf semigroup.assoc by fastforce
     also have "... = (-F \<sqinter> v * F) * e * top * top * e\<^sup>T * (F * v\<^sup>T \<sqinter> -F)"
       by (metis inf_top_right vector_export_comp vector_top_closed)
     also have "... = (-F \<sqinter> v * F) * e * top * e\<^sup>T * (F * v\<^sup>T \<sqinter> -F)"
       by (simp add: comp_associative)
     also have "... \<le> (-F \<sqinter> v * F) * (F * v\<^sup>T \<sqinter> -F)"
       by (smt assms(3) conv_dist_comp mult.semigroup_axioms mult_left_isotone shunt_bijective symmetric_top_closed top_right_mult_increasing semigroup.assoc)
     also have "... = (-F \<sqinter> v * F) * ((v * F)\<^sup>T \<sqinter> -F)"
       by (simp add: assms(1) conv_dist_comp)
     also have "... = (-F \<sqinter> v * F) * (-F \<sqinter> v * F)\<^sup>T"
       using assms(1) conv_complement conv_dist_inf by (simp add: inf.sup_monoid.add_commute)
     also have "... \<le> (-F \<sqinter> v) * (F \<sqinter> v)\<^sup>\<star> * (F \<sqinter> v)\<^sup>T\<^sup>\<star> * (-F \<sqinter> v)\<^sup>T"
     proof -
       let ?Fv = "F \<sqinter> v"
       have "-F \<sqinter> v * F \<le> -F \<sqinter> v * (F \<sqinter> v)\<^sup>T\<^sup>\<star> * (F \<sqinter> v)\<^sup>\<star>"
         using assms(5) inf.sup_right_isotone mult_right_isotone comp_associative by auto
       also have "... \<le> -F \<sqinter> v * (F \<sqinter> v)\<^sup>\<star>"
       proof -
         have "v * v\<^sup>T \<le> 1"
           by (simp add: assms(2))
         hence "v * v\<^sup>T * F \<le> F"
           using assms(1) dual_order.trans mult_left_isotone by blast
         hence "v * v\<^sup>T * F\<^sup>T\<^sup>\<star> * F\<^sup>\<star> \<le> F"
           by (metis assms(1) mult_1_right preorder_idempotent star.circ_sup_one_right_unfold star.circ_transitive_equal star_one star_simulation_right_equal mult_assoc)
         hence "v * (F \<sqinter> v)\<^sup>T * F\<^sup>T\<^sup>\<star> * F\<^sup>\<star> \<le> F"
           by (meson conv_isotone dual_order.trans inf.cobounded2 inf.sup_monoid.add_commute mult_left_isotone mult_right_isotone)
         hence "v * (F \<sqinter> v)\<^sup>T * (F \<sqinter> v)\<^sup>T\<^sup>\<star> * (F \<sqinter> v)\<^sup>\<star> \<le> F"
           by (meson conv_isotone dual_order.trans inf.cobounded2 inf.sup_monoid.add_commute mult_left_isotone mult_right_isotone comp_isotone conv_dist_inf inf.cobounded1 star_isotone)
         hence "-F \<sqinter> v * (F \<sqinter> v)\<^sup>T * (F \<sqinter> v)\<^sup>T\<^sup>\<star> * (F \<sqinter> v)\<^sup>\<star> \<le> bot"
           using order.eq_iff p_antitone pseudo_complement by auto
         hence "(-F \<sqinter> v * (F \<sqinter> v)\<^sup>T * (F \<sqinter> v)\<^sup>T\<^sup>\<star> * (F \<sqinter> v)\<^sup>\<star>) \<squnion> v * (v \<sqinter> F)\<^sup>\<star> \<le> v * (v \<sqinter> F)\<^sup>\<star>"
           using bot_least le_bot by fastforce
         hence "(-F \<squnion> v * (v \<sqinter> F)\<^sup>\<star>) \<sqinter> (v * (F \<sqinter> v)\<^sup>T * (F \<sqinter> v)\<^sup>T\<^sup>\<star> * (F \<sqinter> v)\<^sup>\<star> \<squnion> v * (v \<sqinter> F)\<^sup>\<star>) \<le> v * (v \<sqinter> F)\<^sup>\<star>"
           by (simp add: sup_inf_distrib2)
         hence "(-F \<squnion> v * (v \<sqinter> F)\<^sup>\<star>) \<sqinter> v * ((F \<sqinter> v)\<^sup>T * (F \<sqinter> v)\<^sup>T\<^sup>\<star> \<squnion> 1) * (v \<sqinter> F)\<^sup>\<star> \<le> v * (v \<sqinter> F)\<^sup>\<star>"
           by (simp add: inf.sup_monoid.add_commute mult.semigroup_axioms mult_left_dist_sup mult_right_dist_sup semigroup.assoc)
         hence "(-F \<squnion> v * (v \<sqinter> F)\<^sup>\<star>) \<sqinter> v * (F \<sqinter> v)\<^sup>T\<^sup>\<star> * (v \<sqinter> F)\<^sup>\<star> \<le> v * (v \<sqinter> F)\<^sup>\<star>"
           by (simp add: star_left_unfold_equal sup_commute)
         hence "-F \<sqinter> v * (F \<sqinter> v)\<^sup>T\<^sup>\<star> * (v \<sqinter> F)\<^sup>\<star> \<le> v * (v \<sqinter> F)\<^sup>\<star>"
           using comp_inf.mult_right_sub_dist_sup_left inf.order_lesseq_imp by blast
         thus ?thesis
           by (simp add: inf.sup_monoid.add_commute)
       qed
       also have "... \<le> (v \<sqinter> -F * (F \<sqinter> v)\<^sup>T\<^sup>\<star>) * (F \<sqinter> v)\<^sup>\<star>"
         by (metis dedekind_2 conv_star_commute inf.sup_monoid.add_commute)
       also have "... \<le> (v \<sqinter> -F * F\<^sup>T\<^sup>\<star>) * (F \<sqinter> v)\<^sup>\<star>"
         using conv_isotone inf.sup_right_isotone mult_left_isotone mult_right_isotone star_isotone by auto
       also have "... = (v \<sqinter> -F * F) * (F \<sqinter> v)\<^sup>\<star>"
         by (metis assms(1) equivalence_comp_right_complement mult_left_one star_one star_simulation_right_equal)
       also have "... = (-F \<sqinter> v) * (F \<sqinter> v)\<^sup>\<star>"
         using assms(1) equivalence_comp_right_complement inf.sup_monoid.add_commute by auto
       finally have "-F \<sqinter> v * F \<le> (-F \<sqinter> v) * (F \<sqinter> v)\<^sup>\<star>"
         by simp
       hence "(-F \<sqinter> v * F) * (-F \<sqinter> v * F)\<^sup>T \<le> (-F \<sqinter> v) * (F \<sqinter> v)\<^sup>\<star> * ((-F \<sqinter> v) * (F \<sqinter> v)\<^sup>\<star>)\<^sup>T"
         by (simp add: comp_isotone conv_isotone)
       also have "... = (-F \<sqinter> v) * (F \<sqinter> v)\<^sup>\<star> * (F \<sqinter> v)\<^sup>T\<^sup>\<star> * (-F \<sqinter> v)\<^sup>T"
         by (simp add: comp_associative conv_dist_comp conv_star_commute)
       finally show ?thesis
         by simp
     qed
     also have "... \<le> (-F \<sqinter> v) * ((F \<sqinter> v\<^sup>\<star>) \<squnion> (F \<sqinter> v\<^sup>T\<^sup>\<star>)) * (-F \<sqinter> v)\<^sup>T"
     proof -
       have "(F \<sqinter> v)\<^sup>\<star> * (F \<sqinter> v)\<^sup>T\<^sup>\<star> \<le> F\<^sup>\<star> * F\<^sup>T\<^sup>\<star>"
         using fc_isotone by auto
       also have "... \<le> F * F"
         by (metis assms(1) preorder_idempotent star.circ_sup_one_left_unfold star.circ_transitive_equal star_right_induct_mult)
       finally have 21: "(F \<sqinter> v)\<^sup>\<star> * (F \<sqinter> v)\<^sup>T\<^sup>\<star> \<le> F"
         using assms(1) dual_order.trans by blast
       have "(F \<sqinter> v)\<^sup>\<star> * (F \<sqinter> v)\<^sup>T\<^sup>\<star> \<le> v\<^sup>\<star> * v\<^sup>T\<^sup>\<star>"
         by (simp add: fc_isotone)
       hence "(F \<sqinter> v)\<^sup>\<star> * (F \<sqinter> v)\<^sup>T\<^sup>\<star> \<le> F \<sqinter> v\<^sup>\<star> * v\<^sup>T\<^sup>\<star>"
         using 21 by simp
       also have "... = F \<sqinter> (v\<^sup>\<star> \<squnion> v\<^sup>T\<^sup>\<star>)"
         by (simp add: assms(2) cancel_separate_eq)
       finally show ?thesis
         by (metis assms(4, 6) comp_associative comp_inf.semiring.distrib_left comp_isotone inf_pp_semi_commute mult_left_isotone regular_closed_inf)
     qed
     also have "... \<le> (-F \<sqinter> v) * (F \<sqinter> v\<^sup>T\<^sup>\<star>) * (-F \<sqinter> v)\<^sup>T \<squnion> (-F \<sqinter> v) * (F \<sqinter> v\<^sup>\<star>) * (-F \<sqinter> v)\<^sup>T"
       by (simp add: mult_left_dist_sup mult_right_dist_sup)
     also have "... \<le> (-F \<sqinter> v) * (-F \<sqinter> v)\<^sup>T \<squnion> (-F \<sqinter> v) * (-F \<sqinter> v)\<^sup>T"
     proof -
       have "(-F \<sqinter> v) * (F \<sqinter> v\<^sup>T\<^sup>\<star>) \<le> (-F \<sqinter> v) * ((F \<sqinter> v)\<^sup>T\<^sup>\<star> * (F \<sqinter> v)\<^sup>\<star> \<sqinter> v\<^sup>T\<^sup>\<star>)"
         by (simp add: assms(5) inf.coboundedI1 mult_right_isotone)
       also have "... = (-F \<sqinter> v) * ((F \<sqinter> v)\<^sup>T * (F \<sqinter> v)\<^sup>T\<^sup>\<star> * (F \<sqinter> v)\<^sup>\<star> \<sqinter> v\<^sup>T\<^sup>\<star>) \<squnion> (-F \<sqinter> v) * ((F \<sqinter> v)\<^sup>\<star> \<sqinter> v\<^sup>T\<^sup>\<star>)"
         by (metis comp_associative comp_inf.mult_right_dist_sup mult_left_dist_sup star.circ_loop_fixpoint)
       also have "... \<le> (-F \<sqinter> v) * (F \<sqinter> v)\<^sup>T * top \<squnion> (-F \<sqinter> v) * ((F \<sqinter> v)\<^sup>\<star> \<sqinter> v\<^sup>T\<^sup>\<star>)"
         by (simp add: comp_associative comp_isotone inf.coboundedI2 inf.sup_monoid.add_commute le_supI1)
       also have "... \<le> (-F \<sqinter> v) * (F \<sqinter> v)\<^sup>T * top \<squnion> (-F \<sqinter> v) * (v\<^sup>\<star> \<sqinter> v\<^sup>T\<^sup>\<star>)"
         by (smt comp_inf.mult_right_isotone comp_inf.semiring.add_mono order.eq_iff inf.cobounded2 inf.sup_monoid.add_commute mult_right_isotone star_isotone)
       also have "... \<le> bot \<squnion> (-F \<sqinter> v) * (v\<^sup>\<star> \<sqinter> v\<^sup>T\<^sup>\<star>)"
         by (metis assms(1, 2) forests_bot_1 comp_associative comp_inf.semiring.add_right_mono mult_semi_associative vector_bot_closed)
       also have "... \<le> -F \<sqinter> v"
         by (simp add: assms(2) acyclic_star_inf_conv)
       finally have 22: "(-F \<sqinter> v) * (F \<sqinter> v\<^sup>T\<^sup>\<star>) \<le> -F \<sqinter> v"
         by simp
       have "((-F \<sqinter> v) * (F \<sqinter> v\<^sup>T\<^sup>\<star>))\<^sup>T = (F \<sqinter> v\<^sup>\<star>) * (-F \<sqinter> v)\<^sup>T"
         by (simp add: assms(1) conv_dist_inf conv_star_commute conv_dist_comp)
       hence "(F \<sqinter> v\<^sup>\<star>) * (-F \<sqinter> v)\<^sup>T \<le> (-F \<sqinter> v)\<^sup>T"
         using 22 conv_isotone by fastforce
       thus ?thesis
         using 22 by (metis assms(4, 6) comp_associative comp_inf.pp_comp_semi_commute comp_inf.semiring.add_mono comp_isotone inf_pp_commute mult_left_isotone)
     qed
     also have "... = (-F \<sqinter> v) * (-F \<sqinter> v)\<^sup>T"
       by simp
     also have "... \<le> v * v\<^sup>T"
       by (simp add: comp_isotone conv_isotone)
     also have "... \<le> 1"
       by (simp add: assms(2))
     thus ?thesis
       using calculation dual_order.trans by blast
   qed
   have 3: "top * ?i * top = top"
   proof -
     have 31: "regular (e\<^sup>T * -F * v * F * e)"
       using assms(3, 4, 6) arc_regular regular_mult_closed by auto
     have 32: "bijective ((top * e\<^sup>T)\<^sup>T)"
       using assms(3) by (simp add: conv_dist_comp)
     have "top * ?i * top = top * (v \<sqinter> -F * e * top) * ((top * e\<^sup>T * F)\<^sup>T \<sqinter> top)"
       by (simp add: comp_associative comp_inf_vector_1)
     also have "... = (top \<sqinter> (-F * e * top)\<^sup>T) * v * ((top * e\<^sup>T * F)\<^sup>T \<sqinter> top)"
       using comp_inf_vector conv_dist_comp by auto
     also have "... = (-F * e * top)\<^sup>T * v * (top * e\<^sup>T * F)\<^sup>T"
       by simp
     also have "... = top\<^sup>T * e\<^sup>T * -F\<^sup>T * v * F\<^sup>T * e\<^sup>T\<^sup>T * top\<^sup>T"
       by (simp add: comp_associative conv_complement conv_dist_comp)
     finally have 33: "top * ?i * top = top * e\<^sup>T * -F * v * F * e * top"
       by (simp add: assms(1))
     have "top * ?i * top \<noteq> bot"
     proof (rule ccontr)
       assume "\<not> top * (v \<sqinter> - F * e * top \<sqinter> top * e\<^sup>T * F) * top \<noteq> bot"
       hence "top * e\<^sup>T * -F * v * F * e * top = bot"
         using 33 by auto
       hence "e\<^sup>T * -F * v * F * e = bot"
         using 31 tarski comp_associative le_bot by fastforce
       hence "top * (-F * v * F * e)\<^sup>T \<le> -(e\<^sup>T)"
         by (metis comp_associative conv_complement_sub_leq conv_involutive p_bot schroeder_5_p)
       hence "top * e\<^sup>T * F\<^sup>T * v\<^sup>T * -F\<^sup>T \<le> -(e\<^sup>T)"
         by (simp add: comp_associative conv_complement conv_dist_comp)
       hence "v * F * e * top * e\<^sup>T \<le> F"
         by (metis assms(1, 4) comp_associative conv_dist_comp schroeder_3_p symmetric_top_closed)
       hence "v * F * e * top * top * e\<^sup>T \<le> F"
         by (simp add: comp_associative)
       hence "v * F * e * top \<le> F * (top * e\<^sup>T)\<^sup>T"
         using 32 by (metis shunt_bijective comp_associative conv_involutive)
       hence "v * F * e * top \<le> F * e * top"
         using comp_associative conv_dist_comp by auto
       hence "v\<^sup>\<star> * F * e * top \<le> F * e * top"
         using comp_associative star_left_induct_mult_iff by auto
       hence "e\<^sup>T * F * e * top \<le> F * e * top"
         by (meson assms(9) mult_left_isotone order_trans)
       hence "e\<^sup>T * F * e * top * (e * top)\<^sup>T \<le> F"
         using 32 shunt_bijective assms(3) mult_assoc by auto
       hence 34: "e\<^sup>T * F * e * top * top * e\<^sup>T \<le> F"
         by (metis conv_dist_comp mult.semigroup_axioms symmetric_top_closed semigroup.assoc)
       hence "e\<^sup>T \<le> F"
       proof -
         have "e\<^sup>T \<le> e\<^sup>T * e * e\<^sup>T"
           by (metis conv_involutive ex231c)
         also have "... \<le> e\<^sup>T * F * e * e\<^sup>T"
           using assms(1) comp_associative mult_left_isotone mult_right_isotone by fastforce
         also have "... \<le> e\<^sup>T * F * e * top * top * e\<^sup>T"
           by (simp add: mult_left_isotone top_right_mult_increasing vector_mult_closed)
         finally show ?thesis
           using 34 by simp
       qed
       hence 35: "e \<le> F"
         using assms(1) conv_order by fastforce
       have "top * (F * e)\<^sup>T \<le> - e"
         using assms(8) comp_associative schroeder_4_p by auto
       hence "top * e\<^sup>T * F \<le> - e"
         by (simp add: assms(1) comp_associative conv_dist_comp)
       hence "(top * e\<^sup>T)\<^sup>T * e \<le> - F"
         using schroeder_3_p by auto
       hence "e * top * e \<le> - F"
         by (simp add: conv_dist_comp)
       hence "e \<le> - F"
         by (simp add: assms(3) arc_top_arc)
       hence "e \<le> F \<sqinter> - F"
         using 35 inf.boundedI by blast
       hence "e = bot"
         using bot_unique by auto
       thus "False"
         using assms(10) by auto
     qed
     thus ?thesis
       by (metis assms(3, 4, 6) arc_regular regular_closed_inf regular_closed_top regular_conv_closed regular_mult_closed semiring.mult_not_zero tarski)
   qed
   have "bijective (?i * top) \<and> bijective (?i\<^sup>T * top)"
     using 1 2 3 arc_expanded by blast
   thus ?thesis
     by blast
 qed
 
 subsubsection \<open>Comparison of edge weights\<close>
 
 text \<open>
 In this section we compare the weight of the \<open>selected_edge\<close> with other edges of interest.
 For example, Theorem \<open>e_leq_c_c_complement_transpose_general\<close> is used to show that the \<open>selected_edge\<close> has its source inside and its target outside the component it is chosen for.
 \<close>
 
 lemma e_leq_c_c_complement_transpose_general:
   assumes "e = minarc (v * -(v)\<^sup>T \<sqinter> g)"
     and "regular v"
   shows "e \<le> v * -(v)\<^sup>T"
 proof -
   have "e \<le> -- (v * - v\<^sup>T \<sqinter> g)"
     using assms(1) minarc_below order_trans by blast
   also have "... \<le> -- (v * - v\<^sup>T)"
     using order_lesseq_imp pp_isotone_inf by blast
   also have "... = v * - v\<^sup>T"
     using assms(2) regular_mult_closed by auto
   finally show ?thesis
     by simp
 qed
 
 lemma x_leq_c_transpose_general:
   assumes "vector_classes x v"
     and "a\<^sup>T * top \<le> x * e * top"
     and "e \<le> v * -v\<^sup>T"
   shows "a \<le> v\<^sup>T"
 proof -
   have 1: "equivalence x"
     using assms(1) using vector_classes_def by blast
   have "a \<le> top * a"
     using top_left_mult_increasing by blast
   also have "... \<le> (x * e * top)\<^sup>T"
     using assms(2) conv_dist_comp conv_isotone by fastforce
   also have "... = top * e\<^sup>T * x"
     using 1 by (simp add: conv_dist_comp mult_assoc)
   also have "... \<le> top * (v * - v\<^sup>T)\<^sup>T * x"
     by (metis assms(3) conv_dist_comp conv_isotone mult_left_isotone symmetric_top_closed)
   also have "... = top * (- v * v\<^sup>T) * x"
     by (simp add: conv_complement conv_dist_comp)
   also have "... \<le> top * v\<^sup>T * x"
     by (metis mult_left_isotone top.extremum mult_assoc)
   also have "... = v\<^sup>T * x"
     using assms(1) vector_classes_def vector_conv_covector by auto
   also have "... = v\<^sup>T"
     by (metis assms(1) order.antisym conv_dist_comp conv_order dual_order.trans mult_right_isotone mult_sub_right_one vector_classes_def)
   finally show ?thesis
     by simp
 qed
 
 lemma x_leq_c_complement_general:
   assumes "vector v"
     and "v * v\<^sup>T \<le> x"
     and "a \<le> v\<^sup>T"
     and "a \<le> -x"
   shows "a \<le> -v"
 proof -
   have "a \<le> -x \<sqinter> v\<^sup>T"
     using assms(3, 4) by auto
   also have "... \<le> - v"
   proof -
     have "v \<sqinter> v\<^sup>T \<le> x"
       using assms(1, 2) vector_covector by auto
     hence "-x \<sqinter> v \<sqinter> v\<^sup>T \<le> bot"
       using inf.sup_monoid.add_assoc p_antitone pseudo_complement by fastforce
     thus ?thesis
       using le_bot p_shunting_swap pseudo_complement by blast
   qed
   finally show ?thesis
     by simp
 qed
 
 lemma sum_e_below_sum_a_when_outgoing_same_component_general:
   assumes "e = minarc (v * -(v)\<^sup>T \<sqinter> g)"
     and "symmetric g"
     and "arc a"
     and "a \<le> -x \<sqinter> -- g"
     and "a\<^sup>T * top \<le> x * e * top"
     and "unique_vector_class x v"
   shows "sum (e \<sqinter> g) \<le> sum (a \<sqinter> g)"
 proof -
   have 1:"e \<le> v * - v\<^sup>T"
     using assms(1, 6) e_leq_c_c_complement_transpose_general unique_vector_class_def vector_classes_def by auto
   have 2: "a \<le> v\<^sup>T"
     using 1 assms(5) assms(6) x_leq_c_transpose_general unique_vector_class_def by blast
   hence "a \<le> -v"
     using assms(4, 6) inf.boundedE unique_vector_class_def vector_classes_def x_leq_c_complement_general by meson
   hence "a \<le> - v \<sqinter> v\<^sup>T"
     using 2 by simp
   hence "a \<le> - v * v\<^sup>T"
     using assms(6) vector_complement_closed vector_covector unique_vector_class_def vector_classes_def by metis
   hence "a\<^sup>T \<le> v\<^sup>T\<^sup>T * - v\<^sup>T"
     using conv_complement conv_dist_comp conv_isotone by metis
   hence 3: "a\<^sup>T \<le> v * - v\<^sup>T"
     by simp
   hence "a \<le> -- g"
     using assms(4) by auto
   hence "a\<^sup>T \<le> -- g"
     using assms(2) conv_complement conv_isotone by fastforce
   hence "a\<^sup>T \<sqinter> v * - v\<^sup>T \<sqinter> -- g \<noteq> bot"
     using 3 assms(3, 6) inf.orderE semiring.mult_not_zero unique_vector_class_def vector_classes_def by metis
   hence "a\<^sup>T \<sqinter> v * - v\<^sup>T \<sqinter> g \<noteq> bot"
     using inf.sup_monoid.add_commute pp_inf_bot_iff by auto
   hence "sum (minarc (v * - v\<^sup>T \<sqinter> g) \<sqinter> (v * - v\<^sup>T \<sqinter> g)) \<le> sum (a\<^sup>T \<sqinter> v * - v\<^sup>T \<sqinter> g)"
     using assms(3) minarc_min inf.sup_monoid.add_assoc by simp
   hence "sum (e \<sqinter> v * - v\<^sup>T \<sqinter> g) \<le> sum (a\<^sup>T \<sqinter> v * - v\<^sup>T \<sqinter> g)"
     using assms(1, 6) inf.sup_monoid.add_assoc by simp
   hence "sum (e \<sqinter> g) \<le> sum (a\<^sup>T \<sqinter> g)"
     using 1 3 by (metis inf.orderE)
   hence "sum (e \<sqinter> g) \<le> sum (a \<sqinter> g)"
     by (simp add: assms(2) sum_symmetric)
   thus ?thesis
     by simp
 qed
 
 lemma sum_e_below_sum_x_when_outgoing_same_component:
   assumes "symmetric g"
     and "vector j"
     and "forest h"
     and "regular h"
     and "x \<le> - forest_components h \<sqinter> -- g"
     and "x\<^sup>T * top \<le> forest_components h * selected_edge h j g * top"
     and "j \<noteq> bot"
     and "arc x"
   shows "sum (selected_edge h j g \<sqinter> g) \<le> sum (x \<sqinter> g)"
 proof -
   let ?e = "selected_edge h j g"
   let ?c = "choose_component (forest_components h) j"
   let ?H = "forest_components h"
   show ?thesis
   proof (rule sum_e_below_sum_a_when_outgoing_same_component_general)
   next
     show "?e = minarc (?c * - ?c\<^sup>T \<sqinter> g)"
       by simp
   next
     show "symmetric g"
       by (simp add: assms(1))
   next
     show "arc x"
       by (simp add: assms(8))
   next
     show "x \<le> -?H \<sqinter> -- g"
       using assms(5) by auto
   next
     show "x\<^sup>T * top \<le> ?H * ?e * top"
       by (simp add: assms(6))
   next
     show "unique_vector_class ?H ?c"
     proof (unfold unique_vector_class_def, unfold vector_classes_def, intro conjI)
     next
       show "regular ?H"
         by (metis assms(4) conv_complement pp_dist_star regular_mult_closed)
     next
       show "regular ?c"
         using component_is_regular by auto
     next
       show "reflexive ?H"
         using assms(3) forest_components_equivalence by blast
     next
       show "transitive ?H"
         using assms(3) fch_equivalence by blast
     next
       show "symmetric ?H"
         by (simp add: assms(3) fch_equivalence)
     next
       show "vector ?c"
         by (simp add: assms(2, 6) component_is_vector)
     next
       show "?H * ?c \<le> ?c"
         using component_single by auto
     next
       show "?c \<noteq> bot"
         using assms(2, 6 , 7, 8) inf_bot_left le_bot minarc_bot mult_left_zero mult_right_zero by fastforce
     next
       show "?c * ?c\<^sup>T \<le> ?H"
         by (simp add: component_is_connected)
     qed
   qed
 qed
 
 text \<open>
 If there is a path in the \<open>forest_modulo_equivalence\<close> from an edge between components, $a$, to the \<open>selected_edge\<close>, $e$, then the weight of $e$ is no greater than the weight of $a$.
 This is because either,
 \begin{itemize}
 \item the edges $a$ and $e$ are adjacent the same component so that we can use \<open>sum_e_below_sum_x_when_outgoing_same_component\<close>, or
 \item there is at least one edge between $a$ and $e$, namely $x$, the edge incoming to the component that $e$ is outgoing from.
       The path from $a$ to $e$ is split on $x$ using \<open>forest_modulo_equivalence_path_split_disj\<close>.
       We show that the weight of $e$ is no greater than the weight of $x$ by making use of lemma \<open>sum_e_below_sum_x_when_outgoing_same_component\<close>.
       We define $x$ in a way that we can show that the weight of $x$ is no greater than the weight of $a$ using the invariant.
       Then, it follows that the weight of $e$ is no greater than the weight of $a$ owing to transitivity.
 \end{itemize}
 \<close>
 
 lemma a_to_e_in_forest_modulo_equivalence:
   assumes "symmetric g"
     and "f \<le> --g"
     and "vector j"
     and "forest h"
     and "forest_modulo_equivalence (forest_components h) d"
     and "f \<squnion> f\<^sup>T = h \<squnion> h\<^sup>T \<squnion> d \<squnion> d\<^sup>T"
     and "(\<forall> a b . forest_modulo_equivalence_path a b (forest_components h) d \<and> a \<le> -(forest_components h) \<sqinter> -- g \<and> b \<le> d \<longrightarrow> sum(b \<sqinter> g) \<le> sum(a \<sqinter> g))"
     and "regular d"
     and "j \<noteq> bot"
     and "b = selected_edge h j g"
     and "arc a"
     and "forest_modulo_equivalence_path a b (forest_components h) (d \<squnion> selected_edge h j g)"
     and "a \<le> - forest_components h \<sqinter> -- g"
     and "regular h"
   shows "sum (b \<sqinter> g) \<le> sum (a \<sqinter> g)"
 proof -
   let ?p = "path f h j g"
   let ?e = "selected_edge h j g"
   let ?F = "forest_components f"
   let ?H = "forest_components h"
   have "sum (b \<sqinter> g) \<le> sum (a \<sqinter> g)"
   proof (cases "a\<^sup>T * top \<le> ?H * ?e * top")
     case True
     show "a\<^sup>T * top \<le> ?H * ?e * top \<Longrightarrow> sum (b \<sqinter> g) \<le> sum (a \<sqinter> g)"
     proof-
       have "sum (?e \<sqinter> g) \<le> sum (a \<sqinter> g)"
       proof (rule sum_e_below_sum_x_when_outgoing_same_component)
         show "symmetric g"
           using assms(1) by auto
       next
         show "vector j"
           using assms(3) by blast
       next
         show "forest h"
           by (simp add: assms(4))
       next
         show "a \<le> - ?H \<sqinter> -- g"
           using assms(13) by auto
       next
         show "a\<^sup>T * top \<le> ?H * ?e * top"
           using True by auto
       next
         show "j \<noteq> bot"
           by (simp add: assms(9))
       next
         show "arc a"
           by (simp add: assms(11))
       next
         show "regular h"
           using assms(14) by auto
       qed
       thus ?thesis
         using assms(10) by auto
     qed
   next
     case False
     show "\<not> a\<^sup>T * top \<le> ?H * ?e * top \<Longrightarrow> sum (b \<sqinter> g) \<le> sum (a \<sqinter> g)"
     proof -
       let ?d' = "d \<squnion> ?e"
       let ?x = "d \<sqinter> top * ?e\<^sup>T * ?H \<sqinter> (?H * d\<^sup>T)\<^sup>\<star> * ?H * a\<^sup>T * top"
       have 61: "arc (?x)"
       proof (rule shows_arc_x)
         show "forest_modulo_equivalence ?H d"
           by (simp add: assms(5))
       next
         show "forest_modulo_equivalence_path a ?e ?H d"
         proof -
           have 611: "forest_modulo_equivalence_path a b ?H (d \<squnion> b)"
             using assms(10, 12) by auto
           have 616: "regular h"
             using assms(14) by auto
           have "regular a"
             using 611 forest_modulo_equivalence_path_def arc_regular by fastforce
           thus ?thesis
             using 616 by (smt forest_modulo_equivalence_path_split_disj assms(4, 8, 10, 12) forest_modulo_equivalence_path_def fch_equivalence minarc_regular regular_closed_star regular_conv_closed regular_mult_closed)
         qed
       next
         show "(?H * d)\<^sup>+ \<le> - ?H"
           using assms(5) forest_modulo_equivalence_def le_bot pseudo_complement by blast
       next
         show "\<not> a\<^sup>T * top \<le> ?H * ?e * top"
           by (simp add: False)
       next
         show "regular a"
           using assms(12) forest_modulo_equivalence_path_def arc_regular by auto
       next
         show "regular ?e"
           using minarc_regular by auto
       next
         show "regular ?H"
           using assms(14) pp_dist_star regular_conv_closed regular_mult_closed by auto
       next
         show "regular d"
           using assms(8) by auto
       qed
       have 62: "bijective (a\<^sup>T * top)"
         by (simp add: assms(11))
       have 63: "bijective (?x * top)"
         using 61 by simp
       have 64: "?x \<le> (?H * d\<^sup>T)\<^sup>\<star> * ?H * a\<^sup>T * top"
         by simp
       hence "?x * top \<le> (?H * d\<^sup>T)\<^sup>\<star> * ?H * a\<^sup>T * top"
         using mult_left_isotone inf_vector_comp by auto
       hence "a\<^sup>T * top \<le> ((?H * d\<^sup>T)\<^sup>\<star> * ?H)\<^sup>T * ?x * top"
         using 62 63 64 by (smt bijective_reverse mult_assoc)
       also have "... = ?H * (d * ?H)\<^sup>\<star> * ?x * top"
         using conv_dist_comp conv_star_commute by auto
       also have "... = (?H * d)\<^sup>\<star> * ?H * ?x * top"
         by (simp add: star_slide)
       finally have "a\<^sup>T * top \<le> (?H * d)\<^sup>\<star> * ?H * ?x * top"
         by simp
       hence 65: "forest_modulo_equivalence_path a ?x ?H d"
         using 61 assms(12) forest_modulo_equivalence_path_def by blast
       have 66: "?x \<le> d"
         by (simp add: inf.sup_monoid.add_assoc)
       hence x_below_a: "sum (?x \<sqinter> g) \<le> sum (a \<sqinter> g)"
         using 65 forest_modulo_equivalence_path_def assms(7, 13) by blast
       have "sum (?e \<sqinter> g) \<le> sum (?x \<sqinter> g)"
       proof (rule sum_e_below_sum_x_when_outgoing_same_component)
         show "symmetric g"
           using assms(1) by auto
       next
         show "vector j"
           using assms(3) by blast
       next
         show "forest h"
           by (simp add: assms(4))
       next
         show "?x \<le> - ?H \<sqinter> -- g"
         proof -
           have 67: "?x \<le> - ?H"
           proof -
             have "?x \<le> d"
               using 66 by blast
             also have "... \<le> ?H * d"
               using dual_order.trans star.circ_loop_fixpoint sup.cobounded2 mult_assoc by metis
             also have "... \<le> (?H * d)\<^sup>+"
               using star.circ_mult_increasing by blast
             also have "... \<le> - ?H"
               using assms(5) bot_unique pseudo_complement forest_modulo_equivalence_def by blast
             thus ?thesis
               using calculation inf.order_trans by blast
           qed
           have "?x \<le> d"
             by (simp add: conv_isotone inf.sup_monoid.add_assoc)
           also have "... \<le> f \<squnion> f\<^sup>T"
           proof -
             have "h \<squnion> h\<^sup>T \<squnion> d \<squnion> d\<^sup>T = f \<squnion> f\<^sup>T"
               by (simp add: assms(6))
             thus ?thesis
               by (metis (no_types) le_supE sup.absorb_iff2 sup.idem)
           qed
           also have "... \<le> -- g"
             using assms(1, 2) conv_complement conv_isotone by fastforce
           finally have "?x \<le> -- g"
             by simp
           thus ?thesis
             by (simp add: 67)
         qed
       next
         show "?x\<^sup>T * top \<le> ?H * ?e * top"
         proof -
           have "?x \<le> top * ?e\<^sup>T * ?H"
             using inf.coboundedI1 by auto
           hence "?x\<^sup>T \<le> ?H * ?e * top"
             using conv_dist_comp conv_dist_inf conv_star_commute inf.orderI inf.sup_monoid.add_assoc inf.sup_monoid.add_commute mult_assoc by auto
           hence "?x\<^sup>T * top \<le> ?H * ?e * top * top"
             by (simp add: mult_left_isotone)
           thus ?thesis
             by (simp add: mult_assoc)
         qed
       next
         show "j \<noteq> bot"
           by (simp add: assms(9))
       next
         show "arc (?x)"
           using 61 by blast
       next
         show "regular h"
           using assms(14) by auto
       qed
       hence "sum (?e \<sqinter> g) \<le> sum (a \<sqinter> g)"
         using x_below_a order.trans by blast
       thus ?thesis
         by (simp add: assms(10))
     qed
   qed
   thus ?thesis
     by simp
 qed
 
 subsubsection \<open>Maintenance of algorithm invariants\<close>
 
 text \<open>
 In this section, most of the work is done to maintain the invariants of the inner and outer loops of the algorithm.
 In particular, we use \<open>exists_a_w\<close> to maintain that $f$ can be extended to a minimum spanning forest.
 \<close>
 
 lemma boruvka_exchange_spanning_inv:
   assumes "forest v"
     and "v\<^sup>\<star> * e\<^sup>T = e\<^sup>T"
     and "i \<le> v \<sqinter> top * e\<^sup>T * w\<^sup>T\<^sup>\<star>"
     and "arc i"
     and "arc e"
     and "v \<le> --g"
     and "w \<le> --g"
     and "e \<le> --g"
     and "components g \<le> forest_components v"
   shows "i \<le> (v \<sqinter> -i)\<^sup>T\<^sup>\<star> * e\<^sup>T * top"
 proof -
   have 1: "(v \<sqinter> -i \<sqinter> -i\<^sup>T) * (v\<^sup>T \<sqinter> -i \<sqinter> -i\<^sup>T) \<le> 1"
     using assms(1) comp_isotone order.trans inf.cobounded1 by blast
   have 2: "bijective (i * top) \<and> bijective (e\<^sup>T * top)"
     using assms(4, 5) mult_assoc by auto
   have "i \<le> v * (top * e\<^sup>T * w\<^sup>T\<^sup>\<star>)\<^sup>T"
     using assms(3) covector_mult_closed covector_restrict_comp_conv order_lesseq_imp vector_top_closed by blast
   also have "... \<le> v * w\<^sup>T\<^sup>\<star>\<^sup>T * e\<^sup>T\<^sup>T * top\<^sup>T"
     by (simp add: comp_associative conv_dist_comp)
   also have "... \<le> v * w\<^sup>\<star> * e * top"
     by (simp add: conv_star_commute)
   also have "... = v * w\<^sup>\<star> * e * e\<^sup>T * e * top"
     using assms(5) arc_eq_1 by (simp add: comp_associative)
   also have "... \<le> v * w\<^sup>\<star> * e * e\<^sup>T * top"
     by (simp add: comp_associative mult_right_isotone)
   also have "... \<le> (--g) * (--g)\<^sup>\<star> * (--g) * e\<^sup>T * top"
     using assms(6, 7, 8) by (simp add: comp_isotone star_isotone)
   also have "... \<le> (--g)\<^sup>\<star> * e\<^sup>T * top"
     by (metis comp_isotone mult_left_isotone star.circ_increasing star.circ_transitive_equal)
   also have "... \<le> v\<^sup>T\<^sup>\<star> * v\<^sup>\<star> * e\<^sup>T * top"
     by (simp add: assms(9) mult_left_isotone)
   also have "... \<le> v\<^sup>T\<^sup>\<star> * e\<^sup>T * top"
     by (simp add: assms(2) comp_associative)
   finally have "i \<le> v\<^sup>T\<^sup>\<star> * e\<^sup>T * top"
     by simp
   hence "i * top \<le> v\<^sup>T\<^sup>\<star> * e\<^sup>T * top"
     by (metis comp_associative mult_left_isotone vector_top_closed)
   hence "e\<^sup>T * top \<le> v\<^sup>T\<^sup>\<star>\<^sup>T * i * top"
     using 2 by (metis bijective_reverse mult_assoc)
   also have "... = v\<^sup>\<star> * i * top"
     by (simp add: conv_star_commute)
   also have "... \<le> (v \<sqinter> -i \<sqinter> -i\<^sup>T)\<^sup>\<star> * i * top"
   proof -
     have 3: "i * top \<le> (v \<sqinter> -i \<sqinter> -i\<^sup>T)\<^sup>\<star> * i * top"
       using star.circ_loop_fixpoint sup_right_divisibility mult_assoc by auto
     have "(v \<sqinter> i) * (v \<sqinter> -i \<sqinter> -i\<^sup>T)\<^sup>\<star> * i * top \<le> i * top * i * top"
       by (metis comp_isotone inf.cobounded1 inf.sup_monoid.add_commute mult_left_isotone top.extremum)
     also have "... \<le> i * top"
       by simp
     finally have 4: "(v \<sqinter> i) * (v \<sqinter> -i \<sqinter> -i\<^sup>T)\<^sup>\<star> * i * top \<le> (v \<sqinter> -i \<sqinter> -i\<^sup>T)\<^sup>\<star> * i * top"
       using 3 dual_order.trans by blast
     have 5: "(v \<sqinter> -i \<sqinter> -i\<^sup>T) * (v \<sqinter> -i \<sqinter> -i\<^sup>T)\<^sup>\<star> * i * top \<le> (v \<sqinter> -i \<sqinter> -i\<^sup>T)\<^sup>\<star> * i * top"
       by (metis mult_left_isotone star.circ_increasing star.left_plus_circ)
     have "v\<^sup>+ \<le> -1"
       by (simp add: assms(1))
     hence "v * v \<le> -1"
       by (metis mult_left_isotone order_trans star.circ_increasing star.circ_plus_same)
     hence "v * 1 \<le> -v\<^sup>T"
       by (simp add: schroeder_5_p)
     hence "v \<le> -v\<^sup>T"
       by simp
     hence "v \<sqinter> v\<^sup>T \<le> bot"
       by (simp add: bot_unique pseudo_complement)
     hence 7: "v \<sqinter> i\<^sup>T \<le> bot"
       by (metis assms(3) comp_inf.mult_right_isotone conv_dist_inf inf.boundedE inf.le_iff_sup le_bot)
     hence "(v \<sqinter> i\<^sup>T) * (v \<sqinter> -i \<sqinter> -i\<^sup>T)\<^sup>\<star> * i * top \<le> bot"
       using le_bot semiring.mult_zero_left by fastforce
     hence 6: "(v \<sqinter> i\<^sup>T) * (v \<sqinter> -i \<sqinter> -i\<^sup>T)\<^sup>\<star> * i * top \<le> (v \<sqinter> -i \<sqinter> -i\<^sup>T)\<^sup>\<star> * i * top"
       using bot_least le_bot by blast
     have 8: "v = (v \<sqinter> i) \<squnion> (v \<sqinter> i\<^sup>T) \<squnion> (v \<sqinter> -i \<sqinter> -i\<^sup>T)"
     proof -
       have 81: "regular i"
         by (simp add: assms(4) arc_regular)
       have "(v \<sqinter> i\<^sup>T) \<squnion> (v \<sqinter> -i \<sqinter> -i\<^sup>T) = (v \<sqinter> -i)"
         using 7 by (metis comp_inf.coreflexive_comp_inf_complement inf_import_p inf_p le_bot maddux_3_11_pp top.extremum)
       hence "(v \<sqinter> i) \<squnion> (v \<sqinter> i\<^sup>T) \<squnion> (v \<sqinter> -i \<sqinter> -i\<^sup>T) = (v \<sqinter> i) \<squnion> (v \<sqinter> -i)"
         by (simp add: sup.semigroup_axioms semigroup.assoc)
       also have "... = v"
         using 81 by (metis maddux_3_11_pp)
       finally show ?thesis
         by simp
     qed
     have "(v \<sqinter> i) * (v \<sqinter> -i \<sqinter> -i\<^sup>T)\<^sup>\<star> * i * top \<squnion> (v \<sqinter> i\<^sup>T) * (v \<sqinter> -i \<sqinter> -i\<^sup>T)\<^sup>\<star> * i * top \<squnion> (v \<sqinter> -i \<sqinter> -i\<^sup>T) * (v \<sqinter> -i \<sqinter> -i\<^sup>T)\<^sup>\<star> * i * top \<le> (v \<sqinter> -i \<sqinter> -i\<^sup>T)\<^sup>\<star> * i * top"
       using 4 5 6 by simp
     hence "((v \<sqinter> i) \<squnion> (v \<sqinter> i\<^sup>T) \<squnion> (v \<sqinter> -i \<sqinter> -i\<^sup>T)) * (v \<sqinter> -i \<sqinter> -i\<^sup>T)\<^sup>\<star> * i * top \<le> (v \<sqinter> -i \<sqinter> -i\<^sup>T)\<^sup>\<star> * i * top"
       by (simp add: mult_right_dist_sup)
     hence "v * (v \<sqinter> -i \<sqinter> -i\<^sup>T)\<^sup>\<star> * i * top \<le> (v \<sqinter> -i \<sqinter> -i\<^sup>T)\<^sup>\<star> * i * top"
       using 8 by auto
     hence "i * top \<squnion> v * (v \<sqinter> -i \<sqinter> -i\<^sup>T)\<^sup>\<star> * i * top \<le> (v \<sqinter> -i \<sqinter> -i\<^sup>T)\<^sup>\<star> * i * top"
       using 3 by auto
     hence 9:"v\<^sup>\<star> * (v \<sqinter> -i \<sqinter> -i\<^sup>T)\<^sup>\<star> * i * top \<le> (v \<sqinter> -i \<sqinter> -i\<^sup>T)\<^sup>\<star> * i * top"
       by (simp add: star_left_induct_mult mult_assoc)
     have "v\<^sup>\<star> * i * top \<le> v\<^sup>\<star> * (v \<sqinter> -i \<sqinter> -i\<^sup>T)\<^sup>\<star> * i * top"
       using 3 mult_right_isotone mult_assoc by auto
     thus ?thesis
       using 9 order.trans by blast
   qed
   finally have "e\<^sup>T * top \<le> (v \<sqinter> -i \<sqinter> -i\<^sup>T)\<^sup>\<star> * i * top"
     by simp
   hence "i * top \<le> (v \<sqinter> -i \<sqinter> -i\<^sup>T)\<^sup>\<star>\<^sup>T * e\<^sup>T * top"
     using 2 by (metis bijective_reverse mult_assoc)
   also have "... = (v\<^sup>T \<sqinter> -i \<sqinter> -i\<^sup>T)\<^sup>\<star> * e\<^sup>T * top"
     using comp_inf.inf_vector_comp conv_complement conv_dist_inf conv_star_commute inf.sup_monoid.add_commute by auto
   also have "... \<le> ((v \<sqinter> -i \<sqinter> -i\<^sup>T) \<squnion> (v\<^sup>T \<sqinter> -i \<sqinter> -i\<^sup>T))\<^sup>\<star> * e\<^sup>T * top"
     by (simp add: mult_left_isotone star_isotone)
   finally have "i \<le> ((v\<^sup>T \<sqinter> -i \<sqinter> -i\<^sup>T) \<squnion> (v \<sqinter> -i \<sqinter> -i\<^sup>T))\<^sup>\<star> * e\<^sup>T * top"
     using dual_order.trans top_right_mult_increasing sup_commute by auto
   also have "... = (v\<^sup>T \<sqinter> -i \<sqinter> -i\<^sup>T)\<^sup>\<star> * (v \<sqinter> -i \<sqinter> -i\<^sup>T)\<^sup>\<star> * e\<^sup>T * top"
     using 1 cancel_separate_1 by (simp add: sup_commute)
   also have "... \<le> (v\<^sup>T \<sqinter> -i \<sqinter> -i\<^sup>T)\<^sup>\<star> * v\<^sup>\<star> * e\<^sup>T * top"
     by (simp add: inf_assoc mult_left_isotone mult_right_isotone star_isotone)
   also have "... = (v\<^sup>T \<sqinter> -i \<sqinter> -i\<^sup>T)\<^sup>\<star> * e\<^sup>T * top"
     using assms(2) mult_assoc by simp
   also have "... \<le> (v\<^sup>T \<sqinter> -i\<^sup>T)\<^sup>\<star> * e\<^sup>T * top"
     by (metis mult_left_isotone star_isotone inf.cobounded2 inf.left_commute inf.sup_monoid.add_commute)
   also have "... = (v \<sqinter> -i)\<^sup>T\<^sup>\<star> * e\<^sup>T * top"
     using conv_complement conv_dist_inf by auto
   finally show ?thesis
     by simp
 qed
 
 lemma exists_a_w:
   assumes "symmetric g"
     and "forest f"
     and "f \<le> --g"
     and "regular f"
     and "(\<exists>w . minimum_spanning_forest w g \<and> f \<le> w \<squnion> w\<^sup>T)"
     and "vector j"
     and "regular j"
     and "forest h"
     and "forest_modulo_equivalence (forest_components h) d"
     and "d * top \<le> - j"
     and "forest_components h * j = j"
     and "f \<squnion> f\<^sup>T = h \<squnion> h\<^sup>T \<squnion> d \<squnion> d\<^sup>T"
     and "(\<forall> a b . forest_modulo_equivalence_path a b (forest_components h) d \<and> a \<le> -(forest_components h) \<sqinter> -- g \<and> b \<le> d \<longrightarrow> sum(b \<sqinter> g) \<le> sum(a \<sqinter> g))"
     and "regular d"
     and "selected_edge h j g \<le> - forest_components f"
     and "selected_edge h j g \<noteq> bot"
     and "j \<noteq> bot"
     and "regular h"
     and "h \<le> --g"
   shows "\<exists>w. minimum_spanning_forest w g \<and>
     f \<sqinter> - (selected_edge h j g)\<^sup>T \<sqinter> - (path f h j g) \<squnion> (f \<sqinter> - (selected_edge h j g)\<^sup>T \<sqinter> (path f h j g))\<^sup>T \<squnion> (selected_edge h j g) \<le> w \<squnion> w\<^sup>T"
 proof -
   let ?p = "path f h j g"
   let ?e = "selected_edge h j g"
   let ?f = "(f \<sqinter> -?e\<^sup>T \<sqinter> -?p) \<squnion> (f \<sqinter> -?e\<^sup>T \<sqinter> ?p)\<^sup>T \<squnion> ?e"
   let ?F = "forest_components f"
   let ?H = "forest_components h"
   let ?ec = "choose_component (forest_components h) j * - choose_component (forest_components h) j\<^sup>T \<sqinter> g"
   from assms(4) obtain w where 2: "minimum_spanning_forest w g \<and> f \<le> w \<squnion> w\<^sup>T"
     using assms(5) by blast
   hence 3: "regular w \<and> regular f \<and> regular ?e"
     by (metis assms(4) minarc_regular minimum_spanning_forest_def spanning_forest_def)
   have 5: "equivalence ?F"
     using assms(2) forest_components_equivalence by auto
   have "?e\<^sup>T * top * ?e\<^sup>T = ?e\<^sup>T"
     by (metis arc_conv_closed arc_top_arc coreflexive_bot_closed coreflexive_symmetric minarc_arc minarc_bot_iff semiring.mult_not_zero)
   hence "?e\<^sup>T * top * ?e\<^sup>T \<le> -?F"
     using 5 assms(15) conv_complement conv_isotone by fastforce
   hence 6: "?e * ?F * ?e = bot"
     using assms(2) le_bot triple_schroeder_p by simp
   let ?q = "w \<sqinter> top * ?e * w\<^sup>T\<^sup>\<star>"
   let ?v = "(w \<sqinter> -(top * ?e * w\<^sup>T\<^sup>\<star>)) \<squnion> ?q\<^sup>T"
   have 7: "regular ?q"
     using 3 regular_closed_star regular_conv_closed regular_mult_closed by auto
   have 8: "injective ?v"
   proof (rule kruskal_exchange_injective_inv_1)
     show "injective w"
       using 2 minimum_spanning_forest_def spanning_forest_def by blast
   next
     show "covector (top * ?e * w\<^sup>T\<^sup>\<star>)"
       by (simp add: covector_mult_closed)
   next
     show "top * ?e * w\<^sup>T\<^sup>\<star> * w\<^sup>T \<le> top * ?e * w\<^sup>T\<^sup>\<star>"
       by (simp add: mult_right_isotone star.right_plus_below_circ mult_assoc)
   next
     show "coreflexive ((top * ?e * w\<^sup>T\<^sup>\<star>)\<^sup>T * (top * ?e * w\<^sup>T\<^sup>\<star>) \<sqinter> w\<^sup>T * w)"
       using 2 by (metis comp_inf.semiring.mult_not_zero forest_bot kruskal_injective_inv_3 minarc_arc minarc_bot_iff minimum_spanning_forest_def semiring.mult_not_zero spanning_forest_def)
   qed
   have 9: "components g \<le> forest_components ?v"
   proof (rule kruskal_exchange_spanning_inv_1)
     show "injective (w \<sqinter> - (top *?e * w\<^sup>T\<^sup>\<star>) \<squnion> (w \<sqinter> top * ?e * w\<^sup>T\<^sup>\<star>)\<^sup>T)"
       using 8 by simp
   next
     show "regular (w \<sqinter> top * ?e * w\<^sup>T\<^sup>\<star>)"
       using 7 by simp
   next
     show "components g \<le> forest_components w"
       using 2 minimum_spanning_forest_def spanning_forest_def by blast
   qed
   have 10: "spanning_forest ?v g"
   proof (unfold spanning_forest_def, intro conjI)
     show "injective ?v"
       using 8 by auto
   next
     show "acyclic ?v"
     proof (rule kruskal_exchange_acyclic_inv_1)
       show "pd_kleene_allegory_class.acyclic w"
         using 2 minimum_spanning_forest_def spanning_forest_def by blast
     next
       show "covector (top * ?e * w\<^sup>T\<^sup>\<star>)"
         by (simp add: covector_mult_closed)
     qed
   next
     show "?v \<le> --g"
     proof (rule sup_least)
       show "w \<sqinter> - (top * ?e * w\<^sup>T\<^sup>\<star>) \<le> - - g"
         using 7 inf.coboundedI1 minimum_spanning_forest_def spanning_forest_def 2 by blast
     next
       show "(w \<sqinter> top * ?e * w\<^sup>T\<^sup>\<star>)\<^sup>T \<le> - - g"
         using 2 by (metis assms(1) conv_complement conv_isotone inf.coboundedI1 minimum_spanning_forest_def spanning_forest_def)
     qed
   next
     show "components g \<le> forest_components ?v"
       using 9 by simp
   next
     show "regular ?v"
       using 3 regular_closed_star regular_conv_closed regular_mult_closed by auto
   qed
   have 11: "sum (?v \<sqinter> g) = sum (w \<sqinter> g)"
   proof -
     have "sum (?v \<sqinter> g) = sum (w \<sqinter> -(top * ?e * w\<^sup>T\<^sup>\<star>) \<sqinter> g) + sum (?q\<^sup>T \<sqinter> g)"
       using 2 by (smt conv_complement conv_top epm_8 inf_import_p inf_top_right regular_closed_top vector_top_closed minimum_spanning_forest_def spanning_forest_def sum_disjoint)
     also have "... = sum (w \<sqinter> -(top * ?e * w\<^sup>T\<^sup>\<star>) \<sqinter> g) + sum (?q \<sqinter> g)"
       by (simp add: assms(1) sum_symmetric)
     also have "... = sum (((w \<sqinter> -(top * ?e * w\<^sup>T\<^sup>\<star>)) \<squnion> ?q) \<sqinter> g)"
       using inf_commute inf_left_commute sum_disjoint by simp
     also have "... = sum (w \<sqinter> g)"
       using 3 7 8 maddux_3_11_pp by auto
     finally show ?thesis
       by simp
   qed
   have 12: "?v \<squnion> ?v\<^sup>T = w \<squnion> w\<^sup>T"
   proof -
     have "?v \<squnion> ?v\<^sup>T = (w \<sqinter> -?q) \<squnion> ?q\<^sup>T \<squnion> (w\<^sup>T \<sqinter> -?q\<^sup>T) \<squnion> ?q"
       using conv_complement conv_dist_inf conv_dist_sup inf_import_p sup_assoc by simp
     also have "... = w \<squnion> w\<^sup>T"
       using 3 7 conv_complement conv_dist_inf inf_import_p maddux_3_11_pp sup_monoid.add_assoc sup_monoid.add_commute by auto
     finally show ?thesis
       by simp
   qed
   have 13: "?v * ?e\<^sup>T = bot"
   proof (rule kruskal_reroot_edge)
     show "injective (?e\<^sup>T * top)"
       using assms(16) minarc_arc minarc_bot_iff by blast
   next
     show "pd_kleene_allegory_class.acyclic w"
       using 2 minimum_spanning_forest_def spanning_forest_def by simp
   qed
   have "?v \<sqinter> ?e \<le> ?v \<sqinter> top * ?e"
     using inf.sup_right_isotone top_left_mult_increasing by simp
   also have "... \<le> ?v * (top * ?e)\<^sup>T"
     using covector_restrict_comp_conv covector_mult_closed vector_top_closed by simp
   finally have 14: "?v \<sqinter> ?e = bot"
     using 13 by (metis conv_dist_comp mult_assoc le_bot mult_left_zero)
   let ?i = "?v \<sqinter> (- ?F) * ?e * top \<sqinter> top * ?e\<^sup>T * ?F"
   let ?w = "(?v \<sqinter> -?i) \<squnion> ?e"
   have 15: "regular ?i"
     using 3 regular_closed_star regular_conv_closed regular_mult_closed by simp
   have 16: "?F \<le> -?i"
   proof -
     have 161: "bijective (?e * top)"
       using assms(16) minarc_arc minarc_bot_iff by auto
     have "?i \<le> - ?F * ?e * top"
       using inf.cobounded2 inf.coboundedI1 by blast
     also have "... = - (?F * ?e * top)"
       using 161 comp_bijective_complement by (simp add: mult_assoc)
     finally have "?i \<le> - (?F * ?e * top)"
       by blast
     hence 162: "?i \<sqinter> ?F \<le> - (?F * ?e * top)"
       using inf.coboundedI1 by blast
     have "?i \<sqinter> ?F \<le> ?F \<sqinter> (top * ?e\<^sup>T * ?F)"
       by (meson inf_le1 inf_le2 le_infI order_trans)
     also have "... \<le> ?F * (top * ?e\<^sup>T * ?F)\<^sup>T"
       by (simp add: covector_mult_closed covector_restrict_comp_conv)
     also have "... = ?F * ?F\<^sup>T * ?e\<^sup>T\<^sup>T * top\<^sup>T"
       by (simp add: conv_dist_comp mult_assoc)
     also have "... = ?F * ?F * ?e * top"
       by (simp add: conv_dist_comp conv_star_commute)
     also have "... = ?F * ?e * top"
       by (simp add: 5 preorder_idempotent)
     finally have "?i \<sqinter> ?F \<le> ?F * ?e * top"
       by simp
     hence "?i \<sqinter> ?F \<le> ?F * ?e * top \<sqinter> - (?F * ?e * top)"
       using 162 inf.bounded_iff by blast
     also have "... = bot"
       by simp
     finally show ?thesis
       using le_bot p_antitone_iff pseudo_complement by blast
   qed
   have 17: "?i \<le> top * ?e\<^sup>T * (?F \<sqinter> ?v \<sqinter> -?i)\<^sup>T\<^sup>\<star>"
   proof -
     have "?i \<le> ?v \<sqinter> - ?F * ?e * top \<sqinter> top * ?e\<^sup>T * (?F \<sqinter> ?v)\<^sup>T\<^sup>\<star> * (?F \<sqinter> ?v)\<^sup>\<star>"
       using 2 8 12 by (smt inf.sup_right_isotone kruskal_forest_components_inf mult_right_isotone mult_assoc)
     also have "... = ?v \<sqinter> - ?F * ?e * top \<sqinter> top * ?e\<^sup>T * (?F \<sqinter> ?v)\<^sup>T\<^sup>\<star> * (1 \<squnion> (?F \<sqinter> ?v)\<^sup>\<star> * (?F \<sqinter> ?v))"
       using star_left_unfold_equal star.circ_right_unfold_1 by auto
     also have "... = ?v \<sqinter> - ?F * ?e * top \<sqinter> (top * ?e\<^sup>T * (?F \<sqinter> ?v)\<^sup>T\<^sup>\<star> \<squnion> top * ?e\<^sup>T * (?F \<sqinter> ?v)\<^sup>T\<^sup>\<star> * (?F \<sqinter> ?v)\<^sup>\<star> * (?F \<sqinter> ?v))"
       by (simp add: mult_left_dist_sup mult_assoc)
     also have "... = (?v \<sqinter> - ?F * ?e * top \<sqinter> top * ?e\<^sup>T * (?F \<sqinter> ?v)\<^sup>T\<^sup>\<star>) \<squnion> (?v \<sqinter> - ?F * ?e * top \<sqinter> top * ?e\<^sup>T * (?F \<sqinter> ?v)\<^sup>T\<^sup>\<star> * (?F \<sqinter> ?v)\<^sup>\<star> * (?F \<sqinter> ?v))"
       using comp_inf.semiring.distrib_left by blast
     also have "... \<le> top * ?e\<^sup>T * (?F \<sqinter> ?v)\<^sup>T\<^sup>\<star> \<squnion> (?v \<sqinter> - ?F * ?e * top \<sqinter> top * ?e\<^sup>T * (?F \<sqinter> ?v)\<^sup>T\<^sup>\<star> * (?F \<sqinter> ?v)\<^sup>\<star> * (?F \<sqinter> ?v))"
       using comp_inf.semiring.add_right_mono inf_le2 by blast
     also have "... \<le> top * ?e\<^sup>T * (?F \<sqinter> ?v)\<^sup>T\<^sup>\<star> \<squnion> (?v \<sqinter> - ?F * ?e * top \<sqinter> top * ?e\<^sup>T * (?F\<^sup>T \<sqinter> ?v\<^sup>T)\<^sup>\<star> * (?F \<sqinter> ?v)\<^sup>\<star> * (?F \<sqinter> ?v))"
       by (simp add: conv_dist_inf)
     also have "... \<le> top * ?e\<^sup>T * (?F \<sqinter> ?v)\<^sup>T\<^sup>\<star> \<squnion> (?v \<sqinter> - ?F * ?e * top \<sqinter> top * ?e\<^sup>T * ?F\<^sup>T\<^sup>\<star> * ?F\<^sup>\<star> * (?F \<sqinter> ?v))"
     proof -
       have "top * ?e\<^sup>T * (?F\<^sup>T \<sqinter> ?v\<^sup>T)\<^sup>\<star> * (?F \<sqinter> ?v)\<^sup>\<star> * (?F \<sqinter> ?v) \<le> top * ?e\<^sup>T * ?F\<^sup>T\<^sup>\<star> * ?F\<^sup>\<star> * (?F \<sqinter> ?v)"
         using star_isotone by (simp add: comp_isotone)
       hence "?v \<sqinter> - ?F * ?e * top \<sqinter> top * ?e\<^sup>T * (?F\<^sup>T \<sqinter> ?v\<^sup>T)\<^sup>\<star> * (?F \<sqinter> ?v)\<^sup>\<star> * (?F \<sqinter> ?v) \<le> ?v \<sqinter> - ?F * ?e * top \<sqinter> top * ?e\<^sup>T * ?F\<^sup>T\<^sup>\<star> * ?F\<^sup>\<star> * (?F \<sqinter> ?v)"
         using inf.sup_right_isotone by blast
       thus ?thesis
         using sup_right_isotone by blast
     qed
     also have "... = top * ?e\<^sup>T * (?F \<sqinter> ?v)\<^sup>T\<^sup>\<star> \<squnion> (?v \<sqinter> - ?F * ?e * top \<sqinter> top * ?e\<^sup>T * ?F\<^sup>\<star> * ?F\<^sup>\<star> * (?F \<sqinter> ?v))"
       using 5 by auto
     also have "... = top * ?e\<^sup>T * (?F \<sqinter> ?v)\<^sup>T\<^sup>\<star> \<squnion> (?v \<sqinter> - ?F * ?e * top \<sqinter> top * ?e\<^sup>T * ?F * ?F * (?F \<sqinter> ?v))"
       by (simp add: assms(2) forest_components_star)
     also have "... = top * ?e\<^sup>T * (?F \<sqinter> ?v)\<^sup>T\<^sup>\<star> \<squnion> (?v \<sqinter> - ?F * ?e * top \<sqinter> top * ?e\<^sup>T * ?F * (?F \<sqinter> ?v))"
       using 5 mult.semigroup_axioms preorder_idempotent semigroup.assoc by fastforce
     also have "... = top * ?e\<^sup>T * (?F \<sqinter> ?v)\<^sup>T\<^sup>\<star>"
     proof -
       have "?e * top * ?e\<^sup>T \<le> 1"
         using assms(16) arc_expanded minarc_arc minarc_bot_iff by auto
       hence "?F * ?e * top * ?e\<^sup>T \<le> ?F * 1"
         by (metis comp_associative comp_isotone mult_semi_associative star.circ_transitive_equal)
       hence "?v * ?v\<^sup>T * ?F * ?e * top * ?e\<^sup>T \<le> 1 * ?F * 1"
         using 8 by (smt comp_isotone mult_assoc)
       hence 171: "?v * ?v\<^sup>T * ?F * ?e * top * ?e\<^sup>T \<le> ?F"
         by simp
       hence "?v * (?F \<sqinter> ?v)\<^sup>T * ?F * ?e * top * ?e\<^sup>T \<le> ?F"
       proof -
         have "?v * (?F \<sqinter> ?v)\<^sup>T * ?F * ?e * top * ?e\<^sup>T \<le> ?v * ?v\<^sup>T * ?F * ?e * top * ?e\<^sup>T"
           by (simp add: conv_dist_inf mult_left_isotone mult_right_isotone)
         thus ?thesis
           using 171 order_trans by blast
       qed
       hence 172: "-?F * ((?F \<sqinter> ?v)\<^sup>T * ?F * ?e * top * ?e\<^sup>T)\<^sup>T \<le> -?v"
         by (smt schroeder_4_p comp_associative order_lesseq_imp pp_increasing)
       have "-?F * ((?F \<sqinter> ?v)\<^sup>T * ?F * ?e * top * ?e\<^sup>T)\<^sup>T = -?F * ?e\<^sup>T\<^sup>T * top\<^sup>T * ?e\<^sup>T * ?F\<^sup>T * (?F \<sqinter> ?v)\<^sup>T\<^sup>T"
         by (simp add: comp_associative conv_dist_comp)
       also have "... = -?F * ?e * top * ?e\<^sup>T * ?F * (?F \<sqinter> ?v)"
         using 5 by auto
       also have "... = -?F * ?e * top * top * ?e\<^sup>T * ?F * (?F \<sqinter> ?v)"
         using comp_associative by auto
       also have "... = -?F * ?e * top \<sqinter> top * ?e\<^sup>T * ?F * (?F \<sqinter> ?v)"
         by (smt comp_associative comp_inf.star.circ_decompose_9 comp_inf.star_star_absorb comp_inf_covector inf_vector_comp vector_top_closed)
       finally have "-?F * ((?F \<sqinter> ?v)\<^sup>T * ?F * ?e * top * ?e\<^sup>T)\<^sup>T = -?F * ?e * top \<sqinter> top * ?e\<^sup>T * ?F * (?F \<sqinter> ?v)"
         by simp
       hence "-?F * ?e * top \<sqinter> top * ?e\<^sup>T * ?F * (?F \<sqinter> ?v) \<le> -?v"
         using 172 by auto
       hence "?v \<sqinter> -?F * ?e * top \<sqinter> top * ?e\<^sup>T * ?F * (?F \<sqinter> ?v) \<le> bot"
         by (smt bot_unique inf.sup_monoid.add_commute p_shunting_swap pseudo_complement)
       thus ?thesis
         using le_bot sup_monoid.add_0_right by blast
     qed
     also have "... = top * ?e\<^sup>T * (?F \<sqinter> ?v \<sqinter> -?i)\<^sup>T\<^sup>\<star>"
       using 16 by (smt comp_inf.coreflexive_comp_inf_complement inf_top_right p_bot pseudo_complement top.extremum)
     finally show ?thesis
       by blast
   qed
   have 18: "?i \<le> top * ?e\<^sup>T * ?w\<^sup>T\<^sup>\<star>"
   proof -
     have "?i \<le> top * ?e\<^sup>T * (?F \<sqinter> ?v \<sqinter> -?i)\<^sup>T\<^sup>\<star>"
       using 17 by simp
     also have "... \<le> top * ?e\<^sup>T * (?v \<sqinter> -?i)\<^sup>T\<^sup>\<star>"
       using mult_right_isotone conv_isotone star_isotone inf.cobounded2 inf.sup_monoid.add_assoc by (simp add: inf.sup_monoid.add_assoc order.eq_iff inf.sup_monoid.add_commute)
     also have "... \<le> top * ?e\<^sup>T * ((?v \<sqinter> -?i) \<squnion> ?e)\<^sup>T\<^sup>\<star>"
       using mult_right_isotone conv_isotone star_isotone sup_ge1 by simp
     finally show ?thesis
       by blast
   qed
   have 19: "?i \<le> top * ?e\<^sup>T * ?v\<^sup>T\<^sup>\<star>"
   proof -
     have "?i \<le> top * ?e\<^sup>T * (?F \<sqinter> ?v \<sqinter> -?i)\<^sup>T\<^sup>\<star>"
       using 17 by simp
     also have "... \<le> top * ?e\<^sup>T * (?v \<sqinter> -?i)\<^sup>T\<^sup>\<star>"
       using mult_right_isotone conv_isotone star_isotone inf.cobounded2 inf.sup_monoid.add_assoc by (simp add: inf.sup_monoid.add_assoc order.eq_iff inf.sup_monoid.add_commute)
     also have "... \<le> top * ?e\<^sup>T * (?v)\<^sup>T\<^sup>\<star>"
       using mult_right_isotone conv_isotone star_isotone by auto
     finally show ?thesis
       by blast
   qed
   have 20: "f \<squnion> f\<^sup>T \<le> (?v \<sqinter> -?i \<sqinter> -?i\<^sup>T) \<squnion> (?v\<^sup>T \<sqinter> -?i \<sqinter> -?i\<^sup>T)"
   proof (rule kruskal_edge_between_components_2)
     show "?F \<le> - ?i"
       using 16 by simp
   next
     show "injective f"
       by (simp add: assms(2))
   next
     show "f \<squnion> f\<^sup>T \<le> w \<sqinter> - (top * ?e * w\<^sup>T\<^sup>\<star>) \<squnion> (w \<sqinter> top * ?e * w\<^sup>T\<^sup>\<star>)\<^sup>T \<squnion> (w \<sqinter> - (top * ?e * w\<^sup>T\<^sup>\<star>) \<squnion> (w \<sqinter> top * ?e * w\<^sup>T\<^sup>\<star>)\<^sup>T)\<^sup>T"
       using 2 12 by (metis conv_dist_sup conv_involutive conv_isotone le_supI sup_commute)
   qed
   have "minimum_spanning_forest ?w g \<and> ?f \<le> ?w \<squnion> ?w\<^sup>T"
   proof (intro conjI)
     have 211: "?e\<^sup>T \<le> ?v\<^sup>\<star>"
     proof (rule kruskal_edge_arc_1[where g=g and h="?ec"])
       show "?e \<le> -- ?ec"
         using minarc_below by blast
     next
       show "?ec \<le> g"
         using assms(4) inf.cobounded2 by (simp add: boruvka_inner_invariant_def boruvka_outer_invariant_def conv_dist_inf)
     next
       show "symmetric g"
         by (meson assms(1) boruvka_inner_invariant_def boruvka_outer_invariant_def)
     next
       show "components g \<le> forest_components (w \<sqinter> - (top * ?e * w\<^sup>T\<^sup>\<star>) \<squnion> (w \<sqinter> top * ?e * w\<^sup>T\<^sup>\<star>)\<^sup>T)"
         using 9 by simp
     next
       show "(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"
         using 13 by blast
     qed
     have 212: "arc ?i"
     proof (rule boruvka_edge_arc)
       show "equivalence ?F"
         by (simp add: 5)
     next
       show "forest ?v"
         using 10 spanning_forest_def by blast
     next
       show "arc ?e"
         using assms(16) minarc_arc minarc_bot_iff by blast
     next
       show "regular ?F"
         using 3 regular_closed_star regular_conv_closed regular_mult_closed by auto
     next
       show "?F \<le> forest_components (?F \<sqinter> ?v)"
         by (simp add: 12 2 8 kruskal_forest_components_inf)
     next
       show "regular ?v"
         using 10 spanning_forest_def by blast
     next
       show "?v * ?e\<^sup>T = bot"
         using 13 by auto
     next
       show "?e * ?F * ?e = bot"
         by (simp add: 6)
     next
       show "?e\<^sup>T \<le> ?v\<^sup>\<star>"
         using 211 by auto
 
     next
       show "?e \<noteq> bot"
         by (simp add: assms(16))
     qed
     show "minimum_spanning_forest ?w g"
     proof (unfold minimum_spanning_forest_def, intro conjI)
       have "(?v \<sqinter> -?i) * ?e\<^sup>T \<le> ?v * ?e\<^sup>T"
         using inf_le1 mult_left_isotone by simp
       hence "(?v \<sqinter> -?i) * ?e\<^sup>T = bot"
         using 13 le_bot by simp
       hence 221: "?e * (?v \<sqinter> -?i)\<^sup>T = bot"
         using conv_dist_comp conv_involutive conv_bot by force
       have 222: "injective ?w"
       proof (rule injective_sup)
         show "injective (?v \<sqinter> -?i)"
           using 8 by (simp add: injective_inf_closed)
       next
         show "coreflexive (?e * (?v \<sqinter> -?i)\<^sup>T)"
           using 221 by simp
       next
         show "injective ?e"
           by (metis arc_injective minarc_arc coreflexive_bot_closed coreflexive_injective minarc_bot_iff)
       qed
       show "spanning_forest ?w g"
       proof (unfold spanning_forest_def, intro conjI)
         show "injective ?w"
           using 222 by simp
       next
         show "acyclic ?w"
         proof (rule kruskal_exchange_acyclic_inv_2)
           show "acyclic ?v"
             using 10 spanning_forest_def by blast
         next
           show "injective ?v"
             using 8 by simp
         next
           show "?i \<le>?v"
             using inf.coboundedI1 by simp
         next
           show "bijective (?i\<^sup>T * top)"
             using 212 by simp
         next
           show "bijective (?e * top)"
             using 14 212 by (smt assms(4) comp_inf.idempotent_bot_closed conv_complement minarc_arc minarc_bot_iff p_bot regular_closed_bot semiring.mult_not_zero symmetric_top_closed)
         next
           show "?i \<le> top * ?e\<^sup>T *?v\<^sup>T\<^sup>\<star>"
             using 19 by simp
         next
           show "?v * ?e\<^sup>T * top = bot"
             using 13 by simp
         qed
       next
         have "?w \<le> ?v \<squnion> ?e"
           using inf_le1 sup_left_isotone by simp
         also have "... \<le> --g \<squnion> ?e"
           using 10 sup_left_isotone spanning_forest_def by blast
         also have "... \<le> --g \<squnion> --h"
         proof -
           have 1: "--g \<le> --g \<squnion> --h"
             by simp
           have 2: "?e \<le> --g \<squnion> --h"
             by (metis inf.coboundedI1 inf.sup_monoid.add_commute minarc_below order.trans p_dist_inf p_dist_sup sup.cobounded1)
           thus ?thesis
             using 1 2 by simp
         qed
         also have "... \<le> --g"
             using assms(18, 19) by auto
         finally show "?w \<le> --g"
           by simp
       next
         have 223: "?i \<le> (?v \<sqinter> -?i)\<^sup>T\<^sup>\<star> * ?e\<^sup>T * top"
         proof (rule boruvka_exchange_spanning_inv)
           show "forest ?v"
             using 10 spanning_forest_def by blast
         next
           show "?v\<^sup>\<star> * ?e\<^sup>T = ?e\<^sup>T"
             using 13 by (smt conv_complement conv_dist_comp conv_involutive conv_star_commute dense_pp fc_top regular_closed_top star_absorb)
         next
           show "?i \<le> ?v \<sqinter> top * ?e\<^sup>T * ?w\<^sup>T\<^sup>\<star>"
             using 18 inf.sup_monoid.add_assoc by auto
         next
           show "arc ?i"
             using 212 by blast
         next
           show "arc ?e"
             using assms(16) minarc_arc minarc_bot_iff by auto
         next
           show "?v \<le> --g"
             using 10 spanning_forest_def by blast
         next
           show "?w \<le> --g"
           proof -
             have 2231: "?e \<le> --g"
               by (metis inf.boundedE minarc_below pp_dist_inf)
             have "?w \<le> ?v \<squnion> ?e"
               using inf_le1 sup_left_isotone by simp
             also have "... \<le> --g"
               using 2231 10 spanning_forest_def sup_least by blast
             finally show ?thesis
               by blast
           qed
         next
           show "?e \<le> --g"
             by (metis inf.boundedE minarc_below pp_dist_inf)
         next
           show "components g \<le> forest_components ?v"
             by (simp add: 9)
         qed
         have "components g \<le> forest_components ?v"
           using 10 spanning_forest_def by auto
         also have "... \<le> forest_components ?w"
         proof (rule kruskal_exchange_forest_components_inv)
         next
           show "injective ((?v \<sqinter> -?i) \<squnion> ?e)"
             using 222 by simp
         next
           show "regular ?i"
             using 15 by simp
         next
           show "?e * top * ?e = ?e"
             by (metis arc_top_arc minarc_arc minarc_bot_iff semiring.mult_not_zero)
         next
           show "?i \<le> top * ?e\<^sup>T * ?v\<^sup>T\<^sup>\<star>"
             using 19 by blast
         next
           show "?v * ?e\<^sup>T * top = bot"
             using 13 by simp
         next
           show "injective ?v"
             using 8 by simp
         next
           show "?i \<le> ?v"
             by (simp add: le_infI1)
         next
           show "?i \<le> (?v \<sqinter> -?i)\<^sup>T\<^sup>\<star> * ?e\<^sup>T * top"
             using 223 by blast
         qed
         finally show "components g \<le> forest_components ?w"
           by simp
       next
         show "regular ?w"
           using 3 7 regular_conv_closed by simp
       qed
     next
       have 224: "?e \<sqinter> g \<noteq> bot"
         using assms(16) inf.left_commute inf_bot_right minarc_meet_bot by fastforce
       have 225: "sum (?e \<sqinter> g) \<le> sum (?i \<sqinter> g)"
       proof (rule a_to_e_in_forest_modulo_equivalence)
         show "symmetric g"
           using assms(1) boruvka_inner_invariant_def boruvka_outer_invariant_def by auto
       next
         show "j \<noteq> bot"
           by (simp add: assms(17))
       next
         show "f \<le> -- g"
           by (simp add: assms(3))
       next
         show "vector j"
           using assms(6) boruvka_inner_invariant_def by blast
       next
         show "forest h"
           by (simp add: assms(8))
       next
         show " forest_modulo_equivalence (forest_components h) d"
           by (simp add: assms(9))
       next
         show "f \<squnion> f\<^sup>T = h \<squnion> h\<^sup>T \<squnion> d \<squnion> d\<^sup>T"
           by (simp add: assms(12))
       next
         show "\<forall>a b. forest_modulo_equivalence_path a b (?H) d \<and> a \<le> - ?H \<sqinter> - - g \<and> b \<le> d \<longrightarrow> sum (b \<sqinter> g) \<le> sum (a \<sqinter> g)"
           by (simp add: assms(13))
       next
         show "regular d"
           using assms(14) by auto
       next
         show "?e = ?e"
           by simp
       next
         show "arc ?i"
           using 212 by blast
       next
         show "forest_modulo_equivalence_path ?i ?e ?H (d \<squnion> ?e)"
         proof -
           have "d\<^sup>T * ?H * ?e = bot"
             using assms(6, 7, 10 ,11, 17) dT_He_eq_bot le_bot by blast
           hence 251: "d\<^sup>T * ?H * ?e \<le> (?H * d)\<^sup>\<star> * ?H * ?e"
             by simp
           hence "d\<^sup>T * ?H * ?H * ?e \<le> (?H * d)\<^sup>\<star> * ?H * ?e"
             by (metis assms(8) forest_components_star star.circ_decompose_9 mult_assoc)
           hence "d\<^sup>T * (?H * d)\<^sup>\<star> * ?H * ?e \<le> (?H * d)\<^sup>\<star> * ?H * ?e"
           proof -
             have "d\<^sup>T * ?H * d \<le> 1"
               using assms(9) forest_modulo_equivalence_def dTransHd_le_1 by blast
             hence "d\<^sup>T * ?H * d * (?H * d)\<^sup>\<star> * ?H * ?e \<le> (?H * d)\<^sup>\<star> * ?H * ?e"
               by (metis mult_left_isotone star.circ_circ_mult star_involutive star_one)
             hence "d\<^sup>T * ?H * ?e \<squnion> d\<^sup>T * ?H * d * (?H * d)\<^sup>\<star> * ?H * ?e \<le> (?H * d)\<^sup>\<star> * ?H * ?e"
               using 251 by simp
             hence "d\<^sup>T * (1 \<squnion> ?H * d * (?H * d)\<^sup>\<star>) * ?H * ?e \<le> (?H * d)\<^sup>\<star> * ?H * ?e"
               by (simp add: comp_associative comp_left_dist_sup semiring.distrib_right)
             thus ?thesis
               by (simp add: star_left_unfold_equal)
           qed
           hence "?H * d\<^sup>T * (?H * d)\<^sup>\<star> * ?H * ?e \<le> ?H * (?H * d)\<^sup>\<star> * ?H * ?e"
             by (simp add: mult_right_isotone mult_assoc)
           hence "?H * d\<^sup>T * (?H * d)\<^sup>\<star> * ?H * ?e \<le> ?H * ?H * (d * ?H)\<^sup>\<star> * ?e"
             by (smt star_slide mult_assoc)
           hence "?H * d\<^sup>T * (?H * d)\<^sup>\<star> * ?H * ?e \<le> ?H * (d * ?H)\<^sup>\<star> * ?e"
             by (metis assms(8) forest_components_star star.circ_decompose_9)
           hence "?H * d\<^sup>T * (?H * d)\<^sup>\<star> * ?H * ?e \<le> (?H * d)\<^sup>\<star> * ?H * ?e"
             using star_slide by auto
           hence "?H * d * (?H * d)\<^sup>\<star> * ?H * ?e \<squnion> ?H * d\<^sup>T * (?H * d)\<^sup>\<star> * ?H * ?e \<le> (?H * d)\<^sup>\<star> * ?H * ?e"
             by (smt le_supI star.circ_loop_fixpoint sup.cobounded2 sup_commute mult_assoc)
           hence "(?H * (d \<squnion> d\<^sup>T)) * (?H * d)\<^sup>\<star> * ?H * ?e \<le> (?H * d)\<^sup>\<star> * ?H * ?e"
             by (simp add: semiring.distrib_left semiring.distrib_right)
           hence "(?H * (d \<squnion> d\<^sup>T))\<^sup>\<star> * (?H * d)\<^sup>\<star> * ?H * ?e \<le> (?H * d)\<^sup>\<star> * ?H * ?e"
             by (simp add: star_left_induct_mult mult_assoc)
           hence 252: "(?H * (d \<squnion> d\<^sup>T))\<^sup>\<star> * ?H * ?e \<le> (?H * d)\<^sup>\<star> * ?H * ?e"
             by (smt mult_left_dist_sup star.circ_transitive_equal star_slide star_sup_1 mult_assoc)
           have "?i \<le> top * ?e\<^sup>T * ?F"
             by auto
           hence "?i\<^sup>T \<le> ?F\<^sup>T * ?e\<^sup>T\<^sup>T * top\<^sup>T"
             by (simp add: conv_dist_comp conv_dist_inf mult_assoc)
           hence "?i\<^sup>T * top \<le> ?F\<^sup>T * ?e\<^sup>T\<^sup>T * top\<^sup>T * top"
             using comp_isotone by blast
           also have "... = ?F\<^sup>T * ?e\<^sup>T\<^sup>T * top\<^sup>T"
             by (simp add: vector_mult_closed)
           also have "... = ?F * ?e\<^sup>T\<^sup>T * top\<^sup>T"
             by (simp add: conv_dist_comp conv_star_commute)
           also have "... = ?F * ?e * top"
             by simp
           also have "... = (?H * (d \<squnion> d\<^sup>T))\<^sup>\<star> * ?H * ?e * top"
             using assms(2, 8, 12) F_is_H_and_d by simp
           also have "... \<le> (?H * d)\<^sup>\<star> * ?H * ?e * top"
             by (simp add: 252 comp_isotone)
           also have "... \<le> (?H * (d \<squnion> ?e))\<^sup>\<star> * ?H * ?e * top"
             by (simp add: comp_isotone star_isotone)
           finally have "?i\<^sup>T * top \<le> (?H * (d \<squnion> ?e))\<^sup>\<star> * ?H * ?e * top"
             by blast
           thus ?thesis
             using 212 assms(16) forest_modulo_equivalence_path_def minarc_arc minarc_bot_iff by blast
         qed
       next
         show "?i \<le> - ?H \<sqinter> -- g"
         proof -
           have "forest_components h \<le> forest_components f"
             using assms(2, 8, 12) H_below_F by blast
           then have 241: "?i \<le> -?H"
             using 16 assms(9) inf.order_lesseq_imp p_antitone_iff by blast
           have "?i \<le> -- g"
             using 10 inf.coboundedI1 spanning_forest_def by blast
           thus ?thesis
             using 241 inf_greatest by blast
         qed
       next
         show "regular h"
           using assms(18) by auto
       qed
       have "?v \<sqinter> ?e \<sqinter> -?i = bot"
         using 14 by simp
       hence "sum (?w \<sqinter> g) = sum (?v \<sqinter> -?i \<sqinter> g) + sum (?e \<sqinter> g)"
         using sum_disjoint inf_commute inf_assoc by simp
       also have "... \<le> sum (?v \<sqinter> -?i \<sqinter> g) + sum (?i \<sqinter> g)"
         using 224 225 sum_plus_right_isotone by simp
       also have "... = sum (((?v \<sqinter> -?i) \<squnion> ?i) \<sqinter> g)"
         using sum_disjoint inf_le2 pseudo_complement by simp
       also have "... = sum ((?v \<squnion> ?i) \<sqinter> (-?i \<squnion> ?i) \<sqinter> g)"
         by (simp add: sup_inf_distrib2)
       also have "... = sum ((?v \<squnion> ?i) \<sqinter> g)"
         using 15 by (metis inf_top_right stone)
       also have "... = sum (?v \<sqinter> g)"
         by (simp add: inf.sup_monoid.add_assoc)
       finally have "sum (?w \<sqinter> g) \<le> sum (?v \<sqinter> g)"
         by simp
       thus "\<forall>u . spanning_forest u g \<longrightarrow> sum (?w \<sqinter> g) \<le> sum (u \<sqinter> g)"
         using 2 11 minimum_spanning_forest_def by auto
     qed
   next
     have "?f \<le> f \<squnion> f\<^sup>T \<squnion> ?e"
       by (smt conv_dist_inf inf_le1 sup_left_isotone sup_mono inf.order_lesseq_imp)
     also have "... \<le> (?v \<sqinter> -?i \<sqinter> -?i\<^sup>T) \<squnion> (?v\<^sup>T \<sqinter> -?i \<sqinter> -?i\<^sup>T) \<squnion> ?e"
       using 20 sup_left_isotone by simp
     also have "... \<le> (?v \<sqinter> -?i) \<squnion> (?v\<^sup>T \<sqinter> -?i \<sqinter> -?i\<^sup>T) \<squnion> ?e"
       by (metis inf.cobounded1 sup_inf_distrib2)
     also have "... = ?w \<squnion> (?v\<^sup>T \<sqinter> -?i \<sqinter> -?i\<^sup>T)"
       by (simp add: sup_assoc sup_commute)
     also have "... \<le> ?w \<squnion> (?v\<^sup>T \<sqinter> -?i\<^sup>T)"
       using inf.sup_right_isotone inf_assoc sup_right_isotone by simp
     also have "... \<le> ?w \<squnion> ?w\<^sup>T"
       using conv_complement conv_dist_inf conv_dist_sup sup_right_isotone by simp
     finally show "?f \<le> ?w \<squnion> ?w\<^sup>T"
       by simp
   qed
   thus ?thesis by auto
 qed
 
 lemma boruvka_outer_invariant_when_e_not_bot:
   assumes "boruvka_inner_invariant j f h g d"
     and "j \<noteq> bot"
     and "selected_edge h j g \<le> - forest_components f"
     and "selected_edge h j g \<noteq> bot"
   shows "boruvka_outer_invariant (f \<sqinter> - selected_edge h j g\<^sup>T \<sqinter> - path f h j g \<squnion> (f \<sqinter> - selected_edge h j g\<^sup>T \<sqinter> path f h j g)\<^sup>T \<squnion> selected_edge h j g) g"
 proof -
   let ?c = "choose_component (forest_components h) j"
   let ?p = "path f h j g"
   let ?F = "forest_components f"
   let ?H = "forest_components h"
   let ?e = "selected_edge h j g"
   let ?f' = "f \<sqinter> -?e\<^sup>T \<sqinter> -?p \<squnion> (f \<sqinter> -?e\<^sup>T \<sqinter> ?p)\<^sup>T \<squnion> ?e"
   let ?d' = "d \<squnion> ?e"
   let ?j' = "j \<sqinter> -?c"
   show "boruvka_outer_invariant ?f' g"
   proof (unfold boruvka_outer_invariant_def, intro conjI)
     show "symmetric g"
       by (meson assms(1) boruvka_inner_invariant_def boruvka_outer_invariant_def)
   next
     show "injective ?f'"
     proof (rule kruskal_injective_inv)
       show "injective (f \<sqinter> - ?e\<^sup>T)"
         by (meson assms(1) boruvka_inner_invariant_def boruvka_outer_invariant_def injective_inf_closed)
       show "covector (?p)"
         using covector_mult_closed by simp
       show "?p * (f \<sqinter> - ?e\<^sup>T)\<^sup>T \<le> ?p"
         by (simp add: mult_right_isotone star.left_plus_below_circ star_plus mult_assoc)
       show "?e \<le> ?p"
         by (meson mult_left_isotone order.trans star_outer_increasing top.extremum)
       show "?p * (f \<sqinter> - ?e\<^sup>T)\<^sup>T \<le> - ?e"
       proof -
         have "?p * (f \<sqinter> - ?e\<^sup>T)\<^sup>T \<le> ?p * f\<^sup>T"
           by (simp add: conv_dist_inf mult_right_isotone)
         also have "... \<le> top * ?e * (f)\<^sup>T\<^sup>\<star> * f\<^sup>T"
           using conv_dist_inf star_isotone comp_isotone by simp
         also have "... \<le> - ?e"
           using assms(1, 4) boruvka_inner_invariant_def boruvka_outer_invariant_def kruskal_injective_inv_2 minarc_arc minarc_bot_iff by auto
         finally show ?thesis .
       qed
       show "injective (?e)"
         by (metis arc_injective coreflexive_bot_closed minarc_arc minarc_bot_iff semiring.mult_not_zero)
       show "coreflexive (?p\<^sup>T * ?p \<sqinter> (f \<sqinter> - ?e\<^sup>T)\<^sup>T * (f \<sqinter> - ?e\<^sup>T))"
       proof -
         have "(?p\<^sup>T * ?p \<sqinter> (f \<sqinter> - ?e\<^sup>T)\<^sup>T * (f \<sqinter> - ?e\<^sup>T)) \<le> ?p\<^sup>T * ?p \<sqinter> f\<^sup>T * f"
           using conv_dist_inf inf.sup_right_isotone mult_isotone by simp
         also have "... \<le> (top * ?e * f\<^sup>T\<^sup>\<star>)\<^sup>T * (top * ?e * f\<^sup>T\<^sup>\<star>) \<sqinter> f\<^sup>T * f"
           by (metis comp_associative comp_inf.coreflexive_transitive comp_inf.mult_right_isotone comp_isotone conv_isotone inf.cobounded1 inf.idem inf.sup_monoid.add_commute star_isotone top.extremum)
         also have "... \<le> 1"
           using assms(1, 4) boruvka_inner_invariant_def boruvka_outer_invariant_def kruskal_injective_inv_3 minarc_arc minarc_bot_iff by auto
         finally show ?thesis
           by simp
       qed
     qed
   next
     show "acyclic ?f'"
     proof (rule kruskal_acyclic_inv)
       show "acyclic (f \<sqinter> - ?e\<^sup>T)"
       proof -
         have f_intersect_below: "(f \<sqinter> - ?e\<^sup>T) \<le> f" by simp
         have "acyclic f"
           by (meson assms(1) boruvka_inner_invariant_def boruvka_outer_invariant_def)
         thus ?thesis
           using comp_isotone dual_order.trans star_isotone f_intersect_below by blast
       qed
     next
       show "covector ?p"
         by (metis comp_associative vector_top_closed)
     next
       show "(f \<sqinter> - ?e\<^sup>T \<sqinter> ?p)\<^sup>T * (f \<sqinter> - ?e\<^sup>T)\<^sup>\<star> * ?e = bot"
       proof -
         have "?e \<le> - (f\<^sup>T\<^sup>\<star> * f\<^sup>\<star>)"
           by (simp add: assms(3))
         hence "?e * top * ?e \<le> - (f\<^sup>T\<^sup>\<star> * f\<^sup>\<star>)"
           by (metis arc_top_arc minarc_arc minarc_bot_iff semiring.mult_not_zero)
         hence "?e\<^sup>T * top * ?e\<^sup>T \<le> - (f\<^sup>T\<^sup>\<star> * f\<^sup>\<star>)\<^sup>T"
           by (metis comp_associative conv_complement conv_dist_comp conv_isotone symmetric_top_closed)
         hence "?e\<^sup>T * top * ?e\<^sup>T \<le> - (f\<^sup>T\<^sup>\<star> * f\<^sup>\<star>)"
           by (simp add: conv_dist_comp conv_star_commute)
         hence "?e * (f\<^sup>T\<^sup>\<star> * f\<^sup>\<star>) * ?e \<le> bot"
           using triple_schroeder_p by auto
         hence 1: "?e * f\<^sup>T\<^sup>\<star> * f\<^sup>\<star> * ?e \<le> bot"
           using mult_assoc by auto
         have 2: "(f \<sqinter> - ?e\<^sup>T)\<^sup>T\<^sup>\<star> \<le> f\<^sup>T\<^sup>\<star>"
           by (simp add: conv_dist_inf star_isotone)
         have "(f \<sqinter> - ?e\<^sup>T \<sqinter> ?p)\<^sup>T * (f \<sqinter> - ?e\<^sup>T)\<^sup>\<star> * ?e \<le> (f \<sqinter> ?p)\<^sup>T * (f \<sqinter> - ?e\<^sup>T)\<^sup>\<star> * ?e"
           by (simp add: comp_isotone conv_dist_inf inf.orderI inf.sup_monoid.add_assoc)
         also have "... \<le> (f \<sqinter> ?p)\<^sup>T * f\<^sup>\<star> * ?e"
           by (simp add: comp_isotone star_isotone)
         also have "... \<le> (f \<sqinter> top * ?e * (f)\<^sup>T\<^sup>\<star>)\<^sup>T * f\<^sup>\<star> * ?e"
           using 2 by (metis comp_inf.comp_isotone comp_inf.coreflexive_transitive comp_isotone conv_isotone inf.idem top.extremum)
         also have "... = (f\<^sup>T \<sqinter> (top * ?e * f\<^sup>T\<^sup>\<star>)\<^sup>T) * f\<^sup>\<star> * ?e"
           by (simp add: conv_dist_inf)
         also have "... \<le> top * (f\<^sup>T \<sqinter> (top * ?e * f\<^sup>T\<^sup>\<star>)\<^sup>T) * f\<^sup>\<star> * ?e"
           using top_left_mult_increasing mult_assoc by auto
         also have "... = (top \<sqinter> top * ?e * f\<^sup>T\<^sup>\<star>) * f\<^sup>T * f\<^sup>\<star> * ?e"
           by (smt covector_comp_inf_1 covector_mult_closed order.eq_iff inf.sup_monoid.add_commute vector_top_closed)
         also have "... = top * ?e * f\<^sup>T\<^sup>\<star> * f\<^sup>T * f\<^sup>\<star> * ?e"
           by simp
         also have "... \<le> top * ?e * f\<^sup>T\<^sup>\<star> * f\<^sup>\<star> * ?e"
           by (smt conv_dist_comp conv_isotone conv_star_commute mult_left_isotone mult_right_isotone star.left_plus_below_circ mult_assoc)
         also have "... \<le> bot"
           using 1 covector_bot_closed le_bot mult_assoc by fastforce
         finally show ?thesis
           using le_bot by auto
       qed
     next
       show "?e * (f \<sqinter> - ?e\<^sup>T)\<^sup>\<star> * ?e = bot"
       proof -
         have 1: "?e \<le> - ?F"
           by (simp add: assms(3))
         have 2: "injective f"
           by (meson assms(1) boruvka_inner_invariant_def boruvka_outer_invariant_def)
         have 3: "equivalence ?F"
           using 2 forest_components_equivalence by simp
         hence 4: "?e\<^sup>T = ?e\<^sup>T * top * ?e\<^sup>T"
           by (smt arc_conv_closed arc_top_arc covector_complement_closed covector_conv_vector ex231e minarc_arc minarc_bot_iff pp_surjective regular_closed_top vector_mult_closed vector_top_closed)
         also have "... \<le> - ?F" using 1 3 conv_isotone conv_complement calculation by fastforce
         finally have 5: "?e * ?F * ?e = bot"
           using 4 by (smt triple_schroeder_p le_bot pp_total regular_closed_top vector_top_closed)
         have "(f \<sqinter> - ?e\<^sup>T)\<^sup>\<star> \<le> f\<^sup>\<star>"
           by (simp add: star_isotone)
         hence "?e * (f \<sqinter> - ?e\<^sup>T)\<^sup>\<star> * ?e \<le> ?e * f\<^sup>\<star> * ?e"
           using mult_left_isotone mult_right_isotone by blast
         also have "... \<le> ?e * ?F * ?e"
           by (metis conv_star_commute forest_components_increasing mult_left_isotone mult_right_isotone star_involutive)
         also have 6: "... = bot"
           using 5 by simp
         finally show ?thesis using 6 le_bot by blast
       qed
     next
       show "forest_components (f \<sqinter> -?e\<^sup>T) \<le> - ?e"
       proof -
         have 1: "?e \<le> - ?F"
           by (simp add: assms(3))
         have "f \<sqinter> - ?e\<^sup>T \<le> f"
           by simp
         hence "forest_components (f \<sqinter> - ?e\<^sup>T) \<le> ?F"
           using forest_components_isotone by blast
         thus ?thesis
           using 1 order_lesseq_imp p_antitone_iff by blast
       qed
     qed
   next
     show "?f' \<le> --g"
     proof -
       have 1: "(f \<sqinter> - ?e\<^sup>T \<sqinter> - ?p) \<le> --g"
         by (meson assms(1) boruvka_inner_invariant_def boruvka_outer_invariant_def inf.coboundedI1)
       have 2: "(f \<sqinter> - ?e\<^sup>T \<sqinter> ?p)\<^sup>T \<le> --g"
       proof -
         have "(f \<sqinter> - ?e\<^sup>T \<sqinter> ?p)\<^sup>T \<le> f\<^sup>T"
           by (simp add: conv_isotone inf.sup_monoid.add_assoc)
         also have "... \<le> --g"
           by (metis assms(1) boruvka_inner_invariant_def boruvka_outer_invariant_def conv_complement conv_isotone)
         finally show ?thesis
           by simp
       qed
       have 3: "?e \<le> --g"
         by (metis inf.boundedE minarc_below pp_dist_inf)
       show ?thesis using 1 2 3
         by simp
     qed
   next
     show "regular ?f'"
       using assms(1) boruvka_inner_invariant_def boruvka_outer_invariant_def minarc_regular regular_closed_star regular_conv_closed regular_mult_closed by auto
   next
     show "\<exists>w. minimum_spanning_forest w g \<and> ?f' \<le> w \<squnion> w\<^sup>T"
     proof (rule exists_a_w)
       show "symmetric g"
         using assms(1) boruvka_inner_invariant_def boruvka_outer_invariant_def by auto
     next
       show "forest f"
         using assms(1) boruvka_inner_invariant_def boruvka_outer_invariant_def by auto
     next
       show "f \<le> --g"
         using assms(1) boruvka_inner_invariant_def boruvka_outer_invariant_def by auto
     next
       show "regular f"
         using assms(1) boruvka_inner_invariant_def boruvka_outer_invariant_def by auto
     next
       show "(\<exists>w . minimum_spanning_forest w g \<and> f \<le> w \<squnion> w\<^sup>T)"
         using assms(1) boruvka_inner_invariant_def boruvka_outer_invariant_def by auto
     next
       show "vector j"
         using assms(1) boruvka_inner_invariant_def by blast
     next
       show "regular j"
         using assms(1) boruvka_inner_invariant_def by blast
     next
       show "forest h"
         using assms(1) boruvka_inner_invariant_def by blast
     next
       show "forest_modulo_equivalence (forest_components h) d"
         using assms(1) boruvka_inner_invariant_def by blast
     next
       show "d * top \<le> - j"
         using assms(1) boruvka_inner_invariant_def by blast
     next
       show "forest_components h * j = j"
         using assms(1) boruvka_inner_invariant_def by blast
     next
       show "f \<squnion> f\<^sup>T = h \<squnion> h\<^sup>T \<squnion> d \<squnion> d\<^sup>T"
         using assms(1) boruvka_inner_invariant_def by blast
     next
       show "(\<forall> a b . forest_modulo_equivalence_path a b (forest_components h) d \<and> a \<le> -(forest_components h) \<sqinter> -- g \<and> b \<le> d \<longrightarrow> sum(b \<sqinter> g) \<le> sum(a \<sqinter> g))"
         using assms(1) boruvka_inner_invariant_def by blast
     next
       show "regular d"
         using assms(1) boruvka_inner_invariant_def by blast
     next
       show "selected_edge h j g \<le> - forest_components f"
         by (simp add: assms(3))
     next
       show "selected_edge h j g \<noteq> bot"
         by (simp add: assms(4))
     next
       show "j \<noteq> bot"
         by (simp add: assms(2))
     next
       show "regular h"
         using assms(1) boruvka_inner_invariant_def boruvka_outer_invariant_def by auto
     next
       show "h \<le> --g"
         using H_below_regular_g assms(1) boruvka_inner_invariant_def boruvka_outer_invariant_def by auto
     qed
   qed
 qed
 
 lemma second_inner_invariant_when_e_not_bot:
   assumes "boruvka_inner_invariant j f h g d"
     and "j \<noteq> bot"
     and "selected_edge h j g \<le> - forest_components f"
     and "selected_edge h j g \<noteq> bot"
   shows "boruvka_inner_invariant
          (j \<sqinter> - choose_component (forest_components h) j)
          (f \<sqinter> - selected_edge h j g\<^sup>T \<sqinter> - path f h j g \<squnion>
           (f \<sqinter> - selected_edge h j g\<^sup>T \<sqinter> path f h j g)\<^sup>T \<squnion>
           selected_edge h j g)
          h g (d \<squnion> selected_edge h j g)"
 proof -
   let ?c = "choose_component (forest_components h) j"
   let ?p = "path f h j g"
   let ?F = "forest_components f"
   let ?H = "forest_components h"
   let ?e = "selected_edge h j g"
   let ?f' = "f \<sqinter> -?e\<^sup>T \<sqinter> -?p \<squnion> (f \<sqinter> -?e\<^sup>T \<sqinter> ?p)\<^sup>T \<squnion> ?e"
   let ?d' = "d \<squnion> ?e"
   let ?j' = "j \<sqinter> -?c"
   show "boruvka_inner_invariant ?j' ?f' h g ?d'"
   proof (unfold boruvka_inner_invariant_def, intro conjI)
     show 1: "boruvka_outer_invariant ?f' g"
       using assms(1, 2, 3, 4) boruvka_outer_invariant_when_e_not_bot by blast
   next
     show "g \<noteq> bot"
       using assms(1) boruvka_inner_invariant_def by force
   next
     show "regular ?d'"
       using assms(1) boruvka_inner_invariant_def minarc_regular by auto
   next
     show "regular ?j'"
       using assms(1) boruvka_inner_invariant_def by auto
   next
     show "vector ?j'"
       using assms(1, 2) boruvka_inner_invariant_def component_is_vector vector_complement_closed vector_inf_closed by simp
   next
     show "regular h"
       by (meson assms(1) boruvka_inner_invariant_def)
   next
     show "injective h"
       by (meson assms(1) boruvka_inner_invariant_def)
   next
     show "pd_kleene_allegory_class.acyclic h"
       by (meson assms(1) boruvka_inner_invariant_def)
   next
     show "?H * ?j' = ?j'"
       using fc_j_eq_j_inv assms(1) boruvka_inner_invariant_def by blast
   next
     show "forest_modulo_equivalence ?H ?d'"
       using assms(1, 2, 3) forest_modulo_equivalence_d_U_e boruvka_inner_invariant_def boruvka_outer_invariant_def by auto
   next
     show "?d' * top \<le> -?j'"
     proof -
       have 31: "?d' * top = d * top \<squnion> ?e * top"
         by (simp add: mult_right_dist_sup)
       have 32: "d * top \<le> -?j'"
         by (meson assms(1) boruvka_inner_invariant_def inf.coboundedI1 p_antitone_iff)
       have "regular (?c * - ?c\<^sup>T)"
         using assms(1) boruvka_inner_invariant_def boruvka_outer_invariant_def component_is_regular regular_conv_closed regular_mult_closed by presburger
       then have "minarc(?c * - ?c\<^sup>T \<sqinter> g) = minarc(?c \<sqinter> - ?c\<^sup>T \<sqinter> g)"
         by (metis component_is_vector covector_comp_inf inf_top.left_neutral vector_conv_compl)
       also have "... \<le> -- (?c \<sqinter> - ?c\<^sup>T \<sqinter> g)"
         using minarc_below by blast
       also have "... \<le> -- ?c"
         by (simp add: inf.sup_monoid.add_assoc)
       also have "... = ?c"
         using component_is_regular by auto
       finally have "?e \<le> ?c"
         by simp
       then have "?e * top \<le> ?c"
         by (metis component_is_vector mult_left_isotone)
       also have "... \<le> -j \<squnion> ?c"
         by simp
       also have "... = - (j \<sqinter> - ?c)"
         using component_is_regular by auto
       finally have 33: "?e * top \<le> - (j \<sqinter> - ?c)"
         by simp
       show ?thesis
         using 31 32 33 by auto
     qed
   next
     show "?f' \<squnion> ?f'\<^sup>T = h \<squnion> h\<^sup>T \<squnion> ?d' \<squnion> ?d'\<^sup>T"
     proof -
       have "?f' \<squnion> ?f'\<^sup>T = f \<sqinter> - ?e\<^sup>T \<sqinter> - ?p \<squnion> (f \<sqinter> - ?e\<^sup>T \<sqinter> ?p)\<^sup>T \<squnion> ?e \<squnion> (f \<sqinter> - ?e\<^sup>T \<sqinter> - ?p)\<^sup>T \<squnion> (f \<sqinter> - ?e\<^sup>T \<sqinter> ?p) \<squnion> ?e\<^sup>T"
         by (simp add: conv_dist_sup sup_monoid.add_assoc)
       also have "... = (f \<sqinter> - ?e\<^sup>T \<sqinter> - ?p) \<squnion> (f \<sqinter> - ?e\<^sup>T \<sqinter> ?p) \<squnion> (f \<sqinter> - ?e\<^sup>T \<sqinter> ?p)\<^sup>T \<squnion> (f \<sqinter> - ?e\<^sup>T \<sqinter> - ?p)\<^sup>T \<squnion> ?e\<^sup>T \<squnion> ?e"
         by (simp add: sup.left_commute sup_commute)
       also have "... = f \<squnion> f\<^sup>T \<squnion> ?e \<squnion> ?e\<^sup>T"
       proof (rule simplify_f)
         show "regular ?p"
           using assms(1) boruvka_inner_invariant_def boruvka_outer_invariant_def minarc_regular regular_closed_star regular_conv_closed regular_mult_closed by auto
       next
         show "regular ?e"
           using minarc_regular by blast
       qed
       also have "... = h \<squnion> h\<^sup>T \<squnion> d \<squnion> d\<^sup>T \<squnion> ?e \<squnion> ?e\<^sup>T"
         using assms(1) boruvka_inner_invariant_def by auto
       finally show ?thesis
         by (smt conv_dist_sup sup.left_commute sup_commute)
     qed
   next
     show "\<forall> a b . forest_modulo_equivalence_path a b ?H ?d' \<and> a \<le> - ?H \<sqinter> -- g \<and> b \<le> ?d' \<longrightarrow> sum (b \<sqinter> g) \<le> sum (a \<sqinter> g)"
     proof (intro allI, rule impI, unfold forest_modulo_equivalence_path_def)
       fix a b
       assume 1: "(arc a \<and> arc b \<and> a\<^sup>T * top \<le> (?H * ?d')\<^sup>\<star> * ?H * b * top) \<and> a \<le> - ?H \<sqinter> -- g \<and> b \<le> ?d'"
       thus "sum (b \<sqinter> g) \<le> sum (a \<sqinter> g)"
       proof (cases "b = ?e")
         case b_equals_e: True
         thus ?thesis
         proof (cases "a = ?e")
           case True
           thus ?thesis
             using b_equals_e by auto
         next
           case a_ne_e: False
           have "sum (b \<sqinter> g) \<le> sum (a \<sqinter> g)"
           proof (rule a_to_e_in_forest_modulo_equivalence)
             show "symmetric g"
               using assms(1) boruvka_inner_invariant_def boruvka_outer_invariant_def by auto
           next
             show "j \<noteq> bot"
               by (simp add: assms(2))
           next
             show "f \<le> -- g"
               using assms(1) boruvka_inner_invariant_def boruvka_outer_invariant_def by auto
           next
             show "vector j"
               using assms(1) boruvka_inner_invariant_def by blast
           next
             show "forest h"
               using assms(1) boruvka_inner_invariant_def by blast
           next
             show "forest_modulo_equivalence (forest_components h) d"
               using assms(1) boruvka_inner_invariant_def by blast
           next
             show "f \<squnion> f\<^sup>T = h \<squnion> h\<^sup>T \<squnion> d \<squnion> d\<^sup>T"
               using assms(1) boruvka_inner_invariant_def by blast
           next
             show "\<forall>a b. forest_modulo_equivalence_path a b (?H) d \<and> a \<le> - ?H \<sqinter> - - g \<and> b \<le> d \<longrightarrow> sum (b \<sqinter> g) \<le> sum (a \<sqinter> g)"
               using assms(1) boruvka_inner_invariant_def by blast
           next
             show "regular d"
               using assms(1) boruvka_inner_invariant_def by blast
           next
             show "b = ?e"
               using b_equals_e by simp
           next
             show "arc a"
               using 1 by simp
           next
             show "forest_modulo_equivalence_path a b ?H ?d'"
               using 1 forest_modulo_equivalence_path_def by simp
           next
             show "a \<le> - ?H \<sqinter> -- g"
               using 1 by simp
           next
             show "regular h"
               using assms(1) boruvka_inner_invariant_def boruvka_outer_invariant_def by auto
           qed
           thus ?thesis
             by simp
         qed
       next
         case b_not_equal_e: False
         then have b_below_d: "b \<le> d"
           using 1 assms(4) different_arc_in_sup_arc minarc_arc minarc_bot_iff by metis
         thus ?thesis
         proof (cases "?e \<le> d")
           case True
           then have "forest_modulo_equivalence_path a b ?H d \<and> b \<le> d"
             using 1 forest_modulo_equivalence_path_def sup.absorb1 by auto
           thus ?thesis
             using 1 assms(1) boruvka_inner_invariant_def by blast
         next
           case e_not_less_than_d: False
           have 71:"equivalence ?H"
             using assms(1) fch_equivalence boruvka_inner_invariant_def by auto
           then have 72: "forest_modulo_equivalence_path a b ?H ?d' \<longleftrightarrow> forest_modulo_equivalence_path a b ?H d \<or> (forest_modulo_equivalence_path a ?e ?H d \<and> forest_modulo_equivalence_path ?e b ?H d)"
           proof (rule forest_modulo_equivalence_path_split_disj)
             show "arc ?e"
               using assms(4) minarc_arc minarc_bot_iff by blast
           next
             show "regular a \<and> regular b \<and> regular ?e \<and> regular d \<and> regular ?H"
               using assms(1) 1 boruvka_inner_invariant_def boruvka_outer_invariant_def arc_regular minarc_regular regular_closed_star regular_conv_closed regular_mult_closed by auto
           qed
           thus ?thesis
           proof (cases "forest_modulo_equivalence_path a b ?H d")
             case True
             have "forest_modulo_equivalence_path a b ?H d \<and> b \<le> d"
               using 1 True forest_modulo_equivalence_path_def sup.absorb1 by (metis assms(4) b_not_equal_e minarc_arc minarc_bot_iff different_arc_in_sup_arc)
             thus ?thesis
               using 1 assms(1) b_below_d boruvka_inner_invariant_def by auto
           next
             case False
             have 73:"forest_modulo_equivalence_path a ?e ?H d \<and> forest_modulo_equivalence_path ?e b ?H d"
               using 1 72 False forest_modulo_equivalence_path_def by blast
             have 74: "?e \<le> --g"
               by (metis inf.boundedE minarc_below pp_dist_inf)
             have "?H \<le> ?F"
                 using assms(1) H_below_F boruvka_inner_invariant_def boruvka_outer_invariant_def by blast
             then have "?e \<le> - ?H"
               using assms(3) order_trans p_antitone by blast
             then have "?e \<le> - ?H \<sqinter> --g"
               using 74 by simp
             then have 75: "sum (b \<sqinter> g) \<le> sum (?e \<sqinter> g)"
               using assms(1) b_below_d 73 boruvka_inner_invariant_def by blast
             have 76: "forest_modulo_equivalence_path a ?e ?H ?d'"
               by (meson 73 forest_modulo_equivalence_path_split_disj assms(1) forest_modulo_equivalence_path_def boruvka_inner_invariant_def boruvka_outer_invariant_def fch_equivalence arc_regular regular_closed_star regular_conv_closed regular_mult_closed)
             have 77: "sum (?e \<sqinter> g) \<le> sum (a \<sqinter> g)"
             proof (rule a_to_e_in_forest_modulo_equivalence)
               show "symmetric g"
                 using assms(1) boruvka_inner_invariant_def boruvka_outer_invariant_def by auto
             next
               show "j \<noteq> bot"
                 by (simp add: assms(2))
             next
               show "f \<le> -- g"
                 using assms(1) boruvka_inner_invariant_def boruvka_outer_invariant_def by auto
             next
               show "vector j"
                 using assms(1) boruvka_inner_invariant_def by blast
             next
               show "forest h"
                 using assms(1) boruvka_inner_invariant_def by blast
             next
               show "forest_modulo_equivalence (forest_components h) d"
                 using assms(1) boruvka_inner_invariant_def by blast
             next
               show "f \<squnion> f\<^sup>T = h \<squnion> h\<^sup>T \<squnion> d \<squnion> d\<^sup>T"
                 using assms(1) boruvka_inner_invariant_def by blast
             next
               show "\<forall>a b. forest_modulo_equivalence_path a b (?H) d \<and> a \<le> - ?H \<sqinter> - - g \<and> b \<le> d \<longrightarrow> sum (b \<sqinter> g) \<le> sum (a \<sqinter> g)"
                 using assms(1) boruvka_inner_invariant_def by blast
             next
               show "regular d"
                 using assms(1) boruvka_inner_invariant_def by blast
             next
               show "?e = ?e"
                 by simp
             next
               show "arc a"
                 using 1 by simp
             next
               show "forest_modulo_equivalence_path a ?e ?H ?d'"
                 by (simp add: "76")
             next
               show "a \<le> - ?H \<sqinter> --g"
                 using 1 by simp
             next
               show "regular h"
                 using assms(1) boruvka_inner_invariant_def boruvka_outer_invariant_def by auto
             qed
             thus ?thesis
               using 75 order.trans by blast
           qed
         qed
       qed
     qed
   qed
 qed
 
 lemma second_inner_invariant_when_e_bot:
   assumes "selected_edge h j g = bot"
     and "selected_edge h j g \<le> - forest_components f"
     and "boruvka_inner_invariant j f h g d"
   shows "boruvka_inner_invariant
      (j \<sqinter> - choose_component (forest_components h) j)
      (f \<sqinter> - selected_edge h j g\<^sup>T \<sqinter> - path f h j g \<squnion>
       (f \<sqinter> - selected_edge h j g\<^sup>T \<sqinter> path f h j g)\<^sup>T \<squnion>
       selected_edge h j g)
      h g (d \<squnion> selected_edge h j g)"
 proof -
   let ?c = "choose_component (forest_components h) j"
   let ?p = "path f h j g"
   let ?F = "forest_components f"
   let ?H = "forest_components h"
   let ?e = "selected_edge h j g"
   let ?f' = "f \<sqinter> -?e\<^sup>T \<sqinter> -?p \<squnion> (f \<sqinter> -?e\<^sup>T \<sqinter> ?p)\<^sup>T \<squnion> ?e"
   let ?d' = "d \<squnion> ?e"
   let ?j' = "j \<sqinter> -?c"
   show "boruvka_inner_invariant ?j' ?f' h g ?d'"
   proof (unfold boruvka_inner_invariant_def, intro conjI)
   next
     show "boruvka_outer_invariant ?f' g"
       using assms(1) assms(3) boruvka_inner_invariant_def by auto
   next
     show "g \<noteq> bot"
       using assms(3) boruvka_inner_invariant_def by blast
   next
     show "regular ?d'"
       using assms(1) assms(3) boruvka_inner_invariant_def by auto
   next
     show "regular ?j'"
       using assms(3) boruvka_inner_invariant_def by auto
   next
     show "vector ?j'"
       by (metis assms(3) boruvka_inner_invariant_def component_is_vector vector_complement_closed vector_inf_closed)
   next
     show "regular h"
       using assms(3) boruvka_inner_invariant_def by blast
   next
     show "injective h"
       using assms(3) boruvka_inner_invariant_def by blast
   next
     show "pd_kleene_allegory_class.acyclic h"
       using assms(3) boruvka_inner_invariant_def by blast
   next
     show "?H * ?j' = ?j'"
       using assms(3) fc_j_eq_j_inv boruvka_inner_invariant_def by blast
   next
     show "forest_modulo_equivalence ?H ?d'"
       using assms(1) assms(3) boruvka_inner_invariant_def by auto
   next
     show "?d' * top \<le> -?j'"
       using assms(1) assms(3) boruvka_inner_invariant_def by (metis order.trans p_antitone_inf sup_monoid.add_0_right)
   next
     show "?f' \<squnion> ?f'\<^sup>T = h \<squnion> h\<^sup>T \<squnion> ?d' \<squnion> ?d'\<^sup>T"
       using assms(1, 3) boruvka_inner_invariant_def by auto
   next
     show "\<forall>a b. forest_modulo_equivalence_path a b ?H ?d' \<and> a \<le> -?H \<sqinter> --g \<and> b \<le> ?d' \<longrightarrow> sum(b \<sqinter> g) \<le> sum(a \<sqinter> g)"
       using assms(1, 3) boruvka_inner_invariant_def by auto
   qed
 qed
 
 subsection \<open>Formalization and correctness proof\<close>
 
 text \<open>
 The following result shows that Bor\r{u}vka's algorithm constructs a minimum spanning forest.
 We have the same postcondition as the proof of Kruskal's minimum spanning tree algorithm.
 We show only partial correctness.
 \<close>
 
 theorem boruvka_mst:
   "VARS f j h c e d
   { symmetric g }
   f := bot;
   WHILE -(forest_components f) \<sqinter> g \<noteq> bot
     INV { boruvka_outer_invariant f g }
     DO
       j := top;
       h := f;
       d := bot;
       WHILE j \<noteq> bot
         INV { boruvka_inner_invariant j f h g d }
         DO
           c := choose_component (forest_components h) j;
           e := minarc(c * -c\<^sup>T \<sqinter> g);
           IF e \<le> -(forest_components f) THEN
             f := f \<sqinter> -e\<^sup>T;
             f := (f \<sqinter> -(top * e * f\<^sup>T\<^sup>\<star>)) \<squnion> (f \<sqinter> top * e * f\<^sup>T\<^sup>\<star>)\<^sup>T \<squnion> e;
             d := d \<squnion> e
           ELSE
             SKIP
           FI;
           j := j \<sqinter> -c
         OD
     OD
   { minimum_spanning_forest f g }"
 proof vcg_simp
   assume 1: "symmetric g"
   show "boruvka_outer_invariant bot g"
     using 1 boruvka_outer_invariant_def kruskal_exists_minimal_spanning by auto
 next
   fix f
   let ?F = "forest_components f"
   assume 1: "boruvka_outer_invariant f g \<and> - ?F \<sqinter> g \<noteq> bot"
   have 2: "equivalence ?F"
     using 1 boruvka_outer_invariant_def forest_components_equivalence by auto
   show "boruvka_inner_invariant top f f g bot"
   proof (unfold boruvka_inner_invariant_def, intro conjI)
     show "boruvka_outer_invariant f g"
       by (simp add: 1)
   next
     show "g \<noteq> bot"
       using 1 by auto
   next
     show "surjective top"
       by simp
   next
     show "regular top"
       by simp
   next
     show "regular bot"
       by auto
   next
     show "regular f"
       using 1 boruvka_outer_invariant_def by blast
   next
     show "injective f"
       using 1 boruvka_outer_invariant_def by blast
   next
     show "pd_kleene_allegory_class.acyclic f"
       using 1 boruvka_outer_invariant_def by blast
   next
     show "forest_modulo_equivalence ?F bot"
       by (simp add: 2 forest_modulo_equivalence_def)
   next
     show "bot * top \<le> - top"
       by simp
   next
     show "times_top_class.total (?F)"
       by (simp add: star.circ_right_top mult_assoc)
   next
     show "f \<squnion> f\<^sup>T = f \<squnion> f\<^sup>T \<squnion> bot \<squnion> bot\<^sup>T"
       by simp
   next
     show "\<forall> a b. forest_modulo_equivalence_path a b ?F bot \<and> a \<le> - ?F \<sqinter> -- g \<and> b \<le> bot \<longrightarrow> sum (b \<sqinter> g) \<le> sum (a \<sqinter> g)"
       by (metis (full_types) forest_modulo_equivalence_path_def bot_unique mult_left_zero mult_right_zero top.extremum)
   qed
 next
   fix f j h d
   let ?c = "choose_component (forest_components h) j"
   let ?p = "path f h j g"
   let ?F = "forest_components f"
   let ?H = "forest_components h"
   let ?e = "selected_edge h j g"
   let ?f' = "f \<sqinter> -?e\<^sup>T \<sqinter> -?p \<squnion> (f \<sqinter> -?e\<^sup>T \<sqinter> ?p)\<^sup>T \<squnion> ?e"
   let ?d' = "d \<squnion> ?e"
   let ?j' = "j \<sqinter> -?c"
   assume 1: "boruvka_inner_invariant j f h g d \<and> j \<noteq> bot"
   show "(?e \<le> -?F \<longrightarrow> boruvka_inner_invariant ?j' ?f' h g ?d') \<and> (\<not> ?e \<le> -?F \<longrightarrow> boruvka_inner_invariant ?j' f h g d)"
   proof (intro conjI)
     show "?e \<le> -?F \<longrightarrow> boruvka_inner_invariant ?j' ?f' h g ?d'"
     proof (cases "?e = bot")
       case True
       thus ?thesis
         using 1 second_inner_invariant_when_e_bot by simp
     next
       case False
       thus ?thesis
         using 1 second_inner_invariant_when_e_not_bot by simp
     qed
   next
     show "\<not> ?e \<le> -?F \<longrightarrow> boruvka_inner_invariant ?j' f h g d"
     proof (rule impI, unfold boruvka_inner_invariant_def, intro conjI)
       show "boruvka_outer_invariant f g"
         using 1 boruvka_inner_invariant_def by blast
     next
       show "g \<noteq> bot"
         using 1 boruvka_inner_invariant_def by blast
     next
       show "vector ?j'"
         using 1 boruvka_inner_invariant_def component_is_vector vector_complement_closed vector_inf_closed by auto
     next
       show "regular ?j'"
         using 1 boruvka_inner_invariant_def by auto
     next
       show "regular d"
         using 1 boruvka_inner_invariant_def by blast
     next
       show "regular h"
         using 1 boruvka_inner_invariant_def by blast
     next
       show "injective h"
         using 1 boruvka_inner_invariant_def by blast
     next
       show "pd_kleene_allegory_class.acyclic h"
         using 1 boruvka_inner_invariant_def by blast
     next
       show "forest_modulo_equivalence ?H d"
         using 1 boruvka_inner_invariant_def by blast
     next
       show "d * top \<le> -?j'"
         using 1 by (meson boruvka_inner_invariant_def dual_order.trans p_antitone_inf)
     next
       show "?H * ?j' = ?j'"
         using 1 fc_j_eq_j_inv boruvka_inner_invariant_def by blast
     next
       show "f \<squnion> f\<^sup>T = h \<squnion> h\<^sup>T \<squnion> d \<squnion> d\<^sup>T"
         using 1 boruvka_inner_invariant_def by blast
     next
       show "\<not> ?e \<le> -?F \<Longrightarrow> \<forall>a b. forest_modulo_equivalence_path a b ?H d \<and> a \<le> -?H \<sqinter> --g \<and> b \<le> d \<longrightarrow> sum(b \<sqinter> g) \<le> sum(a \<sqinter> g)"
         using 1 boruvka_inner_invariant_def by blast
     qed
   qed
 next
   fix f h d
   assume "boruvka_inner_invariant bot f h g d"
   thus "boruvka_outer_invariant f g"
     by (meson boruvka_inner_invariant_def)
 next
   fix f
   assume 1: "boruvka_outer_invariant f g \<and> - forest_components f \<sqinter> g = bot"
   hence 2:"spanning_forest f g"
   proof (unfold spanning_forest_def, intro conjI)
     show "injective f"
       using 1 boruvka_outer_invariant_def by blast
   next
     show "acyclic f"
       using 1 boruvka_outer_invariant_def by blast
   next
     show "f \<le> --g"
       using 1 boruvka_outer_invariant_def by blast
   next
     show "components g \<le> forest_components f"
     proof -
       let ?F = "forest_components f"
       have "-?F \<sqinter> g \<le> bot"
         by (simp add: 1)
       hence "--g \<le> bot \<squnion> --?F"
         using 1 shunting_p p_antitone pseudo_complement by auto
       hence "--g \<le> ?F"
         using 1 boruvka_outer_invariant_def pp_dist_comp pp_dist_star regular_conv_closed by auto
       hence "(--g)\<^sup>\<star> \<le> ?F\<^sup>\<star>"
         by (simp add: star_isotone)
       thus ?thesis
         using 1 boruvka_outer_invariant_def forest_components_star by auto
     qed
   next
     show "regular f"
       using 1 boruvka_outer_invariant_def by auto
   qed
   from 1 obtain w where 3: "minimum_spanning_forest w g \<and> f \<le> w \<squnion> w\<^sup>T"
     using boruvka_outer_invariant_def by blast
   hence "w = w \<sqinter> --g"
     by (simp add: inf.absorb1 minimum_spanning_forest_def spanning_forest_def)
   also have "... \<le> w \<sqinter> components g"
     by (metis inf.sup_right_isotone star.circ_increasing)
   also have "... \<le> w \<sqinter> f\<^sup>T\<^sup>\<star> * f\<^sup>\<star>"
     using 2 spanning_forest_def inf.sup_right_isotone by simp
   also have "... \<le> f \<squnion> f\<^sup>T"
   proof (rule cancel_separate_6[where z=w and y="w\<^sup>T"])
     show "injective w"
       using 3 minimum_spanning_forest_def spanning_forest_def by simp
   next
     show "f\<^sup>T \<le> w\<^sup>T \<squnion> w"
       using 3 by (metis conv_dist_inf conv_dist_sup conv_involutive inf.cobounded2 inf.orderE)
   next
     show "f \<le> w\<^sup>T \<squnion> w"
       using 3 by (simp add: sup_commute)
   next
     show "injective w"
       using 3 minimum_spanning_forest_def spanning_forest_def by simp
   next
     show "w \<sqinter> w\<^sup>T\<^sup>\<star> = bot"
       using 3 by (metis acyclic_star_below_complement comp_inf.mult_right_isotone inf_p le_bot minimum_spanning_forest_def spanning_forest_def)
   qed
   finally have 4: "w \<le> f \<squnion> f\<^sup>T"
     by simp
   have "sum (f \<sqinter> g) = sum ((w \<squnion> w\<^sup>T) \<sqinter> (f \<sqinter> g))"
     using 3 by (metis inf_absorb2 inf.assoc)
   also have "... = sum (w \<sqinter> (f \<sqinter> g)) + sum (w\<^sup>T \<sqinter> (f \<sqinter> g))"
     using 3 inf.commute acyclic_asymmetric sum_disjoint minimum_spanning_forest_def spanning_forest_def by simp
   also have "... = sum (w \<sqinter> (f \<sqinter> g)) + sum (w \<sqinter> (f\<^sup>T \<sqinter> g\<^sup>T))"
     by (metis conv_dist_inf conv_involutive sum_conv)
   also have "... = sum (f \<sqinter> (w \<sqinter> g)) + sum (f\<^sup>T \<sqinter> (w \<sqinter> g))"
   proof -
     have 51:"f\<^sup>T \<sqinter> (w \<sqinter> g) = f\<^sup>T \<sqinter> (w \<sqinter> g\<^sup>T)"
       using 1 boruvka_outer_invariant_def by auto
     have 52:"f \<sqinter> (w \<sqinter> g) = w \<sqinter> (f \<sqinter> g)"
       by (simp add: inf.left_commute)
     thus ?thesis
       using 51 52 abel_semigroup.left_commute inf.abel_semigroup_axioms by fastforce
   qed
   also have "... = sum ((f \<squnion> f\<^sup>T) \<sqinter> (w \<sqinter> g))"
     using 2 acyclic_asymmetric inf.sup_monoid.add_commute sum_disjoint spanning_forest_def by simp
   also have "... = sum (w \<sqinter> g)"
     using 4 by (metis inf_absorb2 inf.assoc)
   finally show "minimum_spanning_forest f g"
     using 2 3 minimum_spanning_forest_def by simp
 qed
 
 end
 
 end
 
diff --git a/thys/Relational_Minimum_Spanning_Trees/ROOT b/thys/Relational_Minimum_Spanning_Trees/ROOT
--- a/thys/Relational_Minimum_Spanning_Trees/ROOT
+++ b/thys/Relational_Minimum_Spanning_Trees/ROOT
@@ -1,19 +1,18 @@
 chapter AFP
 
-session Relational_Minimum_Spanning_Trees = Aggregation_Algebras +
+session Relational_Minimum_Spanning_Trees = Relational_Disjoint_Set_Forests +
 
   options [timeout = 600]
 
   sessions
     "HOL-Hoare"
-    Relational_Disjoint_Set_Forests
 
   theories
     Kruskal
     Prim
     Boruvka
 
   document_files
     "root.tex"
     "root.bib"
 
diff --git a/thys/Stone_Kleene_Relation_Algebras/Iterings.thy b/thys/Stone_Kleene_Relation_Algebras/Iterings.thy
--- a/thys/Stone_Kleene_Relation_Algebras/Iterings.thy
+++ b/thys/Stone_Kleene_Relation_Algebras/Iterings.thy
@@ -1,858 +1,864 @@
 (* Title:      Iterings
    Author:     Walter Guttmann
    Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
 *)
 
 section \<open>Iterings\<close>
 
 text \<open>
 This theory introduces algebraic structures with an operation that describes iteration in various relational computation models.
 An iteration describes the repeated sequential execution of a computation.
 This is typically modelled by fixpoints, but different computation models use different fixpoints in the refinement order.
 We therefore look at equational and simulation axioms rather than induction axioms.
 Our development is based on \<^cite>\<open>"Guttmann2012c"\<close> and the proposed algebras generalise Kleene algebras.
 
 We first consider a variant of Conway semirings \<^cite>\<open>"BloomEsik1993a"\<close> based on idempotent left semirings.
 Conway semirings expand semirings by an iteration operation satisfying Conway's sumstar and productstar axioms \<^cite>\<open>"Conway1971"\<close>.
 Many properties of iteration follow already from these equational axioms.
 
 Next we introduce iterings, which use generalised versions of simulation axioms in addition to sumstar and productstar.
 Unlike the induction axioms of the Kleene star, which hold only in partial-correctness models, the simulation axioms are also valid in total and general correctness models.
 They are still powerful enough to prove the correctness of complex results such as separation theorems of \<^cite>\<open>"Cohen2000"\<close> and Back's atomicity refinement theorem \<^cite>\<open>"BackWright1999" and "Wright2004"\<close>.
 \<close>
 
 theory Iterings
 
 imports Stone_Relation_Algebras.Semirings
 
 begin
 
 subsection \<open>Conway Semirings\<close>
 
 text \<open>
 In this section, we consider equational axioms for iteration.
 The algebraic structures are based on idempotent left semirings, which are expanded by a unary iteration operation.
 We start with an unfold property, one inequality of the sliding rule and distributivity over joins, which is similar to Conway's sumstar.
 \<close>
 
 class circ =
   fixes circ :: "'a \<Rightarrow> 'a" ("_\<^sup>\<circ>" [100] 100)
 
 class left_conway_semiring = idempotent_left_semiring + circ +
   assumes circ_left_unfold: "1 \<squnion> x * x\<^sup>\<circ> = x\<^sup>\<circ>"
   assumes circ_left_slide: "(x * y)\<^sup>\<circ> * x \<le> x * (y * x)\<^sup>\<circ>"
   assumes circ_sup_1: "(x \<squnion> y)\<^sup>\<circ> = x\<^sup>\<circ> * (y * x\<^sup>\<circ>)\<^sup>\<circ>"
 begin
 
 text \<open>
 We obtain one inequality of Conway's productstar, as well as of the other unfold rule.
 \<close>
 
 lemma circ_mult_sub:
   "1 \<squnion> x * (y * x)\<^sup>\<circ> * y \<le> (x * y)\<^sup>\<circ>"
   by (metis sup_right_isotone circ_left_slide circ_left_unfold mult_assoc mult_right_isotone)
 
 lemma circ_right_unfold_sub:
   "1 \<squnion> x\<^sup>\<circ> * x \<le> x\<^sup>\<circ>"
   by (metis circ_mult_sub mult_1_left mult_1_right)
 
 lemma circ_zero:
   "bot\<^sup>\<circ> = 1"
   by (metis sup_monoid.add_0_right circ_left_unfold mult_left_zero)
 
 lemma circ_increasing:
   "x \<le> x\<^sup>\<circ>"
   by (metis le_supI2 circ_left_unfold circ_right_unfold_sub mult_1_left mult_right_sub_dist_sup_left order_trans)
 
 lemma circ_reflexive:
   "1 \<le> x\<^sup>\<circ>"
   by (metis sup_left_divisibility circ_left_unfold)
 
 lemma circ_mult_increasing:
   "x \<le> x * x\<^sup>\<circ>"
   by (metis circ_reflexive mult_right_isotone mult_1_right)
 
 lemma circ_mult_increasing_2:
   "x \<le> x\<^sup>\<circ> * x"
   by (metis circ_reflexive mult_left_isotone mult_1_left)
 
 lemma circ_transitive_equal:
   "x\<^sup>\<circ> * x\<^sup>\<circ> = x\<^sup>\<circ>"
   by (metis sup_idem circ_sup_1 circ_left_unfold mult_assoc)
 
 text \<open>
 While iteration is not idempotent, a fixpoint is reached after applying this operation twice.
 Iteration is idempotent for the unit.
 \<close>
 
 lemma circ_circ_circ:
   "x\<^sup>\<circ>\<^sup>\<circ>\<^sup>\<circ> = x\<^sup>\<circ>\<^sup>\<circ>"
   by (metis sup_idem circ_sup_1 circ_increasing circ_transitive_equal le_iff_sup)
 
 lemma circ_one:
   "1\<^sup>\<circ> = 1\<^sup>\<circ>\<^sup>\<circ>"
   by (metis circ_circ_circ circ_zero)
 
 lemma circ_sup_sub:
   "(x\<^sup>\<circ> * y)\<^sup>\<circ> * x\<^sup>\<circ> \<le> (x \<squnion> y)\<^sup>\<circ>"
   by (metis circ_sup_1 circ_left_slide)
 
 lemma circ_plus_one:
   "x\<^sup>\<circ> = 1 \<squnion> x\<^sup>\<circ>"
   by (metis le_iff_sup circ_reflexive)
 
 text \<open>
 Iteration satisfies a characteristic property of reflexive transitive closures.
 \<close>
 
 lemma circ_rtc_2:
   "1 \<squnion> x \<squnion> x\<^sup>\<circ> * x\<^sup>\<circ> = x\<^sup>\<circ>"
   by (metis sup_assoc circ_increasing circ_plus_one circ_transitive_equal le_iff_sup)
 
 lemma mult_zero_circ:
   "(x * bot)\<^sup>\<circ> = 1 \<squnion> x * bot"
   by (metis circ_left_unfold mult_assoc mult_left_zero)
 
 lemma mult_zero_sup_circ:
   "(x \<squnion> y * bot)\<^sup>\<circ> = x\<^sup>\<circ> * (y * bot)\<^sup>\<circ>"
   by (metis circ_sup_1 mult_assoc mult_left_zero)
 
 lemma circ_plus_sub:
   "x\<^sup>\<circ> * x \<le> x * x\<^sup>\<circ>"
   by (metis circ_left_slide mult_1_left mult_1_right)
 
 lemma circ_loop_fixpoint:
   "y * (y\<^sup>\<circ> * z) \<squnion> z = y\<^sup>\<circ> * z"
   by (metis sup_commute circ_left_unfold mult_assoc mult_1_left mult_right_dist_sup)
 
 lemma left_plus_below_circ:
   "x * x\<^sup>\<circ> \<le> x\<^sup>\<circ>"
   by (metis sup.cobounded2 circ_left_unfold)
 
 lemma right_plus_below_circ:
   "x\<^sup>\<circ> * x \<le> x\<^sup>\<circ>"
   using circ_right_unfold_sub by auto
 
 lemma circ_sup_upper_bound:
   "x \<le> z\<^sup>\<circ> \<Longrightarrow> y \<le> z\<^sup>\<circ> \<Longrightarrow> x \<squnion> y \<le> z\<^sup>\<circ>"
   by simp
 
 lemma circ_mult_upper_bound:
   "x \<le> z\<^sup>\<circ> \<Longrightarrow> y \<le> z\<^sup>\<circ> \<Longrightarrow> x * y \<le> z\<^sup>\<circ>"
   by (metis mult_isotone circ_transitive_equal)
 
 lemma circ_sub_dist:
   "x\<^sup>\<circ> \<le> (x \<squnion> y)\<^sup>\<circ>"
   by (metis circ_sup_sub circ_plus_one mult_1_left mult_right_sub_dist_sup_left order_trans)
 
 lemma circ_sub_dist_1:
   "x \<le> (x \<squnion> y)\<^sup>\<circ>"
   using circ_increasing le_supE by blast
 
 lemma circ_sub_dist_2:
   "x * y \<le> (x \<squnion> y)\<^sup>\<circ>"
   by (metis sup_commute circ_mult_upper_bound circ_sub_dist_1)
 
 lemma circ_sub_dist_3:
   "x\<^sup>\<circ> * y\<^sup>\<circ> \<le> (x \<squnion> y)\<^sup>\<circ>"
   by (metis sup_commute circ_mult_upper_bound circ_sub_dist)
 
 lemma circ_isotone:
   "x \<le> y \<Longrightarrow> x\<^sup>\<circ> \<le> y\<^sup>\<circ>"
   by (metis circ_sub_dist le_iff_sup)
 
 lemma circ_sup_2:
   "(x \<squnion> y)\<^sup>\<circ> \<le> (x\<^sup>\<circ> * y\<^sup>\<circ>)\<^sup>\<circ>"
   by (metis sup.bounded_iff circ_increasing circ_isotone circ_reflexive mult_isotone mult_1_left mult_1_right)
 
 lemma circ_sup_one_left_unfold:
   "1 \<le> x \<Longrightarrow> x * x\<^sup>\<circ> = x\<^sup>\<circ>"
   by (metis order.antisym le_iff_sup mult_1_left mult_right_sub_dist_sup_left left_plus_below_circ)
 
 lemma circ_sup_one_right_unfold:
   "1 \<le> x \<Longrightarrow> x\<^sup>\<circ> * x = x\<^sup>\<circ>"
   by (metis order.antisym le_iff_sup mult_left_sub_dist_sup_left mult_1_right right_plus_below_circ)
 
 lemma circ_decompose_4:
   "(x\<^sup>\<circ> * y\<^sup>\<circ>)\<^sup>\<circ> = x\<^sup>\<circ> * (y\<^sup>\<circ> * x\<^sup>\<circ>)\<^sup>\<circ>"
   by (metis sup_assoc sup_commute circ_sup_1 circ_loop_fixpoint circ_plus_one circ_rtc_2 circ_transitive_equal mult_assoc)
 
 lemma circ_decompose_5:
   "(x\<^sup>\<circ> * y\<^sup>\<circ>)\<^sup>\<circ> = (y\<^sup>\<circ> * x\<^sup>\<circ>)\<^sup>\<circ>"
   by (metis circ_decompose_4 circ_loop_fixpoint order.antisym mult_right_sub_dist_sup_right mult_assoc)
 
 lemma circ_decompose_6:
   "x\<^sup>\<circ> * (y * x\<^sup>\<circ>)\<^sup>\<circ> = y\<^sup>\<circ> * (x * y\<^sup>\<circ>)\<^sup>\<circ>"
   by (metis sup_commute circ_sup_1)
 
 lemma circ_decompose_7:
   "(x \<squnion> y)\<^sup>\<circ> = x\<^sup>\<circ> * y\<^sup>\<circ> * (x \<squnion> y)\<^sup>\<circ>"
   by (metis circ_sup_1 circ_decompose_6 circ_transitive_equal mult_assoc)
 
 lemma circ_decompose_8:
   "(x \<squnion> y)\<^sup>\<circ> = (x \<squnion> y)\<^sup>\<circ> * x\<^sup>\<circ> * y\<^sup>\<circ>"
   by (metis order.antisym eq_refl mult_assoc mult_isotone mult_1_right circ_mult_upper_bound circ_reflexive circ_sub_dist_3)
 
 lemma circ_decompose_9:
   "(x\<^sup>\<circ> * y\<^sup>\<circ>)\<^sup>\<circ> = x\<^sup>\<circ> * y\<^sup>\<circ> * (x\<^sup>\<circ> * y\<^sup>\<circ>)\<^sup>\<circ>"
   by (metis circ_decompose_4 mult_assoc)
 
 lemma circ_decompose_10:
   "(x\<^sup>\<circ> * y\<^sup>\<circ>)\<^sup>\<circ> = (x\<^sup>\<circ> * y\<^sup>\<circ>)\<^sup>\<circ> * x\<^sup>\<circ> * y\<^sup>\<circ>"
   by (metis sup_ge2 circ_loop_fixpoint circ_reflexive circ_sup_one_right_unfold mult_assoc order_trans)
 
 lemma circ_back_loop_prefixpoint:
   "(z * y\<^sup>\<circ>) * y \<squnion> z \<le> z * y\<^sup>\<circ>"
   by (metis sup.bounded_iff circ_left_unfold mult_assoc mult_left_sub_dist_sup_left mult_right_isotone mult_1_right right_plus_below_circ)
 
 text \<open>
 We obtain the fixpoint and prefixpoint properties of iteration, but not least or greatest fixpoint properties.
 \<close>
 
 lemma circ_loop_is_fixpoint:
   "is_fixpoint (\<lambda>x . y * x \<squnion> z) (y\<^sup>\<circ> * z)"
   by (metis circ_loop_fixpoint is_fixpoint_def)
 
 lemma circ_back_loop_is_prefixpoint:
   "is_prefixpoint (\<lambda>x . x * y \<squnion> z) (z * y\<^sup>\<circ>)"
   by (metis circ_back_loop_prefixpoint is_prefixpoint_def)
 
 lemma circ_circ_sup:
   "(1 \<squnion> x)\<^sup>\<circ> = x\<^sup>\<circ>\<^sup>\<circ>"
   by (metis sup_commute circ_sup_1 circ_decompose_4 circ_zero mult_1_right)
 
 lemma circ_circ_mult_sub:
   "x\<^sup>\<circ> * 1\<^sup>\<circ> \<le> x\<^sup>\<circ>\<^sup>\<circ>"
   by (metis circ_increasing circ_isotone circ_mult_upper_bound circ_reflexive)
 
 lemma left_plus_circ:
   "(x * x\<^sup>\<circ>)\<^sup>\<circ> = x\<^sup>\<circ>"
   by (metis circ_left_unfold circ_sup_1 mult_1_right mult_sub_right_one sup.absorb1 mult_assoc)
 
 lemma right_plus_circ:
   "(x\<^sup>\<circ> * x)\<^sup>\<circ> = x\<^sup>\<circ>"
   by (metis sup_commute circ_isotone circ_loop_fixpoint circ_plus_sub circ_sub_dist order.eq_iff left_plus_circ)
 
 lemma circ_square:
   "(x * x)\<^sup>\<circ> \<le> x\<^sup>\<circ>"
   by (metis circ_increasing circ_isotone left_plus_circ mult_right_isotone)
 
 lemma circ_mult_sub_sup:
   "(x * y)\<^sup>\<circ> \<le> (x \<squnion> y)\<^sup>\<circ>"
   by (metis sup_ge1 sup_ge2 circ_isotone circ_square mult_isotone order_trans)
 
 lemma circ_sup_mult_zero:
   "x\<^sup>\<circ> * y = (x \<squnion> y * bot)\<^sup>\<circ> * y"
 proof -
   have "(x \<squnion> y * bot)\<^sup>\<circ> * y = x\<^sup>\<circ> * (1 \<squnion> y * bot) * y"
     by (metis mult_zero_sup_circ mult_zero_circ)
   also have "... = x\<^sup>\<circ> * (y \<squnion> y * bot)"
     by (metis mult_assoc mult_1_left mult_left_zero mult_right_dist_sup)
   also have "... = x\<^sup>\<circ> * y"
     by (metis sup_commute le_iff_sup zero_right_mult_decreasing)
   finally show ?thesis
     by simp
 qed
 
 lemma troeger_1:
   "(x \<squnion> y)\<^sup>\<circ> = x\<^sup>\<circ> * (1 \<squnion> y * (x \<squnion> y)\<^sup>\<circ>)"
   by (metis circ_sup_1 circ_left_unfold mult_assoc)
 
 lemma troeger_2:
   "(x \<squnion> y)\<^sup>\<circ> * z = x\<^sup>\<circ> * (y * (x \<squnion> y)\<^sup>\<circ> * z \<squnion> z)"
   by (metis circ_sup_1 circ_loop_fixpoint mult_assoc)
 
 lemma troeger_3:
   "(x \<squnion> y * bot)\<^sup>\<circ> = x\<^sup>\<circ> * (1 \<squnion> y * bot)"
   by (metis mult_zero_sup_circ mult_zero_circ)
 
 lemma circ_sup_sub_sup_one_1:
   "x \<squnion> y \<le> x\<^sup>\<circ> * (1 \<squnion> y)"
   by (metis circ_increasing circ_left_unfold mult_1_left mult_1_right mult_left_sub_dist_sup mult_right_sub_dist_sup_left order_trans sup_mono)
 
 lemma circ_sup_sub_sup_one_2:
   "x\<^sup>\<circ> * (x \<squnion> y) \<le> x\<^sup>\<circ> * (1 \<squnion> y)"
   by (metis circ_sup_sub_sup_one_1 circ_transitive_equal mult_assoc mult_right_isotone)
 
 lemma circ_sup_sub_sup_one:
   "x * x\<^sup>\<circ> * (x \<squnion> y) \<le> x * x\<^sup>\<circ> * (1 \<squnion> y)"
   by (metis circ_sup_sub_sup_one_2 mult_assoc mult_right_isotone)
 
 lemma circ_square_2:
   "(x * x)\<^sup>\<circ> * (x \<squnion> 1) \<le> x\<^sup>\<circ>"
   by (metis sup.bounded_iff circ_increasing circ_mult_upper_bound circ_reflexive circ_square)
 
 lemma circ_extra_circ:
   "(y * x\<^sup>\<circ>)\<^sup>\<circ> = (y * y\<^sup>\<circ> * x\<^sup>\<circ>)\<^sup>\<circ>"
   by (metis circ_decompose_6 circ_transitive_equal left_plus_circ mult_assoc)
 
 lemma circ_circ_sub_mult:
   "1\<^sup>\<circ> * x\<^sup>\<circ> \<le> x\<^sup>\<circ>\<^sup>\<circ>"
   by (metis circ_increasing circ_isotone circ_mult_upper_bound circ_reflexive)
 
 lemma circ_decompose_11:
   "(x\<^sup>\<circ> * y\<^sup>\<circ>)\<^sup>\<circ> = (x\<^sup>\<circ> * y\<^sup>\<circ>)\<^sup>\<circ> * x\<^sup>\<circ>"
   by (metis circ_decompose_10 circ_decompose_4 circ_decompose_5 circ_decompose_9 left_plus_circ)
 
 lemma circ_mult_below_circ_circ:
   "(x * y)\<^sup>\<circ> \<le> (x\<^sup>\<circ> * y)\<^sup>\<circ> * x\<^sup>\<circ>"
   by (metis circ_increasing circ_isotone circ_reflexive dual_order.trans mult_left_isotone mult_right_isotone mult_1_right)
 
+lemma power_below_circ:
+  "power x i \<le> x\<^sup>\<circ>"
+  apply (induct rule: nat.induct)
+  apply (simp add: circ_reflexive)
+  by (simp add: circ_increasing circ_mult_upper_bound)
+
 (*
 lemma circ_right_unfold: "1 \<squnion> x\<^sup>\<circ> * x = x\<^sup>\<circ>" nitpick [expect=genuine] oops
 lemma circ_mult: "1 \<squnion> x * (y * x)\<^sup>\<circ> * y = (x * y)\<^sup>\<circ>" nitpick [expect=genuine] oops
 lemma circ_slide: "(x * y)\<^sup>\<circ> * x = x * (y * x)\<^sup>\<circ>" nitpick [expect=genuine] oops
 lemma circ_plus_same: "x\<^sup>\<circ> * x = x * x\<^sup>\<circ>" nitpick [expect=genuine] oops
 lemma "1\<^sup>\<circ> * x\<^sup>\<circ> \<le> x\<^sup>\<circ> * 1\<^sup>\<circ>" nitpick [expect=genuine,card=7] oops
 lemma circ_circ_mult_1: "x\<^sup>\<circ> * 1\<^sup>\<circ> = x\<^sup>\<circ>\<^sup>\<circ>" nitpick [expect=genuine,card=7] oops
 lemma "x\<^sup>\<circ> * 1\<^sup>\<circ> \<le> 1\<^sup>\<circ> * x\<^sup>\<circ>" nitpick [expect=genuine,card=7] oops
 lemma circ_circ_mult: "1\<^sup>\<circ> * x\<^sup>\<circ> = x\<^sup>\<circ>\<^sup>\<circ>" nitpick [expect=genuine,card=7] oops
 lemma circ_sup: "(x\<^sup>\<circ> * y)\<^sup>\<circ> * x\<^sup>\<circ> = (x \<squnion> y)\<^sup>\<circ>" nitpick [expect=genuine,card=8] oops
 lemma circ_unfold_sum: "(x \<squnion> y)\<^sup>\<circ> = x\<^sup>\<circ> \<squnion> x\<^sup>\<circ> * y * (x \<squnion> y)\<^sup>\<circ>" nitpick [expect=genuine,card=7] oops
 
 lemma mult_zero_sup_circ_2: "(x \<squnion> y * bot)\<^sup>\<circ> = x\<^sup>\<circ> \<squnion> x\<^sup>\<circ> * y * bot" nitpick [expect=genuine,card=7] oops
 lemma sub_mult_one_circ: "x * 1\<^sup>\<circ> \<le> 1\<^sup>\<circ> * x" nitpick [expect=genuine] oops
 lemma circ_back_loop_fixpoint: "(z * y\<^sup>\<circ>) * y \<squnion> z = z * y\<^sup>\<circ>" nitpick [expect=genuine] oops
 lemma circ_back_loop_is_fixpoint: "is_fixpoint (\<lambda>x . x * y \<squnion> z) (z * y\<^sup>\<circ>)" nitpick [expect=genuine] oops
 lemma "x\<^sup>\<circ> * y\<^sup>\<circ> \<le> (x\<^sup>\<circ> * y)\<^sup>\<circ> * x\<^sup>\<circ>" nitpick [expect=genuine,card=7] oops
 *)
 
 end
 
 text \<open>
 The next class considers the interaction of iteration with a greatest element.
 \<close>
 
 class bounded_left_conway_semiring = bounded_idempotent_left_semiring + left_conway_semiring
 begin
 
 lemma circ_top:
   "top\<^sup>\<circ> = top"
   by (simp add: order.antisym circ_increasing)
 
 lemma circ_right_top:
   "x\<^sup>\<circ> * top = top"
   by (metis sup_right_top circ_loop_fixpoint)
 
 lemma circ_left_top:
   "top * x\<^sup>\<circ> = top"
   by (metis circ_right_top circ_top circ_decompose_11)
 
 lemma mult_top_circ:
   "(x * top)\<^sup>\<circ> = 1 \<squnion> x * top"
   by (metis circ_left_top circ_left_unfold mult_assoc)
 
 end
 
 class left_zero_conway_semiring = idempotent_left_zero_semiring + left_conway_semiring
 begin
 
 lemma mult_zero_sup_circ_2:
   "(x \<squnion> y * bot)\<^sup>\<circ> = x\<^sup>\<circ> \<squnion> x\<^sup>\<circ> * y * bot"
   by (metis mult_assoc mult_left_dist_sup mult_1_right troeger_3)
 
 lemma circ_unfold_sum:
   "(x \<squnion> y)\<^sup>\<circ> = x\<^sup>\<circ> \<squnion> x\<^sup>\<circ> * y * (x \<squnion> y)\<^sup>\<circ>"
   by (metis mult_assoc mult_left_dist_sup mult_1_right troeger_1)
 
 end
 
 text \<open>
 The next class assumes the full sliding equation.
 \<close>
 
 class left_conway_semiring_1 = left_conway_semiring +
   assumes circ_right_slide: "x * (y * x)\<^sup>\<circ> \<le> (x * y)\<^sup>\<circ> * x"
 begin
 
 lemma circ_slide_1:
   "x * (y * x)\<^sup>\<circ> = (x * y)\<^sup>\<circ> * x"
   by (metis order.antisym circ_left_slide circ_right_slide)
 
 text \<open>
 This implies the full unfold rules and Conway's productstar.
 \<close>
 
 lemma circ_right_unfold_1:
   "1 \<squnion> x\<^sup>\<circ> * x = x\<^sup>\<circ>"
   by (metis circ_left_unfold circ_slide_1 mult_1_left mult_1_right)
 
 lemma circ_mult_1:
   "(x * y)\<^sup>\<circ> = 1 \<squnion> x * (y * x)\<^sup>\<circ> * y"
   by (metis circ_left_unfold circ_slide_1 mult_assoc)
 
 lemma circ_sup_9:
   "(x \<squnion> y)\<^sup>\<circ> = (x\<^sup>\<circ> * y)\<^sup>\<circ> * x\<^sup>\<circ>"
   by (metis circ_sup_1 circ_slide_1)
 
 lemma circ_plus_same:
   "x\<^sup>\<circ> * x = x * x\<^sup>\<circ>"
   by (metis circ_slide_1 mult_1_left mult_1_right)
 
 lemma circ_decompose_12:
   "x\<^sup>\<circ> * y\<^sup>\<circ> \<le> (x\<^sup>\<circ> * y)\<^sup>\<circ> * x\<^sup>\<circ>"
   by (metis circ_sup_9 circ_sub_dist_3)
 
 end
 
 class left_zero_conway_semiring_1 = left_zero_conway_semiring + left_conway_semiring_1
 begin
 
 lemma circ_back_loop_fixpoint:
   "(z * y\<^sup>\<circ>) * y \<squnion> z = z * y\<^sup>\<circ>"
   by (metis sup_commute circ_left_unfold circ_plus_same mult_assoc mult_left_dist_sup mult_1_right)
 
 lemma circ_back_loop_is_fixpoint:
   "is_fixpoint (\<lambda>x . x * y \<squnion> z) (z * y\<^sup>\<circ>)"
   by (metis circ_back_loop_fixpoint is_fixpoint_def)
 
 lemma circ_elimination:
   "x * y = bot \<Longrightarrow> x * y\<^sup>\<circ> \<le> x"
   by (metis sup_monoid.add_0_left circ_back_loop_fixpoint circ_plus_same mult_assoc mult_left_zero order_refl)
 
 end
 
 subsection \<open>Iterings\<close>
 
 text \<open>
 This section adds simulation axioms to Conway semirings.
 We consider several classes with increasingly general simulation axioms.
 \<close>
 
 class itering_1 = left_conway_semiring_1 +
   assumes circ_simulate: "z * x \<le> y * z \<longrightarrow> z * x\<^sup>\<circ> \<le> y\<^sup>\<circ> * z"
 begin
 
 lemma circ_circ_mult:
   "1\<^sup>\<circ> * x\<^sup>\<circ> = x\<^sup>\<circ>\<^sup>\<circ>"
   by (metis order.antisym circ_circ_sup circ_reflexive circ_simulate circ_sub_dist_3 circ_sup_one_left_unfold circ_transitive_equal mult_1_left order_refl)
 
 lemma sub_mult_one_circ:
   "x * 1\<^sup>\<circ> \<le> 1\<^sup>\<circ> * x"
   by (metis circ_simulate mult_1_left mult_1_right order_refl)
 
 text \<open>
 The left simulation axioms is enough to prove a basic import property of tests.
 \<close>
 
 lemma circ_import:
   assumes "p \<le> p * p"
       and "p \<le> 1"
       and "p * x \<le> x * p"
     shows "p * x\<^sup>\<circ> = p * (p * x)\<^sup>\<circ>"
 proof -
   have "p * x \<le> p * (p * x * p) * p"
     by (metis assms coreflexive_transitive order.eq_iff test_preserves_equation mult_assoc)
   hence "p * x\<^sup>\<circ> \<le> p * (p * x)\<^sup>\<circ>"
     by (metis (no_types) assms circ_simulate circ_slide_1 test_preserves_equation)
   thus ?thesis
     by (metis assms(2) circ_isotone mult_left_isotone mult_1_left mult_right_isotone order.antisym)
 qed
 
 end
 
 text \<open>
 Including generalisations of both simulation axioms allows us to prove separation rules.
 \<close>
 
 class itering_2 = left_conway_semiring_1 +
   assumes circ_simulate_right: "z * x \<le> y * z \<squnion> w \<longrightarrow> z * x\<^sup>\<circ> \<le> y\<^sup>\<circ> * (z \<squnion> w * x\<^sup>\<circ>)"
   assumes circ_simulate_left: "x * z \<le> z * y \<squnion> w \<longrightarrow> x\<^sup>\<circ> * z \<le> (z \<squnion> x\<^sup>\<circ> * w) * y\<^sup>\<circ>"
 begin
 
 subclass itering_1
   apply unfold_locales
   by (metis sup_monoid.add_0_right circ_simulate_right mult_left_zero)
 
 lemma circ_simulate_left_1:
   "x * z \<le> z * y \<Longrightarrow> x\<^sup>\<circ> * z \<le> z * y\<^sup>\<circ> \<squnion> x\<^sup>\<circ> * bot"
   by (metis sup_monoid.add_0_right circ_simulate_left mult_assoc mult_left_zero mult_right_dist_sup)
 
 lemma circ_separate_1:
   assumes "y * x \<le> x * y"
     shows "(x \<squnion> y)\<^sup>\<circ> = x\<^sup>\<circ> * y\<^sup>\<circ>"
 proof -
   have "y\<^sup>\<circ> * x \<le> x * y\<^sup>\<circ> \<squnion> y\<^sup>\<circ> * bot"
     by (metis assms circ_simulate_left_1)
   hence "y\<^sup>\<circ> * x * y\<^sup>\<circ> \<le> x * y\<^sup>\<circ> * y\<^sup>\<circ> \<squnion> y\<^sup>\<circ> * bot * y\<^sup>\<circ>"
     by (metis mult_assoc mult_left_isotone mult_right_dist_sup)
   also have "... = x * y\<^sup>\<circ> \<squnion> y\<^sup>\<circ> * bot"
     by (metis circ_transitive_equal mult_assoc mult_left_zero)
   finally have "y\<^sup>\<circ> * (x * y\<^sup>\<circ>)\<^sup>\<circ> \<le> x\<^sup>\<circ> * (y\<^sup>\<circ> \<squnion> y\<^sup>\<circ> * bot)"
     using circ_simulate_right mult_assoc by fastforce
   also have "... = x\<^sup>\<circ> * y\<^sup>\<circ>"
     by (simp add: sup_absorb1 zero_right_mult_decreasing)
   finally have "(x \<squnion> y)\<^sup>\<circ> \<le> x\<^sup>\<circ> * y\<^sup>\<circ>"
     by (simp add: circ_decompose_6 circ_sup_1)
   thus ?thesis
     by (simp add: order.antisym circ_sub_dist_3)
 qed
 
 lemma circ_circ_mult_1:
   "x\<^sup>\<circ> * 1\<^sup>\<circ> = x\<^sup>\<circ>\<^sup>\<circ>"
   by (metis sup_commute circ_circ_sup circ_separate_1 mult_1_left mult_1_right order_refl)
 
 end
 
 text \<open>
 With distributivity, we also get Back's atomicity refinement theorem.
 \<close>
 
 class itering_3 = itering_2 + left_zero_conway_semiring_1
 begin
 
 lemma circ_simulate_1:
   assumes "y * x \<le> x * y"
     shows "y\<^sup>\<circ> * x\<^sup>\<circ> \<le> x\<^sup>\<circ> * y\<^sup>\<circ>"
 proof -
   have "y * x\<^sup>\<circ> \<le> x\<^sup>\<circ> * y"
     by (metis assms circ_simulate)
   hence "y\<^sup>\<circ> * x\<^sup>\<circ> \<le> x\<^sup>\<circ> * y\<^sup>\<circ> \<squnion> y\<^sup>\<circ> * bot"
     by (metis circ_simulate_left_1)
   thus ?thesis
     by (metis sup_assoc sup_monoid.add_0_right circ_loop_fixpoint mult_assoc mult_left_zero mult_zero_sup_circ_2)
 qed
 
 lemma atomicity_refinement:
   assumes "s = s * q"
       and "x = q * x"
       and "q * b = bot"
       and "r * b \<le> b * r"
       and "r * l \<le> l * r"
       and "x * l \<le> l * x"
       and "b * l \<le> l * b"
       and "q * l \<le> l * q"
       and "r\<^sup>\<circ> * q \<le> q * r\<^sup>\<circ>"
       and "q \<le> 1"
     shows "s * (x \<squnion> b \<squnion> r \<squnion> l)\<^sup>\<circ> * q \<le> s * (x * b\<^sup>\<circ> * q \<squnion> r \<squnion> l)\<^sup>\<circ>"
 proof -
   have "(x \<squnion> b \<squnion> r) * l \<le> l * (x \<squnion> b \<squnion> r)"
     using assms(5-7) mult_left_dist_sup mult_right_dist_sup semiring.add_mono by presburger
   hence "s * (x \<squnion> b \<squnion> r \<squnion> l)\<^sup>\<circ> * q = s * l\<^sup>\<circ> * (x \<squnion> b \<squnion> r)\<^sup>\<circ> * q"
     by (metis sup_commute circ_separate_1 mult_assoc)
   also have "... = s * l\<^sup>\<circ> * b\<^sup>\<circ> * r\<^sup>\<circ> * q * (x * b\<^sup>\<circ> * r\<^sup>\<circ> * q)\<^sup>\<circ>"
   proof -
     have "(b \<squnion> r)\<^sup>\<circ> = b\<^sup>\<circ> * r\<^sup>\<circ>"
       by (simp add: assms(4) circ_separate_1)
     hence "b\<^sup>\<circ> * r\<^sup>\<circ> * (q * (x * b\<^sup>\<circ> * r\<^sup>\<circ>))\<^sup>\<circ> = (x \<squnion> b \<squnion> r)\<^sup>\<circ>"
       by (metis (full_types) assms(2) circ_sup_1 sup_assoc sup_commute mult_assoc)
     thus ?thesis
       by (metis circ_slide_1 mult_assoc)
   qed
   also have "... \<le> s * l\<^sup>\<circ> * b\<^sup>\<circ> * r\<^sup>\<circ> * q * (x * b\<^sup>\<circ> * q * r\<^sup>\<circ>)\<^sup>\<circ>"
     by (metis assms(9) circ_isotone mult_assoc mult_right_isotone)
   also have "... \<le> s * q * l\<^sup>\<circ> * b\<^sup>\<circ> * r\<^sup>\<circ> * (x * b\<^sup>\<circ> * q * r\<^sup>\<circ>)\<^sup>\<circ>"
     by (metis assms(1,10) mult_left_isotone mult_right_isotone mult_1_right)
   also have "... \<le> s * l\<^sup>\<circ> * q * b\<^sup>\<circ> * r\<^sup>\<circ> * (x * b\<^sup>\<circ> * q * r\<^sup>\<circ>)\<^sup>\<circ>"
     by (metis assms(1,8) circ_simulate mult_assoc mult_left_isotone mult_right_isotone)
   also have "... \<le> s * l\<^sup>\<circ> * r\<^sup>\<circ> * (x * b\<^sup>\<circ> * q * r\<^sup>\<circ>)\<^sup>\<circ>"
     by (metis assms(3,10) sup_monoid.add_0_left circ_back_loop_fixpoint circ_plus_same mult_assoc mult_left_zero mult_left_isotone mult_right_isotone mult_1_right)
   also have "... \<le> s * (x * b\<^sup>\<circ> * q \<squnion> r \<squnion> l)\<^sup>\<circ>"
     by (metis sup_commute circ_sup_1 circ_sub_dist_3 mult_assoc mult_right_isotone)
   finally show ?thesis
     .
 qed
 
 end
 
 text \<open>
 The following class contains the most general simulation axioms we consider.
 They allow us to prove further separation properties.
 \<close>
 
 class itering = idempotent_left_zero_semiring + circ +
   assumes circ_sup: "(x \<squnion> y)\<^sup>\<circ> = (x\<^sup>\<circ> * y)\<^sup>\<circ> * x\<^sup>\<circ>"
   assumes circ_mult: "(x * y)\<^sup>\<circ> = 1 \<squnion> x * (y * x)\<^sup>\<circ> * y"
   assumes circ_simulate_right_plus: "z * x \<le> y * y\<^sup>\<circ> * z \<squnion> w \<longrightarrow> z * x\<^sup>\<circ> \<le> y\<^sup>\<circ> * (z \<squnion> w * x\<^sup>\<circ>)"
   assumes circ_simulate_left_plus: "x * z \<le> z * y\<^sup>\<circ> \<squnion> w \<longrightarrow> x\<^sup>\<circ> * z \<le> (z \<squnion> x\<^sup>\<circ> * w) * y\<^sup>\<circ>"
 begin
 
 lemma circ_right_unfold:
   "1 \<squnion> x\<^sup>\<circ> * x = x\<^sup>\<circ>"
   by (metis circ_mult mult_1_left mult_1_right)
 
 lemma circ_slide:
   "x * (y * x)\<^sup>\<circ> = (x * y)\<^sup>\<circ> * x"
 proof -
   have "x * (y * x)\<^sup>\<circ> = Rf x (y * 1 \<squnion> y * (x * (y * x)\<^sup>\<circ> * y)) * x"
     by (metis (no_types) circ_mult mult_1_left mult_1_right mult_left_dist_sup mult_right_dist_sup mult_assoc)
   thus ?thesis
     by (metis (no_types) circ_mult mult_1_right mult_left_dist_sup mult_assoc)
 qed
 
 subclass itering_3
   apply unfold_locales
   apply (metis circ_mult mult_1_left mult_1_right)
   apply (metis circ_slide order_refl)
   apply (metis circ_sup circ_slide)
   apply (metis circ_slide order_refl)
   apply (metis sup_left_isotone circ_right_unfold mult_left_isotone mult_left_sub_dist_sup_left mult_1_right order_trans circ_simulate_right_plus)
   by (metis sup_commute sup_ge1 sup_right_isotone circ_mult mult_right_isotone mult_1_right order_trans circ_simulate_left_plus)
 
 lemma circ_simulate_right_plus_1:
   "z * x \<le> y * y\<^sup>\<circ> * z \<Longrightarrow> z * x\<^sup>\<circ> \<le> y\<^sup>\<circ> * z"
   by (metis sup_monoid.add_0_right circ_simulate_right_plus mult_left_zero)
 
 lemma circ_simulate_left_plus_1:
   "x * z \<le> z * y\<^sup>\<circ> \<Longrightarrow> x\<^sup>\<circ> * z \<le> z * y\<^sup>\<circ> \<squnion> x\<^sup>\<circ> * bot"
   by (metis sup_monoid.add_0_right circ_simulate_left_plus mult_assoc mult_left_zero mult_right_dist_sup)
 
 lemma circ_simulate_2:
   "y * x\<^sup>\<circ> \<le> x\<^sup>\<circ> * y\<^sup>\<circ> \<longleftrightarrow> y\<^sup>\<circ> * x\<^sup>\<circ> \<le> x\<^sup>\<circ> * y\<^sup>\<circ>"
   apply (rule iffI)
   apply (metis sup_assoc sup_monoid.add_0_right circ_loop_fixpoint circ_simulate_left_plus_1 mult_assoc mult_left_zero mult_zero_sup_circ_2)
   by (metis circ_increasing mult_left_isotone order_trans)
 
 lemma circ_simulate_absorb:
   "y * x \<le> x \<Longrightarrow> y\<^sup>\<circ> * x \<le> x \<squnion> y\<^sup>\<circ> * bot"
   by (metis circ_simulate_left_plus_1 circ_zero mult_1_right)
 
 lemma circ_simulate_3:
   "y * x\<^sup>\<circ> \<le> x\<^sup>\<circ> \<Longrightarrow> y\<^sup>\<circ> * x\<^sup>\<circ> \<le> x\<^sup>\<circ> * y\<^sup>\<circ>"
   by (metis sup.bounded_iff circ_reflexive circ_simulate_2 le_iff_sup mult_right_isotone mult_1_right)
 
 lemma circ_separate_mult_1:
   "y * x \<le> x * y \<Longrightarrow> (x * y)\<^sup>\<circ> \<le> x\<^sup>\<circ> * y\<^sup>\<circ>"
   by (metis circ_mult_sub_sup circ_separate_1)
 
 lemma circ_separate_unfold:
   "(y * x\<^sup>\<circ>)\<^sup>\<circ> = y\<^sup>\<circ> \<squnion> y\<^sup>\<circ> * y * x * x\<^sup>\<circ> * (y * x\<^sup>\<circ>)\<^sup>\<circ>"
   by (metis circ_back_loop_fixpoint circ_plus_same circ_unfold_sum sup_commute mult_assoc)
 
 lemma separation:
   assumes "y * x \<le> x * y\<^sup>\<circ>"
     shows "(x \<squnion> y)\<^sup>\<circ> = x\<^sup>\<circ> * y\<^sup>\<circ>"
 proof -
   have "y\<^sup>\<circ> * x * y\<^sup>\<circ> \<le> x * y\<^sup>\<circ> \<squnion> y\<^sup>\<circ> * bot"
     by (metis assms circ_simulate_left_plus_1 circ_transitive_equal mult_assoc mult_left_isotone)
   thus ?thesis
     by (metis sup_commute circ_sup_1 circ_simulate_right circ_sub_dist_3 le_iff_sup mult_assoc mult_left_zero zero_right_mult_decreasing)
 qed
 
 lemma simulation:
   "y * x \<le> x * y\<^sup>\<circ> \<Longrightarrow> y\<^sup>\<circ> * x\<^sup>\<circ> \<le> x\<^sup>\<circ> * y\<^sup>\<circ>"
   by (metis sup_ge2 circ_isotone circ_mult_upper_bound circ_sub_dist separation)
 
 lemma circ_simulate_4:
   assumes "y * x \<le> x * x\<^sup>\<circ> * (1 \<squnion> y)"
     shows "y\<^sup>\<circ> * x\<^sup>\<circ> \<le> x\<^sup>\<circ> * y\<^sup>\<circ>"
 proof -
   have "x \<squnion> (x * x\<^sup>\<circ> * x * x \<squnion> x * x) = x * x\<^sup>\<circ>"
     by (metis (no_types) circ_back_loop_fixpoint mult_right_dist_sup sup_commute)
   hence "x \<le> x * x\<^sup>\<circ> * 1 \<squnion> x * x\<^sup>\<circ> * y"
     by (metis mult_1_right sup_assoc sup_ge1)
   hence "(1 \<squnion> y) * x \<le> x * x\<^sup>\<circ> * (1 \<squnion> y)"
     using assms mult_left_dist_sup mult_right_dist_sup by force
   hence "y * x\<^sup>\<circ> \<le> x\<^sup>\<circ> * y\<^sup>\<circ>"
     by (metis circ_sup_upper_bound circ_increasing circ_reflexive circ_simulate_right_plus_1 mult_right_isotone mult_right_sub_dist_sup_right order_trans)
   thus ?thesis
     by (metis circ_simulate_2)
 qed
 
 lemma circ_simulate_5:
   "y * x \<le> x * x\<^sup>\<circ> * (x \<squnion> y) \<Longrightarrow> y\<^sup>\<circ> * x\<^sup>\<circ> \<le> x\<^sup>\<circ> * y\<^sup>\<circ>"
   by (metis circ_sup_sub_sup_one circ_simulate_4 order_trans)
 
 lemma circ_simulate_6:
   "y * x \<le> x * (x \<squnion> y) \<Longrightarrow> y\<^sup>\<circ> * x\<^sup>\<circ> \<le> x\<^sup>\<circ> * y\<^sup>\<circ>"
   by (metis sup_commute circ_back_loop_fixpoint circ_simulate_5 mult_right_sub_dist_sup_left order_trans)
 
 lemma circ_separate_4:
   assumes "y * x \<le> x * x\<^sup>\<circ> * (1 \<squnion> y)"
     shows "(x \<squnion> y)\<^sup>\<circ> = x\<^sup>\<circ> * y\<^sup>\<circ>"
 proof -
   have "y * x * x\<^sup>\<circ> \<le> x * x\<^sup>\<circ> * (1 \<squnion> y) * x\<^sup>\<circ>"
     by (simp add: assms mult_left_isotone)
   also have "... = x * x\<^sup>\<circ> \<squnion> x * x\<^sup>\<circ> * y * x\<^sup>\<circ>"
     by (simp add: circ_transitive_equal mult_left_dist_sup mult_right_dist_sup mult_assoc)
   also have "... \<le> x * x\<^sup>\<circ> \<squnion> x * x\<^sup>\<circ> * x\<^sup>\<circ> * y\<^sup>\<circ>"
     by (metis assms sup_right_isotone circ_simulate_2 circ_simulate_4 mult_assoc mult_right_isotone)
   finally have "y * x * x\<^sup>\<circ> \<le> x * x\<^sup>\<circ> * y\<^sup>\<circ>"
     by (metis circ_reflexive circ_transitive_equal le_iff_sup mult_assoc mult_right_isotone mult_1_right)
   thus ?thesis
     by (metis circ_sup_1 left_plus_circ mult_assoc separation)
 qed
 
 lemma circ_separate_5:
   "y * x \<le> x * x\<^sup>\<circ> * (x \<squnion> y) \<Longrightarrow> (x \<squnion> y)\<^sup>\<circ> = x\<^sup>\<circ> * y\<^sup>\<circ>"
   by (metis circ_sup_sub_sup_one circ_separate_4 order_trans)
 
 lemma circ_separate_6:
   "y * x \<le> x * (x \<squnion> y) \<Longrightarrow> (x \<squnion> y)\<^sup>\<circ> = x\<^sup>\<circ> * y\<^sup>\<circ>"
   by (metis sup_commute circ_back_loop_fixpoint circ_separate_5 mult_right_sub_dist_sup_left order_trans)
 
 end
 
 class bounded_itering = bounded_idempotent_left_zero_semiring + itering
 begin
 
 subclass bounded_left_conway_semiring ..
 
 (*
 lemma "1 = x\<^sup>\<circ>" nitpick [expect=genuine] oops
 lemma "x = x\<^sup>\<circ>" nitpick [expect=genuine] oops
 lemma "x = x * x\<^sup>\<circ>" nitpick [expect=genuine] oops
 lemma "x * x\<^sup>\<circ> = x\<^sup>\<circ>" nitpick [expect=genuine] oops
 lemma "x\<^sup>\<circ> = x\<^sup>\<circ>\<^sup>\<circ>" nitpick [expect=genuine] oops
 lemma "(x * y)\<^sup>\<circ> = (x \<squnion> y)\<^sup>\<circ>" nitpick [expect=genuine] oops
 lemma "x\<^sup>\<circ> * y\<^sup>\<circ> = (x \<squnion> y)\<^sup>\<circ>" nitpick [expect=genuine,card=6] oops
 lemma "(x \<squnion> y)\<^sup>\<circ> = (x\<^sup>\<circ> * y\<^sup>\<circ>)\<^sup>\<circ>" nitpick [expect=genuine] oops
 lemma "1 = 1\<^sup>\<circ>" nitpick [expect=genuine] oops
 
 lemma "1 = (x * bot)\<^sup>\<circ>" nitpick [expect=genuine] oops
 lemma "1 \<squnion> x * bot = x\<^sup>\<circ>" nitpick [expect=genuine] oops
 lemma "x\<^sup>\<circ> = x\<^sup>\<circ> * 1\<^sup>\<circ>" nitpick [expect=genuine] oops
 lemma "z \<squnion> y * x = x \<longrightarrow> y\<^sup>\<circ> * z \<le> x" nitpick [expect=genuine] oops
 lemma "y * x = x \<longrightarrow> y\<^sup>\<circ> * x \<le> x" nitpick [expect=genuine] oops
 lemma "z \<squnion> x * y = x \<longrightarrow> z * y\<^sup>\<circ> \<le> x" nitpick [expect=genuine] oops
 lemma "x * y = x \<longrightarrow> x * y\<^sup>\<circ> \<le> x" nitpick [expect=genuine] oops
 lemma "x = z \<squnion> y * x \<longrightarrow> x \<le> y\<^sup>\<circ> * z" nitpick [expect=genuine] oops
 lemma "x = y * x \<longrightarrow> x \<le> y\<^sup>\<circ>" nitpick [expect=genuine] oops
 lemma "x * z = z * y \<longrightarrow> x\<^sup>\<circ> * z \<le> z * y\<^sup>\<circ>" nitpick [expect=genuine] oops
 
 lemma "x\<^sup>\<circ> = (x * x)\<^sup>\<circ> * (x \<squnion> 1)" oops
 lemma "y\<^sup>\<circ> * x\<^sup>\<circ> \<le> x\<^sup>\<circ> * y\<^sup>\<circ> \<longrightarrow> (x \<squnion> y)\<^sup>\<circ> = x\<^sup>\<circ> * y\<^sup>\<circ>" oops
 lemma "y * x \<le> (1 \<squnion> x) * y\<^sup>\<circ> \<longrightarrow> (x \<squnion> y)\<^sup>\<circ> = x\<^sup>\<circ> * y\<^sup>\<circ>" oops
 lemma "y * x \<le> x \<longrightarrow> y\<^sup>\<circ> * x \<le> 1\<^sup>\<circ> * x" oops
 *)
 
 end
 
 text \<open>
 We finally expand Conway semirings and iterings by an element that corresponds to the endless loop.
 \<close>
 
 class L =
   fixes L :: "'a"
 
 class left_conway_semiring_L = left_conway_semiring + L +
   assumes one_circ_mult_split: "1\<^sup>\<circ> * x = L \<squnion> x"
   assumes L_split_sup: "x * (y \<squnion> L) \<le> x * y \<squnion> L"
 begin
 
 lemma L_def:
   "L = 1\<^sup>\<circ> * bot"
   by (metis sup_monoid.add_0_right one_circ_mult_split)
 
 lemma one_circ_split:
   "1\<^sup>\<circ> = L \<squnion> 1"
   by (metis mult_1_right one_circ_mult_split)
 
 lemma one_circ_circ_split:
   "1\<^sup>\<circ>\<^sup>\<circ> = L \<squnion> 1"
   by (metis circ_one one_circ_split)
 
 lemma sub_mult_one_circ:
   "x * 1\<^sup>\<circ> \<le> 1\<^sup>\<circ> * x"
   by (metis L_split_sup sup_commute mult_1_right one_circ_mult_split)
 
 lemma one_circ_mult_split_2:
   "1\<^sup>\<circ> * x = x * 1\<^sup>\<circ> \<squnion> L"
 proof -
   have 1: "x * 1\<^sup>\<circ> \<le> L \<squnion> x"
     using one_circ_mult_split sub_mult_one_circ by presburger
   have "x \<squnion> x * 1\<^sup>\<circ> = x * 1\<^sup>\<circ>"
     by (meson circ_back_loop_prefixpoint le_iff_sup sup.boundedE)
   thus ?thesis
     using 1 by (simp add: le_iff_sup one_circ_mult_split sup_assoc sup_commute)
 qed
 
 lemma sub_mult_one_circ_split:
   "x * 1\<^sup>\<circ> \<le> x \<squnion> L"
   by (metis sup_commute one_circ_mult_split sub_mult_one_circ)
 
 lemma sub_mult_one_circ_split_2:
   "x * 1\<^sup>\<circ> \<le> x \<squnion> 1\<^sup>\<circ>"
   by (metis L_def sup_right_isotone order_trans sub_mult_one_circ_split zero_right_mult_decreasing)
 
 lemma L_split:
   "x * L \<le> x * bot \<squnion> L"
   by (metis L_split_sup sup_monoid.add_0_left)
 
 lemma L_left_zero:
   "L * x = L"
   by (metis L_def mult_assoc mult_left_zero)
 
 lemma one_circ_L:
   "1\<^sup>\<circ> * L = L"
   by (metis L_def circ_transitive_equal mult_assoc)
 
 lemma mult_L_circ:
   "(x * L)\<^sup>\<circ> = 1 \<squnion> x * L"
   by (metis L_left_zero circ_left_unfold mult_assoc)
 
 lemma mult_L_circ_mult:
   "(x * L)\<^sup>\<circ> * y = y \<squnion> x * L"
   by (metis L_left_zero mult_L_circ mult_assoc mult_1_left mult_right_dist_sup)
 
 lemma circ_L:
   "L\<^sup>\<circ> = L \<squnion> 1"
   by (metis L_left_zero sup_commute circ_left_unfold)
 
 lemma L_below_one_circ:
   "L \<le> 1\<^sup>\<circ>"
   by (metis L_def zero_right_mult_decreasing)
 
 lemma circ_circ_mult_1:
   "x\<^sup>\<circ> * 1\<^sup>\<circ> = x\<^sup>\<circ>\<^sup>\<circ>"
   by (metis L_left_zero sup_commute circ_sup_1 circ_circ_sup mult_zero_circ one_circ_split)
 
 lemma circ_circ_mult:
   "1\<^sup>\<circ> * x\<^sup>\<circ> = x\<^sup>\<circ>\<^sup>\<circ>"
   by (metis order.antisym circ_circ_mult_1 circ_circ_sub_mult sub_mult_one_circ)
 
 lemma circ_circ_split:
   "x\<^sup>\<circ>\<^sup>\<circ> = L \<squnion> x\<^sup>\<circ>"
   by (metis circ_circ_mult one_circ_mult_split)
 
 lemma circ_sup_6:
   "L \<squnion> (x \<squnion> y)\<^sup>\<circ> = (x\<^sup>\<circ> * y\<^sup>\<circ>)\<^sup>\<circ>"
   by (metis sup_assoc sup_commute circ_sup_1 circ_circ_sup circ_circ_split circ_decompose_4)
 
 end
 
 class itering_L = itering + L +
   assumes L_def: "L = 1\<^sup>\<circ> * bot"
 begin
 
 lemma one_circ_split:
   "1\<^sup>\<circ> = L \<squnion> 1"
   by (metis L_def sup_commute order.antisym circ_sup_upper_bound circ_reflexive circ_simulate_absorb mult_1_right order_refl zero_right_mult_decreasing)
 
 lemma one_circ_mult_split:
   "1\<^sup>\<circ> * x = L \<squnion> x"
   by (metis L_def sup_commute circ_loop_fixpoint mult_assoc mult_left_zero mult_zero_circ one_circ_split)
 
 lemma sub_mult_one_circ_split:
   "x * 1\<^sup>\<circ> \<le> x \<squnion> L"
   by (metis sup_commute one_circ_mult_split sub_mult_one_circ)
 
 lemma sub_mult_one_circ_split_2:
   "x * 1\<^sup>\<circ> \<le> x \<squnion> 1\<^sup>\<circ>"
   by (metis L_def sup_right_isotone order_trans sub_mult_one_circ_split zero_right_mult_decreasing)
 
 lemma L_split:
   "x * L \<le> x * bot \<squnion> L"
   by (metis L_def mult_assoc mult_left_isotone mult_right_dist_sup sub_mult_one_circ_split_2)
 
 subclass left_conway_semiring_L
   apply unfold_locales
   apply (metis L_def sup_commute circ_loop_fixpoint mult_assoc mult_left_zero mult_zero_circ one_circ_split)
   by (metis sup_commute mult_assoc mult_left_isotone one_circ_mult_split sub_mult_one_circ)
 
 lemma circ_left_induct_mult_L:
   "L \<le> x \<Longrightarrow> x * y \<le> x \<Longrightarrow> x * y\<^sup>\<circ> \<le> x"
   by (metis circ_one circ_simulate le_iff_sup one_circ_mult_split)
 
 lemma circ_left_induct_mult_iff_L:
   "L \<le> x \<Longrightarrow> x * y \<le> x \<longleftrightarrow> x * y\<^sup>\<circ> \<le> x"
   by (metis sup.bounded_iff circ_back_loop_fixpoint circ_left_induct_mult_L le_iff_sup)
 
 lemma circ_left_induct_L:
   "L \<le> x \<Longrightarrow> x * y \<squnion> z \<le> x \<Longrightarrow> z * y\<^sup>\<circ> \<le> x"
   by (metis sup.bounded_iff circ_left_induct_mult_L le_iff_sup mult_right_dist_sup)
 
 end
 
 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,3300 +1,3309 @@
 (* 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>\<open>"Ng1984"\<close>.
 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 order.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>Lemma \<open>reflexive_inf_star\<close> was contributed by Nicolas Robinson-O'Brien.\<close>
 
 lemma reflexive_inf_star:
   assumes "reflexive y"
     shows "y \<sqinter> x\<^sup>\<star> = 1 \<squnion> (y \<sqinter> x\<^sup>+)"
   by (simp add: assms star_left_unfold_equal sup.absorb2 sup_inf_distrib1)
 
 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)
 
 lemma equivalence_star_closed:
   "equivalence x \<Longrightarrow> equivalence (x\<^sup>\<star>)"
   by (simp add: conv_star_commute star.circ_reflexive star.circ_transitive_equal)
 
 lemma equivalence_plus_closed:
   "equivalence x \<Longrightarrow> equivalence (x\<^sup>+)"
   by (simp add: conv_star_commute star.circ_reflexive star.circ_sup_one_left_unfold star.circ_transitive_equal)
 
 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 order.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: order.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_down_closed:
   "x \<le> y \<Longrightarrow> acyclic y \<Longrightarrow> acyclic x"
   using comp_isotone star_isotone by fastforce
 
 lemma forest_down_closed:
   "x \<le> y \<Longrightarrow> forest y \<Longrightarrow> forest x"
   using conv_isotone mult_isotone star_isotone by fastforce
 
 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 order.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: order.antisym star.circ_reflexive)
 qed
 
 lemma acyclic_asymmetric:
   "acyclic w \<Longrightarrow> asymmetric w"
   by (simp add: dual_order.trans pseudo_complement schroeder_5_p 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: order.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) p_antitone p_antitone_iff 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: order.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 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 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
 
 text \<open>Lemmas \<open>forests_bot_1\<close>, \<open>forests_bot_2\<close>, \<open>forests_bot_3\<close> and \<open>fc_comp_eq_fc\<close> were contributed by Nicolas Robinson-O'Brien.\<close>
 
 lemma forests_bot_1:
   assumes "equivalence e"
       and "forest f"
     shows "(-e \<sqinter> f) * (e \<sqinter> f)\<^sup>T = bot"
 proof -
   have "f * f\<^sup>T \<le> e"
     using assms dual_order.trans by blast
   hence "f * (e \<sqinter> f)\<^sup>T \<le> e"
     by (metis conv_dist_inf inf.boundedE inf.cobounded2 inf.orderE mult_right_isotone)
   hence "-e \<sqinter> f * (e \<sqinter> f)\<^sup>T = bot"
     by (simp add: p_antitone pseudo_complement)
   thus ?thesis
     by (metis assms(1) comp_isotone conv_dist_inf equivalence_comp_right_complement inf.boundedI inf.cobounded1 inf.cobounded2 le_bot)
 qed
 
 lemma forests_bot_2:
   assumes "equivalence e"
       and "forest f"
     shows "(-e \<sqinter> f\<^sup>T) * x \<sqinter> (e \<sqinter> f\<^sup>T) * y = bot"
 proof -
   have "(-e \<sqinter> f) * (e \<sqinter> f\<^sup>T) = bot"
     using assms forests_bot_1 conv_dist_inf by simp
   thus ?thesis
     by (smt assms(1) comp_associative comp_inf.semiring.mult_not_zero conv_complement conv_dist_comp conv_dist_inf conv_involutive dedekind_1 inf.cobounded2 inf.sup_monoid.add_commute le_bot mult_right_zero p_antitone_iff pseudo_complement semiring.mult_not_zero symmetric_top_closed top.extremum)
 qed
 
 lemma forests_bot_3:
   assumes "equivalence e"
       and "forest f"
     shows "x * (-e \<sqinter> f) \<sqinter> y * (e \<sqinter> f) = bot"
 proof -
   have "(e \<sqinter> f) * (-e \<sqinter> f\<^sup>T) = bot"
     using assms forests_bot_1 conv_dist_inf conv_complement by (smt conv_dist_comp conv_involutive conv_order coreflexive_bot_closed coreflexive_symmetric)
   hence "y * (e \<sqinter> f) * (-e \<sqinter> f\<^sup>T) = bot"
     by (simp add: comp_associative)
   hence 1: "x \<sqinter> y * (e \<sqinter> f) * (-e \<sqinter> f\<^sup>T) = bot"
     using comp_inf.semiring.mult_not_zero by blast
   hence "(x \<sqinter> y * (e \<sqinter> f) * (-e \<sqinter> f\<^sup>T)) * (-e \<sqinter> f) = bot"
     using semiring.mult_not_zero by blast
   hence "x * (-e \<sqinter> f\<^sup>T)\<^sup>T \<sqinter> y * (e \<sqinter> f) = bot"
     using 1 dedekind_2 inf_commute schroeder_2 by auto
   thus ?thesis
     by (simp add: assms(1) conv_complement conv_dist_inf)
 qed
 
 lemma acyclic_plus:
   "acyclic x \<Longrightarrow> acyclic (x\<^sup>+)"
   by (simp add: star.circ_transitive_equal star.left_plus_circ mult_assoc)
 
 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 reachable_without_loops:
   "x\<^sup>\<star> = (x \<sqinter> -1)\<^sup>\<star>"
 proof (rule order.antisym)
   have "x * (x \<sqinter> -1)\<^sup>\<star> = (x \<sqinter> 1) * (x \<sqinter> -1)\<^sup>\<star> \<squnion> (x \<sqinter> -1) * (x \<sqinter> -1)\<^sup>\<star>"
     by (metis maddux_3_11_pp mult_right_dist_sup regular_one_closed)
   also have "... \<le> (x \<sqinter> -1)\<^sup>\<star>"
     by (metis inf.cobounded2 le_supI mult_left_isotone star.circ_circ_mult star.left_plus_below_circ star_involutive star_one)
   finally show "x\<^sup>\<star> \<le> (x \<sqinter> -1)\<^sup>\<star>"
     by (metis inf.cobounded2 maddux_3_11_pp regular_one_closed star.circ_circ_mult star.circ_sup_2 star_involutive star_sub_one)
 next
   show "(x \<sqinter> -1)\<^sup>\<star> \<le> x\<^sup>\<star>"
     by (simp add: star_isotone)
 qed
 
 lemma plus_reachable_without_loops:
   "x\<^sup>+ = (x \<sqinter> -1)\<^sup>+ \<squnion> (x \<sqinter> 1)"
   by (metis comp_associative maddux_3_11_pp regular_one_closed star.circ_back_loop_fixpoint star.circ_loop_fixpoint sup_assoc reachable_without_loops)
 
 lemma star_plus_without_loops:
   "x\<^sup>\<star> \<sqinter> -1 = x\<^sup>+ \<sqinter> -1"
   by (metis maddux_3_13 star_left_unfold_equal)
 
 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
 
 lemma fc_comp_eq_fc:
   "-forest_components (--f) = -forest_components f"
   by (metis conv_complement p_comp_pp p_pp_comp pp_dist_star)
 
 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 order.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: order.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 order.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 order.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: order.antisym mult_right_isotone star_isotone)
   also have "... = r\<^sup>T * t\<^sup>\<star>"
     using assms(5,6) order.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) dual_order.trans pp_increasing 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) order.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: order.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, opaque_lifting) 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: order.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) order.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: order.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: order.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 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"
     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
 
 class stone_kleene_relation_algebra_tarski = stone_kleene_relation_algebra + stone_relation_algebra_tarski
 
 class kleene_relation_algebra_tarski = kleene_relation_algebra + stone_kleene_relation_algebra_tarski
 begin
 
 subclass relation_algebra_tarski ..
 
 end
 
 class stone_kleene_relation_algebra_consistent = stone_kleene_relation_algebra + stone_relation_algebra_consistent
 
 class kleene_relation_algebra_consistent = kleene_relation_algebra + stone_kleene_relation_algebra_consistent
 begin
 
 subclass relation_algebra_consistent ..
 
 end
 
 class stone_kleene_relation_algebra_tarski_consistent = stone_kleene_relation_algebra + stone_relation_algebra_tarski_consistent
 
 class kleene_relation_algebra_tarski_consistent = kleene_relation_algebra + stone_kleene_relation_algebra_tarski_consistent
 begin
 
 subclass relation_algebra_tarski_consistent ..
 
 end
 
+class linorder_stone_kleene_relation_algebra_tarski_consistent_expansion = linorder_stone_kleene_relation_algebra_expansion + non_trivial_bounded_order
+begin
+
+subclass stone_kleene_relation_algebra_tarski_consistent
+  apply unfold_locales
+  by (simp_all add: bot_not_top)
+
 end
 
+end
+
diff --git a/thys/Stone_Kleene_Relation_Algebras/Matrix_Kleene_Algebras.thy b/thys/Stone_Kleene_Relation_Algebras/Matrix_Kleene_Algebras.thy
--- a/thys/Stone_Kleene_Relation_Algebras/Matrix_Kleene_Algebras.thy
+++ b/thys/Stone_Kleene_Relation_Algebras/Matrix_Kleene_Algebras.thy
@@ -1,1313 +1,1322 @@
 (* Title:      Matrix Kleene Algebras
    Author:     Walter Guttmann
    Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
 *)
 
 section \<open>Matrix Kleene Algebras\<close>
 
 text \<open>
 This theory gives a matrix model of Stone-Kleene relation algebras.
 The main result is that matrices over Kleene algebras form Kleene algebras.
 The automata-based construction is due to Conway \<^cite>\<open>"Conway1971"\<close>.
 An implementation of the construction in Isabelle/HOL that extends \<^cite>\<open>"ArmstrongGomesStruthWeber2016"\<close> was given in \<^cite>\<open>"Asplund2014"\<close> without a correctness proof.
 
 For specifying the size of matrices, Isabelle/HOL's type system requires the use of types, not sets.
 This creates two issues when trying to implement Conway's recursive construction directly.
 First, the matrix size changes for recursive calls, which requires dependent types.
 Second, some submatrices used in the construction are not square, which requires typed Kleene algebras \<^cite>\<open>"Kozen1998"\<close>, that is, categories of Kleene algebras.
 
 Because these instruments are not available in Isabelle/HOL, we use square matrices with a constant size given by the argument of the Kleene star operation.
 Smaller, possibly rectangular submatrices are identified by two lists of indices: one for the rows to include and one for the columns to include.
 Lists are used to make recursive calls deterministic; otherwise sets would be sufficient.
 \<close>
 
 theory Matrix_Kleene_Algebras
 
 imports Stone_Relation_Algebras.Matrix_Relation_Algebras Kleene_Relation_Algebras
 
 begin
 
 subsection \<open>Matrix Restrictions\<close>
 
 text \<open>
 In this section we develop a calculus of matrix restrictions.
 The restriction of a matrix to specific row and column indices is implemented by the following function, which keeps the size of the matrix and sets all unused entries to \<open>bot\<close>.
 \<close>
 
 definition restrict_matrix :: "'a list \<Rightarrow> ('a,'b::bot) square \<Rightarrow> 'a list \<Rightarrow> ('a,'b) square" ("_ \<langle>_\<rangle> _" [90,41,90] 91)
   where "restrict_matrix as f bs = (\<lambda>(i,j) . if List.member as i \<and> List.member bs j then f (i,j) else bot)"
 
 text \<open>
 The following function captures Conway's automata-based construction of the Kleene star of a matrix.
 An index \<open>k\<close> is chosen and \<open>s\<close> contains all other indices.
 The matrix is split into four submatrices \<open>a\<close>, \<open>b\<close>, \<open>c\<close>, \<open>d\<close> including/not including row/column \<open>k\<close>.
 Four matrices are computed containing the entries given by Conway's construction.
 These four matrices are added to obtain the result.
 All matrices involved in the function have the same size, but matrix restriction is used to set irrelevant entries to \<open>bot\<close>.
 \<close>
 
 primrec star_matrix' :: "'a list \<Rightarrow> ('a,'b::{star,times,bounded_semilattice_sup_bot}) square \<Rightarrow> ('a,'b) square" where
 "star_matrix' Nil g = mbot" |
 "star_matrix' (k#s) g = (
   let r = [k] in
   let a = r\<langle>g\<rangle>r in
   let b = r\<langle>g\<rangle>s in
   let c = s\<langle>g\<rangle>r in
   let d = s\<langle>g\<rangle>s in
   let as = r\<langle>star o a\<rangle>r in
   let ds = star_matrix' s d in
   let e = a \<oplus> b \<odot> ds \<odot> c in
   let es = r\<langle>star o e\<rangle>r in
   let f = d \<oplus> c \<odot> as \<odot> b in
   let fs = star_matrix' s f in
   es \<oplus> as \<odot> b \<odot> fs \<oplus> ds \<odot> c \<odot> es \<oplus> fs
 )"
 
 text \<open>
 The Kleene star of the whole matrix is obtained by taking as indices all elements of the underlying type \<open>'a\<close>.
 This is conveniently supplied by the \<open>enum\<close> class.
 \<close>
 
 fun star_matrix :: "('a::enum,'b::{star,times,bounded_semilattice_sup_bot}) square \<Rightarrow> ('a,'b) square" ("_\<^sup>\<odot>" [100] 100) where "star_matrix f = star_matrix' (enum_class.enum::'a list) f"
 
 text \<open>
 The following lemmas deconstruct matrices with non-empty restrictions.
 \<close>
 
 lemma restrict_empty_left:
   "[]\<langle>f\<rangle>ls = mbot"
   by (unfold restrict_matrix_def List.member_def bot_matrix_def) auto
 
 lemma restrict_empty_right:
   "ks\<langle>f\<rangle>[] = mbot"
   by (unfold restrict_matrix_def List.member_def bot_matrix_def) auto
 
 lemma restrict_nonempty_left:
   fixes f :: "('a,'b::bounded_semilattice_sup_bot) square"
   shows "(k#ks)\<langle>f\<rangle>ls = [k]\<langle>f\<rangle>ls \<oplus> ks\<langle>f\<rangle>ls"
   by (unfold restrict_matrix_def List.member_def sup_matrix_def) auto
 
 lemma restrict_nonempty_right:
   fixes f :: "('a,'b::bounded_semilattice_sup_bot) square"
   shows "ks\<langle>f\<rangle>(l#ls) = ks\<langle>f\<rangle>[l] \<oplus> ks\<langle>f\<rangle>ls"
   by (unfold restrict_matrix_def List.member_def sup_matrix_def) auto
 
 lemma restrict_nonempty:
   fixes f :: "('a,'b::bounded_semilattice_sup_bot) square"
   shows "(k#ks)\<langle>f\<rangle>(l#ls) = [k]\<langle>f\<rangle>[l] \<oplus> [k]\<langle>f\<rangle>ls \<oplus> ks\<langle>f\<rangle>[l] \<oplus> ks\<langle>f\<rangle>ls"
   by (unfold restrict_matrix_def List.member_def sup_matrix_def) auto
 
 text \<open>
 The following predicate captures that two index sets are disjoint.
 This has consequences for composition and the unit matrix.
 \<close>
 
 abbreviation "disjoint ks ls \<equiv> \<not>(\<exists>x . List.member ks x \<and> List.member ls x)"
 
 lemma times_disjoint:
   fixes f g :: "('a,'b::idempotent_semiring) square"
   assumes "disjoint ls ms"
     shows "ks\<langle>f\<rangle>ls \<odot> ms\<langle>g\<rangle>ns = mbot"
 proof (rule ext, rule prod_cases)
   fix i j
   have "(ks\<langle>f\<rangle>ls \<odot> ms\<langle>g\<rangle>ns) (i,j) = (\<Squnion>\<^sub>k (ks\<langle>f\<rangle>ls) (i,k) * (ms\<langle>g\<rangle>ns) (k,j))"
     by (simp add: times_matrix_def)
   also have "... = (\<Squnion>\<^sub>k (if List.member ks i \<and> List.member ls k then f (i,k) else bot) * (if List.member ms k \<and> List.member ns j then g (k,j) else bot))"
     by (simp add: restrict_matrix_def)
   also have "... = (\<Squnion>\<^sub>k if List.member ms k \<and> List.member ns j then bot * g (k,j) else (if List.member ks i \<and> List.member ls k then f (i,k) else bot) * bot)"
     using assms by (auto intro: sup_monoid.sum.cong)
   also have "... = (\<Squnion>\<^sub>(k::'a) bot)"
     by (simp add: sup_monoid.sum.neutral)
   also have "... = bot"
     by (simp add: eq_iff le_funI)
   also have "... = mbot (i,j)"
     by (simp add: bot_matrix_def)
   finally show "(ks\<langle>f\<rangle>ls \<odot> ms\<langle>g\<rangle>ns) (i,j) = mbot (i,j)"
     .
 qed
 
 lemma one_disjoint:
   assumes "disjoint ks ls"
     shows "ks\<langle>(mone::('a,'b::idempotent_semiring) square)\<rangle>ls = mbot"
 proof (rule ext, rule prod_cases)
   let ?o = "mone::('a,'b) square"
   fix i j
   have "(ks\<langle>?o\<rangle>ls) (i,j) = (if List.member ks i \<and> List.member ls j then if i = j then 1 else bot else bot)"
     by (simp add: restrict_matrix_def one_matrix_def)
   also have "... = bot"
     using assms by auto
   also have "... = mbot (i,j)"
     by (simp add: bot_matrix_def)
   finally show "(ks\<langle>?o\<rangle>ls) (i,j) = mbot (i,j)"
     .
 qed
 
 text \<open>
 The following predicate captures that an index set is a subset of another index set.
 This has consequences for repeated restrictions.
 \<close>
 
 abbreviation "is_sublist ks ls \<equiv> \<forall>x . List.member ks x \<longrightarrow> List.member ls x"
 
 lemma restrict_sublist:
   assumes "is_sublist ls ks"
       and "is_sublist ms ns"
     shows "ls\<langle>ks\<langle>f\<rangle>ns\<rangle>ms = ls\<langle>f\<rangle>ms"
 proof (rule ext, rule prod_cases)
   fix i j
   show "(ls\<langle>ks\<langle>f\<rangle>ns\<rangle>ms) (i,j) = (ls\<langle>f\<rangle>ms) (i,j)"
   proof (cases "List.member ls i \<and> List.member ms j")
     case True thus ?thesis
       by (simp add: assms restrict_matrix_def)
   next
     case False thus ?thesis
       by (unfold restrict_matrix_def) auto
   qed
 qed
 
 lemma restrict_superlist:
   assumes "is_sublist ls ks"
       and "is_sublist ms ns"
     shows "ks\<langle>ls\<langle>f\<rangle>ms\<rangle>ns = ls\<langle>f\<rangle>ms"
 proof (rule ext, rule prod_cases)
   fix i j
   show "(ks\<langle>ls\<langle>f\<rangle>ms\<rangle>ns) (i,j) = (ls\<langle>f\<rangle>ms) (i,j)"
   proof (cases "List.member ls i \<and> List.member ms j")
     case True thus ?thesis
       by (simp add: assms restrict_matrix_def)
   next
     case False thus ?thesis
       by (unfold restrict_matrix_def) auto
   qed
 qed
 
 text \<open>
 The following lemmas give the sizes of the results of some matrix operations.
 \<close>
 
 lemma restrict_sup:
   fixes f g :: "('a,'b::bounded_semilattice_sup_bot) square"
   shows "ks\<langle>f \<oplus> g\<rangle>ls = ks\<langle>f\<rangle>ls \<oplus> ks\<langle>g\<rangle>ls"
   by (unfold restrict_matrix_def sup_matrix_def) auto
 
 lemma restrict_times:
   fixes f g :: "('a,'b::idempotent_semiring) square"
   shows "ks\<langle>ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms\<rangle>ms = ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms"
 proof (rule ext, rule prod_cases)
   fix i j
   have "(ks\<langle>(ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms)\<rangle>ms) (i,j) = (if List.member ks i \<and> List.member ms j then (\<Squnion>\<^sub>k (ks\<langle>f\<rangle>ls) (i,k) * (ls\<langle>g\<rangle>ms) (k,j)) else bot)"
     by (simp add: times_matrix_def restrict_matrix_def)
   also have "... = (if List.member ks i \<and> List.member ms j then (\<Squnion>\<^sub>k (if List.member ks i \<and> List.member ls k then f (i,k) else bot) * (if List.member ls k \<and> List.member ms j then g (k,j) else bot)) else bot)"
     by (simp add: restrict_matrix_def)
   also have "... = (if List.member ks i \<and> List.member ms j then (\<Squnion>\<^sub>k if List.member ls k then f (i,k) * g (k,j) else bot) else bot)"
     by (auto intro: sup_monoid.sum.cong)
   also have "... = (\<Squnion>\<^sub>k if List.member ks i \<and> List.member ms j then (if List.member ls k then f (i,k) * g (k,j) else bot) else bot)"
     by auto
   also have "... = (\<Squnion>\<^sub>k (if List.member ks i \<and> List.member ls k then f (i,k) else bot) * (if List.member ls k \<and> List.member ms j then g (k,j) else bot))"
     by (auto intro: sup_monoid.sum.cong)
   also have "... = (\<Squnion>\<^sub>k (ks\<langle>f\<rangle>ls) (i,k) * (ls\<langle>g\<rangle>ms) (k,j))"
     by (simp add: restrict_matrix_def)
   also have "... = (ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms) (i,j)"
     by (simp add: times_matrix_def)
   finally show "(ks\<langle>(ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms)\<rangle>ms) (i,j) = (ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms) (i,j)"
     .
 qed
 
 lemma restrict_star:
   fixes g :: "('a,'b::kleene_algebra) square"
   shows "t\<langle>star_matrix' t g\<rangle>t = star_matrix' t g"
 proof (induct arbitrary: g rule: list.induct)
   case Nil show ?case
     by (simp add: restrict_empty_left)
 next
   case (Cons k s)
   let ?t = "k#s"
   assume "\<And>g::('a,'b) square . s\<langle>star_matrix' s g\<rangle>s = star_matrix' s g"
   hence 1: "\<And>g::('a,'b) square . ?t\<langle>star_matrix' s g\<rangle>?t = star_matrix' s g"
     by (metis member_rec(1) restrict_superlist)
   show "?t\<langle>star_matrix' ?t g\<rangle>?t = star_matrix' ?t g"
   proof -
     let ?r = "[k]"
     let ?a = "?r\<langle>g\<rangle>?r"
     let ?b = "?r\<langle>g\<rangle>s"
     let ?c = "s\<langle>g\<rangle>?r"
     let ?d = "s\<langle>g\<rangle>s"
     let ?as = "?r\<langle>star o ?a\<rangle>?r"
     let ?ds = "star_matrix' s ?d"
     let ?e = "?a \<oplus> ?b \<odot> ?ds \<odot> ?c"
     let ?es = "?r\<langle>star o ?e\<rangle>?r"
     let ?f = "?d \<oplus> ?c \<odot> ?as \<odot> ?b"
     let ?fs = "star_matrix' s ?f"
     have 2: "?t\<langle>?as\<rangle>?t = ?as \<and> ?t\<langle>?b\<rangle>?t = ?b \<and> ?t\<langle>?c\<rangle>?t = ?c \<and> ?t\<langle>?es\<rangle>?t = ?es"
       by (simp add: restrict_superlist member_def)
     have 3: "?t\<langle>?ds\<rangle>?t = ?ds \<and> ?t\<langle>?fs\<rangle>?t = ?fs"
       using 1 by simp
     have 4: "?t\<langle>?t\<langle>?as\<rangle>?t \<odot> ?t\<langle>?b\<rangle>?t \<odot> ?t\<langle>?fs\<rangle>?t\<rangle>?t = ?t\<langle>?as\<rangle>?t \<odot> ?t\<langle>?b\<rangle>?t \<odot> ?t\<langle>?fs\<rangle>?t"
       by (metis (no_types) restrict_times)
     have 5: "?t\<langle>?t\<langle>?ds\<rangle>?t \<odot> ?t\<langle>?c\<rangle>?t \<odot> ?t\<langle>?es\<rangle>?t\<rangle>?t = ?t\<langle>?ds\<rangle>?t \<odot> ?t\<langle>?c\<rangle>?t \<odot> ?t\<langle>?es\<rangle>?t"
       by (metis (no_types) restrict_times)
     have "?t\<langle>star_matrix' ?t g\<rangle>?t = ?t\<langle>?es \<oplus> ?as \<odot> ?b \<odot> ?fs \<oplus> ?ds \<odot> ?c \<odot> ?es \<oplus> ?fs\<rangle>?t"
       by (metis star_matrix'.simps(2))
     also have "... = ?t\<langle>?es\<rangle>?t \<oplus> ?t\<langle>?as \<odot> ?b \<odot> ?fs\<rangle>?t \<oplus> ?t\<langle>?ds \<odot> ?c \<odot> ?es\<rangle>?t \<oplus> ?t\<langle>?fs\<rangle>?t"
       by (simp add: restrict_sup)
     also have "... = ?es \<oplus> ?as \<odot> ?b \<odot> ?fs \<oplus> ?ds \<odot> ?c \<odot> ?es \<oplus> ?fs"
       using 2 3 4 5 by simp
     also have "... = star_matrix' ?t g"
       by (metis star_matrix'.simps(2))
     finally show ?thesis
       .
   qed
 qed
 
 lemma restrict_one:
   assumes "\<not> List.member ks k"
     shows "(k#ks)\<langle>(mone::('a,'b::idempotent_semiring) square)\<rangle>(k#ks) = [k]\<langle>mone\<rangle>[k] \<oplus> ks\<langle>mone\<rangle>ks"
   by (subst restrict_nonempty) (simp add: assms member_rec one_disjoint)
 
 lemma restrict_one_left_unit:
   "ks\<langle>(mone::('a::finite,'b::idempotent_semiring) square)\<rangle>ks \<odot> ks\<langle>f\<rangle>ls = ks\<langle>f\<rangle>ls"
 proof (rule ext, rule prod_cases)
   let ?o = "mone::('a,'b::idempotent_semiring) square"
   fix i j
   have "(ks\<langle>?o\<rangle>ks \<odot> ks\<langle>f\<rangle>ls) (i,j) = (\<Squnion>\<^sub>k (ks\<langle>?o\<rangle>ks) (i,k) * (ks\<langle>f\<rangle>ls) (k,j))"
     by (simp add: times_matrix_def)
   also have "... = (\<Squnion>\<^sub>k (if List.member ks i \<and> List.member ks k then ?o (i,k) else bot) * (if List.member ks k \<and> List.member ls j then f (k,j) else bot))"
     by (simp add: restrict_matrix_def)
   also have "... = (\<Squnion>\<^sub>k (if List.member ks i \<and> List.member ks k then (if i = k then 1 else bot) else bot) * (if List.member ks k \<and> List.member ls j then f (k,j) else bot))"
     by (unfold one_matrix_def) auto
   also have "... = (\<Squnion>\<^sub>k (if i = k then (if List.member ks i then 1 else bot) else bot) * (if List.member ks k \<and> List.member ls j then f (k,j) else bot))"
     by (auto intro: sup_monoid.sum.cong)
   also have "... = (\<Squnion>\<^sub>k if i = k then (if List.member ks i then 1 else bot) * (if List.member ks i \<and> List.member ls j then f (i,j) else bot) else bot)"
     by (rule sup_monoid.sum.cong) simp_all
   also have "... = (if List.member ks i then 1 else bot) * (if List.member ks i \<and> List.member ls j then f (i,j) else bot)"
     by simp
   also have "... = (if List.member ks i \<and> List.member ls j then f (i,j) else bot)"
     by simp
   also have "... = (ks\<langle>f\<rangle>ls) (i,j)"
     by (simp add: restrict_matrix_def)
   finally show "(ks\<langle>?o\<rangle>ks \<odot> ks\<langle>f\<rangle>ls) (i,j) = (ks\<langle>f\<rangle>ls) (i,j)"
     .
 qed
 
 text \<open>
 The following lemmas consider restrictions to singleton index sets.
 \<close>
 
 lemma restrict_singleton:
   "([k]\<langle>f\<rangle>[l]) (i,j) = (if i = k \<and> j = l then f (i,j) else bot)"
   by (simp add: restrict_matrix_def List.member_def)
 
 lemma restrict_singleton_list:
   "([k]\<langle>f\<rangle>ls) (i,j) = (if i = k \<and> List.member ls j then f (i,j) else bot)"
   by (simp add: restrict_matrix_def List.member_def)
 
 lemma restrict_list_singleton:
   "(ks\<langle>f\<rangle>[l]) (i,j) = (if List.member ks i \<and> j = l then f (i,j) else bot)"
   by (simp add: restrict_matrix_def List.member_def)
 
 lemma restrict_singleton_product:
   fixes f g :: "('a::finite,'b::kleene_algebra) square"
   shows "([k]\<langle>f\<rangle>[l] \<odot> [m]\<langle>g\<rangle>[n]) (i,j) = (if i = k \<and> l = m \<and> j = n then f (i,l) * g (m,j) else bot)"
 proof -
   have "([k]\<langle>f\<rangle>[l] \<odot> [m]\<langle>g\<rangle>[n]) (i,j) = (\<Squnion>\<^sub>h ([k]\<langle>f\<rangle>[l]) (i,h) * ([m]\<langle>g\<rangle>[n]) (h,j))"
     by (simp add: times_matrix_def)
   also have "... = (\<Squnion>\<^sub>h (if i = k \<and> h = l then f (i,h) else bot) * (if h = m \<and> j = n then g (h,j) else bot))"
     by (simp add: restrict_singleton)
   also have "... = (\<Squnion>\<^sub>h if h = l then (if i = k then f (i,h) else bot) * (if h = m \<and> j = n then g (h,j) else bot) else bot)"
     by (rule sup_monoid.sum.cong) auto
   also have "... = (if i = k then f (i,l) else bot) * (if l = m \<and> j = n then g (l,j) else bot)"
     by simp
   also have "... = (if i = k \<and> l = m \<and> j = n then f (i,l) * g (m,j) else bot)"
     by simp
   finally show ?thesis
     .
 qed
 
 text \<open>
 The Kleene star unfold law holds for matrices with a single entry on the diagonal.
 \<close>
 
 lemma restrict_star_unfold:
   "[l]\<langle>(mone::('a::finite,'b::kleene_algebra) square)\<rangle>[l] \<oplus> [l]\<langle>f\<rangle>[l] \<odot> [l]\<langle>star o f\<rangle>[l] = [l]\<langle>star o f\<rangle>[l]"
 proof (rule ext, rule prod_cases)
   let ?o = "mone::('a,'b::kleene_algebra) square"
   fix i j
   have "([l]\<langle>?o\<rangle>[l] \<oplus> [l]\<langle>f\<rangle>[l] \<odot> [l]\<langle>star o f\<rangle>[l]) (i,j) = ([l]\<langle>?o\<rangle>[l]) (i,j) \<squnion> ([l]\<langle>f\<rangle>[l] \<odot> [l]\<langle>star o f\<rangle>[l]) (i,j)"
     by (simp add: sup_matrix_def)
   also have "... = ([l]\<langle>?o\<rangle>[l]) (i,j) \<squnion> (\<Squnion>\<^sub>k ([l]\<langle>f\<rangle>[l]) (i,k) * ([l]\<langle>star o f\<rangle>[l]) (k,j))"
     by (simp add: times_matrix_def)
   also have "... = ([l]\<langle>?o\<rangle>[l]) (i,j) \<squnion> (\<Squnion>\<^sub>k (if i = l \<and> k = l then f (i,k) else bot) * (if k = l \<and> j = l then (f (k,j))\<^sup>\<star> else bot))"
     by (simp add: restrict_singleton o_def)
   also have "... = ([l]\<langle>?o\<rangle>[l]) (i,j) \<squnion> (\<Squnion>\<^sub>k if k = l then (if i = l then f (i,k) else bot) * (if j = l then (f (k,j))\<^sup>\<star> else bot) else bot)"
     apply (rule arg_cong2[where f=sup])
     apply simp
     by (rule sup_monoid.sum.cong) auto
   also have "... = ([l]\<langle>?o\<rangle>[l]) (i,j) \<squnion> (if i = l then f (i,l) else bot) * (if j = l then (f (l,j))\<^sup>\<star> else bot)"
     by simp
   also have "... = (if i = l \<and> j = l then 1 \<squnion> f (l,l) * (f (l,l))\<^sup>\<star> else bot)"
     by (simp add: restrict_singleton one_matrix_def)
   also have "... = (if i = l \<and> j = l then (f (l,l))\<^sup>\<star> else bot)"
     by (simp add: star_left_unfold_equal)
   also have "... = ([l]\<langle>star o f\<rangle>[l]) (i,j)"
     by (simp add: restrict_singleton o_def)
   finally show "([l]\<langle>?o\<rangle>[l] \<oplus> [l]\<langle>f\<rangle>[l] \<odot> [l]\<langle>star o f\<rangle>[l]) (i,j) = ([l]\<langle>star o f\<rangle>[l]) (i,j)"
     .
 qed
 
 lemma restrict_all:
   "enum_class.enum\<langle>f\<rangle>enum_class.enum = f"
   by (simp add: restrict_matrix_def List.member_def enum_UNIV)
 
 text \<open>
 The following shows the various components of a matrix product.
 It is essentially a recursive implementation of the product.
 \<close>
 
 lemma restrict_nonempty_product:
   fixes f g :: "('a::finite,'b::idempotent_semiring) square"
   assumes "\<not> List.member ls l"
     shows "(k#ks)\<langle>f\<rangle>(l#ls) \<odot> (l#ls)\<langle>g\<rangle>(m#ms) = ([k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m] \<oplus> [k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m]) \<oplus> ([k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms \<oplus> [k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms) \<oplus> (ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m] \<oplus> ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m]) \<oplus> (ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms \<oplus> ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms)"
 proof -
   have "(k#ks)\<langle>f\<rangle>(l#ls) \<odot> (l#ls)\<langle>g\<rangle>(m#ms) = ([k]\<langle>f\<rangle>[l] \<oplus> [k]\<langle>f\<rangle>ls \<oplus> ks\<langle>f\<rangle>[l] \<oplus> ks\<langle>f\<rangle>ls) \<odot> ([l]\<langle>g\<rangle>[m] \<oplus> [l]\<langle>g\<rangle>ms \<oplus> ls\<langle>g\<rangle>[m] \<oplus> ls\<langle>g\<rangle>ms)"
     by (metis restrict_nonempty)
   also have "... = [k]\<langle>f\<rangle>[l] \<odot> ([l]\<langle>g\<rangle>[m] \<oplus> [l]\<langle>g\<rangle>ms \<oplus> ls\<langle>g\<rangle>[m] \<oplus> ls\<langle>g\<rangle>ms) \<oplus> [k]\<langle>f\<rangle>ls \<odot> ([l]\<langle>g\<rangle>[m] \<oplus> [l]\<langle>g\<rangle>ms \<oplus> ls\<langle>g\<rangle>[m] \<oplus> ls\<langle>g\<rangle>ms) \<oplus> ks\<langle>f\<rangle>[l] \<odot> ([l]\<langle>g\<rangle>[m] \<oplus> [l]\<langle>g\<rangle>ms \<oplus> ls\<langle>g\<rangle>[m] \<oplus> ls\<langle>g\<rangle>ms) \<oplus> ks\<langle>f\<rangle>ls \<odot> ([l]\<langle>g\<rangle>[m] \<oplus> [l]\<langle>g\<rangle>ms \<oplus> ls\<langle>g\<rangle>[m] \<oplus> ls\<langle>g\<rangle>ms)"
     by (simp add: matrix_idempotent_semiring.mult_right_dist_sup)
   also have "... = ([k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m] \<oplus> [k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms \<oplus> [k]\<langle>f\<rangle>[l] \<odot> ls\<langle>g\<rangle>[m] \<oplus> [k]\<langle>f\<rangle>[l] \<odot> ls\<langle>g\<rangle>ms) \<oplus> ([k]\<langle>f\<rangle>ls \<odot> [l]\<langle>g\<rangle>[m] \<oplus> [k]\<langle>f\<rangle>ls \<odot> [l]\<langle>g\<rangle>ms \<oplus> [k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m] \<oplus> [k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms) \<oplus> (ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m] \<oplus> ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms \<oplus> ks\<langle>f\<rangle>[l] \<odot> ls\<langle>g\<rangle>[m] \<oplus> ks\<langle>f\<rangle>[l] \<odot> ls\<langle>g\<rangle>ms) \<oplus> (ks\<langle>f\<rangle>ls \<odot> [l]\<langle>g\<rangle>[m] \<oplus> ks\<langle>f\<rangle>ls \<odot> [l]\<langle>g\<rangle>ms \<oplus> ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m] \<oplus> ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms)"
     by (simp add: matrix_idempotent_semiring.mult_left_dist_sup)
   also have "... = ([k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m] \<oplus> [k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms) \<oplus> ([k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m] \<oplus> [k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms) \<oplus> (ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m] \<oplus> ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms) \<oplus> (ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m] \<oplus> ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms)"
     using assms by (simp add: List.member_def times_disjoint)
   also have "... = ([k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m] \<oplus> [k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m]) \<oplus> ([k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms \<oplus> [k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms) \<oplus> (ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m] \<oplus> ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m]) \<oplus> (ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms \<oplus> ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms)"
     by (simp add: matrix_bounded_semilattice_sup_bot.sup_monoid.add_assoc matrix_semilattice_sup.sup_left_commute)
   finally show ?thesis
     .
 qed
 
 text \<open>
 Equality of matrices is componentwise.
 \<close>
 
 lemma restrict_nonempty_eq:
   "(k#ks)\<langle>f\<rangle>(l#ls) = (k#ks)\<langle>g\<rangle>(l#ls) \<longleftrightarrow> [k]\<langle>f\<rangle>[l] = [k]\<langle>g\<rangle>[l] \<and> [k]\<langle>f\<rangle>ls = [k]\<langle>g\<rangle>ls \<and> ks\<langle>f\<rangle>[l] = ks\<langle>g\<rangle>[l] \<and> ks\<langle>f\<rangle>ls = ks\<langle>g\<rangle>ls"
 proof
   assume 1: "(k#ks)\<langle>f\<rangle>(l#ls) = (k#ks)\<langle>g\<rangle>(l#ls)"
   have 2: "is_sublist [k] (k#ks) \<and> is_sublist ks (k#ks) \<and> is_sublist [l] (l#ls) \<and> is_sublist ls (l#ls)"
     by (simp add: member_rec)
   hence "[k]\<langle>f\<rangle>[l] = [k]\<langle>(k#ks)\<langle>f\<rangle>(l#ls)\<rangle>[l] \<and> [k]\<langle>f\<rangle>ls = [k]\<langle>(k#ks)\<langle>f\<rangle>(l#ls)\<rangle>ls \<and> ks\<langle>f\<rangle>[l] = ks\<langle>(k#ks)\<langle>f\<rangle>(l#ls)\<rangle>[l] \<and> ks\<langle>f\<rangle>ls = ks\<langle>(k#ks)\<langle>f\<rangle>(l#ls)\<rangle>ls"
     by (simp add: restrict_sublist)
   thus "[k]\<langle>f\<rangle>[l] = [k]\<langle>g\<rangle>[l] \<and> [k]\<langle>f\<rangle>ls = [k]\<langle>g\<rangle>ls \<and> ks\<langle>f\<rangle>[l] = ks\<langle>g\<rangle>[l] \<and> ks\<langle>f\<rangle>ls = ks\<langle>g\<rangle>ls"
     using 1 2 by (simp add: restrict_sublist)
 next
   assume 3: "[k]\<langle>f\<rangle>[l] = [k]\<langle>g\<rangle>[l] \<and> [k]\<langle>f\<rangle>ls = [k]\<langle>g\<rangle>ls \<and> ks\<langle>f\<rangle>[l] = ks\<langle>g\<rangle>[l] \<and> ks\<langle>f\<rangle>ls = ks\<langle>g\<rangle>ls"
   show "(k#ks)\<langle>f\<rangle>(l#ls) = (k#ks)\<langle>g\<rangle>(l#ls)"
   proof (rule ext, rule prod_cases)
     fix i j
     have 4: "f (k,l) = g (k,l)"
       using 3 by (metis restrict_singleton)
     have 5: "List.member ls j \<Longrightarrow> f (k,j) = g (k,j)"
       using 3 by (metis restrict_singleton_list)
     have 6: "List.member ks i \<Longrightarrow> f (i,l) = g (i,l)"
       using 3 by (metis restrict_list_singleton)
     have "(ks\<langle>f\<rangle>ls) (i,j) = (ks\<langle>g\<rangle>ls) (i,j)"
       using 3 by simp
     hence 7: "List.member ks i \<Longrightarrow> List.member ls j \<Longrightarrow> f (i,j) = g (i,j)"
       by (simp add: restrict_matrix_def)
     have "((k#ks)\<langle>f\<rangle>(l#ls)) (i,j) = (if (i = k \<or> List.member ks i) \<and> (j = l \<or> List.member ls j) then f (i,j) else bot)"
       by (simp add: restrict_matrix_def List.member_def)
     also have "... = (if i = k \<and> j = l then f (i,j) else if i = k \<and> List.member ls j then f (i,j) else if List.member ks i \<and> j = l then f (i,j) else if List.member ks i \<and> List.member ls j then f (i,j) else bot)"
       by auto
     also have "... = (if i = k \<and> j = l then g (i,j) else if i = k \<and> List.member ls j then g (i,j) else if List.member ks i \<and> j = l then g (i,j) else if List.member ks i \<and> List.member ls j then g (i,j) else bot)"
       using 4 5 6 7 by simp
     also have "... = (if (i = k \<or> List.member ks i) \<and> (j = l \<or> List.member ls j) then g (i,j) else bot)"
       by auto
     also have "... = ((k#ks)\<langle>g\<rangle>(l#ls)) (i,j)"
       by (simp add: restrict_matrix_def List.member_def)
     finally show "((k#ks)\<langle>f\<rangle>(l#ls)) (i,j) = ((k#ks)\<langle>g\<rangle>(l#ls)) (i,j)"
       .
   qed
 qed
 
 text \<open>
 Inequality of matrices is componentwise.
 \<close>
 
 lemma restrict_nonempty_less_eq:
   fixes f g :: "('a,'b::idempotent_semiring) square"
   shows "(k#ks)\<langle>f\<rangle>(l#ls) \<preceq> (k#ks)\<langle>g\<rangle>(l#ls) \<longleftrightarrow> [k]\<langle>f\<rangle>[l] \<preceq> [k]\<langle>g\<rangle>[l] \<and> [k]\<langle>f\<rangle>ls \<preceq> [k]\<langle>g\<rangle>ls \<and> ks\<langle>f\<rangle>[l] \<preceq> ks\<langle>g\<rangle>[l] \<and> ks\<langle>f\<rangle>ls \<preceq> ks\<langle>g\<rangle>ls"
   by (unfold matrix_semilattice_sup.sup.order_iff) (metis (no_types, lifting) restrict_nonempty_eq restrict_sup)
 
 text \<open>
 The following lemmas treat repeated restrictions to disjoint index sets.
 \<close>
 
 lemma restrict_disjoint_left:
   assumes "disjoint ks ms"
     shows "ms\<langle>ks\<langle>f\<rangle>ls\<rangle>ns = mbot"
 proof (rule ext, rule prod_cases)
   fix i j
   have "(ms\<langle>ks\<langle>f\<rangle>ls\<rangle>ns) (i,j) = (if List.member ms i \<and> List.member ns j then if List.member ks i \<and> List.member ls j then f (i,j) else bot else bot)"
     by (simp add: restrict_matrix_def)
   thus "(ms\<langle>ks\<langle>f\<rangle>ls\<rangle>ns) (i,j) = mbot (i,j)"
     using assms by (simp add: bot_matrix_def)
 qed
 
 lemma restrict_disjoint_right:
   assumes "disjoint ls ns"
     shows "ms\<langle>ks\<langle>f\<rangle>ls\<rangle>ns = mbot"
 proof (rule ext, rule prod_cases)
   fix i j
   have "(ms\<langle>ks\<langle>f\<rangle>ls\<rangle>ns) (i,j) = (if List.member ms i \<and> List.member ns j then if List.member ks i \<and> List.member ls j then f (i,j) else bot else bot)"
     by (simp add: restrict_matrix_def)
   thus "(ms\<langle>ks\<langle>f\<rangle>ls\<rangle>ns) (i,j) = mbot (i,j)"
     using assms by (simp add: bot_matrix_def)
 qed
 
 text \<open>
 The following lemma expresses the equality of a matrix and a product of two matrices componentwise.
 \<close>
 
 lemma restrict_nonempty_product_eq:
   fixes f g h :: "('a::finite,'b::idempotent_semiring) square"
   assumes "\<not> List.member ks k"
       and "\<not> List.member ls l"
       and "\<not> List.member ms m"
     shows "(k#ks)\<langle>f\<rangle>(l#ls) \<odot> (l#ls)\<langle>g\<rangle>(m#ms) = (k#ks)\<langle>h\<rangle>(m#ms) \<longleftrightarrow> [k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m] \<oplus> [k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m] = [k]\<langle>h\<rangle>[m] \<and> [k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms \<oplus> [k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms = [k]\<langle>h\<rangle>ms \<and> ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m] \<oplus> ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m] = ks\<langle>h\<rangle>[m] \<and> ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms \<oplus> ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms = ks\<langle>h\<rangle>ms"
 proof -
   have 1: "disjoint [k] ks \<and> disjoint [m] ms"
     by (simp add: assms(1,3) member_rec)
   have 2: "[k]\<langle>(k#ks)\<langle>f\<rangle>(l#ls) \<odot> (l#ls)\<langle>g\<rangle>(m#ms)\<rangle>[m] = [k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m] \<oplus> [k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m]"
   proof -
     have "[k]\<langle>(k#ks)\<langle>f\<rangle>(l#ls) \<odot> (l#ls)\<langle>g\<rangle>(m#ms)\<rangle>[m] = [k]\<langle>([k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m] \<oplus> [k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m]) \<oplus> ([k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms \<oplus> [k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms) \<oplus> (ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m] \<oplus> ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m]) \<oplus> (ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms \<oplus> ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms)\<rangle>[m]"
       by (simp add: assms(2) restrict_nonempty_product)
     also have "... = [k]\<langle>[k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m]\<rangle>[m] \<oplus> [k]\<langle>[k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m]\<rangle>[m] \<oplus> [k]\<langle>[k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms\<rangle>[m] \<oplus> [k]\<langle>[k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms\<rangle>[m] \<oplus> [k]\<langle>ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m]\<rangle>[m] \<oplus> [k]\<langle>ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m]\<rangle>[m] \<oplus> [k]\<langle>ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms\<rangle>[m] \<oplus> [k]\<langle>ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms\<rangle>[m]"
       by (simp add: matrix_bounded_semilattice_sup_bot.sup_monoid.add_assoc restrict_sup)
     also have "... = [k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m] \<oplus> [k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m] \<oplus> [k]\<langle>[k]\<langle>[k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms\<rangle>ms\<rangle>[m] \<oplus> [k]\<langle>[k]\<langle>[k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms\<rangle>ms\<rangle>[m] \<oplus> [k]\<langle>ks\<langle>ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m]\<rangle>[m]\<rangle>[m] \<oplus> [k]\<langle>ks\<langle>ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m]\<rangle>[m]\<rangle>[m] \<oplus> [k]\<langle>ks\<langle>ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms\<rangle>ms\<rangle>[m] \<oplus> [k]\<langle>ks\<langle>ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms\<rangle>ms\<rangle>[m]"
       by (simp add: restrict_times)
     also have "... = [k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m] \<oplus> [k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m]"
       using 1 by (metis restrict_disjoint_left restrict_disjoint_right matrix_bounded_semilattice_sup_bot.sup_monoid.add_0_right)
     finally show ?thesis
       .
   qed
   have 3: "[k]\<langle>(k#ks)\<langle>f\<rangle>(l#ls) \<odot> (l#ls)\<langle>g\<rangle>(m#ms)\<rangle>ms = [k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms \<oplus> [k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms"
   proof -
     have "[k]\<langle>(k#ks)\<langle>f\<rangle>(l#ls) \<odot> (l#ls)\<langle>g\<rangle>(m#ms)\<rangle>ms = [k]\<langle>([k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m] \<oplus> [k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m]) \<oplus> ([k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms \<oplus> [k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms) \<oplus> (ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m] \<oplus> ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m]) \<oplus> (ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms \<oplus> ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms)\<rangle>ms"
       by (simp add: assms(2) restrict_nonempty_product)
     also have "... = [k]\<langle>[k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m]\<rangle>ms \<oplus> [k]\<langle>[k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m]\<rangle>ms \<oplus> [k]\<langle>[k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms\<rangle>ms \<oplus> [k]\<langle>[k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms\<rangle>ms \<oplus> [k]\<langle>ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m]\<rangle>ms \<oplus> [k]\<langle>ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m]\<rangle>ms \<oplus> [k]\<langle>ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms\<rangle>ms \<oplus> [k]\<langle>ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms\<rangle>ms"
       by (simp add: matrix_bounded_semilattice_sup_bot.sup_monoid.add_assoc restrict_sup)
     also have "... = [k]\<langle>[k]\<langle>[k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m]\<rangle>[m]\<rangle>ms \<oplus> [k]\<langle>[k]\<langle>[k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m]\<rangle>[m]\<rangle>ms \<oplus> [k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms \<oplus> [k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms \<oplus> [k]\<langle>ks\<langle>ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m]\<rangle>[m]\<rangle>ms \<oplus> [k]\<langle>ks\<langle>ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m]\<rangle>[m]\<rangle>ms \<oplus> [k]\<langle>ks\<langle>ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms\<rangle>ms\<rangle>ms \<oplus> [k]\<langle>ks\<langle>ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms\<rangle>ms\<rangle>ms"
       by (simp add: restrict_times)
     also have "... = [k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms \<oplus> [k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms"
       using 1 by (metis restrict_disjoint_left restrict_disjoint_right matrix_bounded_semilattice_sup_bot.sup_monoid.add_0_right matrix_bounded_semilattice_sup_bot.sup_monoid.add_0_left)
     finally show ?thesis
       .
   qed
   have 4: "ks\<langle>(k#ks)\<langle>f\<rangle>(l#ls) \<odot> (l#ls)\<langle>g\<rangle>(m#ms)\<rangle>[m] = ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m] \<oplus> ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m]"
   proof -
     have "ks\<langle>(k#ks)\<langle>f\<rangle>(l#ls) \<odot> (l#ls)\<langle>g\<rangle>(m#ms)\<rangle>[m] = ks\<langle>([k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m] \<oplus> [k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m]) \<oplus> ([k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms \<oplus> [k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms) \<oplus> (ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m] \<oplus> ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m]) \<oplus> (ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms \<oplus> ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms)\<rangle>[m]"
       by (simp add: assms(2) restrict_nonempty_product)
     also have "... = ks\<langle>[k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m]\<rangle>[m] \<oplus> ks\<langle>[k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m]\<rangle>[m] \<oplus> ks\<langle>[k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms\<rangle>[m] \<oplus> ks\<langle>[k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms\<rangle>[m] \<oplus> ks\<langle>ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m]\<rangle>[m] \<oplus> ks\<langle>ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m]\<rangle>[m] \<oplus> ks\<langle>ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms\<rangle>[m] \<oplus> ks\<langle>ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms\<rangle>[m]"
       by (simp add: matrix_bounded_semilattice_sup_bot.sup_monoid.add_assoc restrict_sup)
     also have "... = ks\<langle>[k]\<langle>[k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m]\<rangle>[m]\<rangle>[m] \<oplus> ks\<langle>[k]\<langle>[k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m]\<rangle>[m]\<rangle>[m] \<oplus> ks\<langle>[k]\<langle>[k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms\<rangle>ms\<rangle>[m] \<oplus> ks\<langle>[k]\<langle>[k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms\<rangle>ms\<rangle>[m] \<oplus> ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m] \<oplus> ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m] \<oplus> ks\<langle>ks\<langle>ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms\<rangle>ms\<rangle>[m] \<oplus> ks\<langle>ks\<langle>ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms\<rangle>ms\<rangle>[m]"
       by (simp add: restrict_times)
     also have "... = ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m] \<oplus> ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m]"
       using 1 by (metis restrict_disjoint_left restrict_disjoint_right matrix_bounded_semilattice_sup_bot.sup_monoid.add_0_right matrix_bounded_semilattice_sup_bot.sup_monoid.add_0_left)
     finally show ?thesis
       .
   qed
   have 5: "ks\<langle>(k#ks)\<langle>f\<rangle>(l#ls) \<odot> (l#ls)\<langle>g\<rangle>(m#ms)\<rangle>ms = ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms \<oplus> ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms"
   proof -
     have "ks\<langle>(k#ks)\<langle>f\<rangle>(l#ls) \<odot> (l#ls)\<langle>g\<rangle>(m#ms)\<rangle>ms = ks\<langle>([k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m] \<oplus> [k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m]) \<oplus> ([k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms \<oplus> [k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms) \<oplus> (ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m] \<oplus> ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m]) \<oplus> (ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms \<oplus> ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms)\<rangle>ms"
       by (simp add: assms(2) restrict_nonempty_product)
     also have "... = ks\<langle>[k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m]\<rangle>ms \<oplus> ks\<langle>[k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m]\<rangle>ms \<oplus> ks\<langle>[k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms\<rangle>ms \<oplus> ks\<langle>[k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms\<rangle>ms \<oplus> ks\<langle>ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m]\<rangle>ms \<oplus> ks\<langle>ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m]\<rangle>ms \<oplus> ks\<langle>ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms\<rangle>ms \<oplus> ks\<langle>ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms\<rangle>ms"
       by (simp add: matrix_bounded_semilattice_sup_bot.sup_monoid.add_assoc restrict_sup)
     also have "... = ks\<langle>[k]\<langle>[k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m]\<rangle>[m]\<rangle>ms \<oplus> ks\<langle>[k]\<langle>[k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m]\<rangle>[m]\<rangle>ms \<oplus> ks\<langle>[k]\<langle>[k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms\<rangle>ms\<rangle>ms \<oplus> ks\<langle>[k]\<langle>[k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms\<rangle>ms\<rangle>ms \<oplus> ks\<langle>ks\<langle>ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m]\<rangle>[m]\<rangle>ms \<oplus> ks\<langle>ks\<langle>ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m]\<rangle>[m]\<rangle>ms \<oplus> ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms \<oplus> ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms"
       by (simp add: restrict_times)
     also have "... = ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms \<oplus> ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms"
       using 1 by (metis restrict_disjoint_left restrict_disjoint_right matrix_bounded_semilattice_sup_bot.sup_monoid.add_0_left)
     finally show ?thesis
       .
   qed
   have "(k#ks)\<langle>f\<rangle>(l#ls) \<odot> (l#ls)\<langle>g\<rangle>(m#ms) = (k#ks)\<langle>h\<rangle>(m#ms) \<longleftrightarrow> (k#ks)\<langle>(k#ks)\<langle>f\<rangle>(l#ls) \<odot> (l#ls)\<langle>g\<rangle>(m#ms)\<rangle>(m#ms) = (k#ks)\<langle>h\<rangle>(m#ms)"
     by (simp add: restrict_times)
   also have "... \<longleftrightarrow> [k]\<langle>(k#ks)\<langle>f\<rangle>(l#ls) \<odot> (l#ls)\<langle>g\<rangle>(m#ms)\<rangle>[m] = [k]\<langle>h\<rangle>[m] \<and> [k]\<langle>(k#ks)\<langle>f\<rangle>(l#ls) \<odot> (l#ls)\<langle>g\<rangle>(m#ms)\<rangle>ms = [k]\<langle>h\<rangle>ms \<and> ks\<langle>(k#ks)\<langle>f\<rangle>(l#ls) \<odot> (l#ls)\<langle>g\<rangle>(m#ms)\<rangle>[m] = ks\<langle>h\<rangle>[m] \<and> ks\<langle>(k#ks)\<langle>f\<rangle>(l#ls) \<odot> (l#ls)\<langle>g\<rangle>(m#ms)\<rangle>ms = ks\<langle>h\<rangle>ms"
     by (meson restrict_nonempty_eq)
   also have "... \<longleftrightarrow> [k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m] \<oplus> [k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m] = [k]\<langle>h\<rangle>[m] \<and> [k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms \<oplus> [k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms = [k]\<langle>h\<rangle>ms \<and> ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m] \<oplus> ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m] = ks\<langle>h\<rangle>[m] \<and> ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms \<oplus> ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms = ks\<langle>h\<rangle>ms"
     using 2 3 4 5 by simp
   finally show ?thesis
     by simp
 qed
 
 text \<open>
 The following lemma gives a componentwise characterisation of the inequality of a matrix and a product of two matrices.
 \<close>
 
 lemma restrict_nonempty_product_less_eq:
   fixes f g h :: "('a::finite,'b::idempotent_semiring) square"
   assumes "\<not> List.member ks k"
       and "\<not> List.member ls l"
       and "\<not> List.member ms m"
     shows "(k#ks)\<langle>f\<rangle>(l#ls) \<odot> (l#ls)\<langle>g\<rangle>(m#ms) \<preceq> (k#ks)\<langle>h\<rangle>(m#ms) \<longleftrightarrow> [k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m] \<oplus> [k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m] \<preceq> [k]\<langle>h\<rangle>[m] \<and> [k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms \<oplus> [k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms \<preceq> [k]\<langle>h\<rangle>ms \<and> ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m] \<oplus> ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m] \<preceq> ks\<langle>h\<rangle>[m] \<and> ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms \<oplus> ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms \<preceq> ks\<langle>h\<rangle>ms"
 proof -
   have 1: "[k]\<langle>(k#ks)\<langle>f\<rangle>(l#ls) \<odot> (l#ls)\<langle>g\<rangle>(m#ms)\<rangle>[m] = [k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m] \<oplus> [k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m]"
     by (metis assms restrict_nonempty_product_eq restrict_times)
   have 2: "[k]\<langle>(k#ks)\<langle>f\<rangle>(l#ls) \<odot> (l#ls)\<langle>g\<rangle>(m#ms)\<rangle>ms = [k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms \<oplus> [k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms"
     by (metis assms restrict_nonempty_product_eq restrict_times)
   have 3: "ks\<langle>(k#ks)\<langle>f\<rangle>(l#ls) \<odot> (l#ls)\<langle>g\<rangle>(m#ms)\<rangle>[m] = ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m] \<oplus> ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m]"
     by (metis assms restrict_nonempty_product_eq restrict_times)
   have 4: "ks\<langle>(k#ks)\<langle>f\<rangle>(l#ls) \<odot> (l#ls)\<langle>g\<rangle>(m#ms)\<rangle>ms = ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms \<oplus> ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms"
     by (metis assms restrict_nonempty_product_eq restrict_times)
   have "(k#ks)\<langle>f\<rangle>(l#ls) \<odot> (l#ls)\<langle>g\<rangle>(m#ms) \<preceq> (k#ks)\<langle>h\<rangle>(m#ms) \<longleftrightarrow> (k#ks)\<langle>(k#ks)\<langle>f\<rangle>(l#ls) \<odot> (l#ls)\<langle>g\<rangle>(m#ms)\<rangle>(m#ms) \<preceq> (k#ks)\<langle>h\<rangle>(m#ms)"
     by (simp add: restrict_times)
   also have "... \<longleftrightarrow> [k]\<langle>(k#ks)\<langle>f\<rangle>(l#ls) \<odot> (l#ls)\<langle>g\<rangle>(m#ms)\<rangle>[m] \<preceq> [k]\<langle>h\<rangle>[m] \<and> [k]\<langle>(k#ks)\<langle>f\<rangle>(l#ls) \<odot> (l#ls)\<langle>g\<rangle>(m#ms)\<rangle>ms \<preceq> [k]\<langle>h\<rangle>ms \<and> ks\<langle>(k#ks)\<langle>f\<rangle>(l#ls) \<odot> (l#ls)\<langle>g\<rangle>(m#ms)\<rangle>[m] \<preceq> ks\<langle>h\<rangle>[m] \<and> ks\<langle>(k#ks)\<langle>f\<rangle>(l#ls) \<odot> (l#ls)\<langle>g\<rangle>(m#ms)\<rangle>ms \<preceq> ks\<langle>h\<rangle>ms"
     by (meson restrict_nonempty_less_eq)
   also have "... \<longleftrightarrow> [k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m] \<oplus> [k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m] \<preceq> [k]\<langle>h\<rangle>[m] \<and> [k]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms \<oplus> [k]\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms \<preceq> [k]\<langle>h\<rangle>ms \<and> ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m] \<oplus> ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>[m] \<preceq> ks\<langle>h\<rangle>[m] \<and> ks\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms \<oplus> ks\<langle>f\<rangle>ls \<odot> ls\<langle>g\<rangle>ms \<preceq> ks\<langle>h\<rangle>ms"
     using 1 2 3 4 by simp
   finally show ?thesis
     by simp
 qed
 
 text \<open>
 The Kleene star induction laws hold for matrices with a single entry on the diagonal.
 The matrix \<open>g\<close> can actually contain a whole row/colum at the appropriate index.
 \<close>
 
 lemma restrict_star_left_induct:
   fixes f g :: "('a::finite,'b::kleene_algebra) square"
   shows "distinct ms \<Longrightarrow> [l]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms \<preceq> [l]\<langle>g\<rangle>ms \<Longrightarrow> [l]\<langle>star o f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms \<preceq> [l]\<langle>g\<rangle>ms"
 proof (induct ms)
   case Nil thus ?case
     by (simp add: restrict_empty_right)
 next
   case (Cons m ms)
   assume 1: "distinct ms \<Longrightarrow> [l]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms \<preceq> [l]\<langle>g\<rangle>ms \<Longrightarrow> [l]\<langle>star o f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms \<preceq> [l]\<langle>g\<rangle>ms"
   assume 2: "distinct (m#ms)"
   assume 3: "[l]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>(m#ms) \<preceq> [l]\<langle>g\<rangle>(m#ms)"
   have 4: "[l]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m] \<preceq> [l]\<langle>g\<rangle>[m] \<and> [l]\<langle>f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms \<preceq> [l]\<langle>g\<rangle>ms"
     using 2 3 by (metis distinct.simps(2) matrix_semilattice_sup.sup.bounded_iff member_def member_rec(2) restrict_nonempty_product_less_eq)
   hence 5: "[l]\<langle>star o f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>ms \<preceq> [l]\<langle>g\<rangle>ms"
     using 1 2 by simp
   have "f (l,l) * g (l,m) \<le> g (l,m)"
     using 4 by (metis restrict_singleton_product restrict_singleton less_eq_matrix_def)
   hence 6: "(f (l,l))\<^sup>\<star> * g (l,m) \<le> g (l,m)"
     by (simp add: star_left_induct_mult)
   have "[l]\<langle>star o f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m] \<preceq> [l]\<langle>g\<rangle>[m]"
   proof (unfold less_eq_matrix_def, rule allI, rule prod_cases)
     fix i j
     have "([l]\<langle>star o f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m]) (i,j) = (\<Squnion>\<^sub>k ([l]\<langle>star o f\<rangle>[l]) (i,k) * ([l]\<langle>g\<rangle>[m]) (k,j))"
       by (simp add: times_matrix_def)
     also have "... = (\<Squnion>\<^sub>k (if i = l \<and> k = l then (f (i,k))\<^sup>\<star> else bot) * (if k = l \<and> j = m then g (k,j) else bot))"
       by (simp add: restrict_singleton o_def)
     also have "... = (\<Squnion>\<^sub>k if k = l then (if i = l then (f (i,k))\<^sup>\<star> else bot) * (if j = m then g (k,j) else bot) else bot)"
       by (rule sup_monoid.sum.cong) auto
     also have "... = (if i = l then (f (i,l))\<^sup>\<star> else bot) * (if j = m then g (l,j) else bot)"
       by simp
     also have "... = (if i = l \<and> j = m then (f (l,l))\<^sup>\<star> * g (l,m) else bot)"
       by simp
     also have "... \<le> ([l]\<langle>g\<rangle>[m]) (i,j)"
       using 6 by (simp add: restrict_singleton)
     finally show "([l]\<langle>star o f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>[m]) (i,j) \<le> ([l]\<langle>g\<rangle>[m]) (i,j)"
       .
   qed
   thus "[l]\<langle>star o f\<rangle>[l] \<odot> [l]\<langle>g\<rangle>(m#ms) \<preceq> [l]\<langle>g\<rangle>(m#ms)"
     using 2 5 by (metis (no_types, opaque_lifting) matrix_idempotent_semiring.mult_left_dist_sup matrix_semilattice_sup.sup.mono restrict_nonempty_right)
 qed
 
 lemma restrict_star_right_induct:
   fixes f g :: "('a::finite,'b::kleene_algebra) square"
   shows "distinct ms \<Longrightarrow> ms\<langle>g\<rangle>[l] \<odot> [l]\<langle>f\<rangle>[l] \<preceq> ms\<langle>g\<rangle>[l] \<Longrightarrow> ms\<langle>g\<rangle>[l] \<odot> [l]\<langle>star o f\<rangle>[l] \<preceq> ms\<langle>g\<rangle>[l]"
 proof (induct ms)
   case Nil thus ?case
     by (simp add: restrict_empty_left)
 next
   case (Cons m ms)
   assume 1: "distinct ms \<Longrightarrow> ms\<langle>g\<rangle>[l] \<odot> [l]\<langle>f\<rangle>[l] \<preceq> ms\<langle>g\<rangle>[l] \<Longrightarrow> ms\<langle>g\<rangle>[l] \<odot> [l]\<langle>star o f\<rangle>[l] \<preceq> ms\<langle>g\<rangle>[l]"
   assume 2: "distinct (m#ms)"
   assume 3: "(m#ms)\<langle>g\<rangle>[l] \<odot> [l]\<langle>f\<rangle>[l] \<preceq> (m#ms)\<langle>g\<rangle>[l]"
   have 4: "[m]\<langle>g\<rangle>[l] \<odot> [l]\<langle>f\<rangle>[l] \<preceq> [m]\<langle>g\<rangle>[l] \<and> ms\<langle>g\<rangle>[l] \<odot> [l]\<langle>f\<rangle>[l] \<preceq> ms\<langle>g\<rangle>[l]"
     using 2 3 by (metis distinct.simps(2) matrix_semilattice_sup.sup.bounded_iff member_def member_rec(2) restrict_nonempty_product_less_eq)
   hence 5: "ms\<langle>g\<rangle>[l] \<odot> [l]\<langle>star o f\<rangle>[l] \<preceq> ms\<langle>g\<rangle>[l]"
     using 1 2  by simp
   have "g (m,l) * f (l,l) \<le> g (m,l)"
     using 4 by (metis restrict_singleton_product restrict_singleton less_eq_matrix_def)
   hence 6: "g (m,l) * (f (l,l))\<^sup>\<star> \<le> g (m,l)"
     by (simp add: star_right_induct_mult)
   have "[m]\<langle>g\<rangle>[l] \<odot> [l]\<langle>star o f\<rangle>[l] \<preceq> [m]\<langle>g\<rangle>[l]"
   proof (unfold less_eq_matrix_def, rule allI, rule prod_cases)
     fix i j
     have "([m]\<langle>g\<rangle>[l] \<odot> [l]\<langle>star o f\<rangle>[l]) (i,j) = (\<Squnion>\<^sub>k ([m]\<langle>g\<rangle>[l]) (i,k) * ([l]\<langle>star o f\<rangle>[l]) (k,j))"
       by (simp add: times_matrix_def)
     also have "... = (\<Squnion>\<^sub>k (if i = m \<and> k = l then g (i,k) else bot) * (if k = l \<and> j = l then (f (k,j))\<^sup>\<star> else bot))"
       by (simp add: restrict_singleton o_def)
     also have "... = (\<Squnion>\<^sub>k if k = l then (if i = m then g (i,k) else bot) * (if j = l then (f (k,j))\<^sup>\<star> else bot) else bot)"
       by (rule sup_monoid.sum.cong) auto
     also have "... = (if i = m then g (i,l) else bot) * (if j = l then (f (l,j))\<^sup>\<star> else bot)"
       by simp
     also have "... = (if i = m \<and> j = l then g (m,l) * (f (l,l))\<^sup>\<star> else bot)"
       by simp
     also have "... \<le> ([m]\<langle>g\<rangle>[l]) (i,j)"
       using 6 by (simp add: restrict_singleton)
     finally show "([m]\<langle>g\<rangle>[l] \<odot> [l]\<langle>star o f\<rangle>[l]) (i,j) \<le> ([m]\<langle>g\<rangle>[l]) (i,j)"
       .
   qed
   thus "(m#ms)\<langle>g\<rangle>[l] \<odot> [l]\<langle>star o f\<rangle>[l] \<preceq> (m#ms)\<langle>g\<rangle>[l]"
     using 2 5 by (metis (no_types, opaque_lifting) matrix_idempotent_semiring.mult_right_dist_sup matrix_semilattice_sup.sup.mono restrict_nonempty_left)
 qed
 
 lemma restrict_pp:
   fixes f :: "('a,'b::p_algebra) square"
   shows "ks\<langle>\<ominus>\<ominus>f\<rangle>ls = \<ominus>\<ominus>(ks\<langle>f\<rangle>ls)"
   by (unfold restrict_matrix_def uminus_matrix_def) auto
 
 lemma pp_star_commute:
   fixes f :: "('a,'b::stone_kleene_relation_algebra) square"
   shows "\<ominus>\<ominus>(star o f) = star o \<ominus>\<ominus>f"
   by (simp add: uminus_matrix_def o_def pp_dist_star)
 
 subsection \<open>Matrices form a Kleene Algebra\<close>
 
 text \<open>
 Matrices over Kleene algebras form a Kleene algebra using Conway's construction.
 It remains to prove one unfold and two induction axioms of the Kleene star.
 Each proof is by induction over the size of the matrix represented by an index list.
 \<close>
 
 interpretation matrix_kleene_algebra: kleene_algebra_var where sup = sup_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix::('a::enum,'b::kleene_algebra) square" and one = one_matrix and times = times_matrix and star = star_matrix
 proof
   fix y :: "('a,'b) square"
   let ?e = "enum_class.enum::'a list"
   let ?o = "mone :: ('a,'b) square"
   have "\<forall>g :: ('a,'b) square . distinct ?e \<longrightarrow> (?e\<langle>?o\<rangle>?e \<oplus> ?e\<langle>g\<rangle>?e \<odot> star_matrix' ?e g) = (star_matrix' ?e g)"
   proof (induct rule: list.induct)
     case Nil thus ?case
       by (simp add: restrict_empty_left)
   next
     case (Cons k s)
     let ?t = "k#s"
     assume 1: "\<forall>g :: ('a,'b) square . distinct s \<longrightarrow> (s\<langle>?o\<rangle>s \<oplus> s\<langle>g\<rangle>s \<odot> star_matrix' s g) = (star_matrix' s g)"
     show "\<forall>g :: ('a,'b) square . distinct ?t \<longrightarrow> (?t\<langle>?o\<rangle>?t \<oplus> ?t\<langle>g\<rangle>?t \<odot> star_matrix' ?t g) = (star_matrix' ?t g)"
     proof (rule allI, rule impI)
       fix g :: "('a,'b) square"
       assume 2: "distinct ?t"
       let ?r = "[k]"
       let ?a = "?r\<langle>g\<rangle>?r"
       let ?b = "?r\<langle>g\<rangle>s"
       let ?c = "s\<langle>g\<rangle>?r"
       let ?d = "s\<langle>g\<rangle>s"
       let ?as = "?r\<langle>star o ?a\<rangle>?r"
       let ?ds = "star_matrix' s ?d"
       let ?e = "?a \<oplus> ?b \<odot> ?ds \<odot> ?c"
       let ?es = "?r\<langle>star o ?e\<rangle>?r"
       let ?f = "?d \<oplus> ?c \<odot> ?as \<odot> ?b"
       let ?fs = "star_matrix' s ?f"
       have "s\<langle>?ds\<rangle>s = ?ds \<and> s\<langle>?fs\<rangle>s = ?fs"
         by (simp add: restrict_star)
       hence 3: "?r\<langle>?e\<rangle>?r = ?e \<and> s\<langle>?f\<rangle>s = ?f"
         by (metis (no_types, lifting) restrict_one_left_unit restrict_sup restrict_times)
       have 4: "disjoint s ?r \<and> disjoint ?r s"
         using 2 by (simp add: in_set_member member_rec)
       hence 5: "?t\<langle>?o\<rangle>?t = ?r\<langle>?o\<rangle>?r \<oplus> s\<langle>?o\<rangle>s"
         by (meson member_rec(1) restrict_one)
       have 6: "?t\<langle>g\<rangle>?t \<odot> ?es = ?a \<odot> ?es \<oplus> ?c \<odot> ?es"
       proof -
         have "?t\<langle>g\<rangle>?t \<odot> ?es = (?a \<oplus> ?b \<oplus> ?c \<oplus> ?d) \<odot> ?es"
           by (metis restrict_nonempty)
         also have "... = ?a \<odot> ?es \<oplus> ?b \<odot> ?es \<oplus> ?c \<odot> ?es \<oplus> ?d \<odot> ?es"
           by (simp add: matrix_idempotent_semiring.mult_right_dist_sup)
         also have "... = ?a \<odot> ?es \<oplus> ?c \<odot> ?es"
           using 4 by (simp add: times_disjoint)
         finally show ?thesis
           .
       qed
       have 7: "?t\<langle>g\<rangle>?t \<odot> ?as \<odot> ?b \<odot> ?fs = ?a \<odot> ?as \<odot> ?b \<odot> ?fs \<oplus> ?c \<odot> ?as \<odot> ?b \<odot> ?fs"
       proof -
         have "?t\<langle>g\<rangle>?t \<odot> ?as \<odot> ?b \<odot> ?fs = (?a \<oplus> ?b \<oplus> ?c \<oplus> ?d) \<odot> ?as \<odot> ?b \<odot> ?fs"
           by (metis restrict_nonempty)
         also have "... = ?a \<odot> ?as \<odot> ?b \<odot> ?fs \<oplus> ?b \<odot> ?as \<odot> ?b \<odot> ?fs \<oplus> ?c \<odot> ?as \<odot> ?b \<odot> ?fs \<oplus> ?d \<odot> ?as \<odot> ?b \<odot> ?fs"
           by (simp add: matrix_idempotent_semiring.mult_right_dist_sup)
         also have "... = ?a \<odot> ?as \<odot> ?b \<odot> ?fs \<oplus> ?c \<odot> ?as \<odot> ?b \<odot> ?fs"
           using 4 by (simp add: times_disjoint)
         finally show ?thesis
           .
       qed
       have 8: "?t\<langle>g\<rangle>?t \<odot> ?ds \<odot> ?c \<odot> ?es = ?b \<odot> ?ds \<odot> ?c \<odot> ?es \<oplus> ?d \<odot> ?ds \<odot> ?c \<odot> ?es"
       proof -
         have "?t\<langle>g\<rangle>?t \<odot> ?ds \<odot> ?c \<odot> ?es = (?a \<oplus> ?b \<oplus> ?c \<oplus> ?d) \<odot> ?ds \<odot> ?c \<odot> ?es"
           by (metis restrict_nonempty)
         also have "... = ?a \<odot> ?ds \<odot> ?c \<odot> ?es \<oplus> ?b \<odot> ?ds \<odot> ?c \<odot> ?es \<oplus> ?c \<odot> ?ds \<odot> ?c \<odot> ?es \<oplus> ?d \<odot> ?ds \<odot> ?c \<odot> ?es"
           by (simp add: matrix_idempotent_semiring.mult_right_dist_sup)
         also have "... = ?b \<odot> ?ds \<odot> ?c \<odot> ?es \<oplus> ?d \<odot> ?ds \<odot> ?c \<odot> ?es"
           using 4 by (metis (no_types, lifting) times_disjoint matrix_idempotent_semiring.mult_left_zero restrict_star matrix_bounded_semilattice_sup_bot.sup_monoid.add_0_right matrix_bounded_semilattice_sup_bot.sup_monoid.add_0_left)
         finally show ?thesis
           .
       qed
       have 9: "?t\<langle>g\<rangle>?t \<odot> ?fs = ?b \<odot> ?fs \<oplus> ?d \<odot> ?fs"
       proof -
         have "?t\<langle>g\<rangle>?t \<odot> ?fs = (?a \<oplus> ?b \<oplus> ?c \<oplus> ?d) \<odot> ?fs"
           by (metis restrict_nonempty)
         also have "... = ?a \<odot> ?fs \<oplus> ?b \<odot> ?fs \<oplus> ?c \<odot> ?fs \<oplus> ?d \<odot> ?fs"
           by (simp add: matrix_idempotent_semiring.mult_right_dist_sup)
         also have "... = ?b \<odot> ?fs \<oplus> ?d \<odot> ?fs"
           using 4 by (metis (no_types, lifting) times_disjoint restrict_star matrix_bounded_semilattice_sup_bot.sup_monoid.add_0_right matrix_bounded_semilattice_sup_bot.sup_monoid.add_0_left)
         finally show ?thesis
           .
       qed
       have "?t\<langle>?o\<rangle>?t \<oplus> ?t\<langle>g\<rangle>?t \<odot> star_matrix' ?t g = ?t\<langle>?o\<rangle>?t \<oplus> ?t\<langle>g\<rangle>?t \<odot> (?es \<oplus> ?as \<odot> ?b \<odot> ?fs \<oplus> ?ds \<odot> ?c \<odot> ?es \<oplus> ?fs)"
         by (metis star_matrix'.simps(2))
       also have "... = ?t\<langle>?o\<rangle>?t \<oplus> ?t\<langle>g\<rangle>?t \<odot> ?es \<oplus> ?t\<langle>g\<rangle>?t \<odot> ?as \<odot> ?b \<odot> ?fs \<oplus> ?t\<langle>g\<rangle>?t \<odot> ?ds \<odot> ?c \<odot> ?es \<oplus> ?t\<langle>g\<rangle>?t \<odot> ?fs"
         by (simp add: matrix_idempotent_semiring.mult_left_dist_sup matrix_monoid.mult_assoc matrix_semilattice_sup.sup_assoc)
       also have "... = ?r\<langle>?o\<rangle>?r \<oplus> s\<langle>?o\<rangle>s \<oplus> ?a \<odot> ?es \<oplus> ?c \<odot> ?es \<oplus> ?a \<odot> ?as \<odot> ?b \<odot> ?fs \<oplus> ?c \<odot> ?as \<odot> ?b \<odot> ?fs \<oplus> ?b \<odot> ?ds \<odot> ?c \<odot> ?es \<oplus> ?d \<odot> ?ds \<odot> ?c \<odot> ?es \<oplus> ?b \<odot> ?fs \<oplus> ?d \<odot> ?fs"
         using 5 6 7 8 9 by (simp add: matrix_semilattice_sup.sup.assoc)
       also have "... = (?r\<langle>?o\<rangle>?r \<oplus> (?a \<odot> ?es \<oplus> ?b \<odot> ?ds \<odot> ?c \<odot> ?es)) \<oplus> (?b \<odot> ?fs \<oplus> ?a \<odot> ?as \<odot> ?b \<odot> ?fs) \<oplus> (?c \<odot> ?es \<oplus> ?d \<odot> ?ds \<odot> ?c \<odot> ?es) \<oplus> (s\<langle>?o\<rangle>s \<oplus> (?d \<odot> ?fs \<oplus> ?c \<odot> ?as \<odot> ?b \<odot> ?fs))"
         by (simp only: matrix_semilattice_sup.sup_assoc matrix_semilattice_sup.sup_commute matrix_semilattice_sup.sup_left_commute)
       also have "... = (?r\<langle>?o\<rangle>?r \<oplus> (?a \<odot> ?es \<oplus> ?b \<odot> ?ds \<odot> ?c \<odot> ?es)) \<oplus> (?r\<langle>?o\<rangle>?r \<odot> ?b \<odot> ?fs \<oplus> ?a \<odot> ?as \<odot> ?b \<odot> ?fs) \<oplus> (s\<langle>?o\<rangle>s \<odot> ?c \<odot> ?es \<oplus> ?d \<odot> ?ds \<odot> ?c \<odot> ?es) \<oplus> (s\<langle>?o\<rangle>s \<oplus> (?d \<odot> ?fs \<oplus> ?c \<odot> ?as \<odot> ?b \<odot> ?fs))"
         by (simp add: restrict_one_left_unit)
       also have "... = (?r\<langle>?o\<rangle>?r \<oplus> ?e \<odot> ?es) \<oplus> ((?r\<langle>?o\<rangle>?r \<oplus> ?a \<odot> ?as) \<odot> ?b \<odot> ?fs) \<oplus> ((s\<langle>?o\<rangle>s \<oplus> ?d \<odot> ?ds) \<odot> ?c \<odot> ?es) \<oplus> (s\<langle>?o\<rangle>s \<oplus> ?f \<odot> ?fs)"
         by (simp add: matrix_idempotent_semiring.mult_right_dist_sup)
       also have "... = (?r\<langle>?o\<rangle>?r \<oplus> ?e \<odot> ?es) \<oplus> ((?r\<langle>?o\<rangle>?r \<oplus> ?a \<odot> ?as) \<odot> ?b \<odot> ?fs) \<oplus> ((s\<langle>?o\<rangle>s \<oplus> ?d \<odot> ?ds) \<odot> ?c \<odot> ?es) \<oplus> ?fs"
         using 1 2 3 by (metis distinct.simps(2))
       also have "... = (?r\<langle>?o\<rangle>?r \<oplus> ?e \<odot> ?es) \<oplus> ((?r\<langle>?o\<rangle>?r \<oplus> ?a \<odot> ?as) \<odot> ?b \<odot> ?fs) \<oplus> (?ds \<odot> ?c \<odot> ?es) \<oplus> ?fs"
         using 1 2 by (metis (no_types, lifting) distinct.simps(2) restrict_superlist)
       also have "... = ?es \<oplus> ((?r\<langle>?o\<rangle>?r \<oplus> ?a \<odot> ?as) \<odot> ?b \<odot> ?fs) \<oplus> (?ds \<odot> ?c \<odot> ?es) \<oplus> ?fs"
         using 3 by (metis restrict_star_unfold)
       also have "... = ?es \<oplus> ?as \<odot> ?b \<odot> ?fs \<oplus> ?ds \<odot> ?c \<odot> ?es \<oplus> ?fs"
         by (metis (no_types, lifting) restrict_one_left_unit restrict_star_unfold restrict_times)
       also have "... = star_matrix' ?t g"
         by (metis star_matrix'.simps(2))
       finally show "?t\<langle>?o\<rangle>?t \<oplus> ?t\<langle>g\<rangle>?t \<odot> star_matrix' ?t g = star_matrix' ?t g"
         .
     qed
   qed
   thus "?o \<oplus> y \<odot> y\<^sup>\<odot> \<preceq> y\<^sup>\<odot>"
     by (simp add: enum_distinct restrict_all)
 next
   fix x y z :: "('a,'b) square"
   let ?e = "enum_class.enum::'a list"
   have "\<forall>g h :: ('a,'b) square . \<forall>zs . distinct ?e \<and> distinct zs \<longrightarrow> (?e\<langle>g\<rangle>?e \<odot> ?e\<langle>h\<rangle>zs \<preceq> ?e\<langle>h\<rangle>zs \<longrightarrow> star_matrix' ?e g \<odot> ?e\<langle>h\<rangle>zs \<preceq> ?e\<langle>h\<rangle>zs)"
   proof (induct rule: list.induct)
     case Nil thus ?case
       by (simp add: restrict_empty_left)
     case (Cons k s)
     let ?t = "k#s"
     assume 1: "\<forall>g h :: ('a,'b) square . \<forall>zs . distinct s \<and> distinct zs \<longrightarrow> (s\<langle>g\<rangle>s \<odot> s\<langle>h\<rangle>zs \<preceq> s\<langle>h\<rangle>zs \<longrightarrow> star_matrix' s g \<odot> s\<langle>h\<rangle>zs \<preceq> s\<langle>h\<rangle>zs)"
     show "\<forall>g h :: ('a,'b) square . \<forall>zs . distinct ?t \<and> distinct zs \<longrightarrow> (?t\<langle>g\<rangle>?t \<odot> ?t\<langle>h\<rangle>zs \<preceq> ?t\<langle>h\<rangle>zs \<longrightarrow> star_matrix' ?t g \<odot> ?t\<langle>h\<rangle>zs \<preceq> ?t\<langle>h\<rangle>zs)"
     proof (intro allI)
       fix g h :: "('a,'b) square"
       fix zs :: "'a list"
       show "distinct ?t \<and> distinct zs \<longrightarrow> (?t\<langle>g\<rangle>?t \<odot> ?t\<langle>h\<rangle>zs \<preceq> ?t\<langle>h\<rangle>zs \<longrightarrow> star_matrix' ?t g \<odot> ?t\<langle>h\<rangle>zs \<preceq> ?t\<langle>h\<rangle>zs)"
       proof (cases zs)
         case Nil thus ?thesis
           by (metis restrict_empty_right restrict_star restrict_times)
       next
         case (Cons y ys)
         assume 2: "zs = y#ys"
         show "distinct ?t \<and> distinct zs \<longrightarrow> (?t\<langle>g\<rangle>?t \<odot> ?t\<langle>h\<rangle>zs \<preceq> ?t\<langle>h\<rangle>zs \<longrightarrow> star_matrix' ?t g \<odot> ?t\<langle>h\<rangle>zs \<preceq> ?t\<langle>h\<rangle>zs)"
         proof (intro impI)
           let ?y = "[y]"
           assume 3: "distinct ?t \<and> distinct zs"
           hence 4: "distinct s \<and> distinct ys \<and> \<not> List.member s k \<and> \<not> List.member ys y"
             using 2 by (simp add: List.member_def)
           let ?r = "[k]"
           let ?a = "?r\<langle>g\<rangle>?r"
           let ?b = "?r\<langle>g\<rangle>s"
           let ?c = "s\<langle>g\<rangle>?r"
           let ?d = "s\<langle>g\<rangle>s"
           let ?as = "?r\<langle>star o ?a\<rangle>?r"
           let ?ds = "star_matrix' s ?d"
           let ?e = "?a \<oplus> ?b \<odot> ?ds \<odot> ?c"
           let ?es = "?r\<langle>star o ?e\<rangle>?r"
           let ?f = "?d \<oplus> ?c \<odot> ?as \<odot> ?b"
           let ?fs = "star_matrix' s ?f"
           let ?ha = "?r\<langle>h\<rangle>?y"
           let ?hb = "?r\<langle>h\<rangle>ys"
           let ?hc = "s\<langle>h\<rangle>?y"
           let ?hd = "s\<langle>h\<rangle>ys"
           assume "?t\<langle>g\<rangle>?t \<odot> ?t\<langle>h\<rangle>zs \<preceq> ?t\<langle>h\<rangle>zs"
           hence 5: "?a \<odot> ?ha \<oplus> ?b \<odot> ?hc \<preceq> ?ha \<and> ?a \<odot> ?hb \<oplus> ?b \<odot> ?hd \<preceq> ?hb \<and> ?c \<odot> ?ha \<oplus> ?d \<odot> ?hc \<preceq> ?hc \<and> ?c \<odot> ?hb \<oplus> ?d \<odot> ?hd \<preceq> ?hd"
             using 2 3 4 by (simp add: restrict_nonempty_product_less_eq)
           have 6: "s\<langle>?ds\<rangle>s = ?ds \<and> s\<langle>?fs\<rangle>s = ?fs"
             by (simp add: restrict_star)
           hence 7: "?r\<langle>?e\<rangle>?r = ?e \<and> s\<langle>?f\<rangle>s = ?f"
             by (metis (no_types, lifting) restrict_one_left_unit restrict_sup restrict_times)
           have 8: "disjoint s ?r \<and> disjoint ?r s"
             using 3 by (simp add: in_set_member member_rec(1) member_rec(2))
           have 9: "?es \<odot> ?t\<langle>h\<rangle>zs = ?es \<odot> ?ha \<oplus> ?es \<odot> ?hb"
           proof -
             have "?es \<odot> ?t\<langle>h\<rangle>zs = ?es \<odot> (?ha \<oplus> ?hb \<oplus> ?hc \<oplus> ?hd)"
               using 2 by (metis restrict_nonempty)
             also have "... = ?es \<odot> ?ha \<oplus> ?es \<odot> ?hb \<oplus> ?es \<odot> ?hc \<oplus> ?es \<odot> ?hd"
               by (simp add: matrix_idempotent_semiring.mult_left_dist_sup)
             also have "... = ?es \<odot> ?ha \<oplus> ?es \<odot> ?hb"
               using 8 by (simp add: times_disjoint)
             finally show ?thesis
               .
           qed
           have 10: "?as \<odot> ?b \<odot> ?fs \<odot> ?t\<langle>h\<rangle>zs = ?as \<odot> ?b \<odot> ?fs \<odot> ?hc \<oplus> ?as \<odot> ?b \<odot> ?fs \<odot> ?hd"
           proof -
             have "?as \<odot> ?b \<odot> ?fs \<odot> ?t\<langle>h\<rangle>zs = ?as \<odot> ?b \<odot> ?fs \<odot> (?ha \<oplus> ?hb \<oplus> ?hc \<oplus> ?hd)"
               using 2 by (metis restrict_nonempty)
             also have "... = ?as \<odot> ?b \<odot> ?fs \<odot> ?ha \<oplus> ?as \<odot> ?b \<odot> ?fs \<odot> ?hb \<oplus> ?as \<odot> ?b \<odot> ?fs \<odot> ?hc \<oplus> ?as \<odot> ?b \<odot> ?fs \<odot> ?hd"
               by (simp add: matrix_idempotent_semiring.mult_left_dist_sup)
             also have "... = ?as \<odot> ?b \<odot> (?fs \<odot> ?ha) \<oplus> ?as \<odot> ?b \<odot> (?fs \<odot> ?hb) \<oplus> ?as \<odot> ?b \<odot> ?fs \<odot> ?hc \<oplus> ?as \<odot> ?b \<odot> ?fs \<odot> ?hd"
               by (simp add: matrix_monoid.mult_assoc)
             also have "... = ?as \<odot> ?b \<odot> mbot \<oplus> ?as \<odot> ?b \<odot> mbot \<oplus> ?as \<odot> ?b \<odot> ?fs \<odot> ?hc \<oplus> ?as \<odot> ?b \<odot> ?fs \<odot> ?hd"
               using 6 8 by (metis (no_types) times_disjoint)
             also have "... = ?as \<odot> ?b \<odot> ?fs \<odot> ?hc \<oplus> ?as \<odot> ?b \<odot> ?fs \<odot> ?hd"
               by simp
             finally show ?thesis
               .
           qed
           have 11: "?ds \<odot> ?c \<odot> ?es \<odot> ?t\<langle>h\<rangle>zs = ?ds \<odot> ?c \<odot> ?es \<odot> ?ha \<oplus> ?ds \<odot> ?c \<odot> ?es \<odot> ?hb"
           proof -
             have "?ds \<odot> ?c \<odot> ?es \<odot> ?t\<langle>h\<rangle>zs = ?ds \<odot> ?c \<odot> ?es \<odot> (?ha \<oplus> ?hb \<oplus> ?hc \<oplus> ?hd)"
               using 2 by (metis restrict_nonempty)
             also have "... = ?ds \<odot> ?c \<odot> ?es \<odot> ?ha \<oplus> ?ds \<odot> ?c \<odot> ?es \<odot> ?hb \<oplus> ?ds \<odot> ?c \<odot> ?es \<odot> ?hc \<oplus> ?ds \<odot> ?c \<odot> ?es \<odot> ?hd"
               by (simp add: matrix_idempotent_semiring.mult_left_dist_sup)
             also have "... = ?ds \<odot> ?c \<odot> ?es \<odot> ?ha \<oplus> ?ds \<odot> ?c \<odot> ?es \<odot> ?hb \<oplus> ?ds \<odot> ?c \<odot> (?es \<odot> ?hc) \<oplus> ?ds \<odot> ?c \<odot> (?es \<odot> ?hd)"
               by (simp add: matrix_monoid.mult_assoc)
             also have "... = ?ds \<odot> ?c \<odot> ?es \<odot> ?ha \<oplus> ?ds \<odot> ?c \<odot> ?es \<odot> ?hb \<oplus> ?ds \<odot> ?c \<odot> mbot \<oplus> ?ds \<odot> ?c \<odot> mbot"
               using 8 by (metis times_disjoint)
             also have "... = ?ds \<odot> ?c \<odot> ?es \<odot> ?ha \<oplus> ?ds \<odot> ?c \<odot> ?es \<odot> ?hb"
               by simp
             finally show ?thesis
               .
           qed
           have 12: "?fs \<odot> ?t\<langle>h\<rangle>zs = ?fs \<odot> ?hc \<oplus> ?fs \<odot> ?hd"
           proof -
             have "?fs \<odot> ?t\<langle>h\<rangle>zs = ?fs \<odot> (?ha \<oplus> ?hb \<oplus> ?hc \<oplus> ?hd)"
               using 2 by (metis restrict_nonempty)
             also have "... = ?fs \<odot> ?ha \<oplus> ?fs \<odot> ?hb \<oplus> ?fs \<odot> ?hc \<oplus> ?fs \<odot> ?hd"
               by (simp add: matrix_idempotent_semiring.mult_left_dist_sup)
             also have "... = ?fs \<odot> ?hc \<oplus> ?fs \<odot> ?hd"
               using 6 8 by (metis (no_types) times_disjoint matrix_bounded_semilattice_sup_bot.sup_monoid.add_0_left)
             finally show ?thesis
               .
           qed
           have 13: "?es \<odot> ?ha \<preceq> ?ha"
           proof -
             have "?b \<odot> ?ds \<odot> ?c \<odot> ?ha \<preceq> ?b \<odot> ?ds \<odot> ?hc"
               using 5 by (simp add: matrix_idempotent_semiring.mult_right_isotone matrix_monoid.mult_assoc)
             also have "... \<preceq> ?b \<odot> ?hc"
               using 1 3 5 by (simp add: matrix_idempotent_semiring.mult_right_isotone matrix_monoid.mult_assoc member_rec(2) restrict_sublist)
             also have "... \<preceq> ?ha"
               using 5 by simp
             finally have "?e \<odot> ?ha \<preceq> ?ha"
               using 5 by (simp add: matrix_idempotent_semiring.mult_right_dist_sup)
             thus ?thesis
               using 7 by (simp add: restrict_star_left_induct)
           qed
           have 14: "?es \<odot> ?hb \<preceq> ?hb"
           proof -
             have "?b \<odot> ?ds \<odot> ?c \<odot> ?hb \<preceq> ?b \<odot> ?ds \<odot> ?hd"
               using 5 by (simp add: matrix_idempotent_semiring.mult_right_isotone matrix_monoid.mult_assoc)
             also have "... \<preceq> ?b \<odot> ?hd"
               using 1 4 5 by (simp add: matrix_idempotent_semiring.mult_right_isotone matrix_monoid.mult_assoc restrict_sublist)
             also have "... \<preceq> ?hb"
               using 5 by simp
             finally have "?e \<odot> ?hb \<preceq> ?hb"
               using 5 by (simp add: matrix_idempotent_semiring.mult_right_dist_sup)
             thus ?thesis
               using 4 7 by (simp add: restrict_star_left_induct)
           qed
           have 15: "?fs \<odot> ?hc \<preceq> ?hc"
           proof -
             have "?c \<odot> ?as \<odot> ?b \<odot> ?hc \<preceq> ?c \<odot> ?as \<odot> ?ha"
               using 5 by (simp add: matrix_idempotent_semiring.mult_right_isotone matrix_monoid.mult_assoc)
             also have "... \<preceq> ?c \<odot> ?ha"
               using 5 by (simp add: matrix_idempotent_semiring.mult_right_isotone matrix_monoid.mult_assoc restrict_star_left_induct restrict_sublist)
             also have "... \<preceq> ?hc"
               using 5 by simp
             finally have "?f \<odot> ?hc \<preceq> ?hc"
               using 5 by (simp add: matrix_idempotent_semiring.mult_right_dist_sup)
             thus ?thesis
               using 1 3 7 by simp
           qed
           have 16: "?fs \<odot> ?hd \<preceq> ?hd"
           proof -
             have "?c \<odot> ?as \<odot> ?b \<odot> ?hd \<preceq> ?c \<odot> ?as \<odot> ?hb"
               using 5 by (simp add: matrix_idempotent_semiring.mult_right_isotone matrix_monoid.mult_assoc)
             also have "... \<preceq> ?c \<odot> ?hb"
               using 4 5 by (simp add: matrix_idempotent_semiring.mult_right_isotone matrix_monoid.mult_assoc restrict_star_left_induct restrict_sublist)
             also have "... \<preceq> ?hd"
               using 5 by simp
             finally have "?f \<odot> ?hd \<preceq> ?hd"
               using 5 by (simp add: matrix_idempotent_semiring.mult_right_dist_sup)
             thus ?thesis
               using 1 4 7 by simp
           qed
           have 17: "?as \<odot> ?b \<odot> ?fs \<odot> ?hc \<preceq> ?ha"
           proof -
             have "?as \<odot> ?b \<odot> ?fs \<odot> ?hc \<preceq> ?as \<odot> ?b \<odot> ?hc"
               using 15 by (simp add: matrix_idempotent_semiring.mult_right_isotone matrix_monoid.mult_assoc)
             also have "... \<preceq> ?as \<odot> ?ha"
               using 5 by (simp add: matrix_idempotent_semiring.mult_right_isotone matrix_monoid.mult_assoc)
             also have "... \<preceq> ?ha"
               using 5 by (simp add: restrict_star_left_induct restrict_sublist)
             finally show ?thesis
               .
           qed
           have 18: "?as \<odot> ?b \<odot> ?fs \<odot> ?hd \<preceq> ?hb"
           proof -
             have "?as \<odot> ?b \<odot> ?fs \<odot> ?hd \<preceq> ?as \<odot> ?b \<odot> ?hd"
               using 16 by (simp add: matrix_idempotent_semiring.mult_right_isotone matrix_monoid.mult_assoc)
             also have "... \<preceq> ?as \<odot> ?hb"
               using 5 by (simp add: matrix_idempotent_semiring.mult_right_isotone matrix_monoid.mult_assoc)
             also have "... \<preceq> ?hb"
               using 4 5 by (simp add: restrict_star_left_induct restrict_sublist)
             finally show ?thesis
               .
           qed
           have 19: "?ds \<odot> ?c \<odot> ?es \<odot> ?ha \<preceq> ?hc"
           proof -
             have "?ds \<odot> ?c \<odot> ?es \<odot> ?ha \<preceq> ?ds \<odot> ?c \<odot> ?ha"
               using 13 by (simp add: matrix_idempotent_semiring.mult_right_isotone matrix_monoid.mult_assoc)
             also have "... \<preceq> ?ds \<odot> ?hc"
               using 5 by (simp add: matrix_idempotent_semiring.mult_right_isotone matrix_monoid.mult_assoc)
             also have "... \<preceq> ?hc"
               using 1 3 5 by (simp add: restrict_sublist)
             finally show ?thesis
               .
           qed
           have 20: "?ds \<odot> ?c \<odot> ?es \<odot> ?hb \<preceq> ?hd"
           proof -
             have "?ds \<odot> ?c \<odot> ?es \<odot> ?hb \<preceq> ?ds \<odot> ?c \<odot> ?hb"
               using 14 by (simp add: matrix_idempotent_semiring.mult_right_isotone matrix_monoid.mult_assoc)
             also have "... \<preceq> ?ds \<odot> ?hd"
               using 5 by (simp add: matrix_idempotent_semiring.mult_right_isotone matrix_monoid.mult_assoc)
             also have "... \<preceq> ?hd"
               using 1 4 5 by (simp add: restrict_sublist)
             finally show ?thesis
               .
           qed
           have 21: "?es \<odot> ?ha \<oplus> ?as \<odot> ?b \<odot> ?fs \<odot> ?hc \<preceq> ?ha"
             using 13 17 matrix_semilattice_sup.le_supI by blast
           have 22: "?es \<odot> ?hb \<oplus> ?as \<odot> ?b \<odot> ?fs \<odot> ?hd \<preceq> ?hb"
             using 14 18 matrix_semilattice_sup.le_supI by blast
           have 23: "?ds \<odot> ?c \<odot> ?es \<odot> ?ha \<oplus> ?fs \<odot> ?hc \<preceq> ?hc"
             using 15 19 matrix_semilattice_sup.le_supI by blast
           have 24: "?ds \<odot> ?c \<odot> ?es \<odot> ?hb \<oplus> ?fs \<odot> ?hd \<preceq> ?hd"
             using 16 20 matrix_semilattice_sup.le_supI by blast
           have "star_matrix' ?t g \<odot> ?t\<langle>h\<rangle>zs = (?es \<oplus> ?as \<odot> ?b \<odot> ?fs \<oplus> ?ds \<odot> ?c \<odot> ?es \<oplus> ?fs) \<odot> ?t\<langle>h\<rangle>zs"
             by (metis star_matrix'.simps(2))
           also have "... = ?es \<odot> ?t\<langle>h\<rangle>zs \<oplus> ?as \<odot> ?b \<odot> ?fs \<odot> ?t\<langle>h\<rangle>zs \<oplus> ?ds \<odot> ?c \<odot> ?es \<odot> ?t\<langle>h\<rangle>zs \<oplus> ?fs \<odot> ?t\<langle>h\<rangle>zs"
             by (simp add: matrix_idempotent_semiring.mult_right_dist_sup)
           also have "... = ?es \<odot> ?ha \<oplus> ?es \<odot> ?hb \<oplus> ?as \<odot> ?b \<odot> ?fs \<odot> ?hc \<oplus> ?as \<odot> ?b \<odot> ?fs \<odot> ?hd \<oplus> ?ds \<odot> ?c \<odot> ?es \<odot> ?ha \<oplus> ?ds \<odot> ?c \<odot> ?es \<odot> ?hb \<oplus> ?fs \<odot> ?hc \<oplus> ?fs \<odot> ?hd"
             using 9 10 11 12 by (simp only: matrix_semilattice_sup.sup_assoc)
           also have "... = (?es \<odot> ?ha \<oplus> ?as \<odot> ?b \<odot> ?fs \<odot> ?hc) \<oplus> (?es \<odot> ?hb \<oplus> ?as \<odot> ?b \<odot> ?fs \<odot> ?hd) \<oplus> (?ds \<odot> ?c \<odot> ?es \<odot> ?ha \<oplus> ?fs \<odot> ?hc) \<oplus> (?ds \<odot> ?c \<odot> ?es \<odot> ?hb \<oplus> ?fs \<odot> ?hd)"
             by (simp only: matrix_semilattice_sup.sup_assoc matrix_semilattice_sup.sup_commute matrix_semilattice_sup.sup_left_commute)
           also have "... \<preceq> ?ha \<oplus> ?hb \<oplus> ?hc \<oplus> ?hd"
             using 21 22 23 24 matrix_semilattice_sup.sup.mono by blast
           also have "... = ?t\<langle>h\<rangle>zs"
             using 2 by (metis restrict_nonempty)
           finally show "star_matrix' ?t g \<odot> ?t\<langle>h\<rangle>zs \<preceq> ?t\<langle>h\<rangle>zs"
             .
         qed
       qed
     qed
   qed
   hence "\<forall>zs . distinct zs \<longrightarrow> (y \<odot> ?e\<langle>x\<rangle>zs \<preceq> ?e\<langle>x\<rangle>zs \<longrightarrow> y\<^sup>\<odot> \<odot> ?e\<langle>x\<rangle>zs \<preceq> ?e\<langle>x\<rangle>zs)"
     by (simp add: enum_distinct restrict_all)
   thus "y \<odot> x \<preceq> x \<longrightarrow> y\<^sup>\<odot> \<odot> x \<preceq> x"
     by (metis restrict_all enum_distinct)
 next
   fix x y z :: "('a,'b) square"
   let ?e = "enum_class.enum::'a list"
   have "\<forall>g h :: ('a,'b) square . \<forall>zs . distinct ?e \<and> distinct zs \<longrightarrow> (zs\<langle>h\<rangle>?e \<odot> ?e\<langle>g\<rangle>?e \<preceq> zs\<langle>h\<rangle>?e \<longrightarrow> zs\<langle>h\<rangle>?e \<odot> star_matrix' ?e g \<preceq> zs\<langle>h\<rangle>?e)"
   proof (induct rule:list.induct)
     case Nil thus ?case
       by (simp add: restrict_empty_left)
     case (Cons k s)
     let ?t = "k#s"
     assume 1: "\<forall>g h :: ('a,'b) square . \<forall>zs . distinct s \<and> distinct zs \<longrightarrow> (zs\<langle>h\<rangle>s \<odot> s\<langle>g\<rangle>s \<preceq> zs\<langle>h\<rangle>s \<longrightarrow> zs\<langle>h\<rangle>s \<odot> star_matrix' s g \<preceq> zs\<langle>h\<rangle>s)"
     show "\<forall>g h :: ('a,'b) square . \<forall>zs . distinct ?t \<and> distinct zs \<longrightarrow> (zs\<langle>h\<rangle>?t \<odot> ?t\<langle>g\<rangle>?t \<preceq> zs\<langle>h\<rangle>?t \<longrightarrow> zs\<langle>h\<rangle>?t \<odot> star_matrix' ?t g \<preceq> zs\<langle>h\<rangle>?t)"
     proof (intro allI)
       fix g h :: "('a,'b) square"
       fix zs :: "'a list"
       show "distinct ?t \<and> distinct zs \<longrightarrow> (zs\<langle>h\<rangle>?t \<odot> ?t\<langle>g\<rangle>?t \<preceq> zs\<langle>h\<rangle>?t \<longrightarrow> zs\<langle>h\<rangle>?t \<odot> star_matrix' ?t g \<preceq> zs\<langle>h\<rangle>?t)"
       proof (cases zs)
         case Nil thus ?thesis
           by (metis restrict_empty_left restrict_star restrict_times)
       next
         case (Cons y ys)
         assume 2: "zs = y#ys"
         show "distinct ?t \<and> distinct zs \<longrightarrow> (zs\<langle>h\<rangle>?t \<odot> ?t\<langle>g\<rangle>?t \<preceq> zs\<langle>h\<rangle>?t \<longrightarrow> zs\<langle>h\<rangle>?t \<odot> star_matrix' ?t g \<preceq> zs\<langle>h\<rangle>?t)"
         proof (intro impI)
           let ?y = "[y]"
           assume 3: "distinct ?t \<and> distinct zs"
           hence 4: "distinct s \<and> distinct ys \<and> \<not> List.member s k \<and> \<not> List.member ys y"
             using 2 by (simp add: List.member_def)
           let ?r = "[k]"
           let ?a = "?r\<langle>g\<rangle>?r"
           let ?b = "?r\<langle>g\<rangle>s"
           let ?c = "s\<langle>g\<rangle>?r"
           let ?d = "s\<langle>g\<rangle>s"
           let ?as = "?r\<langle>star o ?a\<rangle>?r"
           let ?ds = "star_matrix' s ?d"
           let ?e = "?a \<oplus> ?b \<odot> ?ds \<odot> ?c"
           let ?es = "?r\<langle>star o ?e\<rangle>?r"
           let ?f = "?d \<oplus> ?c \<odot> ?as \<odot> ?b"
           let ?fs = "star_matrix' s ?f"
           let ?ha = "?y\<langle>h\<rangle>?r"
           let ?hb = "?y\<langle>h\<rangle>s"
           let ?hc = "ys\<langle>h\<rangle>?r"
           let ?hd = "ys\<langle>h\<rangle>s"
           assume "zs\<langle>h\<rangle>?t \<odot> ?t\<langle>g\<rangle>?t \<preceq> zs\<langle>h\<rangle>?t"
           hence 5: "?ha \<odot> ?a \<oplus> ?hb \<odot> ?c \<preceq> ?ha \<and> ?ha \<odot> ?b \<oplus> ?hb \<odot> ?d \<preceq> ?hb \<and> ?hc \<odot> ?a \<oplus> ?hd \<odot> ?c \<preceq> ?hc \<and> ?hc \<odot> ?b \<oplus> ?hd \<odot> ?d \<preceq> ?hd"
             using 2 3 4 by (simp add: restrict_nonempty_product_less_eq)
           have 6: "s\<langle>?ds\<rangle>s = ?ds \<and> s\<langle>?fs\<rangle>s = ?fs"
             by (simp add: restrict_star)
           hence 7: "?r\<langle>?e\<rangle>?r = ?e \<and> s\<langle>?f\<rangle>s = ?f"
             by (metis (no_types, lifting) restrict_one_left_unit restrict_sup restrict_times)
           have 8: "disjoint s ?r \<and> disjoint ?r s"
             using 3 by (simp add: in_set_member member_rec)
           have 9: "zs\<langle>h\<rangle>?t \<odot> ?es = ?ha \<odot> ?es \<oplus> ?hc \<odot> ?es"
           proof -
             have "zs\<langle>h\<rangle>?t \<odot> ?es = (?ha \<oplus> ?hb \<oplus> ?hc \<oplus> ?hd) \<odot> ?es"
               using 2 by (metis restrict_nonempty)
             also have "... = ?ha \<odot> ?es \<oplus> ?hb \<odot> ?es \<oplus> ?hc \<odot> ?es \<oplus> ?hd \<odot> ?es"
               by (simp add: matrix_idempotent_semiring.mult_right_dist_sup)
             also have "... = ?ha \<odot> ?es \<oplus> ?hc \<odot> ?es"
               using 8 by (simp add: times_disjoint)
             finally show ?thesis
               .
           qed
           have 10: "zs\<langle>h\<rangle>?t \<odot> ?as \<odot> ?b \<odot> ?fs = ?ha \<odot> ?as \<odot> ?b \<odot> ?fs \<oplus> ?hc \<odot> ?as \<odot> ?b \<odot> ?fs"
           proof -
             have "zs\<langle>h\<rangle>?t \<odot> ?as \<odot> ?b \<odot> ?fs = (?ha \<oplus> ?hb \<oplus> ?hc \<oplus> ?hd) \<odot> ?as \<odot> ?b \<odot> ?fs"
               using 2 by (metis restrict_nonempty)
             also have "... = ?ha \<odot> ?as \<odot> ?b \<odot> ?fs \<oplus> ?hb \<odot> ?as \<odot> ?b \<odot> ?fs \<oplus> ?hc \<odot> ?as \<odot> ?b \<odot> ?fs \<oplus> ?hd \<odot> ?as \<odot> ?b \<odot> ?fs"
               by (simp add: matrix_idempotent_semiring.mult_right_dist_sup)
             also have "... = ?ha \<odot> ?as \<odot> ?b \<odot> ?fs \<oplus> mbot \<odot> ?b \<odot> ?fs \<oplus> ?hc \<odot> ?as \<odot> ?b \<odot> ?fs \<oplus> mbot \<odot> ?b \<odot> ?fs"
               using 8 by (metis (no_types) times_disjoint)
             also have "... = ?ha \<odot> ?as \<odot> ?b \<odot> ?fs \<oplus> ?hc \<odot> ?as \<odot> ?b \<odot> ?fs"
               by simp
             finally show ?thesis
               .
           qed
           have 11: "zs\<langle>h\<rangle>?t \<odot> ?ds \<odot> ?c \<odot> ?es = ?hb \<odot> ?ds \<odot> ?c \<odot> ?es \<oplus> ?hd \<odot> ?ds \<odot> ?c \<odot> ?es"
           proof -
             have "zs\<langle>h\<rangle>?t \<odot> ?ds \<odot> ?c \<odot> ?es = (?ha \<oplus> ?hb \<oplus> ?hc \<oplus> ?hd) \<odot> ?ds \<odot> ?c \<odot> ?es"
               using 2 by (metis restrict_nonempty)
             also have "... = ?ha \<odot> ?ds \<odot> ?c \<odot> ?es \<oplus> ?hb \<odot> ?ds \<odot> ?c \<odot> ?es \<oplus> ?hc \<odot> ?ds \<odot> ?c \<odot> ?es \<oplus> ?hd \<odot> ?ds \<odot> ?c \<odot> ?es"
               by (simp add: matrix_idempotent_semiring.mult_right_dist_sup)
             also have "... = mbot \<odot> ?c \<odot> ?es \<oplus> ?hb \<odot> ?ds \<odot> ?c \<odot> ?es \<oplus> mbot \<odot> ?c \<odot> ?es \<oplus> ?hd \<odot> ?ds \<odot> ?c \<odot> ?es"
               using 6 8 by (metis (no_types) times_disjoint)
             also have "... = ?hb \<odot> ?ds \<odot> ?c \<odot> ?es \<oplus> ?hd \<odot> ?ds \<odot> ?c \<odot> ?es"
               by simp
             finally show ?thesis
               .
           qed
           have 12: "zs\<langle>h\<rangle>?t \<odot> ?fs = ?hb \<odot> ?fs \<oplus> ?hd \<odot> ?fs"
           proof -
             have "zs\<langle>h\<rangle>?t \<odot> ?fs = (?ha \<oplus> ?hb \<oplus> ?hc \<oplus> ?hd) \<odot> ?fs"
               using 2 by (metis restrict_nonempty)
             also have "... = ?ha \<odot> ?fs \<oplus> ?hb \<odot> ?fs \<oplus> ?hc \<odot> ?fs \<oplus> ?hd \<odot> ?fs"
               by (simp add: matrix_idempotent_semiring.mult_right_dist_sup)
             also have "... = ?hb \<odot> ?fs \<oplus> ?hd \<odot> ?fs"
               using 6 8 by (metis (no_types) times_disjoint matrix_bounded_semilattice_sup_bot.sup_monoid.add_0_right matrix_bounded_semilattice_sup_bot.sup_monoid.add_0_left)
             finally show ?thesis
               .
           qed
           have 13: "?ha \<odot> ?es \<preceq> ?ha"
           proof -
             have "?ha \<odot> ?b \<odot> ?ds \<odot> ?c \<preceq> ?hb \<odot> ?ds \<odot> ?c"
               using 5 by (simp add: matrix_idempotent_semiring.mult_left_isotone)
             also have "... \<preceq> ?hb \<odot> ?c"
               using 1 4 5 by (simp add: matrix_idempotent_semiring.mult_left_isotone restrict_sublist)
             also have "... \<preceq> ?ha"
               using 5 by simp
             finally have "?ha \<odot> ?e \<preceq> ?ha"
               using 5 by (simp add: matrix_idempotent_semiring.mult_left_dist_sup matrix_monoid.mult_assoc)
             thus ?thesis
               using 7 by (simp add: restrict_star_right_induct)
           qed
           have 14: "?hb \<odot> ?fs \<preceq> ?hb"
           proof -
             have "?hb \<odot> ?c \<odot> ?as \<odot> ?b \<preceq> ?ha \<odot> ?as \<odot> ?b"
               using 5 by (metis matrix_semilattice_sup.le_supE matrix_idempotent_semiring.mult_left_isotone)
             also have "... \<preceq> ?ha \<odot> ?b"
               using 5 by (simp add: matrix_idempotent_semiring.mult_left_isotone restrict_star_right_induct restrict_sublist)
             also have "... \<preceq> ?hb"
               using 5 by simp
             finally have "?hb \<odot> ?f \<preceq> ?hb"
               using 5 by (simp add: matrix_idempotent_semiring.mult_left_dist_sup matrix_monoid.mult_assoc)
             thus ?thesis
               using 1 3 7 by simp
           qed
           have 15: "?hc \<odot> ?es \<preceq> ?hc"
           proof -
             have "?hc \<odot> ?b \<odot> ?ds \<odot> ?c \<preceq> ?hd \<odot> ?ds \<odot> ?c"
               using 5 by (simp add: matrix_idempotent_semiring.mult_left_isotone)
             also have "... \<preceq> ?hd \<odot> ?c"
               using 1 4 5 by (simp add: matrix_idempotent_semiring.mult_left_isotone restrict_sublist)
             also have "... \<preceq> ?hc"
               using 5 by simp
             finally have "?hc \<odot> ?e \<preceq> ?hc"
               using 5 by (simp add: matrix_idempotent_semiring.mult_left_dist_sup matrix_monoid.mult_assoc)
             thus ?thesis
               using 4 7 by (simp add: restrict_star_right_induct)
           qed
           have 16: "?hd \<odot> ?fs \<preceq> ?hd"
           proof -
             have "?hd \<odot> ?c \<odot> ?as \<odot> ?b \<preceq> ?hc \<odot> ?as \<odot> ?b"
               using 5 by (simp add: matrix_idempotent_semiring.mult_left_isotone)
             also have "... \<preceq> ?hc \<odot> ?b"
               using 4 5 by (simp add: matrix_idempotent_semiring.mult_left_isotone restrict_star_right_induct restrict_sublist)
             also have "... \<preceq> ?hd"
               using 5 by simp
             finally have "?hd \<odot> ?f \<preceq> ?hd"
               using 5 by (simp add: matrix_idempotent_semiring.mult_left_dist_sup matrix_monoid.mult_assoc)
             thus ?thesis
               using 1 4 7 by simp
           qed
           have 17: "?hb \<odot> ?ds \<odot> ?c \<odot> ?es \<preceq> ?ha"
           proof -
             have "?hb \<odot> ?ds \<odot> ?c \<odot> ?es \<preceq> ?hb \<odot> ?c \<odot> ?es"
               using 1 4 5 by (simp add: matrix_idempotent_semiring.mult_left_isotone restrict_sublist)
             also have "... \<preceq> ?ha \<odot> ?es"
               using 5 by (simp add: matrix_idempotent_semiring.mult_left_isotone)
             also have "... \<preceq> ?ha"
               using 13 by simp
             finally show ?thesis
               .
           qed
           have 18: "?ha \<odot> ?as \<odot> ?b \<odot> ?fs \<preceq> ?hb"
           proof -
             have "?ha \<odot> ?as \<odot> ?b \<odot> ?fs \<preceq> ?ha \<odot> ?b \<odot> ?fs"
               using 5 by (simp add: matrix_idempotent_semiring.mult_left_isotone restrict_star_right_induct restrict_sublist)
             also have "... \<preceq> ?hb \<odot> ?fs"
               using 5 by (simp add: matrix_idempotent_semiring.mult_left_isotone)
             also have "... \<preceq> ?hb"
               using 14 by simp
             finally show ?thesis
               by simp
           qed
           have 19: "?hd \<odot> ?ds \<odot> ?c \<odot> ?es \<preceq> ?hc"
           proof -
             have "?hd \<odot> ?ds \<odot> ?c \<odot> ?es \<preceq> ?hd \<odot> ?c \<odot> ?es"
               using 1 4 5 by (simp add: matrix_idempotent_semiring.mult_left_isotone restrict_sublist)
             also have "... \<preceq> ?hc \<odot> ?es"
               using 5 by (simp add: matrix_idempotent_semiring.mult_left_isotone)
             also have "... \<preceq> ?hc"
               using 15 by simp
             finally show ?thesis
               by simp
           qed
           have 20: "?hc \<odot> ?as \<odot> ?b \<odot> ?fs \<preceq> ?hd"
           proof -
             have "?hc \<odot> ?as \<odot> ?b \<odot> ?fs \<preceq> ?hc \<odot> ?b \<odot> ?fs"
               using 4 5 by (simp add: matrix_idempotent_semiring.mult_left_isotone restrict_star_right_induct restrict_sublist)
             also have "... \<preceq> ?hd \<odot> ?fs"
               using 5 by (simp add: matrix_idempotent_semiring.mult_left_isotone)
             also have "... \<preceq> ?hd"
               using 16 by simp
             finally show ?thesis
               by simp
           qed
           have 21: "?ha \<odot> ?es \<oplus> ?hb \<odot> ?ds \<odot> ?c \<odot> ?es \<preceq> ?ha"
             using 13 17 matrix_semilattice_sup.le_supI by blast
           have 22: "?ha \<odot> ?as \<odot> ?b \<odot> ?fs \<oplus> ?hb \<odot> ?fs \<preceq> ?hb"
             using 14 18 matrix_semilattice_sup.le_supI by blast
           have 23: "?hc \<odot> ?es \<oplus> ?hd \<odot> ?ds \<odot> ?c \<odot> ?es \<preceq> ?hc"
             using 15 19 matrix_semilattice_sup.le_supI by blast
           have 24: "?hc \<odot> ?as \<odot> ?b \<odot> ?fs \<oplus> ?hd \<odot> ?fs \<preceq> ?hd"
             using 16 20 matrix_semilattice_sup.le_supI by blast
           have "zs\<langle>h\<rangle>?t \<odot> star_matrix' ?t g = zs\<langle>h\<rangle>?t \<odot> (?es \<oplus> ?as \<odot> ?b \<odot> ?fs \<oplus> ?ds \<odot> ?c \<odot> ?es \<oplus> ?fs)"
             by (metis star_matrix'.simps(2))
           also have "... = zs\<langle>h\<rangle>?t \<odot> ?es \<oplus> zs\<langle>h\<rangle>?t \<odot> ?as \<odot> ?b \<odot> ?fs \<oplus> zs\<langle>h\<rangle>?t \<odot> ?ds \<odot> ?c \<odot> ?es \<oplus> zs\<langle>h\<rangle>?t \<odot> ?fs"
             by (simp add: matrix_idempotent_semiring.mult_left_dist_sup matrix_monoid.mult_assoc)
           also have "... = ?ha \<odot> ?es \<oplus> ?hc \<odot> ?es \<oplus> ?ha \<odot> ?as \<odot> ?b \<odot> ?fs \<oplus> ?hc \<odot> ?as \<odot> ?b \<odot> ?fs \<oplus> ?hb \<odot> ?ds \<odot> ?c \<odot> ?es \<oplus> ?hd \<odot> ?ds \<odot> ?c \<odot> ?es \<oplus> ?hb \<odot> ?fs \<oplus> ?hd \<odot> ?fs"
             using 9 10 11 12 by (simp add: matrix_semilattice_sup.sup_assoc)
           also have "... = (?ha \<odot> ?es \<oplus> ?hb \<odot> ?ds \<odot> ?c \<odot> ?es) \<oplus> (?ha \<odot> ?as \<odot> ?b \<odot> ?fs \<oplus> ?hb \<odot> ?fs) \<oplus> (?hc \<odot> ?es \<oplus> ?hd \<odot> ?ds \<odot> ?c \<odot> ?es) \<oplus> (?hc \<odot> ?as \<odot> ?b \<odot> ?fs \<oplus> ?hd \<odot> ?fs)"
             using 9 10 11 12 by (simp only: matrix_semilattice_sup.sup_assoc matrix_semilattice_sup.sup_commute matrix_semilattice_sup.sup_left_commute)
           also have "... \<preceq> ?ha \<oplus> ?hb \<oplus> ?hc \<oplus> ?hd"
             using 21 22 23 24 matrix_semilattice_sup.sup.mono by blast
           also have "... = zs\<langle>h\<rangle>?t"
             using 2 by (metis restrict_nonempty)
           finally show "zs\<langle>h\<rangle>?t \<odot> star_matrix' ?t g \<preceq> zs\<langle>h\<rangle>?t"
             .
         qed
       qed
     qed
   qed
   hence "\<forall>zs . distinct zs \<longrightarrow> (zs\<langle>x\<rangle>?e \<odot> y \<preceq> zs\<langle>x\<rangle>?e \<longrightarrow> zs\<langle>x\<rangle>?e \<odot> y\<^sup>\<odot> \<preceq> zs\<langle>x\<rangle>?e)"
     by (simp add: enum_distinct restrict_all)
   thus "x \<odot> y \<preceq> x \<longrightarrow> x \<odot> y\<^sup>\<odot> \<preceq> x"
     by (metis restrict_all enum_distinct)
 qed
 
 subsection \<open>Matrices form a Stone-Kleene Relation Algebra\<close>
 
 text \<open>
 Matrices over Stone-Kleene relation algebras form a Stone-Kleene relation algebra.
 It remains to prove the axiom about the interaction of Kleene star and double complement.
 \<close>
 
 interpretation matrix_stone_kleene_relation_algebra: stone_kleene_relation_algebra where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix::('a::enum,'b::stone_kleene_relation_algebra) square" and top = top_matrix and uminus = uminus_matrix and one = one_matrix and times = times_matrix and conv = conv_matrix and star = star_matrix
 proof
   fix x :: "('a,'b) square"
   let ?e = "enum_class.enum::'a list"
   let ?o = "mone :: ('a,'b) square"
   show "\<ominus>\<ominus>(x\<^sup>\<odot>) = (\<ominus>\<ominus>x)\<^sup>\<odot>"
   proof (rule matrix_order.order_antisym)
     have "\<forall>g :: ('a,'b) square . distinct ?e \<longrightarrow> \<ominus>\<ominus>(star_matrix' ?e (\<ominus>\<ominus>g)) = star_matrix' ?e (\<ominus>\<ominus>g)"
     proof (induct rule: list.induct)
       case Nil thus ?case
         by simp
     next
       case (Cons k s)
       let ?t = "k#s"
       assume 1: "\<forall>g :: ('a,'b) square . distinct s \<longrightarrow> \<ominus>\<ominus>(star_matrix' s (\<ominus>\<ominus>g)) = star_matrix' s (\<ominus>\<ominus>g)"
       show "\<forall>g :: ('a,'b) square . distinct ?t \<longrightarrow> \<ominus>\<ominus>(star_matrix' ?t (\<ominus>\<ominus>g)) = star_matrix' ?t (\<ominus>\<ominus>g)"
       proof (rule allI, rule impI)
         fix g :: "('a,'b) square"
         assume 2: "distinct ?t"
         let ?r = "[k]"
         let ?a = "?r\<langle>\<ominus>\<ominus>g\<rangle>?r"
         let ?b = "?r\<langle>\<ominus>\<ominus>g\<rangle>s"
         let ?c = "s\<langle>\<ominus>\<ominus>g\<rangle>?r"
         let ?d = "s\<langle>\<ominus>\<ominus>g\<rangle>s"
         let ?as = "?r\<langle>star o ?a\<rangle>?r"
         let ?ds = "star_matrix' s ?d"
         let ?e = "?a \<oplus> ?b \<odot> ?ds \<odot> ?c"
         let ?es = "?r\<langle>star o ?e\<rangle>?r"
         let ?f = "?d \<oplus> ?c \<odot> ?as \<odot> ?b"
         let ?fs = "star_matrix' s ?f"
         have "s\<langle>?ds\<rangle>s = ?ds \<and> s\<langle>?fs\<rangle>s = ?fs"
           by (simp add: restrict_star)
         have 3: "\<ominus>\<ominus>?a = ?a \<and> \<ominus>\<ominus>?b = ?b \<and> \<ominus>\<ominus>?c = ?c \<and> \<ominus>\<ominus>?d = ?d"
           by (metis matrix_p_algebra.regular_closed_p restrict_pp)
         hence 4: "\<ominus>\<ominus>?as = ?as"
           by (metis pp_star_commute restrict_pp)
         hence "\<ominus>\<ominus>?f = ?f"
           using 3 by (metis matrix_stone_algebra.regular_closed_sup matrix_stone_relation_algebra.regular_mult_closed)
         hence 5: "\<ominus>\<ominus>?fs = ?fs"
           using 1 2 by (metis distinct.simps(2))
         have 6: "\<ominus>\<ominus>?ds = ?ds"
           using 1 2 by (simp add: restrict_pp)
         hence "\<ominus>\<ominus>?e = ?e"
           using 3 by (metis matrix_stone_algebra.regular_closed_sup matrix_stone_relation_algebra.regular_mult_closed)
         hence 7: "\<ominus>\<ominus>?es = ?es"
           by (metis pp_star_commute restrict_pp)
         have "\<ominus>\<ominus>(star_matrix' ?t (\<ominus>\<ominus>g)) = \<ominus>\<ominus>(?es \<oplus> ?as \<odot> ?b \<odot> ?fs \<oplus> ?ds \<odot> ?c \<odot> ?es \<oplus> ?fs)"
           by (metis star_matrix'.simps(2))
         also have "... = \<ominus>\<ominus>?es \<oplus> \<ominus>\<ominus>?as \<odot> \<ominus>\<ominus>?b \<odot> \<ominus>\<ominus>?fs \<oplus> \<ominus>\<ominus>?ds \<odot> \<ominus>\<ominus>?c \<odot> \<ominus>\<ominus>?es \<oplus> \<ominus>\<ominus>?fs"
           by (simp add: matrix_stone_relation_algebra.pp_dist_comp)
         also have "... = ?es \<oplus> ?as \<odot> ?b \<odot> ?fs \<oplus> ?ds \<odot> ?c \<odot> ?es \<oplus> ?fs"
           using 3 4 5 6 7 by simp
         finally show "\<ominus>\<ominus>(star_matrix' ?t (\<ominus>\<ominus>g)) = star_matrix' ?t (\<ominus>\<ominus>g)"
           by (metis star_matrix'.simps(2))
       qed
     qed
     hence "(\<ominus>\<ominus>x)\<^sup>\<odot> = \<ominus>\<ominus>((\<ominus>\<ominus>x)\<^sup>\<odot>)"
       by (simp add: enum_distinct restrict_all)
     thus "\<ominus>\<ominus>(x\<^sup>\<odot>) \<preceq> (\<ominus>\<ominus>x)\<^sup>\<odot>"
       by (metis matrix_kleene_algebra.star.circ_isotone matrix_p_algebra.pp_increasing matrix_p_algebra.pp_isotone)
   next
     have "?o \<oplus> \<ominus>\<ominus>x \<odot> \<ominus>\<ominus>(x\<^sup>\<odot>) \<preceq> \<ominus>\<ominus>(x\<^sup>\<odot>)"
       by (metis matrix_kleene_algebra.star_left_unfold_equal matrix_p_algebra.sup_pp_semi_commute matrix_stone_relation_algebra.pp_dist_comp)
     thus "(\<ominus>\<ominus>x)\<^sup>\<odot> \<preceq> \<ominus>\<ominus>(x\<^sup>\<odot>)"
       using matrix_kleene_algebra.star_left_induct by fastforce
   qed
 qed
 
+interpretation matrix_stone_kleene_relation_algebra_consistent: stone_kleene_relation_algebra_consistent where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a::enum,'b::stone_kleene_relation_algebra_consistent) square" and top = top_matrix and uminus = uminus_matrix and one = one_matrix and times = times_matrix and conv = conv_matrix and star = star_matrix
+  ..
+
+interpretation matrix_stone_kleene_relation_algebra_tarski: stone_kleene_relation_algebra_tarski where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a::enum,'b::stone_kleene_relation_algebra_tarski) square" and top = top_matrix and uminus = uminus_matrix and one = one_matrix and times = times_matrix and conv = conv_matrix and star = star_matrix
+  ..
+
+interpretation matrix_stone_kleene_relation_algebra_tarski_consistent: stone_kleene_relation_algebra_tarski_consistent where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a::enum,'b::stone_kleene_relation_algebra_tarski_consistent) square" and top = top_matrix and uminus = uminus_matrix and one = one_matrix and times = times_matrix and conv = conv_matrix and star = star_matrix
+  ..
+
 end
 
diff --git a/thys/Stone_Relation_Algebras/Choose_Component.thy b/thys/Stone_Relation_Algebras/Choose_Component.thy
new file mode 100644
--- /dev/null
+++ b/thys/Stone_Relation_Algebras/Choose_Component.thy
@@ -0,0 +1,97 @@
+(* Title:      An Operation to Select Components
+   Author:     Nicolas Robinson-O'Brien, Walter Guttmann
+   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
+*)
+
+section \<open>An Operation to Select Components\<close>
+
+text \<open>
+In this theory we axiomatise an operation to select components of a graph.
+This is joint work with Nicolas Robinson-O'Brien.
+\<close>
+
+theory Choose_Component
+
+imports
+  Relation_Algebras
+
+begin
+
+context stone_relation_algebra
+begin
+
+text \<open>
+A \<open>vector_classes\<close> corresponds to one or more equivalence classes and a \<open>unique_vector_class\<close> corresponds to a single equivalence class.
+\<close>
+
+definition vector_classes        :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where "vector_classes x v \<equiv> regular x \<and> regular v \<and> equivalence x \<and> vector v \<and> x * v \<le> v \<and> v \<noteq> bot"
+definition unique_vector_class   :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where "unique_vector_class x v \<equiv> vector_classes x v \<and> v * v\<^sup>T \<le> x"
+
+end
+
+text \<open>
+We introduce the operation \<open>choose_component\<close>.
+\begin{itemize}
+  \item Axiom \<open>component_in_v\<close> expresses that the result of \<open>choose_component\<close> is contained in the set of vertices, $v$, we are selecting from, ignoring the weights.
+  \item Axiom \<open>component_is_vector\<close> states that the result of \<open>choose_component\<close> is a vector.
+  \item Axiom \<open>component_is_regular\<close> states that the result of \<open>choose_component\<close> is regular.
+  \item Axiom \<open>component_is_connected\<close> states that any two vertices from the result of \<open>choose_component\<close> are connected in $e$.
+  \item Axiom \<open>component_single\<close> states that the result of \<open>choose_component\<close> is closed under being connected in $e$.
+  \item Finally, axiom \<open>component_not_bot_when_v_bot_bot\<close> expresses that the operation \<open>choose_component\<close> returns a non-empty component if the input satisfies the given criteria.
+\end{itemize}
+\<close>
+
+class choose_component =
+  fixes choose_component :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
+
+class choose_component_algebra = choose_component + stone_relation_algebra +
+  assumes component_is_vector:              "vector (choose_component e v)"
+  assumes component_is_regular:             "regular (choose_component e v)"
+  assumes component_in_v:                   "choose_component e v \<le> --v"
+  assumes component_is_connected:           "choose_component e v * (choose_component e v)\<^sup>T \<le> e"
+  assumes component_single:                 "e * choose_component e v \<le> choose_component e v"
+  assumes component_not_bot_when_v_bot_bot: "vector_classes e v \<longrightarrow> choose_component e v \<noteq> bot"
+begin
+
+lemma component_single_eq:
+  assumes "equivalence x"
+  shows "choose_component x v = x * choose_component x v"
+proof -
+  have "choose_component x v \<le> x * choose_component x v"
+    by (meson component_is_connected ex231c mult_isotone order_lesseq_imp)
+  thus ?thesis
+    by (simp add: component_single order.antisym)
+qed
+
+end
+
+class choose_component_algebra_tarski = choose_component_algebra + stone_relation_algebra_tarski
+begin
+
+definition "choose_component_point x \<equiv> choose_component 1 (--x)"
+
+lemma choose_component_point_point:
+  assumes "vector x"
+      and "x \<noteq> bot"
+    shows "point (choose_component_point x)"
+proof (intro conjI)
+  show 1: "vector (choose_component_point x)"
+    by (simp add: choose_component_point_def component_is_vector)
+  show "injective (choose_component_point x)"
+    by (simp add: choose_component_point_def component_is_connected)
+  have "vector_classes 1 (--x)"
+    by (metis assms comp_inf.semiring.mult_zero_left coreflexive_symmetric inf.eq_refl mult_1_left pp_one regular_closed_p selection_closed_id vector_classes_def vector_complement_closed)
+  hence "choose_component_point x \<noteq> bot"
+    by (simp add: choose_component_point_def component_not_bot_when_v_bot_bot)
+  thus "surjective (choose_component_point x)"
+    using 1 choose_component_point_def component_is_regular tarski vector_mult_closed by fastforce
+qed
+
+lemma choose_component_point_decreasing:
+  "choose_component_point x \<le> --x"
+  by (metis choose_component_point_def component_in_v regular_closed_p)
+
+end
+
+end
+
diff --git a/thys/Stone_Relation_Algebras/Matrix_Relation_Algebras.thy b/thys/Stone_Relation_Algebras/Matrix_Relation_Algebras.thy
--- a/thys/Stone_Relation_Algebras/Matrix_Relation_Algebras.thy
+++ b/thys/Stone_Relation_Algebras/Matrix_Relation_Algebras.thy
@@ -1,613 +1,651 @@
 (* Title:      Matrix Relation Algebras
    Author:     Walter Guttmann
    Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
 *)
 
 section \<open>Matrix Relation Algebras\<close>
 
 text \<open>
 This theory gives matrix models of Stone relation algebras and more general structures.
 We consider only square matrices.
 The main result is that matrices over Stone relation algebras form a Stone relation algebra.
 
 We use the monoid structure underlying semilattices to provide finite sums, which are necessary for defining the composition of two matrices.
 See \<^cite>\<open>"ArmstrongFosterStruthWeber2016" and "ArmstrongGomesStruthWeber2016"\<close> for similar liftings to matrices for semirings and relation algebras.
 A technical difference is that those theories are mostly based on semirings whereas our hierarchy is mostly based on lattices (and our semirings directly inherit from semilattices).
 
 Relation algebras have both a semiring and a lattice structure such that semiring addition and lattice join coincide.
 In particular, finite sums and finite suprema coincide.
 Isabelle/HOL has separate theories for semirings and lattices, based on separate addition and join operations and different operations for finite sums and finite suprema.
 Reusing results from both theories is beneficial for relation algebras, but not always easy to realise.
 \<close>
 
 theory Matrix_Relation_Algebras
 
 imports Relation_Algebras
 
 begin
 
 subsection \<open>Finite Suprema\<close>
 
 text \<open>
 We consider finite suprema in idempotent semirings and Stone relation algebras.
 We mostly use the first of the following notations, which denotes the supremum of expressions \<open>t(x)\<close> over all \<open>x\<close> from the type of \<open>x\<close>.
 For finite types, this is implemented in Isabelle/HOL as the repeated application of binary suprema.
 \<close>
 
 syntax
   "_sum_sup_monoid" :: "idt \<Rightarrow> 'a::bounded_semilattice_sup_bot \<Rightarrow> 'a" ("(\<Squnion>\<^sub>_ _)" [0,10] 10)
   "_sum_sup_monoid_bounded" :: "idt \<Rightarrow> 'b set \<Rightarrow> 'a::bounded_semilattice_sup_bot \<Rightarrow> 'a" ("(\<Squnion>\<^bsub>_\<in>_\<^esub> _)" [0,51,10] 10)
 translations
   "\<Squnion>\<^sub>x t" => "XCONST sup_monoid.sum (\<lambda>x . t) { x . CONST True }"
   "\<Squnion>\<^bsub>x\<in>X\<^esub> t" => "XCONST sup_monoid.sum (\<lambda>x . t) X"
 
 context idempotent_semiring
 begin
 
 text \<open>
 The following induction principles are useful for comparing two suprema.
 The first principle works because types are not empty.
 \<close>
 
 lemma one_sup_induct [case_names one sup]:
   fixes f g :: "'b::finite \<Rightarrow> 'a"
   assumes one: "\<And>i . P (f i) (g i)"
       and sup: "\<And>j I . j \<notin> I \<Longrightarrow> P (\<Squnion>\<^bsub>i\<in>I\<^esub> f i) (\<Squnion>\<^bsub>i\<in>I\<^esub> g i) \<Longrightarrow> P (f j \<squnion> (\<Squnion>\<^bsub>i\<in>I\<^esub> f i)) (g j \<squnion> (\<Squnion>\<^bsub>i\<in>I\<^esub> g i))"
     shows "P (\<Squnion>\<^sub>k f k) (\<Squnion>\<^sub>k g k)"
 proof -
   let ?X = "{ k::'b . True }"
   have "finite ?X" and "?X \<noteq> {}"
     by auto
   thus ?thesis
   proof (induct rule: finite_ne_induct)
     case (singleton i) thus ?case
       using one by simp
   next
     case (insert j I) thus ?case
       using sup by simp
   qed
 qed
 
 lemma bot_sup_induct [case_names bot sup]:
   fixes f g :: "'b::finite \<Rightarrow> 'a"
   assumes bot: "P bot bot"
       and sup: "\<And>j I . j \<notin> I \<Longrightarrow> P (\<Squnion>\<^bsub>i\<in>I\<^esub> f i) (\<Squnion>\<^bsub>i\<in>I\<^esub> g i) \<Longrightarrow> P (f j \<squnion> (\<Squnion>\<^bsub>i\<in>I\<^esub> f i)) (g j \<squnion> (\<Squnion>\<^bsub>i\<in>I\<^esub> g i))"
     shows "P (\<Squnion>\<^sub>k f k) (\<Squnion>\<^sub>k g k)"
   apply (induct rule: one_sup_induct)
   using bot sup apply fastforce
   using sup by blast
 
 text \<open>
 Now many properties of finite suprema follow by simple applications of the above induction rules.
 In particular, we show distributivity of composition, isotonicity and the upper-bound property.
 \<close>
 
 lemma comp_right_dist_sum:
   fixes f :: "'b::finite \<Rightarrow> 'a"
   shows "(\<Squnion>\<^sub>k f k * x) = (\<Squnion>\<^sub>k f k) * x"
 proof (induct rule: one_sup_induct)
   case one show ?case
     by simp
 next
   case (sup j I) thus ?case
     using mult_right_dist_sup by auto
 qed
 
 lemma comp_left_dist_sum:
   fixes f :: "'b::finite \<Rightarrow> 'a"
   shows "(\<Squnion>\<^sub>k x * f k) = x * (\<Squnion>\<^sub>k f k)"
 proof (induct rule: one_sup_induct)
   case one show ?case
     by simp
 next
   case (sup j I) thus ?case
     by (simp add: mult_left_dist_sup)
 qed
 
 lemma leq_sum:
   fixes f g :: "'b::finite \<Rightarrow> 'a"
   shows "(\<forall>k . f k \<le> g k) \<Longrightarrow> (\<Squnion>\<^sub>k f k) \<le> (\<Squnion>\<^sub>k g k)"
 proof (induct rule: one_sup_induct)
   case one thus ?case
     by simp
 next
   case (sup j I) thus ?case
     using sup_mono by blast
 qed
 
 lemma ub_sum:
   fixes f :: "'b::finite \<Rightarrow> 'a"
   shows "f i \<le> (\<Squnion>\<^sub>k f k)"
 proof -
   have "i \<in> { k . True }"
     by simp
   thus "f i \<le> (\<Squnion>\<^sub>k f (k::'b))"
     by (metis finite_code sup_monoid.sum.insert sup_ge1 mk_disjoint_insert)
 qed
 
 lemma lub_sum:
   fixes f :: "'b::finite \<Rightarrow> 'a"
   assumes "\<forall>k . f k \<le> x"
     shows "(\<Squnion>\<^sub>k f k) \<le> x"
 proof (induct rule: one_sup_induct)
   case one show ?case
     by (simp add: assms)
 next
   case (sup j I) thus ?case
     using assms le_supI by blast
 qed
 
 lemma lub_sum_iff:
   fixes f :: "'b::finite \<Rightarrow> 'a"
   shows "(\<forall>k . f k \<le> x) \<longleftrightarrow> (\<Squnion>\<^sub>k f k) \<le> x"
   using order.trans ub_sum lub_sum by blast
 
+lemma sum_const:
+  "(\<Squnion>\<^sub>k::'b::finite f) = f"
+  by (metis lub_sum sup.cobounded1 sup_monoid.add_0_right sup_same_context ub_sum)
+
 end
 
 context stone_relation_algebra
 begin
 
 text \<open>
 In Stone relation algebras, we can also show that converse,  double complement and meet distribute over finite suprema.
 \<close>
 
 lemma conv_dist_sum:
   fixes f :: "'b::finite \<Rightarrow> 'a"
   shows "(\<Squnion>\<^sub>k (f k)\<^sup>T) = (\<Squnion>\<^sub>k f k)\<^sup>T"
 proof (induct rule: one_sup_induct)
   case one show ?case
     by simp
 next
   case (sup j I) thus ?case
     by (simp add: conv_dist_sup)
 qed
 
 lemma pp_dist_sum:
   fixes f :: "'b::finite \<Rightarrow> 'a"
   shows "(\<Squnion>\<^sub>k --f k) = --(\<Squnion>\<^sub>k f k)"
 proof (induct rule: one_sup_induct)
   case one show ?case
     by simp
 next
   case (sup j I) thus ?case
     by simp
 qed
 
 lemma inf_right_dist_sum:
   fixes f :: "'b::finite \<Rightarrow> 'a"
   shows "(\<Squnion>\<^sub>k f k \<sqinter> x) = (\<Squnion>\<^sub>k f k) \<sqinter> x"
   by (rule comp_inf.comp_right_dist_sum)
 
 end
 
 subsection \<open>Square Matrices\<close>
 
 text \<open>
 Because our semiring and relation algebra type classes only work for homogeneous relations, we only look at square matrices.
 \<close>
 
 type_synonym ('a,'b) square = "'a \<times> 'a \<Rightarrow> 'b"
 
 text \<open>
 We use standard matrix operations.
 The Stone algebra structure is lifted componentwise.
 Composition is matrix multiplication using given composition and supremum operations.
 Its unit lifts given zero and one elements into an identity matrix.
 Converse is matrix transpose with an additional componentwise transpose.
 \<close>
 
 definition less_eq_matrix :: "('a,'b::ord) square \<Rightarrow> ('a,'b) square \<Rightarrow> bool"                                           (infix "\<preceq>" 50)   where "f \<preceq> g = (\<forall>e . f e \<le> g e)"
 definition less_matrix    :: "('a,'b::ord) square \<Rightarrow> ('a,'b) square \<Rightarrow> bool"                                           (infix "\<prec>" 50)   where "f \<prec> g = (f \<preceq> g \<and> \<not> g \<preceq> f)"
 definition sup_matrix     :: "('a,'b::sup) square \<Rightarrow> ('a,'b) square \<Rightarrow> ('a,'b) square"                                 (infixl "\<oplus>" 65)  where "f \<oplus> g = (\<lambda>e . f e \<squnion> g e)"
 definition inf_matrix     :: "('a,'b::inf) square \<Rightarrow> ('a,'b) square \<Rightarrow> ('a,'b) square"                                 (infixl "\<otimes>" 67)  where "f \<otimes> g = (\<lambda>e . f e \<sqinter> g e)"
 definition minus_matrix   :: "('a,'b::{uminus,inf}) square \<Rightarrow> ('a,'b) square \<Rightarrow> ('a,'b) square"                        (infixl "\<ominus>" 65)  where "f \<ominus> g = (\<lambda>e . f e \<sqinter> -g e)"
 definition implies_matrix :: "('a,'b::implies) square \<Rightarrow> ('a,'b) square \<Rightarrow> ('a,'b) square"                             (infixl "\<oslash>" 65)  where "f \<oslash> g = (\<lambda>e . f e \<leadsto> g e)"
 definition times_matrix   :: "('a,'b::{times,bounded_semilattice_sup_bot}) square \<Rightarrow> ('a,'b) square \<Rightarrow> ('a,'b) square" (infixl "\<odot>" 70)  where "f \<odot> g = (\<lambda>(i,j) . \<Squnion>\<^sub>k f (i,k) * g (k,j))"
 definition uminus_matrix  :: "('a,'b::uminus) square \<Rightarrow> ('a,'b) square"                                                ("\<ominus> _" [80] 80)  where "\<ominus>f    = (\<lambda>e . -f e)"
 definition conv_matrix    :: "('a,'b::conv) square \<Rightarrow> ('a,'b) square"                                                  ("_\<^sup>t" [100] 100) where "f\<^sup>t      = (\<lambda>(i,j) . (f (j,i))\<^sup>T)"
 definition bot_matrix     :: "('a,'b::bot) square"                                                                     ("mbot")         where "mbot   = (\<lambda>e . bot)"
 definition top_matrix     :: "('a,'b::top) square"                                                                     ("mtop")         where "mtop   = (\<lambda>e . top)"
 definition one_matrix     :: "('a,'b::{one,bot}) square"                                                               ("mone")         where "mone   = (\<lambda>(i,j) . if i = j then 1 else bot)"
 
 subsection \<open>Stone Algebras\<close>
 
 text \<open>
 We first lift the Stone algebra structure.
 Because all operations are componentwise, this also works for infinite matrices.
 \<close>
 
 interpretation matrix_order: order where less_eq = less_eq_matrix and less = "less_matrix :: ('a,'b::order) square \<Rightarrow> ('a,'b) square \<Rightarrow> bool"
   apply unfold_locales
   apply (simp add: less_matrix_def)
   apply (simp add: less_eq_matrix_def)
   apply (meson less_eq_matrix_def order_trans)
   by (meson less_eq_matrix_def antisym ext)
 
 interpretation matrix_semilattice_sup: semilattice_sup where sup = sup_matrix and less_eq = less_eq_matrix and less = "less_matrix :: ('a,'b::semilattice_sup) square \<Rightarrow> ('a,'b) square \<Rightarrow> bool"
   apply unfold_locales
   apply (simp add: sup_matrix_def less_eq_matrix_def)
   apply (simp add: sup_matrix_def less_eq_matrix_def)
   by (simp add: sup_matrix_def less_eq_matrix_def)
 
 interpretation matrix_semilattice_inf: semilattice_inf where inf = inf_matrix and less_eq = less_eq_matrix and less = "less_matrix :: ('a,'b::semilattice_inf) square \<Rightarrow> ('a,'b) square \<Rightarrow> bool"
   apply unfold_locales
   apply (simp add: inf_matrix_def less_eq_matrix_def)
   apply (simp add: inf_matrix_def less_eq_matrix_def)
   by (simp add: inf_matrix_def less_eq_matrix_def)
 
 interpretation matrix_bounded_semilattice_sup_bot: bounded_semilattice_sup_bot where sup = sup_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a,'b::bounded_semilattice_sup_bot) square"
   apply unfold_locales
   by (simp add: bot_matrix_def less_eq_matrix_def)
 
 interpretation matrix_bounded_semilattice_inf_top: bounded_semilattice_inf_top where inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and top = "top_matrix :: ('a,'b::bounded_semilattice_inf_top) square"
   apply unfold_locales
   by (simp add: less_eq_matrix_def top_matrix_def)
 
 interpretation matrix_lattice: lattice where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = "less_matrix :: ('a,'b::lattice) square \<Rightarrow> ('a,'b) square \<Rightarrow> bool" ..
 
 interpretation matrix_distrib_lattice: distrib_lattice where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = "less_matrix :: ('a,'b::distrib_lattice) square \<Rightarrow> ('a,'b) square \<Rightarrow> bool"
   apply unfold_locales
   by (simp add: sup_inf_distrib1 sup_matrix_def inf_matrix_def)
 
 interpretation matrix_bounded_lattice: bounded_lattice where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a,'b::bounded_lattice) square" and top = top_matrix ..
 
 interpretation matrix_bounded_distrib_lattice: bounded_distrib_lattice where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a,'b::bounded_distrib_lattice) square" and top = top_matrix ..
 
 interpretation matrix_p_algebra: p_algebra where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a,'b::p_algebra) square" and top = top_matrix and uminus = uminus_matrix
   apply unfold_locales
   apply (unfold inf_matrix_def bot_matrix_def less_eq_matrix_def uminus_matrix_def)
   by (meson pseudo_complement)
 
 interpretation matrix_pd_algebra: pd_algebra where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a,'b::pd_algebra) square" and top = top_matrix and uminus = uminus_matrix ..
 
 text \<open>
 In particular, matrices over Stone algebras form a Stone algebra.
 \<close>
 
 interpretation matrix_stone_algebra: stone_algebra where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a,'b::stone_algebra) square" and top = top_matrix and uminus = uminus_matrix
   by unfold_locales (simp add: sup_matrix_def uminus_matrix_def top_matrix_def)
 
 interpretation matrix_heyting_stone_algebra: heyting_stone_algebra where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a,'b::heyting_stone_algebra) square" and top = top_matrix and uminus = uminus_matrix and implies = implies_matrix
   apply unfold_locales
   apply (unfold inf_matrix_def sup_matrix_def bot_matrix_def top_matrix_def less_eq_matrix_def uminus_matrix_def implies_matrix_def)
   apply (simp add: implies_galois)
   apply (simp add: uminus_eq)
   by simp
 
 interpretation matrix_boolean_algebra: boolean_algebra where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a,'b::boolean_algebra) square" and top = top_matrix and uminus = uminus_matrix and minus = minus_matrix
   apply unfold_locales
   apply simp
   apply (simp add: sup_matrix_def uminus_matrix_def top_matrix_def)
   by (simp add: inf_matrix_def uminus_matrix_def minus_matrix_def)
 
 subsection \<open>Semirings\<close>
 
 text \<open>
 Next, we lift the semiring structure.
 Because of composition, this requires a restriction to finite matrices.
 \<close>
 
 interpretation matrix_monoid: monoid_mult where times = times_matrix and one = "one_matrix :: ('a::finite,'b::idempotent_semiring) square"
 proof
   fix f g h :: "('a,'b) square"
   show "(f \<odot> g) \<odot> h = f \<odot> (g \<odot> h)"
   proof (rule ext, rule prod_cases)
     fix i j
     have "((f \<odot> g) \<odot> h) (i,j) = (\<Squnion>\<^sub>l (f \<odot> g) (i,l) * h (l,j))"
       by (simp add: times_matrix_def)
     also have "... = (\<Squnion>\<^sub>l (\<Squnion>\<^sub>k f (i,k) * g (k,l)) * h (l,j))"
       by (simp add: times_matrix_def)
     also have "... = (\<Squnion>\<^sub>l \<Squnion>\<^sub>k (f (i,k) * g (k,l)) * h (l,j))"
       by (metis (no_types) comp_right_dist_sum)
     also have "... = (\<Squnion>\<^sub>l \<Squnion>\<^sub>k f (i,k) * (g (k,l) * h (l,j)))"
       by (simp add: mult.assoc)
     also have "... = (\<Squnion>\<^sub>k \<Squnion>\<^sub>l f (i,k) * (g (k,l) * h (l,j)))"
       using sup_monoid.sum.swap by auto
     also have "... = (\<Squnion>\<^sub>k f (i,k) * (\<Squnion>\<^sub>l g (k,l) * h (l,j)))"
       by (metis (no_types) comp_left_dist_sum)
     also have "... = (\<Squnion>\<^sub>k f (i,k) * (g \<odot> h) (k,j))"
       by (simp add: times_matrix_def)
     also have "... = (f \<odot> (g \<odot> h)) (i,j)"
       by (simp add: times_matrix_def)
     finally show "((f \<odot> g) \<odot> h) (i,j) = (f \<odot> (g \<odot> h)) (i,j)"
       .
   qed
 next
   fix f :: "('a,'b) square"
   show "mone \<odot> f = f"
   proof (rule ext, rule prod_cases)
     fix i j
     have "(mone \<odot> f) (i,j) = (\<Squnion>\<^sub>k mone (i,k) * f (k,j))"
       by (simp add: times_matrix_def)
     also have "... = (\<Squnion>\<^sub>k (if i = k then 1 else bot) * f (k,j))"
       by (simp add: one_matrix_def)
     also have "... = (\<Squnion>\<^sub>k if i = k then 1 * f (k,j) else bot * f (k,j))"
       by (metis (full_types, opaque_lifting))
     also have "... = (\<Squnion>\<^sub>k if i = k then f (k,j) else bot)"
       by (meson mult_left_one mult_left_zero)
     also have "... = f (i,j)"
       by simp
     finally show "(mone \<odot> f) (i,j) = f (i,j)"
       .
   qed
 next
   fix f :: "('a,'b) square"
   show "f \<odot> mone = f"
   proof (rule ext, rule prod_cases)
     fix i j
     have "(f \<odot> mone) (i,j) = (\<Squnion>\<^sub>k f (i,k) * mone (k,j))"
       by (simp add: times_matrix_def)
     also have "... = (\<Squnion>\<^sub>k f (i,k) * (if k = j then 1 else bot))"
       by (simp add: one_matrix_def)
     also have "... = (\<Squnion>\<^sub>k if k = j then f (i,k) * 1 else f (i,k) * bot)"
       by (metis (full_types, opaque_lifting))
     also have "... = (\<Squnion>\<^sub>k if k = j then f (i,k) else bot)"
       by (meson mult.right_neutral semiring.mult_zero_right)
     also have "... = f (i,j)"
       by simp
     finally show "(f \<odot> mone) (i,j) = f (i,j)"
       .
   qed
 qed
 
 interpretation matrix_idempotent_semiring: idempotent_semiring where sup = sup_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a::finite,'b::idempotent_semiring) square" and one = one_matrix and times = times_matrix
 proof
   fix f g h :: "('a,'b) square"
   show "f \<odot> g \<oplus> f \<odot> h \<preceq> f \<odot> (g \<oplus> h)"
   proof (unfold less_eq_matrix_def, rule allI, rule prod_cases)
     fix i j
     have "(f \<odot> g \<oplus> f \<odot> h) (i,j) = (f \<odot> g) (i,j) \<squnion> (f \<odot> h) (i,j)"
       by (simp add: sup_matrix_def)
     also have "... = (\<Squnion>\<^sub>k f (i,k) * g (k,j)) \<squnion> (\<Squnion>\<^sub>k f (i,k) * h (k,j))"
       by (simp add: times_matrix_def)
     also have "... = (\<Squnion>\<^sub>k f (i,k) * g (k,j) \<squnion> f (i,k) * h (k,j))"
       by (simp add: sup_monoid.sum.distrib)
     also have "... = (\<Squnion>\<^sub>k f (i,k) * (g (k,j) \<squnion> h (k,j)))"
       by (simp add: mult_left_dist_sup)
     also have "... = (\<Squnion>\<^sub>k f (i,k) * (g \<oplus> h) (k,j))"
       by (simp add: sup_matrix_def)
     also have "... = (f \<odot> (g \<oplus> h)) (i,j)"
       by (simp add: times_matrix_def)
     finally show "(f \<odot> g \<oplus> f \<odot> h) (i,j) \<le> (f \<odot> (g \<oplus> h)) (i,j)"
       by simp
   qed
 next
   fix f g h :: "('a,'b) square"
   show "(f \<oplus> g) \<odot> h = f \<odot> h \<oplus> g \<odot> h"
   proof (rule ext, rule prod_cases)
     fix i j
     have "((f \<oplus> g) \<odot> h) (i,j) = (\<Squnion>\<^sub>k (f \<oplus> g) (i,k) * h (k,j))"
       by (simp add: times_matrix_def)
     also have "... = (\<Squnion>\<^sub>k (f (i,k) \<squnion> g (i,k)) * h (k,j))"
       by (simp add: sup_matrix_def)
     also have "... = (\<Squnion>\<^sub>k f (i,k) * h (k,j) \<squnion> g (i,k) * h (k,j))"
       by (meson mult_right_dist_sup)
     also have "... = (\<Squnion>\<^sub>k f (i,k) * h (k,j)) \<squnion> (\<Squnion>\<^sub>k g (i,k) * h (k,j))"
       by (simp add: sup_monoid.sum.distrib)
     also have "... = (f \<odot> h) (i,j) \<squnion> (g \<odot> h) (i,j)"
       by (simp add: times_matrix_def)
     also have "... = (f \<odot> h \<oplus> g \<odot> h) (i,j)"
       by (simp add: sup_matrix_def)
     finally show "((f \<oplus> g) \<odot> h) (i,j) = (f \<odot> h \<oplus> g \<odot> h) (i,j)"
       .
   qed
 next
   fix f :: "('a,'b) square"
   show "mbot \<odot> f = mbot"
   proof (rule ext, rule prod_cases)
     fix i j
     have "(mbot \<odot> f) (i,j) = (\<Squnion>\<^sub>k mbot (i,k) * f (k,j))"
       by (simp add: times_matrix_def)
     also have "... = (\<Squnion>\<^sub>k bot * f (k,j))"
       by (simp add: bot_matrix_def)
     also have "... = bot"
       by simp
     also have "... = mbot (i,j)"
       by (simp add: bot_matrix_def)
     finally show "(mbot \<odot> f) (i,j) = mbot (i,j)"
       .
   qed
 next
   fix f :: "('a,'b) square"
   show "mone \<odot> f = f"
     by simp
 next
   fix f :: "('a,'b) square"
   show "f \<preceq> f \<odot> mone"
     by simp
 next
   fix f g h :: "('a,'b) square"
   show "f \<odot> (g \<oplus> h) = f \<odot> g \<oplus> f \<odot> h"
   proof (rule ext, rule prod_cases)
     fix i j
     have "(f \<odot> (g \<oplus> h)) (i,j) = (\<Squnion>\<^sub>k f (i,k) * (g \<oplus> h) (k,j))"
       by (simp add: times_matrix_def)
     also have "... = (\<Squnion>\<^sub>k f (i,k) * (g (k,j) \<squnion> h (k,j)))"
       by (simp add: sup_matrix_def)
     also have "... = (\<Squnion>\<^sub>k f (i,k) * g (k,j) \<squnion> f (i,k) * h (k,j))"
       by (meson mult_left_dist_sup)
     also have "... = (\<Squnion>\<^sub>k f (i,k) * g (k,j)) \<squnion> (\<Squnion>\<^sub>k f (i,k) * h (k,j))"
       by (simp add: sup_monoid.sum.distrib)
     also have "... = (f \<odot> g) (i,j) \<squnion> (f \<odot> h) (i,j)"
       by (simp add: times_matrix_def)
     also have "... = (f \<odot> g \<oplus> f \<odot> h) (i,j)"
       by (simp add: sup_matrix_def)
     finally show "(f \<odot> (g \<oplus> h)) (i,j) = (f \<odot> g \<oplus> f \<odot> h) (i,j)"
       .
   qed
 next
   fix f :: "('a,'b) square"
   show "f \<odot> mbot = mbot"
   proof (rule ext, rule prod_cases)
     fix i j
     have "(f \<odot> mbot) (i,j) = (\<Squnion>\<^sub>k f (i,k) * mbot (k,j))"
       by (simp add: times_matrix_def)
     also have "... = (\<Squnion>\<^sub>k f (i,k) * bot)"
       by (simp add: bot_matrix_def)
     also have "... = bot"
       by simp
     also have "... = mbot (i,j)"
       by (simp add: bot_matrix_def)
     finally show "(f \<odot> mbot) (i,j) = mbot (i,j)"
       .
   qed
 qed
 
 interpretation matrix_bounded_idempotent_semiring: bounded_idempotent_semiring where sup = sup_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a::finite,'b::bounded_idempotent_semiring) square" and top = top_matrix and one = one_matrix and times = times_matrix
 proof
   fix f :: "('a,'b) square"
   show "f \<oplus> mtop = mtop"
   proof
     fix e
     have "(f \<oplus> mtop) e = f e \<squnion> mtop e"
       by (simp add: sup_matrix_def)
     also have "... = f e \<squnion> top"
       by (simp add: top_matrix_def)
     also have "... = top"
       by simp
     also have "... = mtop e"
       by (simp add: top_matrix_def)
     finally show "(f \<oplus> mtop) e = mtop e"
       .
   qed
 qed
 
 subsection \<open>Stone Relation Algebras\<close>
 
 text \<open>
 Finally, we show that matrices over Stone relation algebras form a Stone relation algebra.
 \<close>
 
 interpretation matrix_stone_relation_algebra: stone_relation_algebra where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a::finite,'b::stone_relation_algebra) square" and top = top_matrix and uminus = uminus_matrix and one = one_matrix and times = times_matrix and conv = conv_matrix
 proof
   fix f g h :: "('a,'b) square"
   show "(f \<odot> g) \<odot> h = f \<odot> (g \<odot> h)"
     by (simp add: matrix_monoid.mult_assoc)
 next
   fix f g h :: "('a,'b) square"
   show "(f \<oplus> g) \<odot> h = f \<odot> h \<oplus> g \<odot> h"
     by (simp add: matrix_idempotent_semiring.mult_right_dist_sup)
 next
   fix f :: "('a,'b) square"
   show "mbot \<odot> f = mbot"
     by simp
 next
   fix f :: "('a,'b) square"
   show "mone \<odot> f = f"
     by simp
 next
   fix f :: "('a,'b) square"
   show "f\<^sup>t\<^sup>t = f"
   proof (rule ext, rule prod_cases)
     fix i j
     have "(f\<^sup>t\<^sup>t) (i,j) = ((f\<^sup>t) (j,i))\<^sup>T"
       by (simp add: conv_matrix_def)
     also have "... = f (i,j)"
       by (simp add: conv_matrix_def)
     finally show "(f\<^sup>t\<^sup>t) (i,j) = f (i,j)"
       .
   qed
 next
   fix f g :: "('a,'b) square"
   show "(f \<oplus> g)\<^sup>t = f\<^sup>t \<oplus> g\<^sup>t"
   proof (rule ext, rule prod_cases)
     fix i j
     have "((f \<oplus> g)\<^sup>t) (i,j) = ((f \<oplus> g) (j,i))\<^sup>T"
       by (simp add: conv_matrix_def)
     also have "... = (f (j,i) \<squnion> g (j,i))\<^sup>T"
       by (simp add: sup_matrix_def)
     also have "... = (f\<^sup>t) (i,j) \<squnion> (g\<^sup>t) (i,j)"
       by (simp add: conv_matrix_def conv_dist_sup)
     also have "... = (f\<^sup>t \<oplus> g\<^sup>t) (i,j)"
       by (simp add: sup_matrix_def)
     finally show "((f \<oplus> g)\<^sup>t) (i,j) = (f\<^sup>t \<oplus> g\<^sup>t) (i,j)"
       .
   qed
 next
   fix f g :: "('a,'b) square"
   show "(f \<odot> g)\<^sup>t = g\<^sup>t \<odot> f\<^sup>t"
   proof (rule ext, rule prod_cases)
     fix i j
     have "((f \<odot> g)\<^sup>t) (i,j) = ((f \<odot> g) (j,i))\<^sup>T"
       by (simp add: conv_matrix_def)
     also have "... = (\<Squnion>\<^sub>k f (j,k) * g (k,i))\<^sup>T"
       by (simp add: times_matrix_def)
     also have "... = (\<Squnion>\<^sub>k (f (j,k) * g (k,i))\<^sup>T)"
       by (metis (no_types) conv_dist_sum)
     also have "... = (\<Squnion>\<^sub>k (g (k,i))\<^sup>T * (f (j,k))\<^sup>T)"
       by (simp add: conv_dist_comp)
     also have "... = (\<Squnion>\<^sub>k (g\<^sup>t) (i,k) * (f\<^sup>t) (k,j))"
       by (simp add: conv_matrix_def)
     also have "... = (g\<^sup>t \<odot> f\<^sup>t) (i,j)"
       by (simp add: times_matrix_def)
     finally show "((f \<odot> g)\<^sup>t) (i,j) = (g\<^sup>t \<odot> f\<^sup>t) (i,j)"
       .
   qed
 next
   fix f g h :: "('a,'b) square"
   show "(f \<odot> g) \<otimes> h \<preceq> f \<odot> (g \<otimes> (f\<^sup>t \<odot> h))"
   proof (unfold less_eq_matrix_def, rule allI, rule prod_cases)
     fix i j
     have "((f \<odot> g) \<otimes> h) (i,j) = (f \<odot> g) (i,j) \<sqinter> h (i,j)"
       by (simp add: inf_matrix_def)
     also have "... = (\<Squnion>\<^sub>k f (i,k) * g (k,j)) \<sqinter> h (i,j)"
       by (simp add: times_matrix_def)
     also have "... = (\<Squnion>\<^sub>k f (i,k) * g (k,j) \<sqinter> h (i,j))"
       by (metis (no_types) inf_right_dist_sum)
     also have "... \<le> (\<Squnion>\<^sub>k f (i,k) * (g (k,j) \<sqinter> (f (i,k))\<^sup>T * h (i,j)))"
       by (rule leq_sum, meson dedekind_1)
     also have "... = (\<Squnion>\<^sub>k f (i,k) * (g (k,j) \<sqinter> (f\<^sup>t) (k,i) * h (i,j)))"
       by (simp add: conv_matrix_def)
     also have "... \<le> (\<Squnion>\<^sub>k f (i,k) * (g (k,j) \<sqinter> (\<Squnion>\<^sub>l (f\<^sup>t) (k,l) * h (l,j))))"
       by (rule leq_sum, rule allI, rule comp_right_isotone, rule inf.sup_right_isotone, rule ub_sum)
     also have "... = (\<Squnion>\<^sub>k f (i,k) * (g (k,j) \<sqinter> (f\<^sup>t \<odot> h) (k,j)))"
       by (simp add: times_matrix_def)
     also have "... = (\<Squnion>\<^sub>k f (i,k) * (g \<otimes> (f\<^sup>t \<odot> h)) (k,j))"
       by (simp add: inf_matrix_def)
     also have "... = (f \<odot> (g \<otimes> (f\<^sup>t \<odot> h))) (i,j)"
       by (simp add: times_matrix_def)
     finally show "((f \<odot> g) \<otimes> h) (i,j) \<le> (f \<odot> (g \<otimes> (f\<^sup>t \<odot> h))) (i,j)"
       .
   qed
 next
   fix f g :: "('a,'b) square"
   show "\<ominus>\<ominus>(f \<odot> g) = \<ominus>\<ominus>f \<odot> \<ominus>\<ominus>g"
   proof (rule ext, rule prod_cases)
     fix i j
     have "(\<ominus>\<ominus>(f \<odot> g)) (i,j) = --((f \<odot> g) (i,j))"
       by (simp add: uminus_matrix_def)
     also have "... = --(\<Squnion>\<^sub>k f (i,k) * g (k,j))"
       by (simp add: times_matrix_def)
     also have "... = (\<Squnion>\<^sub>k --(f (i,k) * g (k,j)))"
       by (metis (no_types) pp_dist_sum)
     also have "... = (\<Squnion>\<^sub>k --(f (i,k)) * --(g (k,j)))"
       by (meson pp_dist_comp)
     also have "... = (\<Squnion>\<^sub>k (\<ominus>\<ominus>f) (i,k) * (\<ominus>\<ominus>g) (k,j))"
       by (simp add: uminus_matrix_def)
     also have "... = (\<ominus>\<ominus>f \<odot> \<ominus>\<ominus>g) (i,j)"
       by (simp add: times_matrix_def)
     finally show "(\<ominus>\<ominus>(f \<odot> g)) (i,j) = (\<ominus>\<ominus>f \<odot> \<ominus>\<ominus>g) (i,j)"
       .
   qed
 next
   let ?o = "mone :: ('a,'b) square"
   show "\<ominus>\<ominus>?o = ?o"
   proof (rule ext, rule prod_cases)
     fix i j
     have "(\<ominus>\<ominus>?o) (i,j) = --(?o (i,j))"
       by (simp add: uminus_matrix_def)
     also have "... = --(if i = j then 1 else bot)"
       by (simp add: one_matrix_def)
     also have "... = (if i = j then --1 else --bot)"
       by simp
     also have "... = (if i = j then 1 else bot)"
       by auto
     also have "... = ?o (i,j)"
       by (simp add: one_matrix_def)
     finally show "(\<ominus>\<ominus>?o) (i,j) = ?o (i,j)"
       .
   qed
 qed
 
+interpretation matrix_stone_relation_algebra_consistent: stone_relation_algebra_consistent where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a::finite,'b::stone_relation_algebra_consistent) square" and top = top_matrix and uminus = uminus_matrix and one = one_matrix and times = times_matrix and conv = conv_matrix
+proof
+  show "(mbot::('a,'b) square) \<noteq> mtop"
+    by (metis consistent bot_matrix_def top_matrix_def)
+qed
+
+interpretation matrix_stone_relation_algebra_tarski: stone_relation_algebra_tarski where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a::finite,'b::stone_relation_algebra_tarski) square" and top = top_matrix and uminus = uminus_matrix and one = one_matrix and times = times_matrix and conv = conv_matrix
+proof
+  fix x :: "('a,'b) square"
+  assume 1: "matrix_p_algebra.regular x"
+  assume "x \<noteq> mbot"
+  from this obtain i j where "x (i,j) \<noteq> bot"
+    by (metis bot_matrix_def ext surj_pair)
+  hence 2: "top * x (i,j) * top = top"
+    using 1 by (metis tarski uminus_matrix_def)
+  show "matrix_bounded_idempotent_semiring.total (mtop \<odot> x)"
+  proof (rule ext, rule prod_cases)
+    fix k l
+    have "top * x (i,j) * top \<le> (\<Squnion>\<^sub>m top * x (m,j)) * top"
+      using comp_inf.ub_sum comp_isotone by fastforce
+    also have "... = (mtop \<odot> x) (k,j) * top"
+      by (simp add: times_matrix_def top_matrix_def)
+    also have "... \<le> (\<Squnion>\<^sub>m (mtop \<odot> x) (k,m) * top)"
+      using comp_inf.ub_sum by force
+    also have "... = (mtop \<odot> x \<odot> mtop) (k,l)"
+      by (simp add: times_matrix_def top_matrix_def)
+    finally show "(mtop \<odot> x \<odot> mtop) (k,l) = mtop (k,l)"
+      using 2 by (simp add: top_matrix_def inf.bot_unique)
+  qed
+qed
+
+interpretation matrix_stone_relation_algebra_tarski_consistent: stone_relation_algebra_tarski_consistent where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a::finite,'b::stone_relation_algebra_tarski_consistent) square" and top = top_matrix and uminus = uminus_matrix and one = one_matrix and times = times_matrix and conv = conv_matrix
+  ..
+
 end
 
diff --git a/thys/Stone_Relation_Algebras/ROOT b/thys/Stone_Relation_Algebras/ROOT
--- a/thys/Stone_Relation_Algebras/ROOT
+++ b/thys/Stone_Relation_Algebras/ROOT
@@ -1,14 +1,15 @@
 chapter AFP
 
 session Stone_Relation_Algebras = Stone_Algebras +
   options [timeout = 600]
   theories
     Fixpoints
     Semirings
     Relation_Algebras
     Relation_Subalgebras
     Matrix_Relation_Algebras
     Linear_Order_Matrices
+    Choose_Component
   document_files
     "root.tex"
     "root.bib"
diff --git a/thys/Stone_Relation_Algebras/document/root.tex b/thys/Stone_Relation_Algebras/document/root.tex
--- a/thys/Stone_Relation_Algebras/document/root.tex
+++ b/thys/Stone_Relation_Algebras/document/root.tex
@@ -1,71 +1,73 @@
 \documentclass[11pt,a4paper]{article}
 \usepackage[T1]{fontenc}
 \usepackage{isabelle,isabellesym}
 \usepackage{amssymb,ragged2e}
 \usepackage{pdfsetup}
 
 \isabellestyle{it}
 \renewenvironment{isamarkuptext}{\par\isastyletext\begin{isapar}\justifying\color{blue}}{\end{isapar}}
 \renewcommand\labelitemi{$*$}
 
 \begin{document}
 
 \title{Stone Relation Algebras}
 \author{Walter Guttmann}
 \maketitle
 
 \begin{abstract}
   We develop Stone relation algebras, which generalise relation algebras by replacing the underlying Boolean algebra structure with a Stone algebra.
   We show that finite matrices over bounded linear orders form an instance.
   As a consequence, relation-algebraic concepts and methods can be used for reasoning about weighted graphs.
   We also develop a fixpoint calculus and apply it to compare different definitions of reflexive-transitive closures in semirings.
 \end{abstract}
 
 \tableofcontents
 
 \section{Synopsis and Motivation}
 
 This document describes the following six theory files:
 \begin{itemize}
 \item Fixpoints develops a fixpoint calculus based on partial orders.
       We also consider least (pre)fixpoints and greatest (post)fixpoints.
       The derived rules include unfold, square, rolling, fusion, exchange and diagonal rules studied in \cite{AartsBackhouseBoitenDoornbosGasterenGeldropHoogendijkVoermansWoude1995}.
       Our results are based on the existence of fixpoints instead of completeness of the underlying structure.
 \item Semirings contains a hierarchy of structures generalising idempotent semirings.
       In particular, several of these algebras do not assume that multiplication is associative in order to capture models such as multirelations.
       Even in such a weak setting we can derive several results comparing different definitions of reflexive-transitive closures based on fixpoints.
 \item Relation Algebras introduces Stone relation algebras, which weaken the Boolean algebra structure of relation algebras to Stone algebras.
       This is motivated by the wish to represent weighted graphs (matrices over numbers) in addition to unweighted graphs (Boolean matrices) that form relations.
       Many results of relation algebras can be derived from the weaker axioms and therefore also apply to weighted graphs.
       Some results hold in Stone relation algebras after small modifications.
       This allows us to apply relational concepts and methods also to weighted graphs.
       In particular, we prove a number of properties that have been used to verify graph algorithms.
       Tarski's relation algebras \cite{Tarski1941} arise as a special case by imposing further axioms.
 \item Subalgebras of Relation Algebras studies the structures of subsets of elements characterised by a given property.
       In particular we look at regular elements (which correspond to unweighted graphs), coreflexives (tests), vectors and covectors (which can be used to represent sets).
       The subsets are turned into Isabelle/HOL types, which are shown to form instances of various algebras.
 \item Matrix Relation Algebras lifts the Stone algebra hierarchy, the semiring structure and, finally, Stone relation algebras to finite square matrices.
       These are mostly standard constructions similar to those in \cite{ArmstrongFosterStruthWeber2016,ArmstrongGomesStruthWeber2016} implemented so that they work for many algebraic structures.
       In particular, they can be instantiated to weighted graphs (see below) and extended to Kleene algebras (not part of this development).
 \item Matrices over Bounded Linear Orders studies relational properties.
       In particular, we characterise univalent, injective, total, surjective, mapping, bijective, vector, covector, point, atom, reflexive, coreflexive, irreflexive, symmetric, antisymmetric and asymmetric matrices.
       Definitions of these properties are taken from relation algebras and their meaning for matrices over bounded linear orders (weighted graphs) is explained by logical formulas in terms of matrix entries.
 \end{itemize}
+Following a refactoring, the selection of components of a graph in Stone relation algebras, which was originally part of Nicolas Robinson-O'Brien's theory \texttt{Relational\_Minimum\_Spanning\_Trees/Boruvka.thy}, has been moved into a new theory in this entry.
+
 The development is based on a theory of Stone algebras \cite{Guttmann2016b} and forms the basis for an extension to Kleene algebras to capture further properties of graphs.
 We apply Stone relation algebras to verify Prim's minimum spanning tree algorithm in Isabelle/HOL in \cite{Guttmann2016c}.
 
 Related libraries for semirings and relation algebras in the Archive of Formal Proofs are \cite{ArmstrongFosterStruthWeber2016,ArmstrongGomesStruthWeber2016}.
 The theory \texttt{Kleene\_Algebra/Dioid.thy} introduces a number of structures that generalise idempotent semirings, but does not cover most of the semiring structures in the present development.
 The theory \texttt{Relation\_Algebra/Relation\_Algebra.thy} covers Tarski's relation algebras and hence cannot be reused for the present development as most properties need to be derived from the weaker axioms of Stone relation algebras.
 The matrix constructions in theories \texttt{Kleene\_Algebra/Inf\_Matrix.thy} and \texttt{Relation\_Algebra/Relation\_Algebra\_Models.thy} are similar, but have strong restrictions on the matrix entry types not appropriate for many algebraic structures in the present development.
 We also deviate from these hierarchies by basing idempotent semirings directly on the Isabelle/HOL semilattice structures instead of a separate structure; this results in a somewhat smoother integration with the lattice structure of relation algebras.
 
 \begin{flushleft}
 \input{session}
 \end{flushleft}
 
 \bibliographystyle{abbrv}
 \bibliography{root}
 
 \end{document}