diff --git a/thys/Relational_Disjoint_Set_Forests/Disjoint_Set_Forests.thy b/thys/Relational_Disjoint_Set_Forests/Disjoint_Set_Forests.thy
--- a/thys/Relational_Disjoint_Set_Forests/Disjoint_Set_Forests.thy
+++ b/thys/Relational_Disjoint_Set_Forests/Disjoint_Set_Forests.thy
@@ -1,2280 +1,2312 @@
 (* Title:      Disjoint-Set Forests
    Author:     Walter Guttmann
    Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
 *)
 
 theory Disjoint_Set_Forests
 
 imports
   "HOL-Hoare.Hoare_Logic"
   Stone_Kleene_Relation_Algebras.Kleene_Relation_Algebras
 begin
 
 no_notation
   trancl ("(_\<^sup>+)" [1000] 999)
 
 text \<open>
 An arc in a Stone relation algebra corresponds to an atom in a relation algebra and represents a single edge in a graph.
 A point represents a set of nodes.
 A rectangle represents the Cartesian product of two sets of nodes \cite{BerghammerStruth2010}.
 \<close>
 
 context times_top
 begin
 
 abbreviation rectangle :: "'a \<Rightarrow> bool"
   where "rectangle x \<equiv> x * top * x = x"
 
 end
 
 context stone_relation_algebra
 begin
 
 lemma arc_rectangle:
   "arc x \<Longrightarrow> rectangle x"
   using arc_top_arc by blast
 
 section \<open>Relation-Algebraic Semantics of Associative Array Access\<close>
 
 text \<open>
 The following two operations model updating array $x$ at index $y$ to value $z$, 
 and reading the content of array $x$ at index $y$, respectively.
 The read operation uses double brackets to avoid ambiguity with list syntax.
 The remainder of this section shows basic properties of these operations.
 \<close>
 
 abbreviation rel_update :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("(_[_\<longmapsto>_])" [70, 65, 65] 61)
   where "x[y\<longmapsto>z] \<equiv> (y \<sqinter> z\<^sup>T) \<squnion> (-y \<sqinter> x)"
 
 abbreviation rel_access :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("(2_[[_]])" [70, 65] 65)
   where "x[[y]] \<equiv> x\<^sup>T * y"
 
 text \<open>Theorem 1.1\<close>
 
 lemma update_univalent:
   assumes "univalent x"
     and "vector y"
     and "injective z"
   shows "univalent (x[y\<longmapsto>z])"
 proof -
   have 1: "univalent (y \<sqinter> z\<^sup>T)"
     using assms(3) inf_commute univalent_inf_closed by force
   have "(y \<sqinter> z\<^sup>T)\<^sup>T * (-y \<sqinter> x) = (y\<^sup>T \<sqinter> z) * (-y \<sqinter> x)"
     by (simp add: conv_dist_inf)
   also have "... = z * (y \<sqinter> -y \<sqinter> x)"
     by (metis assms(2) covector_inf_comp_3 inf.sup_monoid.add_assoc inf.sup_monoid.add_commute)
   finally have 2: "(y \<sqinter> z\<^sup>T)\<^sup>T * (-y \<sqinter> x) = bot"
     by simp
   have 3: "vector (-y)"
     using assms(2) vector_complement_closed by simp
   have "(-y \<sqinter> x)\<^sup>T * (y \<sqinter> z\<^sup>T) = (-y\<^sup>T \<sqinter> x\<^sup>T) * (y \<sqinter> z\<^sup>T)"
     by (simp add: conv_complement conv_dist_inf)
   also have "... = x\<^sup>T * (-y \<sqinter> y \<sqinter> z\<^sup>T)"
     using 3 by (metis (mono_tags, hide_lams) conv_complement covector_inf_comp_3 inf.sup_monoid.add_assoc inf.sup_monoid.add_commute)
   finally have 4: "(-y \<sqinter> x)\<^sup>T * (y \<sqinter> z\<^sup>T) = bot"
     by simp
   have 5: "univalent (-y \<sqinter> x)"
     using assms(1) inf_commute univalent_inf_closed by fastforce
   have "(x[y\<longmapsto>z])\<^sup>T * (x[y\<longmapsto>z]) = (y \<sqinter> z\<^sup>T)\<^sup>T * (x[y\<longmapsto>z]) \<squnion> (-y \<sqinter> x)\<^sup>T * (x[y\<longmapsto>z])"
     by (simp add: conv_dist_sup mult_right_dist_sup)
   also have "... = (y \<sqinter> z\<^sup>T)\<^sup>T * (y \<sqinter> z\<^sup>T) \<squnion> (y \<sqinter> z\<^sup>T)\<^sup>T * (-y \<sqinter> x) \<squnion> (-y \<sqinter> x)\<^sup>T * (y \<sqinter> z\<^sup>T) \<squnion> (-y \<sqinter> x)\<^sup>T * (-y \<sqinter> x)"
     by (simp add: mult_left_dist_sup sup_assoc)
   finally show ?thesis
     using 1 2 4 5 by simp
 qed
 
 text \<open>Theorem 1.2\<close>
 
 lemma update_total:
   assumes "total x"
     and "vector y"
     and "regular y"
     and "surjective z"
   shows "total (x[y\<longmapsto>z])"
 proof -
   have "(x[y\<longmapsto>z]) * top = x*top[y\<longmapsto>top*z]"
     by (simp add: assms(2) semiring.distrib_right vector_complement_closed vector_inf_comp conv_dist_comp)
   also have "... = top[y\<longmapsto>top]"
     using assms(1) assms(4) by simp
   also have "... = top"
     using assms(3) regular_complement_top by auto
   finally show ?thesis
     by simp
 qed
 
 text \<open>Theorem 1.3\<close>
 
 lemma update_mapping:
   assumes "mapping x"
     and "vector y"
     and "regular y"
     and "bijective z"
   shows "mapping (x[y\<longmapsto>z])"
   using assms update_univalent update_total by simp
 
 text \<open>Theorem 1.4\<close>
 
 lemma read_injective:
   assumes "injective y"
     and "univalent x"
   shows "injective (x[[y]])"
   using assms injective_mult_closed univalent_conv_injective by blast
 
 text \<open>Theorem 1.5\<close>
 
 lemma read_surjective:
   assumes "surjective y"
     and "total x"
   shows "surjective (x[[y]])"
   using assms surjective_mult_closed total_conv_surjective by blast
 
 text \<open>Theorem 1.6\<close>
 
 lemma read_bijective:
   assumes "bijective y"
     and "mapping x"
   shows "bijective (x[[y]])"
   by (simp add: assms read_injective read_surjective)
 
 text \<open>Theorem 1.7\<close>
 
 lemma read_point:
   assumes "point p"
     and "mapping x"
   shows "point (x[[p]])"
   using assms comp_associative read_injective read_surjective by auto
 
 text \<open>Theorem 1.8\<close>
 
 lemma update_postcondition:
   assumes "point x" "point y"
   shows "x \<sqinter> p = x * y\<^sup>T \<longleftrightarrow> p[[x]] = y"
   apply (rule iffI)
   subgoal by (metis assms comp_associative conv_dist_comp conv_involutive covector_inf_comp_3 equivalence_top_closed vector_covector)
   subgoal
     apply (rule order.antisym)
     subgoal by (metis assms conv_dist_comp conv_involutive inf.boundedI inf.cobounded1 vector_covector vector_restrict_comp_conv)
     subgoal by (smt assms comp_associative conv_dist_comp conv_involutive covector_restrict_comp_conv dense_conv_closed equivalence_top_closed inf.boundedI shunt_mapping vector_covector preorder_idempotent)
     done
   done
 
 text \<open>Back and von Wright's array independence requirements \cite{BackWright1998}, 
   later also lens laws \cite{FosterGreenwaldMoorePierceSchmitt2007}\<close>
 
+text \<open>Theorem 2.1\<close>
+
 lemma put_get:
   assumes "vector y" "surjective y" "vector z"
   shows "(x[y\<longmapsto>z])[[y]] = z"
 proof -
   have "(x[y\<longmapsto>z])[[y]] = (y\<^sup>T \<sqinter> z) * y \<squnion> (-y\<^sup>T \<sqinter> x\<^sup>T) * y"
     by (simp add: conv_complement conv_dist_inf conv_dist_sup mult_right_dist_sup)
   also have "... = z * y"
   proof -
     have "(-y\<^sup>T \<sqinter> x\<^sup>T) * y = bot"
       by (metis assms(1) covector_inf_comp_3 inf_commute conv_complement mult_right_zero p_inf vector_complement_closed)
     thus ?thesis
       by (simp add: assms covector_inf_comp_3 inf_commute)
   qed
   also have "... = z"
     by (metis assms(2,3) mult_assoc)
   finally show ?thesis
     .
 qed
 
+text \<open>Theorem 2.3\<close>
+
 lemma put_put:
   "(x[y\<longmapsto>z])[y\<longmapsto>w] = x[y\<longmapsto>w]"
   by (metis inf_absorb2 inf_commute inf_le1 inf_sup_distrib1 maddux_3_13 sup_inf_absorb)
 
+text \<open>Theorem 2.5\<close>
+
 lemma get_put:
   assumes "point y"
   shows "x[y\<longmapsto>x[[y]]] = x"
 proof -
   have "x[y\<longmapsto>x[[y]]] = (y \<sqinter> y\<^sup>T * x) \<squnion> (-y \<sqinter> x)"
     by (simp add: conv_dist_comp)
   also have "... = (y \<sqinter> x) \<squnion> (-y \<sqinter> x)"
   proof -
     have "y \<sqinter> y\<^sup>T * x = y \<sqinter> x"
     proof (rule order.antisym)
       have "y \<sqinter> y\<^sup>T * x = (y \<sqinter> y\<^sup>T) * x"
         by (simp add: assms vector_inf_comp)
       also have "(y \<sqinter> y\<^sup>T) * x = y * y\<^sup>T * x"
         by (simp add: assms vector_covector)
       also have "... \<le> x"
         using assms comp_isotone by fastforce
       finally show "y \<sqinter> y\<^sup>T * x \<le> y \<sqinter> x"
         by simp
       have "y \<sqinter> x \<le> y\<^sup>T * x"
         by (simp add: assms vector_restrict_comp_conv)
       thus "y \<sqinter> x \<le> y \<sqinter> y\<^sup>T * x"
         by simp
     qed
     thus ?thesis
       by simp
   qed
   also have "... = x"
   proof -
     have "regular y"
       using assms bijective_regular by blast
     thus ?thesis
       by (metis inf.sup_monoid.add_commute maddux_3_11_pp)
   qed
   finally show ?thesis
     .
 qed
 
 lemma update_inf:
   "u \<le> y \<Longrightarrow> (x[y\<longmapsto>z]) \<sqinter> u = z\<^sup>T \<sqinter> u"
   by (smt comp_inf.mult_right_dist_sup comp_inf.semiring.mult_zero_right inf.left_commute inf.sup_monoid.add_assoc inf_absorb2 p_inf sup_bot_right inf.sup_monoid.add_commute)
 
 lemma update_inf_same:
   "(x[y\<longmapsto>z]) \<sqinter> y = z\<^sup>T \<sqinter> y"
   by (simp add: update_inf)
 
 lemma update_inf_different:
   "u \<le> -y \<Longrightarrow> (x[y\<longmapsto>z]) \<sqinter> u = x \<sqinter> u"
   by (smt inf.right_idem inf.sup_monoid.add_commute inf.sup_relative_same_increasing inf_import_p maddux_3_13 sup.cobounded2 update_inf_same)
 
 end
 
 section \<open>Relation-Algebraic Semantics of Disjoint-Set Forests\<close>
 
 text \<open>
 A disjoint-set forest represents a partition of a set into equivalence classes.
 We take the represented equivalence relation as the semantics of a forest.
 It is obtained by operation \<open>fc\<close> below.
 Additionally, operation \<open>wcc\<close> giving the weakly connected components of a graph will be used for the semantics of the union of two disjoint sets.
 Finally, operation \<open>root\<close> yields the root of a component tree, that is, the representative of a set containing a given element.
 This section defines these operations and derives their properties.
 \<close>
 
 context stone_kleene_relation_algebra
 begin
 
-text \<open>Theorem 4.2\<close>
+text \<open>Theorem 5.2\<close>
 
 lemma omit_redundant_points:
   assumes "point p"
   shows "p \<sqinter> x\<^sup>\<star> = (p \<sqinter> 1) \<squnion> (p \<sqinter> x) * (-p \<sqinter> x)\<^sup>\<star>"
 proof (rule order.antisym)
   let ?p = "p \<sqinter> 1"
   have "?p * x * (-p \<sqinter> x)\<^sup>\<star> * ?p \<le> ?p * top * ?p"
     by (metis comp_associative mult_left_isotone mult_right_isotone top.extremum)
   also have "... \<le> ?p"
     by (simp add: assms injective_codomain vector_inf_one_comp)
   finally have "?p * x * (-p \<sqinter> x)\<^sup>\<star> * ?p * x \<le> ?p * x"
     using mult_left_isotone by blast
   hence "?p * x * (-p \<sqinter> x)\<^sup>\<star> * (p \<sqinter> x) \<le> ?p * x"
     by (simp add: assms comp_associative vector_inf_one_comp)
   also have 1: "... \<le> ?p * x * (-p \<sqinter> x)\<^sup>\<star>"
     using mult_right_isotone star.circ_reflexive by fastforce
   finally have "?p * x * (-p \<sqinter> x)\<^sup>\<star> * (p \<sqinter> x) \<squnion> ?p * x * (-p \<sqinter> x)\<^sup>\<star> * (-p \<sqinter> x) \<le> ?p * x * (-p \<sqinter> x)\<^sup>\<star>"
     by (simp add: mult_right_isotone star.circ_plus_same star.left_plus_below_circ mult_assoc)
   hence "?p * x * (-p \<sqinter> x)\<^sup>\<star> * ((p \<squnion> -p) \<sqinter> x) \<le> ?p * x * (-p \<sqinter> x)\<^sup>\<star>"
     by (simp add: comp_inf.mult_right_dist_sup mult_left_dist_sup)
   hence "?p * x * (-p \<sqinter> x)\<^sup>\<star> * x \<le> ?p * x * (-p \<sqinter> x)\<^sup>\<star>"
     by (metis assms bijective_regular inf.absorb2 inf.cobounded1 inf.sup_monoid.add_commute shunting_p)
   hence "?p * x * (-p \<sqinter> x)\<^sup>\<star> * x \<squnion> ?p * x \<le> ?p * x * (-p \<sqinter> x)\<^sup>\<star>"
     using 1 by simp
   hence "?p * (1 \<squnion> x * (-p \<sqinter> x)\<^sup>\<star>) * x \<le> ?p * x * (-p \<sqinter> x)\<^sup>\<star>"
     by (simp add: comp_associative mult_left_dist_sup mult_right_dist_sup)
   also have "... \<le> ?p * (1 \<squnion> x * (-p \<sqinter> x)\<^sup>\<star>)"
     by (simp add: comp_associative mult_right_isotone)
   finally have "?p * x\<^sup>\<star> \<le> ?p * (1 \<squnion> x * (-p \<sqinter> x)\<^sup>\<star>)"
     using star_right_induct by (meson dual_order.trans le_supI mult_left_sub_dist_sup_left mult_sub_right_one)
   also have "... = ?p \<squnion> ?p * x * (-p \<sqinter> x)\<^sup>\<star>"
     by (simp add: comp_associative semiring.distrib_left)
   finally show "p \<sqinter> x\<^sup>\<star> \<le> ?p \<squnion> (p \<sqinter> x) * (-p \<sqinter> x)\<^sup>\<star>"
     by (simp add: assms vector_inf_one_comp)
   show "?p \<squnion> (p \<sqinter> x) * (-p \<sqinter> x)\<^sup>\<star> \<le> p \<sqinter> x\<^sup>\<star>"
     by (metis assms comp_isotone inf.boundedI inf.cobounded1 inf.coboundedI2 inf.sup_monoid.add_commute le_supI star.circ_increasing star.circ_transitive_equal star_isotone star_left_unfold_equal sup.cobounded1 vector_export_comp)
 qed
 
 text \<open>Weakly connected components\<close>
 
 abbreviation "wcc x \<equiv> (x \<squnion> x\<^sup>T)\<^sup>\<star>"
 
-text \<open>Theorem 5.1\<close>
+text \<open>Theorem 7.1\<close>
 
 lemma wcc_equivalence:
   "equivalence (wcc x)"
   apply (intro conjI)
   subgoal by (simp add: star.circ_reflexive)
   subgoal by (simp add: star.circ_transitive_equal)
   subgoal by (simp add: conv_dist_sup conv_star_commute sup_commute)
   done
 
-text \<open>Theorem 5.2\<close>
+text \<open>Theorem 7.2\<close>
 
 lemma wcc_increasing:
   "x \<le> wcc x"
   by (simp add: star.circ_sub_dist_1)
 
 lemma wcc_isotone:
   "x \<le> y \<Longrightarrow> wcc x \<le> wcc y"
   using conv_isotone star_isotone sup_mono by blast
 
 lemma wcc_idempotent:
   "wcc (wcc x) = wcc x"
   using star_involutive wcc_equivalence by auto
 
-text \<open>Theorem 5.3\<close>
+text \<open>Theorem 7.3\<close>
 
 lemma wcc_below_wcc:
   "x \<le> wcc y \<Longrightarrow> wcc x \<le> wcc y"
   using wcc_idempotent wcc_isotone by fastforce
 
-text \<open>Theorem 5.4\<close>
+text \<open>Theorem 7.4\<close>
 
 lemma wcc_bot:
   "wcc bot = 1"
   by (simp add: star.circ_zero)
 
 lemma wcc_one:
   "wcc 1 = 1"
   by (simp add: star_one)
 
-text \<open>Theorem 5.5\<close>
+text \<open>Theorem 7.5\<close>
 
 lemma wcc_top:
   "wcc top = top"
   by (simp add: star.circ_top)
 
-text \<open>Theorem 5.6\<close>
+text \<open>Theorem 7.6\<close>
 
 lemma wcc_with_loops:
   "wcc x = wcc (x \<squnion> 1)"
   by (metis conv_dist_sup star_decompose_1 star_sup_one sup_commute symmetric_one_closed)
 
 lemma wcc_without_loops:
   "wcc x = wcc (x \<sqinter> -1)"
   by (metis conv_star_commute star_sum reachable_without_loops)
 
 lemma forest_components_wcc:
   "injective x \<Longrightarrow> wcc x = forest_components x"
   by (simp add: cancel_separate_1)
 
+text \<open>Theorem 7.8\<close>
+
+lemma wcc_sup_wcc:
+  "wcc (x \<squnion> y) = wcc (x \<squnion> wcc y)"
+  by (smt (verit, del_insts) le_sup_iff order.antisym sup_right_divisibility wcc_below_wcc wcc_increasing wcc_isotone)
+
 text \<open>Components of a forest, which is represented using edges directed towards the roots\<close>
 
 abbreviation "fc x \<equiv> x\<^sup>\<star> * x\<^sup>T\<^sup>\<star>"
 
-text \<open>Theorem 2.1\<close>
+text \<open>Theorem 3.1\<close>
 
 lemma fc_equivalence:
   "univalent x \<Longrightarrow> equivalence (fc x)"
   apply (intro conjI)
   subgoal by (simp add: reflexive_mult_closed star.circ_reflexive)
   subgoal by (metis cancel_separate_1 order.eq_iff star.circ_transitive_equal)
   subgoal by (simp add: conv_dist_comp conv_star_commute)
   done
 
-text \<open>Theorem 2.2\<close>
+text \<open>Theorem 3.2\<close>
 
 lemma fc_increasing:
   "x \<le> fc x"
   by (metis le_supE mult_left_isotone star.circ_back_loop_fixpoint star.circ_increasing)
 
-text \<open>Theorem 2.3\<close>
+text \<open>Theorem 3.3\<close>
 
 lemma fc_isotone:
   "x \<le> y \<Longrightarrow> fc x \<le> fc y"
   by (simp add: comp_isotone conv_isotone star_isotone)
 
-text \<open>Theorem 2.4\<close>
+text \<open>Theorem 3.4\<close>
 
 lemma fc_idempotent:
   "univalent x \<Longrightarrow> fc (fc x) = fc x"
   by (metis fc_equivalence cancel_separate_1 star.circ_transitive_equal star_involutive)
 
-text \<open>Theorem 2.5\<close>
+text \<open>Theorem 3.5\<close>
 
 lemma fc_star:
   "univalent x \<Longrightarrow> (fc x)\<^sup>\<star> = fc x"
   using fc_equivalence fc_idempotent star.circ_transitive_equal by simp
 
 lemma fc_plus:
   "univalent x \<Longrightarrow> (fc x)\<^sup>+ = fc x"
   by (metis fc_star star.circ_decompose_9)
 
-text \<open>Theorem 2.6\<close>
+text \<open>Theorem 3.6\<close>
 
 lemma fc_bot:
   "fc bot = 1"
   by (simp add: star.circ_zero)
 
 lemma fc_one:
   "fc 1 = 1"
   by (simp add: star_one)
 
-text \<open>Theorem 2.7\<close>
+text \<open>Theorem 3.7\<close>
 
 lemma fc_top:
   "fc top = top"
   by (simp add: star.circ_top)
 
-text \<open>Theorem 5.7\<close>
+text \<open>Theorem 7.7\<close>
 
 lemma fc_wcc:
   "univalent x \<Longrightarrow> wcc x = fc x"
   by (simp add: fc_star star_decompose_1)
 
 lemma fc_via_root:
   assumes "total (p\<^sup>\<star> * (p \<sqinter> 1))"
   shows "fc p = p\<^sup>\<star> * (p \<sqinter> 1) * p\<^sup>T\<^sup>\<star>"
 proof (rule order.antisym)
   have "1 \<le> p\<^sup>\<star> * (p \<sqinter> 1) * p\<^sup>T\<^sup>\<star>"
     by (smt assms comp_associative conv_dist_comp conv_star_commute coreflexive_idempotent coreflexive_symmetric inf.cobounded2 total_var)
   hence "fc p \<le> p\<^sup>\<star> * p\<^sup>\<star> * (p \<sqinter> 1) * p\<^sup>T\<^sup>\<star> * p\<^sup>T\<^sup>\<star>"
     by (metis comp_right_one mult_left_isotone mult_right_isotone mult_assoc)
   thus "fc p \<le> p\<^sup>\<star> * (p \<sqinter> 1) * p\<^sup>T\<^sup>\<star>"
     by (simp add: star.circ_transitive_equal mult_assoc)
   show "p\<^sup>\<star> * (p \<sqinter> 1) * p\<^sup>T\<^sup>\<star> \<le> fc p"
     by (metis comp_isotone inf.cobounded2 mult_1_right order.refl)
 qed
 
-text \<open>Theorem 4.1\<close>
+text \<open>Theorem 5.1\<close>
 
 lemma update_acyclic_1:
   assumes "acyclic (p \<sqinter> -1)"
     and "point y"
     and "vector w"
     and "w \<le> p\<^sup>\<star> * y"
   shows "acyclic ((p[w\<longmapsto>y]) \<sqinter> -1)"
 proof -
   let ?p = "p[w\<longmapsto>y]"
   have "w * y\<^sup>T \<le> p\<^sup>\<star>"
     using assms(2,4) shunt_bijective by blast
   hence "w * y\<^sup>T \<le> (p \<sqinter> -1)\<^sup>\<star>"
     using reachable_without_loops by auto
   hence "w * y\<^sup>T \<sqinter> -1 \<le> (p \<sqinter> -1)\<^sup>\<star> \<sqinter> -1"
     by (simp add: inf.coboundedI2 inf.sup_monoid.add_commute)
   also have "... \<le> (p \<sqinter> -1)\<^sup>+"
     by (simp add: star_plus_without_loops)
   finally have 1: "w \<sqinter> y\<^sup>T \<sqinter> -1 \<le> (p \<sqinter> -1)\<^sup>+"
     using assms(2,3) vector_covector by auto
   have "?p \<sqinter> -1 = (w \<sqinter> y\<^sup>T \<sqinter> -1) \<squnion> (-w \<sqinter> p \<sqinter> -1)"
     by (simp add: inf_sup_distrib2)
   also have "... \<le> (p \<sqinter> -1)\<^sup>+ \<squnion> (-w \<sqinter> p \<sqinter> -1)"
     using 1 sup_left_isotone by blast
   also have "... \<le> (p \<sqinter> -1)\<^sup>+ \<squnion> (p \<sqinter> -1)"
     using comp_inf.mult_semi_associative sup_right_isotone by auto
   also have "... = (p \<sqinter> -1)\<^sup>+"
     by (metis star.circ_back_loop_fixpoint sup.right_idem)
   finally have "(?p \<sqinter> -1)\<^sup>+ \<le> (p \<sqinter> -1)\<^sup>+"
     by (metis comp_associative comp_isotone star.circ_transitive_equal star.left_plus_circ star_isotone)
   also have "... \<le> -1"
     using assms(1) by blast
   finally show ?thesis
     by simp
 qed
 
 lemma update_acyclic_2:
   assumes "acyclic (p \<sqinter> -1)"
     and "point y"
     and "point x"
     and "y \<le> p\<^sup>T\<^sup>\<star> * x"
     and "univalent p"
     and "p\<^sup>T * y \<le> y"
   shows "acyclic ((p[p\<^sup>T\<^sup>\<star>*x\<longmapsto>y]) \<sqinter> -1)"
 proof -
   have "p\<^sup>T * p\<^sup>\<star> * y = p\<^sup>T * p * p\<^sup>\<star> * y \<squnion> p\<^sup>T * y"
     by (metis comp_associative mult_left_dist_sup star.circ_loop_fixpoint)
   also have "... \<le> p\<^sup>\<star> * y"
     by (metis assms(5,6) comp_right_one le_supI le_supI2 mult_left_isotone star.circ_loop_fixpoint star.circ_transitive_equal)
   finally have "p\<^sup>T\<^sup>\<star> * x \<le> p\<^sup>\<star> * y"
     by (simp add: assms(2-4) bijective_reverse conv_star_commute comp_associative star_left_induct)
   thus ?thesis
     by (simp add: assms(1-3) vector_mult_closed update_acyclic_1)
 qed
 
 lemma update_acyclic_3:
   assumes "acyclic (p \<sqinter> -1)"
     and "point y"
     and "point w"
     and "y \<le> p\<^sup>T\<^sup>\<star> * w"
   shows "acyclic ((p[w\<longmapsto>y]) \<sqinter> -1)"
   by (simp add: assms bijective_reverse conv_star_commute update_acyclic_1)
 
 lemma rectangle_star_rectangle:
   "rectangle a \<Longrightarrow> a * x\<^sup>\<star> * a \<le> a"
   by (metis mult_left_isotone mult_right_isotone top.extremum)
 
 lemma arc_star_arc:
   "arc a \<Longrightarrow> a * x\<^sup>\<star> * a \<le> a"
   using arc_top_arc rectangle_star_rectangle by blast
 
 lemma star_rectangle_decompose:
   assumes "rectangle a"
   shows "(a \<squnion> x)\<^sup>\<star> = x\<^sup>\<star> \<squnion> x\<^sup>\<star> * a * x\<^sup>\<star>"
 proof (rule order.antisym)
   have 1: "1 \<le> x\<^sup>\<star> \<squnion> x\<^sup>\<star> * a * x\<^sup>\<star>"
     by (simp add: star.circ_reflexive sup.coboundedI1)
   have "(a \<squnion> x) * (x\<^sup>\<star> \<squnion> x\<^sup>\<star> * a * x\<^sup>\<star>) = a * x\<^sup>\<star> \<squnion> a * x\<^sup>\<star> * a * x\<^sup>\<star> \<squnion> x\<^sup>+ \<squnion> x\<^sup>+ * a * x\<^sup>\<star>"
     by (metis comp_associative semiring.combine_common_factor semiring.distrib_left sup_commute)
   also have "... = a * x\<^sup>\<star> \<squnion> x\<^sup>+ \<squnion> x\<^sup>+ * a * x\<^sup>\<star>"
     using assms rectangle_star_rectangle by (simp add: mult_left_isotone sup_absorb1)
   also have "... = x\<^sup>+ \<squnion> x\<^sup>\<star> * a * x\<^sup>\<star>"
     by (metis comp_associative star.circ_loop_fixpoint sup_assoc sup_commute)
   also have "... \<le> x\<^sup>\<star> \<squnion> x\<^sup>\<star> * a * x\<^sup>\<star>"
     using star.left_plus_below_circ sup_left_isotone by auto
   finally show "(a \<squnion> x)\<^sup>\<star> \<le> x\<^sup>\<star> \<squnion> x\<^sup>\<star> * a * x\<^sup>\<star>"
     using 1 by (metis comp_right_one le_supI star_left_induct)
 next
   show "x\<^sup>\<star> \<squnion> x\<^sup>\<star> * a * x\<^sup>\<star> \<le> (a \<squnion> x)\<^sup>\<star>"
     by (metis comp_isotone le_supE le_supI star.circ_increasing star.circ_transitive_equal star_isotone sup_ge2)
 qed
 
 lemma star_arc_decompose:
   "arc a \<Longrightarrow> (a \<squnion> x)\<^sup>\<star> = x\<^sup>\<star> \<squnion> x\<^sup>\<star> * a * x\<^sup>\<star>"
   using arc_top_arc star_rectangle_decompose by blast
 
 lemma plus_rectangle_decompose:
   assumes "rectangle a"
   shows "(a \<squnion> x)\<^sup>+ = x\<^sup>+ \<squnion> x\<^sup>\<star> * a * x\<^sup>\<star>"
 proof -
   have "(a \<squnion> x)\<^sup>+ = (a \<squnion> x) * (x\<^sup>\<star> \<squnion> x\<^sup>\<star> * a * x\<^sup>\<star>)"
     by (simp add: assms star_rectangle_decompose)
   also have "... = a * x\<^sup>\<star> \<squnion> a * x\<^sup>\<star> * a * x\<^sup>\<star> \<squnion> x\<^sup>+ \<squnion> x\<^sup>+ * a * x\<^sup>\<star>"
     by (metis comp_associative semiring.combine_common_factor semiring.distrib_left sup_commute)
   also have "... = a * x\<^sup>\<star> \<squnion> x\<^sup>+ \<squnion> x\<^sup>+ * a * x\<^sup>\<star>"
     using assms rectangle_star_rectangle by (simp add: mult_left_isotone sup_absorb1)
   also have "... = x\<^sup>+ \<squnion> x\<^sup>\<star> * a * x\<^sup>\<star>"
     by (metis comp_associative star.circ_loop_fixpoint sup_assoc sup_commute)
   finally show ?thesis
     by simp
 qed
 
-text \<open>Theorem 6.1\<close>
+text \<open>Theorem 8.1\<close>
 
 lemma plus_arc_decompose:
   "arc a \<Longrightarrow> (a \<squnion> x)\<^sup>+ = x\<^sup>+ \<squnion> x\<^sup>\<star> * a * x\<^sup>\<star>"
   using arc_top_arc plus_rectangle_decompose by blast
 
-text \<open>Theorem 6.2\<close>
+text \<open>Theorem 8.2\<close>
 
 lemma update_acyclic_4:
   assumes "acyclic (p \<sqinter> -1)"
     and "point y"
     and "point w"
     and "y \<sqinter> p\<^sup>\<star> * w = bot"
   shows "acyclic ((p[w\<longmapsto>y]) \<sqinter> -1)"
 proof -
   let ?p = "p[w\<longmapsto>y]"
   have "y\<^sup>T * p\<^sup>\<star> * w \<le> -1"
     using assms(4) comp_associative pseudo_complement schroeder_3_p by auto
   hence 1: "p\<^sup>\<star> * w * y\<^sup>T * p\<^sup>\<star> \<le> -1"
     by (metis comp_associative comp_commute_below_diversity star.circ_transitive_equal)
   have "?p \<sqinter> -1 \<le> (w \<sqinter> y\<^sup>T) \<squnion> (p \<sqinter> -1)"
     by (metis comp_inf.mult_right_dist_sup dual_order.trans inf.cobounded1 inf.coboundedI2 inf.sup_monoid.add_assoc le_supI sup.cobounded1 sup_ge2)
   also have "... = w * y\<^sup>T \<squnion> (p \<sqinter> -1)"
     using assms(2,3) by (simp add: vector_covector)
   finally have "(?p \<sqinter> -1)\<^sup>+ \<le> (w * y\<^sup>T \<squnion> (p \<sqinter> -1))\<^sup>+"
     by (simp add: comp_isotone star_isotone)
   also have "... = (p \<sqinter> -1)\<^sup>+ \<squnion> (p \<sqinter> -1)\<^sup>\<star> * w * y\<^sup>T * (p \<sqinter> -1)\<^sup>\<star>"
     using assms(2,3) plus_arc_decompose points_arc by (simp add: comp_associative)
   also have "... \<le> (p \<sqinter> -1)\<^sup>+ \<squnion> p\<^sup>\<star> * w * y\<^sup>T * p\<^sup>\<star>"
     using reachable_without_loops by auto
   also have "... \<le> -1"
     using 1 assms(1) by simp
   finally show ?thesis
     by simp
 qed
 
-text \<open>Theorem 6.3\<close>
+text \<open>Theorem 8.3\<close>
 
 lemma update_acyclic_5:
   assumes "acyclic (p \<sqinter> -1)"
     and "point w"
   shows "acyclic ((p[w\<longmapsto>w]) \<sqinter> -1)"
 proof -
   let ?p = "p[w\<longmapsto>w]"
   have "?p \<sqinter> -1 \<le> (w \<sqinter> w\<^sup>T \<sqinter> -1) \<squnion> (p \<sqinter> -1)"
     by (metis comp_inf.mult_right_dist_sup inf.cobounded2 inf.sup_monoid.add_assoc sup_right_isotone)
   also have "... = p \<sqinter> -1"
     using assms(2) by (metis comp_inf.covector_complement_closed equivalence_top_closed inf_top.right_neutral maddux_3_13 pseudo_complement regular_closed_top regular_one_closed vector_covector vector_top_closed)
   finally show ?thesis
     using assms(1) acyclic_down_closed by blast
 qed
 
 text \<open>Root of the tree containing point $x$ in the disjoint-set forest $p$\<close>
 
 abbreviation "root p x \<equiv> p\<^sup>T\<^sup>\<star> * x \<sqinter> (p \<sqinter> 1) * top"
 
-text \<open>Theorem 3.1\<close>
+text \<open>Theorem 4.1\<close>
 
 lemma root_var:
   "root p x = (p \<sqinter> 1) * p\<^sup>T\<^sup>\<star> * x"
   by (simp add: coreflexive_comp_top_inf inf_commute mult_assoc)
 
-text \<open>Theorem 3.2\<close>
+text \<open>Theorem 4.2\<close>
 
 lemma root_successor_loop:
   "univalent p \<Longrightarrow> root p x = p[[root p x]]"
   by (metis root_var injective_codomain comp_associative conv_dist_inf coreflexive_symmetric equivalence_one_closed inf.cobounded2 univalent_conv_injective)
 
 lemma root_transitive_successor_loop:
   "univalent p \<Longrightarrow> root p x = p\<^sup>T\<^sup>\<star> * (root p x)"
   by (metis mult_1_right star_one star_simulation_right_equal root_successor_loop)
 
 text \<open>The root of a tree of a node belongs to the same component as the node.\<close>
 
 lemma root_same_component:
   "injective x \<Longrightarrow> root p x * x\<^sup>T \<le> fc p"
   by (metis comp_associative coreflexive_comp_top_inf eq_refl inf.sup_left_divisibility inf.sup_monoid.add_commute mult_isotone star.circ_circ_mult star.circ_right_top star.circ_transitive_equal star_one star_outer_increasing test_preserves_equation top_greatest)
 
 lemma root_vector:
   "vector x \<Longrightarrow> vector (root p x)"
   by (simp add: vector_mult_closed root_var)
 
 lemma root_vector_inf:
   "vector x \<Longrightarrow> root p x * x\<^sup>T = root p x \<sqinter> x\<^sup>T"
   by (simp add: vector_covector root_vector)
 
 lemma root_same_component_vector:
   "injective x \<Longrightarrow> vector x \<Longrightarrow> root p x \<sqinter> x\<^sup>T \<le> fc p"
   using root_same_component root_vector_inf by fastforce
 
 lemma univalent_root_successors:
   assumes "univalent p"
   shows "(p \<sqinter> 1) * p\<^sup>\<star> = p \<sqinter> 1"
 proof (rule order.antisym)
   have "(p \<sqinter> 1) * p \<le> p \<sqinter> 1"
     by (smt assms(1) 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)
   thus "(p \<sqinter> 1) * p\<^sup>\<star> \<le> p \<sqinter> 1"
     using star_right_induct_mult by blast
   show "p \<sqinter> 1 \<le> (p \<sqinter> 1) * p\<^sup>\<star>"
     by (metis coreflexive_idempotent inf_le1 inf_le2 mult_right_isotone order_trans star.circ_increasing)
 qed
 
 lemma same_component_same_root_sub:
   assumes "univalent p"
     and "bijective y"
     and "x * y\<^sup>T \<le> fc p"
   shows "root p x \<le> root p y"
 proof -
   have "root p x * y\<^sup>T \<le> (p \<sqinter> 1) * p\<^sup>T\<^sup>\<star>"
     by (smt assms(1,3) mult_isotone mult_assoc root_var fc_plus fc_star order.eq_iff univalent_root_successors)
   thus ?thesis
     by (simp add: assms(2) shunt_bijective root_var)
 qed
 
 lemma same_component_same_root:
   assumes "univalent p"
     and "bijective x"
     and "bijective y"
     and "x * y\<^sup>T \<le> fc p"
   shows "root p x = root p y"
 proof (rule order.antisym)
   show "root p x \<le> root p y"
     using assms(1,3,4) same_component_same_root_sub by blast
   have "y * x\<^sup>T \<le> fc p"
     using assms(1,4) fc_equivalence conv_dist_comp conv_isotone by fastforce
   thus "root p y \<le> root p x"
     using assms(1,2) same_component_same_root_sub by blast
 qed
 
 lemma same_roots_sub:
   assumes "univalent q"
     and "p \<sqinter> 1 \<le> q \<sqinter> 1"
     and "fc p \<le> fc q"
   shows "p\<^sup>\<star> * (p \<sqinter> 1) \<le> q\<^sup>\<star> * (q \<sqinter> 1)"
 proof -
   have "p\<^sup>\<star> * (p \<sqinter> 1) \<le> p\<^sup>\<star> * (q \<sqinter> 1)"
     using assms(2) mult_right_isotone by auto
   also have "... \<le> fc p * (q \<sqinter> 1)"
     using mult_left_isotone mult_right_isotone star.circ_reflexive by fastforce
   also have "... \<le> fc q * (q \<sqinter> 1)"
     by (simp add: assms(3) mult_left_isotone)
   also have "... = q\<^sup>\<star> * (q \<sqinter> 1)"
     by (metis assms(1) conv_dist_comp conv_dist_inf conv_star_commute inf_commute one_inf_conv symmetric_one_closed mult_assoc univalent_root_successors)
   finally show ?thesis
     .
 qed
 
 lemma same_roots:
   assumes "univalent p"
     and "univalent q"
     and "p \<sqinter> 1 = q \<sqinter> 1"
     and "fc p = fc q"
   shows "p\<^sup>\<star> * (p \<sqinter> 1) = q\<^sup>\<star> * (q \<sqinter> 1)"
   by (smt assms conv_dist_comp conv_dist_inf conv_involutive conv_star_commute inf_commute one_inf_conv symmetric_one_closed root_var univalent_root_successors)
 
 lemma same_root:
   assumes "univalent p"
     and "univalent q"
     and "p \<sqinter> 1 = q \<sqinter> 1"
     and "fc p = fc q"
   shows "root p x = root q x"
   by (metis assms mult_assoc root_var univalent_root_successors)
 
 lemma loop_root:
   assumes "injective x"
     and "x = p[[x]]"
   shows "x = root p x"
 proof (rule order.antisym)
   have "x \<le> p * x"
     by (metis assms comp_associative comp_right_one conv_order equivalence_one_closed ex231c inf.orderE inf.sup_monoid.add_commute mult_left_isotone mult_right_isotone one_inf_conv)
   hence "x = (p \<sqinter> 1) * x"
     by (simp add: assms(1) inf_absorb2 injective_comp_right_dist_inf)
   thus "x \<le> root p x"
     by (metis assms(2) coreflexive_comp_top_inf inf.boundedI inf.cobounded1 inf.cobounded2 mult_isotone star.circ_increasing)
 next
   show "root p x \<le> x"
     using assms(2) le_infI1 star_left_induct_mult by auto
 qed
 
 lemma one_loop:
   assumes "acyclic (p \<sqinter> -1)"
     and "univalent p"
   shows "(p \<sqinter> 1) * (p\<^sup>T \<sqinter> -1)\<^sup>+ * (p \<sqinter> 1) = bot"
 proof -
   have "p\<^sup>T\<^sup>+ \<sqinter> (p \<sqinter> 1) * top * (p \<sqinter> 1) = (p \<sqinter> 1) * p\<^sup>T\<^sup>+ * (p \<sqinter> 1)"
     by (simp add: test_comp_test_top)
   also have "... \<le> p\<^sup>T\<^sup>\<star> * (p \<sqinter> 1)"
     by (simp add: inf.coboundedI2 mult_left_isotone star.circ_mult_upper_bound star.circ_reflexive star.left_plus_below_circ)
   also have "... = p \<sqinter> 1"
     by (metis assms(2) conv_dist_comp conv_dist_inf conv_star_commute inf_commute one_inf_conv symmetric_one_closed univalent_root_successors)
   also have "... \<le> 1"
     by simp
   finally have "(p \<sqinter> 1) * top * (p \<sqinter> 1) \<le> -(p\<^sup>T\<^sup>+ \<sqinter> -1)"
     using p_antitone p_antitone_iff p_shunting_swap by blast
   hence "(p \<sqinter> 1)\<^sup>T * (p\<^sup>T\<^sup>+ \<sqinter> -1) * (p \<sqinter> 1)\<^sup>T \<le> bot"
     using triple_schroeder_p p_top by blast
   hence "(p \<sqinter> 1) * (p\<^sup>T\<^sup>+ \<sqinter> -1) * (p \<sqinter> 1) = bot"
     by (simp add: coreflexive_symmetric le_bot)
   thus ?thesis
     by (smt assms(1) conv_complement conv_dist_comp conv_dist_inf conv_star_commute inf_absorb1 star.circ_plus_same symmetric_one_closed reachable_without_loops star_plus_without_loops)
 qed
 
 lemma root_root:
   "root p x = root p (root p x)"
   by (smt comp_associative comp_inf.mult_right_sub_dist_sup_right dual_order.eq_iff inf.cobounded1 inf.cobounded2 inf.orderE mult_right_isotone star.circ_loop_fixpoint star.circ_transitive_equal root_var)
 
 lemma loop_root_2:
   assumes "acyclic (p \<sqinter> -1)"
     and "univalent p"
     and "injective x"
     and "x \<le> p\<^sup>T\<^sup>+ * x"
   shows "x = root p x"
 proof (rule order.antisym)
   have 1: "x = x \<sqinter> -(-1 * x)"
     by (metis assms(3) comp_injective_below_complement inf.orderE mult_1_left regular_one_closed)
   have "x \<le> (p\<^sup>T \<sqinter> -1)\<^sup>+ * x \<squnion> (p \<sqinter> 1) * x"
     by (metis assms(4) inf_commute mult_right_dist_sup one_inf_conv plus_reachable_without_loops)
   also have "... \<le> -1 * x \<squnion> (p \<sqinter> 1) * x"
     by (metis assms(1) conv_complement conv_dist_inf conv_isotone conv_plus_commute mult_left_isotone semiring.add_right_mono symmetric_one_closed)
   also have "... \<le> -1 * x \<squnion> root p x"
     using comp_isotone inf.coboundedI2 star.circ_reflexive sup_right_isotone by auto
   finally have "x \<le> (-1 * x \<squnion> root p x) \<sqinter> -(-1 * x)"
     using 1 inf.boundedI inf.order_iff by blast
   also have "... \<le> root p x"
     using inf.sup_left_divisibility by auto
   finally show 2: "x \<le> root p x"
     .
   have "root p x = (p \<sqinter> 1) * x \<squnion> (p \<sqinter> 1) * (p\<^sup>T \<sqinter> -1)\<^sup>+ * x"
     by (metis comp_associative mult_left_dist_sup star.circ_loop_fixpoint sup_commute reachable_without_loops root_var)
   also have "... \<le> x \<squnion> (p \<sqinter> 1) * (p\<^sup>T \<sqinter> -1)\<^sup>+ * root p x"
     using 2 by (metis coreflexive_comp_top_inf inf.cobounded2 mult_right_isotone semiring.add_mono)
   also have "... = x"
     by (metis assms(1,2) one_loop root_var mult_assoc semiring.mult_not_zero sup_bot_right)
   finally show "root p x \<le> x"
     .
 qed
 
+lemma path_compression_invariant_simplify:
+  assumes "point w"
+      and "p\<^sup>T\<^sup>+ * w \<le> -w"
+      and "w \<noteq> y"
+    shows "p[[w]] \<noteq> w"
+proof
+  assume "p[[w]] = w"
+  hence "w \<le> p\<^sup>T\<^sup>+ * w"
+    by (metis comp_isotone eq_refl star.circ_mult_increasing)
+  also have "... \<le> -w"
+    by (simp add: assms(2))
+  finally have "w = bot"
+    using inf.orderE by fastforce
+  thus False
+    using assms(1,3) le_bot by force
+qed
+
 end
 
 context stone_relation_algebra_tarski
 begin
 
-text \<open>Theorem 4.3 \<open>distinct_points\<close> has been moved to theory \<open>Relation_Algebras\<close> in entry \<open>Stone_Relation_Algebras\<close>\<close>
+text \<open>Theorem 5.4 \<open>distinct_points\<close> has been moved to theory \<open>Relation_Algebras\<close> in entry \<open>Stone_Relation_Algebras\<close>\<close>
 
 text \<open>Back and von Wright's array independence requirements \cite{BackWright1998}\<close>
 
+text \<open>Theorem 2.2\<close>
+
 lemma put_get_different_vector:
-  assumes "vector y" "vector w" "w \<le> -y"
+  assumes "vector y" "w \<le> -y"
   shows "(x[y\<longmapsto>z])[[w]] = x[[w]]"
 proof -
   have "(x[y\<longmapsto>z])[[w]] = (y\<^sup>T \<sqinter> z) * w \<squnion> (-y\<^sup>T \<sqinter> x\<^sup>T) * w"
     by (simp add: conv_complement conv_dist_inf conv_dist_sup mult_right_dist_sup)
   also have "... = z * (w \<sqinter> y) \<squnion> x\<^sup>T * (w \<sqinter> -y)"
     by (metis assms(1) conv_complement covector_inf_comp_3 inf_commute vector_complement_closed)
   also have "... = z * (w \<sqinter> y) \<squnion> x\<^sup>T * w"
-    by (simp add: assms(3) inf.absorb1)
+    by (simp add: assms(2) inf.absorb1)
   also have "... = z * bot \<squnion> x\<^sup>T * w"
-    by (metis assms(3) comp_inf.semiring.mult_zero_right inf.absorb1 inf.sup_monoid.add_assoc p_inf)
+    by (metis assms(2) comp_inf.semiring.mult_zero_right inf.absorb1 inf.sup_monoid.add_assoc p_inf)
   also have "... = x\<^sup>T * w"
     by simp
   finally show ?thesis
     .
 qed
 
 lemma put_get_different:
   assumes "point y" "point w" "w \<noteq> y"
   shows "(x[y\<longmapsto>z])[[w]] = x[[w]]"
 proof -
   have "w \<sqinter> y = bot"
     using assms distinct_points by simp
   hence "w \<le> -y"
     using pseudo_complement by simp
   thus ?thesis
     by (simp add: assms(1) assms(2) put_get_different_vector)
 qed
 
+text \<open>Theorem 2.4\<close>
+
 lemma put_put_different_vector:
   assumes "vector y" "vector v" "v \<sqinter> y = bot"
   shows "(x[y\<longmapsto>z])[v\<longmapsto>w] = (x[v\<longmapsto>w])[y\<longmapsto>z]"
 proof -
   have "(x[y\<longmapsto>z])[v\<longmapsto>w] = (v \<sqinter> w\<^sup>T) \<squnion> (-v \<sqinter> y \<sqinter> z\<^sup>T) \<squnion> (-v \<sqinter> -y \<sqinter> x)"
     by (simp add: comp_inf.semiring.distrib_left inf_assoc sup_assoc)
   also have "... = (v \<sqinter> w\<^sup>T) \<squnion> (y \<sqinter> z\<^sup>T) \<squnion> (-v \<sqinter> -y \<sqinter> x)"
     by (metis assms(3) inf_commute inf_import_p p_inf selection_closed_id)
   also have "... = (y \<sqinter> z\<^sup>T) \<squnion> (v \<sqinter> w\<^sup>T) \<squnion> (-y \<sqinter> -v \<sqinter> x)"
     by (simp add: inf_commute sup_commute)
   also have "... = (y \<sqinter> z\<^sup>T) \<squnion> (-y \<sqinter> v \<sqinter> w\<^sup>T) \<squnion> (-y \<sqinter> -v \<sqinter> x)"
     using assms distinct_points pseudo_complement inf.absorb2 by simp
   also have "... = (x[v\<longmapsto>w])[y\<longmapsto>z]"
     by (simp add: comp_inf.semiring.distrib_left inf_assoc sup_assoc)
   finally show ?thesis
     .
 qed
 
 lemma put_put_different:
   assumes "point y" "point v" "v \<noteq> y"
   shows "(x[y\<longmapsto>z])[v\<longmapsto>w] = (x[v\<longmapsto>w])[y\<longmapsto>z]"
   using assms distinct_points put_put_different_vector by blast
 
 end
 
 section \<open>Verifying Operations on Disjoint-Set Forests\<close>
 
 text \<open>
 In this section we verify the make-set, find-set and union-sets operations of disjoint-set forests.
 We start by introducing syntax for updating arrays in programs.
 Updating the value at a given array index means updating the whole array.
 \<close>
 
 syntax
   "_rel_update" :: "idt \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'b com" ("(2_[_] :=/ _)" [70, 65, 65] 61)
 
 translations
   "x[y] := z" => "(x := (y \<sqinter> z\<^sup>T) \<squnion> (CONST uminus y \<sqinter> x))"
 
 text \<open>
 The finiteness requirement in the following class is used for proving that the operations terminate.
 \<close>
 
 class finite_regular_p_algebra = p_algebra +
   assumes finite_regular: "finite { x . regular x }"
 
-class stone_kleene_relation_algebra_tarski = stone_kleene_relation_algebra + stone_relation_algebra_tarski
-
 class stone_kleene_relation_algebra_tarski_finite_regular = stone_kleene_relation_algebra_tarski + finite_regular_p_algebra
 begin
 
 subsection \<open>Make-Set\<close>
 
 text \<open>
 We prove two correctness results about make-set.
 The first shows that the forest changes only to the extent of making one node the root of a tree.
 The second result adds that only singleton sets are created.
 \<close>
 
 definition "make_set_postcondition p x p0 \<equiv> x \<sqinter> p = x * x\<^sup>T \<and> -x \<sqinter> p = -x \<sqinter> p0"
 
 theorem make_set:
   "VARS p
   [ point x \<and> p0 = p ]
   p[x] := x
   [ make_set_postcondition p x p0 ]"
   apply vcg_tc_simp
   by (simp add: make_set_postcondition_def inf_sup_distrib1 inf_assoc[THEN sym] vector_covector[THEN sym])
 
 theorem make_set_2:
   "VARS p
   [ point x \<and> p0 = p \<and> p \<le> 1 ]
   p[x] := x
   [ make_set_postcondition p x p0 \<and> p \<le> 1 ]"
 proof vcg_tc
   fix p
   assume 1: "point x \<and> p0 = p \<and> p \<le> 1"
   show "make_set_postcondition (p[x\<longmapsto>x]) x p0 \<and> p[x\<longmapsto>x] \<le> 1"
   proof (rule conjI)
     show "make_set_postcondition (p[x\<longmapsto>x]) x p0"
       using 1 by (simp add: make_set_postcondition_def inf_sup_distrib1 inf_assoc[THEN sym] vector_covector[THEN sym])
     show "p[x\<longmapsto>x] \<le> 1"
       using 1 by (metis coreflexive_sup_closed dual_order.trans inf.cobounded2 vector_covector)
   qed
 qed
 
 text \<open>
 The above total-correctness proof allows us to extract a function, which can be used in other implementations below.
 This is a technique of \cite{Guttmann2018c}.
 \<close>
 
 lemma make_set_exists:
   "point x \<Longrightarrow> \<exists>p' . make_set_postcondition p' x p"
   using tc_extract_function make_set by blast
 
 definition "make_set p x \<equiv> (SOME p' . make_set_postcondition p' x p)"
 
 lemma make_set_function:
   assumes "point x"
     and "p' = make_set p x"
   shows "make_set_postcondition p' x p"
 proof -
   let ?P = "\<lambda>p' . make_set_postcondition p' x p"
   have "?P (SOME z . ?P z)"
     using assms(1) make_set_exists by (meson someI)
   thus ?thesis
     using assms(2) make_set_def by auto
 qed
 
+end
+
 subsection \<open>Find-Set\<close>
 
 text \<open>
 Disjoint-set forests are represented by their parent mapping.
 It is a forest except each root of a component tree points to itself.
 
 We prove that find-set returns the root of the component tree of the given node.
 \<close>
 
+context pd_kleene_allegory
+begin
+
 abbreviation "disjoint_set_forest p \<equiv> mapping p \<and> acyclic (p \<sqinter> -1)"
 
+end
+
+context stone_kleene_relation_algebra_tarski_finite_regular
+begin
+
 definition "find_set_precondition p x \<equiv> disjoint_set_forest p \<and> point x"
 definition "find_set_invariant p x y \<equiv> find_set_precondition p x \<and> point y \<and> y \<le> p\<^sup>T\<^sup>\<star> * x"
 definition "find_set_postcondition p x y \<equiv> point y \<and> y = root p x"
 
 lemma find_set_1:
   "find_set_precondition p x \<Longrightarrow> find_set_invariant p x x"
   apply (unfold find_set_invariant_def)
   using mult_left_isotone star.circ_reflexive find_set_precondition_def by fastforce
 
 lemma find_set_2:
   "find_set_invariant p x y \<and> y \<noteq> p[[y]] \<Longrightarrow> find_set_invariant p x (p[[y]]) \<and> card { z . regular z \<and> z \<le> p\<^sup>T\<^sup>\<star> * (p[[y]]) } < card { z . regular z \<and> z \<le> p\<^sup>T\<^sup>\<star> * y }"
 proof -
   let ?s = "{ z . regular z \<and> z \<le> p\<^sup>T\<^sup>\<star> * y }"
   let ?t = "{ z . regular z \<and> z \<le> p\<^sup>T\<^sup>\<star> * (p[[y]]) }"
   assume 1: "find_set_invariant p x y \<and> y \<noteq> p[[y]]"
   have 2: "point (p[[y]])"
     using 1 read_point find_set_invariant_def find_set_precondition_def by simp
   show "find_set_invariant p x (p[[y]]) \<and> card ?t < card ?s"
   proof (unfold find_set_invariant_def, intro conjI)
     show "find_set_precondition p x"
       using 1 find_set_invariant_def by simp
     show "vector (p[[y]])"
       using 2 by simp
     show "injective (p[[y]])"
       using 2 by simp
     show "surjective (p[[y]])"
       using 2 by simp
     show "p[[y]] \<le> p\<^sup>T\<^sup>\<star> * x"
       using 1 by (metis (hide_lams) find_set_invariant_def comp_associative comp_isotone star.circ_increasing star.circ_transitive_equal)
     show "card ?t < card ?s"
     proof -
       have 3: "(p\<^sup>T \<sqinter> -1) * (p\<^sup>T \<sqinter> -1)\<^sup>+ * y \<le> (p\<^sup>T \<sqinter> -1)\<^sup>+ * y"
         by (simp add: mult_left_isotone mult_right_isotone star.left_plus_below_circ)
       have "p[[y]] = (p\<^sup>T \<sqinter> 1) * y \<squnion> (p\<^sup>T \<sqinter> -1) * y"
         by (metis maddux_3_11_pp mult_right_dist_sup regular_one_closed)
       also have "... \<le> ((p[[y]]) \<sqinter> y) \<squnion> (p\<^sup>T \<sqinter> -1) * y"
         by (metis comp_left_subdist_inf mult_1_left semiring.add_right_mono)
       also have "... = (p\<^sup>T \<sqinter> -1) * y"
         using 1 2 find_set_invariant_def distinct_points by auto
       finally have 4: "(p\<^sup>T \<sqinter> -1)\<^sup>\<star> * (p[[y]]) \<le> (p\<^sup>T \<sqinter> -1)\<^sup>+ * y"
         using 3 by (metis inf.antisym_conv inf.eq_refl inf_le1 mult_left_isotone star_plus mult_assoc)
       hence "p\<^sup>T\<^sup>\<star> * (p[[y]]) \<le> p\<^sup>T\<^sup>\<star> * y"
         by (metis mult_isotone order_refl star.left_plus_below_circ star_plus mult_assoc)
       hence 5: "?t \<subseteq> ?s"
         using order_trans by auto
       have 6: "y \<in> ?s"
         using 1 find_set_invariant_def bijective_regular mult_left_isotone star.circ_reflexive by fastforce
       have 7: "\<not> y \<in> ?t"
       proof
         assume "y \<in> ?t"
         hence "y \<le> (p\<^sup>T \<sqinter> -1)\<^sup>+ * y"
           using 4 by (metis reachable_without_loops mem_Collect_eq order_trans)
         hence "y * y\<^sup>T \<le> (p\<^sup>T \<sqinter> -1)\<^sup>+"
           using 1 find_set_invariant_def shunt_bijective by simp
         also have "... \<le> -1"
           using 1 by (metis (mono_tags, lifting) find_set_invariant_def find_set_precondition_def conv_dist_comp conv_dist_inf conv_isotone conv_star_commute equivalence_one_closed star.circ_plus_same symmetric_complement_closed)
         finally have "y \<le> -y"
           using schroeder_4_p by auto
         thus False
           using 1 by (metis find_set_invariant_def comp_inf.coreflexive_idempotent conv_complement covector_vector_comp inf.absorb1 inf.sup_monoid.add_commute pseudo_complement surjective_conv_total top.extremum vector_top_closed regular_closed_top)
       qed
       show "card ?t < card ?s"
         apply (rule psubset_card_mono)
         subgoal using finite_regular by simp
         subgoal using 5 6 7 by auto
         done
     qed
   qed
 qed
 
 lemma find_set_3:
   "find_set_invariant p x y \<and> y = p[[y]] \<Longrightarrow> find_set_postcondition p x y"
 proof -
   assume 1: "find_set_invariant p x y \<and> y = p[[y]]"
   show "find_set_postcondition p x y"
   proof (unfold find_set_postcondition_def, rule conjI)
     show "point y"
       using 1 find_set_invariant_def by simp
     show "y = root p x"
     proof (rule order.antisym)
       have "y * y\<^sup>T \<le> p"
         using 1 by (metis find_set_invariant_def find_set_precondition_def shunt_bijective shunt_mapping top_right_mult_increasing)
       hence "y * y\<^sup>T \<le> p \<sqinter> 1"
         using 1 find_set_invariant_def le_infI by blast
       hence "y \<le> (p \<sqinter> 1) * top"
         using 1 by (metis find_set_invariant_def order_lesseq_imp shunt_bijective top_right_mult_increasing mult_assoc)
       thus "y \<le> root p x"
         using 1 find_set_invariant_def by simp
     next
       have 2: "x \<le> p\<^sup>\<star> * y"
         using 1 find_set_invariant_def find_set_precondition_def bijective_reverse conv_star_commute by auto
       have "p\<^sup>T * p\<^sup>\<star> * y = p\<^sup>T * p * p\<^sup>\<star> * y \<squnion> (p[[y]])"
         by (metis comp_associative mult_left_dist_sup star.circ_loop_fixpoint)
       also have "... \<le> p\<^sup>\<star> * y \<squnion> y"
         using 1 by (metis find_set_invariant_def find_set_precondition_def comp_isotone mult_left_sub_dist_sup semiring.add_right_mono star.circ_back_loop_fixpoint star.circ_circ_mult star.circ_top star.circ_transitive_equal star_involutive star_one)
       also have "... = p\<^sup>\<star> * y"
         by (metis star.circ_loop_fixpoint sup.left_idem sup_commute)
       finally have 3: "p\<^sup>T\<^sup>\<star> * x \<le> p\<^sup>\<star> * y"
         using 2 by (simp add: comp_associative star_left_induct)
       have "p * y \<sqinter> (p \<sqinter> 1) * top = (p \<sqinter> 1) * p * y"
         using comp_associative coreflexive_comp_top_inf inf_commute by auto
       also have "... \<le> p\<^sup>T * p * y"
         by (metis inf.cobounded2 inf.sup_monoid.add_commute mult_left_isotone one_inf_conv)
       also have "... \<le> y"
         using 1 find_set_invariant_def find_set_precondition_def mult_left_isotone by fastforce
       finally have 4: "p * y \<le> y \<squnion> -((p \<sqinter> 1) * top)"
         using 1 by (metis find_set_invariant_def shunting_p bijective_regular)
       have "p\<^sup>T * (p \<sqinter> 1) \<le> p\<^sup>T \<sqinter> 1"
         using 1 by (metis find_set_invariant_def find_set_precondition_def N_top comp_isotone coreflexive_idempotent inf.cobounded2 inf.sup_monoid.add_commute inf_assoc one_inf_conv shunt_mapping)
       hence "p\<^sup>T * (p \<sqinter> 1) * top \<le> (p \<sqinter> 1) * top"
         using inf_commute mult_isotone one_inf_conv by auto
       hence "p * -((p \<sqinter> 1) * top) \<le> -((p \<sqinter> 1) * top)"
         by (metis comp_associative inf.sup_monoid.add_commute p_antitone p_antitone_iff schroeder_3_p)
       hence "p * y \<squnion> p * -((p \<sqinter> 1) * top) \<le> y \<squnion> -((p \<sqinter> 1) * top)"
         using 4 dual_order.trans le_supI sup_ge2 by blast
       hence "p * (y \<squnion> -((p \<sqinter> 1) * top)) \<le> y \<squnion> -((p \<sqinter> 1) * top)"
         by (simp add: mult_left_dist_sup)
       hence "p\<^sup>\<star> * y \<le> y \<squnion> -((p \<sqinter> 1) * top)"
         by (simp add: star_left_induct)
       hence "p\<^sup>T\<^sup>\<star> * x \<le> y \<squnion> -((p \<sqinter> 1) * top)"
         using 3 dual_order.trans by blast
       thus "root p x \<le> y"
         using 1 by (metis find_set_invariant_def shunting_p bijective_regular)
     qed
   qed
 qed
 
 theorem find_set:
   "VARS y
   [ find_set_precondition p x ]
   y := x;
   WHILE y \<noteq> p[[y]]
     INV { find_set_invariant p x y }
     VAR { card { z . regular z \<and> z \<le> p\<^sup>T\<^sup>\<star> * y } }
      DO y := p[[y]]
      OD
   [ find_set_postcondition p x y ]"
   apply vcg_tc_simp
     apply (fact find_set_1)
    apply (fact find_set_2)
   by (fact find_set_3)
 
 lemma find_set_exists:
   "find_set_precondition p x \<Longrightarrow> \<exists>y . find_set_postcondition p x y"
   using tc_extract_function find_set by blast
 
 text \<open>
 The root of a component tree is a point, that is, represents a singleton set of nodes.
 This could be proved from the definitions using Kleene-relation algebraic calculations.
 But they can be avoided because the property directly follows from the postcondition of the previous correctness proof.
 The corresponding algorithm shows how to obtain the root.
 We therefore have an essentially constructive proof of the following result.
 \<close>
 
-text \<open>Theorem 3.3\<close>
+text \<open>Theorem 4.3\<close>
 
 lemma root_point:
   "disjoint_set_forest p \<Longrightarrow> point x \<Longrightarrow> point (root p x)"
   using find_set_exists find_set_precondition_def find_set_postcondition_def by simp
 
 definition "find_set p x \<equiv> (SOME y . find_set_postcondition p x y)"
 
 lemma find_set_function:
   assumes "find_set_precondition p x"
     and "y = find_set p x"
   shows "find_set_postcondition p x y"
   by (metis assms find_set_def find_set_exists someI)
 
 subsection \<open>Path Compression\<close>
 
 text \<open>
 The path-compression technique is frequently implemented in recursive implementations of find-set 
 modifying the tree on the way out from recursive calls. Here we implement it using a second while-loop, 
 which iterates over the same path to the root and changes edges to point to the root of the component, 
 which is known after the while-loop in find-set completes. We prove that path compression 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 compression.
 \<close>
 
 definition "path_compression_precondition p x y \<equiv> disjoint_set_forest p \<and> point x \<and> point y \<and> y = root p x"
 definition "path_compression_invariant p x y p0 w \<equiv> 
   path_compression_precondition p x y \<and> point w \<and> y \<le> p\<^sup>T\<^sup>\<star> * w \<and> 
   (w \<noteq> x \<longrightarrow> p[[x]] = y \<and> y \<noteq> x \<and> p\<^sup>T\<^sup>+ * w \<le> -x) \<and> p \<sqinter> 1 = p0 \<sqinter> 1 \<and> fc p = fc p0 \<and>
-  root p w = y \<and> (w \<noteq> y \<longrightarrow> p[[w]] \<noteq> w \<and> p\<^sup>T\<^sup>+ * w \<le> -w) \<and> p[[w]] = p0[[w]] \<and> p0[p0\<^sup>T\<^sup>\<star> * x \<sqinter> -(p0\<^sup>T\<^sup>\<star> * w)\<longmapsto>y] = p \<and>
+  root p w = y \<and> (w \<noteq> y \<longrightarrow> p\<^sup>T\<^sup>+ * w \<le> -w) \<and> p[[w]] = p0[[w]] \<and> p0[p0\<^sup>T\<^sup>\<star> * x \<sqinter> -(p0\<^sup>T\<^sup>\<star> * w)\<longmapsto>y] = p \<and>
   disjoint_set_forest p0 \<and> y = root p0 x \<and> w \<le> p0\<^sup>T\<^sup>\<star> * x"
 definition "path_compression_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>y] = p"
 
 text \<open>
 We first consider a variant that achieves the effect as a single update.
 The parents of all nodes reachable from x are simultaneously updated to the root of the component of x.
 \<close>
 
 lemma path_compression_exact:
   assumes "path_compression_precondition p0 x y"
     and "p0[p0\<^sup>T\<^sup>\<star> * x\<longmapsto>y] = p"
   shows "p \<sqinter> 1 = p0 \<sqinter> 1" "fc p = fc p0"
 proof -
   have a1: "disjoint_set_forest p0" and a2: "point x" and a3: "point y" and a4: "y = root p0 x"
     using path_compression_precondition_def assms(1) by auto
   have 1: "regular (p0\<^sup>T\<^sup>\<star> * x)"
     using a1 a2 bijective_regular mapping_regular regular_closed_star regular_conv_closed regular_mult_closed by auto
   have "p \<sqinter> 1 = (p0\<^sup>T\<^sup>\<star> * x \<sqinter> y\<^sup>T \<sqinter> 1) \<squnion> (-(p0\<^sup>T\<^sup>\<star> * x) \<sqinter> p0 \<sqinter> 1)"
     using assms(2) inf_sup_distrib2 by auto
   also have "... = (p0\<^sup>T\<^sup>\<star> * x \<sqinter> p0 \<sqinter> 1) \<squnion> (-(p0\<^sup>T\<^sup>\<star> * x) \<sqinter> p0 \<sqinter> 1)"
   proof -
     have "p0\<^sup>T\<^sup>\<star> * x \<sqinter> y\<^sup>T \<sqinter> 1 = p0\<^sup>T\<^sup>\<star> * x \<sqinter> p0 \<sqinter> 1"
     proof (rule order.antisym)
       have "(p0 \<sqinter> 1) * p0\<^sup>T\<^sup>\<star> * x \<sqinter> 1 \<le> p0"
         by (smt coreflexive_comp_top_inf_one inf.absorb_iff2 inf.cobounded2 inf.sup_monoid.add_assoc root_var)
       hence "p0\<^sup>T\<^sup>\<star> * x \<sqinter> y\<^sup>T \<sqinter> 1 \<le> p0"
         by (metis inf_le1 a4 conv_dist_inf coreflexive_symmetric inf.absorb2 inf.cobounded2 inf.sup_monoid.add_assoc root_var symmetric_one_closed)
       thus "p0\<^sup>T\<^sup>\<star> * x \<sqinter> y\<^sup>T \<sqinter> 1 \<le> p0\<^sup>T\<^sup>\<star> * x \<sqinter> p0 \<sqinter> 1"
         by (meson inf.le_sup_iff order.refl)
       have "p0\<^sup>T\<^sup>\<star> * x \<sqinter> p0 \<sqinter> 1 \<le> y"
         by (metis a4 coreflexive_comp_top_inf_one inf.cobounded1 inf_assoc inf_le2)
       thus "p0\<^sup>T\<^sup>\<star> * x \<sqinter> p0 \<sqinter> 1 \<le> p0\<^sup>T\<^sup>\<star> * x \<sqinter> y\<^sup>T \<sqinter> 1"
         by (smt conv_dist_inf coreflexive_symmetric inf.absorb_iff2 inf.cobounded2 inf.sup_monoid.add_assoc)
     qed
     thus ?thesis
       by simp
   qed
   also have "... = p0 \<sqinter> 1"
     using 1 by (metis inf.sup_monoid.add_commute inf_sup_distrib1 maddux_3_11_pp)
   finally show "p \<sqinter> 1 = p0 \<sqinter> 1"
     .
   show  "fc p = fc p0"
   proof (rule order.antisym)
     have 2: "univalent (p0[p0\<^sup>T\<^sup>\<star> * x\<longmapsto>y])"
       by (simp add: a1 a2 a3 update_univalent mult_assoc)
     have 3: "-(p0\<^sup>T\<^sup>\<star> * x) \<sqinter> p0 \<le> (p0[p0\<^sup>T\<^sup>\<star> * x\<longmapsto>y])\<^sup>\<star> * (p0[p0\<^sup>T\<^sup>\<star> * x\<longmapsto>y])\<^sup>T\<^sup>\<star>"
       using fc_increasing inf.order_trans sup.cobounded2 by blast
     have "p0\<^sup>T\<^sup>\<star> * x \<sqinter> p0 \<le> (p0\<^sup>T\<^sup>\<star> \<sqinter> p0 * x\<^sup>T) * (x \<sqinter> p0\<^sup>\<star> * p0)"
       by (metis conv_involutive conv_star_commute dedekind)
     also have "... \<le> p0\<^sup>T\<^sup>\<star> * x \<sqinter> p0 * x\<^sup>T * p0\<^sup>\<star> * p0"
       by (metis comp_associative inf.boundedI inf.cobounded2 inf_le1 mult_isotone)
     also have "... \<le> p0\<^sup>T\<^sup>\<star> * x \<sqinter> top * x\<^sup>T * p0\<^sup>\<star>"
       using comp_associative comp_inf.mult_right_isotone mult_isotone star.right_plus_below_circ by auto
     also have "... = p0\<^sup>T\<^sup>\<star> * x * x\<^sup>T * p0\<^sup>\<star>"
       by (metis a2 symmetric_top_closed vector_covector vector_inf_comp vector_mult_closed)
     also have "... \<le> (p0\<^sup>T\<^sup>\<star> * x * y\<^sup>T) * (y * x\<^sup>T * p0\<^sup>\<star>)"
       by (metis a3 order.antisym comp_inf.top_right_mult_increasing conv_involutive dedekind_1 inf.sup_left_divisibility inf.sup_monoid.add_commute mult_right_isotone surjective_conv_total mult_assoc)
     also have "... = (p0\<^sup>T\<^sup>\<star> * x \<sqinter> y\<^sup>T) * (y \<sqinter> x\<^sup>T * p0\<^sup>\<star>)"
       by (metis a2 a3 vector_covector vector_inf_comp vector_mult_closed)
     also have "... = (p0\<^sup>T\<^sup>\<star> * x \<sqinter> y\<^sup>T) * (p0\<^sup>T\<^sup>\<star> * x \<sqinter> y\<^sup>T)\<^sup>T"
       by (simp add: conv_dist_comp conv_dist_inf conv_star_commute inf_commute)
     also have "... \<le> (p0[p0\<^sup>T\<^sup>\<star> * x\<longmapsto>y])\<^sup>\<star> * (p0[p0\<^sup>T\<^sup>\<star> * x\<longmapsto>y])\<^sup>T\<^sup>\<star>"
       by (meson conv_isotone dual_order.trans mult_isotone star.circ_increasing sup.cobounded1)
     finally have "p0\<^sup>T\<^sup>\<star> * x \<sqinter> p0 \<le> (p0[p0\<^sup>T\<^sup>\<star> * x\<longmapsto>y])\<^sup>\<star> * (p0[p0\<^sup>T\<^sup>\<star> * x\<longmapsto>y])\<^sup>T\<^sup>\<star>"
       .
     hence "(p0\<^sup>T\<^sup>\<star> * x \<sqinter> p0) \<squnion> (-(p0\<^sup>T\<^sup>\<star> * x) \<sqinter> p0) \<le> (p0[p0\<^sup>T\<^sup>\<star> * x\<longmapsto>y])\<^sup>\<star> * (p0[p0\<^sup>T\<^sup>\<star> * x\<longmapsto>y])\<^sup>T\<^sup>\<star>"
       using 3 le_supI by blast
     hence "p0 \<le> (p0[p0\<^sup>T\<^sup>\<star> * x\<longmapsto>y])\<^sup>\<star> * (p0[p0\<^sup>T\<^sup>\<star> * x\<longmapsto>y])\<^sup>T\<^sup>\<star>"
       using 1 by (metis inf_commute maddux_3_11_pp)
     hence "fc p0 \<le> (p0[p0\<^sup>T\<^sup>\<star> * x\<longmapsto>y])\<^sup>\<star> * (p0[p0\<^sup>T\<^sup>\<star> * x\<longmapsto>y])\<^sup>T\<^sup>\<star>"
       using 2 fc_idempotent fc_isotone by fastforce
     thus "fc p0 \<le> fc p"
       by (simp add: assms(2))
     have "((p0\<^sup>T\<^sup>\<star> * x \<sqinter> y\<^sup>T) \<squnion> (-(p0\<^sup>T\<^sup>\<star> * x) \<sqinter> p0))\<^sup>\<star> = (-(p0\<^sup>T\<^sup>\<star> * x) \<sqinter> p0)\<^sup>\<star> * ((p0\<^sup>T\<^sup>\<star> * x \<sqinter> y\<^sup>T) \<squnion> 1)"
     proof (rule star_sup_2)
       have 4: "transitive (p0\<^sup>T\<^sup>\<star> * x)"
         using a2 comp_associative mult_right_isotone rectangle_star_rectangle by auto
       have "transitive (y\<^sup>T)"
         by (metis a3 conv_dist_comp inf.eq_refl mult_assoc)
       thus "transitive (p0\<^sup>T\<^sup>\<star> * x \<sqinter> y\<^sup>T)"
         using 4 transitive_inf_closed by auto
       have 5: "p0\<^sup>T\<^sup>\<star> * x * (-(p0\<^sup>T\<^sup>\<star> * x) \<sqinter> p0) \<le> p0\<^sup>T\<^sup>\<star> * x"
         by (metis a2 mult_right_isotone top_greatest mult_assoc)
       have "(-(p0\<^sup>T\<^sup>\<star> * x) \<sqinter> p0)\<^sup>T * y \<le> p0\<^sup>T * y"
         by (simp add: conv_dist_inf mult_left_isotone)
       also have "... \<le> y"
         using a1 a4 root_successor_loop by auto
       finally have "y\<^sup>T * (-(p0\<^sup>T\<^sup>\<star> * x) \<sqinter> p0) \<le> y\<^sup>T"
         using conv_dist_comp conv_isotone by fastforce
       thus "(p0\<^sup>T\<^sup>\<star> * x \<sqinter> y\<^sup>T) * (-(p0\<^sup>T\<^sup>\<star> * x) \<sqinter> p0) \<le> p0\<^sup>T\<^sup>\<star> * x \<sqinter> y\<^sup>T"
         using 5 comp_left_subdist_inf inf_mono order_trans by blast
     qed
     hence "p\<^sup>\<star> = (-(p0\<^sup>T\<^sup>\<star> * x) \<sqinter> p0)\<^sup>\<star> * ((p0\<^sup>T\<^sup>\<star> * x \<sqinter> y\<^sup>T) \<squnion> 1)"
       by (simp add: assms(2))
     also have "... \<le> p0\<^sup>\<star> * ((p0\<^sup>T\<^sup>\<star> * x \<sqinter> y\<^sup>T) \<squnion> 1)"
       by (simp add: mult_left_isotone star_isotone)
     also have "... = p0\<^sup>\<star> * (p0\<^sup>T\<^sup>\<star> * x * y\<^sup>T \<squnion> 1)"
       by (simp add: a2 a3 vector_covector vector_mult_closed)
     also have "... = p0\<^sup>\<star> * (p0\<^sup>T\<^sup>\<star> * (x * x\<^sup>T) * p0\<^sup>\<star> * (p0 \<sqinter> 1) \<squnion> 1)"
       by (metis a4 coreflexive_symmetric inf.cobounded2 root_var comp_associative conv_dist_comp conv_involutive conv_star_commute)
     also have "... \<le> p0\<^sup>\<star> * (p0\<^sup>T\<^sup>\<star> * 1 * p0\<^sup>\<star> * (p0 \<sqinter> 1) \<squnion> 1)"
       by (metis a2 mult_left_isotone mult_right_isotone semiring.add_left_mono sup_commute)
     also have "... = p0\<^sup>\<star> * (p0\<^sup>T\<^sup>\<star> * (p0 \<sqinter> 1) \<squnion> p0\<^sup>\<star> * (p0 \<sqinter> 1) \<squnion> 1)"
       by (simp add: a1 cancel_separate_eq mult_right_dist_sup)
     also have "... = p0\<^sup>\<star> * ((p0 \<sqinter> 1) \<squnion> p0\<^sup>\<star> * (p0 \<sqinter> 1) \<squnion> 1)"
       by (smt univalent_root_successors a1 conv_dist_comp conv_dist_inf coreflexive_idempotent coreflexive_symmetric inf.cobounded2 injective_codomain loop_root root_transitive_successor_loop symmetric_one_closed)
     also have "... = p0\<^sup>\<star> * (p0\<^sup>\<star> * (p0 \<sqinter> 1) \<squnion> 1)"
       by (metis inf.sup_left_divisibility inf_commute sup.left_idem sup_commute sup_relative_same_increasing)
     also have "... \<le> p0\<^sup>\<star> * p0\<^sup>\<star>"
       by (metis inf.cobounded2 inf_commute order.refl order_lesseq_imp star.circ_mult_upper_bound star.circ_reflexive star.circ_transitive_equal sup.boundedI sup_monoid.add_commute)
     also have "... = p0\<^sup>\<star>"
       by (simp add: star.circ_transitive_equal)
     finally show "fc p \<le> fc p0"
       by (metis conv_order conv_star_commute mult_isotone)
   qed
 qed
 
 lemma update_acyclic_6:
   assumes "disjoint_set_forest p"
     and "point x"
   shows "acyclic ((p[p\<^sup>T\<^sup>\<star>*x\<longmapsto>root p x]) \<sqinter> -1)"
   using assms root_point root_successor_loop update_acyclic_2 by auto
 
 theorem path_compression_assign:
-  "VARS p t w
+  "VARS p
   [ path_compression_precondition p x y \<and> p0 = p ]
   p[p\<^sup>T\<^sup>\<star> * x] := y
   [ path_compression_postcondition p x y p0 ]"
   apply vcg_tc_simp
   apply (unfold path_compression_precondition_def path_compression_postcondition_def)
   apply (intro conjI)
   subgoal using update_univalent mult_assoc by auto
   subgoal using bijective_regular mapping_regular regular_closed_star regular_conv_closed regular_mult_closed update_mapping mult_assoc by auto
   subgoal using update_acyclic_6 by blast
   subgoal by blast
   subgoal by blast
   subgoal by blast
   subgoal by blast
   subgoal by blast
   subgoal by blast
   subgoal by (smt same_root path_compression_exact path_compression_precondition_def update_univalent vector_mult_closed)
   subgoal using path_compression_exact(1) path_compression_precondition_def by blast
   subgoal using path_compression_exact(2) path_compression_precondition_def by blast
   by blast
 
 text \<open>
 We next look at implementing these updates using a loop.
 \<close>
 
 lemma path_compression_1a:
   assumes "point x"
     and "disjoint_set_forest p"
     and "x \<noteq> root p x"
   shows "p\<^sup>T\<^sup>+ * x \<le> - x"
   by (meson assms bijective_regular mapping_regular regular_closed_star regular_conv_closed regular_mult_closed vector_mult_closed point_in_vector_or_complement_2 loop_root_2)
 
 lemma path_compression_1b:
   "x \<le> p\<^sup>T\<^sup>\<star> * x"
   using mult_left_isotone star.circ_reflexive by fastforce
 
 lemma path_compression_1:
   "path_compression_precondition p x y \<Longrightarrow> path_compression_invariant p x y p x"
   using path_compression_invariant_def path_compression_precondition_def loop_root path_compression_1a path_compression_1b by auto
 
 lemma path_compression_2:
   "path_compression_invariant p x y p0 w \<and> y \<noteq> p[[w]] \<Longrightarrow> path_compression_invariant (p[w\<longmapsto>y]) x y p0 (p[[w]]) \<and> card { z . regular z \<and> z \<le> (p[w\<longmapsto>y])\<^sup>T\<^sup>\<star> * (p[[w]]) } < card { z . regular z \<and> z \<le> p\<^sup>T\<^sup>\<star> * w }"
 proof -
   let ?p = "p[w\<longmapsto>y]"
   let ?s = "{ z . regular z \<and> z \<le> p\<^sup>T\<^sup>\<star> * w }"
   let ?t = "{ z . regular z \<and> z \<le> ?p\<^sup>T\<^sup>\<star> * (p[[w]]) }"
   assume 1: "path_compression_invariant p x y p0 w \<and> y \<noteq> p[[w]]"
   have i1: "disjoint_set_forest p" and i2: "point x" and i3: "point y" and i4: "y = root p x"
     using 1 path_compression_invariant_def path_compression_precondition_def by meson+
   have i5: "point w" and i6: "y \<le> p\<^sup>T\<^sup>\<star> * w"
     and i7: "w \<noteq> x \<longrightarrow> p[[x]] = y \<and> y \<noteq> x \<and> p\<^sup>T\<^sup>+ * w \<le> -x" and i8: "p \<sqinter> 1 = p0 \<sqinter> 1" and i9: "fc p = fc p0"
-    and i10: "root p w = y" and i11: "w \<noteq> y \<longrightarrow> p[[w]] \<noteq> w" and i12: "p[[w]] = p0[[w]]" and i13: "p0[p0\<^sup>T\<^sup>\<star> * x \<sqinter> -(p0\<^sup>T\<^sup>\<star> * w)\<longmapsto>y] = p"
+    and i10: "root p w = y" and i11: "p[[w]] = p0[[w]]" and i12: "p0[p0\<^sup>T\<^sup>\<star> * x \<sqinter> -(p0\<^sup>T\<^sup>\<star> * w)\<longmapsto>y] = p"
     using 1 path_compression_invariant_def by blast+
-  have i14: "disjoint_set_forest p0" and i15: "y = root p0 x" and i16: "w \<le> p0\<^sup>T\<^sup>\<star> * x"
+  have i13: "disjoint_set_forest p0" and i14: "y = root p0 x" and i15: "w \<le> p0\<^sup>T\<^sup>\<star> * x"
     using 1 path_compression_invariant_def by auto
   have 2: "point (p[[w]])"
     using i1 i5 read_point by blast
   show "path_compression_invariant ?p x y p0 (p[[w]]) \<and> card ?t < card ?s"
   proof (unfold path_compression_invariant_def, intro conjI)
     have 3: "mapping ?p"
       by (simp add: i1 i3 i5 bijective_regular update_total update_univalent)
     have 4: "w \<noteq> y"
       using 1 i1 i4 root_successor_loop by blast
     hence 5: "w \<sqinter> y = bot"
       by (simp add: i3 i5 distinct_points)
     hence "y * w\<^sup>T \<le> -1"
       using pseudo_complement schroeder_4_p by auto
     hence "y * w\<^sup>T \<le> p\<^sup>T\<^sup>\<star> \<sqinter> -1"
       using i5 i6 shunt_bijective by auto
     also have "... \<le> p\<^sup>T\<^sup>+"
       by (simp add: star_plus_without_loops)
     finally have 6: "y \<le> p\<^sup>T\<^sup>+ * w"
       using i5 shunt_bijective by auto
     have 7: "w * w\<^sup>T \<le> -p\<^sup>T\<^sup>+"
     proof (rule ccontr)
       assume "\<not> w * w\<^sup>T \<le> -p\<^sup>T\<^sup>+"
       hence "w * w\<^sup>T \<le> --p\<^sup>T\<^sup>+"
         using i5 point_arc arc_in_partition by blast
       hence "w * w\<^sup>T \<le> p\<^sup>T\<^sup>+ \<sqinter> 1"
         using i1 i5 mapping_regular regular_conv_closed regular_closed_star regular_mult_closed by simp
       also have "... = ((p\<^sup>T \<sqinter> 1) * p\<^sup>T\<^sup>\<star> \<sqinter> 1) \<squnion> ((p\<^sup>T \<sqinter> -1) * p\<^sup>T\<^sup>\<star> \<sqinter> 1)"
         by (metis comp_inf.mult_right_dist_sup maddux_3_11_pp mult_right_dist_sup regular_one_closed)
       also have "... = ((p\<^sup>T \<sqinter> 1) * p\<^sup>T\<^sup>\<star> \<sqinter> 1) \<squnion> ((p \<sqinter> -1)\<^sup>+ \<sqinter> 1)\<^sup>T"
         by (metis conv_complement conv_dist_inf conv_plus_commute equivalence_one_closed reachable_without_loops)
       also have "... \<le> ((p\<^sup>T \<sqinter> 1) * p\<^sup>T\<^sup>\<star> \<sqinter> 1) \<squnion> (-1 \<sqinter> 1)\<^sup>T"
         by (metis (no_types, hide_lams) i1 sup_right_isotone inf.sup_left_isotone conv_isotone)
       also have "... = (p\<^sup>T \<sqinter> 1) * p\<^sup>T\<^sup>\<star> \<sqinter> 1"
         by simp
       also have "... \<le> (p\<^sup>T \<sqinter> 1) * top \<sqinter> 1"
         by (metis comp_inf.comp_isotone coreflexive_comp_top_inf equivalence_one_closed inf.cobounded1 inf.cobounded2)
       also have "... \<le> p\<^sup>T"
         by (simp add: coreflexive_comp_top_inf_one)
       finally have "w * w\<^sup>T \<le> p\<^sup>T"
         by simp
       hence "w \<le> p[[w]]"
         using i5 shunt_bijective by blast
       hence "w = p[[w]]"
         using 2 by (metis i5 epm_3 mult_semi_associative)
       thus False
-        using 4 i11 by auto
+        using 2 4 i10 loop_root by auto
     qed
     hence 8: "w \<sqinter> p\<^sup>T\<^sup>+ * w = bot"
       using p_antitone_iff pseudo_complement schroeder_4_p by blast
     show "y \<le> ?p\<^sup>T\<^sup>\<star> * (p[[w]])"
     proof -
       have "(w \<sqinter> y\<^sup>T)\<^sup>T * (-w \<sqinter> p)\<^sup>T\<^sup>\<star> * p\<^sup>T * w \<le> w\<^sup>T * (-w \<sqinter> p)\<^sup>T\<^sup>\<star> * p\<^sup>T * w"
         by (simp add: conv_isotone mult_left_isotone)
       also have "... \<le> w\<^sup>T * p\<^sup>T\<^sup>\<star> * p\<^sup>T * w"
         by (simp add: conv_isotone mult_left_isotone star_isotone mult_right_isotone)
       also have "... = w\<^sup>T * p\<^sup>T\<^sup>+ * w"
         by (simp add: star_plus mult_assoc)
       also have "... = bot"
         using 8 by (smt i5 covector_inf_comp_3 mult_assoc conv_dist_comp conv_star_commute covector_bot_closed equivalence_top_closed inf.le_iff_sup mult_left_isotone)
       finally have "((w \<sqinter> y\<^sup>T)\<^sup>T \<squnion> (-w \<sqinter> p)\<^sup>T) * (-w \<sqinter> p)\<^sup>T\<^sup>\<star> * p\<^sup>T * w \<le> (-w \<sqinter> p)\<^sup>T * (-w \<sqinter> p)\<^sup>T\<^sup>\<star> * p\<^sup>T * w"
         by (simp add: bot_unique mult_right_dist_sup)
       also have "... \<le> (-w \<sqinter> p)\<^sup>T\<^sup>\<star> * p\<^sup>T * w"
         by (simp add: mult_left_isotone star.left_plus_below_circ)
       finally have "?p\<^sup>T * (-w \<sqinter> p)\<^sup>T\<^sup>\<star> * p\<^sup>T * w \<le> (-w \<sqinter> p)\<^sup>T\<^sup>\<star> * p\<^sup>T * w"
         by (simp add: conv_dist_sup)
       hence "?p\<^sup>T\<^sup>\<star> * p\<^sup>T * w \<le> (-w \<sqinter> p)\<^sup>T\<^sup>\<star> * p\<^sup>T * w"
         by (metis comp_associative star.circ_loop_fixpoint star_left_induct sup_commute sup_least sup_left_divisibility)
       hence "w \<sqinter> ?p\<^sup>T\<^sup>\<star> * p\<^sup>T * w \<le> w \<sqinter> (-w \<sqinter> p)\<^sup>T\<^sup>\<star> * p\<^sup>T * w"
         using inf.sup_right_isotone by blast
       also have "... \<le> w \<sqinter> p\<^sup>T\<^sup>\<star> * p\<^sup>T * w"
         using conv_isotone mult_left_isotone star_isotone inf.sup_right_isotone by simp
       also have "... = bot"
         using 8 by (simp add: star_plus)
       finally have 9: "w\<^sup>T * ?p\<^sup>T\<^sup>\<star> * p\<^sup>T * w = bot"
         by (smt i5 covector_inf_comp_3 mult_assoc conv_dist_comp covector_bot_closed equivalence_top_closed inf.le_iff_sup mult_left_isotone bot_least inf.absorb1)
       have "p\<^sup>T * ?p\<^sup>T\<^sup>\<star> * p\<^sup>T * w = ((w \<sqinter> p)\<^sup>T \<squnion> (-w \<sqinter> p)\<^sup>T) * ?p\<^sup>T\<^sup>\<star> * p\<^sup>T * w"
         by (metis i5 bijective_regular conv_dist_sup inf.sup_monoid.add_commute maddux_3_11_pp)
       also have "... = (w \<sqinter> p)\<^sup>T * ?p\<^sup>T\<^sup>\<star> * p\<^sup>T * w \<squnion> (-w \<sqinter> p)\<^sup>T * ?p\<^sup>T\<^sup>\<star> * p\<^sup>T * w"
         by (simp add: mult_right_dist_sup)
       also have "... \<le> w\<^sup>T * ?p\<^sup>T\<^sup>\<star> * p\<^sup>T * w \<squnion> (-w \<sqinter> p)\<^sup>T * ?p\<^sup>T\<^sup>\<star> * p\<^sup>T * w"
         using semiring.add_right_mono comp_isotone conv_isotone by auto
       also have "... = (-w \<sqinter> p)\<^sup>T * ?p\<^sup>T\<^sup>\<star> * p\<^sup>T * w"
         using 9 by simp
       also have "... \<le> ?p\<^sup>T\<^sup>+ * p\<^sup>T * w"
         by (simp add: conv_isotone mult_left_isotone)
       also have "... \<le> ?p\<^sup>T\<^sup>\<star> * p\<^sup>T * w"
         by (simp add: comp_isotone star.left_plus_below_circ)
       finally have "p\<^sup>T\<^sup>\<star> * p\<^sup>T * w \<le> ?p\<^sup>T\<^sup>\<star> * p\<^sup>T * w"
         by (metis comp_associative star.circ_loop_fixpoint star_left_induct sup_commute sup_least sup_left_divisibility)
       thus "y \<le> ?p\<^sup>T\<^sup>\<star> * (p[[w]])"
         using 6 by (simp add: star_simulation_right_equal mult_assoc)
     qed
     have 10: "acyclic (?p \<sqinter> -1)"
       using i1 i10 i3 i5 inf_le1 update_acyclic_3 by blast
     have "?p[[p\<^sup>T\<^sup>+ * w]] \<le> p\<^sup>T\<^sup>+ * w"
     proof -
       have "(w\<^sup>T \<sqinter> y) * p\<^sup>T\<^sup>+ * w = y \<sqinter> w\<^sup>T * p\<^sup>T\<^sup>+ * w"
         by (metis i3 inf_vector_comp vector_inf_comp)
       hence "?p[[p\<^sup>T\<^sup>+ * w]] = (y \<sqinter> w\<^sup>T * p\<^sup>T\<^sup>+ * w) \<squnion> (-w\<^sup>T \<sqinter> p\<^sup>T) * p\<^sup>T\<^sup>+ * w"
         by (simp add: comp_associative conv_complement conv_dist_inf conv_dist_sup mult_right_dist_sup)
       also have "... \<le> y \<squnion> (-w\<^sup>T \<sqinter> p\<^sup>T) * p\<^sup>T\<^sup>+ * w"
         using sup_left_isotone by auto
       also have "... \<le> y \<squnion> p\<^sup>T * p\<^sup>T\<^sup>+ * w"
         using mult_left_isotone sup_right_isotone by auto
       also have "... \<le> y \<squnion> p\<^sup>T\<^sup>+ * w"
         using semiring.add_left_mono mult_left_isotone mult_right_isotone star.left_plus_below_circ by auto
       also have "... = p\<^sup>T\<^sup>+ * w"
         using 6 by (simp add: sup_absorb2)
       finally show ?thesis
         by simp
     qed
     hence 11: "?p\<^sup>T\<^sup>\<star> * (p[[w]]) \<le> p\<^sup>T\<^sup>+ * w"
       using star_left_induct by (simp add: mult_left_isotone star.circ_mult_increasing)
     hence 12: "?p\<^sup>T\<^sup>+ * (p[[w]]) \<le> p\<^sup>T\<^sup>+ * w"
       using dual_order.trans mult_left_isotone star.left_plus_below_circ by blast
     have 13: "?p[[x]] = y \<and> y \<noteq> x \<and> ?p\<^sup>T\<^sup>+ * (p[[w]]) \<le> -x"
     proof (cases "w = x")
       case True
       hence "?p[[x]] = (w\<^sup>T \<sqinter> y) * w \<squnion> (-w\<^sup>T \<sqinter> p\<^sup>T) * w"
         by (simp add: conv_complement conv_dist_inf conv_dist_sup mult_right_dist_sup)
       also have "... = (w\<^sup>T \<sqinter> y) * w \<squnion> p\<^sup>T * (-w \<sqinter> w)"
         by (metis i5 conv_complement covector_inf_comp_3 inf.sup_monoid.add_commute vector_complement_closed)
       also have "... = (w\<^sup>T \<sqinter> y) * w"
         by simp
       also have "... = y * w"
         by (simp add: i5 covector_inf_comp_3 inf.sup_monoid.add_commute)
       also have "... = y"
         by (metis i3 i5 comp_associative)
       finally show ?thesis
         using 4 8 12 True pseudo_complement inf.sup_monoid.add_commute order.trans by blast
     next
       case False
       have "?p[[x]] = (w\<^sup>T \<sqinter> y) * x \<squnion> (-w\<^sup>T \<sqinter> p\<^sup>T) * x"
         by (simp add: conv_complement conv_dist_inf conv_dist_sup mult_right_dist_sup)
       also have "... = y * (w \<sqinter> x) \<squnion> p\<^sup>T * (-w \<sqinter> x)"
         by (metis i5 conv_complement covector_inf_comp_3 inf_commute vector_complement_closed)
       also have "... = p\<^sup>T * (-w \<sqinter> x)"
         using i2 i5 False distinct_points by auto
       also have "... = y"
         using i2 i5 i7 False distinct_points inf.absorb2 pseudo_complement by auto
       finally show ?thesis
         using 12 False i7 dual_order.trans by blast
     qed
     thus "p[[w]] \<noteq> x \<longrightarrow> ?p[[x]] = y \<and> y \<noteq> x \<and> ?p\<^sup>T\<^sup>+ * (p[[w]]) \<le> -x"
       by simp
     have 14: "?p\<^sup>T\<^sup>\<star> * x = x \<squnion> y"
     proof (rule order.antisym)
       have "?p\<^sup>T * (x \<squnion> y) = y \<squnion> ?p\<^sup>T * y"
         using 13 by (simp add: mult_left_dist_sup)
       also have "... = y \<squnion> (w\<^sup>T \<sqinter> y) * y \<squnion> (-w\<^sup>T \<sqinter> p\<^sup>T) * y"
         by (simp add: conv_complement conv_dist_inf conv_dist_sup mult_right_dist_sup sup_assoc)
       also have "... \<le> y \<squnion> (w\<^sup>T \<sqinter> y) * y \<squnion> p\<^sup>T * y"
         using mult_left_isotone sup_right_isotone by auto
       also have "... = y \<squnion> (w\<^sup>T \<sqinter> y) * y"
         using i1 i10 root_successor_loop sup_commute by auto
       also have "... \<le> y \<squnion> y * y"
         using mult_left_isotone sup_right_isotone by auto
       also have "... = y"
         by (metis i3 comp_associative sup.idem)
       also have "... \<le> x \<squnion> y"
         by simp
       finally show "?p\<^sup>T\<^sup>\<star> * x \<le> x \<squnion> y"
         by (simp add: star_left_induct)
     next
       show "x \<squnion> y \<le> ?p\<^sup>T\<^sup>\<star> * x"
         using 13 by (metis mult_left_isotone star.circ_increasing star.circ_loop_fixpoint sup.boundedI sup_ge2)
     qed
     have 15: "y = root ?p x"
     proof -
       have "(p \<sqinter> 1) * y = (p \<sqinter> 1) * (p \<sqinter> 1) * p\<^sup>T\<^sup>\<star> * x"
         by (simp add: i4 comp_associative root_var)
       also have "... = (p \<sqinter> 1) * p\<^sup>T\<^sup>\<star> * x"
         using coreflexive_idempotent by auto
       finally have 16: "(p \<sqinter> 1) * y = y"
         by (simp add: i4 root_var)
       have 17: "(p \<sqinter> 1) * x \<le> y"
         by (metis (no_types, lifting) i4 comp_right_one mult_left_isotone mult_right_isotone star.circ_reflexive root_var)
       have "root ?p x = (?p \<sqinter> 1) * (x \<squnion> y)"
         using 14 by (metis mult_assoc root_var)
       also have "... = (w \<sqinter> y\<^sup>T \<sqinter> 1) * (x \<squnion> y) \<squnion> (-w \<sqinter> p \<sqinter> 1) * (x \<squnion> y)"
         by (simp add: inf_sup_distrib2 semiring.distrib_right)
       also have "... = (w \<sqinter> 1 \<sqinter> y\<^sup>T) * (x \<squnion> y) \<squnion> (-w \<sqinter> p \<sqinter> 1) * (x \<squnion> y)"
         by (simp add: inf.left_commute inf.sup_monoid.add_commute)
       also have "... = (w \<sqinter> 1) * (y \<sqinter> (x \<squnion> y)) \<squnion> (-w \<sqinter> p \<sqinter> 1) * (x \<squnion> y)"
         by (simp add: i3 covector_inf_comp_3)
       also have "... = (w \<sqinter> 1) * y \<squnion> (-w \<sqinter> p \<sqinter> 1) * (x \<squnion> y)"
         by (simp add: inf.absorb1)
       also have "... = (w \<sqinter> 1 * y) \<squnion> (-w \<sqinter> (p \<sqinter> 1) * (x \<squnion> y))"
         by (simp add: i5 inf_assoc vector_complement_closed vector_inf_comp)
       also have "... = (w \<sqinter> y) \<squnion> (-w \<sqinter> ((p \<sqinter> 1) * x \<squnion> y))"
         using 16 by (simp add: mult_left_dist_sup)
       also have "... = (w \<sqinter> y) \<squnion> (-w \<sqinter> y)"
         using 17 by (simp add: sup.absorb2)
       also have "... = y"
         using 5 inf.sup_monoid.add_commute le_iff_inf pseudo_complement sup_monoid.add_0_left by fastforce
       finally show ?thesis
         by simp
     qed
     show "path_compression_precondition ?p x y"
       using 3 10 15 i2 i3 path_compression_precondition_def by blast
     show "vector (p[[w]])"
       using 2 by simp
     show "injective (p[[w]])"
       using 2 by simp
     show "surjective (p[[w]])"
       using 2 by simp
     have "w \<sqinter> p \<sqinter> 1 \<le> w \<sqinter> w\<^sup>T \<sqinter> p"
       by (metis inf.boundedE inf.boundedI inf.cobounded1 inf.cobounded2 one_inf_conv)
     also have "... = w * w\<^sup>T \<sqinter> p"
       by (simp add: i5 vector_covector)
     also have "... \<le> -p\<^sup>T\<^sup>+ \<sqinter> p"
       using 7 by (simp add: inf.coboundedI2 inf.sup_monoid.add_commute)
     finally have "w \<sqinter> p \<sqinter> 1 = bot"
       by (metis (no_types, hide_lams) conv_dist_inf coreflexive_symmetric inf.absorb1 inf.boundedE inf.cobounded2 pseudo_complement star.circ_mult_increasing)
     also have "w \<sqinter> y\<^sup>T \<sqinter> 1 = bot"
       using 5 antisymmetric_bot_closed asymmetric_bot_closed comp_inf.schroeder_2 inf.absorb1 one_inf_conv by fastforce
     finally have "w \<sqinter> p \<sqinter> 1 = w \<sqinter> y\<^sup>T \<sqinter> 1"
       by simp
     thus 18: "?p \<sqinter> 1 = p0 \<sqinter> 1"
       by (metis i5 i8 bijective_regular inf.sup_monoid.add_commute inf_sup_distrib2 maddux_3_11_pp)
     show 19: "fc ?p = fc p0"
     proof -
       have "p[[w]] = p\<^sup>T * (w \<sqinter> p\<^sup>\<star> * y)"
         by (metis i3 i5 i6 bijective_reverse conv_star_commute inf.absorb1)
       also have "... = p\<^sup>T * (w \<sqinter> p\<^sup>\<star>) * y"
         by (simp add: i5 vector_inf_comp mult_assoc)
       also have "... = p\<^sup>T * ((w \<sqinter> 1) \<squnion> (w \<sqinter> p) * (-w \<sqinter> p)\<^sup>\<star>) * y"
         by (simp add: i5 omit_redundant_points)
       also have "... = p\<^sup>T * (w \<sqinter> 1) * y \<squnion> p\<^sup>T * (w \<sqinter> p) * (-w \<sqinter> p)\<^sup>\<star> * y"
         by (simp add: comp_associative mult_left_dist_sup mult_right_dist_sup)
       also have "... \<le> p\<^sup>T * y \<squnion> p\<^sup>T * (w \<sqinter> p) * (-w \<sqinter> p)\<^sup>\<star> * y"
         by (metis semiring.add_right_mono comp_isotone order.eq_iff inf.cobounded1 inf.sup_monoid.add_commute mult_1_right)
       also have "... = y \<squnion> p\<^sup>T * (w \<sqinter> p) * (-w \<sqinter> p)\<^sup>\<star> * y"
         using i1 i4 root_successor_loop by auto
       also have "... \<le> y \<squnion> p\<^sup>T * p * (-w \<sqinter> p)\<^sup>\<star> * y"
         using comp_isotone sup_right_isotone by auto
       also have "... \<le> y \<squnion> (-w \<sqinter> p)\<^sup>\<star> * y"
         by (metis i1 comp_associative eq_refl shunt_mapping sup_right_isotone)
       also have "... = (-w \<sqinter> p)\<^sup>\<star> * y"
         by (metis star.circ_loop_fixpoint sup.left_idem sup_commute)
       finally have 20: "p[[w]] \<le> (-w \<sqinter> p)\<^sup>\<star> * y"
         by simp
       have "p\<^sup>T * (-w \<sqinter> p)\<^sup>\<star> * y = p\<^sup>T * y \<squnion> p\<^sup>T * (-w \<sqinter> p) * (-w \<sqinter> p)\<^sup>\<star> * y"
         by (metis comp_associative mult_left_dist_sup star.circ_loop_fixpoint sup_commute)
       also have "... = y \<squnion> p\<^sup>T * (-w \<sqinter> p) * (-w \<sqinter> p)\<^sup>\<star> * y"
         using i1 i4 root_successor_loop by auto
       also have "... \<le> y \<squnion> p\<^sup>T * p * (-w \<sqinter> p)\<^sup>\<star> * y"
         using comp_isotone sup_right_isotone by auto
       also have "... \<le> y \<squnion> (-w \<sqinter> p)\<^sup>\<star> * y"
         by (metis i1 comp_associative eq_refl shunt_mapping sup_right_isotone)
       also have "... = (-w \<sqinter> p)\<^sup>\<star> * y"
         by (metis star.circ_loop_fixpoint sup.left_idem sup_commute)
       finally have 21: "p\<^sup>T\<^sup>\<star> * p\<^sup>T * w \<le> (-w \<sqinter> p)\<^sup>\<star> * y"
         using 20 by (simp add: comp_associative star_left_induct)
       have "w\<^sup>T \<sqinter> p\<^sup>T = p\<^sup>T * (w\<^sup>T \<sqinter> 1)"
         by (metis i5 comp_right_one covector_inf_comp_3 inf.sup_monoid.add_commute one_inf_conv)
       also have "... \<le> p[[w]]"
         by (metis comp_right_subdist_inf inf.boundedE inf.sup_monoid.add_commute one_inf_conv)
       also have "... \<le> p\<^sup>T\<^sup>\<star> * p\<^sup>T * w"
         by (simp add: mult_left_isotone star.circ_mult_increasing_2)
       also have "... \<le> (-w \<sqinter> p)\<^sup>\<star> * y"
         using 21 by simp
       finally have "w \<sqinter> p \<le> y\<^sup>T * (-w \<sqinter> p)\<^sup>T\<^sup>\<star>"
         by (metis conv_dist_comp conv_dist_inf conv_involutive conv_isotone conv_star_commute)
       hence "w \<sqinter> p \<le> (w \<sqinter> y\<^sup>T) * (-w \<sqinter> p)\<^sup>T\<^sup>\<star>"
         by (simp add: i5 vector_inf_comp)
       also have "... \<le> (w \<sqinter> y\<^sup>T) * ?p\<^sup>T\<^sup>\<star>"
         by (simp add: conv_isotone mult_right_isotone star_isotone)
       also have "... \<le> ?p * ?p\<^sup>T\<^sup>\<star>"
         by (simp add: mult_left_isotone)
       also have "... \<le> fc ?p"
         by (simp add: mult_left_isotone star.circ_increasing)
       finally have 22: "w \<sqinter> p \<le> fc ?p"
         by simp
       have "-w \<sqinter> p \<le> ?p"
         by simp
       also have "... \<le> fc ?p"
         by (simp add: fc_increasing)
       finally have "(w \<squnion> -w) \<sqinter> p \<le> fc ?p"
         using 22 by (simp add: comp_inf.semiring.distrib_left inf.sup_monoid.add_commute)
       hence "p \<le> fc ?p"
         by (metis i5 bijective_regular inf.sup_monoid.add_commute inf_sup_distrib1 maddux_3_11_pp)
       hence 23: "fc p \<le> fc ?p"
         using 3 fc_idempotent fc_isotone by fastforce
       have "?p \<le> (w \<sqinter> y\<^sup>T) \<squnion> p"
         using sup_right_isotone by auto
       also have "... = w * y\<^sup>T \<squnion> p"
         by (simp add: i3 i5 vector_covector)
       also have "... \<le> p\<^sup>\<star> \<squnion> p"
         by (smt i5 i6 conv_dist_comp conv_involutive conv_isotone conv_star_commute le_supI shunt_bijective star.circ_increasing sup_absorb1)
       also have "... \<le> fc p"
         using fc_increasing star.circ_back_loop_prefixpoint by auto
       finally have "fc ?p \<le> fc p"
         using i1 fc_idempotent fc_isotone by fastforce
       thus ?thesis
         using 23 i9 by auto
     qed
     show "?p[[p[[w]]]] = p0[[p[[w]]]]"
     proof -
       have "?p[[p[[w]]]] = p[[p[[w]]]]"
-        using 2 4 i5 i11 by (simp add: put_get_different)
+        using 2 4 by (metis i5 i10 loop_root put_get_different)
       also have "... = p[[p0[[w]]]]"
-        by (simp add: i12)
+        by (simp add: i11)
       also have "... = (p0[p0\<^sup>T\<^sup>\<star> * x \<sqinter> -(p0\<^sup>T\<^sup>\<star> * w)\<longmapsto>y])[[p0[[w]]]]"
-        using i13 by auto
+        using i12 by auto
       also have "... = p0[[p0[[w]]]]"
       proof -
         have "p0[[w]] \<le> -(p0\<^sup>T\<^sup>\<star> * x \<sqinter> -(p0\<^sup>T\<^sup>\<star> * w))"
           by (meson inf.coboundedI2 mult_left_isotone p_antitone p_antitone_iff star.circ_increasing)
         thus ?thesis
           by (meson i2 i5 put_get_different_vector vector_complement_closed vector_inf_closed vector_mult_closed)
       qed
       also have "... = p0[[p[[w]]]]"
-        by (simp add: i12)
+        by (simp add: i11)
       finally show ?thesis
         .
     qed
     have 24: "root ?p (p[[w]]) = root p0 (p[[w]])"
-      using 3 18 19 i14 same_root by blast
+      using 3 18 19 i13 same_root by blast
     also have "... = root p0 (p0[[w]])"
-      by (simp add: i12)
+      by (simp add: i11)
     also have 25: "... = root p0 w"
-      by (metis i5 i14 conv_involutive forest_components_increasing mult_left_isotone shunt_bijective injective_mult_closed read_surjective same_component_same_root)
+      by (metis i5 i13 conv_involutive forest_components_increasing mult_left_isotone shunt_bijective injective_mult_closed read_surjective same_component_same_root)
     finally show 26: "root ?p (p[[w]]) = y"
-      by (metis i1 i10 i14 i8 i9 same_root)
-    show "p[[w]] \<noteq> y \<longrightarrow> ?p[[p[[w]]]] \<noteq> p[[w]] \<and> ?p\<^sup>T\<^sup>+ * (p[[w]]) \<le> -(p[[w]])"
-    proof
-      assume 27: "p[[w]] \<noteq> y"
-      show "?p[[p[[w]]]] \<noteq> p[[w]] \<and> ?p\<^sup>T\<^sup>+ * (p[[w]]) \<le> -(p[[w]])"
-      proof
-        show "?p[[p[[w]]]] \<noteq> p[[w]]"
-          using 2 26 27 loop_root by auto
-        show "?p\<^sup>T\<^sup>+ * (p[[w]]) \<le> -(p[[w]])"
-          using 2 3 10 26 27 by (simp add: path_compression_1a)
-      qed
-    qed
+      by (metis i1 i10 i13 i8 i9 same_root)
+    thus "p[[w]] \<noteq> y \<longrightarrow> ?p\<^sup>T\<^sup>+ * (p[[w]]) \<le> -(p[[w]])"
+      using 2 3 10 by (simp add: path_compression_1a)
     show "univalent p0" "total p0" "acyclic (p0 \<sqinter> -1)"
-      by (simp_all add: i14)
+      by (simp_all add: i13)
     show "y = root p0 x"
-      by (simp add: i15)
+      by (simp add: i14)
     show "p[[w]] \<le> p0\<^sup>T\<^sup>\<star> * x"
-      by (metis i12 i16 mult_isotone star.circ_increasing star.circ_transitive_equal mult_assoc)
+      by (metis i11 i15 mult_isotone star.circ_increasing star.circ_transitive_equal mult_assoc)
     let ?q = "p0[p0\<^sup>T\<^sup>\<star> * x \<sqinter> -(p0\<^sup>T\<^sup>\<star> * (p[[w]]))\<longmapsto>y]"
     show "?q = ?p"
     proof -
-      have 28: "w \<squnion> p0\<^sup>T\<^sup>+ * w = p0\<^sup>T\<^sup>\<star> * w"
+      have 27: "w \<squnion> p0\<^sup>T\<^sup>+ * w = p0\<^sup>T\<^sup>\<star> * w"
         using comp_associative star.circ_loop_fixpoint sup_commute by auto
-      hence 29: "p0\<^sup>T\<^sup>+ * w = p0\<^sup>T\<^sup>\<star> * w \<sqinter> -w"
-        using 4 24 25 26 by (metis i12 i14 i5 inf.orderE maddux_3_13 path_compression_1a)
+      hence 28: "p0\<^sup>T\<^sup>+ * w = p0\<^sup>T\<^sup>\<star> * w \<sqinter> -w"
+        using 4 24 25 26 by (metis i11 i13 i5 inf.orderE maddux_3_13 path_compression_1a)
       hence "p0\<^sup>T\<^sup>\<star> * (p[[w]]) \<le> -w"
-        by (metis i12 inf_le2 star_plus mult.assoc)
+        by (metis i11 inf_le2 star_plus mult.assoc)
       hence "w \<le> -(p0\<^sup>T\<^sup>\<star> * (p[[w]]))"
         by (simp add: p_antitone_iff)
       hence "w \<le> p0\<^sup>T\<^sup>\<star> * x \<sqinter> -(p0\<^sup>T\<^sup>\<star> * (p[[w]]))"
-        by (simp add: i16)
-      hence 30: "?q \<sqinter> w = ?p \<sqinter> w"
+        by (simp add: i15)
+      hence 29: "?q \<sqinter> w = ?p \<sqinter> w"
         by (metis update_inf update_inf_same)
-      have 31: "?q \<sqinter> p0\<^sup>T\<^sup>+ * w = ?p \<sqinter> p0\<^sup>T\<^sup>+ * w"
+      have 30: "?q \<sqinter> p0\<^sup>T\<^sup>+ * w = ?p \<sqinter> p0\<^sup>T\<^sup>+ * w"
       proof -
         have "?q \<sqinter> p0\<^sup>T\<^sup>+ * w = p0 \<sqinter> p0\<^sup>T\<^sup>+ * w"
-          by (metis i12 comp_associative inf.cobounded2 p_antitone_iff star.circ_plus_same update_inf_different)
+          by (metis i11 comp_associative inf.cobounded2 p_antitone_iff star.circ_plus_same update_inf_different)
         also have "... = p \<sqinter> p0\<^sup>T\<^sup>+ * w"
-          using 29 by (metis i13 inf.cobounded2 inf.sup_monoid.add_assoc p_antitone_iff update_inf_different)
+          using 28 by (metis i12 inf.cobounded2 inf.sup_monoid.add_assoc p_antitone_iff update_inf_different)
         also have "... = ?p \<sqinter> p0\<^sup>T\<^sup>+ * w"
-          using 29 by (simp add: update_inf_different)
+          using 28 by (simp add: update_inf_different)
         finally show ?thesis
           .
       qed
-      have 32: "?q \<sqinter> p0\<^sup>T\<^sup>\<star> * w = ?p \<sqinter> p0\<^sup>T\<^sup>\<star> * w"
-        using 28 30 31 by (metis inf_sup_distrib1)
-      have 33: "?q \<sqinter> (p0\<^sup>T\<^sup>\<star> * x \<sqinter> -(p0\<^sup>T\<^sup>\<star> * w)) = ?p \<sqinter> (p0\<^sup>T\<^sup>\<star> * x \<sqinter> -(p0\<^sup>T\<^sup>\<star> * w))"
+      have 31: "?q \<sqinter> p0\<^sup>T\<^sup>\<star> * w = ?p \<sqinter> p0\<^sup>T\<^sup>\<star> * w"
+        using 27 29 30 by (metis inf_sup_distrib1)
+      have 32: "?q \<sqinter> (p0\<^sup>T\<^sup>\<star> * x \<sqinter> -(p0\<^sup>T\<^sup>\<star> * w)) = ?p \<sqinter> (p0\<^sup>T\<^sup>\<star> * x \<sqinter> -(p0\<^sup>T\<^sup>\<star> * w))"
       proof -
         have "p0\<^sup>T\<^sup>\<star> * x \<sqinter> -(p0\<^sup>T\<^sup>\<star> * w) \<le> p0\<^sup>T\<^sup>\<star> * x \<sqinter> -(p0\<^sup>T\<^sup>\<star> * (p[[w]]))"
-          using 29 by (metis i12 inf.sup_right_isotone mult.semigroup_axioms p_antitone_inf star_plus semigroup.assoc)
+          using 28 by (metis i11 inf.sup_right_isotone mult.semigroup_axioms p_antitone_inf star_plus semigroup.assoc)
         hence "?q \<sqinter> (p0\<^sup>T\<^sup>\<star> * x \<sqinter> -(p0\<^sup>T\<^sup>\<star> * w)) = y\<^sup>T \<sqinter> p0\<^sup>T\<^sup>\<star> * x \<sqinter> -(p0\<^sup>T\<^sup>\<star> * w)"
           by (metis inf_assoc update_inf)
         also have "... = p \<sqinter> (p0\<^sup>T\<^sup>\<star> * x \<sqinter> -(p0\<^sup>T\<^sup>\<star> * w))"
-          by (metis i13 inf_assoc update_inf_same)
+          by (metis i12 inf_assoc update_inf_same)
         also have "... = ?p \<sqinter> (p0\<^sup>T\<^sup>\<star> * x \<sqinter> -(p0\<^sup>T\<^sup>\<star> * w))"
           by (simp add: inf.coboundedI2 p_antitone path_compression_1b inf_assoc update_inf_different)
         finally show ?thesis
           .
       qed
       have "p0\<^sup>T\<^sup>\<star> * w \<squnion> (p0\<^sup>T\<^sup>\<star> * x \<sqinter> -(p0\<^sup>T\<^sup>\<star> * w)) = p0\<^sup>T\<^sup>\<star> * x"
       proof -
-        have 34: "regular (p0\<^sup>T\<^sup>\<star> * w)"
-          using i14 i5 bijective_regular mapping_regular regular_closed_star regular_conv_closed regular_mult_closed by auto
+        have 33: "regular (p0\<^sup>T\<^sup>\<star> * w)"
+          using i13 i5 bijective_regular mapping_regular regular_closed_star regular_conv_closed regular_mult_closed by auto
         have "p0\<^sup>T\<^sup>\<star> * w \<le> p0\<^sup>T\<^sup>\<star> * x"
-          by (metis i16 comp_associative mult_right_isotone star.circ_transitive_equal)
+          by (metis i15 comp_associative mult_right_isotone star.circ_transitive_equal)
         hence "p0\<^sup>T\<^sup>\<star> * w \<squnion> (p0\<^sup>T\<^sup>\<star> * x \<sqinter> -(p0\<^sup>T\<^sup>\<star> * w)) = p0\<^sup>T\<^sup>\<star> * x \<sqinter> (p0\<^sup>T\<^sup>\<star> * w \<squnion> -(p0\<^sup>T\<^sup>\<star> * w))"
           by (simp add: comp_inf.semiring.distrib_left inf.absorb2)
         also have "... = p0\<^sup>T\<^sup>\<star> * x"
-          using 34 by (metis inf_sup_distrib1 maddux_3_11_pp)
+          using 33 by (metis inf_sup_distrib1 maddux_3_11_pp)
         finally show ?thesis
           .
       qed
-      hence 35: "?q \<sqinter> p0\<^sup>T\<^sup>\<star> * x = ?p \<sqinter> p0\<^sup>T\<^sup>\<star> * x"
-        using 32 33 by (metis inf_sup_distrib1)
-      have 36: "regular (p0\<^sup>T\<^sup>\<star> * x)"
-        using i14 i2 bijective_regular mapping_regular regular_closed_star regular_conv_closed regular_mult_closed by auto
+      hence 34: "?q \<sqinter> p0\<^sup>T\<^sup>\<star> * x = ?p \<sqinter> p0\<^sup>T\<^sup>\<star> * x"
+        using 31 32 by (metis inf_sup_distrib1)
+      have 35: "regular (p0\<^sup>T\<^sup>\<star> * x)"
+        using i13 i2 bijective_regular mapping_regular regular_closed_star regular_conv_closed regular_mult_closed by auto
       have "-(p0\<^sup>T\<^sup>\<star> * x) \<le> -w"
-        by (simp add: i16 p_antitone)
+        by (simp add: i15 p_antitone)
       hence "?q \<sqinter> -(p0\<^sup>T\<^sup>\<star> * x) = ?p \<sqinter> -(p0\<^sup>T\<^sup>\<star> * x)"
-        by (metis i13 p_antitone_inf update_inf_different)
+        by (metis i12 p_antitone_inf update_inf_different)
       thus ?thesis
-        using 35 36 by (metis maddux_3_11_pp)
+        using 34 35 by (metis maddux_3_11_pp)
     qed
     show "card ?t < card ?s"
     proof -
       have "?p\<^sup>T * p\<^sup>T\<^sup>\<star> * w = (w\<^sup>T \<sqinter> y) * p\<^sup>T\<^sup>\<star> * w \<squnion> (-w\<^sup>T \<sqinter> p\<^sup>T) * p\<^sup>T\<^sup>\<star> * w"
         by (simp add: conv_complement conv_dist_inf conv_dist_sup mult_right_dist_sup)
       also have "... \<le> (w\<^sup>T \<sqinter> y) * p\<^sup>T\<^sup>\<star> * w \<squnion> p\<^sup>T * p\<^sup>T\<^sup>\<star> * w"
         using mult_left_isotone sup_right_isotone by auto
       also have "... \<le> (w\<^sup>T \<sqinter> y) * p\<^sup>T\<^sup>\<star> * w \<squnion> p\<^sup>T\<^sup>\<star> * w"
         using mult_left_isotone star.left_plus_below_circ sup_right_isotone by blast
       also have "... \<le> y * p\<^sup>T\<^sup>\<star> * w \<squnion> p\<^sup>T\<^sup>\<star> * w"
         using semiring.add_right_mono mult_left_isotone by auto
       also have "... \<le> y * top \<squnion> p\<^sup>T\<^sup>\<star> * w"
         by (simp add: comp_associative le_supI1 mult_right_isotone)
       also have "... = p\<^sup>T\<^sup>\<star> * w"
         by (simp add: i3 i6 sup_absorb2)
       finally have "?p\<^sup>T\<^sup>\<star> * p\<^sup>T * w \<le> p\<^sup>T\<^sup>\<star> * w"
         using 11 by (metis dual_order.trans star.circ_loop_fixpoint sup_commute sup_ge2 mult_assoc)
-      hence 37: "?t \<subseteq> ?s"
+      hence 36: "?t \<subseteq> ?s"
         using order_lesseq_imp mult_assoc by auto
-      have 38: "w \<in> ?s"
+      have 37: "w \<in> ?s"
         by (simp add: i5 bijective_regular path_compression_1b)
-      have 39: "\<not> w \<in> ?t"
+      have 38: "\<not> w \<in> ?t"
       proof
         assume "w \<in> ?t"
-        hence 40: "w \<le> (?p\<^sup>T \<sqinter> -1)\<^sup>\<star> * (p[[w]])"
+        hence 39: "w \<le> (?p\<^sup>T \<sqinter> -1)\<^sup>\<star> * (p[[w]])"
           using reachable_without_loops by auto
         hence "p[[w]] \<le> (?p \<sqinter> -1)\<^sup>\<star> * w"
           using 2 by (smt i5 bijective_reverse conv_star_commute reachable_without_loops)
         also have "... \<le> p\<^sup>\<star> * w"
         proof -
           have "p\<^sup>T\<^sup>\<star> * y = y"
             using i1 i4 root_transitive_successor_loop by auto
           hence "y\<^sup>T * p\<^sup>\<star> * w = y\<^sup>T * w"
             by (metis conv_dist_comp conv_involutive conv_star_commute)
           also have "... = bot"
             using 5 by (metis i5 inf.idem inf.sup_monoid.add_commute mult_left_zero schroeder_1 vector_inf_comp)
-          finally have 41: "y\<^sup>T * p\<^sup>\<star> * w = bot"
+          finally have 40: "y\<^sup>T * p\<^sup>\<star> * w = bot"
             by simp
           have "(?p \<sqinter> -1) * p\<^sup>\<star> * w = (w \<sqinter> y\<^sup>T \<sqinter> -1) * p\<^sup>\<star> * w \<squnion> (-w \<sqinter> p \<sqinter> -1) * p\<^sup>\<star> * w"
             by (simp add: comp_inf.mult_right_dist_sup mult_right_dist_sup)
           also have "... \<le> (w \<sqinter> y\<^sup>T \<sqinter> -1) * p\<^sup>\<star> * w \<squnion> p * p\<^sup>\<star> * w"
             by (meson inf_le1 inf_le2 mult_left_isotone order_trans sup_right_isotone)
           also have "... \<le> (w \<sqinter> y\<^sup>T \<sqinter> -1) * p\<^sup>\<star> * w \<squnion> p\<^sup>\<star> * w"
             using mult_left_isotone star.left_plus_below_circ sup_right_isotone by blast
           also have "... \<le> y\<^sup>T * p\<^sup>\<star> * w \<squnion> p\<^sup>\<star> * w"
             by (meson inf_le1 inf_le2 mult_left_isotone order_trans sup_left_isotone)
           also have "... = p\<^sup>\<star> * w"
-            using 41 by simp
+            using 40 by simp
           finally show ?thesis
             by (metis comp_associative le_supI star.circ_loop_fixpoint sup_ge2 star_left_induct)
         qed
         finally have "w \<le> p\<^sup>T\<^sup>\<star> * p\<^sup>T * w"
-          using 11 40 reachable_without_loops star_plus by auto
+          using 11 39 reachable_without_loops star_plus by auto
         thus False
           using 4 i1 i10 i5 loop_root_2 star.circ_plus_same by auto
       qed
       show "card ?t < card ?s"
         apply (rule psubset_card_mono)
         subgoal using finite_regular by simp
-        subgoal using 37 38 39 by auto
+        subgoal using 36 37 38 by auto
         done
     qed
   qed
 qed
 
 lemma path_compression_3a:
   assumes "path_compression_invariant p x (p[[w]]) p0 w"
   shows "p0[p0\<^sup>T\<^sup>\<star> * x\<longmapsto>p[[w]]] = p"
 proof -
   let ?y = "p[[w]]"
   let ?p = "p0[p0\<^sup>T\<^sup>\<star> * x\<longmapsto>?y]"
   have i1: "disjoint_set_forest p" and i2: "point x" and i3: "point ?y" and i4: "?y = root p x"
     using assms path_compression_invariant_def path_compression_precondition_def by meson+
   have i5: "point w" and i6: "?y \<le> p\<^sup>T\<^sup>\<star> * w"
     and i7: "w \<noteq> x \<longrightarrow> p[[x]] = ?y \<and> ?y \<noteq> x \<and> p\<^sup>T\<^sup>+ * w \<le> -x" and i8: "p \<sqinter> 1 = p0 \<sqinter> 1" and i9: "fc p = fc p0"
-    and i10: "root p w = ?y" and i11: "w \<noteq> ?y \<longrightarrow> p[[w]] \<noteq> w" and i12: "p[[w]] = p0[[w]]" and i13: "p0[p0\<^sup>T\<^sup>\<star> * x \<sqinter> -(p0\<^sup>T\<^sup>\<star> * w)\<longmapsto>?y] = p"
-    and i14: "disjoint_set_forest p0" and i15: "?y = root p0 x" and i16: "w \<le> p0\<^sup>T\<^sup>\<star> * x"
+    and i10: "root p w = ?y" and i11: "p[[w]] = p0[[w]]" and i12: "p0[p0\<^sup>T\<^sup>\<star> * x \<sqinter> -(p0\<^sup>T\<^sup>\<star> * w)\<longmapsto>?y] = p"
+    and i13: "disjoint_set_forest p0" and i14: "?y = root p0 x" and i15: "w \<le> p0\<^sup>T\<^sup>\<star> * x"
     using assms path_compression_invariant_def by blast+
   have 1: "?p \<sqinter> ?y = p \<sqinter> ?y"
-    by (metis i1 i15 i3 i4 get_put inf_le1 root_successor_loop update_inf update_inf_same)
+    by (metis i1 i14 i3 i4 get_put inf_le1 root_successor_loop update_inf update_inf_same)
   have 2: "?p \<sqinter> w = p \<sqinter> w"
-    by (metis i5 i12 i16 get_put update_inf update_inf_same)
+    by (metis i5 i11 i15 get_put update_inf update_inf_same)
   have "?y = root p0 w"
-    by (metis i1 i10 i14 i8 i9 same_root)
+    by (metis i1 i10 i13 i8 i9 same_root)
   hence "p0\<^sup>T\<^sup>\<star> * w = w \<squnion> ?y"
-    by (metis i12 i14 root_transitive_successor_loop star.circ_loop_fixpoint star_plus sup_monoid.add_commute mult_assoc)
+    by (metis i11 i13 root_transitive_successor_loop star.circ_loop_fixpoint star_plus sup_monoid.add_commute mult_assoc)
   hence 3: "?p \<sqinter> p0\<^sup>T\<^sup>\<star> * w = p \<sqinter> p0\<^sup>T\<^sup>\<star> * w"
     using 1 2 by (simp add: inf_sup_distrib1)
   have "p0\<^sup>T\<^sup>\<star> * w \<le> p0\<^sup>T\<^sup>\<star> * x"
-    by (metis i16 comp_associative mult_right_isotone star.circ_transitive_equal)
+    by (metis i15 comp_associative mult_right_isotone star.circ_transitive_equal)
   hence 4: "?p \<sqinter> (p0\<^sup>T\<^sup>\<star> * x \<sqinter> p0\<^sup>T\<^sup>\<star> * w) = p \<sqinter> (p0\<^sup>T\<^sup>\<star> * x \<sqinter> p0\<^sup>T\<^sup>\<star> * w)"
     using 3 by (simp add: inf.absorb2)
   have 5: "?p \<sqinter> (p0\<^sup>T\<^sup>\<star> * x \<sqinter> -(p0\<^sup>T\<^sup>\<star> * w)) = p \<sqinter> (p0\<^sup>T\<^sup>\<star> * x \<sqinter> -(p0\<^sup>T\<^sup>\<star> * w))"
-    by (metis i13 inf_le1 update_inf update_inf_same)
+    by (metis i12 inf_le1 update_inf update_inf_same)
   have "regular (p0\<^sup>T\<^sup>\<star> * w)"
-    using i14 i5 bijective_regular mapping_regular regular_closed_star regular_conv_closed regular_mult_closed by auto
+    using i13 i5 bijective_regular mapping_regular regular_closed_star regular_conv_closed regular_mult_closed by auto
   hence 6: "?p \<sqinter> p0\<^sup>T\<^sup>\<star> * x = p \<sqinter> p0\<^sup>T\<^sup>\<star> * x"
     using 4 5 by (smt inf_sup_distrib1 maddux_3_11_pp)
   have 7: "?p \<sqinter> -(p0\<^sup>T\<^sup>\<star> * x) = p \<sqinter> -(p0\<^sup>T\<^sup>\<star> * x)"
-    by (smt i13 inf.sup_monoid.add_commute inf_import_p inf_sup_absorb le_iff_inf p_dist_inf update_inf_different inf.idem p_antitone_inf)
+    by (smt i12 inf.sup_monoid.add_commute inf_import_p inf_sup_absorb le_iff_inf p_dist_inf update_inf_different inf.idem p_antitone_inf)
   have "regular (p0\<^sup>T\<^sup>\<star> * x)"
-    using i14 i2 bijective_regular mapping_regular regular_closed_star regular_conv_closed regular_mult_closed by auto
+    using i13 i2 bijective_regular mapping_regular regular_closed_star regular_conv_closed regular_mult_closed by auto
   thus "?p = p"
     using 6 7 by (smt inf_sup_distrib1 maddux_3_11_pp)
 qed
 
 lemma path_compression_3:
   "path_compression_invariant p x (p[[w]]) p0 w \<Longrightarrow> path_compression_postcondition p x (p[[w]]) p0"
   using path_compression_invariant_def path_compression_postcondition_def path_compression_precondition_def path_compression_3a by blast
 
 theorem path_compression:
   "VARS p t w
   [ path_compression_precondition p x y \<and> p0 = p ]
   w := x;
   WHILE y \<noteq> p[[w]]
     INV { path_compression_invariant p x y p0 w }
     VAR { card { z . regular z \<and> z \<le> p\<^sup>T\<^sup>\<star> * w } }
      DO t := w;
         w := p[[w]];
         p[t] := y
      OD
   [ path_compression_postcondition p x y p0 ]"
   apply vcg_tc_simp
     apply (fact path_compression_1)
    apply (fact path_compression_2)
   using path_compression_3 by auto
 
 lemma path_compression_exists:
   "path_compression_precondition p x y \<Longrightarrow> \<exists>p' . path_compression_postcondition p' x y p"
   using tc_extract_function path_compression by blast
 
 definition "path_compression p x y \<equiv> (SOME p' . path_compression_postcondition p' x y p)"
 
 lemma path_compression_function:
   assumes "path_compression_precondition p x y"
     and "p' = path_compression p x y"
   shows "path_compression_postcondition p' x y p"
   by (metis assms path_compression_def path_compression_exists someI)
 
 subsection \<open>Find-Set with Path Compression\<close>
 
 text \<open>
 We sequentially combine find-set and path compression.
 We consider implementations which use the previously derived functions and implementations which unfold their definitions.
 \<close>
 
 theorem find_set_path_compression:
   "VARS p y
   [ find_set_precondition p x \<and> p0 = p ]
   y := find_set p x;
   p := path_compression p x y
   [ path_compression_postcondition p x y p0 ]"
   apply vcg_tc_simp
   using find_set_function find_set_postcondition_def find_set_precondition_def path_compression_function path_compression_precondition_def by fastforce
 
 theorem find_set_path_compression_1:
   "VARS p t w y
   [ find_set_precondition p x \<and> p0 = p ]
   y := find_set p x;
   w := x;
   WHILE y \<noteq> p[[w]]
     INV { path_compression_invariant p x y p0 w }
     VAR { card { z . regular z \<and> z \<le> p\<^sup>T\<^sup>\<star> * w } }
      DO t := w;
         w := p[[w]];
         p[t] := y
      OD
   [ path_compression_postcondition p x y p0 ]"
   apply vcg_tc_simp
     using find_set_function find_set_postcondition_def find_set_precondition_def path_compression_1 path_compression_precondition_def apply fastforce
    apply (fact path_compression_2)
   by (fact path_compression_3)
 
 theorem find_set_path_compression_2:
   "VARS p y
   [ find_set_precondition p x \<and> p0 = p ]
   y := x;
   WHILE y \<noteq> p[[y]]
     INV { find_set_invariant p x y \<and> p0 = p }
     VAR { card { z . regular z \<and> z \<le> p\<^sup>T\<^sup>\<star> * y } }
      DO y := p[[y]]
      OD;
   p := path_compression p x y
   [ path_compression_postcondition p x y p0 ]"
   apply vcg_tc_simp
     apply (fact find_set_1)
    apply (fact find_set_2)
   by (smt find_set_3 find_set_invariant_def find_set_postcondition_def find_set_precondition_def path_compression_function path_compression_precondition_def)
 
 theorem find_set_path_compression_3:
   "VARS p t w y
   [ find_set_precondition p x \<and> p0 = p ]
   y := x;
   WHILE y \<noteq> p[[y]]
     INV { find_set_invariant p x y \<and> p0 = p }
     VAR { card { z . regular z \<and> z \<le> p\<^sup>T\<^sup>\<star> * y } }
      DO y := p[[y]]
      OD;
   w := x;
   WHILE y \<noteq> p[[w]]
     INV { path_compression_invariant p x y p0 w }
     VAR { card { z . regular z \<and> z \<le> p\<^sup>T\<^sup>\<star> * w } }
      DO t := w;
         w := p[[w]];
         p[t] := y
      OD
   [ path_compression_postcondition p x y p0 ]"
   apply vcg_tc_simp
       apply (simp add: find_set_1)
      apply (fact find_set_2)
     using find_set_3 find_set_invariant_def find_set_postcondition_def find_set_precondition_def path_compression_1 path_compression_precondition_def apply blast
    apply (fact path_compression_2)
   by (fact path_compression_3)
 
 text \<open>
 Find-set with path compression returns two results: the representative of the tree and the modified disjoint-set forest.
 \<close>
 
 lemma find_set_path_compression_exists:
   "find_set_precondition p x \<Longrightarrow> \<exists>p' y . path_compression_postcondition p' x y p"
   using tc_extract_function find_set_path_compression by blast
 
 definition "find_set_path_compression p x \<equiv> (SOME (p',y) . path_compression_postcondition p' x y p)"
 
 lemma find_set_path_compression_function:
   assumes "find_set_precondition p x"
     and "(p',y) = find_set_path_compression p x"
   shows "path_compression_postcondition p' x y p"
 proof -
   let ?P = "\<lambda>(p',y) . path_compression_postcondition p' x y p"
   have "?P (SOME z . ?P z)"
     apply (unfold some_eq_ex)
     using assms(1) find_set_path_compression_exists by simp
   thus ?thesis
     using assms(2) find_set_path_compression_def by auto
 qed
 
 text \<open>
 We prove that \<open>find_set_path_compression\<close> returns the same representative as \<open>find_set\<close>.
 \<close>
 
 lemma find_set_path_compression_find_set:
   assumes "find_set_precondition p x"
   shows "find_set p x = snd (find_set_path_compression p x)"
 proof -
   let ?r = "find_set p x"
   let ?p = "fst (find_set_path_compression p x)"
   let ?y = "snd (find_set_path_compression p x)"
   have 1: "find_set_postcondition p x ?r"
     by (simp add: assms find_set_function)
   have "path_compression_postcondition ?p x ?y p"
     using assms find_set_path_compression_function prod.collapse by blast
   thus "?r = ?y"
     using 1 by (smt assms same_root find_set_precondition_def find_set_postcondition_def path_compression_precondition_def path_compression_postcondition_def)
 qed
 
 text \<open>
 A weaker postcondition suffices to prove that the two forests have the same semantics; that is, they describe the same disjoint sets and have the same roots.
 \<close>
 
 lemma find_set_path_compression_path_compression_semantics:
   assumes "find_set_precondition p x"
   shows "fc (path_compression p x (find_set p x)) = fc (fst (find_set_path_compression p x))"
     and "path_compression p x (find_set p x) \<sqinter> 1 = fst (find_set_path_compression p x) \<sqinter> 1"
 proof -
   let ?r = "find_set p x"
   let ?q = "path_compression p x ?r"
   let ?p = "fst (find_set_path_compression p x)"
   let ?y = "snd (find_set_path_compression p x)"
   have 1: "path_compression_postcondition (path_compression p x ?r) x ?r p"
     using assms find_set_function find_set_postcondition_def find_set_precondition_def path_compression_function path_compression_precondition_def by auto
   have 2: "path_compression_postcondition ?p x ?y p"
     using assms find_set_path_compression_function prod.collapse by blast
   show "fc ?q = fc ?p"
     using 1 2 by (simp add: path_compression_postcondition_def)
   show "?q \<sqinter> 1 = ?p \<sqinter> 1"
     using 1 2 by (simp add: path_compression_postcondition_def)
 qed
 
 text \<open>
 With the current, stronger postcondition of path compression describing the precise effect of how links change, we can prove that the two forests are actually equal.
 \<close>
 
 lemma find_set_path_compression_find_set_pathcompression:
   assumes "find_set_precondition p x"
   shows "path_compression p x (find_set p x) = fst (find_set_path_compression p x)"
 proof -
   let ?r = "find_set p x"
   let ?q = "path_compression p x ?r"
   let ?p = "fst (find_set_path_compression p x)"
   let ?y = "snd (find_set_path_compression p x)"
   have 1: "path_compression_postcondition (path_compression p x ?r) x ?r p"
     using assms find_set_function find_set_postcondition_def find_set_precondition_def path_compression_function path_compression_precondition_def by auto
   have 2: "path_compression_postcondition ?p x ?y p"
     using assms find_set_path_compression_function prod.collapse by blast
   have "?r = ?y"
     by (simp add: assms find_set_path_compression_find_set)
   thus "?q = ?p"
     using 1 2 by (simp add: path_compression_postcondition_def)
 qed
 
 subsection \<open>Union-Sets\<close>
 
 text \<open>
 We only consider a naive union-sets operation (without ranks).
 The semantics is the equivalence closure obtained after adding the link between the two given nodes, 
 which requires those two elements to be in the same set.
 The implementation uses temporary variable \<open>t\<close> to store the two results returned by find-set with path compression.
 The disjoint-set forest, which keeps being updated, is threaded through the sequence of operations.
 \<close>
 
 definition "union_sets_precondition p x y \<equiv> disjoint_set_forest p \<and> point x \<and> point y"
 definition "union_sets_postcondition p x y p0 \<equiv> union_sets_precondition p x y \<and> fc p = wcc (p0 \<squnion> x * y\<^sup>T)"
 
 lemma union_sets_1:
   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[r\<longmapsto>s]) x y p0"
 proof (unfold union_sets_postcondition_def union_sets_precondition_def, intro conjI)
   let ?p = "p2[r\<longmapsto>s]"
   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 \<sqinter> -1)"
   proof (cases "r = s")
     case True
     thus ?thesis
       using 2 update_acyclic_5 by fastforce
   next
     case False
     hence "bot = r \<sqinter> s"
       using 1 2 distinct_points by blast
     also have "... = r \<sqinter> p2\<^sup>T\<^sup>\<star> * s"
       using 2 by (smt root_transitive_successor_loop)
     finally have "s \<sqinter> p2\<^sup>\<star> * r = 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 "r = p1[[r]]"
       using 1 by (metis root_successor_loop)
     hence "r * r\<^sup>T \<le> p1\<^sup>T"
       using 1 eq_refl shunt_bijective by blast
     hence "r * r\<^sup>T \<le> p1"
       using 1 conv_order coreflexive_symmetric by fastforce
     hence "r * r\<^sup>T \<le> p1 \<sqinter> 1"
       using 1 inf.boundedI by blast
     also have "... = p2 \<sqinter> 1"
       using 2 by simp
     finally have "r * r\<^sup>T \<le> p2"
       by simp
     hence "r \<le> p2 * r"
       using 1 shunt_bijective by blast
     hence 5: "p2[[r]] \<le> r"
       using 2 shunt_mapping by blast
     have "r \<sqinter> p2 \<le> r * (top \<sqinter> r\<^sup>T * p2)"
       using 1 by (metis dedekind_1)
     also have "... = r * r\<^sup>T * p2"
       by (simp add: mult_assoc)
     also have "... \<le> r * r\<^sup>T"
       using 5 by (metis comp_associative conv_dist_comp conv_involutive conv_order mult_right_isotone)
     also have "... \<le> 1"
       using 1 by blast
     finally have 6: "r \<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 ((-r \<sqinter> p2) \<squnion> (r \<sqinter> p2))"
         using 1 by (metis bijective_regular inf.sup_monoid.add_commute maddux_3_11_pp)
       also have "... \<le> wcc ((-r \<sqinter> p2) \<squnion> 1)"
         using 6 wcc_isotone sup_right_isotone by simp
       also have "... = wcc (-r \<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 "r \<le> p1\<^sup>T\<^sup>\<star> * x"
       using 1 by (metis inf_le1)
     hence 9: "r * x\<^sup>T \<le> p1\<^sup>T\<^sup>\<star>"
       using assms(1) shunt_bijective union_sets_precondition_def by blast
     hence "x * r\<^sup>T \<le> p1\<^sup>\<star>"
       using conv_dist_comp conv_order conv_star_commute by force
     also have "... \<le> wcc p1"
       by (simp add: star.circ_sub_dist)
     also have "... = wcc p2"
       using 1 2 by (simp add: fc_wcc)
     also have "... \<le> wcc ?p"
       using 7 by simp
     finally have 10: "x * r\<^sup>T \<le> wcc ?p"
       by simp
     have 11: "r * s\<^sup>T \<le> wcc ?p"
       using 1 2 star.circ_sub_dist_1 sup_assoc vector_covector by auto
     have "s \<le> p2\<^sup>T\<^sup>\<star> * y"
       using 2 by (metis inf_le1)
     hence 12: "s * y\<^sup>T \<le> p2\<^sup>T\<^sup>\<star>"
       using assms(1) shunt_bijective union_sets_precondition_def by blast
     also have "... \<le> wcc p2"
       using star_isotone sup_ge2 by blast
     also have "... \<le> wcc ?p"
       using 7 by simp
     finally have 13: "s * y\<^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 "x * y\<^sup>T \<le> x * r\<^sup>T * r * (y * s\<^sup>T * s)\<^sup>T"
       using comp_isotone conv_isotone by blast
     also have "... = x * r\<^sup>T * r * s\<^sup>T * s * y\<^sup>T"
       by (simp add: comp_associative conv_dist_comp)
     also have "... \<le> wcc ?p * (r * s\<^sup>T) * (s * y\<^sup>T)"
       using 10 by (metis mult_left_isotone mult_assoc)
     also have "... \<le> wcc ?p * wcc ?p * (s * y\<^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 "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 "-r \<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> x * y\<^sup>T)"
       by (simp add: wcc_isotone)
     finally have 14: "-r \<sqinter> p2 \<le> wcc (p0 \<squnion> x * y\<^sup>T)"
       by simp
     have "r * x\<^sup>T \<le> wcc p1"
       using 9 inf.order_trans 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> x * y\<^sup>T)"
       by (simp add: wcc_isotone)
     finally have 15: "r * x\<^sup>T \<le> wcc (p0 \<squnion> x * y\<^sup>T)"
       by simp
     have 16: "x * y\<^sup>T \<le> wcc (p0 \<squnion> x * y\<^sup>T)"
       using le_supE star.circ_sub_dist_1 by blast
     have "y * s\<^sup>T \<le> p2\<^sup>\<star>"
       using 12 conv_dist_comp conv_order conv_star_commute by fastforce
     also have "... \<le> wcc p2"
       using star.circ_sub_dist sup_commute by fastforce
     also have "... = wcc p0"
       using 3 by (simp add: star_decompose_1)
     also have "... \<le> wcc (p0 \<squnion> x * y\<^sup>T)"
       by (simp add: wcc_isotone)
     finally have 17: "y * s\<^sup>T \<le> wcc (p0 \<squnion> x * y\<^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 "r * s\<^sup>T \<le> r * x\<^sup>T * x * (s * y\<^sup>T * y)\<^sup>T"
       using comp_isotone conv_isotone by blast
     also have "... = r * x\<^sup>T * x * y\<^sup>T * y * s\<^sup>T"
       by (simp add: comp_associative conv_dist_comp)
     also have "... \<le> wcc (p0 \<squnion> x * y\<^sup>T) * (x * y\<^sup>T) * (y * s\<^sup>T)"
       using 15 by (metis mult_left_isotone mult_assoc)
     also have "... \<le> wcc (p0 \<squnion> x * y\<^sup>T) * wcc (p0 \<squnion> x * y\<^sup>T) * (y * s\<^sup>T)"
       using 16 by (metis mult_left_isotone mult_right_isotone)
     also have "... \<le> wcc (p0 \<squnion> x * y\<^sup>T) * wcc (p0 \<squnion> x * y\<^sup>T) * wcc (p0 \<squnion> x * y\<^sup>T)"
       using 17 by (metis mult_right_isotone)
     also have "... = wcc (p0 \<squnion> x * y\<^sup>T)"
       by (simp add: star.circ_transitive_equal)
     finally have "?p \<le> wcc (p0 \<squnion> x * y\<^sup>T)"
       using 1 2 14 vector_covector by auto
     hence "wcc ?p \<le> wcc (p0 \<squnion> x * y\<^sup>T)"
       using wcc_below_wcc by blast
     thus "fc ?p \<le> wcc (p0 \<squnion> x * y\<^sup>T)"
       using 4 fc_wcc by simp
   qed
 qed
 
 theorem union_sets:
   "VARS p r s t
   [ union_sets_precondition p x y \<and> p0 = p ]
   t := find_set_path_compression p x;
   p := fst t;
   r := snd t;
   t := find_set_path_compression p y;
   p := fst t;
   s := snd t;
   p[r] := s
   [ union_sets_postcondition p x y p0 ]"
 proof vcg_tc_simp
   let ?t1 = "find_set_path_compression p0 x"
   let ?p1 = "fst ?t1"
   let ?r = "snd ?t1"
   let ?t2 = "find_set_path_compression ?p1 y"
   let ?p2 = "fst ?t2"
   let ?s = "snd ?t2"
   let ?p = "?p2[?r\<longmapsto>?s]"
   assume 1: "union_sets_precondition p0 x y"
   hence 2: "path_compression_postcondition ?p1 x ?r p0"
     by (simp add: find_set_precondition_def union_sets_precondition_def find_set_path_compression_function)
   hence "path_compression_postcondition ?p2 y ?s ?p1"
     using 1 by (meson find_set_precondition_def union_sets_precondition_def find_set_path_compression_function path_compression_postcondition_def path_compression_precondition_def prod.collapse)
   thus "union_sets_postcondition (?p2[?r\<longmapsto>?s]) x y p0"
     using 1 2 by (simp add: union_sets_1)
 qed
 
 lemma union_sets_exists:
   "union_sets_precondition p x y \<Longrightarrow> \<exists>p' . union_sets_postcondition p' x y p"
   using tc_extract_function union_sets by blast
 
 definition "union_sets p x y \<equiv> (SOME p' . union_sets_postcondition p' x y p)"
 
 lemma union_sets_function:
   assumes "union_sets_precondition p x y"
     and "p' = union_sets p x y"
   shows "union_sets_postcondition p' x y p"
   by (metis assms union_sets_def union_sets_exists someI)
 
 theorem union_sets_2:
-  "VARS p r s t
+  "VARS p r s
   [ union_sets_precondition p x y \<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;
   p[r] := s
   [ union_sets_postcondition p x y p0 ]"
 proof vcg_tc_simp
   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"
   assume 1: "union_sets_precondition p0 x y"
   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 "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
   thus "union_sets_postcondition (?p2[?r\<longmapsto>?s]) x y p0"
     using 1 2 by (simp add: union_sets_1)
 qed
 
 end
 
 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
new file mode 100644
--- /dev/null
+++ b/thys/Relational_Disjoint_Set_Forests/More_Disjoint_Set_Forests.thy
@@ -0,0 +1,3175 @@
+(* 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 \<sqinter> -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 \<sqinter> -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 \<sqinter> -1"
+    using assms(2) p_shunting_swap pp_dist_comp by auto
+  hence "x\<^sup>\<star> * (x \<sqinter> -(top * (x \<sqinter> 1))) \<le> (x \<sqinter> -1)\<^sup>\<star> * (x \<sqinter> -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 \<sqinter> -1)\<^sup>\<star> \<sqinter> (x \<sqinter> -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 \<sqinter> -1)"
+    shows "x * x \<sqinter> 1 = x \<sqinter> 1"
+proof (rule order.antisym)
+  have "1 \<sqinter> x * x = 1 \<sqinter> ((x \<sqinter> -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 \<sqinter> -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 \<sqinter> -1) * (x \<sqinter> -1) \<squnion> (x \<sqinter> -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 \<sqinter> -1) * (x \<sqinter> -1)) \<squnion> (x \<sqinter> -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 \<sqinter> -1)\<^sup>+) \<squnion> (x \<sqinter> -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 \<sqinter> -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 \<sqinter> -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 \<sqinter> -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 \<sqinter> -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 \<sqinter> -1)"
+  shows "x\<^sup>+ \<sqinter> 1 = x \<sqinter> 1"
+proof -
+  let ?r = "x \<sqinter> 1"
+  let ?i = "x \<sqinter> -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> \<sqinter> -1 = (x \<sqinter> -1)\<^sup>+ \<sqinter> -1"
+  by (metis reachable_without_loops star_plus_without_loops)
+
+text \<open>Theorem 6.3\<close>
+
+lemma star_irreflexive_part:
+  "x\<^sup>\<star> \<sqinter> -1 \<le> (x \<sqinter> -1)\<^sup>+"
+  using star_irreflexive_part_eq by auto
+
+lemma square_irreflexive_part:
+  "x * x \<sqinter> -1 \<le> (x \<sqinter> -1)\<^sup>+"
+proof -
+  have "x * x = (x \<sqinter> 1) * x \<squnion> (x \<sqinter> -1) * x"
+    by (metis maddux_3_11_pp mult_right_dist_sup regular_one_closed)
+  also have "... \<le> 1 * x \<squnion> (x \<sqinter> -1) * x"
+    using comp_isotone inf.cobounded2 semiring.add_right_mono by blast
+  also have "... \<le> 1 \<squnion> (x \<sqinter> -1) \<squnion> (x \<sqinter> -1) * x"
+    by (metis inf.cobounded2 maddux_3_11_pp mult_1_left regular_one_closed sup_left_isotone)
+  also have "... = (x \<sqinter> -1) * (x \<squnion> 1) \<squnion> 1"
+    by (simp add: mult_left_dist_sup sup_assoc sup_commute)
+  finally have "x * x \<sqinter> -1 \<le> (x \<sqinter> -1) * (x \<squnion> 1)"
+    using shunting_var_p by auto
+  also have "... = (x \<sqinter> -1) * (x \<sqinter> -1) \<squnion> (x \<sqinter> -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 \<sqinter> -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 \<sqinter> -1 \<le> x\<^sup>\<star> \<sqinter> -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 \<sqinter> -1)"
+  shows "acyclic ((x[y\<longmapsto>(x * x)\<^sup>T]) \<sqinter> -1)"
+proof -
+  have "((x[y\<longmapsto>(x * x)\<^sup>T]) \<sqinter> -1)\<^sup>+ \<le> ((x \<squnion> x * x) \<sqinter> -1)\<^sup>+"
+    by (metis comp_inf.mult_right_isotone comp_isotone inf.sup_monoid.add_commute star_isotone update_square_ub)
+  also have "... = ((x \<sqinter> -1) \<squnion> (x * x \<sqinter> -1))\<^sup>+"
+    using comp_inf.semiring.distrib_right by auto
+  also have "... \<le> ((x \<sqinter> -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]) \<sqinter> -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"
+
+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 ]
+  h := top;
+  WHILE h \<noteq> bot
+    INV { regular h \<and> vector h \<and> p \<sqinter> -h = 1 \<sqinter> -h }
+    VAR { card { x . regular x \<and> x \<le> h } }
+     DO x := choose_point h;
+        p := make_set p x;
+        h[x] := bot
+     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 \<sqinter> -h = 1 \<sqinter> -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 } < card { x . regular x \<and> x \<le> h }"
+  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 \<sqinter> -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 \<sqinter> -h)"
+      using 1 3 4 inf.absorb2 inf.sup_monoid.add_assoc inf_commute by auto
+    also have "... = (1 \<sqinter> ?x) \<squnion> (1 \<sqinter> -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 } < card { x . regular x \<and> x \<le> h }"
+      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 \<sqinter> -(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 \<sqinter> -(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 \<sqinter> -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 \<sqinter> -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 \<sqinter> -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 \<sqinter> -p0)"
+      by (simp add: conv_dist_comp conv_star_commute)
+    also have "... = (?px \<sqinter> x\<^sup>T) * ?p2\<^sup>\<star> * (1 \<sqinter> -p0)"
+      using 2 vector_inf_comp by auto
+    also have "... = ?p2ts * (x * x\<^sup>T) * ?p2\<^sup>\<star> * (1 \<sqinter> -p0)"
+      using 2 vector_covector mult_assoc by auto
+    also have "... \<le> ?p2ts * ?p2\<^sup>\<star> * (1 \<sqinter> -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 \<sqinter> -p0)"
+      using 4 by (simp add: cancel_separate_eq)
+    also have "... = (?p2ts \<squnion> ?p2\<^sup>+) * (1 \<sqinter> -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 \<sqinter> - (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 \<sqinter> -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> card { z . regular z \<and> z \<le> (p[y\<longmapsto>p[[p[[y]]]]])\<^sup>T\<^sup>\<star> * ((p[y\<longmapsto>p[[p[[y]]]]])[[y]]) } < card { z . regular z \<and> z \<le> p\<^sup>T\<^sup>\<star> * y }"
+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> card { z . regular z \<and> z \<le> ?pyppy\<^sup>T\<^sup>\<star> * (?pyppy[[y]]) } < card { z . regular z \<and> z \<le> p\<^sup>T\<^sup>\<star> * y }"
+  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 \<sqinter> -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 \<sqinter> -(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 \<sqinter> -(p0\<^sup>T\<^sup>\<star> * (?pyppy[[y]]))\<longmapsto>?p2t] = p0[?px \<sqinter> -(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 \<sqinter> -?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 \<sqinter> -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 \<sqinter> -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 \<sqinter> -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 \<sqinter> -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 { card { z . regular z \<and> z \<le> p\<^sup>T\<^sup>\<star> * y } }
+     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 \<sqinter> -(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 \<sqinter> -(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 \<sqinter> -(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 \<sqinter> -(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 \<sqinter> - (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 \<sqinter> -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> card { z . regular z \<and> z \<le> (p[y\<longmapsto>p[[p[[y]]]]])\<^sup>T\<^sup>\<star> * (p[[y]]) } < card { z . regular z \<and> z \<le> p\<^sup>T\<^sup>\<star> * y }"
+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> card { z . regular z \<and> z \<le> ?pyppy\<^sup>T\<^sup>\<star> * (p[[y]]) } < card { z . regular z \<and> z \<le> p\<^sup>T\<^sup>\<star> * y }"
+  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 \<sqinter> -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 \<sqinter> -(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 \<sqinter> -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 \<sqinter> -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 \<sqinter> -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 \<sqinter> -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 { card { z . regular z \<and> z \<le> p\<^sup>T\<^sup>\<star> * y } }
+     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 +
+  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 \<sqinter> -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 \<sqinter> -M"
+proof -
+  have "S' = S * (1 \<sqinter> -Z\<^sup>T)"
+    by (simp add: Z_point covector_comp_inf vector_conv_compl)
+  also have "... = S * (1 \<sqinter> -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 \<sqinter> -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 \<sqinter> -1) * rank \<le> rank * S'\<^sup>+ \<and> card_less_eq ((p \<sqinter> 1) * top) (-(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_rank:
+  "VARS h p x rank
+  [ True ]
+  h := top;
+  WHILE h \<noteq> bot
+    INV { regular h \<and> vector h \<and> p \<sqinter> -h = 1 \<sqinter> -h \<and> rank \<sqinter> -h = Z\<^sup>T \<sqinter> -h }
+    VAR { card { x . regular x \<and> x \<le> h } }
+     DO x := choose_point h;
+        p := make_set p x;
+        rank[x] := Z;
+        h[x] := bot
+     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 \<sqinter> -h = 1 \<sqinter> -h \<and> rank \<sqinter> -h = Z\<^sup>T \<sqinter> -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 } < card { x . regular x \<and> x \<le> h }"
+  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 \<sqinter> -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 \<sqinter> -h)"
+      using 1 3 4 inf.absorb2 inf.sup_monoid.add_assoc inf_commute by auto
+    also have "... = (1 \<sqinter> ?x) \<squnion> (1 \<sqinter> -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 \<sqinter> -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 \<sqinter> -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 } < card { x . regular x \<and> x \<le> h }"
+      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 \<sqinter> -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 ((1 \<sqinter> 1) * top) (-(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 \<sqinter> -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 \<sqinter> -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
+
+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 \<sqinter> -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 \<sqinter> -1)\<^sup>+"
+    using half_shunting by blast
+  have "p0[?px\<longmapsto>y] = p"
+    using assms(1) path_compression_postcondition_def by simp
+  hence "(p \<sqinter> -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 \<sqinter> -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 \<sqinter> -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 \<sqinter> -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 \<sqinter> -1)\<^sup>+ * rank \<le> (p0 \<sqinter> -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 \<sqinter> - 1) * rank \<le> rank * S'\<^sup>+"
+    .
+  show "univalent rank" "total rank"
+    using rank_property_def assms(3) by auto
+  show "card_less_eq ((p \<sqinter> 1) * top) (- (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]])
+      ELSE
+        SKIP
+      FI
+    FI
+  ELSE
+    SKIP
+  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 "(?p3 \<sqinter> 1) * top \<le> (?p2 \<sqinter> 1) * top"
+                by (simp add: mult_left_isotone)
+              thus "card_less_eq ((?p3 \<sqinter> 1) * top) (-(S'\<^sup>+ * rank\<^sup>T * top))"
+                using 4 by (meson rank_property_def card_less_eq_def order_trans)
+              have "(?p3 \<sqinter> -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 \<sqinter> -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 \<sqinter> -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 \<sqinter> -?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 ((?p2 \<sqinter> 1) * top) (-(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> (?p2 \<sqinter> 1) * top \<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> (?p2 \<sqinter> 1) * top"
+                    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 "(?p4 \<sqinter> 1) * top \<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 "(?p4 \<sqinter> 1) * top \<le> (-?s \<sqinter> ?p2 \<sqinter> 1) * top"
+                      by (simp add: mult_left_isotone)
+                    also have "... = -?s \<sqinter> (?p2 \<sqinter> 1) * top"
+                      using 5 inf_assoc vector_complement_closed vector_inf_comp by auto
+                    also have "... = (i * ?rr \<sqinter> -?s \<sqinter> (?p2 \<sqinter> 1) * top) \<squnion> (-(i * ?rr) \<sqinter> -?s \<sqinter> (?p2 \<sqinter> 1) * top)"
+                      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> (?p2 \<sqinter> 1) * top) \<le> ?s * (i * S'\<^sup>\<star> * i\<^sup>T * ?s \<sqinter> -?s \<sqinter> (?p2 \<sqinter> 1) * top)"
+                        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> (?p2 \<sqinter> 1) * top)"
+                        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> (?p2 \<sqinter> 1) * top)"
+                        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> (?p2 \<sqinter> 1) * top)"
+                        using comp_inf.comp_right_dist_sup by simp
+                      also have "... \<le> ?s * (i * S'\<^sup>+ * i\<^sup>T * ?s \<sqinter> (?p2 \<sqinter> 1) * top)"
+                        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> (?p2 \<sqinter> 1) * top) \<le> i * -(S'\<^sup>+ * ?rank\<^sup>T * top)"
+                        .
+                      hence "i * ?rr \<sqinter> -?s \<sqinter> (?p2 \<sqinter> 1) * top \<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> (?p2 \<sqinter> 1) * top \<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> (?p2 \<sqinter> 1) * top \<le> ?i * -(S'\<^sup>+ * ?rank\<^sup>T * top)"
+                        .
+                      have "-(i * ?rr) \<sqinter> (?p2 \<sqinter> 1) * top \<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) \<sqinter> -(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> (?p2 \<sqinter> 1) * top \<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> (?p2 \<sqinter> 1) * top \<le> ?i * -(S'\<^sup>+ * ?rank\<^sup>T * top)"
+                        .
+                    qed
+                    finally show ?thesis
+                      .
+                  qed
+                  thus "card_less_eq ((?p4 \<sqinter> 1) * top) (-(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> (?p2 \<sqinter> 1) * top"
+                    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 \<sqinter> -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 \<sqinter> -1) * ?rank \<le> ?s\<^sup>T * rank * S' * S'\<^sup>+"
+                    proof -
+                      have "?r \<sqinter> (?p4 \<sqinter> -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> (?p2 \<sqinter> 1) * top"
+                          by simp
+                        finally have "?r \<sqinter> ?p2 \<le> (?p2 \<sqinter> 1) * top \<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 \<sqinter> -1) * ?rank \<le> rank * S'\<^sup>+"
+                    proof -
+                      have "-?r \<sqinter> (?p4 \<sqinter> -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 \<sqinter> -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 \<sqinter> -1) * ?rank"
+                        using 5 by (simp add: covector_inf_comp_3)
+                      also have "... = ?s * (?r \<sqinter> (S'\<^sup>T * ?rs)\<^sup>T) \<squnion> (?p2 \<sqinter> -1) * ?rank"
+                        using inf_commute update_inf_same mult_assoc by force
+                      also have "... = ?s * (?r \<sqinter> ?s\<^sup>T * rank * S') \<squnion> (?p2 \<sqinter> -1) * ?rank"
+                        using comp_associative conv_dist_comp conv_involutive by auto
+                      also have "... \<le> ?s * ?s\<^sup>T * rank * S' \<squnion> (?p2 \<sqinter> -1) * ?rank"
+                        using comp_associative inf.cobounded2 mult_right_isotone semiring.add_right_mono by auto
+                      also have "... \<le> 1 * rank * S' \<squnion> (?p2 \<sqinter> -1) * ?rank"
+                        using 5 by (meson mult_left_isotone order.refl semiring.add_mono)
+                      also have "... = rank * S' \<squnion> (?p2 \<sqinter> -1) * (?r \<sqinter> (S'\<^sup>T * ?rr)\<^sup>T) \<squnion> (?p2 \<sqinter> -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 \<sqinter> -1) * (?r \<sqinter> ?r\<^sup>T * rank * S') \<squnion> (?p2 \<sqinter> -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 \<sqinter> -1) * (?r \<sqinter> ?r\<^sup>T) * rank * S' \<squnion> (?p2 \<sqinter> -1) * rank"
+                        using 5 comp_associative vector_inf_comp by auto
+                      also have "... \<le> rank * S' \<squnion> (?p2 \<sqinter> -1) * rank * S' \<squnion> (?p2 \<sqinter> -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 \<sqinter> -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 \<sqinter> -1) * ?rank = (?r \<sqinter> (?p4 \<sqinter> -1) * ?rank) \<squnion> (-?r \<sqinter> (?p4 \<sqinter> -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 "(?p4 \<sqinter> 1) * top \<le> (?p2 \<sqinter> 1) * top"
+                    by (simp add: mult_left_isotone)
+                  thus "card_less_eq ((?p4 \<sqinter> 1) * top) (-(S'\<^sup>+ * rank\<^sup>T * top))"
+                    using 4 by (meson rank_property_def card_less_eq_def order_trans)
+                  have "(?p4 \<sqinter> -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 \<sqinter> -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 \<sqinter> -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,16 +1,17 @@
 chapter AFP
 
 session Relational_Disjoint_Set_Forests (AFP) = Stone_Kleene_Relation_Algebras +
 
   options [timeout = 600]
 
   sessions
     "HOL-Hoare"
 
   theories
     Disjoint_Set_Forests
+    More_Disjoint_Set_Forests
 
   document_files
     "root.tex"
     "root.bib"
 
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,61 +1,64 @@
 \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}
 
 \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 with a naive union operation and a find operation with path compression.
+  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 and naive union \cite{CormenLeisersonRivest1990,GallerFisher1964,Tarjan1975}.
+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, find-set and union-sets operations are implemented and verified in Section 4.
+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.
 
-This Isabelle/HOL theory formally verifies results in \cite{Guttmann2020b}.
-Theorem numbers from this paper are mentioned in the theory for reference.
+This Isabelle/HOL theory formally verifies results in \cite{Guttmann2020b} and in an extended version of that paper.
+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/Stone_Algebras/P_Algebras.thy b/thys/Stone_Algebras/P_Algebras.thy
--- a/thys/Stone_Algebras/P_Algebras.thy
+++ b/thys/Stone_Algebras/P_Algebras.thy
@@ -1,1324 +1,1328 @@
 (* Title:      Pseudocomplemented Algebras
    Author:     Walter Guttmann
    Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
 *)
 
 section \<open>Pseudocomplemented Algebras\<close>
 
 text \<open>
 This theory expands lattices with a pseudocomplement operation.
 In particular, we consider the following algebraic structures:
 \begin{itemize}
 \item pseudocomplemented lattices (p-algebras)
 \item pseudocomplemented distributive lattices (distributive p-algebras)
 \item Stone algebras
 \item Heyting semilattices
 \item Heyting lattices
 \item Heyting algebras
 \item Heyting-Stone algebras
 \item Brouwer algebras
 \item Boolean algebras
 \end{itemize}
 Most of these structures and many results in this theory are discussed in \cite{BalbesDwinger1974,Birkhoff1967,Blyth2005,Curry1977,Graetzer1971,Maddux1996}.
 \<close>
 
 theory P_Algebras
 
 imports Lattice_Basics
 
 begin
 
 subsection \<open>P-Algebras\<close>
 
 text \<open>
 In this section we add a pseudocomplement operation to lattices and to distributive lattices.
 \<close>
 
 subsubsection \<open>Pseudocomplemented Lattices\<close>
 
 text \<open>
 The pseudocomplement of an element \<open>y\<close> is the greatest element whose meet with \<open>y\<close> is the least element of the lattice.
 \<close>
 
 class p_algebra = bounded_lattice + uminus +
   assumes pseudo_complement: "x \<sqinter> y = bot \<longleftrightarrow> x \<le> -y"
 begin
 
 subclass sup_inf_top_bot_uminus_ord .
 
 text \<open>
 Regular elements and dense elements are frequently used in pseudocomplemented algebras.
 \<close>
 
 abbreviation "regular x \<equiv> x = --x"
 abbreviation "dense x \<equiv> -x = bot"
 abbreviation "complemented x \<equiv> \<exists>y . x \<sqinter> y = bot \<and> x \<squnion> y = top"
 abbreviation "in_p_image x \<equiv> \<exists>y . x = -y"
 abbreviation "selection s x \<equiv> s = --s \<sqinter> x"
 
 abbreviation "dense_elements \<equiv> { x . dense x }"
 abbreviation "regular_elements \<equiv> { x . in_p_image x }"
 
 lemma p_bot [simp]:
   "-bot = top"
   using inf_top.left_neutral pseudo_complement top_unique by blast
 
 lemma p_top [simp]:
   "-top = bot"
   by (metis eq_refl inf_top.comm_neutral pseudo_complement)
 
 text \<open>
 The pseudocomplement satisfies the following half of the requirements of a complement.
 \<close>
 
 lemma inf_p [simp]:
   "x \<sqinter> -x = bot"
   using inf.commute pseudo_complement by fastforce
 
 lemma p_inf [simp]:
   "-x \<sqinter> x = bot"
   by (simp add: inf_commute)
 
 lemma pp_inf_p:
   "--x \<sqinter> -x = bot"
   by simp
 
 text \<open>
 The double complement is a closure operation.
 \<close>
 
 lemma pp_increasing:
   "x \<le> --x"
   using inf_p pseudo_complement by blast
 
 lemma ppp [simp]:
   "---x = -x"
   by (metis order.antisym inf.commute order_trans pseudo_complement pp_increasing)
 
 lemma pp_idempotent:
   "----x = --x"
   by simp
 
 lemma regular_in_p_image_iff:
   "regular x \<longleftrightarrow> in_p_image x"
   by auto
 
 lemma pseudo_complement_pp:
   "x \<sqinter> y = bot \<longleftrightarrow> --x \<le> -y"
   by (metis inf_commute pseudo_complement ppp)
 
 lemma p_antitone:
   "x \<le> y \<Longrightarrow> -y \<le> -x"
   by (metis inf_commute order_trans pseudo_complement pp_increasing)
 
 lemma p_antitone_sup:
   "-(x \<squnion> y) \<le> -x"
   by (simp add: p_antitone)
 
 lemma p_antitone_inf:
   "-x \<le> -(x \<sqinter> y)"
   by (simp add: p_antitone)
 
 lemma p_antitone_iff:
   "x \<le> -y \<longleftrightarrow> y \<le> -x"
   using order_lesseq_imp p_antitone pp_increasing by blast
 
 lemma pp_isotone:
   "x \<le> y \<Longrightarrow> --x \<le> --y"
   by (simp add: p_antitone)
 
 lemma pp_isotone_sup:
   "--x \<le> --(x \<squnion> y)"
   by (simp add: p_antitone)
 
 lemma pp_isotone_inf:
   "--(x \<sqinter> y) \<le> --x"
   by (simp add: p_antitone)
 
 text \<open>
 One of De Morgan's laws holds in pseudocomplemented lattices.
 \<close>
 
 lemma p_dist_sup [simp]:
   "-(x \<squnion> y) = -x \<sqinter> -y"
   apply (rule order.antisym)
   apply (simp add: p_antitone)
   using inf_le1 inf_le2 le_sup_iff p_antitone_iff by blast
 
 lemma p_supdist_inf:
   "-x \<squnion> -y \<le> -(x \<sqinter> y)"
   by (simp add: p_antitone)
 
 lemma pp_dist_pp_sup [simp]:
   "--(--x \<squnion> --y) = --(x \<squnion> y)"
   by simp
 
 lemma p_sup_p [simp]:
   "-(x \<squnion> -x) = bot"
   by simp
 
 lemma pp_sup_p [simp]:
   "--(x \<squnion> -x) = top"
   by simp
 
 lemma dense_pp:
   "dense x \<longleftrightarrow> --x = top"
   by (metis p_bot p_top ppp)
 
 lemma dense_sup_p:
   "dense (x \<squnion> -x)"
   by simp
 
 lemma regular_char:
   "regular x \<longleftrightarrow> (\<exists>y . x = -y)"
   by auto
 
 lemma pp_inf_bot_iff:
   "x \<sqinter> y = bot \<longleftrightarrow> --x \<sqinter> y = bot"
   by (simp add: pseudo_complement_pp)
 
 text \<open>
 Weak forms of the shunting property hold.
 Most require a pseudocomplemented element on the right-hand side.
 \<close>
 
 lemma p_shunting_swap:
   "x \<sqinter> y \<le> -z \<longleftrightarrow> x \<sqinter> z \<le> -y"
   by (metis inf_assoc inf_commute pseudo_complement)
 
 lemma pp_inf_below_iff:
   "x \<sqinter> y \<le> -z \<longleftrightarrow> --x \<sqinter> y \<le> -z"
   by (simp add: inf_commute p_shunting_swap)
 
 lemma p_inf_pp [simp]:
   "-(x \<sqinter> --y) = -(x \<sqinter> y)"
   apply (rule order.antisym)
   apply (simp add: inf.coboundedI2 p_antitone pp_increasing)
   using inf_commute p_antitone_iff pp_inf_below_iff by auto
 
 lemma p_inf_pp_pp [simp]:
   "-(--x \<sqinter> --y) = -(x \<sqinter> y)"
   by (simp add: inf_commute)
 
 lemma regular_closed_inf:
   "regular x \<Longrightarrow> regular y \<Longrightarrow> regular (x \<sqinter> y)"
   by (metis p_dist_sup ppp)
 
 lemma regular_closed_p:
   "regular (-x)"
   by simp
 
 lemma regular_closed_pp:
   "regular (--x)"
   by simp
 
 lemma regular_closed_bot:
   "regular bot"
   by simp
 
 lemma regular_closed_top:
   "regular top"
   by simp
 
 lemma pp_dist_inf [simp]:
   "--(x \<sqinter> y) = --x \<sqinter> --y"
   by (metis p_dist_sup p_inf_pp_pp ppp)
 
 lemma inf_import_p [simp]:
   "x \<sqinter> -(x \<sqinter> y) = x \<sqinter> -y"
   apply (rule order.antisym)
   using p_shunting_swap apply fastforce
   using inf.sup_right_isotone p_antitone by auto
 
 text \<open>
 Pseudocomplements are unique.
 \<close>
 
 lemma p_unique:
   "(\<forall>x . x \<sqinter> y = bot \<longleftrightarrow> x \<le> z) \<Longrightarrow> z = -y"
   using inf.order_eq_iff pseudo_complement by auto
 
 lemma maddux_3_5:
   "x \<squnion> x = x \<squnion> -(y \<squnion> -y)"
   by simp
 
 lemma shunting_1_pp:
   "x \<le> --y \<longleftrightarrow> x \<sqinter> -y = bot"
   by (simp add: pseudo_complement)
 
 lemma pp_pp_inf_bot_iff:
   "x \<sqinter> y = bot \<longleftrightarrow> --x \<sqinter> --y = bot"
   by (simp add: pseudo_complement_pp)
 
 lemma inf_pp_semi_commute:
   "x \<sqinter> --y \<le> --(x \<sqinter> y)"
   using inf.eq_refl p_antitone_iff p_inf_pp by presburger
 
 lemma inf_pp_commute:
   "--(--x \<sqinter> y) = --x \<sqinter> --y"
   by simp
 
 lemma sup_pp_semi_commute:
   "x \<squnion> --y \<le> --(x \<squnion> y)"
   by (simp add: p_antitone_iff)
 
 lemma regular_sup:
   "regular z \<Longrightarrow> (x \<le> z \<and> y \<le> z \<longleftrightarrow> --(x \<squnion> y) \<le> z)"
   apply (rule iffI)
   apply (metis le_supI pp_isotone)
   using dual_order.trans sup_ge2 pp_increasing pp_isotone_sup by blast
 
 lemma dense_closed_inf:
   "dense x \<Longrightarrow> dense y \<Longrightarrow> dense (x \<sqinter> y)"
   by (simp add: dense_pp)
 
 lemma dense_closed_sup:
   "dense x \<Longrightarrow> dense y \<Longrightarrow> dense (x \<squnion> y)"
   by simp
 
 lemma dense_closed_pp:
   "dense x \<Longrightarrow> dense (--x)"
   by simp
 
 lemma dense_closed_top:
   "dense top"
   by simp
 
 lemma dense_up_closed:
   "dense x \<Longrightarrow> x \<le> y \<Longrightarrow> dense y"
   using dense_pp top_le pp_isotone by auto
 
 lemma regular_dense_top:
   "regular x \<Longrightarrow> dense x \<Longrightarrow> x = top"
   using p_bot by blast
 
 lemma selection_char:
   "selection s x \<longleftrightarrow> (\<exists>y . s = -y \<sqinter> x)"
   by (metis inf_import_p inf_commute regular_closed_p)
 
 lemma selection_closed_inf:
   "selection s x \<Longrightarrow> selection t x \<Longrightarrow> selection (s \<sqinter> t) x"
   by (metis inf_assoc inf_commute inf_idem pp_dist_inf)
 
 lemma selection_closed_pp:
   "regular x \<Longrightarrow> selection s x \<Longrightarrow> selection (--s) x"
   by (metis pp_dist_inf)
 
 lemma selection_closed_bot:
   "selection bot x"
   by simp
 
 lemma selection_closed_id:
   "selection x x"
   using inf.le_iff_sup pp_increasing by auto
 
 text \<open>
 Conjugates are usually studied for Boolean algebras, however, some of their properties generalise to pseudocomplemented algebras.
 \<close>
 
 lemma conjugate_unique_p:
   assumes "conjugate f g"
       and "conjugate f h"
     shows "uminus \<circ> g = uminus \<circ> h"
 proof -
   have "\<forall>x y . x \<sqinter> g y = bot \<longleftrightarrow> x \<sqinter> h y = bot"
     using assms conjugate_def inf.commute by simp
   hence "\<forall>x y . x \<le> -(g y) \<longleftrightarrow> x \<le> -(h y)"
     using inf.commute pseudo_complement by simp
   hence "\<forall>y . -(g y) = -(h y)"
     using order.eq_iff by blast
   thus ?thesis
     by auto
 qed
 
 lemma conjugate_symmetric:
   "conjugate f g \<Longrightarrow> conjugate g f"
   by (simp add: conjugate_def inf_commute)
 
 lemma additive_isotone:
   "additive f \<Longrightarrow> isotone f"
   by (metis additive_def isotone_def le_iff_sup)
 
 lemma dual_additive_antitone:
   assumes "dual_additive f"
     shows "isotone (uminus \<circ> f)"
 proof -
   have "\<forall>x y . f (x \<squnion> y) \<le> f x"
     using assms dual_additive_def by simp
   hence "\<forall>x y . x \<le> y \<longrightarrow> f y \<le> f x"
     by (metis sup_absorb2)
   hence "\<forall>x y . x \<le> y \<longrightarrow> -(f x) \<le> -(f y)"
     by (simp add: p_antitone)
   thus ?thesis
     by (simp add: isotone_def)
 qed
 
 lemma conjugate_dual_additive:
   assumes "conjugate f g"
     shows "dual_additive (uminus \<circ> f)"
 proof -
   have 1: "\<forall>x y z . -z \<le> -(f (x \<squnion> y)) \<longleftrightarrow> -z \<le> -(f x) \<and> -z \<le> -(f y)"
   proof (intro allI)
     fix x y z
     have "(-z \<le> -(f (x \<squnion> y))) = (f (x \<squnion> y) \<sqinter> -z = bot)"
       by (simp add: p_antitone_iff pseudo_complement)
     also have "... = ((x \<squnion> y) \<sqinter> g(-z) = bot)"
       using assms conjugate_def by auto
     also have "... = (x \<squnion> y \<le> -(g(-z)))"
       by (simp add: pseudo_complement)
     also have "... = (x \<le> -(g(-z)) \<and> y \<le> -(g(-z)))"
       by (simp add: le_sup_iff)
     also have "... = (x \<sqinter> g(-z) = bot \<and> y \<sqinter> g(-z) = bot)"
       by (simp add: pseudo_complement)
     also have "... = (f x \<sqinter> -z = bot \<and> f y \<sqinter> -z = bot)"
       using assms conjugate_def by auto
     also have "... = (-z \<le> -(f x) \<and> -z \<le> -(f y))"
       by (simp add: p_antitone_iff pseudo_complement)
     finally show "-z \<le> -(f (x \<squnion> y)) \<longleftrightarrow> -z \<le> -(f x) \<and> -z \<le> -(f y)"
       by simp
   qed
   have "\<forall>x y . -(f (x \<squnion> y)) = -(f x) \<sqinter> -(f y)"
   proof (intro allI)
     fix x y
     have "-(f x) \<sqinter> -(f y) = --(-(f x) \<sqinter> -(f y))"
       by simp
     hence "-(f x) \<sqinter> -(f y) \<le> -(f (x \<squnion> y))"
       using 1 by (metis inf_le1 inf_le2)
     thus "-(f (x \<squnion> y)) = -(f x) \<sqinter> -(f y)"
       using 1 order.antisym by fastforce
   qed
   thus ?thesis
     using dual_additive_def by simp
 qed
 
 lemma conjugate_isotone_pp:
   "conjugate f g \<Longrightarrow> isotone (uminus \<circ> uminus \<circ> f)"
   by (simp add: comp_assoc conjugate_dual_additive dual_additive_antitone)
 
 lemma conjugate_char_1_pp:
   "conjugate f g \<longleftrightarrow> (\<forall>x y . f(x \<sqinter> -(g y)) \<le> --f x \<sqinter> -y \<and> g(y \<sqinter> -(f x)) \<le> --g y \<sqinter> -x)"
 proof
   assume 1: "conjugate f g"
   show "\<forall>x y . f(x \<sqinter> -(g y)) \<le> --f x \<sqinter> -y \<and> g(y \<sqinter> -(f x)) \<le> --g y \<sqinter> -x"
   proof (intro allI)
     fix x y
     have 2: "f(x \<sqinter> -(g y)) \<le> -y"
       using 1 by (simp add: conjugate_def pseudo_complement)
     have "f(x \<sqinter> -(g y)) \<le> --f(x \<sqinter> -(g y))"
       by (simp add: pp_increasing)
     also have "... \<le> --f x"
       using 1 conjugate_isotone_pp isotone_def by simp
     finally have 3: "f(x \<sqinter> -(g y)) \<le> --f x \<sqinter> -y"
       using 2 by simp
     have 4: "isotone (uminus \<circ> uminus \<circ> g)"
       using 1 conjugate_isotone_pp conjugate_symmetric by auto
     have 5: "g(y \<sqinter> -(f x)) \<le> -x"
       using 1 by (metis conjugate_def inf.cobounded2 inf_commute pseudo_complement)
     have "g(y \<sqinter> -(f x)) \<le> --g(y \<sqinter> -(f x))"
       by (simp add: pp_increasing)
     also have "... \<le> --g y"
       using 4 isotone_def by auto
     finally have "g(y \<sqinter> -(f x)) \<le> --g y \<sqinter> -x"
       using 5 by simp
     thus "f(x \<sqinter> -(g y)) \<le> --f x \<sqinter> -y \<and> g(y \<sqinter> -(f x)) \<le> --g y \<sqinter> -x"
       using 3 by simp
   qed
 next
   assume 6: "\<forall>x y . f(x \<sqinter> -(g y)) \<le> --f x \<sqinter> -y \<and> g(y \<sqinter> -(f x)) \<le> --g y \<sqinter> -x"
   hence 7: "\<forall>x y . f x \<sqinter> y = bot \<longrightarrow> x \<sqinter> g y = bot"
     by (metis inf.le_iff_sup inf.le_sup_iff inf_commute pseudo_complement)
   have "\<forall>x y . x \<sqinter> g y = bot \<longrightarrow> f x \<sqinter> y = bot"
     using 6 by (metis inf.le_iff_sup inf.le_sup_iff inf_commute pseudo_complement)
   thus "conjugate f g"
     using 7 conjugate_def by auto
 qed
 
 lemma conjugate_char_1_isotone:
   "conjugate f g \<Longrightarrow> isotone f \<Longrightarrow> isotone g \<Longrightarrow> f(x \<sqinter> -(g y)) \<le> f x \<sqinter> -y \<and> g(y \<sqinter> -(f x)) \<le> g y \<sqinter> -x"
   by (simp add: conjugate_char_1_pp ord.isotone_def)
 
 lemma dense_lattice_char_1:
   "(\<forall>x y . x \<sqinter> y = bot \<longrightarrow> x = bot \<or> y = bot) \<longleftrightarrow> (\<forall>x . x \<noteq> bot \<longrightarrow> dense x)"
   by (metis inf_top.left_neutral p_bot p_inf pp_inf_bot_iff)
 
 lemma dense_lattice_char_2:
   "(\<forall>x y . x \<sqinter> y = bot \<longrightarrow> x = bot \<or> y = bot) \<longleftrightarrow> (\<forall>x . regular x \<longrightarrow> x = bot \<or> x = top)"
   by (metis dense_lattice_char_1 inf_top.left_neutral p_inf regular_closed_p regular_closed_top)
 
 lemma restrict_below_Rep_eq:
   "x \<sqinter> --y \<le> z \<Longrightarrow> x \<sqinter> y = x \<sqinter> z \<sqinter> y"
   by (metis inf.absorb2 inf.commute inf.left_commute pp_increasing)
 
 (*
 lemma p_inf_sup_below: "-x \<sqinter> (x \<squnion> y) \<le> y" nitpick [expect=genuine] oops
 lemma complement_p: "x \<sqinter> y = bot \<and> x \<squnion> y = top \<longrightarrow> -x = y" nitpick [expect=genuine] oops
 lemma complemented_regular: "complemented x \<longrightarrow> regular x" nitpick [expect=genuine] oops
 *)
 
 end
 
 text \<open>
 The following class gives equational axioms for the pseudocomplement operation.
 \<close>
 
 class p_algebra_eq = bounded_lattice + uminus +
   assumes p_bot_eq: "-bot = top"
       and p_top_eq: "-top = bot"
       and inf_import_p_eq: "x \<sqinter> -(x \<sqinter> y) = x \<sqinter> -y"
 begin
 
 lemma inf_p_eq:
   "x \<sqinter> -x = bot"
   by (metis inf_bot_right inf_import_p_eq inf_top_right p_top_eq)
 
 subclass p_algebra
   apply unfold_locales
   apply (rule iffI)
   apply (metis inf.orderI inf_import_p_eq inf_top.right_neutral p_bot_eq)
   by (metis (full_types) inf.left_commute inf.orderE inf_bot_right inf_commute inf_p_eq)
 
 end
 
 subsubsection \<open>Pseudocomplemented Distributive Lattices\<close>
 
 text \<open>
 We obtain further properties if we assume that the lattice operations are distributive.
 \<close>
 
 class pd_algebra = p_algebra + bounded_distrib_lattice
 begin
 
 lemma p_inf_sup_below:
   "-x \<sqinter> (x \<squnion> y) \<le> y"
   by (simp add: inf_sup_distrib1)
 
 lemma pp_inf_sup_p [simp]:
   "--x \<sqinter> (x \<squnion> -x) = x"
   using inf.absorb2 inf_sup_distrib1 pp_increasing by auto
 
 lemma complement_p:
   "x \<sqinter> y = bot \<Longrightarrow> x \<squnion> y = top \<Longrightarrow> -x = y"
   by (metis pseudo_complement inf.commute inf_top.left_neutral sup.absorb_iff1 sup.commute sup_bot.right_neutral sup_inf_distrib2 p_inf)
 
 lemma complemented_regular:
   "complemented x \<Longrightarrow> regular x"
   using complement_p inf.commute sup.commute by fastforce
 
 lemma regular_inf_dense:
   "\<exists>y z . regular y \<and> dense z \<and> x = y \<sqinter> z"
   by (metis pp_inf_sup_p dense_sup_p ppp)
 
 lemma maddux_3_12 [simp]:
   "(x \<squnion> -y) \<sqinter> (x \<squnion> y) = x"
   by (metis p_inf sup_bot_right sup_inf_distrib1)
 
 lemma maddux_3_13 [simp]:
   "(x \<squnion> y) \<sqinter> -x = y \<sqinter> -x"
   by (simp add: inf_sup_distrib2)
 
 lemma maddux_3_20:
   "((v \<sqinter> w) \<squnion> (-v \<sqinter> x)) \<sqinter> -((v \<sqinter> y) \<squnion> (-v \<sqinter> z)) = (v \<sqinter> w \<sqinter> -y) \<squnion> (-v \<sqinter> x \<sqinter> -z)"
 proof -
   have "v \<sqinter> w \<sqinter> -(v \<sqinter> y) \<sqinter> -(-v \<sqinter> z) = v \<sqinter> w \<sqinter> -(v \<sqinter> y)"
     by (meson inf.cobounded1 inf_absorb1 le_infI1 p_antitone_iff)
   also have "... = v \<sqinter> w \<sqinter> -y"
     using inf.sup_relative_same_increasing inf_import_p inf_le1 by blast
   finally have 1: "v \<sqinter> w \<sqinter> -(v \<sqinter> y) \<sqinter> -(-v \<sqinter> z) = v \<sqinter> w \<sqinter> -y"
     .
   have "-v \<sqinter> x \<sqinter> -(v \<sqinter> y) \<sqinter> -(-v \<sqinter> z) = -v \<sqinter> x \<sqinter> -(-v \<sqinter> z)"
     by (simp add: inf.absorb1 le_infI1 p_antitone_inf)
   also have "... = -v \<sqinter> x \<sqinter> -z"
     by (simp add: inf.assoc inf_left_commute)
   finally have 2: "-v \<sqinter> x \<sqinter> -(v \<sqinter> y) \<sqinter> -(-v \<sqinter> z) = -v \<sqinter> x \<sqinter> -z"
     .
   have "((v \<sqinter> w) \<squnion> (-v \<sqinter> x)) \<sqinter> -((v \<sqinter> y) \<squnion> (-v \<sqinter> z)) = (v \<sqinter> w \<sqinter> -(v \<sqinter> y) \<sqinter> -(-v \<sqinter> z)) \<squnion> (-v \<sqinter> x \<sqinter> -(v \<sqinter> y) \<sqinter> -(-v \<sqinter> z))"
     by (simp add: inf_assoc inf_sup_distrib2)
   also have "... = (v \<sqinter> w \<sqinter> -y) \<squnion> (-v \<sqinter> x \<sqinter> -z)"
     using 1 2 by simp
   finally show ?thesis
     .
 qed
 
 lemma order_char_1:
   "x \<le> y \<longleftrightarrow> x \<le> y \<squnion> -x"
   by (metis inf.sup_left_isotone inf_sup_absorb le_supI1 maddux_3_12 sup_commute)
 
 lemma order_char_2:
   "x \<le> y \<longleftrightarrow> x \<squnion> -x \<le> y \<squnion> -x"
   using order_char_1 by auto
 
+lemma half_shunting:
+  "x \<le> y \<squnion> z \<Longrightarrow> x \<sqinter> -z \<le> y"
+  by (metis inf.sup_right_isotone inf_commute inf_sup_distrib1 sup.boundedE maddux_3_12)
+
 (*
 lemma pp_dist_sup [simp]: "--(x \<squnion> y) = --x \<squnion> --y" nitpick [expect=genuine] oops
 lemma regular_closed_sup: "regular x \<and> regular y \<longrightarrow> regular (x \<squnion> y)" nitpick [expect=genuine] oops
 lemma regular_complemented_iff: "regular x \<longleftrightarrow> complemented x" nitpick [expect=genuine] oops
 lemma selection_closed_sup: "selection s x \<and> selection t x \<longrightarrow> selection (s \<squnion> t) x" nitpick [expect=genuine] oops
 lemma stone [simp]: "-x \<squnion> --x = top" nitpick [expect=genuine] oops
 *)
 
 end
 
 subsection \<open>Stone Algebras\<close>
 
 text \<open>
 A Stone algebra is a distributive lattice with a pseudocomplement that satisfies the following equation.
 We thus obtain the other half of the requirements of a complement at least for the regular elements.
 \<close>
 
 class stone_algebra = pd_algebra +
   assumes stone [simp]: "-x \<squnion> --x = top"
 begin
 
 text \<open>
 As a consequence, we obtain both De Morgan's laws for all elements.
 \<close>
 
 lemma p_dist_inf [simp]:
   "-(x \<sqinter> y) = -x \<squnion> -y"
 proof (rule p_unique[THEN sym], rule allI, rule iffI)
   fix w
   assume "w \<sqinter> (x \<sqinter> y) = bot"
   hence "w \<sqinter> --x \<sqinter> y = bot"
     using inf_commute inf_left_commute pseudo_complement by auto
   hence 1: "w \<sqinter> --x \<le> -y"
     by (simp add: pseudo_complement)
   have "w = (w \<sqinter> -x) \<squnion> (w \<sqinter> --x)"
     using distrib_imp2 sup_inf_distrib1 by auto
   thus "w \<le> -x \<squnion> -y"
     using 1 by (metis inf_le2 sup.mono)
 next
   fix w
   assume "w \<le> -x \<squnion> -y"
   thus "w \<sqinter> (x \<sqinter> y) = bot"
     using order_trans p_supdist_inf pseudo_complement by blast
 qed
 
 lemma pp_dist_sup [simp]:
   "--(x \<squnion> y) = --x \<squnion> --y"
   by simp
 
 lemma regular_closed_sup:
   "regular x \<Longrightarrow> regular y \<Longrightarrow> regular (x \<squnion> y)"
   by simp
 
 text \<open>
 The regular elements are precisely the ones having a complement.
 \<close>
 
 lemma regular_complemented_iff:
   "regular x \<longleftrightarrow> complemented x"
   by (metis inf_p stone complemented_regular)
 
 lemma selection_closed_sup:
   "selection s x \<Longrightarrow> selection t x \<Longrightarrow> selection (s \<squnion> t) x"
   by (simp add: inf_sup_distrib2)
 
 lemma huntington_3_pp [simp]:
   "-(-x \<squnion> -y) \<squnion> -(-x \<squnion> y) = --x"
   by (metis p_dist_inf p_inf sup.commute sup_bot_left sup_inf_distrib1)
 
 lemma maddux_3_3 [simp]:
   "-(x \<squnion> y) \<squnion> -(x \<squnion> -y) = -x"
   by (simp add: sup_commute sup_inf_distrib1)
 
 lemma maddux_3_11_pp:
   "(x \<sqinter> -y) \<squnion> (x \<sqinter> --y) = x"
   by (metis inf_sup_distrib1 inf_top_right stone)
 
 lemma maddux_3_19_pp:
   "(-x \<sqinter> y) \<squnion> (--x \<sqinter> z) = (--x \<squnion> y) \<sqinter> (-x \<squnion> z)"
 proof -
   have "(--x \<squnion> y) \<sqinter> (-x \<squnion> z) = (--x \<sqinter> z) \<squnion> (y \<sqinter> -x) \<squnion> (y \<sqinter> z)"
     by (simp add: inf.commute inf_sup_distrib1 sup.assoc)
   also have "... = (--x \<sqinter> z) \<squnion> (y \<sqinter> -x) \<squnion> (y \<sqinter> z \<sqinter> (-x \<squnion> --x))"
     by simp
   also have "... = (--x \<sqinter> z) \<squnion> ((y \<sqinter> -x) \<squnion> (y \<sqinter> -x \<sqinter> z)) \<squnion> (y \<sqinter> z \<sqinter> --x)"
     using inf_sup_distrib1 sup_assoc inf_commute inf_assoc by presburger
   also have "... = (--x \<sqinter> z) \<squnion> (y \<sqinter> -x) \<squnion> (y \<sqinter> z \<sqinter> --x)"
     by simp
   also have "... = ((--x \<sqinter> z) \<squnion> (--x \<sqinter> z \<sqinter> y)) \<squnion> (y \<sqinter> -x)"
     by (simp add: inf_assoc inf_commute sup.left_commute sup_commute)
   also have "... = (--x \<sqinter> z) \<squnion> (y \<sqinter> -x)"
     by simp
   finally show ?thesis
     by (simp add: inf_commute sup_commute)
 qed
 
 lemma compl_inter_eq_pp:
   "--x \<sqinter> y = --x \<sqinter> z \<Longrightarrow> -x \<sqinter> y = -x \<sqinter> z \<Longrightarrow> y = z"
   by (metis inf_commute inf_p inf_sup_distrib1 inf_top.right_neutral p_bot p_dist_inf)
 
 lemma maddux_3_21_pp [simp]:
   "--x \<squnion> (-x \<sqinter> y) = --x \<squnion> y"
   by (simp add: sup.commute sup_inf_distrib1)
 
 lemma shunting_2_pp:
   "x \<le> --y \<longleftrightarrow> -x \<squnion> --y = top"
   by (metis inf_top_left p_bot p_dist_inf pseudo_complement)
 
 lemma shunting_p:
   "x \<sqinter> y \<le> -z \<longleftrightarrow> x \<le> -z \<squnion> -y"
   by (metis inf.assoc p_dist_inf p_shunting_swap pseudo_complement)
 
 text \<open>
 The following weak shunting property is interesting as it does not require the element \<open>z\<close> on the right-hand side to be regular.
 \<close>
 
 lemma shunting_var_p:
   "x \<sqinter> -y \<le> z \<longleftrightarrow> x \<le> z \<squnion> --y"
 proof
   assume "x \<sqinter> -y \<le> z"
   hence "z \<squnion> --y = --y \<squnion> (z \<squnion> x \<sqinter> -y)"
     by (simp add: sup.absorb1 sup.commute)
   thus "x \<le> z \<squnion> --y"
     by (metis inf_commute maddux_3_21_pp sup.commute sup.left_commute sup_left_divisibility)
 next
   assume "x \<le> z \<squnion> --y"
   thus "x \<sqinter> -y \<le> z"
     by (metis inf.mono maddux_3_12 sup_ge2)
 qed
 
 (* Whether conjugate_char_2_pp can be proved in pd_algebra or in p_algebra is unknown. *)
 lemma conjugate_char_2_pp:
   "conjugate f g \<longleftrightarrow> f bot = bot \<and> g bot = bot \<and> (\<forall>x y . f x \<sqinter> y \<le> --(f(x \<sqinter> --(g y))) \<and> g y \<sqinter> x \<le> --(g(y \<sqinter> --(f x))))"
 proof
   assume 1: "conjugate f g"
   hence 2: "dual_additive (uminus \<circ> g)"
     using conjugate_symmetric conjugate_dual_additive by auto
   show "f bot = bot \<and> g bot = bot \<and> (\<forall>x y . f x \<sqinter> y \<le> --(f(x \<sqinter> --(g y))) \<and> g y \<sqinter> x \<le> --(g(y \<sqinter> --(f x))))"
   proof (intro conjI)
     show "f bot = bot"
       using 1 by (metis conjugate_def inf_idem inf_bot_left)
   next
     show "g bot = bot"
       using 1 by (metis conjugate_def inf_idem inf_bot_right)
   next
     show "\<forall>x y . f x \<sqinter> y \<le> --(f(x \<sqinter> --(g y))) \<and> g y \<sqinter> x \<le> --(g(y \<sqinter> --(f x)))"
     proof (intro allI)
       fix x y
       have 3: "y \<le> -(f(x \<sqinter> -(g y)))"
         using 1 by (simp add: conjugate_def pseudo_complement inf_commute)
       have 4: "x \<le> -(g(y \<sqinter> -(f x)))"
         using 1 conjugate_def inf.commute pseudo_complement by fastforce
       have "y \<sqinter> -(f(x \<sqinter> --(g y))) = y \<sqinter> -(f(x \<sqinter> -(g y))) \<sqinter> -(f(x \<sqinter> --(g y)))"
         using 3 by (simp add: inf.le_iff_sup inf_commute)
       also have "... = y \<sqinter> -(f((x \<sqinter> -(g y)) \<squnion> (x \<sqinter> --(g y))))"
         using 1 conjugate_dual_additive dual_additive_def inf_assoc by auto
       also have "... = y \<sqinter> -(f x)"
         by (simp add: maddux_3_11_pp)
       also have "... \<le> -(f x)"
         by simp
       finally have 5: "f x \<sqinter> y \<le> --(f(x \<sqinter> --(g y)))"
         by (simp add: inf_commute p_shunting_swap)
       have "x \<sqinter> -(g(y \<sqinter> --(f x))) = x \<sqinter> -(g(y \<sqinter> -(f x))) \<sqinter> -(g(y \<sqinter> --(f x)))"
         using 4 by (simp add: inf.le_iff_sup inf_commute)
       also have "... = x \<sqinter> -(g((y \<sqinter> -(f x)) \<squnion> (y \<sqinter> --(f x))))"
         using 2 by (simp add: dual_additive_def inf_assoc)
       also have "... = x \<sqinter> -(g y)"
         by (simp add: maddux_3_11_pp)
       also have "... \<le> -(g y)"
         by simp
       finally have "g y \<sqinter> x \<le> --(g(y \<sqinter> --(f x)))"
         by (simp add: inf_commute p_shunting_swap)
       thus "f x \<sqinter> y \<le> --(f(x \<sqinter> --(g y))) \<and> g y \<sqinter> x \<le> --(g(y \<sqinter> --(f x)))"
         using 5 by simp
     qed
   qed
 next
   assume "f bot = bot \<and> g bot = bot \<and> (\<forall>x y . f x \<sqinter> y \<le> --(f(x \<sqinter> --(g y))) \<and> g y \<sqinter> x \<le> --(g(y \<sqinter> --(f x))))"
   thus "conjugate f g"
     by (unfold conjugate_def, metis inf_commute le_bot pp_inf_bot_iff regular_closed_bot)
 qed
 
 lemma conjugate_char_2_pp_additive:
   assumes "conjugate f g"
       and "additive f"
       and "additive g"
     shows "f x \<sqinter> y \<le> f(x \<sqinter> --(g y)) \<and> g y \<sqinter> x \<le> g(y \<sqinter> --(f x))"
 proof -
   have "f x \<sqinter> y = f ((x \<sqinter> --g y) \<squnion> (x \<sqinter> -g y)) \<sqinter> y"
     by (simp add: sup.commute sup_inf_distrib1)
   also have "... = (f (x \<sqinter> --g y) \<sqinter> y) \<squnion> (f (x \<sqinter> -g y) \<sqinter> y)"
     using assms(2) additive_def inf_sup_distrib2 by auto
   also have "... = f (x \<sqinter> --g y) \<sqinter> y"
     by (metis assms(1) conjugate_def inf_le2 pseudo_complement sup_bot.right_neutral)
   finally have 2: "f x \<sqinter> y \<le> f (x \<sqinter> --g y)"
     by simp
   have "g y \<sqinter> x = g ((y \<sqinter> --f x) \<squnion> (y \<sqinter> -f x)) \<sqinter> x"
     by (simp add: sup.commute sup_inf_distrib1)
   also have "... = (g (y \<sqinter> --f x) \<sqinter> x) \<squnion> (g (y \<sqinter> -f x) \<sqinter> x)"
     using assms(3) additive_def inf_sup_distrib2 by auto
   also have "... = g (y \<sqinter> --f x) \<sqinter> x"
     by (metis assms(1) conjugate_def inf.cobounded2 pseudo_complement sup_bot.right_neutral inf_commute)
   finally have "g y \<sqinter> x \<le> g (y \<sqinter> --f x)"
     by simp
   thus ?thesis
     using 2 by simp
 qed
 
 (*
 lemma compl_le_swap2_iff: "-x \<le> y \<longleftrightarrow> -y \<le> x" nitpick [expect=genuine] oops
 lemma huntington_3: "x = -(-x \<squnion> -y) \<squnion> -(-x \<squnion> y)" nitpick [expect=genuine] oops
 lemma maddux_3_1: "x \<squnion> -x = y \<squnion> -y" nitpick [expect=genuine] oops
 lemma maddux_3_4: "x \<squnion> (y \<squnion> -y) = z \<squnion> -z" nitpick [expect=genuine] oops
 lemma maddux_3_11: "x = (x \<sqinter> y) \<squnion> (x \<sqinter> -y)" nitpick [expect=genuine] oops
 lemma maddux_3_19: "(-x \<sqinter> y) \<squnion> (x \<sqinter> z) = (x \<squnion> y) \<sqinter> (-x \<squnion> z)" nitpick [expect=genuine] oops
 lemma compl_inter_eq: "x \<sqinter> y = x \<sqinter> z \<and> -x \<sqinter> y = -x \<sqinter> z \<longrightarrow> y = z" nitpick [expect=genuine] oops
 lemma maddux_3_21: "x \<squnion> y = x \<squnion> (-x \<sqinter> y)" nitpick [expect=genuine] oops
 lemma shunting_1: "x \<le> y \<longleftrightarrow> x \<sqinter> -y = bot" nitpick [expect=genuine] oops
 lemma shunting_2: "x \<le> y \<longleftrightarrow> -x \<squnion> y = top" nitpick [expect=genuine] oops
 lemma conjugate_unique: "conjugate f g \<and> conjugate f h \<longrightarrow> g = h" nitpick [expect=genuine] oops
 lemma conjugate_isotone_pp: "conjugate f g \<longrightarrow> isotone f" nitpick [expect=genuine] oops
 lemma conjugate_char_1: "conjugate f g \<longleftrightarrow> (\<forall>x y . f(x \<sqinter> -(g y)) \<le> f x \<sqinter> -y \<and> g(y \<sqinter> -(f x)) \<le> g y \<sqinter> -x)" nitpick [expect=genuine] oops
 lemma conjugate_char_2: "conjugate f g \<longleftrightarrow> f bot = bot \<and> g bot = bot \<and> (\<forall>x y . f x \<sqinter> y \<le> f(x \<sqinter> g y) \<and> g y \<sqinter> x \<le> g(y \<sqinter> f x))" nitpick [expect=genuine] oops
 lemma shunting: "x \<sqinter> y \<le> z \<longleftrightarrow> x \<le> z \<squnion> -y" nitpick [expect=genuine] oops
 lemma shunting_var: "x \<sqinter> -y \<le> z \<longleftrightarrow> x \<le> z \<squnion> y" nitpick [expect=genuine] oops
 lemma sup_compl_top: "x \<squnion> -x = top" nitpick [expect=genuine] oops
 lemma selection_closed_p: "selection s x \<longrightarrow> selection (-s) x" nitpick [expect=genuine] oops
 lemma selection_closed_pp: "selection s x \<longrightarrow> selection (--s) x" nitpick [expect=genuine] oops
 *)
 
 end
 
 abbreviation stone_algebra_isomorphism :: "('a::stone_algebra \<Rightarrow> 'b::stone_algebra) \<Rightarrow> bool"
   where "stone_algebra_isomorphism f \<equiv> sup_inf_top_bot_uminus_isomorphism f"
 
 text \<open>
 Every bounded linear order can be expanded to a Stone algebra.
 The pseudocomplement takes \<open>bot\<close> to the \<open>top\<close> and every other element to \<open>bot\<close>.
 \<close>
 
 class linorder_stone_algebra_expansion = linorder_lattice_expansion + uminus +
   assumes uminus_def [simp]: "-x = (if x = bot then top else bot)"
 begin
 
 subclass stone_algebra
   apply unfold_locales
   using bot_unique min_def top_le by auto
 
 text \<open>
 The regular elements are the least and greatest elements.
 All elements except the least element are dense.
 \<close>
 
 lemma regular_bot_top:
   "regular x \<longleftrightarrow> x = bot \<or> x = top"
   by simp
 
 lemma not_bot_dense:
   "x \<noteq> bot \<Longrightarrow> --x = top"
   by simp
 
 end
 
 subsection \<open>Heyting Algebras\<close>
 
 text \<open>
 In this section we add a relative pseudocomplement operation to semilattices and to lattices.
 \<close>
 
 subsubsection \<open>Heyting Semilattices\<close>
 
 text \<open>
 The pseudocomplement of an element \<open>y\<close> relative to an element \<open>z\<close> is the least element whose meet with \<open>y\<close> is below \<open>z\<close>.
 This can be stated as a Galois connection.
 Specialising \<open>z = bot\<close> gives (non-relative) pseudocomplements.
 Many properties can already be shown if the underlying structure is just a semilattice.
 \<close>
 
 class implies =
   fixes implies :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<leadsto>" 65)
 
 class heyting_semilattice = semilattice_inf + implies +
   assumes implies_galois: "x \<sqinter> y \<le> z \<longleftrightarrow> x \<le> y \<leadsto> z"
 begin
 
 lemma implies_below_eq [simp]:
   "y \<sqinter> (x \<leadsto> y) = y"
   using implies_galois inf.absorb_iff1 inf.cobounded1 by blast
 
 lemma implies_increasing:
   "x \<le> y \<leadsto> x"
   by (simp add: inf.orderI)
 
 lemma implies_galois_swap:
   "x \<le> y \<leadsto> z \<longleftrightarrow> y \<le> x \<leadsto> z"
   by (metis implies_galois inf_commute)
 
 lemma implies_galois_var:
   "x \<sqinter> y \<le> z \<longleftrightarrow> y \<le> x \<leadsto> z"
   by (simp add: implies_galois_swap implies_galois)
 
 lemma implies_galois_increasing:
   "x \<le> y \<leadsto> (x \<sqinter> y)"
   using implies_galois by blast
 
 lemma implies_galois_decreasing:
   "(y \<leadsto> x) \<sqinter> y \<le> x"
   using implies_galois by blast
 
 lemma implies_mp_below:
   "x \<sqinter> (x \<leadsto> y) \<le> y"
   using implies_galois_decreasing inf_commute by auto
 
 lemma implies_isotone:
   "x \<le> y \<Longrightarrow> z \<leadsto> x \<le> z \<leadsto> y"
   using implies_galois order_trans by blast
 
 lemma implies_antitone:
   "x \<le> y \<Longrightarrow> y \<leadsto> z \<le> x \<leadsto> z"
   by (meson implies_galois_swap order_lesseq_imp)
 
 lemma implies_isotone_inf:
   "x \<leadsto> (y \<sqinter> z) \<le> x \<leadsto> y"
   by (simp add: implies_isotone)
 
 lemma implies_antitone_inf:
   "x \<leadsto> z \<le> (x \<sqinter> y) \<leadsto> z"
   by (simp add: implies_antitone)
 
 lemma implies_curry:
   "x \<leadsto> (y \<leadsto> z) = (x \<sqinter> y) \<leadsto> z"
   by (metis implies_galois_decreasing implies_galois inf_assoc order.antisym)
 
 lemma implies_curry_flip:
   "x \<leadsto> (y \<leadsto> z) = y \<leadsto> (x \<leadsto> z)"
   by (simp add: implies_curry inf_commute)
 
 lemma triple_implies [simp]:
   "((x \<leadsto> y) \<leadsto> y) \<leadsto> y = x \<leadsto> y"
   using implies_antitone implies_galois_swap order.eq_iff by auto
 
 lemma implies_mp_eq [simp]:
   "x \<sqinter> (x \<leadsto> y) = x \<sqinter> y"
   by (metis implies_below_eq implies_mp_below inf_left_commute inf.absorb2)
 
 lemma implies_dist_implies:
   "x \<leadsto> (y \<leadsto> z) \<le> (x \<leadsto> y) \<leadsto> (x \<leadsto> z)"
   using implies_curry implies_curry_flip by auto
 
 lemma implies_import_inf [simp]:
   "x \<sqinter> ((x \<sqinter> y) \<leadsto> (x \<leadsto> z)) = x \<sqinter> (y \<leadsto> z)"
   by (metis implies_curry implies_mp_eq inf_commute)
 
 lemma implies_dist_inf:
   "x \<leadsto> (y \<sqinter> z) = (x \<leadsto> y) \<sqinter> (x \<leadsto> z)"
 proof -
   have "(x \<leadsto> y) \<sqinter> (x \<leadsto> z) \<sqinter> x \<le> y \<sqinter> z"
     by (simp add: implies_galois)
   hence "(x \<leadsto> y) \<sqinter> (x \<leadsto> z) \<le> x \<leadsto> (y \<sqinter> z)"
     using implies_galois by blast
   thus ?thesis
     by (simp add: implies_isotone order.eq_iff)
 qed
 
 lemma implies_itself_top:
   "y \<le> x \<leadsto> x"
   by (simp add: implies_galois_swap implies_increasing)
 
 lemma inf_implies_top:
   "z \<le> (x \<sqinter> y) \<leadsto> x"
   using implies_galois_var le_infI1 by blast
 
 lemma inf_inf_implies [simp]:
   "z \<sqinter> ((x \<sqinter> y) \<leadsto> x) = z"
   by (simp add: inf_implies_top inf_absorb1)
 
 lemma le_implies_top:
   "x \<le> y \<Longrightarrow> z \<le> x \<leadsto> y"
   using implies_antitone implies_itself_top order.trans by blast
 
 lemma le_iff_le_implies:
   "x \<le> y \<longleftrightarrow> x \<le> x \<leadsto> y"
   using implies_galois inf_idem by force
 
 lemma implies_inf_isotone:
   "x \<leadsto> y \<le> (x \<sqinter> z) \<leadsto> (y \<sqinter> z)"
   by (metis implies_curry implies_galois_increasing implies_isotone)
 
 lemma implies_transitive:
   "(x \<leadsto> y) \<sqinter> (y \<leadsto> z) \<le> x \<leadsto> z"
   using implies_dist_implies implies_galois_var implies_increasing order_lesseq_imp by blast
 
 lemma implies_inf_absorb [simp]:
   "x \<leadsto> (x \<sqinter> y) = x \<leadsto> y"
   using implies_dist_inf implies_itself_top inf.absorb_iff2 by auto
 
 lemma implies_implies_absorb [simp]:
   "x \<leadsto> (x \<leadsto> y) = x \<leadsto> y"
   by (simp add: implies_curry)
 
 lemma implies_inf_identity:
   "(x \<leadsto> y) \<sqinter> y = y"
   by (simp add: inf_commute)
 
 lemma implies_itself_same:
   "x \<leadsto> x = y \<leadsto> y"
   by (simp add: le_implies_top order.eq_iff)
 
 end
 
 text \<open>
 The following class gives equational axioms for the relative pseudocomplement operation (inequalities can be written as equations).
 \<close>
 
 class heyting_semilattice_eq = semilattice_inf + implies +
   assumes implies_mp_below: "x \<sqinter> (x \<leadsto> y) \<le> y"
       and implies_galois_increasing: "x \<le> y \<leadsto> (x \<sqinter> y)"
       and implies_isotone_inf: "x \<leadsto> (y \<sqinter> z) \<le> x \<leadsto> y"
 begin
 
 subclass heyting_semilattice
   apply unfold_locales
   apply (rule iffI)
   apply (metis implies_galois_increasing implies_isotone_inf inf.absorb2 order_lesseq_imp)
   by (metis implies_mp_below inf_commute order_trans inf_mono order_refl)
 
 end
 
 text \<open>
 The following class allows us to explicitly give the pseudocomplement of an element relative to itself.
 \<close>
 
 class bounded_heyting_semilattice = bounded_semilattice_inf_top + heyting_semilattice
 begin
 
 lemma implies_itself [simp]:
   "x \<leadsto> x = top"
   using implies_galois inf_le2 top_le by blast
 
 lemma implies_order:
   "x \<le> y \<longleftrightarrow> x \<leadsto> y = top"
   by (metis implies_galois inf_top.left_neutral top_unique)
 
 lemma inf_implies [simp]:
   "(x \<sqinter> y) \<leadsto> x = top"
   using implies_order inf_le1 by blast
 
 lemma top_implies [simp]:
   "top \<leadsto> x = x"
   by (metis implies_mp_eq inf_top.left_neutral)
 
 end
 
 subsubsection \<open>Heyting Lattices\<close>
 
 text \<open>
 We obtain further properties if the underlying structure is a lattice.
 In particular, the lattice operations are automatically distributive in this case.
 \<close>
 
 class heyting_lattice = lattice + heyting_semilattice
 begin
 
 lemma sup_distrib_inf_le:
   "(x \<squnion> y) \<sqinter> (x \<squnion> z) \<le> x \<squnion> (y \<sqinter> z)"
 proof -
   have "x \<squnion> z \<le> y \<leadsto> (x \<squnion> (y \<sqinter> z))"
     using implies_galois_var implies_increasing sup.bounded_iff sup.cobounded2 by blast
   hence "x \<squnion> y \<le> (x \<squnion> z) \<leadsto> (x \<squnion> (y \<sqinter> z))"
     using implies_galois_swap implies_increasing le_sup_iff by blast
   thus ?thesis
     by (simp add: implies_galois)
 qed
 
 subclass distrib_lattice
   apply unfold_locales
   using distrib_sup_le order.eq_iff sup_distrib_inf_le by auto
 
 lemma implies_isotone_sup:
   "x \<leadsto> y \<le> x \<leadsto> (y \<squnion> z)"
   by (simp add: implies_isotone)
 
 lemma implies_antitone_sup:
   "(x \<squnion> y) \<leadsto> z \<le> x \<leadsto> z"
   by (simp add: implies_antitone)
 
 lemma implies_sup:
   "x \<leadsto> z \<le> (y \<leadsto> z) \<leadsto> ((x \<squnion> y) \<leadsto> z)"
 proof -
   have "(x \<leadsto> z) \<sqinter> (y \<leadsto> z) \<sqinter> y \<le> z"
     by (simp add: implies_galois)
   hence "(x \<leadsto> z) \<sqinter> (y \<leadsto> z) \<sqinter> (x \<squnion> y) \<le> z"
     using implies_galois_swap implies_galois_var by fastforce
   thus ?thesis
     by (simp add: implies_galois)
 qed
 
 lemma implies_dist_sup:
   "(x \<squnion> y) \<leadsto> z = (x \<leadsto> z) \<sqinter> (y \<leadsto> z)"
   apply (rule order.antisym)
   apply (simp add: implies_antitone)
   by (simp add: implies_sup implies_galois)
 
 lemma implies_antitone_isotone:
   "(x \<squnion> y) \<leadsto> (x \<sqinter> y) \<le> x \<leadsto> y"
   by (simp add: implies_antitone_sup implies_dist_inf le_infI2)
 
 lemma implies_antisymmetry:
   "(x \<leadsto> y) \<sqinter> (y \<leadsto> x) = (x \<squnion> y) \<leadsto> (x \<sqinter> y)"
   by (metis implies_dist_sup implies_inf_absorb inf.commute)
 
 lemma sup_inf_implies [simp]:
   "(x \<squnion> y) \<sqinter> (x \<leadsto> y) = y"
   by (simp add: inf_sup_distrib2 sup.absorb2)
 
 lemma implies_subdist_sup:
   "(x \<leadsto> y) \<squnion> (x \<leadsto> z) \<le> x \<leadsto> (y \<squnion> z)"
   by (simp add: implies_isotone)
 
 lemma implies_subdist_inf:
   "(x \<leadsto> z) \<squnion> (y \<leadsto> z) \<le> (x \<sqinter> y) \<leadsto> z"
   by (simp add: implies_antitone)
 
 lemma implies_sup_absorb:
   "(x \<leadsto> y) \<squnion> z \<le> (x \<squnion> z) \<leadsto> (y \<squnion> z)"
   by (metis implies_dist_sup implies_isotone_sup implies_increasing inf_inf_implies le_sup_iff sup_inf_implies)
 
 lemma sup_below_implies_implies:
   "x \<squnion> y \<le> (x \<leadsto> y) \<leadsto> y"
   by (simp add: implies_dist_sup implies_galois_swap implies_increasing)
 
 end
 
 class bounded_heyting_lattice = bounded_lattice + heyting_lattice
 begin
 
 subclass bounded_heyting_semilattice ..
 
 lemma implies_bot [simp]:
   "bot \<leadsto> x = top"
   using implies_galois top_unique by fastforce
 
 end
 
 subsubsection \<open>Heyting Algebras\<close>
 
 text \<open>
 The pseudocomplement operation can be defined in Heyting algebras, but it is typically not part of their signature.
 We add the definition as an axiom so that we can use the class hierarchy, for example, to inherit results from the class \<open>pd_algebra\<close>.
 \<close>
 
 class heyting_algebra = bounded_heyting_lattice + uminus +
   assumes uminus_eq: "-x = x \<leadsto> bot"
 begin
 
 subclass pd_algebra
   apply unfold_locales
   using bot_unique implies_galois uminus_eq by auto
 
 lemma boolean_implies_below:
   "-x \<squnion> y \<le> x \<leadsto> y"
   by (simp add: implies_increasing implies_isotone uminus_eq)
 
 lemma negation_implies:
   "-(x \<leadsto> y) = --x \<sqinter> -y"
 proof (rule order.antisym)
   show "-(x \<leadsto> y) \<le> --x \<sqinter> -y"
     using boolean_implies_below p_antitone by auto
 next
   have "x \<sqinter> -y \<sqinter> (x \<leadsto> y) = bot"
     by (metis implies_mp_eq inf_p inf_bot_left inf_commute inf_left_commute)
   hence "--x \<sqinter> -y \<sqinter> (x \<leadsto> y) = bot"
     using pp_inf_bot_iff inf_assoc by auto
   thus "--x \<sqinter> -y \<le> -(x \<leadsto> y)"
     by (simp add: pseudo_complement)
 qed
 
 lemma double_negation_dist_implies:
   "--(x \<leadsto> y) = --x \<leadsto> --y"
   apply (rule order.antisym)
   apply (metis pp_inf_below_iff implies_galois_decreasing implies_galois negation_implies ppp)
   by (simp add: p_antitone_iff negation_implies)
 
 (*
 lemma stone: "-x \<squnion> --x = top" nitpick [expect=genuine] oops
 *)
 
 end
 
 text \<open>
 The following class gives equational axioms for Heyting algebras.
 \<close>
 
 class heyting_algebra_eq = bounded_lattice + implies + uminus +
   assumes implies_mp_eq: "x \<sqinter> (x \<leadsto> y) = x \<sqinter> y"
       and implies_import_inf: "x \<sqinter> ((x \<sqinter> y) \<leadsto> (x \<leadsto> z)) = x \<sqinter> (y \<leadsto> z)"
       and inf_inf_implies: "z \<sqinter> ((x \<sqinter> y) \<leadsto> x) = z"
       and uminus_eq_eq: "-x = x \<leadsto> bot"
 begin
 
 subclass heyting_algebra
   apply unfold_locales
   apply (rule iffI)
   apply (metis implies_import_inf inf.sup_left_divisibility inf_inf_implies le_iff_inf)
   apply (metis implies_mp_eq inf.commute inf.le_sup_iff inf.sup_right_isotone)
   by (simp add: uminus_eq_eq)
 
 end
 
 text \<open>
 A relative pseudocomplement is not enough to obtain the Stone equation, so we add it in the following class.
 \<close>
 
 class heyting_stone_algebra = heyting_algebra +
   assumes heyting_stone: "-x \<squnion> --x = top"
 begin
 
 subclass stone_algebra
   by unfold_locales (simp add: heyting_stone)
 
 (*
 lemma pre_linear: "(x \<leadsto> y) \<squnion> (y \<leadsto> x) = top" nitpick [expect=genuine] oops
 *)
 
 end
 
 subsubsection \<open>Brouwer Algebras\<close>
 
 text \<open>
 Brouwer algebras are dual to Heyting algebras.
 The dual pseudocomplement of an element \<open>y\<close> relative to an element \<open>x\<close> is the least element whose join with \<open>y\<close> is above \<open>x\<close>.
 We can now use the binary operation provided by Boolean algebras in Isabelle/HOL because it is compatible with dual relative pseudocomplements (not relative pseudocomplements).
 \<close>
 
 class brouwer_algebra = bounded_lattice + minus + uminus +
   assumes minus_galois: "x \<le> y \<squnion> z \<longleftrightarrow> x - y \<le> z"
       and uminus_eq_minus: "-x = top - x"
 begin
 
 sublocale brouwer: heyting_algebra where inf = sup and less_eq = greater_eq and less = greater and sup = inf and bot = top and top = bot and implies = "\<lambda>x y . y - x"
   apply unfold_locales
   apply simp
   apply simp
   apply simp
   apply simp
   apply (metis minus_galois sup_commute)
   by (simp add: uminus_eq_minus)
 
 lemma curry_minus:
   "x - (y \<squnion> z) = (x - y) - z"
   by (simp add: brouwer.implies_curry sup_commute)
 
 lemma minus_subdist_sup:
   "(x - z) \<squnion> (y - z) \<le> (x \<squnion> y) - z"
   by (simp add: brouwer.implies_dist_inf)
 
 lemma inf_sup_minus:
   "(x \<sqinter> y) \<squnion> (x - y) = x"
   by (simp add: inf.absorb1 brouwer.inf_sup_distrib2)
 
 end
 
 subsection \<open>Boolean Algebras\<close>
 
 text \<open>
 This section integrates Boolean algebras in the above hierarchy.
 In particular, we strengthen several results shown above.
 \<close>
 
 context boolean_algebra
 begin
 
 text \<open>
 Every Boolean algebra is a Stone algebra, a Heyting algebra and a Brouwer algebra.
 \<close>
 
 subclass stone_algebra
   apply unfold_locales
   apply (rule iffI)
   apply (metis compl_sup_top inf.orderI inf_bot_right inf_sup_distrib1 inf_top_right sup_inf_absorb)
   using inf.commute inf.sup_right_divisibility apply fastforce
   by simp
 
 sublocale heyting: heyting_algebra where implies = "\<lambda>x y . -x \<squnion> y"
   apply unfold_locales
   apply (rule iffI)
   using shunting_var_p sup_commute apply fastforce
   using shunting_var_p sup_commute apply force
   by simp
 
 subclass brouwer_algebra
   apply unfold_locales
   apply (simp add: diff_eq shunting_var_p sup.commute)
   by (simp add: diff_eq)
 
 lemma huntington_3 [simp]:
   "-(-x \<squnion> -y) \<squnion> -(-x \<squnion> y) = x"
   using huntington_3_pp by auto
 
 lemma maddux_3_1:
   "x \<squnion> -x = y \<squnion> -y"
   by simp
 
 lemma maddux_3_4:
   "x \<squnion> (y \<squnion> -y) = z \<squnion> -z"
   by simp
 
 lemma maddux_3_11 [simp]:
   "(x \<sqinter> y) \<squnion> (x \<sqinter> -y) = x"
   using brouwer.maddux_3_12 sup.commute by auto
 
 lemma maddux_3_19:
   "(-x \<sqinter> y) \<squnion> (x \<sqinter> z) = (x \<squnion> y) \<sqinter> (-x \<squnion> z)"
   using maddux_3_19_pp by auto
 
 lemma compl_inter_eq:
   "x \<sqinter> y = x \<sqinter> z \<Longrightarrow> -x \<sqinter> y = -x \<sqinter> z \<Longrightarrow> y = z"
   by (metis inf_commute maddux_3_11)
 
 lemma maddux_3_21 [simp]:
   "x \<squnion> (-x \<sqinter> y) = x \<squnion> y"
   by (simp add: sup_inf_distrib1)
 
 lemma shunting_1:
   "x \<le> y \<longleftrightarrow> x \<sqinter> -y = bot"
   by (simp add: pseudo_complement)
 
 lemma uminus_involutive:
   "uminus \<circ> uminus = id"
   by auto
 
 lemma uminus_injective:
   "uminus \<circ> f = uminus \<circ> g \<Longrightarrow> f = g"
   by (metis comp_assoc id_o minus_comp_minus)
 
 lemma conjugate_unique:
   "conjugate f g \<Longrightarrow> conjugate f h \<Longrightarrow> g = h"
   using conjugate_unique_p uminus_injective by blast
 
 lemma dual_additive_additive:
   "dual_additive (uminus \<circ> f) \<Longrightarrow> additive f"
   by (metis additive_def compl_eq_compl_iff dual_additive_def p_dist_sup o_def)
 
 lemma conjugate_additive:
   "conjugate f g \<Longrightarrow> additive f"
   by (simp add: conjugate_dual_additive dual_additive_additive)
 
 lemma conjugate_isotone:
   "conjugate f g \<Longrightarrow> isotone f"
   by (simp add: conjugate_additive additive_isotone)
 
 lemma conjugate_char_1:
   "conjugate f g \<longleftrightarrow> (\<forall>x y . f(x \<sqinter> -(g y)) \<le> f x \<sqinter> -y \<and> g(y \<sqinter> -(f x)) \<le> g y \<sqinter> -x)"
   by (simp add: conjugate_char_1_pp)
 
 lemma conjugate_char_2:
   "conjugate f g \<longleftrightarrow> f bot = bot \<and> g bot = bot \<and> (\<forall>x y . f x \<sqinter> y \<le> f(x \<sqinter> g y) \<and> g y \<sqinter> x \<le> g(y \<sqinter> f x))"
   by (simp add: conjugate_char_2_pp)
 
 lemma shunting:
   "x \<sqinter> y \<le> z \<longleftrightarrow> x \<le> z \<squnion> -y"
   by (simp add: heyting.implies_galois sup.commute)
 
 lemma shunting_var:
   "x \<sqinter> -y \<le> z \<longleftrightarrow> x \<le> z \<squnion> y"
   by (simp add: shunting)
 
 end
 
 class non_trivial_stone_algebra = non_trivial_bounded_order + stone_algebra
 
 class non_trivial_boolean_algebra = non_trivial_stone_algebra + boolean_algebra
 
 end
 
diff --git a/thys/Stone_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,3269 +1,3300 @@
 (* Title:      Kleene Relation Algebras
    Author:     Walter Guttmann
    Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
 *)
 
 section \<open>Kleene Relation Algebras\<close>
 
 text \<open>
 This theory combines Kleene algebras with Stone relation algebras.
 Relation algebras with transitive closure have been studied by \cite{Ng1984}.
 The weakening to Stone relation algebras allows us to talk about reachability in weighted graphs, for example.
 
 Many results in this theory are used in the correctness proof of Prim's minimum spanning tree algorithm.
 In particular, they are concerned with the exchange property, preservation of parts of the invariant and with establishing parts of the postcondition.
 \<close>
 
 theory Kleene_Relation_Algebras
 
 imports Stone_Relation_Algebras.Relation_Algebras Kleene_Algebras
 
 begin
 
 text \<open>
 We first note that bounded distributive lattices can be expanded to Kleene algebras by reusing some of the operations.
 \<close>
 
 sublocale bounded_distrib_lattice < comp_inf: bounded_kleene_algebra where star = "\<lambda>x . top" and one = top and times = inf
   apply unfold_locales
   apply (simp add: inf.assoc)
   apply simp
   apply simp
   apply (simp add: le_infI2)
   apply (simp add: inf_sup_distrib2)
   apply simp
   apply simp
   apply simp
   apply simp
   apply simp
   apply (simp add: inf_sup_distrib1)
   apply simp
   apply simp
   by (simp add: inf_assoc)
 
 text \<open>
 We add the Kleene star operation to each of bounded distributive allegories, pseudocomplemented distributive allegories and Stone relation algebras.
 We start with single-object bounded distributive allegories.
 \<close>
 
 class bounded_distrib_kleene_allegory = bounded_distrib_allegory + kleene_algebra
 begin
 
 subclass bounded_kleene_algebra ..
 
 lemma conv_star_conv:
   "x\<^sup>\<star> \<le> x\<^sup>T\<^sup>\<star>\<^sup>T"
 proof -
   have "x\<^sup>T\<^sup>\<star> * x\<^sup>T \<le> x\<^sup>T\<^sup>\<star>"
     by (simp add: star.right_plus_below_circ)
   hence 1: "x * x\<^sup>T\<^sup>\<star>\<^sup>T \<le> x\<^sup>T\<^sup>\<star>\<^sup>T"
     using conv_dist_comp conv_isotone by fastforce
   have "1 \<le> x\<^sup>T\<^sup>\<star>\<^sup>T"
     by (simp add: reflexive_conv_closed star.circ_reflexive)
   hence "1 \<squnion> x * x\<^sup>T\<^sup>\<star>\<^sup>T \<le> x\<^sup>T\<^sup>\<star>\<^sup>T"
     using 1 by simp
   thus ?thesis
     using star_left_induct by fastforce
 qed
 
 text \<open>
 It follows that star and converse commute.
 \<close>
 
 lemma conv_star_commute:
   "x\<^sup>\<star>\<^sup>T = x\<^sup>T\<^sup>\<star>"
 proof (rule 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, hide_lams) comp_associative star.circ_loop_fixpoint sup_assoc sup_commute)
   also have "... \<le> 1 \<sqinter> (?v\<^sup>\<star> * e * ?v\<^sup>\<star> \<squnion> w\<^sup>+)"
     using comp_inf.mult_right_isotone comp_isotone semiring.add_right_mono star_isotone sup_commute by simp
   also have "... = (1 \<sqinter> ?v\<^sup>\<star> * e * ?v\<^sup>\<star>) \<squnion> (1 \<sqinter> w\<^sup>+)"
     by (simp add: inf_sup_distrib1)
   also have "... = 1 \<sqinter> ?v\<^sup>\<star> * e * ?v\<^sup>\<star>"
     by (metis assms(1) inf_commute pseudo_complement sup_bot_right)
   also have "... = bot"
     using 8 p_antitone_iff pseudo_complement by simp
   finally show ?thesis
     using le_bot p_antitone_iff pseudo_complement by auto
 qed
 
 subsubsection \<open>Exchange gives Spanning Trees\<close>
 
 text \<open>
 The lemmas in this section are used to show that the relation after exchange represents a spanning tree.
 \<close>
 
 lemma inf_star_import:
   assumes "x \<le> z"
       and "univalent z"
       and "reflexive y"
       and "regular z"
     shows "x\<^sup>\<star> * y \<sqinter> z\<^sup>\<star> \<le> x\<^sup>\<star> * (y \<sqinter> z\<^sup>\<star>)"
 proof -
   have 1: "y \<le> x\<^sup>\<star> * (y \<sqinter> z\<^sup>\<star>) \<squnion> -z\<^sup>\<star>"
     by (metis assms(4) pp_dist_star shunting_var_p star.circ_loop_fixpoint sup.cobounded2)
   have "x * -z\<^sup>\<star> \<sqinter> z\<^sup>+ \<le> x * (-z\<^sup>\<star> \<sqinter> x\<^sup>T * z\<^sup>+)"
     by (simp add: dedekind_1)
   also have "... \<le> x * (-z\<^sup>\<star> \<sqinter> z\<^sup>T * z\<^sup>+)"
     using assms(1) comp_inf.mult_right_isotone conv_isotone mult_left_isotone mult_right_isotone by simp
   also have "... \<le> x * (-z\<^sup>\<star> \<sqinter> 1 * z\<^sup>\<star>)"
     by (metis assms(2) comp_associative comp_inf.mult_right_isotone mult_left_isotone mult_right_isotone)
   finally have 2: "x * -z\<^sup>\<star> \<sqinter> z\<^sup>+ = bot"
     by (simp add: 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
+
+end
+
diff --git a/thys/Stone_Relation_Algebras/Relation_Algebras.thy b/thys/Stone_Relation_Algebras/Relation_Algebras.thy
--- a/thys/Stone_Relation_Algebras/Relation_Algebras.thy
+++ b/thys/Stone_Relation_Algebras/Relation_Algebras.thy
@@ -1,1973 +1,2020 @@
 (* Title:      Relation Algebras
    Author:     Walter Guttmann
    Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
 *)
 
 section \<open>Relation Algebras\<close>
 
 text \<open>
 The main structures introduced in this theory are Stone relation algebras.
 They generalise Tarski's relation algebras \cite{Tarski1941} by weakening the Boolean algebra lattice structure to a Stone algebra.
 Our motivation is to generalise relation-algebraic methods from unweighted graphs to weighted graphs.
 Unlike unweighted graphs, weighted graphs do not form a Boolean algebra because there is no complement operation on the edge weights.
 However, edge weights form a Stone algebra, and matrices over edge weights (that is, weighted graphs) form a Stone relation algebra.
 
 The development in this theory is described in our papers \cite{Guttmann2016c,Guttmann2017b}.
 Our main application there is the verification of Prim's minimum spanning tree algorithm.
 Related work about fuzzy relations \cite{Goguen1967,Winter2001b}, Dedekind categories \cite{KawaharaFurusawa2001} and rough relations \cite{Comer1993,Pawlak1996} is also discussed in these papers.
 In particular, Stone relation algebras do not assume that the underlying lattice is complete or a Heyting algebra, and they do not assume that composition has residuals.
 
 We proceed in two steps.
 First, we study the positive fragment in the form of single-object bounded distributive allegories \cite{FreydScedrov1990}.
 Second, we extend these structures by a pseudocomplement operation with additional axioms to obtain Stone relation algebras.
 
 Tarski's relation algebras are then obtained by a simple extension that imposes a Boolean algebra.
 See, for example, \cite{BirdMoor1997,HirschHodkinson2002,Maddux1996,Maddux2006,Schmidt2011,SchmidtStroehlein1993} for further details about relations and relation algebras, and \cite{AndrekaMikulas2011,BredihinSchein1978} for algebras of relations with a smaller signature.
 \<close>
 
 theory Relation_Algebras
 
 imports Stone_Algebras.P_Algebras Semirings
 
 begin
 
 subsection \<open>Single-Object Bounded Distributive Allegories\<close>
 
 text \<open>
 We start with developing bounded distributive allegories.
 The following definitions concern properties of relations that require converse in addition to lattice and semiring operations.
 \<close>
 
 class conv =
   fixes conv :: "'a \<Rightarrow> 'a" ("_\<^sup>T" [100] 100)
 
 class bounded_distrib_allegory_signature = inf + sup + times + conv + bot + top + one + ord
 begin
 
 subclass times_one_ord .
 subclass times_top .
 
 abbreviation total_var      :: "'a \<Rightarrow> bool" where "total_var x      \<equiv> 1 \<le> x * x\<^sup>T"
 abbreviation surjective_var :: "'a \<Rightarrow> bool" where "surjective_var x \<equiv> 1 \<le> x\<^sup>T * x"
 abbreviation univalent      :: "'a \<Rightarrow> bool" where "univalent x      \<equiv> x\<^sup>T * x \<le> 1"
 abbreviation injective      :: "'a \<Rightarrow> bool" where "injective x      \<equiv> x * x\<^sup>T \<le> 1"
 
 abbreviation mapping        :: "'a \<Rightarrow> bool" where "mapping x        \<equiv> univalent x \<and> total x"
 abbreviation bijective      :: "'a \<Rightarrow> bool" where "bijective x      \<equiv> injective x \<and> surjective x"
 
 abbreviation point          :: "'a \<Rightarrow> bool" where "point x          \<equiv> vector x \<and> bijective x"
 abbreviation arc            :: "'a \<Rightarrow> bool" where "arc x            \<equiv> bijective (x * top) \<and> bijective (x\<^sup>T * top)" (* earlier name: atom *)
 
 abbreviation symmetric      :: "'a \<Rightarrow> bool" where "symmetric x      \<equiv> x\<^sup>T = x"
 abbreviation antisymmetric  :: "'a \<Rightarrow> bool" where "antisymmetric x  \<equiv> x \<sqinter> x\<^sup>T \<le> 1"
 abbreviation asymmetric     :: "'a \<Rightarrow> bool" where "asymmetric x     \<equiv> x \<sqinter> x\<^sup>T = bot"
 abbreviation linear         :: "'a \<Rightarrow> bool" where "linear x         \<equiv> x \<squnion> x\<^sup>T = top"
 
 abbreviation equivalence    :: "'a \<Rightarrow> bool" where "equivalence x    \<equiv> preorder x \<and> symmetric x"
 abbreviation order          :: "'a \<Rightarrow> bool" where "order x          \<equiv> preorder x \<and> antisymmetric x"
 abbreviation linear_order   :: "'a \<Rightarrow> bool" where "linear_order x   \<equiv> order x \<and> linear x"
 
 end
 
 text \<open>
 We reuse the relation algebra axioms given in \cite{Maddux1996} except for one -- see lemma \<open>conv_complement_sub\<close> below -- which we replace with the Dedekind rule (or modular law) \<open>dedekind_1\<close>.
 The Dedekind rule or variants of it are known from \cite{BirdMoor1997,FreydScedrov1990,KawaharaFurusawaMori1999,SchmidtStroehlein1993}.
 We add \<open>comp_left_zero\<close>, which follows in relation algebras but not in the present setting.
 The main change is that only a bounded distributive lattice is required, not a Boolean algebra.
 \<close>
 
 class bounded_distrib_allegory = bounded_distrib_lattice + times + one + conv +
   assumes comp_associative      : "(x * y) * z = x * (y * z)"
   assumes comp_right_dist_sup   : "(x \<squnion> y) * z = (x * z) \<squnion> (y * z)"
   assumes comp_left_zero  [simp]: "bot * x = bot"
   assumes comp_left_one   [simp]: "1 * x = x"
   assumes conv_involutive [simp]: "x\<^sup>T\<^sup>T = x"
   assumes conv_dist_sup         : "(x \<squnion> y)\<^sup>T = x\<^sup>T \<squnion> y\<^sup>T"
   assumes conv_dist_comp        : "(x * y)\<^sup>T = y\<^sup>T * x\<^sup>T"
   assumes dedekind_1            : "x * y \<sqinter> z \<le> x * (y \<sqinter> (x\<^sup>T * z))"
 begin
 
 subclass bounded_distrib_allegory_signature .
 
 text \<open>
 Many properties of relation algebras already follow in bounded distributive allegories.
 \<close>
 
 lemma conv_isotone:
   "x \<le> y \<Longrightarrow> x\<^sup>T \<le> y\<^sup>T"
   by (metis conv_dist_sup le_iff_sup)
 
 lemma conv_order:
   "x \<le> y \<longleftrightarrow> x\<^sup>T \<le> y\<^sup>T"
   using conv_isotone by fastforce
 
 lemma conv_bot [simp]:
   "bot\<^sup>T = bot"
   using conv_order bot_unique by force
 
 lemma conv_top [simp]:
   "top\<^sup>T = top"
   by (metis conv_involutive conv_order order.eq_iff top_greatest)
 
 lemma conv_dist_inf:
   "(x \<sqinter> y)\<^sup>T = x\<^sup>T \<sqinter> y\<^sup>T"
   apply (rule order.antisym)
   using conv_order apply simp
   by (metis conv_order conv_involutive inf.boundedI inf.cobounded1 inf.cobounded2)
 
 lemma conv_inf_bot_iff:
   "bot = x\<^sup>T \<sqinter> y \<longleftrightarrow> bot = x \<sqinter> y\<^sup>T"
   using conv_dist_inf conv_bot by fastforce
 
 lemma conv_one [simp]:
   "1\<^sup>T = 1"
   by (metis comp_left_one conv_dist_comp conv_involutive)
 
 lemma comp_left_dist_sup:
   "(x * y) \<squnion> (x * z) = x * (y \<squnion> z)"
   by (metis comp_right_dist_sup conv_involutive conv_dist_sup conv_dist_comp)
 
 lemma comp_right_isotone:
   "x \<le> y \<Longrightarrow> z * x \<le> z * y"
   by (simp add: comp_left_dist_sup sup.absorb_iff1)
 
 lemma comp_left_isotone:
   "x \<le> y \<Longrightarrow> x * z \<le> y * z"
   by (metis comp_right_dist_sup le_iff_sup)
 
 lemma comp_isotone:
   "x \<le> y \<Longrightarrow> w \<le> z \<Longrightarrow> x * w \<le> y * z"
   using comp_left_isotone comp_right_isotone order.trans by blast
 
 lemma comp_left_subdist_inf:
   "(x \<sqinter> y) * z \<le> x * z \<sqinter> y * z"
   by (simp add: comp_left_isotone)
 
 lemma comp_left_increasing_sup:
   "x * y \<le> (x \<squnion> z) * y"
   by (simp add: comp_left_isotone)
 
 lemma comp_right_subdist_inf:
   "x * (y \<sqinter> z) \<le> x * y \<sqinter> x * z"
   by (simp add: comp_right_isotone)
 
 lemma comp_right_increasing_sup:
   "x * y \<le> x * (y \<squnion> z)"
   by (simp add: comp_right_isotone)
 
 lemma comp_right_zero [simp]:
   "x * bot = bot"
   by (metis comp_left_zero conv_dist_comp conv_involutive)
 
 lemma comp_right_one [simp]:
   "x * 1 = x"
   by (metis comp_left_one conv_dist_comp conv_involutive)
 
 lemma comp_left_conjugate:
   "conjugate (\<lambda>y . x * y) (\<lambda>y . x\<^sup>T * y)"
   apply (unfold conjugate_def, intro allI)
   by (metis comp_right_zero bot.extremum_unique conv_involutive dedekind_1 inf.commute)
 
 lemma comp_right_conjugate:
   "conjugate (\<lambda>y . y * x) (\<lambda>y . y * x\<^sup>T)"
   apply (unfold conjugate_def, intro allI)
   by (metis comp_left_conjugate[unfolded conjugate_def] conv_inf_bot_iff conv_dist_comp conv_involutive)
 
 text \<open>
 We still obtain a semiring structure.
 \<close>
 
 subclass bounded_idempotent_semiring
   by (unfold_locales)
   (auto simp: comp_right_isotone comp_right_dist_sup comp_associative comp_left_dist_sup)
 
 sublocale inf: semiring_0 sup bot inf
   by (unfold_locales, auto simp: inf_sup_distrib2 inf_sup_distrib1 inf_assoc)
 
 lemma schroeder_1:
   "x * y \<sqinter> z = bot \<longleftrightarrow> x\<^sup>T * z \<sqinter> y = bot"
   using abel_semigroup.commute comp_left_conjugate conjugate_def inf.abel_semigroup_axioms by fastforce
 
 lemma schroeder_2:
   "x * y \<sqinter> z = bot \<longleftrightarrow> z * y\<^sup>T \<sqinter> x = bot"
   by (metis comp_right_conjugate conjugate_def inf_commute)
 
 lemma comp_additive:
   "additive (\<lambda>y . x * y) \<and> additive (\<lambda>y . x\<^sup>T * y) \<and> additive (\<lambda>y . y * x) \<and> additive (\<lambda>y . y * x\<^sup>T)"
   by (simp add: comp_left_dist_sup additive_def comp_right_dist_sup)
 
 lemma dedekind_2:
   "y * x \<sqinter> z \<le> (y \<sqinter> (z * x\<^sup>T)) * x"
   by (metis conv_dist_inf conv_order conv_dist_comp dedekind_1)
 
 text \<open>
 The intersection with a vector can still be exported from the first argument of a composition, and many other properties of vectors and covectors continue to hold.
 \<close>
 
 lemma vector_inf_comp:
   "vector x \<Longrightarrow> (x \<sqinter> y) * z = x \<sqinter> (y * z)"
   apply (rule order.antisym)
   apply (metis comp_left_subdist_inf comp_right_isotone inf.sup_left_isotone order_lesseq_imp top_greatest)
   by (metis comp_left_isotone comp_right_isotone dedekind_2 inf_commute inf_mono order_refl order_trans top_greatest)
 
 lemma vector_inf_closed:
   "vector x \<Longrightarrow> vector y \<Longrightarrow> vector (x \<sqinter> y)"
   by (simp add: vector_inf_comp)
 
 lemma vector_inf_one_comp:
   "vector x \<Longrightarrow> (x \<sqinter> 1) * y = x \<sqinter> y"
   by (simp add: vector_inf_comp)
 
 lemma covector_inf_comp_1:
   assumes "vector x"
     shows "(y \<sqinter> x\<^sup>T) * z = (y \<sqinter> x\<^sup>T) * (x \<sqinter> z)"
 proof -
   have "(y \<sqinter> x\<^sup>T) * z \<le> (y \<sqinter> x\<^sup>T) * (z \<sqinter> ((y\<^sup>T \<sqinter> x) * top))"
     by (metis inf_top_right dedekind_1 conv_dist_inf conv_involutive)
   also have "... \<le> (y \<sqinter> x\<^sup>T) * (x \<sqinter> z)"
     by (metis assms comp_left_isotone comp_right_isotone inf_le2 inf_mono order_refl inf_commute)
   finally show ?thesis
     by (simp add: comp_right_isotone order.antisym)
 qed
 
 lemma covector_inf_comp_2:
   assumes "vector x"
     shows "y * (x \<sqinter> z) = (y \<sqinter> x\<^sup>T) * (x \<sqinter> z)"
 proof -
   have "y * (x \<sqinter> z) \<le> (y \<sqinter> (top * (x \<sqinter> z)\<^sup>T)) * (x \<sqinter> z)"
     by (metis dedekind_2 inf_top_right)
   also have "... \<le> (y \<sqinter> x\<^sup>T) * (x \<sqinter> z)"
     by (metis assms comp_left_isotone conv_dist_comp conv_order conv_top eq_refl inf_le1 inf_mono)
   finally show ?thesis
     using comp_left_subdist_inf order.antisym by auto
 qed
 
 lemma covector_inf_comp_3:
   "vector x \<Longrightarrow> (y \<sqinter> x\<^sup>T) * z = y * (x \<sqinter> z)"
   by (metis covector_inf_comp_1 covector_inf_comp_2)
 
 lemma covector_inf_closed:
   "covector x \<Longrightarrow> covector y \<Longrightarrow> covector (x \<sqinter> y)"
   by (metis comp_right_subdist_inf order.antisym top_left_mult_increasing)
 
 lemma vector_conv_covector:
   "vector v \<longleftrightarrow> covector (v\<^sup>T)"
   by (metis conv_dist_comp conv_involutive conv_top)
 
 lemma covector_conv_vector:
   "covector v \<longleftrightarrow> vector (v\<^sup>T)"
   by (simp add: vector_conv_covector)
 
 lemma covector_comp_inf:
   "covector z \<Longrightarrow> x * (y \<sqinter> z) = x * y \<sqinter> z"
   apply (rule order.antisym)
   apply (metis comp_isotone comp_right_subdist_inf inf.boundedE inf.boundedI inf.cobounded2 top.extremum)
   by (metis comp_left_isotone comp_right_isotone dedekind_1 inf_commute inf_mono order_refl order_trans top_greatest)
 
 lemma vector_restrict_comp_conv:
   "vector x \<Longrightarrow> x \<sqinter> y \<le> x\<^sup>T * y"
   by (metis covector_inf_comp_3 eq_refl inf.sup_monoid.add_commute inf_top_right le_supE sup.orderE top_left_mult_increasing)
 
 lemma covector_restrict_comp_conv:
   "covector x \<Longrightarrow> y \<sqinter> x \<le> y * x\<^sup>T"
   by (metis conv_dist_comp conv_dist_inf conv_order conv_top inf.sup_monoid.add_commute vector_restrict_comp_conv)
 
 lemma covector_comp_inf_1:
   "covector x \<Longrightarrow> (y \<sqinter> x) * z = y * (x\<^sup>T \<sqinter> z)"
   using covector_conv_vector covector_inf_comp_3 by fastforce
 
 text \<open>
 We still have two ways to represent surjectivity and totality.
 \<close>
 
 lemma surjective_var:
   "surjective x \<longleftrightarrow> surjective_var x"
 proof
   assume "surjective x"
   thus "surjective_var x"
     by (metis dedekind_2 comp_left_one inf_absorb2 top_greatest)
 next
   assume "surjective_var x"
   hence "x\<^sup>T * (x * top) = top"
     by (metis comp_left_isotone comp_associative comp_left_one top_le)
   thus "surjective x"
     by (metis comp_right_isotone conv_top conv_dist_comp conv_involutive top_greatest top_le)
 qed
 
 lemma total_var:
   "total x \<longleftrightarrow> total_var x"
   by (metis conv_top conv_dist_comp conv_involutive surjective_var)
 
 lemma surjective_conv_total:
   "surjective x \<longleftrightarrow> total (x\<^sup>T)"
   by (metis conv_top conv_dist_comp conv_involutive)
 
 lemma total_conv_surjective:
   "total x \<longleftrightarrow> surjective (x\<^sup>T)"
   by (simp add: surjective_conv_total)
 
 lemma injective_conv_univalent:
   "injective x \<longleftrightarrow> univalent (x\<^sup>T)"
   by simp
 
 lemma univalent_conv_injective:
   "univalent x \<longleftrightarrow> injective (x\<^sup>T)"
   by simp
 
 text \<open>
 We continue with studying further closure properties.
 \<close>
 
 lemma univalent_bot_closed:
   "univalent bot"
   by simp
 
 lemma univalent_one_closed:
   "univalent 1"
   by simp
 
 lemma univalent_inf_closed:
   "univalent x \<Longrightarrow> univalent (x \<sqinter> y)"
   by (metis comp_left_subdist_inf comp_right_subdist_inf conv_dist_inf inf.cobounded1 order_lesseq_imp)
 
 lemma univalent_mult_closed:
   assumes "univalent x"
       and "univalent y"
     shows "univalent (x * y)"
 proof -
   have "(x * y)\<^sup>T * x \<le> y\<^sup>T"
     by (metis assms(1) comp_left_isotone comp_right_one conv_one conv_order comp_associative conv_dist_comp conv_involutive)
   thus ?thesis
     by (metis assms(2) comp_left_isotone comp_associative dual_order.trans)
 qed
 
 lemma injective_bot_closed:
   "injective bot"
   by simp
 
 lemma injective_one_closed:
   "injective 1"
   by simp
 
 lemma injective_inf_closed:
   "injective x \<Longrightarrow> injective (x \<sqinter> y)"
   by (metis conv_dist_inf injective_conv_univalent univalent_inf_closed)
 
 lemma injective_mult_closed:
   "injective x \<Longrightarrow> injective y \<Longrightarrow> injective (x * y)"
   by (metis injective_conv_univalent conv_dist_comp univalent_mult_closed)
 
 lemma mapping_one_closed:
   "mapping 1"
   by simp
 
 lemma mapping_mult_closed:
   "mapping x \<Longrightarrow> mapping y \<Longrightarrow> mapping (x * y)"
   by (simp add: comp_associative univalent_mult_closed)
 
 lemma bijective_one_closed:
   "bijective 1"
   by simp
 
 lemma bijective_mult_closed:
   "bijective x \<Longrightarrow> bijective y \<Longrightarrow> bijective (x * y)"
   by (metis injective_mult_closed comp_associative)
 
 lemma bijective_conv_mapping:
   "bijective x \<longleftrightarrow> mapping (x\<^sup>T)"
   by (simp add: surjective_conv_total)
 
 lemma mapping_conv_bijective:
   "mapping x \<longleftrightarrow> bijective (x\<^sup>T)"
   by (simp add: total_conv_surjective)
 
 lemma reflexive_inf_closed:
   "reflexive x \<Longrightarrow> reflexive y \<Longrightarrow> reflexive (x \<sqinter> y)"
   by simp
 
 lemma reflexive_conv_closed:
   "reflexive x \<Longrightarrow> reflexive (x\<^sup>T)"
   using conv_isotone by force
 
 lemma coreflexive_inf_closed:
   "coreflexive x \<Longrightarrow> coreflexive (x \<sqinter> y)"
   by (simp add: le_infI1)
 
 lemma coreflexive_conv_closed:
   "coreflexive x \<Longrightarrow> coreflexive (x\<^sup>T)"
   using conv_order by force
 
 lemma coreflexive_symmetric:
   "coreflexive x \<Longrightarrow> symmetric x"
   by (metis comp_right_one comp_right_subdist_inf conv_dist_inf conv_dist_comp conv_involutive dedekind_1 inf.absorb1 inf_absorb2)
 
 lemma transitive_inf_closed:
   "transitive x \<Longrightarrow> transitive y \<Longrightarrow> transitive (x \<sqinter> y)"
   by (meson comp_left_subdist_inf inf.cobounded1 inf.sup_mono inf_le2 mult_right_isotone order.trans)
 
 lemma transitive_conv_closed:
   "transitive x \<Longrightarrow> transitive (x\<^sup>T)"
   using conv_order conv_dist_comp by fastforce
 
 lemma dense_conv_closed:
   "dense_rel x \<Longrightarrow> dense_rel (x\<^sup>T)"
   using conv_order conv_dist_comp by fastforce
 
 lemma idempotent_conv_closed:
   "idempotent x \<Longrightarrow> idempotent (x\<^sup>T)"
   by (metis conv_dist_comp)
 
 lemma preorder_inf_closed:
   "preorder x \<Longrightarrow> preorder y \<Longrightarrow> preorder (x \<sqinter> y)"
   using transitive_inf_closed by auto
 
 lemma preorder_conv_closed:
   "preorder x \<Longrightarrow> preorder (x\<^sup>T)"
   by (simp add: reflexive_conv_closed transitive_conv_closed)
 
 lemma symmetric_bot_closed:
   "symmetric bot"
   by simp
 
 lemma symmetric_one_closed:
   "symmetric 1"
   by simp
 
 lemma symmetric_top_closed:
   "symmetric top"
   by simp
 
 lemma symmetric_inf_closed:
   "symmetric x \<Longrightarrow> symmetric y \<Longrightarrow> symmetric (x \<sqinter> y)"
   by (simp add: conv_dist_inf)
 
 lemma symmetric_sup_closed:
   "symmetric x \<Longrightarrow> symmetric y \<Longrightarrow> symmetric (x \<squnion> y)"
   by (simp add: conv_dist_sup)
 
 lemma symmetric_conv_closed:
   "symmetric x \<Longrightarrow> symmetric (x\<^sup>T)"
   by simp
 
 lemma one_inf_conv:
   "1 \<sqinter> x = 1 \<sqinter> x\<^sup>T"
   by (metis conv_dist_inf coreflexive_symmetric inf.cobounded1 symmetric_one_closed)
 
 lemma antisymmetric_bot_closed:
   "antisymmetric bot"
   by simp
 
 lemma antisymmetric_one_closed:
   "antisymmetric 1"
   by simp
 
 lemma antisymmetric_inf_closed:
   "antisymmetric x \<Longrightarrow> antisymmetric (x \<sqinter> y)"
   by (rule order_trans[where y="x \<sqinter> x\<^sup>T"]) (simp_all add: conv_isotone inf.coboundedI2 inf.sup_assoc)
 
 lemma antisymmetric_conv_closed:
   "antisymmetric x \<Longrightarrow> antisymmetric (x\<^sup>T)"
   by (simp add: inf_commute)
 
 lemma asymmetric_bot_closed:
   "asymmetric bot"
   by simp
 
 lemma asymmetric_inf_closed:
   "asymmetric x \<Longrightarrow> asymmetric (x \<sqinter> y)"
   by (metis conv_dist_inf inf.mult_zero_left inf.left_commute inf_assoc)
 
 lemma asymmetric_conv_closed:
   "asymmetric x \<Longrightarrow> asymmetric (x\<^sup>T)"
   by (simp add: inf_commute)
 
 lemma linear_top_closed:
   "linear top"
   by simp
 
 lemma linear_sup_closed:
   "linear x \<Longrightarrow> linear (x \<squnion> y)"
   by (metis conv_dist_sup sup_assoc sup_commute sup_top_right)
 
 lemma linear_reflexive:
   "linear x \<Longrightarrow> reflexive x"
   by (metis one_inf_conv inf.distrib_left inf.cobounded2 inf.orderE reflexive_top_closed sup.idem)
 
 lemma linear_conv_closed:
   "linear x \<Longrightarrow> linear (x\<^sup>T)"
   by (simp add: sup_commute)
 
 lemma linear_comp_closed:
   assumes "linear x"
       and "linear y"
     shows "linear (x * y)"
 proof -
   have "reflexive y"
     by (simp add: assms(2) linear_reflexive)
   hence "x \<squnion> x\<^sup>T \<le> x * y \<squnion> y\<^sup>T * x\<^sup>T"
     by (metis case_split_left case_split_right le_supI sup.cobounded1 sup.cobounded2 sup.idem reflexive_conv_closed)
   thus ?thesis
     by (simp add: assms(1) conv_dist_comp top_le)
 qed
 
 lemma equivalence_one_closed:
   "equivalence 1"
   by simp
 
 lemma equivalence_top_closed:
   "equivalence top"
   by simp
 
 lemma equivalence_inf_closed:
   "equivalence x \<Longrightarrow> equivalence y \<Longrightarrow> equivalence (x \<sqinter> y)"
   using conv_dist_inf preorder_inf_closed by auto
 
 lemma equivalence_conv_closed:
   "equivalence x \<Longrightarrow> equivalence (x\<^sup>T)"
   by simp
 
 lemma order_one_closed:
   "order 1"
   by simp
 
 lemma order_inf_closed:
   "order x \<Longrightarrow> order y \<Longrightarrow> order (x \<sqinter> y)"
   using antisymmetric_inf_closed transitive_inf_closed by auto
 
 lemma order_conv_closed:
   "order x \<Longrightarrow> order (x\<^sup>T)"
   by (simp add: inf_commute reflexive_conv_closed transitive_conv_closed)
 
 lemma linear_order_conv_closed:
   "linear_order x \<Longrightarrow> linear_order (x\<^sup>T)"
   using equivalence_top_closed conv_dist_sup inf_commute reflexive_conv_closed transitive_conv_closed by force
 
 text \<open>
 We show a fact about equivalences.
 \<close>
 
 lemma equivalence_comp_dist_inf:
   "equivalence x \<Longrightarrow> x * y \<sqinter> x * z = x * (y \<sqinter> x * z)"
   by (metis order.antisym comp_right_subdist_inf dedekind_1 order.eq_iff inf.absorb1 inf.absorb2 mult_1_right mult_assoc)
 
 text \<open>
 The following result generalises the fact that composition with a test amounts to intersection with the corresponding vector.
 Both tests and vectors can be used to represent sets as relations.
 \<close>
 
 lemma coreflexive_comp_top_inf:
   "coreflexive x \<Longrightarrow> x * top \<sqinter> y = x * y"
   apply (rule order.antisym)
   apply (metis comp_left_isotone comp_left_one coreflexive_symmetric dedekind_1 inf_top_left order_trans)
   using comp_left_isotone comp_right_isotone by fastforce
 
 lemma coreflexive_comp_top_inf_one:
   "coreflexive x \<Longrightarrow> x * top \<sqinter> 1 = x"
   by (simp add: coreflexive_comp_top_inf)
 
 lemma coreflexive_comp_inf:
   "coreflexive x \<Longrightarrow> coreflexive y \<Longrightarrow> x * y = x \<sqinter> y"
   by (metis (full_types) coreflexive_comp_top_inf coreflexive_comp_top_inf_one inf.mult_assoc inf.absorb2)
 
 lemma coreflexive_comp_inf_comp:
   assumes "coreflexive x"
       and "coreflexive y"
     shows "(x * z) \<sqinter> (y * z) = (x \<sqinter> y) * z"
 proof -
   have "(x * z) \<sqinter> (y * z) = x * top \<sqinter> z \<sqinter> y * top \<sqinter> z"
     using assms coreflexive_comp_top_inf inf_assoc by auto
   also have "... = x * top \<sqinter> y * top \<sqinter> z"
     by (simp add: inf.commute inf.left_commute)
   also have "... = (x \<sqinter> y) * top \<sqinter> z"
     by (metis assms coreflexive_comp_inf coreflexive_comp_top_inf mult_assoc)
   also have "... = (x \<sqinter> y) * z"
     by (simp add: assms(1) coreflexive_comp_top_inf coreflexive_inf_closed)
   finally show ?thesis
     .
 qed
 
 lemma test_comp_test_inf:
   "(x \<sqinter> 1) * y * (z \<sqinter> 1) = (x \<sqinter> 1) * y \<sqinter> y * (z \<sqinter> 1)"
   by (smt comp_right_one comp_right_subdist_inf coreflexive_comp_top_inf inf.left_commute inf.orderE inf_le2 mult_assoc)
 
 lemma test_comp_test_top:
   "y \<sqinter> (x \<sqinter> 1) * top * (z \<sqinter> 1) = (x \<sqinter> 1) * y * (z \<sqinter> 1)"
 proof -
   have "\<forall>u v . (v \<sqinter> u\<^sup>T)\<^sup>T = v\<^sup>T \<sqinter> u"
     using conv_dist_inf by auto
   thus ?thesis
     by (smt conv_dist_comp conv_involutive coreflexive_comp_top_inf inf.cobounded2 inf.left_commute inf.sup_monoid.add_commute symmetric_one_closed mult_assoc symmetric_top_closed)
 qed
 
 lemma coreflexive_idempotent:
   "coreflexive x \<Longrightarrow> idempotent x"
   by (simp add: coreflexive_comp_inf)
 
 lemma coreflexive_univalent:
   "coreflexive x \<Longrightarrow> univalent x"
   by (simp add: coreflexive_idempotent coreflexive_symmetric)
 
 lemma coreflexive_injective:
   "coreflexive x \<Longrightarrow> injective x"
   by (simp add: coreflexive_idempotent coreflexive_symmetric)
 
 lemma coreflexive_commutative:
   "coreflexive x \<Longrightarrow> coreflexive y \<Longrightarrow> x * y = y * x"
   by (simp add: coreflexive_comp_inf inf.commute)
 
 lemma coreflexive_dedekind:
   "coreflexive x \<Longrightarrow> coreflexive y \<Longrightarrow> coreflexive z \<Longrightarrow> x * y \<sqinter> z \<le> x * (y \<sqinter> x * z)"
   by (simp add: coreflexive_comp_inf inf.coboundedI1 inf.left_commute)
 
 text \<open>
 Also the equational version of the Dedekind rule continues to hold.
 \<close>
 
 lemma dedekind_eq:
   "x * y \<sqinter> z = (x \<sqinter> (z * y\<^sup>T)) * (y \<sqinter> (x\<^sup>T * z)) \<sqinter> z"
 proof (rule order.antisym)
   have "x * y \<sqinter> z \<le> x * (y \<sqinter> (x\<^sup>T * z)) \<sqinter> z"
     by (simp add: dedekind_1)
   also have "... \<le> (x \<sqinter> (z * (y \<sqinter> (x\<^sup>T * z))\<^sup>T)) * (y \<sqinter> (x\<^sup>T * z)) \<sqinter> z"
     by (simp add: dedekind_2)
   also have "... \<le> (x \<sqinter> (z * y\<^sup>T)) * (y \<sqinter> (x\<^sup>T * z)) \<sqinter> z"
     by (metis comp_left_isotone comp_right_isotone inf_mono conv_order inf.cobounded1 order_refl)
   finally show "x * y \<sqinter> z \<le> (x \<sqinter> (z * y\<^sup>T)) * (y \<sqinter> (x\<^sup>T * z)) \<sqinter> z"
     .
 next
   show "(x \<sqinter> (z * y\<^sup>T)) * (y \<sqinter> (x\<^sup>T * z)) \<sqinter> z \<le> x * y \<sqinter> z"
     using comp_isotone inf.sup_left_isotone by auto
 qed
 
 lemma dedekind:
   "x * y \<sqinter> z \<le> (x \<sqinter> (z * y\<^sup>T)) * (y \<sqinter> (x\<^sup>T * z))"
   by (metis dedekind_eq inf.cobounded1)
 
 lemma vector_export_comp:
   "(x * top \<sqinter> y) * z = x * top \<sqinter> y * z"
 proof -
   have "vector (x * top)"
     by (simp add: comp_associative)
   thus ?thesis
     by (simp add: vector_inf_comp)
 qed
 
 lemma vector_export_comp_unit:
   "(x * top \<sqinter> 1) * y = x * top \<sqinter> y"
   by (simp add: vector_export_comp)
 
 text \<open>
 We solve a few exercises from \cite{SchmidtStroehlein1993}.
 \<close>
 
 lemma ex231a [simp]:
   "(1 \<sqinter> x * x\<^sup>T) * x = x"
   by (metis inf.cobounded1 inf.idem inf_right_idem comp_left_one conv_one coreflexive_comp_top_inf dedekind_eq)
 
 lemma ex231b [simp]:
   "x * (1 \<sqinter> x\<^sup>T * x) = x"
   by (metis conv_dist_comp conv_dist_inf conv_involutive conv_one ex231a)
 
 lemma ex231c:
   "x \<le> x * x\<^sup>T * x"
   by (metis comp_left_isotone ex231a inf_le2)
 
 lemma ex231d:
   "x \<le> x * top * x"
   by (metis comp_left_isotone comp_right_isotone top_greatest order_trans ex231c)
 
 lemma ex231e [simp]:
   "x * top * x * top = x * top"
   by (metis ex231d order.antisym comp_associative mult_right_isotone top.extremum)
 
 lemma arc_injective:
   "arc x \<Longrightarrow> injective x"
   by (metis conv_dist_inf conv_involutive inf.absorb2 top_right_mult_increasing univalent_inf_closed)
 
 lemma arc_conv_closed:
   "arc x \<Longrightarrow> arc (x\<^sup>T)"
   by simp
 
 lemma arc_univalent:
   "arc x \<Longrightarrow> univalent x"
   using arc_conv_closed arc_injective univalent_conv_injective by blast
 
 lemma injective_codomain:
   assumes "injective x"
   shows "x * (x \<sqinter> 1) = x \<sqinter> 1"
 proof (rule order.antisym)
   show "x * (x \<sqinter> 1) \<le> x \<sqinter> 1"
     by (metis assms comp_right_one dual_order.trans inf.boundedI inf.cobounded1 inf.sup_monoid.add_commute mult_right_isotone one_inf_conv)
 next
   show "x \<sqinter> 1 \<le> x * (x \<sqinter> 1)"
     by (metis coreflexive_idempotent inf.cobounded1 inf.cobounded2 mult_left_isotone)
 qed
 
 text \<open>
 The following result generalises \cite[Exercise 2]{Oliveira2009}.
 It is used to show that the while-loop preserves injectivity of the constructed tree.
 \<close>
 
 lemma injective_sup:
   assumes "injective t"
       and "e * t\<^sup>T \<le> 1"
       and "injective e"
     shows "injective (t \<squnion> e)"
 proof -
   have "(t \<squnion> e) * (t \<squnion> e)\<^sup>T = t * t\<^sup>T \<squnion> t * e\<^sup>T \<squnion> e * t\<^sup>T \<squnion> e * e\<^sup>T"
     by (simp add: comp_left_dist_sup conv_dist_sup semiring.distrib_right sup.assoc)
   thus ?thesis
     using assms coreflexive_symmetric conv_dist_comp by fastforce
 qed
 
 lemma injective_inv:
   "injective t \<Longrightarrow> e * t\<^sup>T = bot \<Longrightarrow> arc e \<Longrightarrow> injective (t \<squnion> e)"
   using arc_injective injective_sup bot_least by blast
 
 lemma univalent_sup:
   "univalent t \<Longrightarrow> e\<^sup>T * t \<le> 1 \<Longrightarrow> univalent e \<Longrightarrow> univalent (t \<squnion> e)"
   by (metis injective_sup conv_dist_sup conv_involutive)
 
 lemma point_injective:
   "arc x \<Longrightarrow> x\<^sup>T * top * x \<le> 1"
   by (metis conv_top comp_associative conv_dist_comp conv_involutive vector_top_closed)
 
 lemma vv_transitive:
   "vector v \<Longrightarrow> (v * v\<^sup>T) * (v * v\<^sup>T) \<le> v * v\<^sup>T"
   by (metis comp_associative comp_left_isotone comp_right_isotone top_greatest)
 
 lemma epm_3:
   assumes "e \<le> w"
       and "injective w"
     shows "e = w \<sqinter> top * e"
 proof -
   have "w \<sqinter> top * e \<le> w * e\<^sup>T * e"
     by (metis (no_types, lifting) inf.absorb2 top.extremum dedekind_2 inf.commute)
   also have "... \<le> w * w\<^sup>T * e"
     by (simp add: assms(1) conv_isotone mult_left_isotone mult_right_isotone)
   also have "... \<le> e"
     using assms(2) coreflexive_comp_top_inf inf.sup_right_divisibility by blast
   finally show ?thesis
     by (simp add: assms(1) top_left_mult_increasing order.antisym)
 qed
 
 lemma comp_inf_vector:
   "x * (y \<sqinter> z * top) = (x \<sqinter> top * z\<^sup>T) * y"
   by (metis conv_top covector_inf_comp_3 comp_associative conv_dist_comp inf.commute vector_top_closed)
 
 lemma inf_vector_comp:
   "(x \<sqinter> y * top) * z = y * top \<sqinter> x * z"
   using inf.commute vector_export_comp by auto
 
 lemma comp_inf_covector:
   "x * (y \<sqinter> top * z) = x * y \<sqinter> top * z"
   by (simp add: covector_comp_inf covector_mult_closed)
 
 text \<open>
 Well-known distributivity properties of univalent and injective relations over meet continue to hold.
 \<close>
 
 lemma univalent_comp_left_dist_inf:
   assumes "univalent x"
     shows "x * (y \<sqinter> z) = x * y \<sqinter> x * z"
 proof (rule order.antisym)
   show "x * (y \<sqinter> z) \<le> x * y \<sqinter> x * z"
     by (simp add: comp_right_isotone)
 next
   have "x * y \<sqinter> x * z \<le> (x \<sqinter> x * z * y\<^sup>T) * (y \<sqinter> x\<^sup>T * x * z)"
     by (metis comp_associative dedekind)
   also have "... \<le> x * (y \<sqinter> x\<^sup>T * x * z)"
     by (simp add: comp_left_isotone)
   also have "... \<le> x * (y \<sqinter> 1 * z)"
     using assms comp_left_isotone comp_right_isotone inf.sup_right_isotone by blast
   finally show "x * y \<sqinter> x * z \<le> x * (y \<sqinter> z)"
     by simp
 qed
 
 lemma injective_comp_right_dist_inf:
   "injective z \<Longrightarrow> (x \<sqinter> y) * z = x * z \<sqinter> y * z"
   by (metis univalent_comp_left_dist_inf conv_dist_comp conv_involutive conv_dist_inf)
 
 lemma vector_covector:
   "vector v \<Longrightarrow> vector w \<Longrightarrow> v \<sqinter> w\<^sup>T = v * w\<^sup>T"
   by (metis covector_comp_inf inf_top_left vector_conv_covector)
 
 lemma comp_inf_vector_1:
   "(x \<sqinter> top * y) * z = x * (z \<sqinter> (top * y)\<^sup>T)"
   by (simp add: comp_inf_vector conv_dist_comp)
 
 text \<open>
 The shunting properties for bijective relations and mappings continue to hold.
 \<close>
 
 lemma shunt_bijective:
   assumes "bijective z"
     shows "x \<le> y * z \<longleftrightarrow> x * z\<^sup>T \<le> y"
 proof
   assume "x \<le> y * z"
   hence "x * z\<^sup>T \<le> y * z * z\<^sup>T"
     by (simp add: mult_left_isotone)
   also have "... \<le> y"
     using assms comp_associative mult_right_isotone by fastforce
   finally show "x * z\<^sup>T \<le> y"
     .
 next
   assume 1: "x * z\<^sup>T \<le> y"
   have "x = x \<sqinter> top * z"
     by (simp add: assms)
   also have "... \<le> x * z\<^sup>T * z"
     by (metis dedekind_2 inf_commute inf_top.right_neutral)
   also have "... \<le> y * z"
     using 1 by (simp add: mult_left_isotone)
   finally show "x \<le> y * z"
     .
 qed
 
 lemma shunt_mapping:
   "mapping z \<Longrightarrow> x \<le> z * y \<longleftrightarrow> z\<^sup>T * x \<le> y"
   by (metis shunt_bijective mapping_conv_bijective conv_order conv_dist_comp conv_involutive)
 
 lemma bijective_reverse:
   assumes "bijective p"
       and "bijective q"
     shows "p \<le> r * q \<longleftrightarrow> q \<le> r\<^sup>T * p"
 proof -
   have "p \<le> r * q \<longleftrightarrow> p * q\<^sup>T \<le> r"
     by (simp add: assms(2) shunt_bijective)
   also have "... \<longleftrightarrow> q\<^sup>T \<le> p\<^sup>T * r"
     by (metis assms(1) conv_dist_comp conv_involutive conv_order shunt_bijective)
   also have "... \<longleftrightarrow> q \<le> r\<^sup>T * p"
     using conv_dist_comp conv_isotone by fastforce
   finally show ?thesis
     by simp
 qed
 
 lemma arc_expanded:
   "arc x \<longleftrightarrow> x * top * x\<^sup>T \<le> 1 \<and> x\<^sup>T * top * x \<le> 1 \<and> top * x * top = top"
   by (metis conv_top comp_associative conv_dist_comp conv_involutive vector_top_closed)
 
 lemma arc_top_arc:
   assumes "arc x"
     shows "x * top * x = x"
   by (metis assms epm_3 top_right_mult_increasing vector_inf_comp vector_mult_closed vector_top_closed)
 
 lemma arc_top_edge:
   assumes "arc x"
     shows "x\<^sup>T * top * x = x\<^sup>T * x"
 proof -
   have "x\<^sup>T = x\<^sup>T * top \<sqinter> top * x\<^sup>T"
     using assms epm_3 top_right_mult_increasing by simp
   thus ?thesis
     by (metis comp_inf_vector_1 conv_dist_comp conv_involutive conv_top inf.absorb1 top_right_mult_increasing)
 qed
 
 text \<open>Lemmas \<open>arc_eq_1\<close> and \<open>arc_eq_2\<close> were contributed by Nicolas Robinson-O'Brien.\<close>
 
 lemma arc_eq_1:
   assumes "arc x"
     shows "x = x * x\<^sup>T * x"
 proof -
   have "x * x\<^sup>T * x \<le> x * top * x"
     by (simp add: mult_left_isotone mult_right_isotone)
   also have "... \<le> x"
     by (simp add: assms arc_top_arc)
   finally have "x * x\<^sup>T * x \<le> x"
     by simp
   thus ?thesis
     by (simp add: order.antisym ex231c)
 qed
 
 lemma arc_eq_2:
   assumes "arc x"
     shows "x\<^sup>T = x\<^sup>T * x * x\<^sup>T"
   using arc_eq_1 assms conv_involutive by fastforce
 
 lemma points_arc:
   "point x \<Longrightarrow> point y \<Longrightarrow> arc (x * y\<^sup>T)"
   by (metis comp_associative conv_dist_comp conv_involutive equivalence_top_closed)
 
 lemma point_arc:
   "point x \<Longrightarrow> arc (x * x\<^sup>T)"
   by (simp add: points_arc)
 
+lemma arc_expanded_1:
+  "arc e \<Longrightarrow> e * x * e\<^sup>T \<le> 1"
+  by (meson arc_expanded order_trans top_greatest mult_left_isotone mult_right_isotone)
+
+lemma arc_expanded_2:
+  "arc e \<Longrightarrow> e\<^sup>T * x * e \<le> 1"
+  by (meson arc_expanded order_trans top_greatest mult_left_isotone mult_right_isotone)
+
+lemma point_conv_comp:
+  "point x \<Longrightarrow> x\<^sup>T * x = top"
+  using order_eq_iff shunt_bijective top_greatest vector_conv_covector by blast
+
+lemma point_antisymmetric:
+  "point x \<Longrightarrow> antisymmetric x"
+  by (simp add: vector_covector)
+
+lemma mapping_inf_point_arc:
+  assumes "mapping x"
+      and "point y"
+    shows "arc (x \<sqinter> y)"
+proof (unfold arc_expanded, intro conjI)
+  show "(x \<sqinter> y) * top * (x \<sqinter> y)\<^sup>T \<le> 1"
+    by (metis assms conv_dist_comp covector_conv_vector inf.orderE inf.sup_monoid.add_commute surjective_conv_total top.extremum top_right_mult_increasing vector_export_comp)
+  have "(x \<sqinter> y)\<^sup>T * top * (x \<sqinter> y) = x\<^sup>T * y * (x \<sqinter> y)"
+    by (simp add: assms(2) conv_dist_inf covector_inf_comp_3)
+  also have "... = x\<^sup>T * (y \<sqinter> y\<^sup>T) * x"
+    by (simp add: assms(2) comp_associative covector_inf_comp_3 inf.sup_monoid.add_commute)
+  also have "... \<le> x\<^sup>T * x"
+    by (metis assms(2) comp_right_one mult_left_isotone mult_right_isotone vector_covector)
+  also have "... \<le> 1"
+    by (simp add: assms(1))
+  finally show "(x \<sqinter> y)\<^sup>T * top * (x \<sqinter> y) \<le> 1"
+    .
+  show "top * (x \<sqinter> y) * top = top"
+    by (metis assms inf_top_right inf_vector_comp mult_assoc)
+qed
+
 end
 
 subsection \<open>Single-Object Pseudocomplemented Distributive Allegories\<close>
 
 text \<open>
 We extend single-object bounded distributive allegories by a pseudocomplement operation.
 The following definitions concern properties of relations that require a pseudocomplement.
 \<close>
 
 class relation_algebra_signature = bounded_distrib_allegory_signature + uminus
 begin
 
 abbreviation irreflexive         :: "'a \<Rightarrow> bool" where "irreflexive x         \<equiv> x \<le> -1"
 abbreviation strict_linear       :: "'a \<Rightarrow> bool" where "strict_linear x       \<equiv> x \<squnion> x\<^sup>T = -1"
 
 abbreviation strict_order        :: "'a \<Rightarrow> bool" where "strict_order x        \<equiv> irreflexive x \<and> transitive x"
 abbreviation linear_strict_order :: "'a \<Rightarrow> bool" where "linear_strict_order x \<equiv> strict_order x \<and> strict_linear x"
 
 text \<open>
 The following variants are useful for the graph model.
 \<close>
 
 abbreviation pp_mapping          :: "'a \<Rightarrow> bool" where "pp_mapping x          \<equiv> univalent x \<and> total (--x)"
 abbreviation pp_bijective        :: "'a \<Rightarrow> bool" where "pp_bijective x        \<equiv> injective x \<and> surjective (--x)"
 
 abbreviation pp_point            :: "'a \<Rightarrow> bool" where "pp_point x            \<equiv> vector x \<and> pp_bijective x"
 abbreviation pp_arc              :: "'a \<Rightarrow> bool" where "pp_arc x              \<equiv> pp_bijective (x * top) \<and> pp_bijective (x\<^sup>T * top)"
 
 end
 
 class pd_allegory = bounded_distrib_allegory + p_algebra
 begin
 
 subclass relation_algebra_signature .
 
 subclass pd_algebra ..
 
 lemma conv_complement_1:
   "-(x\<^sup>T) \<squnion> (-x)\<^sup>T = (-x)\<^sup>T"
   by (metis conv_dist_inf conv_order bot_least conv_involutive pseudo_complement sup.absorb2 sup.cobounded2)
 
 lemma conv_complement:
   "(-x)\<^sup>T = -(x\<^sup>T)"
   by (metis conv_complement_1 conv_dist_sup conv_involutive sup_commute)
 
 lemma conv_complement_sub_inf [simp]:
   "x\<^sup>T * -(x * y) \<sqinter> y = bot"
   by (metis comp_left_zero conv_dist_comp conv_involutive dedekind_1 inf_import_p inf_p inf_right_idem ppp pseudo_complement regular_closed_bot)
 
 lemma conv_complement_sub_leq:
   "x\<^sup>T * -(x * y) \<le> -y"
   using pseudo_complement conv_complement_sub_inf by blast
 
 lemma conv_complement_sub [simp]:
   "x\<^sup>T * -(x * y) \<squnion> -y = -y"
   by (simp add: conv_complement_sub_leq sup.absorb2)
 
 lemma complement_conv_sub:
   "-(y * x) * x\<^sup>T \<le> -y"
   by (metis conv_complement conv_complement_sub_leq conv_order conv_dist_comp)
 
 text \<open>
 The following so-called Schr\"oder equivalences, or De Morgan's Theorem K, hold only with a pseudocomplemented element on both right-hand sides.
 \<close>
 
 lemma schroeder_3_p:
   "x * y \<le> -z \<longleftrightarrow> x\<^sup>T * z \<le> -y"
   using pseudo_complement schroeder_1 by auto
 
 lemma schroeder_4_p:
   "x * y \<le> -z \<longleftrightarrow> z * y\<^sup>T \<le> -x"
   using pseudo_complement schroeder_2 by auto
 
 lemma comp_pp_semi_commute:
   "x * --y \<le> --(x * y)"
   using conv_complement_sub_leq schroeder_3_p by fastforce
 
 text \<open>
 The following result looks similar to a property of (anti)domain.
 \<close>
 
 lemma p_comp_pp [simp]:
   "-(x * --y) = -(x * y)"
   using comp_pp_semi_commute comp_right_isotone order.eq_iff p_antitone pp_increasing by fastforce
 
 lemma pp_comp_semi_commute:
   "--x * y \<le> --(x * y)"
   using complement_conv_sub schroeder_4_p by fastforce
 
 lemma p_pp_comp [simp]:
   "-(--x * y) = -(x * y)"
   using pp_comp_semi_commute comp_left_isotone order.eq_iff p_antitone pp_increasing by fastforce
 
 lemma pp_comp_subdist:
   "--x * --y \<le> --(x * y)"
   by (simp add: p_antitone_iff)
 
 lemma theorem24xxiii:
   "x * y \<sqinter> -(x * z) = x * (y \<sqinter> -z) \<sqinter> -(x * z)"
 proof -
   have "x * y \<sqinter> -(x * z) \<le> x * (y \<sqinter> (x\<^sup>T * -(x * z)))"
     by (simp add: dedekind_1)
   also have "... \<le> x * (y \<sqinter> -z)"
     using comp_right_isotone conv_complement_sub_leq inf.sup_right_isotone by auto
   finally show ?thesis
     using comp_right_subdist_inf order.antisym inf.coboundedI2 inf.commute by auto
 qed
 
 text \<open>
 Even in Stone relation algebras, we do not obtain the backward implication in the following result.
 \<close>
 
 lemma vector_complement_closed:
   "vector x \<Longrightarrow> vector (-x)"
   by (metis complement_conv_sub conv_top order.eq_iff top_right_mult_increasing)
 
 lemma covector_complement_closed:
   "covector x \<Longrightarrow> covector (-x)"
   by (metis conv_complement_sub_leq conv_top order.eq_iff top_left_mult_increasing)
 
 lemma covector_vector_comp:
   "vector v \<Longrightarrow> -v\<^sup>T * v = bot"
   by (metis conv_bot conv_complement conv_complement_sub_inf conv_dist_comp conv_involutive inf_top.right_neutral)
 
 lemma irreflexive_bot_closed:
   "irreflexive bot"
   by simp
 
 lemma irreflexive_inf_closed:
   "irreflexive x \<Longrightarrow> irreflexive (x \<sqinter> y)"
   by (simp add: le_infI1)
 
 lemma irreflexive_sup_closed:
   "irreflexive x \<Longrightarrow> irreflexive y \<Longrightarrow> irreflexive (x \<squnion> y)"
   by simp
 
 lemma irreflexive_conv_closed:
   "irreflexive x \<Longrightarrow> irreflexive (x\<^sup>T)"
   using conv_complement conv_isotone by fastforce
 
 lemma reflexive_complement_irreflexive:
   "reflexive x \<Longrightarrow> irreflexive (-x)"
   by (simp add: p_antitone)
 
 lemma irreflexive_complement_reflexive:
   "irreflexive x \<longleftrightarrow> reflexive (-x)"
   by (simp add: p_antitone_iff)
 
 lemma symmetric_complement_closed:
   "symmetric x \<Longrightarrow> symmetric (-x)"
   by (simp add: conv_complement)
 
 lemma asymmetric_irreflexive:
   "asymmetric x \<Longrightarrow> irreflexive x"
   by (metis inf.mult_not_zero inf.left_commute inf.right_idem inf.sup_monoid.add_commute pseudo_complement one_inf_conv)
 
 lemma linear_asymmetric:
   "linear x \<Longrightarrow> asymmetric (-x)"
   using conv_complement p_top by force
 
 lemma strict_linear_sup_closed:
   "strict_linear x \<Longrightarrow> strict_linear y \<Longrightarrow> strict_linear (x \<squnion> y)"
   by (metis (mono_tags, hide_lams) conv_dist_sup sup.right_idem sup_assoc sup_commute)
 
 lemma strict_linear_irreflexive:
   "strict_linear x \<Longrightarrow> irreflexive x"
   using sup_left_divisibility by blast
 
 lemma strict_linear_conv_closed:
   "strict_linear x \<Longrightarrow> strict_linear (x\<^sup>T)"
   by (simp add: sup_commute)
 
 lemma strict_order_var:
   "strict_order x \<longleftrightarrow> asymmetric x \<and> transitive x"
   by (metis asymmetric_irreflexive comp_right_one irreflexive_conv_closed conv_dist_comp dual_order.trans pseudo_complement schroeder_3_p)
 
 lemma strict_order_bot_closed:
   "strict_order bot"
   by simp
 
 lemma strict_order_inf_closed:
   "strict_order x \<Longrightarrow> strict_order y \<Longrightarrow> strict_order (x \<sqinter> y)"
   using inf.coboundedI1 transitive_inf_closed by auto
 
 lemma strict_order_conv_closed:
   "strict_order x \<Longrightarrow> strict_order (x\<^sup>T)"
   using irreflexive_conv_closed transitive_conv_closed by blast
 
 lemma order_strict_order:
   assumes "order x"
   shows "strict_order (x \<sqinter> -1)"
 proof (rule conjI)
   show 1: "irreflexive (x \<sqinter> -1)"
     by simp
   have "antisymmetric (x \<sqinter> -1)"
     using antisymmetric_inf_closed assms by blast
   hence "(x \<sqinter> -1) * (x \<sqinter> -1) \<sqinter> 1 \<le> (x \<sqinter> -1 \<sqinter> (x \<sqinter> -1)\<^sup>T) * (x \<sqinter> -1 \<sqinter> (x \<sqinter> -1)\<^sup>T)"
     using 1 by (metis (no_types) coreflexive_symmetric irreflexive_inf_closed coreflexive_transitive dedekind_1 inf_idem mult_1_right semiring.mult_not_zero strict_order_var)
   also have "... = (x \<sqinter> x\<^sup>T \<sqinter> -1) * (x \<sqinter> x\<^sup>T \<sqinter> -1)"
     by (simp add: conv_complement conv_dist_inf inf.absorb2 inf.sup_monoid.add_assoc)
   also have "... = bot"
     using assms order.antisym reflexive_conv_closed by fastforce
   finally have "(x \<sqinter> -1) * (x \<sqinter> -1) \<le> -1"
     using le_bot pseudo_complement by blast
   thus "transitive (x \<sqinter> -1)"
     by (meson assms comp_isotone inf.boundedI inf.cobounded1 inf.order_lesseq_imp)
 qed
 
 lemma strict_order_order:
   "strict_order x \<Longrightarrow> order (x \<squnion> 1)"
   apply (unfold strict_order_var, intro conjI)
   apply simp
   apply (simp add: mult_left_dist_sup mult_right_dist_sup sup.absorb2)
   using conv_dist_sup coreflexive_bot_closed sup.absorb2 sup_inf_distrib2 by fastforce
 
 lemma linear_strict_order_conv_closed:
   "linear_strict_order x \<Longrightarrow> linear_strict_order (x\<^sup>T)"
   by (simp add: irreflexive_conv_closed sup_monoid.add_commute transitive_conv_closed)
 
 lemma linear_order_strict_order:
   "linear_order x \<Longrightarrow> linear_strict_order (x \<sqinter> -1)"
   apply (rule conjI)
   using order_strict_order apply simp
   by (metis conv_complement conv_dist_inf coreflexive_symmetric order.eq_iff inf.absorb2 inf.distrib_left inf.sup_monoid.add_commute top.extremum)
 
 lemma regular_conv_closed:
   "regular x \<Longrightarrow> regular (x\<^sup>T)"
   by (metis conv_complement)
 
 text \<open>
 We show a number of facts about equivalences.
 \<close>
 
 lemma equivalence_comp_left_complement:
   "equivalence x \<Longrightarrow> x * -x = -x"
   apply (rule order.antisym)
   apply (metis conv_complement_sub_leq preorder_idempotent)
   using mult_left_isotone by fastforce
 
 lemma equivalence_comp_right_complement:
   "equivalence x \<Longrightarrow> -x * x = -x"
   by (metis equivalence_comp_left_complement conv_complement conv_dist_comp)
 
 text \<open>
 The pseudocomplement of tests is given by the following operation.
 \<close>
 
 abbreviation coreflexive_complement :: "'a \<Rightarrow> 'a" ("_ ''" [80] 80)
   where "x ' \<equiv> -x \<sqinter> 1"
 
 lemma coreflexive_comp_top_coreflexive_complement:
   "coreflexive x \<Longrightarrow> (x * top)' = x '"
   by (metis coreflexive_comp_top_inf_one inf.commute inf_import_p)
 
 lemma coreflexive_comp_inf_complement:
   "coreflexive x \<Longrightarrow> (x * y) \<sqinter> -z = (x * y) \<sqinter> -(x * z)"
   by (metis coreflexive_comp_top_inf inf.sup_relative_same_increasing inf_import_p inf_le1)
 
 lemma double_coreflexive_complement:
   "x '' = (-x)'"
   using inf.sup_monoid.add_commute inf_import_p by auto
 
 lemma coreflexive_pp_dist_comp:
   assumes "coreflexive x"
       and "coreflexive y"
     shows "(x * y)'' = x '' * y ''"
 proof -
   have "(x * y)'' = --(x * y) \<sqinter> 1"
     by (simp add: double_coreflexive_complement)
   also have "... = --x \<sqinter> --y \<sqinter> 1"
     by (simp add: assms coreflexive_comp_inf)
   also have "... = (--x \<sqinter> 1) * (--y \<sqinter> 1)"
     by (simp add: coreflexive_comp_inf inf.left_commute inf.sup_monoid.add_assoc)
   also have "... = x '' * y ''"
     by (simp add: double_coreflexive_complement)
   finally show ?thesis
     .
 qed
 
 lemma coreflexive_pseudo_complement:
   "coreflexive x \<Longrightarrow> x \<sqinter> y = bot \<longleftrightarrow> x \<le> y '"
   by (simp add: pseudo_complement)
 
 lemma pp_bijective_conv_mapping:
   "pp_bijective x \<longleftrightarrow> pp_mapping (x\<^sup>T)"
   by (simp add: conv_complement surjective_conv_total)
 
 lemma pp_arc_expanded:
   "pp_arc x \<longleftrightarrow> x * top * x\<^sup>T \<le> 1 \<and> x\<^sup>T * top * x \<le> 1 \<and> top * --x * top = top"
 proof
   assume 1: "pp_arc x"
   have 2: "x * top * x\<^sup>T \<le> 1"
     using 1 by (metis comp_associative conv_dist_comp equivalence_top_closed vector_top_closed)
   have 3: "x\<^sup>T * top * x \<le> 1"
     using 1 by (metis conv_dist_comp conv_involutive equivalence_top_closed vector_top_closed mult_assoc)
   have 4: "x\<^sup>T \<le> x\<^sup>T * x * x\<^sup>T"
     by (metis conv_involutive ex231c)
   have "top = --(top * x) * top"
     using 1 by (metis conv_complement conv_dist_comp conv_involutive equivalence_top_closed)
   also have "... \<le> --(top * x\<^sup>T * top * x) * top"
     using 1 by (metis eq_refl mult_assoc p_comp_pp p_pp_comp)
   also have "... = (top * --(x * top) \<sqinter> --(top * x\<^sup>T * top * x)) * top"
     using 1 by simp
   also have "... = top * (--(x * top) \<sqinter> --(top * x\<^sup>T * top * x)) * top"
     by (simp add: covector_complement_closed covector_comp_inf covector_mult_closed)
   also have "... = top * --(x * top \<sqinter> top * x\<^sup>T * top * x) * top"
     by simp
   also have "... = top * --(x * top * x\<^sup>T * top * x) * top"
     by (metis comp_associative comp_inf_covector inf_top.left_neutral)
   also have "... \<le> top * --(x * top * x\<^sup>T * x * x\<^sup>T * top * x) * top"
     using 4 by (metis comp_associative comp_left_isotone comp_right_isotone pp_isotone)
   also have "... \<le> top * --(x * x\<^sup>T * top * x) * top"
     using 2 by (metis comp_associative comp_left_isotone comp_right_isotone pp_isotone comp_left_one)
   also have "... \<le> top * --x * top"
     using 3 by (metis comp_associative comp_left_isotone comp_right_isotone pp_isotone comp_right_one)
   finally show "x * top * x\<^sup>T \<le> 1 \<and> x\<^sup>T * top * x \<le> 1 \<and> top * --x * top = top"
     using 2 3 top_le by blast
 next
   assume "x * top * x\<^sup>T \<le> 1 \<and> x\<^sup>T * top * x \<le> 1 \<and> top * --x * top = top"
   thus "pp_arc x"
     apply (intro conjI)
     apply (metis comp_associative conv_dist_comp equivalence_top_closed vector_top_closed)
     apply (metis comp_associative mult_right_isotone top_le pp_comp_semi_commute)
     apply (metis conv_dist_comp coreflexive_symmetric vector_conv_covector vector_top_closed mult_assoc)
     by (metis conv_complement conv_dist_comp equivalence_top_closed inf.orderE inf_top.left_neutral mult_right_isotone pp_comp_semi_commute)
 qed
 
 text \<open>
 The following operation represents states with infinite executions of non-strict computations.
 \<close>
 
 abbreviation N :: "'a \<Rightarrow> 'a"
   where "N x \<equiv> -(-x * top) \<sqinter> 1"
 
 lemma N_comp:
   "N x * y = -(-x * top) \<sqinter> y"
   by (simp add: vector_mult_closed vector_complement_closed vector_inf_one_comp)
 
 lemma N_comp_top [simp]:
   "N x * top = -(-x * top)"
   by (simp add: N_comp)
 
 lemma vector_N_pp:
   "vector x \<Longrightarrow> N x = --x \<sqinter> 1"
   by (simp add: vector_complement_closed)
 
 lemma N_vector_pp [simp]:
   "N (x * top) = --(x * top) \<sqinter> 1"
   by (simp add: comp_associative vector_complement_closed)
 
 lemma N_vector_top_pp [simp]:
   "N (x * top) * top = --(x * top)"
   by (metis N_comp_top comp_associative vector_top_closed vector_complement_closed)
 
 lemma N_below_inf_one_pp:
   "N x \<le> --x \<sqinter> 1"
   using inf.sup_left_isotone p_antitone top_right_mult_increasing by auto
 
 lemma N_below_pp:
   "N x \<le> --x"
   using N_below_inf_one_pp by auto
 
 lemma N_comp_N:
   "N x * N y = -(-x * top) \<sqinter> -(-y * top) \<sqinter> 1"
   by (simp add: N_comp inf.mult_assoc)
 
 lemma N_bot [simp]:
   "N bot = bot"
   by simp
 
 lemma N_top [simp]:
   "N top = 1"
   by simp
 
 lemma n_split_omega_mult_pp:
   "xs * --xo = xo \<Longrightarrow> vector xo \<Longrightarrow> N top * xo = xs * N xo * top"
   by (metis N_top N_vector_top_pp comp_associative comp_left_one)
 
 text \<open>
 Many of the following results have been derived for verifying Prim's minimum spanning tree algorithm.
 \<close>
 
 lemma ee:
   assumes "vector v"
       and "e \<le> v * -v\<^sup>T"
     shows "e * e = bot"
 proof -
   have "e * v \<le> bot"
     by (metis assms covector_vector_comp comp_associative mult_left_isotone mult_right_zero)
   thus ?thesis
     by (metis assms(2) bot_unique comp_associative mult_right_isotone semiring.mult_not_zero)
 qed
 
 lemma et:
   assumes "vector v"
       and "e \<le> v * -v\<^sup>T"
       and "t \<le> v * v\<^sup>T"
     shows "e * t = bot"
       and "e * t\<^sup>T = bot"
 proof -
   have "e * t \<le> v * -v\<^sup>T * v * v\<^sup>T"
     using assms(2-3) comp_isotone mult_assoc by fastforce
   thus "e * t = bot"
     by (simp add: assms(1) covector_vector_comp le_bot mult_assoc)
 next
   have "t\<^sup>T \<le> v * v\<^sup>T"
     using assms(3) conv_order conv_dist_comp by fastforce
   hence "e * t\<^sup>T \<le> v * -v\<^sup>T * v * v\<^sup>T"
     by (metis assms(2) comp_associative comp_isotone)
   thus "e * t\<^sup>T = bot"
     by (simp add: assms(1) covector_vector_comp le_bot mult_assoc)
 qed
 
 lemma ve_dist:
   assumes "e \<le> v * -v\<^sup>T"
       and "vector v"
       and "arc e"
     shows "(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"
 proof -
   have "e \<le> v * top"
     using assms(1) comp_right_isotone dual_order.trans top_greatest by blast
   hence "v * top * e = v * top * (v * top \<sqinter> e)"
     by (simp add: inf.absorb2)
   also have "... = (v * top \<sqinter> top * v\<^sup>T) * e"
     using assms(2) covector_inf_comp_3 vector_conv_covector by force
   also have "... = v * top * v\<^sup>T * e"
     by (metis assms(2) inf_top_right vector_inf_comp)
   also have "... = v * v\<^sup>T * e"
     by (simp add: assms(2))
   finally have 1: "v * top * e = v * v\<^sup>T * e"
     .
   have "e\<^sup>T * top * e \<le> e\<^sup>T * top * e * e\<^sup>T * e"
     using ex231c comp_associative mult_right_isotone by auto
   also have "... \<le> e\<^sup>T * e"
     by (metis assms(3) coreflexive_comp_top_inf le_infE mult_semi_associative point_injective)
   finally have 2: "e\<^sup>T * top * e = e\<^sup>T * e"
     by (simp add: order.antisym mult_left_isotone top_right_mult_increasing)
   have "(v \<squnion> e\<^sup>T * top) * (v \<squnion> e\<^sup>T * top)\<^sup>T = (v \<squnion> e\<^sup>T * top) * (v\<^sup>T \<squnion> top * e)"
     by (simp add: conv_dist_comp conv_dist_sup)
   also have "... = v * v\<^sup>T \<squnion> v * top * e \<squnion> e\<^sup>T * top * v\<^sup>T \<squnion> e\<^sup>T * top * top * e"
     by (metis semiring.distrib_left semiring.distrib_right sup_assoc mult_assoc)
   also have "... = v * v\<^sup>T \<squnion> v * top * e \<squnion> (v * top * e)\<^sup>T \<squnion> e\<^sup>T * top * e"
     by (simp add: comp_associative conv_dist_comp)
   also have "... = v * v\<^sup>T \<squnion> v * v\<^sup>T * e \<squnion> (v * v\<^sup>T * e)\<^sup>T \<squnion> e\<^sup>T * e"
     using 1 2 by simp
   finally show ?thesis
     by (simp add: comp_associative conv_dist_comp)
 qed
 
 lemma ev:
   "vector v \<Longrightarrow> e \<le> v * -v\<^sup>T \<Longrightarrow> e * v = bot"
   by (metis covector_vector_comp order.antisym bot_least comp_associative mult_left_isotone mult_right_zero)
 
 lemma vTeT:
   "vector v \<Longrightarrow> e \<le> v * -v\<^sup>T \<Longrightarrow> v\<^sup>T * e\<^sup>T = bot"
   using conv_bot ev conv_dist_comp by fastforce
 
 text \<open>
 The following result is used to show that the while-loop of Prim's algorithm preserves that the constructed tree is a subgraph of g.
 \<close>
 
 lemma prim_subgraph_inv:
   assumes "e \<le> v * -v\<^sup>T \<sqinter> g"
       and "t \<le> v * v\<^sup>T \<sqinter> g"
     shows "t \<squnion> e \<le> ((v \<squnion> e\<^sup>T * top) * (v \<squnion> e\<^sup>T * top)\<^sup>T) \<sqinter> g"
 proof (rule sup_least)
   have "t \<le> ((v \<squnion> e\<^sup>T * top) * v\<^sup>T) \<sqinter> g"
     using assms(2) le_supI1 mult_right_dist_sup by auto
   also have "... \<le> ((v \<squnion> e\<^sup>T * top) * (v \<squnion> e\<^sup>T * top)\<^sup>T) \<sqinter> g"
     using comp_right_isotone conv_dist_sup inf.sup_left_isotone by auto
   finally show "t \<le> ((v \<squnion> e\<^sup>T * top) * (v \<squnion> e\<^sup>T * top)\<^sup>T) \<sqinter> g"
     .
 next
   have "e \<le> v * top"
     by (meson assms(1) inf.boundedE mult_right_isotone order.trans top.extremum)
   hence "e \<le> v * top \<sqinter> top * e"
     by (simp add: top_left_mult_increasing)
   also have "... = v * top * e"
     by (metis inf_top_right vector_export_comp)
   finally have "e \<le> v * top * e \<sqinter> g"
     using assms(1) by auto
   also have "... = v * (e\<^sup>T * top)\<^sup>T \<sqinter> g"
     by (simp add: comp_associative conv_dist_comp)
   also have "... \<le> v * (v \<squnion> e\<^sup>T * top)\<^sup>T \<sqinter> g"
     by (simp add: conv_dist_sup mult_left_dist_sup sup.assoc sup.orderI)
   also have "... \<le> (v \<squnion> e\<^sup>T * top) * (v \<squnion> e\<^sup>T * top)\<^sup>T \<sqinter> g"
     using inf.sup_left_isotone mult_right_sub_dist_sup_left by auto
   finally show "e \<le> ((v \<squnion> e\<^sup>T * top) * (v \<squnion> e\<^sup>T * top)\<^sup>T) \<sqinter> g"
     .
 qed
 
 text \<open>
 The following result shows how to apply the Schr\"oder equivalence to the middle factor in a composition of three relations.
 Again the elements on the right-hand side need to be pseudocomplemented.
 \<close>
 
 lemma triple_schroeder_p:
   "x * y * z \<le> -w \<longleftrightarrow> x\<^sup>T * w * z\<^sup>T \<le> -y"
   using mult_assoc p_antitone_iff schroeder_3_p schroeder_4_p by auto
 
 text \<open>
 The rotation versions of the Schr\"oder equivalences continue to hold, again with pseudocomplemented elements on the right-hand side.
 \<close>
 
 lemma schroeder_5_p:
   "x * y \<le> -z \<longleftrightarrow> y * z\<^sup>T \<le> -x\<^sup>T"
   using schroeder_3_p schroeder_4_p by auto
 
 lemma schroeder_6_p:
   "x * y \<le> -z \<longleftrightarrow> z\<^sup>T * x \<le> -y\<^sup>T"
   using schroeder_3_p schroeder_4_p by auto
 
 lemma vector_conv_compl:
   "vector v \<Longrightarrow> top * -v\<^sup>T = -v\<^sup>T"
   by (simp add: covector_complement_closed vector_conv_covector)
 
 text \<open>
 Composition commutes, relative to the diversity relation.
 \<close>
 
 lemma comp_commute_below_diversity:
   "x * y \<le> -1 \<longleftrightarrow> y * x \<le> -1"
   by (metis comp_right_one conv_dist_comp conv_one schroeder_3_p schroeder_4_p)
 
 lemma comp_injective_below_complement:
   "injective y \<Longrightarrow> -x * y \<le> -(x * y)"
   by (metis p_antitone_iff comp_associative comp_right_isotone comp_right_one schroeder_4_p)
 
 lemma comp_univalent_below_complement:
   "univalent x \<Longrightarrow> x * -y \<le> -(x * y)"
   by (metis p_inf pseudo_complement semiring.mult_zero_right univalent_comp_left_dist_inf)
 
 text \<open>
 Bijective relations and mappings can be exported from a pseudocomplement.
 \<close>
 
 lemma comp_bijective_complement:
   "bijective y \<Longrightarrow> -x * y = -(x * y)"
   using comp_injective_below_complement complement_conv_sub order.antisym shunt_bijective by blast
 
 lemma comp_mapping_complement:
   "mapping x \<Longrightarrow> x * -y = -(x * y)"
   by (metis (full_types) comp_bijective_complement conv_complement conv_dist_comp conv_involutive total_conv_surjective)
 
 text \<open>
 The following facts are used in the correctness proof of Kruskal's minimum spanning tree algorithm.
 \<close>
 
 lemma kruskal_injective_inv:
   assumes "injective f"
       and "covector q"
       and "q * f\<^sup>T \<le> q"
       and "e \<le> q"
       and "q * f\<^sup>T \<le> -e"
       and "injective e"
       and "q\<^sup>T * q \<sqinter> f\<^sup>T * f \<le> 1"
     shows "injective ((f \<sqinter> -q) \<squnion> (f \<sqinter> q)\<^sup>T \<squnion> e)"
 proof -
   have 1: "(f \<sqinter> -q) * (f \<sqinter> -q)\<^sup>T \<le> 1"
     by (simp add: assms(1) injective_inf_closed)
   have 2: "(f \<sqinter> -q) * (f \<sqinter> q) \<le> 1"
   proof -
     have 21: "bot = q * f\<^sup>T \<sqinter> - q"
       by (metis assms(3) inf.sup_monoid.add_assoc inf.sup_right_divisibility inf_import_p inf_p)
     have "(f \<sqinter> -q) * (f \<sqinter> q) \<le> -q * f \<sqinter> q"
       by (metis assms(2) comp_inf_covector comp_isotone inf.cobounded2 inf.left_idem)
     also have "... = bot"
       using 21 schroeder_2 by auto
     finally show ?thesis
       by (simp add: bot_unique)
   qed
   have 3: "(f \<sqinter> -q) * e\<^sup>T \<le> 1"
   proof -
     have "(f \<sqinter> -q) * e\<^sup>T \<le> -q * e\<^sup>T"
       by (simp add: mult_left_isotone)
     also have "... = bot"
       by (metis assms(2,4) bot_unique conv_bot conv_complement covector_complement_closed p_antitone p_bot regular_closed_bot schroeder_5_p)
     finally show ?thesis
       by (simp add: bot_unique)
   qed
   have 4: "(f \<sqinter> q)\<^sup>T * (f \<sqinter> -q)\<^sup>T \<le> 1"
     using 2 conv_dist_comp conv_isotone by force
   have 5: "(f \<sqinter> q)\<^sup>T * (f \<sqinter> q) \<le> 1"
   proof -
     have "(f \<sqinter> q)\<^sup>T * (f \<sqinter> q) \<le> q\<^sup>T * q \<sqinter> f\<^sup>T * f"
       by (simp add: conv_isotone mult_isotone)
     also have "... \<le> 1"
       by (simp add: assms(7))
     finally show ?thesis
       by simp
   qed
   have 6: "(f \<sqinter> q)\<^sup>T * e\<^sup>T \<le> 1"
   proof -
     have "f\<^sup>T * e\<^sup>T \<le> -q\<^sup>T"
       using assms(5) schroeder_5_p by simp
     hence "(f \<sqinter> q)\<^sup>T * e\<^sup>T = bot"
       by (metis assms(2,5) conv_bot conv_dist_comp covector_comp_inf inf.absorb1 inf.cobounded2 inf.sup_monoid.add_commute inf_left_commute inf_p schroeder_4_p)
     thus ?thesis
       by (simp add: bot_unique)
   qed
   have 7: "e * (f \<sqinter> -q)\<^sup>T \<le> 1"
     using 3 conv_dist_comp coreflexive_symmetric by fastforce
   have 8: "e * (f \<sqinter> q) \<le> 1"
     using 6 conv_dist_comp coreflexive_symmetric by fastforce
   have 9: "e * e\<^sup>T \<le> 1"
     by (simp add: assms(6))
   have "((f \<sqinter> -q) \<squnion> (f \<sqinter> q)\<^sup>T \<squnion> e) * ((f \<sqinter> -q) \<squnion> (f \<sqinter> q)\<^sup>T \<squnion> e)\<^sup>T = (f \<sqinter> -q) * (f \<sqinter> -q)\<^sup>T \<squnion> (f \<sqinter> -q) * (f \<sqinter> q) \<squnion> (f \<sqinter> -q) * e\<^sup>T \<squnion> (f \<sqinter> q)\<^sup>T * (f \<sqinter> -q)\<^sup>T \<squnion> (f \<sqinter> q)\<^sup>T * (f \<sqinter> q) \<squnion> (f \<sqinter> q)\<^sup>T * e\<^sup>T \<squnion> e * (f \<sqinter> -q)\<^sup>T \<squnion> e * (f \<sqinter> q) \<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
     by simp
 qed
 
 lemma kruskal_exchange_injective_inv_1:
   assumes "injective f"
       and "covector q"
       and "q * f\<^sup>T \<le> q"
       and "q\<^sup>T * q \<sqinter> f\<^sup>T * f \<le> 1"
     shows "injective ((f \<sqinter> -q) \<squnion> (f \<sqinter> q)\<^sup>T)"
   using kruskal_injective_inv[where e=bot] by (simp add: assms)
 
 lemma kruskal_exchange_acyclic_inv_3:
   assumes "injective w"
       and "d \<le> w"
     shows "(w \<sqinter> -d) * d\<^sup>T * top = bot"
 proof -
   have "(w \<sqinter> -d) * d\<^sup>T * top = (w \<sqinter> -d \<sqinter> (d\<^sup>T * top)\<^sup>T) * top"
     by (simp add: comp_associative comp_inf_vector_1 conv_dist_comp)
   also have "... = (w \<sqinter> top * d \<sqinter> -d) * top"
     by (simp add: conv_dist_comp inf_commute inf_left_commute)
   finally show ?thesis
     using assms epm_3 by simp
 qed
 
 lemma kruskal_subgraph_inv:
   assumes "f \<le> --(-h \<sqinter> g)"
       and "e \<le> --g"
       and "symmetric h"
       and "symmetric g"
     shows "(f \<sqinter> -q) \<squnion> (f \<sqinter> q)\<^sup>T \<squnion> e \<le> --(-(h \<sqinter> -e \<sqinter> -e\<^sup>T) \<sqinter> g)"
 proof -
   let ?f = "(f \<sqinter> -q) \<squnion> (f \<sqinter> q)\<^sup>T \<squnion> e"
   let ?h = "h \<sqinter> -e \<sqinter> -e\<^sup>T"
   have 1: "f \<sqinter> -q \<le> -h \<sqinter> --g"
     using assms(1) inf.coboundedI1 by simp
   have "(f \<sqinter> q)\<^sup>T \<le> (-h \<sqinter> --g)\<^sup>T"
     using assms(1) inf.coboundedI1 conv_isotone by simp
   also have "... = -h \<sqinter> --g"
     using assms(3,4) conv_complement conv_dist_inf by simp
   finally have "?f \<le> (-h \<sqinter> --g) \<squnion> (e \<sqinter> --g)"
     using 1 assms(2) inf.absorb1 semiring.add_right_mono by simp
   also have "... \<le> (-h \<squnion> --e) \<sqinter> --g"
     by (simp add: inf.coboundedI1 le_supI2 pp_increasing)
   also have "... \<le> -?h \<sqinter> --g"
     using inf.sup_left_isotone order_trans p_antitone_inf p_supdist_inf by blast
   finally show "?f \<le> --(-?h \<sqinter> g)"
     using inf_pp_semi_commute order_lesseq_imp by blast
 qed
 
+lemma antisymmetric_inf_diversity:
+  "antisymmetric x \<Longrightarrow> x \<sqinter> -1 = x \<sqinter> -x\<^sup>T"
+  by (smt (verit, del_insts) inf.orderE inf.sup_monoid.add_assoc inf.sup_monoid.add_commute inf_import_p one_inf_conv)
+
 end
 
 subsection \<open>Stone Relation Algebras\<close>
 
 text \<open>
 We add \<open>pp_dist_comp\<close> and \<open>pp_one\<close>, which follow in relation algebras but not in the present setting.
 The main change is that only a Stone algebra is required, not a Boolean algebra.
 \<close>
 
 class stone_relation_algebra = pd_allegory + stone_algebra +
   assumes pp_dist_comp : "--(x * y) = --x * --y"
   assumes pp_one [simp]: "--1 = 1"
 begin
 
 text \<open>
 The following property is a simple consequence of the Stone axiom.
 We cannot hope to remove the double complement in it.
 \<close>
 
 lemma conv_complement_0_p [simp]:
   "(-x)\<^sup>T \<squnion> (--x)\<^sup>T = top"
   by (metis conv_top conv_dist_sup stone)
 
 lemma theorem24xxiv_pp:
   "-(x * y) \<squnion> --(x * z) = -(x * (y \<sqinter> -z)) \<squnion> --(x * z)"
   by (metis p_dist_inf theorem24xxiii)
 
 lemma asymmetric_linear:
   "asymmetric x \<longleftrightarrow> linear (-x)"
   by (metis conv_complement inf.distrib_left inf_p maddux_3_11_pp p_bot p_dist_inf)
 
 lemma strict_linear_asymmetric:
   "strict_linear x \<Longrightarrow> antisymmetric (-x)"
   by (metis conv_complement eq_refl p_dist_sup pp_one)
 
 lemma regular_complement_top:
   "regular x \<Longrightarrow> x \<squnion> -x = top"
   by (metis stone)
 
 lemma regular_mult_closed:
   "regular x \<Longrightarrow> regular y \<Longrightarrow> regular (x * y)"
   by (simp add: pp_dist_comp)
 
 lemma regular_one_closed:
   "regular 1"
   by simp
 
 text \<open>
 The following variants of total and surjective are useful for graphs.
 \<close>
 
 lemma pp_total:
   "total (--x) \<longleftrightarrow> -(x*top) = bot"
   by (simp add: dense_pp pp_dist_comp)
 
 lemma pp_surjective:
   "surjective (--x) \<longleftrightarrow> -(top*x) = bot"
   by (metis p_bot p_comp_pp p_top pp_dist_comp)
 
 text \<open>
 Bijective elements and mappings are necessarily regular, that is, invariant under double-complement.
 This implies that points are regular.
 Moreover, also arcs are regular.
 \<close>
 
 lemma bijective_regular:
   "bijective x \<Longrightarrow> regular x"
   by (metis comp_bijective_complement mult_left_one regular_one_closed)
 
 lemma mapping_regular:
   "mapping x \<Longrightarrow> regular x"
   by (metis bijective_regular conv_complement conv_involutive total_conv_surjective)
 
 lemma arc_regular:
   assumes "arc x"
     shows "regular x"
 proof -
   have "--x \<le> --(x * top \<sqinter> top * x)"
     by (simp add: pp_isotone top_left_mult_increasing top_right_mult_increasing)
   also have "... = --(x * top) \<sqinter> --(top * x)"
     by simp
   also have "... = x * top \<sqinter> top * x"
     by (metis assms bijective_regular conv_top conv_dist_comp conv_involutive mapping_regular)
   also have "... \<le> x * x\<^sup>T * top * x"
     by (metis comp_associative dedekind_1 inf.commute inf_top.right_neutral)
   also have "... \<le> x"
     by (metis assms comp_right_one conv_top comp_associative conv_dist_comp conv_involutive mult_right_isotone vector_top_closed)
   finally show ?thesis
     by (simp add: order.antisym pp_increasing)
 qed
 
 (*
 lemma conv_complement_0 [simp]: "x\<^sup>T \<squnion> (-x)\<^sup>T = top" nitpick [expect=genuine] oops
 lemma schroeder_3: "x * y \<le> z \<longleftrightarrow> x\<^sup>T * -z \<le> -y" nitpick [expect=genuine] oops
 lemma schroeder_4: "x * y \<le> z \<longleftrightarrow> -z * y\<^sup>T \<le> -x" nitpick [expect=genuine] oops
 lemma theorem24xxiv: "-(x * y) \<squnion> (x * z) = -(x * (y \<sqinter> -z)) \<squnion> (x * z)" nitpick [expect=genuine] oops
 lemma vector_N: "x = x * top \<longrightarrow> N(x) = x \<sqinter> 1" nitpick [expect=genuine] oops
 lemma N_vector [simp]: "N(x * top) = x * top \<sqinter> 1" nitpick [expect=genuine] oops
 lemma N_vector_top [simp]: "N(x * top) * top = x * top" nitpick [expect=genuine] oops
 lemma N_below_inf_one: "N(x) \<le> x \<sqinter> 1" nitpick [expect=genuine] oops
 lemma N_below: "N(x) \<le> x" nitpick [expect=genuine] oops
 lemma n_split_omega_mult: "xs * xo = xo \<and> xo * top = xo \<longrightarrow> N(top) * xo = xs * N(xo) * top" nitpick [expect=genuine] oops
 lemma complement_vector: "vector v \<longleftrightarrow> vector (-v)" nitpick [expect=genuine] oops
 lemma complement_covector: "covector v \<longleftrightarrow> covector (-v)" nitpick [expect=genuine] oops
 lemma triple_schroeder: "x * y * z \<le> w \<longleftrightarrow> x\<^sup>T * -w * z\<^sup>T \<le> -y" nitpick [expect=genuine] oops
 lemma schroeder_5: "x * y \<le> z \<longleftrightarrow> y * -z\<^sup>T \<le> -x\<^sup>T" nitpick [expect=genuine] oops
 lemma schroeder_6: "x * y \<le> z \<longleftrightarrow> -z\<^sup>T * x \<le> -y\<^sup>T" nitpick [expect=genuine] oops
 *)
 
 end
 
 text \<open>
 Every Stone algebra can be expanded to a Stone relation algebra by identifying the semiring and lattice structures and taking identity as converse.
 \<close>
 
 sublocale stone_algebra < comp_inf: stone_relation_algebra where one = top and times = inf and conv = id
 proof (unfold_locales, goal_cases)
   case 7
   show ?case by (simp add: inf_commute)
 qed (auto simp: inf.assoc inf_sup_distrib2 inf_left_commute)
 
 text \<open>
 Every bounded linear order can be expanded to a Stone algebra, which can be expanded to a Stone relation algebra by reusing some of the operations.
 In particular, composition is meet, its identity is \<open>top\<close> and converse is the identity function.
 \<close>
 
 class linorder_stone_relation_algebra_expansion = linorder_stone_algebra_expansion + times + conv + one +
   assumes times_def [simp]: "x * y = min x y"
   assumes conv_def [simp]: "x\<^sup>T = x"
   assumes one_def [simp]: "1 = top"
 begin
 
 lemma times_inf [simp]:
   "x * y = x \<sqinter> y"
   by simp
 
 subclass stone_relation_algebra
   apply unfold_locales
   using comp_inf.mult_right_dist_sup inf_commute inf_assoc inf_left_commute pp_dist_inf min_def by simp_all
 
 lemma times_dense:
   "x \<noteq> bot \<Longrightarrow> y \<noteq> bot \<Longrightarrow> x * y \<noteq> bot"
   using inf_dense min_inf times_def by presburger
 
 end
 
 subsection \<open>Relation Algebras\<close>
 
 text \<open>
 For a relation algebra, we only require that the underlying lattice is a Boolean algebra.
 In fact, the only missing axiom is that double-complement is the identity.
 \<close>
 
 class relation_algebra = boolean_algebra + stone_relation_algebra
 begin
 
 lemma conv_complement_0 [simp]:
   "x\<^sup>T \<squnion> (-x)\<^sup>T = top"
   by (simp add: conv_complement)
 
 text \<open>
 We now obtain the original formulations of the Schr\"oder equivalences.
 \<close>
 
 lemma schroeder_3:
   "x * y \<le> z \<longleftrightarrow> x\<^sup>T * -z \<le> -y"
   by (simp add: schroeder_3_p)
 
 lemma schroeder_4:
   "x * y \<le> z \<longleftrightarrow> -z * y\<^sup>T \<le> -x"
   by (simp add: schroeder_4_p)
 
 lemma theorem24xxiv:
   "-(x * y) \<squnion> (x * z) = -(x * (y \<sqinter> -z)) \<squnion> (x * z)"
   using theorem24xxiv_pp by auto
 
 lemma vector_N:
   "vector x \<Longrightarrow> N(x) = x \<sqinter> 1"
   by (simp add: vector_N_pp)
 
 lemma N_vector [simp]:
   "N(x * top) = x * top \<sqinter> 1"
   by simp
 
 lemma N_vector_top [simp]:
   "N(x * top) * top = x * top"
   using N_vector_top_pp by simp
 
 lemma N_below_inf_one:
   "N(x) \<le> x \<sqinter> 1"
   using N_below_inf_one_pp by simp
 
 lemma N_below:
   "N(x) \<le> x"
   using N_below_pp by simp
 
 lemma n_split_omega_mult:
   "xs * xo = xo \<Longrightarrow> xo * top = xo \<Longrightarrow> N(top) * xo = xs * N(xo) * top"
   using n_split_omega_mult_pp by simp
 
 lemma complement_vector:
   "vector v \<longleftrightarrow> vector (-v)"
   using vector_complement_closed by fastforce
 
 lemma complement_covector:
   "covector v \<longleftrightarrow> covector (-v)"
   using covector_complement_closed by force
 
 lemma triple_schroeder:
   "x * y * z \<le> w \<longleftrightarrow> x\<^sup>T * -w * z\<^sup>T \<le> -y"
   by (simp add: triple_schroeder_p)
 
 lemma schroeder_5:
   "x * y \<le> z \<longleftrightarrow> y * -z\<^sup>T \<le> -x\<^sup>T"
   by (simp add: conv_complement schroeder_5_p)
 
 lemma schroeder_6:
   "x * y \<le> z \<longleftrightarrow> -z\<^sup>T * x \<le> -y\<^sup>T"
   by (simp add: conv_complement schroeder_5_p)
 
 end
 
 text \<open>
 We briefly look at the so-called Tarski rule.
 In some models of Stone relation algebras it only holds for regular elements, so we add this as an assumption.
 \<close>
 
 class stone_relation_algebra_tarski = stone_relation_algebra +
   assumes tarski: "regular x \<Longrightarrow> x \<noteq> bot \<Longrightarrow> top * x * top = top"
 begin
 
 text \<open>
 We can then show, for example, that every arc is contained in a pseudocomplemented relation or its pseudocomplement.
 \<close>
 
 lemma arc_in_partition:
   assumes "arc x"
     shows "x \<le> -y \<or> x \<le> --y"
 proof -
   have 1: "x * top * x\<^sup>T \<le> 1 \<and> x\<^sup>T * top * x \<le> 1"
     using assms arc_expanded by auto
   have "\<not> x \<le> --y \<longrightarrow> x \<le> -y"
   proof
     assume "\<not> x \<le> --y"
     hence "x \<sqinter> -y \<noteq> bot"
       using pseudo_complement by simp
     hence "top * (x \<sqinter> -y) * top = top"
       using assms arc_regular tarski by auto
     hence "x = x \<sqinter> top * (x \<sqinter> -y) * top"
       by simp
     also have "... \<le> x \<sqinter> x * ((x \<sqinter> -y) * top)\<^sup>T * (x \<sqinter> -y) * top"
       by (metis dedekind_2 inf.cobounded1 inf.boundedI inf_commute mult_assoc inf.absorb2 top.extremum)
     also have "... = x \<sqinter> x * top * (x\<^sup>T \<sqinter> -y\<^sup>T) * (x \<sqinter> -y) * top"
       by (simp add: comp_associative conv_complement conv_dist_comp conv_dist_inf)
     also have "... \<le> x \<sqinter> x * top * x\<^sup>T * (x \<sqinter> -y) * top"
       using inf.sup_right_isotone mult_left_isotone mult_right_isotone by auto
     also have "... \<le> x \<sqinter> 1 * (x \<sqinter> -y) * top"
       using 1 by (metis comp_associative comp_isotone inf.sup_right_isotone mult_1_left mult_semi_associative)
     also have "... = x \<sqinter> (x \<sqinter> -y) * top"
       by simp
     also have "... \<le> (x \<sqinter> -y) * ((x \<sqinter> -y)\<^sup>T * x)"
       by (metis dedekind_1 inf_commute inf_top_right)
     also have "... \<le> (x \<sqinter> -y) * (x\<^sup>T * x)"
       by (simp add: conv_dist_inf mult_left_isotone mult_right_isotone)
     also have "... \<le> (x \<sqinter> -y) * (x\<^sup>T * top * x)"
       by (simp add: mult_assoc mult_right_isotone top_left_mult_increasing)
     also have "... \<le> x \<sqinter> -y"
       using 1 by (metis mult_right_isotone mult_1_right)
     finally show "x \<le> -y"
       by simp
   qed
   thus ?thesis
     by auto
 qed
 
 lemma non_bot_arc_in_partition_xor:
   assumes "arc x"
       and "x \<noteq> bot"
     shows "(x \<le> -y \<and> \<not> x \<le> --y) \<or> (\<not> x \<le> -y \<and> x \<le> --y)"
 proof -
   have "x \<le> -y \<and> x \<le> --y \<longrightarrow> False"
     by (simp add: assms(2) inf_absorb1 shunting_1_pp)
   thus ?thesis
     using assms(1) arc_in_partition by auto
 qed
 
 lemma point_in_vector_or_pseudo_complement:
   assumes "point p"
       and "vector v"
     shows "p \<le> --v \<or> p \<le> -v"
 proof (rule disjCI)
   assume "\<not>(p \<le> -v)"
   hence "top * (p \<sqinter> --v) = top"
     by (smt assms bijective_regular regular_closed_inf regular_closed_p shunting_1_pp tarski vector_complement_closed vector_inf_closed vector_mult_closed)
   thus "p \<le> --v"
     by (metis assms(1) epm_3 inf.absorb_iff1 inf.cobounded1 inf_top.right_neutral)
 qed
 
 lemma distinct_points:
   assumes "point x"
     and "point y"
     and "x \<noteq> y"
   shows "x \<sqinter> y = bot"
   by (metis assms order.antisym comp_bijective_complement inf.sup_monoid.add_commute mult_left_one pseudo_complement regular_one_closed point_in_vector_or_pseudo_complement)
 
 lemma point_in_vector_or_complement:
   assumes "point p"
       and "vector v"
       and "regular v"
     shows "p \<le> v \<or> p \<le> -v"
   using assms point_in_vector_or_pseudo_complement by fastforce
 
 lemma point_in_vector_sup:
   assumes "point p"
       and "vector v"
       and "regular v"
       and "p \<le> v \<squnion> w"
     shows "p \<le> v \<or> p \<le> w"
   by (metis assms inf.absorb1 shunting_var_p sup_commute point_in_vector_or_complement)
 
 lemma point_atomic_vector:
   assumes "point x"
     and "vector y"
     and "regular y"
     and "y \<le> x"
   shows "y = x \<or> y = bot"
 proof (cases "x \<le> -y")
   case True
   thus ?thesis
     using assms(4) inf.absorb2 pseudo_complement by force
 next
   case False
   thus ?thesis
     using assms point_in_vector_or_pseudo_complement by fastforce
 qed
 
 lemma point_in_vector_or_complement_2:
   assumes "point x"
     and "vector y"
     and "regular y"
     and "\<not> y \<le> -x"
   shows "x \<le> y"
   using assms point_in_vector_or_pseudo_complement p_antitone_iff by fastforce
 
 text \<open>The next three lemmas \<open>arc_in_arc_or_complement\<close>, \<open>arc_in_sup_arc\<close> and \<open>different_arc_in_sup_arc\<close> were contributed by Nicolas Robinson-O'Brien.\<close>
 
 lemma arc_in_arc_or_complement:
   assumes "arc x"
       and "arc y"
       and "\<not> x \<le> y"
     shows "x \<le> -y"
   using assms arc_in_partition arc_regular by force
 
 lemma arc_in_sup_arc:
   assumes "arc x"
       and "arc y"
       and "x \<le> z \<squnion> y"
     shows "x \<le> z \<or> x \<le> y"
 proof (cases "x \<le> y")
   case True
   thus ?thesis
     by simp
 next
   case False
   hence "x \<le> -y"
     using assms(1,2) arc_in_arc_or_complement by blast
   hence "x \<le> -y \<sqinter> (z \<squnion> y)"
     using assms(3) by simp
   hence "x \<le> z"
     by (metis inf.boundedE inf.sup_monoid.add_commute maddux_3_13 sup_commute)
   thus ?thesis
     by simp
 qed
 
 lemma different_arc_in_sup_arc:
   assumes "arc x"
       and "arc y"
       and "x \<le> z \<squnion> y"
       and "x \<noteq> y"
     shows "x \<le> z"
 proof -
   have "x \<le> -y"
     using arc_in_arc_or_complement assms(1,2,4) order.eq_iff p_antitone_iff by blast
   hence "x \<le> -y \<sqinter> (z \<squnion> y)"
     using assms arc_in_sup_arc by simp
   thus ?thesis
     by (metis order_lesseq_imp p_inf_sup_below sup_commute)
 qed
 
 end
 
 class relation_algebra_tarski = relation_algebra + stone_relation_algebra_tarski
 
 text \<open>
 Finally, the above axioms of relation algebras do not imply that they contain at least two elements.
 This is necessary, for example, to show that arcs are not empty.
 \<close>
 
 class stone_relation_algebra_consistent = stone_relation_algebra +
   assumes consistent: "bot \<noteq> top"
 begin
 
 lemma arc_not_bot:
   "arc x \<Longrightarrow> x \<noteq> bot"
   using consistent mult_right_zero by auto
 
+lemma point_not_bot:
+  "point p \<Longrightarrow> p \<noteq> bot"
+  using consistent by force
+
 end
 
 class relation_algebra_consistent = relation_algebra + stone_relation_algebra_consistent
 
 class stone_relation_algebra_tarski_consistent = stone_relation_algebra_tarski + stone_relation_algebra_consistent
 begin
 
 lemma arc_in_partition_xor:
   "arc x \<Longrightarrow> (x \<le> -y \<and> \<not> x \<le> --y) \<or> (\<not> x \<le> -y \<and> x \<le> --y)"
   by (simp add: non_bot_arc_in_partition_xor arc_not_bot)
 
 end
 
+class relation_algebra_tarski_consistent = relation_algebra + stone_relation_algebra_tarski_consistent
+
 end