(* 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 eq_iff top_greatest)

lemma conv_dist_inf:
  "(x \<sqinter> y)\<^sup>T = x\<^sup>T \<sqinter> y\<^sup>T"
  apply (rule 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 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 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 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 inf.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 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_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 antisym comp_right_subdist_inf dedekind_1 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_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 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 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 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

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 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 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 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

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: 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

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 inf.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 inf.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 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 eq_iff top_right_mult_increasing)

lemma covector_complement_closed:
  "covector x \<Longrightarrow> covector (-x)"
  by (metis conv_complement_sub_leq conv_top 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 inf.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 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 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)

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: inf.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 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 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

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: 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 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 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) 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

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

end


theory Fibnoacci_Trymatch
  imports "../DP_Lifting" "../DP_CRelVS" "../DP_Proof"
begin

  (*
fun fib :: "nat \<Rightarrow> int option" where
  "fib 0 = Some 0"
| "fib (Suc 0) = Some 1"
| "fib (Suc (Suc n)) = (case (fib (Suc n), fib n) of (Some f1, Some f0) \<Rightarrow> Some (f1 + f0) | _ \<Rightarrow> None)"
term 0 (**)
*)

fun fib :: "nat \<Rightarrow> int option" where
  "fib 0 = Some 0"
| "fib (Suc 0) = Some 1"
| "fib (Suc (Suc n)) = case_prod
      (\<lambda>of1 of0. case_option
        None
        (\<lambda>f1. case_option
          None
          (\<lambda>f0. Some (f1 + f0))
          of0)
        of1)
      (Pair (fib (Suc n)) (fib n))"
thm fib.simps
term 0 (**)

fun fib\<^sub>T :: "nat \<Rightarrow>\<^sub>T int option" where
  "fib\<^sub>T$ 0 =CHECKMEM= \<langle>Some 0\<rangle>"
| "fib\<^sub>T$ (Suc 0) =CHECKMEM= \<langle>Some 1\<rangle>"
| "fib\<^sub>T$ (Suc (Suc n)) =CHECKMEM= case_prod\<^sub>T
    . (\<lambda>\<^sub>T of1 of0. case_option\<^sub>T
        . \<langle>None\<rangle>
        . (\<lambda>\<^sub>T f1. case_option\<^sub>T
          . \<langle>None\<rangle>
          . (\<lambda>\<^sub>T f0. \<langle>Some (f1 + f0)\<rangle>)
          . \<langle>of0\<rangle>)
        . \<langle>of1\<rangle>)
    . (Pair\<^sub>T . (fib\<^sub>T (Suc n)) . (fib\<^sub>T n))"
term 0 (**)

interpretation fib: dp_consistency fib .

lemma "fib.consistentDP fib\<^sub>T"
    apply ( rule dp_consistency.consistentDP_intro,
    rule fib.induct,
    unfold fib\<^sub>T.simps;
    rule dp_consistency.crel_vs_checkmem,
    unfold fib.simps)
    apply dp_step apply dp_naive
    apply dp_step apply dp_naive

end


theory Failures_Core

imports
 Main
 HOL.List
 "HOL-Library.Sublist"
begin

section \<open> Type Definitions\<close>

datatype 'a evt = tick | evt 'a

type_synonym 'a trace = "'a evt list"
type_synonym 'a failure = "('a trace * 'a evt set)"
type_synonym 'a state = "('a failure) option"
type_synonym 'a prel = "('a state * 'a state) set"

text \<open> In Failures a CSP process is denoted by a pair of
        failures (set of failures) and traces (set of traces).\<close>

type_synonym 'a process = "('a failure) set \<times> ('a trace) set"

section \<open> Healthiness Conditions \<close>

definition traces :: "'a process \<Rightarrow> ('a trace) set" ("traces'(_')")
  where "traces P = snd P"

text \<open> T0: tick can only be the last event of a trace \<close>

fun Tick_last :: "'a trace \<Rightarrow> bool" where
"Tick_last [] = True" |
"Tick_last [tick] = True" |
"Tick_last (x#xs) = ((x \<noteq> tick) \<and> Tick_last xs)"

definition T0 :: "'a process \<Rightarrow> bool"
  where "T0 P \<equiv> \<forall>s. s \<in> traces(P) \<longrightarrow> Tick_last s"

lemma Tick_last_last:
  assumes "Tick_last (s@[tick])" "s \<noteq> []"
  shows "last s \<noteq> tick"
  using assms by (induct s rule:Tick_last.induct, auto)

text \<open> T1: traces is non-empty and prefix-closed \<close>

definition T1 :: "'a process \<Rightarrow> bool"
  where "T1 P \<equiv> traces(P) \<noteq> {} \<and> (\<forall>t s. t \<in> traces(P) \<and> prefix s t \<longrightarrow> s \<in> traces(P))"

text \<open> T2: Every trace associated with a failure is a trace. \<close>

definition T2 :: "'a process \<Rightarrow> bool"
  where "T2 P \<equiv> \<forall>s X. (s, X) \<in> (fst P) \<longrightarrow> s \<in> traces(P)"

text \<open> F2: Failures are subset-closed. \<close>

definition F2 :: "'a process \<Rightarrow> bool"
 where "F2 P \<equiv> \<forall>s X Y. (s, X) \<in> (fst P) \<and> Y \<subseteq> X \<longrightarrow> (s, Y) \<in> (fst P)"

text \<open> F3: When a process refuses $x$ it also refuses all events that
            it can never perform after the same trace. \<close>

definition F3 :: "'a process \<Rightarrow> bool"
  where "F3 P \<equiv> \<forall>s X Y. ((s, X) \<in> (fst P) \<and> (Y \<inter> {x. (s@[x]) \<in> traces(P)} = {})) \<longrightarrow> (s, X \<union> Y) \<in> (fst P)"

text \<open> F4: When a process can terminate it can refuse to do anything else,
           and it is assumed to refuse everything after tick. \<close>

definition F4 :: "'a process \<Rightarrow> bool"
  where "F4 P \<equiv> \<forall>s. (s@[tick]) \<in> traces(P) \<longrightarrow> {(s,UNIV-{tick}),(s@[tick],UNIV)} \<subseteq> fst P"

text \<open> F5: A stable process must also refuse to terminate. \<close>

definition F5 :: "'a process \<Rightarrow> bool"
  where "F5 P \<equiv> \<forall>s X. (s,X) \<in> fst P \<longrightarrow> (s,X\<union>{tick}) \<in> fst P"

definition mkFailuresF5 :: "('a failure) set \<Rightarrow> ('a failure) set"
  where "mkFailuresF5 F = (F \<union> {(t,X). \<exists>Y. (t,Y) \<in> F \<and> X \<subseteq> Y\<union>{tick}})"

definition mkF25 :: "'a process \<Rightarrow> 'a process"
  where "mkF25 P = (fst P \<union> {(t,X). \<exists>Y. (t,Y) \<in> fst P \<and> X \<subseteq> Y\<union>{tick}}, snd P)"

lemma F5_F2_imp_mkF25_fixpoint:
  assumes "F5 P" "F2 P"
  shows "mkF25 P = P"
  using assms unfolding mkF25_def apply auto
  by (smt F2_def F5_def Un_absorb2 case_prod_beta' insert_is_Un mem_Collect_eq prod.collapse subsetI sup_commute)

lemma mkF25_fixpoint_imp_F5:
  assumes "mkF25 P = P"
  shows "F5 P"
  using assms unfolding F5_def apply auto
  by (metis (mono_tags, lifting) Un_insert_right boolean_algebra_cancel.sup0 case_prod_conv fst_conv mem_Collect_eq mkF25_def subset_eq sup.cobounded2)

text \<open> F6: No refusals after tick. \<close>

definition F6 :: "'a process \<Rightarrow> bool"
  where "F6 P == \<forall>s X. (s@[tick],X) \<notin> fst P"

text \<open> Is it possible to define a sub-theory where Skip is unstable? ie. Without F4?
       Not sure which function is easier to define. \<close>

definition mkF4 :: "'a process \<Rightarrow> 'a process"
  where "mkF4 P = (fst P \<union> {(t,X). (\<exists>s. s@[tick] \<in> traces(P) \<and> ((t = s \<and> X = UNIV-{tick}) \<or> (t = s@[tick] \<and> X = UNIV)))},traces(P)) "

definition mkF24 :: "'a process \<Rightarrow> 'a process"
  where "mkF24 P = (fst P \<union> {(t,X). (\<exists>s. s@[tick] \<in> traces(P) \<and> ((t = s \<and> X \<subseteq> UNIV-{tick}) \<or> (t = s@[tick] \<and> X \<subseteq> UNIV)))},traces(P)) "

abbreviation "mkF24_Failure P == {(t,X). (\<exists>s. s@[tick] \<in> traces(P) \<and> ((t = s \<and> X \<subseteq> UNIV-{tick}) \<or> (t = s@[tick] \<and> X \<subseteq> UNIV)))}"

lemma T0_mkFailuresF5[simp]:
  assumes "T0 P"
  shows "T0 (mkFailuresF5 (fst P), snd P)"
  using assms unfolding mkFailuresF5_def T0_def traces_def by auto

lemma T1_mkFailuresF5[simp]:
  assumes "T1 P"
  shows "T1 (mkFailuresF5 (fst P), snd P)"
  using assms unfolding mkFailuresF5_def T1_def traces_def by auto

lemma T2_mkFailuresF5[simp]:
  assumes "T2 P"
  shows "T2 (mkFailuresF5 (fst P), snd P)"
  using assms unfolding mkFailuresF5_def T2_def traces_def by auto

lemma F2_mkFailuresF5[simp]:
  assumes "F2 P"
  shows "F2 (mkFailuresF5 (fst P), snd P)"
  using assms unfolding mkFailuresF5_def F2_def traces_def apply auto
  by (meson subset_trans)

lemma F3_mkFailuresF5[simp]:
  assumes "F3 P"
  shows "F3 (mkFailuresF5 (fst P), snd P)"
  using assms unfolding mkFailuresF5_def F3_def traces_def apply auto
  proof -
  fix s :: "'a evt list" and X :: "'a evt set" and Y :: "'a evt set" and Ya :: "'a evt set"
  assume a1: "\<forall>s X Y. (s, X) \<in> fst P \<and> Y \<inter> {x. s @ [x] \<in> snd P} = {} \<longrightarrow> (s, X \<union> Y) \<in> fst P"
  assume a2: "Y \<inter> {x. s @ [x] \<in> snd P} = {}"
    assume a3: "(s, Ya) \<in> fst P"
    assume a4: "X \<subseteq> insert tick Ya"
  assume a5: "\<forall>Ya. X \<subseteq> insert tick Ya \<longrightarrow> (s, Ya) \<in> fst P \<longrightarrow> \<not> Y \<subseteq> insert tick Ya"
    have "(s, Y \<union> Ya) \<in> fst P"
      using a3 a2 a1 by (metis Un_commute)
  then show "(s, X \<union> Y) \<in> fst P"
    using a5 a4 by (metis (no_types) Un_insert_right Un_subset_iff subset_refl subset_trans)
  qed

lemma F4_mkFailuresF5[simp]:
  assumes "F4 P"
  shows "F4 (mkFailuresF5 (fst P), snd P)"
  using assms unfolding mkFailuresF5_def F4_def traces_def by auto

lemma F5_mkFailuresF5[simp]:
  shows "F5 (mkFailuresF5 (fst P), snd P)"
  unfolding mkFailuresF5_def F5_def traces_def by auto

lemma F4_mkF4: "F4 (mkF4 P)"
  unfolding mkF4_def F4_def traces_def by auto

lemma F4_mkF24: "F4 (mkF24 P)"
  unfolding mkF24_def F4_def traces_def by auto

lemma F2_mkF24:
  assumes "F2 P"
  shows "F2 (mkF24 P)"
  using assms unfolding mkF24_def F2_def traces_def
  apply auto
  by blast

lemma F4_imp_tick_failures:
  assumes "F4 P"
  shows "{(t, X). \<exists>s. s @ [tick] \<in> snd P \<and> (t = s \<and> X = UNIV - {tick} \<or> t = s @ [tick] \<and> X = UNIV)} \<subseteq> fst P"
  using assms
  unfolding F4_def traces_def by auto

lemma mkF4_fixpoint:
  shows "mkF4 P = P \<longleftrightarrow> F4 P"
  apply auto
   apply (metis F4_mkF4)
  unfolding mkF4_def traces_def
  using F4_imp_tick_failures
  by (simp add: F4_imp_tick_failures Un_absorb2)

lemma F4_F2_imp_tick_failures:
  assumes "F4 P" "F2 P"
  shows "{(t, X). \<exists>s. s @ [tick] \<in> snd P \<and> (t = s \<and> X \<subseteq> UNIV - {tick} \<or> t = s @ [tick] \<and> X \<subseteq> UNIV)} \<subseteq> fst P"
  using assms
  unfolding F4_def F2_def traces_def apply auto
  by blast

lemma F5_F2_imp_tick_failures:
  assumes "F5 P" "F2 P"
  shows "{(t, X). \<exists>Y. (t, Y) \<in> fst P \<and> X \<subseteq> insert tick Y} \<subseteq> fst P"
  using assms
  unfolding F5_def F2_def traces_def apply auto
  by blast

lemma mkF24_fixpoint_imp:
  assumes "F4 P" "F2 P"
  shows "mkF24 P = P"
  using assms
  unfolding mkF24_def traces_def
  using F4_F2_imp_tick_failures
  by (metis (mono_tags, lifting) Un_absorb2 mem_Collect_eq prod.collapse prod.simps(2) subset_eq)

lemma T1_mkF24:
  assumes "T1 P"
  shows "T1 (mkF24 P)"
  using assms unfolding T1_def traces_def mkF24_def by auto

lemma T1_prefix:
  assumes "T1 P" "s@[x] \<in> traces(P)"
  shows "s \<in> traces(P)"
  using assms T1_def prefixI by blast

lemma T2_mkF24:
  assumes "T2 P" "T1 P"
  shows "T2 (mkF24 P)"
  using assms(1) unfolding T1_def T2_def traces_def mkF24_def apply auto
  using assms(2) T1_prefix unfolding traces_def by blast

lemma F3_mkF24:
  assumes "F3 P"
  shows "F3 (mkF24 P)"
  using assms unfolding mkF24_def F3_def traces_def by auto

definition refines :: "'a process \<Rightarrow> 'a process \<Rightarrow> bool" (infix "\<sqsubseteq>" 60)
  where "P \<sqsubseteq> Q == fst Q \<subseteq> fst P \<and> snd Q \<subseteq> snd P"

lemma refines_rule:
  assumes "fst Q \<subseteq> fst P" "snd Q \<subseteq> snd P"
  shows "P \<sqsubseteq> Q"
  using assms unfolding refines_def by auto

lemma refines_refl:
  "P \<sqsubseteq> P"
  unfolding refines_def by auto

lemma refines_tran:
  assumes "P \<sqsubseteq> Q" "Q \<sqsubseteq> R"
  shows "P \<sqsubseteq> R"
  using assms unfolding refines_def by auto

lemma refines_asym:
  assumes "P \<sqsubseteq> Q" "Q \<sqsubseteq> P"
  shows "P = Q"
  using assms unfolding refines_def apply auto
  by (simp add: prod_eq_iff)

end


section \<open>Values\<close>
theory Sep_Value
imports
  "../../lib/Monad"
begin

  subsection \<open>Values and Addresses\<close>
  datatype 'a val = PAIR (fst: "'a val") (snd: "'a val") | PRIMITIVE (the: 'a)
  hide_const (open) fst snd the
  define_lenses (open) val

  datatype va_item = PFST | PSND
  type_synonym vaddr = "va_item list"

  subsection \<open>Focusing on Address\<close>
  fun lens_of_item where
    "lens_of_item PFST = val.fst\<^sub>L"
  | "lens_of_item PSND = val.snd\<^sub>L"

  definition "lens_of_vaddr vp = foldr (\<lambda>i L. lens_of_item i \<bullet>\<^sub>L L) vp id\<^sub>L"

  lemma lens_of_vaddr_simps[simp]:
    "lens_of_vaddr [] = id\<^sub>L"
    "lens_of_vaddr (i#is) = lens_of_item i \<bullet>\<^sub>L lens_of_vaddr is"
    unfolding lens_of_vaddr_def
    by auto

  lemma ex_two_vals[simp, intro]: "\<exists>a b::'a val. a \<noteq> b" by auto

  lemma lens_of_item_rnl[simp, intro!]: "rnlens (lens_of_item i :: 'a val \<Longrightarrow> 'a val)"
  proof -
    have A: "is_PAIR (PAIR undefined undefined :: 'a val)" by simp

    show ?thesis
      by (cases i) (auto intro!: rnlensI A)
  qed

  lemma lens_of_item_hlens[simp, intro!]: "hlens (lens_of_item i :: 'a val \<Longrightarrow> 'a val)"
    by (cases i) (auto)

  lemma lens_of_vaddr_rnl[simp, intro!]: "rnlens (lens_of_vaddr vp)"
    by (induction vp) auto

  lemma lens_of_vaddr_hlens[simp, intro!]: "hlens (lens_of_vaddr vp)"
    by (induction vp) auto

  lemma lens_of_item_complete[simp, intro!]: "complete_lens (lens_of_item i)"
    apply (rule)
    apply (simp; fail)
    using val.discI(1)
    by (cases i; fastforce)

  subsection \<open>Loading and Storing Address\<close>
  definition "vload err a \<equiv> zoom (lift_lens err (lens_of_vaddr a)) Monad.get"
  definition "vstore err x a \<equiv> zoom (lift_lens err (lens_of_vaddr a)) (Monad.set x)"

  subsection \<open>GEP\<close>

  definition "checked_gep err addr item \<equiv> doM {
    let addr = addr@[item];
    use (lift_lens err (lens_of_vaddr addr));
    return addr
  }"

  subsection \<open>Structure of Value\<close>
  datatype 's vstruct = VS_PAIR "'s vstruct" "'s vstruct" | VS_PRIMITIVE 's

  locale structured_value_defs =
    fixes struct_of_primval :: "'a \<Rightarrow> 's"
      and init_primval :: "'s \<Rightarrow> 'a"
  begin
    fun struct_of_val :: "'a val \<Rightarrow> 's vstruct" where
      "struct_of_val (PAIR a b) = VS_PAIR (struct_of_val a) (struct_of_val b)"
    | "struct_of_val (PRIMITIVE x) = VS_PRIMITIVE (struct_of_primval x)"

    fun init_val :: "'s vstruct \<Rightarrow> 'a val" where
      "init_val (VS_PAIR sa sb) = PAIR (init_val sa) (init_val sb)"
    | "init_val (VS_PRIMITIVE ps) = PRIMITIVE (init_primval ps)"

  end

  lemmas structured_value_code[code] =
    structured_value_defs.struct_of_val.simps
    structured_value_defs.init_val.simps

  locale structured_value = structured_value_defs struct_of_primval init_primval
    for struct_of_primval :: "'a \<Rightarrow> 's"
      and init_primval :: "'s \<Rightarrow> 'a" +
    assumes struct_of_init_primval[simp]: "struct_of_primval (init_primval s) = s"
  begin

    lemma put_preserves_struct:
      assumes "pre_get (lens_of_vaddr a) s"
      assumes "struct_of_val (get' (lens_of_vaddr a) s) = struct_of_val x"
      shows "struct_of_val (put' (lens_of_vaddr a) x s) = struct_of_val s"
      using assms
    proof (induction a arbitrary: s)
      case Nil
      then show ?case by auto
    next
      case (Cons i as)
      then show ?case by (cases s; cases i; simp)
    qed

    lemma struct_of_init[simp]: "struct_of_val (init_val s) = s"
      by (induction s) (auto simp: )

  end

end


(*  Title:       Conflict analysis/Main Result
    Author:      Peter Lammich <peter.lammich@uni-muenster.de>
    Maintainer:  Peter Lammich <peter.lammich@uni-muenster.de>
*)
header "Main Result"
theory MainResult
imports ConstraintSystems
begin
text_raw {*\label{thy:MainResult}*}

text {* At this point everything is available to prove the main result of this project:
  {\em The constraint system @{term RUV_cs} precisely characterizes simultaneously reachable control nodes w.r.t. to our
  semantic reference point.}

  The ,,trusted base'' of this proof, that are all definitions a reader that trusts the Isabelle prover must additionally trust, is the following:
  \begin{itemize}
    \item The flowgraph and the assumptions made on it in the @{text flowgraph}- and @{text eflowgraph}-locales. Note that we show in Section~\ref{sec:Flowgraph:ex_flowgraph}
      that there is at least one non-trivial model of @{text eflowgraph}.
    \item The reference point semantics (@{term refpoint}) and the transitive closure operator (@{term trcl}).
    \item The definition of @{term atUV}.
    \item All dependencies of the above definitions in the Isabelle standard libraries.
  \end{itemize}
*}
theorem (in eflowgraph) RUV_is_sim_reach:
  "(\<exists>w c'. ({#[entry fg (main fg)]#},w,c')\<in>trcl (refpoint fg) \<and> atUV U V c')
    \<longleftrightarrow> (\<exists>Ml Me. (entry fg (main fg),Ml,Me)\<in>RUV_cs fg U V)"
-- {* The proof uses the soundness and precision theorems wrt. to normalized paths (@{thm [source] flowgraph.RUV_sound}, @{thm [source] flowgraph.RUV_precise}) as well as the normalization result,
  i.e. that every reachable configuration is also reachable using a normalized path (@{thm [source] eflowgraph.normalize}) and, vice versa, that every normalized path is also a usual path (@{thm [source] ntr_is_tr}).
  Finally the conversion between our working semantics and the semantic reference point is exploited (@{thm [source] flowgraph.refpoint_eq}).
*}
proof
  case goal1 then obtain w c' where C: "({#[entry fg (main fg)]#}, w, c') \<in> trcl (tr fg)" "atUV U V c'" by (auto simp add: refpoint_eq)
  from normalize[OF C(1), of "main fg", simplified] obtain ww where "({#[entry fg (main fg)]#}, ww, c') \<in> trcl (ntr fg)" by blast
  from ntrs.gtr2gtrp[where c="{#}", simplified, OF this] obtain s' ce' wwl where 1: "c'={#s'#}+ce'" "ww = map le_rem_s wwl" "(([entry fg (main fg)], {#}), wwl, s', ce') \<in> trcl (ntrp fg)" by blast
  with C(2) have 2: "atUV U V ({#s'#}+ce')" by auto
  from RUV_sound[OF 1(3) 2] show "\<exists>Ml Me. (entry fg (main fg), Ml, Me) \<in> RUV_cs fg U V" by blast
next
  case goal2 then obtain Ml Me where C: "(entry fg (main fg), Ml, Me) \<in> RUV_cs fg U V" by blast
  from RUV_precise[OF C] obtain wwl s' c' where P: "(([entry fg (main fg)], {#}), wwl, s', c') \<in> trcl (ntrp fg)" "atUV U V ({#s'#} + c')" by blast
  from gtrp2gtr[OF P(1)] have "({# [entry fg (main fg)] #}, map le_rem_s wwl, {#s'#}+c') \<in> trcl (ntr fg)" by (auto)
  from ntr_is_tr[OF this] P(2) have "\<exists>w c'. ({#[entry fg (main fg)]#}, w, c') \<in> trcl (tr fg) \<and> atUV U V c'" by blast
  thus "\<exists>w c'. ({#[entry fg (main fg)]#}, w, c') \<in> trcl (refpoint fg) \<and> atUV U V c'" by (simp add: refpoint_eq)
qed

end


theory LastVotingDefs
imports "../HOModel"
begin

section \<open>Verification of the \emph{LastVoting} Consensus Algorithm\<close>

text \<open>
  The \emph{LastVoting} algorithm can be considered as a representation of
  Lamport's Paxos consensus algorithm~\cite{lamport:part-time}
  in the Heard-Of model. It is a coordinated algorithm designed to
  tolerate benign failures. Following~\cite{charron:heardof}, we formalize
  its proof of correctness in Isabelle, using the framework of theory \<open>HOModel\<close>.
\<close>

subsection \<open>Model of the Algorithm\<close>

text \<open>
  We begin by introducing an anonymous type of processes of finite
  cardinality that will instantiate the type variable \<open>'proc\<close>
  of the generic CHO model.
\<close>

typedecl Proc \<comment> \<open>the set of processes\<close>
axiomatization where Proc_finite: "OFCLASS(Proc, finite_class)"
instance Proc :: finite by (rule Proc_finite)

abbreviation
  "N \<equiv> card (UNIV::Proc set)"   \<comment> \<open>number of processes\<close>

text \<open>
  The algorithm proceeds in \emph{phases} of $4$ rounds each (we call
  \emph{steps} the individual rounds that constitute a phase).
  The following utility functions compute the phase and step of a round,
  given the round number.
\<close>

definition phase where "phase (r::nat) \<equiv> r div 4"

definition step where "step (r::nat) \<equiv> r mod 4"

lemma phase_zero [simp]: "phase 0 = 0"
by (simp add: phase_def)

lemma step_zero [simp]: "step 0 = 0"
by (simp add: step_def)

lemma phase_step: "(phase r * 4) + step r = r"
  by (auto simp add: phase_def step_def)

text \<open>
  The following record models the local state of a process.
\<close>

record 'val pstate =
  x :: 'val                \<comment> \<open>current value held by process\<close>
  vote :: "'val option"    \<comment> \<open>value the process voted for, if any\<close>
  commt :: bool            \<comment> \<open>did the process commit to the vote?\<close>
  ready :: bool            \<comment> \<open>for coordinators: did the round finish successfully?\<close>
  timestamp :: nat         \<comment> \<open>time stamp of current value\<close>
  decide :: "'val option"  \<comment> \<open>value the process has decided on, if any\<close>
  coord\<Phi> :: Proc           \<comment> \<open>coordinator for current phase\<close>

text \<open>
  Possible messages sent during the execution of the algorithm.
\<close>

datatype 'val msg =
  ValStamp "'val" "nat"
| Vote "'val"
| Ack
| Null  \<comment> \<open>dummy message in case nothing needs to be sent\<close>

text \<open>
  Characteristic predicates on messages.
\<close>

definition isValStamp where "isValStamp m \<equiv> \<exists>v ts. m = ValStamp v ts"

definition isVote where "isVote m \<equiv> \<exists>v. m = Vote v"

definition isAck where "isAck m \<equiv> m = Ack"

text \<open>
  Selector functions to retrieve components of messages. These functions
  have a meaningful result only when the message is of an appropriate kind.
\<close>

fun val where
  "val (ValStamp v ts) = v"
| "val (Vote v) = v"

fun stamp where
  "stamp (ValStamp v ts) = ts"

text \<open>
  The \<open>x\<close> field of the initial state is unconstrained, all other
  fields are initialized appropriately.
\<close>

definition LV_initState where
  "LV_initState p st crd \<equiv>
     vote st = None
   \<and> \<not>(commt st)
   \<and> \<not>(ready st)
   \<and> timestamp st = 0
   \<and> decide st = None
   \<and> coord\<Phi> st = crd"

text \<open>
  We separately define the transition predicates and the send functions
  for each step and later combine them to define the overall next-state relation.
\<close>

\<comment> \<open>processes from which values and timestamps were received\<close>
definition valStampsRcvd where
  "valStampsRcvd (msgs :: Proc \<rightharpoonup> 'val msg) \<equiv>
   {q . \<exists>v ts. msgs q = Some (ValStamp v ts)}"

definition highestStampRcvd where
  "highestStampRcvd msgs \<equiv>
   Max {ts . \<exists>q v. (msgs::Proc \<rightharpoonup> 'val msg) q = Some (ValStamp v ts)}"

text \<open>
  In step 0, each process sends its current \<open>x\<close> and \<open>timestamp\<close>
  values to its coordinator.

  A process that considers itself to be a coordinator updates its
  \<open>vote\<close> field if it has received messages from a majority of processes.
  It then sets its \<open>commt\<close> field to true.
\<close>

definition send0 where
  "send0 r p q st \<equiv>
   if q = coord\<Phi> st then ValStamp (x st) (timestamp st) else Null"

definition next0 where
  "next0 r p st msgs crd st' \<equiv>
      if p = coord\<Phi> st \<and> card (valStampsRcvd msgs) > N div 2
      then (\<exists>p v. msgs p = Some (ValStamp v (highestStampRcvd msgs))
                \<and> st' = st \<lparr> vote := Some v, commt := True \<rparr> )
      else st' = st"

text \<open>
  In step 1, coordinators that have committed send their vote to all
  processes.

  Processes update their \<open>x\<close> and \<open>timestamp\<close> fields if they
  have received a vote from their coordinator.
\<close>

definition send1 where
  "send1 r p q st \<equiv>
   if p = coord\<Phi> st \<and> commt st then Vote (the (vote st)) else Null"

definition next1 where
  "next1 r p st msgs crd st' \<equiv>
   if msgs (coord\<Phi> st) \<noteq> None \<and> isVote (the (msgs (coord\<Phi> st)))
   then st' = st \<lparr> x := val (the (msgs (coord\<Phi> st))), timestamp := Suc(phase r) \<rparr>
   else st' = st"

text \<open>
  In step 2, processes that have current timestamps send an acknowledgement
  to their coordinator.

  A coordinator sets its \<open>ready\<close> field to true if it receives a majority
  of acknowledgements.
\<close>

definition send2 where
  "send2 r p q st \<equiv>
   if timestamp st = Suc(phase r) \<and> q = coord\<Phi> st then Ack else Null"

\<comment> \<open>processes from which an acknowledgement was received\<close>
definition acksRcvd where
  "acksRcvd (msgs :: Proc \<rightharpoonup> 'val msg) \<equiv>
   { q . msgs q \<noteq> None \<and> isAck (the (msgs q)) }"

definition next2 where
  "next2 r p st msgs crd st' \<equiv>
   if p = coord\<Phi> st \<and> card (acksRcvd msgs) > N div 2
   then st' = st \<lparr> ready := True \<rparr>
   else st' = st"

text \<open>
  In step 3, coordinators that are ready send their vote to all processes.

  Processes that received a vote from their coordinator decide on that value.
  Coordinators reset their \<open>ready\<close> and \<open>commt\<close> fields to false.
  All processes reset the coordinators as indicated by the parameter of
  the operator.
\<close>

definition send3 where
  "send3 r p q st \<equiv>
   if p = coord\<Phi> st \<and> ready st then Vote (the (vote st)) else Null"

definition next3 where
  "next3 r p st msgs crd st' \<equiv>
      (if msgs (coord\<Phi> st) \<noteq> None \<and> isVote (the (msgs (coord\<Phi> st)))
       then decide st' = Some (val (the (msgs (coord\<Phi> st))))
       else decide st' = decide st)
   \<and> (if p = coord\<Phi> st
      then \<not>(ready st') \<and> \<not>(commt st')
      else ready st' = ready st \<and> commt st' = commt st)
   \<and> x st' = x st
   \<and> vote st' = vote st
   \<and> timestamp st' = timestamp st
   \<and> coord\<Phi> st' = crd"

text \<open>
  The overall send function and next-state relation are simply obtained as
  the composition of the individual relations defined above.
\<close>

definition LV_sendMsg :: "nat \<Rightarrow> Proc \<Rightarrow> Proc \<Rightarrow> 'val pstate \<Rightarrow> 'val msg" where
  "LV_sendMsg (r::nat) \<equiv>
   if step r = 0 then send0 r
   else if step r = 1 then send1 r
   else if step r = 2 then send2 r
   else send3 r"

definition
  LV_nextState :: "nat \<Rightarrow> Proc \<Rightarrow> 'val pstate \<Rightarrow> (Proc \<rightharpoonup> 'val msg)
                       \<Rightarrow> Proc \<Rightarrow> 'val pstate \<Rightarrow> bool"
  where
  "LV_nextState r \<equiv>
   if step r = 0 then next0 r
   else if step r = 1 then next1 r
   else if step r = 2 then next2 r
   else next3 r"

subsection \<open>Communication Predicate for \emph{LastVoting}\<close>

text \<open>
  We now define the communication predicate that will be assumed for the
  correctness proof of the \emph{LastVoting} algorithm.
  The ``per-round'' part is trivial: integrity and agreement are always ensured.

  For the ``global'' part, Charron-Bost and Schiper propose a predicate
  that requires the existence of infinitely many phases \<open>ph\<close> such that:
  \begin{itemize}
  \item all processes agree on the same coordinator \<open>c\<close>,
  \item \<open>c\<close> hears from a strict majority of processes in steps 0 and 2
    of phase \<open>ph\<close>, and
  \item every process hears from \<open>c\<close> in steps 1 and 3 (this is slightly
    weaker than the predicate that appears in~\cite{charron:heardof}, but
    obviously sufficient).
  \end{itemize}

  Instead of requiring infinitely many such phases, we only assume the
  existence of one such phase (Charron-Bost and Schiper note that this is enough.)
\<close>

definition
  LV_commPerRd where
  "LV_commPerRd r (HO::Proc HO) (coord::Proc coord) \<equiv> True"

definition
  LV_commGlobal where
  "LV_commGlobal HOs coords \<equiv>
      \<exists>ph::nat. \<exists>c::Proc.
           (\<forall>p. coords (4*ph) p = c)
         \<and> card (HOs (4*ph) c) > N div 2
         \<and> card (HOs (4*ph+2) c) > N div 2
         \<and> (\<forall>p. c \<in> HOs (4*ph+1) p \<inter> HOs (4*ph+3) p)"

subsection \<open>The \emph{LastVoting} Heard-Of Machine\<close>

text \<open>
  We now define the coordinated HO machine for the \emph{LastVoting} algorithm
  by assembling the algorithm definition and its communication-predicate.
\<close>

definition LV_CHOMachine where
  "LV_CHOMachine \<equiv>
    \<lparr> CinitState = LV_initState,
      sendMsg = LV_sendMsg,
      CnextState = LV_nextState,
      CHOcommPerRd = LV_commPerRd,
      CHOcommGlobal = LV_commGlobal \<rparr>"

abbreviation
  "LV_M \<equiv> (LV_CHOMachine::(Proc, 'val pstate, 'val msg) CHOMachine)"

end