(* Title:      Matrix Algebras for Aggregation and Minimisation
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>Matrix Algebras for Aggregation and Minimisation\<close>

text \<open>
This theory formalises aggregation orders and lattices as introduced in \<^cite>\<open>"Guttmann2018a"\<close>.
Aggregation in these algebras is an associative and commutative operation satisfying additional properties related to the partial order and its least element.
We apply the aggregation operation to finite matrices over the aggregation algebras, which shows that they form an s-algebra.
By requiring the aggregation algebras to be linearly ordered, we also obtain that the matrices form an m-algebra.

This is an intermediate step in demonstrating that weighted graphs form an s-algebra and an m-algebra.
The present theory specifies abstract properties for the edge weights and shows that matrices over such weights form an instance of s-algebras and m-algebras.
A second step taken in a separate theory gives concrete instances of edge weights satisfying the abstract properties introduced here.

Lifting the aggregation to matrices requires finite sums over elements taken from commutative semigroups with an element that is a unit on the image of the semigroup operation.
Because standard sums assume a commutative monoid we have to derive a number of properties of these generalised sums as their statements or proofs are different.
\<close>

theory Matrix_Aggregation_Algebras

imports Stone_Kleene_Relation_Algebras.Matrix_Kleene_Algebras Aggregation_Algebras Semigroups_Big

begin

no_notation
  inf (infixl "\<sqinter>" 70)
  and uminus ("- _" [81] 80)

subsection \<open>Aggregation Orders and Finite Sums\<close>

text \<open>
An aggregation order is a partial order with a least element and an associative commutative operation satisfying certain properties.
Axiom \<open>add_add_bot\<close> introduces almost a commutative monoid; we require that \<open>bot\<close> is a unit only on the image of the aggregation operation.
This is necessary since it is not a unit of a number of aggregation operations we are interested in.
Axiom \<open>add_right_isotone\<close> states that aggregation is $\leq$-isotone on the image of the aggregation operation.
Its assumption $x \neq bot$ is necessary because the introduction of new edges can decrease the aggregated value.
Axiom \<open>add_bot\<close> expresses that aggregation is zero-sum-free.
\<close>

class aggregation_order = order_bot + ab_semigroup_add +
  assumes add_right_isotone: "x \<noteq> bot \<and> x + bot \<le> y + bot \<longrightarrow> x + z \<le> y + z"
  assumes add_add_bot [simp]: "x + y + bot = x + y"
  assumes add_bot: "x + y = bot \<longrightarrow> x = bot"
begin

abbreviation "zero \<equiv> bot + bot"

sublocale aggregation: ab_semigroup_add_0 where plus = plus and zero = zero
  apply unfold_locales
  using add_assoc add_add_bot by auto

lemma add_bot_bot_bot:
  "x + bot + bot + bot = x + bot"
  by simp

end

text \<open>
We introduce notation for finite sums over aggregation orders.
The index variable of the summation ranges over the finite universe of its type.
Finite sums are defined recursively using the binary aggregation and $\bot + \bot$ for the empty sum.
\<close>

syntax (xsymbols)
  "_sum_ab_semigroup_add_0" :: "idt \<Rightarrow> 'a::bounded_semilattice_sup_bot \<Rightarrow> 'a" ("(\<Sum>\<^sub>_ _)" [0,10] 10)

translations
  "\<Sum>\<^sub>x t" => "XCONST ab_semigroup_add_0.sum_0 XCONST plus (XCONST plus XCONST bot XCONST bot) (\<lambda>x . t) { x . CONST True }"

text \<open>
The following are basic properties of such sums.
\<close>

lemma agg_sum_bot:
  "(\<Sum>\<^sub>k bot::'a::aggregation_order) = bot + bot"
proof (induct rule: infinite_finite_induct)
  case (infinite A)
  thus ?case
    by simp
next
  case empty
  thus ?case
    by simp
next
  case (insert x F)
  thus ?case
    by (metis add.commute add_add_bot aggregation.sum_0.insert)
qed

lemma agg_sum_bot_bot:
  "(\<Sum>\<^sub>k bot + bot::'a::aggregation_order) = bot + bot"
  by (rule aggregation.sum_0.neutral_const)

lemma agg_sum_not_bot_1:
  fixes f :: "'a::finite \<Rightarrow> 'b::aggregation_order"
  assumes "f i \<noteq> bot"
    shows "(\<Sum>\<^sub>k f k) \<noteq> bot"
  by (metis assms add_bot aggregation.sum_0.remove finite_code mem_Collect_eq)

lemma agg_sum_not_bot:
  fixes f :: "('a::finite,'b::aggregation_order) square"
  assumes "f (i,j) \<noteq> bot"
    shows "(\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l)) \<noteq> bot"
  by (metis assms agg_sum_not_bot_1)

lemma agg_sum_distrib:
  fixes f g :: "'a \<Rightarrow> 'b::aggregation_order"
  shows "(\<Sum>\<^sub>k f k + g k) = (\<Sum>\<^sub>k f k) + (\<Sum>\<^sub>k g k)"
  by (rule aggregation.sum_0.distrib)

lemma agg_sum_distrib_2:
  fixes f g :: "('a,'b::aggregation_order) square"
  shows "(\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l) + g (k,l)) = (\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l)) + (\<Sum>\<^sub>k \<Sum>\<^sub>l g (k,l))"
proof -
  have "(\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l) + g (k,l)) = (\<Sum>\<^sub>k (\<Sum>\<^sub>l f (k,l)) + (\<Sum>\<^sub>l g (k,l)))"
    by (metis (no_types) aggregation.sum_0.distrib)
  also have "... = (\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l)) + (\<Sum>\<^sub>k \<Sum>\<^sub>l g (k,l))"
    by (metis (no_types) aggregation.sum_0.distrib)
  finally show ?thesis
    .
qed

lemma agg_sum_add_bot:
  fixes f :: "'a \<Rightarrow> 'b::aggregation_order"
  shows "(\<Sum>\<^sub>k f k) = (\<Sum>\<^sub>k f k) + bot"
  by (metis (no_types) add_add_bot aggregation.sum_0.F_one)

lemma agg_sum_add_bot_2:
  fixes f :: "'a \<Rightarrow> 'b::aggregation_order"
  shows "(\<Sum>\<^sub>k f k + bot) = (\<Sum>\<^sub>k f k)"
proof -
  have "(\<Sum>\<^sub>k f k + bot) = (\<Sum>\<^sub>k f k) + (\<Sum>\<^sub>k::'a bot::'b)"
    using agg_sum_distrib by simp
  also have "... = (\<Sum>\<^sub>k f k) + (bot + bot)"
    by (metis agg_sum_bot)
  also have "... = (\<Sum>\<^sub>k f k)"
    by simp
  finally show ?thesis
    by simp
qed

lemma agg_sum_commute:
  fixes f :: "('a,'b::aggregation_order) square"
  shows "(\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l)) = (\<Sum>\<^sub>l \<Sum>\<^sub>k f (k,l))"
  by (rule aggregation.sum_0.swap)

lemma agg_delta:
  fixes f :: "'a::finite \<Rightarrow> 'b::aggregation_order"
  shows "(\<Sum>\<^sub>l if l = j then f l else zero) = f j + bot"
  apply (subst aggregation.sum_0.delta)
  apply simp
  by (metis add.commute add.left_commute add_add_bot mem_Collect_eq)

lemma agg_delta_1:
  fixes f :: "'a::finite \<Rightarrow> 'b::aggregation_order"
  shows "(\<Sum>\<^sub>l if l = j then f l else bot) = f j + bot"
proof -
  let ?f = "(\<lambda>l . if l = j then f l else bot)"
  let ?S = "{l::'a . True}"
  show ?thesis
  proof (cases "j \<in> ?S")
    case False
    thus ?thesis by simp
  next
    case True
    let ?A = "?S - {j}"
    let ?B = "{j}"
    from True have eq: "?S = ?A \<union> ?B"
      by blast
    have dj: "?A \<inter> ?B = {}"
      by simp
    have fAB: "finite ?A" "finite ?B"
      by auto
    have "aggregation.sum_0 ?f ?S = aggregation.sum_0 ?f ?A + aggregation.sum_0 ?f ?B"
      using aggregation.sum_0.union_disjoint[OF fAB dj, of ?f, unfolded eq [symmetric]] by simp
    also have "... = aggregation.sum_0 (\<lambda>l . bot) ?A + aggregation.sum_0 ?f ?B"
      by (subst aggregation.sum_0.cong[where ?B="?A"]) simp_all
    also have "... = zero + aggregation.sum_0 ?f ?B"
      by (metis (no_types, lifting) add.commute add_add_bot aggregation.sum_0.F_g_one aggregation.sum_0.neutral)
    also have "... = zero + (f j + zero)"
      by simp
    also have "... = f j + bot"
      by (metis add.commute add.left_commute add_add_bot)
    finally show ?thesis
      .
  qed
qed

lemma agg_delta_2:
  fixes f :: "('a::finite,'b::aggregation_order) square"
  shows "(\<Sum>\<^sub>k \<Sum>\<^sub>l if k = i \<and> l = j then f (k,l) else bot) = f (i,j) + bot"
proof -
  have "\<forall>k . (\<Sum>\<^sub>l if k = i \<and> l = j then f (k,l) else bot) = (if k = i then f (k,j) + bot else zero)"
  proof
    fix k
    have "(\<Sum>\<^sub>l if k = i \<and> l = j then f (k,l) else bot) = (\<Sum>\<^sub>l if l = j then if k = i then f (k,l) else bot else bot)"
      by meson
    also have "... = (if k = i then f (k,j) else bot) + bot"
      by (rule agg_delta_1)
    finally show "(\<Sum>\<^sub>l if k = i \<and> l = j then f (k,l) else bot) = (if k = i then f (k,j) + bot else zero)"
      by simp
  qed
  hence "(\<Sum>\<^sub>k \<Sum>\<^sub>l if k = i \<and> l = j then f (k,l) else bot) = (\<Sum>\<^sub>k if k = i then f (k,j) + bot else zero)"
    using aggregation.sum_0.cong by auto
  also have "... = f (i,j) + bot"
    apply (subst agg_delta)
    by simp
  finally show ?thesis
    .
qed

subsection \<open>Matrix Aggregation\<close>

text \<open>
The following definitions introduce the matrix of unit elements, componentwise aggregation and aggregation on matrices.
The aggregation of a matrix is a single value, but because s-algebras are single-sorted the result has to be encoded as a matrix of the same type (size) as the input.
We store the aggregated matrix value in the `first' entry of a matrix, setting all other entries to the unit value.
The first entry is determined by requiring an enumeration of indices.
It does not have to be the first entry; any fixed location in the matrix would work as well.
\<close>

definition zero_matrix :: "('a,'b::{plus,bot}) square" ("mzero") where "mzero = (\<lambda>e . bot + bot)"

definition plus_matrix :: "('a,'b::plus) square \<Rightarrow> ('a,'b) square \<Rightarrow> ('a,'b) square" (infixl "\<oplus>\<^sub>M" 65) where "plus_matrix f g = (\<lambda>e . f e + g e)"

definition sum_matrix :: "('a::enum,'b::{plus,bot}) square \<Rightarrow> ('a,'b) square" ("sum\<^sub>M _" [80] 80) where "sum_matrix f = (\<lambda>(i,j) . if i = hd enum_class.enum \<and> j = i then \<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l) else bot + bot)"

text \<open>
Basic properties of these operations are given in the following.
\<close>

lemma bot_plus_bot:
  "mbot \<oplus>\<^sub>M mbot = mzero"
  by (simp add: plus_matrix_def bot_matrix_def zero_matrix_def)

lemma sum_bot:
  "sum\<^sub>M (mbot :: ('a::enum,'b::aggregation_order) square) = mzero"
proof (rule ext, rule prod_cases)
  fix i j :: "'a"
  have "(sum\<^sub>M mbot :: ('a,'b) square) (i,j) = (if i = hd enum_class.enum \<and> j = i then \<Sum>\<^sub>(k::'a) \<Sum>\<^sub>(l::'a) bot else bot + bot)"
    by (unfold sum_matrix_def bot_matrix_def) simp
  also have "... = bot + bot"
    using agg_sum_bot aggregation.sum_0.neutral by fastforce
  also have "... = mzero (i,j)"
    by (simp add: zero_matrix_def)
  finally show "(sum\<^sub>M mbot :: ('a,'b) square) (i,j) = mzero (i,j)"
    .
qed

lemma sum_plus_bot:
  fixes f :: "('a::enum,'b::aggregation_order) square"
  shows "sum\<^sub>M f \<oplus>\<^sub>M mbot = sum\<^sub>M f"
proof (rule ext, rule prod_cases)
  let ?h = "hd enum_class.enum"
  fix i j
  have "(sum\<^sub>M f \<oplus>\<^sub>M mbot) (i,j) = (if i = ?h \<and> j = i then (\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l)) + bot else zero + bot)"
    by (simp add: plus_matrix_def bot_matrix_def sum_matrix_def)
  also have "... = (if i = ?h \<and> j = i then \<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l) else zero)"
    by (metis (no_types, lifting) add_add_bot aggregation.sum_0.F_one)
  also have "... = (sum\<^sub>M f) (i,j)"
    by (simp add: sum_matrix_def)
  finally show "(sum\<^sub>M f \<oplus>\<^sub>M mbot) (i,j) = (sum\<^sub>M f) (i,j)"
    by simp
qed

lemma sum_plus_zero:
  fixes f :: "('a::enum,'b::aggregation_order) square"
  shows "sum\<^sub>M f \<oplus>\<^sub>M mzero = sum\<^sub>M f"
  by (rule ext, rule prod_cases) (simp add: plus_matrix_def zero_matrix_def sum_matrix_def)

lemma agg_matrix_bot:
  fixes f :: "('a,'b::aggregation_order) square"
  assumes "\<forall>i j . f (i,j) = bot"
    shows "f = mbot"
  apply (unfold bot_matrix_def)
  using assms by auto

text \<open>
We consider a different implementation of matrix aggregation which stores the aggregated value in all entries of the matrix instead of a particular one.
This does not require an enumeration of the indices.
All results continue to hold using this alternative implementation.
\<close>

definition sum_matrix_2 :: "('a,'b::{plus,bot}) square \<Rightarrow> ('a,'b) square" ("sum2\<^sub>M _" [80] 80) where "sum_matrix_2 f = (\<lambda>e . \<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l))"

lemma sum_bot_2:
  "sum2\<^sub>M (mbot :: ('a,'b::aggregation_order) square) = mzero"
proof
  fix e
  have "(sum2\<^sub>M mbot :: ('a,'b) square) e = (\<Sum>\<^sub>(k::'a) \<Sum>\<^sub>(l::'a) bot)"
    by (unfold sum_matrix_2_def bot_matrix_def) simp
  also have "... = bot + bot"
    using agg_sum_bot aggregation.sum_0.neutral by fastforce
  also have "... = mzero e"
    by (simp add: zero_matrix_def)
  finally show "(sum2\<^sub>M mbot :: ('a,'b) square) e = mzero e"
    .
qed

lemma sum_plus_bot_2:
  fixes f :: "('a,'b::aggregation_order) square"
  shows "sum2\<^sub>M f \<oplus>\<^sub>M mbot = sum2\<^sub>M f"
proof
  fix e
  have "(sum2\<^sub>M f \<oplus>\<^sub>M mbot) e = (\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l)) + bot"
    by (simp add: plus_matrix_def bot_matrix_def sum_matrix_2_def)
  also have "... = (\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l))"
    by (metis (no_types, lifting) add_add_bot aggregation.sum_0.F_one)
  also have "... = (sum2\<^sub>M f) e"
    by (simp add: sum_matrix_2_def)
  finally show "(sum2\<^sub>M f \<oplus>\<^sub>M mbot) e = (sum2\<^sub>M f) e"
    by simp
qed

lemma sum_plus_zero_2:
  fixes f :: "('a,'b::aggregation_order) square"
  shows "sum2\<^sub>M f \<oplus>\<^sub>M mzero = sum2\<^sub>M f"
  by (simp add: plus_matrix_def zero_matrix_def sum_matrix_2_def)

subsection \<open>Aggregation Lattices\<close>

text \<open>
We extend aggregation orders to dense bounded distributive lattices.
Axiom \<open>add_lattice\<close> implements the inclusion-exclusion principle at the level of edge weights.
\<close>

class aggregation_lattice = bounded_distrib_lattice + dense_lattice + aggregation_order +
  assumes add_lattice: "x + y = (x \<squnion> y) + (x \<sqinter> y)"

text \<open>
Aggregation lattices form a Stone relation algebra by reusing the meet operation as composition, using identity as converse and a standard implementation of pseudocomplement.
\<close>

class aggregation_algebra = aggregation_lattice + uminus + one + times + conv +
  assumes uminus_def [simp]: "-x = (if x = bot then top else bot)"
  assumes one_def [simp]: "1 = top"
  assumes times_def [simp]: "x * y = x \<sqinter> y"
  assumes conv_def [simp]: "x\<^sup>T = x"
begin

subclass stone_algebra
  apply unfold_locales
  using bot_meet_irreducible bot_unique by auto

subclass stone_relation_algebra
  apply unfold_locales
  prefer 9 using bot_meet_irreducible apply auto[1]
  by (simp_all add: inf.assoc le_infI2 inf_sup_distrib1 inf_sup_distrib2 inf.commute inf.left_commute)

end

text \<open>
We show that matrices over aggregation lattices form an s-algebra using the above operations.
\<close>

interpretation agg_square_s_algebra: s_algebra where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix::('a::enum,'b::aggregation_algebra) square" and top = top_matrix and uminus = uminus_matrix and one = one_matrix and times = times_matrix and conv = conv_matrix and plus = plus_matrix and sum = sum_matrix
proof
  fix f g h :: "('a,'b) square"
  show "f \<noteq> mbot \<and> sum\<^sub>M f \<preceq> sum\<^sub>M g \<longrightarrow> h \<oplus>\<^sub>M sum\<^sub>M f \<preceq> h \<oplus>\<^sub>M sum\<^sub>M g"
  proof
    let ?h = "hd enum_class.enum"
    assume 1: "f \<noteq> mbot \<and> sum\<^sub>M f \<preceq> sum\<^sub>M g"
    hence "\<exists>k l . f (k,l) \<noteq> bot"
      by (meson agg_matrix_bot)
    hence 2: "(\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l)) \<noteq> bot"
      using agg_sum_not_bot by blast
    have "(\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l)) = (sum\<^sub>M f) (?h,?h)"
      by (simp add: sum_matrix_def)
    also have "... \<le> (sum\<^sub>M g) (?h,?h)"
      using 1 by (simp add: less_eq_matrix_def)
    also have "... = (\<Sum>\<^sub>k \<Sum>\<^sub>l g (k,l))"
      by (simp add: sum_matrix_def)
    finally have "(\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l)) \<le> (\<Sum>\<^sub>k \<Sum>\<^sub>l g (k,l))"
      by simp
    hence 3: "(\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l)) + bot \<le> (\<Sum>\<^sub>k \<Sum>\<^sub>l g (k,l)) + bot"
      by (metis (no_types, lifting) add_add_bot aggregation.sum_0.F_one)
    show "h \<oplus>\<^sub>M sum\<^sub>M f \<preceq> h \<oplus>\<^sub>M sum\<^sub>M g"
    proof (unfold less_eq_matrix_def, rule allI, rule prod_cases, unfold plus_matrix_def)
      fix i j
      have 4: "h (i,j) + (\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l)) \<le> h (i,j) + (\<Sum>\<^sub>k \<Sum>\<^sub>l g (k,l))"
        using 2 3 by (metis (no_types, lifting) add_right_isotone add.commute)
      have "h (i,j) + (sum\<^sub>M f) (i,j) = h (i,j) + (if i = ?h \<and> j = i then \<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l) else zero)"
        by (simp add: sum_matrix_def)
      also have "... = (if i = ?h \<and> j = i then h (i,j) + (\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l)) else h (i,j) + zero)"
        by simp
      also have "... \<le> (if i = ?h \<and> j = i then h (i,j) + (\<Sum>\<^sub>k \<Sum>\<^sub>l g (k,l)) else h (i,j) + zero)"
        using 4 order.eq_iff by auto
      also have "... = h (i,j) + (if i = ?h \<and> j = i then \<Sum>\<^sub>k \<Sum>\<^sub>l g (k,l) else zero)"
        by simp
      finally show "h (i,j) + (sum\<^sub>M f) (i,j) \<le> h (i,j) + (sum\<^sub>M g) (i,j)"
        by (simp add: sum_matrix_def)
    qed
  qed
next
  fix f :: "('a,'b) square"
  show "sum\<^sub>M f \<oplus>\<^sub>M sum\<^sub>M mbot = sum\<^sub>M f"
    by (simp add: sum_bot sum_plus_zero)
next
  fix f g :: "('a,'b) square"
  show "sum\<^sub>M f \<oplus>\<^sub>M sum\<^sub>M g = sum\<^sub>M (f \<oplus> g) \<oplus>\<^sub>M sum\<^sub>M (f \<otimes> g)"
  proof (rule ext, rule prod_cases)
    fix i j
    let ?h = "hd enum_class.enum"
    have "(sum\<^sub>M f \<oplus>\<^sub>M sum\<^sub>M g) (i,j) = (sum\<^sub>M f) (i,j) + (sum\<^sub>M g) (i,j)"
      by (simp add: plus_matrix_def)
    also have "... = (if i = ?h \<and> j = i then \<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l) else zero) + (if i = ?h \<and> j = i then \<Sum>\<^sub>k \<Sum>\<^sub>l g (k,l) else zero)"
      by (simp add: sum_matrix_def)
    also have "... = (if i = ?h \<and> j = i then (\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l)) + (\<Sum>\<^sub>k \<Sum>\<^sub>l g (k,l)) else zero)"
      by simp
    also have "... = (if i = ?h \<and> j = i then \<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l) + g (k,l) else zero)"
      using agg_sum_distrib_2 by (metis (no_types))
    also have "... = (if i = ?h \<and> j = i then \<Sum>\<^sub>k \<Sum>\<^sub>l (f (k,l) \<squnion> g (k,l)) + (f (k,l) \<sqinter> g (k,l)) else zero)"
      using add_lattice aggregation.sum_0.cong by (metis (no_types, lifting))
    also have "... = (if i = ?h \<and> j = i then \<Sum>\<^sub>k \<Sum>\<^sub>l (f \<oplus> g) (k,l) + (f \<otimes> g) (k,l) else zero)"
      by (simp add: sup_matrix_def inf_matrix_def)
    also have "... = (if i = ?h \<and> j = i then (\<Sum>\<^sub>k \<Sum>\<^sub>l (f \<oplus> g) (k,l)) + (\<Sum>\<^sub>k \<Sum>\<^sub>l (f \<otimes> g) (k,l)) else zero)"
      using agg_sum_distrib_2 by (metis (no_types))
    also have "... = (if i = ?h \<and> j = i then \<Sum>\<^sub>k \<Sum>\<^sub>l (f \<oplus> g) (k,l) else zero) + (if i = ?h \<and> j = i then \<Sum>\<^sub>k \<Sum>\<^sub>l (f \<otimes> g) (k,l) else zero)"
      by simp
    also have "... = (sum\<^sub>M (f \<oplus> g)) (i,j) + (sum\<^sub>M (f \<otimes> g)) (i,j)"
      by (simp add: sum_matrix_def)
    also have "... = (sum\<^sub>M (f \<oplus> g) \<oplus>\<^sub>M sum\<^sub>M (f \<otimes> g)) (i,j)"
      by (simp add: plus_matrix_def)
    finally show "(sum\<^sub>M f \<oplus>\<^sub>M sum\<^sub>M g) (i,j) = (sum\<^sub>M (f \<oplus> g) \<oplus>\<^sub>M sum\<^sub>M (f \<otimes> g)) (i,j)"
      .
  qed
next
  fix f :: "('a,'b) square"
  show "sum\<^sub>M (f\<^sup>t) = sum\<^sub>M f"
  proof (rule ext, rule prod_cases)
    fix i j
    let ?h = "hd enum_class.enum"
    have "(sum\<^sub>M (f\<^sup>t)) (i,j) = (if i = ?h \<and> j = i then \<Sum>\<^sub>k \<Sum>\<^sub>l (f\<^sup>t) (k,l) else zero)"
      by (simp add: sum_matrix_def)
    also have "... = (if i = ?h \<and> j = i then \<Sum>\<^sub>k \<Sum>\<^sub>l (f (l,k))\<^sup>T else zero)"
      by (simp add: conv_matrix_def)
    also have "... = (if i = ?h \<and> j = i then \<Sum>\<^sub>k \<Sum>\<^sub>l f (l,k) else zero)"
      by simp
    also have "... = (if i = ?h \<and> j = i then \<Sum>\<^sub>l \<Sum>\<^sub>k f (l,k) else zero)"
      by (metis agg_sum_commute)
    also have "... = (sum\<^sub>M f) (i,j)"
      by (simp add: sum_matrix_def)
    finally show "(sum\<^sub>M (f\<^sup>t)) (i,j) = (sum\<^sub>M f) (i,j)"
      .
  qed
qed

text \<open>
We show the same for the alternative implementation that stores the result of aggregation in all elements of the matrix.
\<close>

interpretation agg_square_s_algebra_2: s_algebra where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix::('a::finite,'b::aggregation_algebra) square" and top = top_matrix and uminus = uminus_matrix and one = one_matrix and times = times_matrix and conv = conv_matrix and plus = plus_matrix and sum = sum_matrix_2
proof
  fix f g h :: "('a,'b) square"
  show "f \<noteq> mbot \<and> sum2\<^sub>M f \<preceq> sum2\<^sub>M g \<longrightarrow> h \<oplus>\<^sub>M sum2\<^sub>M f \<preceq> h \<oplus>\<^sub>M sum2\<^sub>M g"
  proof
    assume 1: "f \<noteq> mbot \<and> sum2\<^sub>M f \<preceq> sum2\<^sub>M g"
    hence "\<exists>k l . f (k,l) \<noteq> bot"
      by (meson agg_matrix_bot)
    hence 2: "(\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l)) \<noteq> bot"
      using agg_sum_not_bot by blast
    obtain c :: 'a where True
      by simp
    have "(\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l)) = (sum2\<^sub>M f) (c,c)"
      by (simp add: sum_matrix_2_def)
    also have "... \<le> (sum2\<^sub>M g) (c,c)"
      using 1 by (simp add: less_eq_matrix_def)
    also have "... = (\<Sum>\<^sub>k \<Sum>\<^sub>l g (k,l))"
      by (simp add: sum_matrix_2_def)
    finally have "(\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l)) \<le> (\<Sum>\<^sub>k \<Sum>\<^sub>l g (k,l))"
      by simp
    hence 3: "(\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l)) + bot \<le> (\<Sum>\<^sub>k \<Sum>\<^sub>l g (k,l)) + bot"
      by (metis (no_types, lifting) add_add_bot aggregation.sum_0.F_one)
    show "h \<oplus>\<^sub>M sum2\<^sub>M f \<preceq> h \<oplus>\<^sub>M sum2\<^sub>M g"
    proof (unfold less_eq_matrix_def, rule allI, unfold plus_matrix_def)
      fix e
      have "h e + (sum2\<^sub>M f) e = h e + (\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l))"
        by (simp add: sum_matrix_2_def)
      also have "... \<le> h e + (\<Sum>\<^sub>k \<Sum>\<^sub>l g (k,l))"
        using 2 3 by (metis (no_types, lifting) add_right_isotone add.commute)
      finally show "h e + (sum2\<^sub>M f) e \<le> h e + (sum2\<^sub>M g) e"
        by (simp add: sum_matrix_2_def)
    qed
  qed
next
  fix f :: "('a,'b) square"
  show "sum2\<^sub>M f \<oplus>\<^sub>M sum2\<^sub>M mbot = sum2\<^sub>M f"
    by (simp add: sum_bot_2 sum_plus_zero_2)
next
  fix f g :: "('a,'b) square"
  show "sum2\<^sub>M f \<oplus>\<^sub>M sum2\<^sub>M g = sum2\<^sub>M (f \<oplus> g) \<oplus>\<^sub>M sum2\<^sub>M (f \<otimes> g)"
  proof
    fix e
    have "(sum2\<^sub>M f \<oplus>\<^sub>M sum2\<^sub>M g) e = (sum2\<^sub>M f) e + (sum2\<^sub>M g) e"
      by (simp add: plus_matrix_def)
    also have "... = (\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l)) + (\<Sum>\<^sub>k \<Sum>\<^sub>l g (k,l))"
      by (simp add: sum_matrix_2_def)
    also have "... = (\<Sum>\<^sub>k \<Sum>\<^sub>l f (k,l) + g (k,l))"
      using agg_sum_distrib_2 by (metis (no_types))
    also have "... = (\<Sum>\<^sub>k \<Sum>\<^sub>l (f (k,l) \<squnion> g (k,l)) + (f (k,l) \<sqinter> g (k,l)))"
      using add_lattice aggregation.sum_0.cong by (metis (no_types, lifting))
    also have "... = (\<Sum>\<^sub>k \<Sum>\<^sub>l (f \<oplus> g) (k,l) + (f \<otimes> g) (k,l))"
      by (simp add: sup_matrix_def inf_matrix_def)
    also have "... = (\<Sum>\<^sub>k \<Sum>\<^sub>l (f \<oplus> g) (k,l)) + (\<Sum>\<^sub>k \<Sum>\<^sub>l (f \<otimes> g) (k,l))"
      using agg_sum_distrib_2 by (metis (no_types))
    also have "... = (sum2\<^sub>M (f \<oplus> g)) e + (sum2\<^sub>M (f \<otimes> g)) e"
      by (simp add: sum_matrix_2_def)
    also have "... = (sum2\<^sub>M (f \<oplus> g) \<oplus>\<^sub>M sum2\<^sub>M (f \<otimes> g)) e"
      by (simp add: plus_matrix_def)
    finally show "(sum2\<^sub>M f \<oplus>\<^sub>M sum2\<^sub>M g) e = (sum2\<^sub>M (f \<oplus> g) \<oplus>\<^sub>M sum2\<^sub>M (f \<otimes> g)) e"
      .
  qed
next
  fix f :: "('a,'b) square"
  show "sum2\<^sub>M (f\<^sup>t) = sum2\<^sub>M f"
  proof
    fix e
    have "(sum2\<^sub>M (f\<^sup>t)) e = (\<Sum>\<^sub>k \<Sum>\<^sub>l (f\<^sup>t) (k,l))"
      by (simp add: sum_matrix_2_def)
    also have "... = (\<Sum>\<^sub>k \<Sum>\<^sub>l (f (l,k))\<^sup>T)"
      by (simp add: conv_matrix_def)
    also have "... = (\<Sum>\<^sub>k \<Sum>\<^sub>l f (l,k))"
      by simp
    also have "... = (\<Sum>\<^sub>l \<Sum>\<^sub>k f (l,k))"
      by (metis agg_sum_commute)
    also have "... = (sum2\<^sub>M f) e"
      by (simp add: sum_matrix_2_def)
    finally show "(sum2\<^sub>M (f\<^sup>t)) e = (sum2\<^sub>M f) e"
      .
  qed
qed

subsection \<open>Matrix Minimisation\<close>

text \<open>
We construct an operation that finds the minimum entry of a matrix.
Because a matrix can have several entries with the same minimum value, we introduce a lexicographic order on the indices to make the operation deterministic.
The order is obtained by enumerating the universe of the index.
\<close>

primrec enum_pos' :: "'a list \<Rightarrow> 'a::enum \<Rightarrow> nat" where
  "enum_pos' Nil x = 0"
| "enum_pos' (y#ys) x = (if x = y then 0 else 1 + enum_pos' ys x)"

lemma enum_pos'_inverse:
  "List.member xs x \<Longrightarrow> xs!(enum_pos' xs x) = x"
  apply (induct xs)
  apply (simp add: member_rec(2))
  by (metis diff_add_inverse enum_pos'.simps(2) less_one member_rec(1) not_add_less1 nth_Cons')

text \<open>
The following function finds the position of an index in the enumerated universe.
\<close>

fun enum_pos :: "'a::enum \<Rightarrow> nat" where "enum_pos x = enum_pos' (enum_class.enum::'a list) x"

lemma enum_pos_inverse [simp]:
  "enum_class.enum!(enum_pos x) = x"
  apply (unfold enum_pos.simps)
  apply (rule enum_pos'_inverse)
  by (metis in_enum List.member_def)

lemma enum_pos_injective [simp]:
  "enum_pos x = enum_pos y \<Longrightarrow> x = y"
  by (metis enum_pos_inverse)

text \<open>
The position in the enumerated universe determines the order.
\<close>

abbreviation enum_pos_less_eq :: "'a::enum \<Rightarrow> 'a \<Rightarrow> bool" where "enum_pos_less_eq x y \<equiv> (enum_pos x \<le> enum_pos y)"
abbreviation enum_pos_less :: "'a::enum \<Rightarrow> 'a \<Rightarrow> bool" where "enum_pos_less x y \<equiv> (enum_pos x < enum_pos y)"

sublocale enum < enum_order: order where less_eq = "\<lambda>x y . enum_pos_less_eq x y" and less = "\<lambda>x y . enum_pos x < enum_pos y"
  apply unfold_locales
  by auto

text \<open>
Based on this, a lexicographic order is defined on pairs, which represent locations in a matrix.
\<close>

abbreviation enum_lex_less :: "'a::enum \<times> 'a \<Rightarrow> 'a \<times> 'a \<Rightarrow> bool" where "enum_lex_less \<equiv> (\<lambda>(i,j) (k,l) . enum_pos_less i k \<or> (i = k \<and> enum_pos_less j l))"
abbreviation enum_lex_less_eq :: "'a::enum \<times> 'a \<Rightarrow> 'a \<times> 'a \<Rightarrow> bool" where "enum_lex_less_eq \<equiv> (\<lambda>(i,j) (k,l) . enum_pos_less i k \<or> (i = k \<and> enum_pos_less_eq j l))"

text \<open>
The $m$-operation determines the location of the non-$\bot$ minimum element which is first in the lexicographic order.
The result is returned as a regular matrix with $\top$ at that location and $\bot$ everywhere else.
In the weighted-graph model, this represents a single unweighted edge of the graph.
\<close>

definition minarc_matrix :: "('a::enum,'b::{bot,ord,plus,top}) square \<Rightarrow> ('a,'b) square" ("minarc\<^sub>M _" [80] 80) where "minarc_matrix f = (\<lambda>e . if f e \<noteq> bot \<and> (\<forall>d . (f d \<noteq> bot \<longrightarrow> (f e + bot \<le> f d + bot \<and> (enum_lex_less d e \<longrightarrow> f e + bot \<noteq> f d + bot)))) then top else bot)"

lemma minarc_at_most_one:
  fixes f :: "('a::enum,'b::{aggregation_order,top}) square"
  assumes "(minarc\<^sub>M f) e \<noteq> bot"
      and "(minarc\<^sub>M f) d \<noteq> bot"
    shows "e = d"
proof -
  have 1: "f e + bot \<le> f d + bot"
    by (metis assms minarc_matrix_def)
  have "f d + bot \<le> f e + bot"
    by (metis assms minarc_matrix_def)
  hence "f e + bot = f d + bot"
    using 1 by simp
  hence "\<not> enum_lex_less d e \<and> \<not> enum_lex_less e d"
    using assms by (unfold minarc_matrix_def) (metis (lifting))
  thus ?thesis
    using enum_pos_injective less_linear by auto
qed

subsection \<open>Linear Aggregation Lattices\<close>

text \<open>
We now assume that the aggregation order is linear and forms a bounded lattice.
It follows that these structures are aggregation lattices.
A linear order on matrix entries is necessary to obtain a unique minimum entry.
\<close>

class linear_aggregation_lattice = linear_bounded_lattice + aggregation_order
begin

subclass aggregation_lattice
  apply unfold_locales
  by (metis add_commute sup_inf_selective)

sublocale heyting: bounded_heyting_lattice where implies = "\<lambda>x y . if x \<le> y then top else y"
  apply unfold_locales
  by (simp add: inf_less_eq)

end

text \<open>
Every non-empty set with a transitive total relation has a least element with respect to this relation.
\<close>

lemma least_order:
  assumes transitive: "\<forall>x y z . le x y \<and> le y z \<longrightarrow> le x z"
      and total: "\<forall>x y . le x y \<or> le y x"
    shows "finite A \<Longrightarrow> A \<noteq> {} \<Longrightarrow> \<exists>x . x \<in> A \<and> (\<forall>y . y \<in> A \<longrightarrow> le x y)"
proof (induct A rule: finite_ne_induct)
  case singleton
  thus ?case
    using total by auto
next
  case insert
  thus ?case
    by (metis insert_iff transitive total)
qed

lemma minarc_at_least_one:
  fixes f :: "('a::enum,'b::linear_aggregation_lattice) square"
  assumes "f \<noteq> mbot"
    shows "\<exists>e . (minarc\<^sub>M f) e = top"
proof -
  let ?nbe = "{ (e,f e) | e . f e \<noteq> bot }"
  have 1: "finite ?nbe"
    using finite_code finite_image_set by blast
  have 2: "?nbe \<noteq> {}"
    using assms agg_matrix_bot by fastforce
  let ?le = "\<lambda>(e::'a \<times> 'a,fe::'b) (d::'a \<times> 'a,fd) . fe + bot \<le> fd + bot"
  have 3: "\<forall>x y z . ?le x y \<and> ?le y z \<longrightarrow> ?le x z"
    by auto
  have 4: "\<forall>x y . ?le x y \<or> ?le y x"
    by (simp add: linear)
  have "\<exists>x . x \<in> ?nbe \<and> (\<forall>y . y \<in> ?nbe \<longrightarrow> ?le x y)"
    by (rule least_order, rule 3, rule 4, rule 1, rule 2)
  then obtain e fe where 5: "(e,fe) \<in> ?nbe \<and> (\<forall>y . y \<in> ?nbe \<longrightarrow> ?le (e,fe) y)"
    by auto
  let ?me = "{ e . f e \<noteq> bot \<and> f e + bot = fe + bot }"
  have 6: "finite ?me"
    using finite_code finite_image_set by blast
  have 7: "?me \<noteq> {}"
    using 5 by auto
  have 8: "\<forall>x y z . enum_lex_less_eq x y \<and> enum_lex_less_eq y z \<longrightarrow> enum_lex_less_eq x z"
    by auto
  have 9: "\<forall>x y . enum_lex_less_eq x y \<or> enum_lex_less_eq y x"
    by auto
  have "\<exists>x . x \<in> ?me \<and> (\<forall>y . y \<in> ?me \<longrightarrow> enum_lex_less_eq x y)"
    by (rule least_order, rule 8, rule 9, rule 6, rule 7)
  then obtain m where 10: "m \<in> ?me \<and> (\<forall>y . y \<in> ?me \<longrightarrow> enum_lex_less_eq m y)"
    by auto
  have 11: "f m \<noteq> bot"
    using 10 5 by auto
  have 12: "\<forall>d. f d \<noteq> bot \<longrightarrow> f m + bot \<le> f d + bot"
    using 10 5 by simp
  have "\<forall>d. f d \<noteq> bot \<and> enum_lex_less d m \<longrightarrow> f m + bot \<noteq> f d + bot"
    using 10 by fastforce
  hence "(minarc\<^sub>M f) m = top"
    using 11 12 by (simp add: minarc_matrix_def)
  thus ?thesis
    by blast
qed

text \<open>
Linear aggregation lattices form a Stone relation algebra by reusing the meet operation as composition, using identity as converse and a standard implementation of pseudocomplement.
\<close>

class linear_aggregation_algebra = linear_aggregation_lattice + uminus + one + times + conv +
  assumes uminus_def_2 [simp]: "-x = (if x = bot then top else bot)"
  assumes one_def_2 [simp]: "1 = top"
  assumes times_def_2 [simp]: "x * y = x \<sqinter> y"
  assumes conv_def_2 [simp]: "x\<^sup>T = x"
begin

subclass aggregation_algebra
  apply unfold_locales
  using inf_dense by auto

lemma regular_bot_top_2:
  "regular x \<longleftrightarrow> x = bot \<or> x = top"
  by simp

sublocale heyting: heyting_stone_algebra where implies = "\<lambda>x y . if x \<le> y then top else y"
  apply unfold_locales
  apply (simp add: order.antisym)
  by auto

end

text \<open>
We show that matrices over linear aggregation lattices form an m-algebra using the above operations.
\<close>

interpretation agg_square_m_algebra: m_algebra where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix::('a::enum,'b::linear_aggregation_algebra) square" and top = top_matrix and uminus = uminus_matrix and one = one_matrix and times = times_matrix and conv = conv_matrix and plus = plus_matrix and sum = sum_matrix and minarc = minarc_matrix
proof
  fix f :: "('a,'b) square"
  show "minarc\<^sub>M f \<preceq> \<ominus>\<ominus>f"
  proof (unfold less_eq_matrix_def, rule allI)
    fix e :: "'a \<times> 'a"
    have "(minarc\<^sub>M f) e \<le> (if f e \<noteq> bot then top else --(f e))"
      by (simp add: minarc_matrix_def)
    also have "... = --(f e)"
      by simp
    also have "... = (\<ominus>\<ominus>f) e"
      by (simp add: uminus_matrix_def)
    finally show "(minarc\<^sub>M f) e \<le> (\<ominus>\<ominus>f) e"
      .
  qed
next
  fix f :: "('a,'b) square"
  let ?at = "bounded_distrib_allegory_signature.arc mone times_matrix less_eq_matrix mtop conv_matrix"
  show "f \<noteq> mbot \<longrightarrow> ?at (minarc\<^sub>M f)"
  proof
    assume 1: "f \<noteq> mbot"
    have "minarc\<^sub>M f \<odot> mtop \<odot> (minarc\<^sub>M f \<odot> mtop)\<^sup>t = minarc\<^sub>M f \<odot> mtop \<odot> (minarc\<^sub>M f)\<^sup>t"
      by (metis matrix_bounded_idempotent_semiring.surjective_top_closed matrix_monoid.mult_assoc matrix_stone_relation_algebra.conv_dist_comp matrix_stone_relation_algebra.conv_top)
    also have "... \<preceq> mone"
    proof (unfold less_eq_matrix_def, rule allI, rule prod_cases)
      fix i j
      have "(minarc\<^sub>M f \<odot> mtop \<odot> (minarc\<^sub>M f)\<^sup>t) (i,j) = (\<Squnion>\<^sub>l (\<Squnion>\<^sub>k (minarc\<^sub>M f) (i,k) * mtop (k,l)) * ((minarc\<^sub>M f)\<^sup>t) (l,j))"
        by (simp add: times_matrix_def)
      also have "... = (\<Squnion>\<^sub>l (\<Squnion>\<^sub>k (minarc\<^sub>M f) (i,k) * top) * ((minarc\<^sub>M f) (j,l))\<^sup>T)"
        by (simp add: top_matrix_def conv_matrix_def)
      also have "... = (\<Squnion>\<^sub>l \<Squnion>\<^sub>k (minarc\<^sub>M f) (i,k) * top * ((minarc\<^sub>M f) (j,l))\<^sup>T)"
        by (metis comp_right_dist_sum)
      also have "... = (\<Squnion>\<^sub>l \<Squnion>\<^sub>k if i = j \<and> l = k then (minarc\<^sub>M f) (i,k) * top * ((minarc\<^sub>M f) (j,l))\<^sup>T else bot)"
        apply (rule sup_monoid.sum.cong)
        apply simp
        by (metis (no_types, lifting) comp_left_zero comp_right_zero conv_bot prod.inject minarc_at_most_one)
      also have "... = (if i = j then (\<Squnion>\<^sub>l \<Squnion>\<^sub>k if l = k then (minarc\<^sub>M f) (i,k) * top * ((minarc\<^sub>M f) (j,l))\<^sup>T else bot) else bot)"
        by auto
      also have "... \<le> (if i = j then top else bot)"
        by simp
      also have "... = mone (i,j)"
        by (simp add: one_matrix_def)
      finally show "(minarc\<^sub>M f \<odot> mtop \<odot> (minarc\<^sub>M f)\<^sup>t) (i,j) \<le> mone (i,j)"
        .
    qed
    finally have 2: "minarc\<^sub>M f \<odot> mtop \<odot> (minarc\<^sub>M f \<odot> mtop)\<^sup>t \<preceq> mone"
      .
    have 3: "mtop \<odot> (minarc\<^sub>M f \<odot> mtop) = mtop"
    proof (rule ext, rule prod_cases)
      fix i j
      from minarc_at_least_one obtain ei ej where "(minarc\<^sub>M f) (ei,ej) = top"
        using 1 by force
      hence 4: "top * top \<le> (\<Squnion>\<^sub>l (minarc\<^sub>M f) (ei,l) * top)"
        by (metis comp_inf.ub_sum)
      have "top * (\<Squnion>\<^sub>l (minarc\<^sub>M f) (ei,l) * top) \<le> (\<Squnion>\<^sub>k top * (\<Squnion>\<^sub>l (minarc\<^sub>M f) (k,l) * top))"
        by (rule comp_inf.ub_sum)
      hence "top \<le> (\<Squnion>\<^sub>k top * (\<Squnion>\<^sub>l (minarc\<^sub>M f) (k,l) * top))"
        using 4 by auto
      also have "... = (\<Squnion>\<^sub>k mtop (i,k) * (\<Squnion>\<^sub>l (minarc\<^sub>M f) (k,l) * mtop (l,j)))"
        by (simp add: top_matrix_def)
      also have "... = (mtop \<odot> (minarc\<^sub>M f \<odot> mtop)) (i,j)"
        by (simp add: times_matrix_def)
      finally show "(mtop \<odot> (minarc\<^sub>M f \<odot> mtop)) (i,j) = mtop (i,j)"
        by (simp add: eq_iff top_matrix_def)
    qed
    have "(minarc\<^sub>M f)\<^sup>t \<odot> mtop \<odot> ((minarc\<^sub>M f)\<^sup>t \<odot> mtop)\<^sup>t = (minarc\<^sub>M f)\<^sup>t \<odot> mtop \<odot> (minarc\<^sub>M f)"
      by (metis matrix_stone_relation_algebra.comp_associative matrix_stone_relation_algebra.conv_dist_comp matrix_stone_relation_algebra.conv_involutive matrix_stone_relation_algebra.conv_top matrix_bounded_idempotent_semiring.surjective_top_closed)
    also have "... \<preceq> mone"
    proof (unfold less_eq_matrix_def, rule allI, rule prod_cases)
      fix i j
      have "((minarc\<^sub>M f)\<^sup>t \<odot> mtop \<odot> minarc\<^sub>M f) (i,j) = (\<Squnion>\<^sub>l (\<Squnion>\<^sub>k ((minarc\<^sub>M f)\<^sup>t) (i,k) * mtop (k,l)) * (minarc\<^sub>M f) (l,j))"
        by (simp add: times_matrix_def)
      also have "... = (\<Squnion>\<^sub>l (\<Squnion>\<^sub>k ((minarc\<^sub>M f) (k,i))\<^sup>T * top) * (minarc\<^sub>M f) (l,j))"
        by (simp add: top_matrix_def conv_matrix_def)
      also have "... = (\<Squnion>\<^sub>l \<Squnion>\<^sub>k ((minarc\<^sub>M f) (k,i))\<^sup>T * top * (minarc\<^sub>M f) (l,j))"
        by (metis comp_right_dist_sum)
      also have "... = (\<Squnion>\<^sub>l \<Squnion>\<^sub>k if i = j \<and> l = k then ((minarc\<^sub>M f) (k,i))\<^sup>T * top * (minarc\<^sub>M f) (l,j) else bot)"
        apply (rule sup_monoid.sum.cong)
        apply simp
        by (metis (no_types, lifting) comp_left_zero comp_right_zero conv_bot prod.inject minarc_at_most_one)
      also have "... = (if i = j then (\<Squnion>\<^sub>l \<Squnion>\<^sub>k if l = k then ((minarc\<^sub>M f) (k,i))\<^sup>T * top * (minarc\<^sub>M f) (l,j) else bot) else bot)"
        by auto
      also have "... \<le> (if i = j then top else bot)"
        by simp
      also have "... = mone (i,j)"
        by (simp add: one_matrix_def)
      finally show "((minarc\<^sub>M f)\<^sup>t \<odot> mtop \<odot> (minarc\<^sub>M f)) (i,j) \<le> mone (i,j)"
        .
    qed
    finally have 5: "(minarc\<^sub>M f)\<^sup>t \<odot> mtop \<odot> ((minarc\<^sub>M f)\<^sup>t \<odot> mtop)\<^sup>t \<preceq> mone"
      .
    have "mtop \<odot> ((minarc\<^sub>M f)\<^sup>t \<odot> mtop) = mtop"
      using 3 by (metis matrix_monoid.mult_assoc matrix_stone_relation_algebra.conv_dist_comp matrix_stone_relation_algebra.conv_top)
    thus "?at (minarc\<^sub>M f)"
      using 2 3 5 by blast
  qed
next
  fix f g :: "('a,'b) square"
  let ?at = "bounded_distrib_allegory_signature.arc mone times_matrix less_eq_matrix mtop conv_matrix"
  show "?at g \<and> g \<otimes> f \<noteq> mbot \<longrightarrow> sum\<^sub>M (minarc\<^sub>M f \<otimes> f) \<preceq> sum\<^sub>M (g \<otimes> f)"
  proof
    assume 1: "?at g \<and> g \<otimes> f \<noteq> mbot"
    hence 2: "g = \<ominus>\<ominus>g"
      using matrix_stone_relation_algebra.arc_regular by blast
    show "sum\<^sub>M (minarc\<^sub>M f \<otimes> f) \<preceq> sum\<^sub>M (g \<otimes> f)"
    proof (unfold less_eq_matrix_def, rule allI, rule prod_cases)
      fix i j
      from minarc_at_least_one obtain ei ej where 3: "(minarc\<^sub>M f) (ei,ej) = top"
        using 1 by force
      hence 4: "\<forall>k l . \<not>(k = ei \<and> l = ej) \<longrightarrow> (minarc\<^sub>M f) (k,l) = bot"
        by (metis (mono_tags, opaque_lifting) bot.extremum inf.bot_unique prod.inject minarc_at_most_one)
      from agg_matrix_bot obtain di dj where 5: "(g \<otimes> f) (di,dj) \<noteq> bot"
        using 1 by force
      hence 6: "g (di,dj) \<noteq> bot"
        by (metis inf_bot_left inf_matrix_def)
      hence 7: "g (di,dj) = top"
        using 2 by (metis uminus_matrix_def uminus_def)
      hence 8: "(g \<otimes> f) (di,dj) = f (di,dj)"
        by (metis inf_matrix_def inf_top.left_neutral)
      have 9: "\<forall>k l . k \<noteq> di \<longrightarrow> g (k,l) = bot"
      proof (intro allI, rule impI)
        fix k l
        assume 10: "k \<noteq> di"
        have "top * (g (k,l))\<^sup>T = g (di,dj) * top * (g\<^sup>t) (l,k)"
          using 7 by (simp add: conv_matrix_def)
        also have "... \<le> (\<Squnion>\<^sub>n g (di,n) * top) * (g\<^sup>t) (l,k)"
          by (metis comp_inf.ub_sum comp_right_dist_sum)
        also have "... \<le> (\<Squnion>\<^sub>m (\<Squnion>\<^sub>n g (di,n) * top) * (g\<^sup>t) (m,k))"
          by (metis comp_inf.ub_sum)
        also have "... = (g \<odot> mtop \<odot> g\<^sup>t) (di,k)"
          by (simp add: times_matrix_def top_matrix_def)
        also have "... \<le> mone (di,k)"
          using 1 by (metis matrix_stone_relation_algebra.arc_expanded less_eq_matrix_def)
        also have "... = bot"
          apply (unfold one_matrix_def)
          using 10 by auto
        finally have "g (k,l) \<noteq> top"
          using 5 by (metis bot.extremum conv_def inf.bot_unique mult.left_neutral one_def)
        thus "g (k,l) = bot"
          using 2 by (metis uminus_def uminus_matrix_def)
      qed
      have "\<forall>k l . l \<noteq> dj \<longrightarrow> g (k,l) = bot"
      proof (intro allI, rule impI)
        fix k l
        assume 11: "l \<noteq> dj"
        have "(g (k,l))\<^sup>T * top = (g\<^sup>t) (l,k) * top * g (di,dj)"
          using 7 by (simp add: comp_associative conv_matrix_def)
        also have "... \<le> (\<Squnion>\<^sub>n (g\<^sup>t) (l,n) * top) * g (di,dj)"
          by (metis comp_inf.ub_sum comp_right_dist_sum)
        also have "... \<le> (\<Squnion>\<^sub>m (\<Squnion>\<^sub>n (g\<^sup>t) (l,n) * top) * g (m,dj))"
          by (metis comp_inf.ub_sum)
        also have "... = (g\<^sup>t \<odot> mtop \<odot> g) (l,dj)"
          by (simp add: times_matrix_def top_matrix_def)
        also have "... \<le> mone (l,dj)"
          using 1 by (metis matrix_stone_relation_algebra.arc_expanded less_eq_matrix_def)
        also have "... = bot"
          apply (unfold one_matrix_def)
          using 11 by auto
        finally have "g (k,l) \<noteq> top"
          using 5 by (metis bot.extremum comp_right_one conv_def one_def top.extremum_unique)
        thus "g (k,l) = bot"
          using 2 by (metis uminus_def uminus_matrix_def)
      qed
      hence 12: "\<forall>k l . \<not>(k = di \<and> l = dj) \<longrightarrow> (g \<otimes> f) (k,l) = bot"
        using 9 by (metis inf_bot_left inf_matrix_def)
      have "(\<Sum>\<^sub>k \<Sum>\<^sub>l (minarc\<^sub>M f \<otimes> f) (k,l)) = (\<Sum>\<^sub>k \<Sum>\<^sub>l if k = ei \<and> l = ej then (minarc\<^sub>M f \<otimes> f) (k,l) else (minarc\<^sub>M f \<otimes> f) (k,l))"
        by simp
      also have "... = (\<Sum>\<^sub>k \<Sum>\<^sub>l if k = ei \<and> l = ej then (minarc\<^sub>M f \<otimes> f) (k,l) else (minarc\<^sub>M f) (k,l) \<sqinter> f (k,l))"
        by (unfold inf_matrix_def) simp
      also have "... = (\<Sum>\<^sub>k \<Sum>\<^sub>l if k = ei \<and> l = ej then (minarc\<^sub>M f \<otimes> f) (k,l) else bot)"
        apply (rule aggregation.sum_0.cong)
        apply simp
        using 4 by (metis inf_bot_left)
      also have "... = (minarc\<^sub>M f \<otimes> f) (ei,ej) + bot"
        by (unfold agg_delta_2) simp
      also have "... = f (ei,ej) + bot"
        using 3 by (simp add: inf_matrix_def)
      also have "... \<le> (g \<otimes> f) (di,dj) + bot"
        using 3 5 6 7 8 by (metis minarc_matrix_def)
      also have "... = (\<Sum>\<^sub>k \<Sum>\<^sub>l if k = di \<and> l = dj then (g \<otimes> f) (k,l) else bot)"
        by (unfold agg_delta_2) simp
      also have "... = (\<Sum>\<^sub>k \<Sum>\<^sub>l if k = di \<and> l = dj then (g \<otimes> f) (k,l) else (g \<otimes> f) (k,l))"
        apply (rule aggregation.sum_0.cong)
        apply simp
        using 12 by metis
      also have "... = (\<Sum>\<^sub>k \<Sum>\<^sub>l (g \<otimes> f) (k,l))"
        by simp
      finally show "(sum\<^sub>M (minarc\<^sub>M f \<otimes> f)) (i,j) \<le> (sum\<^sub>M (g \<otimes> f)) (i,j)"
        by (simp add: sum_matrix_def)
    qed
  qed
next
  fix f g :: "('a,'b) square"
  let ?h = "hd enum_class.enum"
  show "sum\<^sub>M f \<preceq> sum\<^sub>M g \<or> sum\<^sub>M g \<preceq> sum\<^sub>M f"
  proof (cases "(sum\<^sub>M f) (?h,?h) \<le> (sum\<^sub>M g) (?h,?h)")
    case 1: True
    have "sum\<^sub>M f \<preceq> sum\<^sub>M g"
      apply (unfold less_eq_matrix_def, rule allI, rule prod_cases)
      using 1 by (unfold sum_matrix_def) auto
    thus ?thesis
      by simp
  next
    case False
    hence 2: "(sum\<^sub>M g) (?h,?h) \<le> (sum\<^sub>M f) (?h,?h)"
      by (simp add: linear)
    have "sum\<^sub>M g \<preceq> sum\<^sub>M f"
      apply (unfold less_eq_matrix_def, rule allI, rule prod_cases)
      using 2 by (unfold sum_matrix_def) auto
    thus ?thesis
      by simp
  qed
next
  have "finite { f :: ('a,'b) square . (\<forall>e . regular (f e)) }"
    by (unfold regular_bot_top_2, rule finite_set_of_finite_funs_pred) auto
  thus "finite { f :: ('a,'b) square . matrix_p_algebra.regular f }"
    by (unfold uminus_matrix_def) meson
qed

text \<open>
We show the same for the alternative implementation that stores the result of aggregation in all elements of the matrix.
\<close>

interpretation agg_square_m_algebra_2: m_algebra where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix::('a::enum,'b::linear_aggregation_algebra) square" and top = top_matrix and uminus = uminus_matrix and one = one_matrix and times = times_matrix and conv = conv_matrix and plus = plus_matrix and sum = sum_matrix_2 and minarc = minarc_matrix
proof
  fix f :: "('a,'b) square"
  show "minarc\<^sub>M f \<preceq> \<ominus>\<ominus>f"
    by (simp add: agg_square_m_algebra.minarc_below)
next
  fix f :: "('a,'b) square"
  let ?at = "bounded_distrib_allegory_signature.arc mone times_matrix less_eq_matrix mtop conv_matrix"
  show "f \<noteq> mbot \<longrightarrow> ?at (minarc\<^sub>M f)"
    by (simp add: agg_square_m_algebra.minarc_arc)
next
  fix f g :: "('a,'b) square"
  let ?at = "bounded_distrib_allegory_signature.arc mone times_matrix less_eq_matrix mtop conv_matrix"
  show "?at g \<and> g \<otimes> f \<noteq> mbot \<longrightarrow> sum2\<^sub>M (minarc\<^sub>M f \<otimes> f) \<preceq> sum2\<^sub>M (g \<otimes> f)"
  proof
    let ?h = "hd enum_class.enum"
    assume "?at g \<and> g \<otimes> f \<noteq> mbot"
    hence "sum\<^sub>M (minarc\<^sub>M f \<otimes> f) \<preceq> sum\<^sub>M (g \<otimes> f)"
      by (simp add: agg_square_m_algebra.minarc_min)
    hence "(sum\<^sub>M (minarc\<^sub>M f \<otimes> f)) (?h,?h) \<le> (sum\<^sub>M (g \<otimes> f)) (?h,?h)"
      by (simp add: less_eq_matrix_def)
    thus "sum2\<^sub>M (minarc\<^sub>M f \<otimes> f) \<preceq> sum2\<^sub>M (g \<otimes> f)"
      by (simp add: sum_matrix_def sum_matrix_2_def less_eq_matrix_def)
  qed
next
  fix f g :: "('a,'b) square"
  let ?h = "hd enum_class.enum"
  have "sum\<^sub>M f \<preceq> sum\<^sub>M g \<or> sum\<^sub>M g \<preceq> sum\<^sub>M f"
    by (simp add: agg_square_m_algebra.sum_linear)
  hence "(sum\<^sub>M f) (?h,?h) \<le> (sum\<^sub>M g) (?h,?h) \<or> (sum\<^sub>M g) (?h,?h) \<le> (sum\<^sub>M f) (?h,?h)"
    using less_eq_matrix_def by auto
  thus "sum2\<^sub>M f \<preceq> sum2\<^sub>M g \<or> sum2\<^sub>M g \<preceq> sum2\<^sub>M f"
    by (simp add: sum_matrix_def sum_matrix_2_def less_eq_matrix_def)
next
  show "finite { f :: ('a,'b) square . matrix_p_algebra.regular f }"
    by (simp add: agg_square_m_algebra.finite_regular)
qed

text \<open>
By defining the Kleene star as $\top$ aggregation lattices form a Kleene algebra.
\<close>

class aggregation_kleene_algebra = aggregation_algebra + star +
  assumes star_def [simp]: "x\<^sup>\<star> = top"
begin

subclass stone_kleene_relation_algebra
  apply unfold_locales
  by (simp_all add: inf.assoc le_infI2 inf_sup_distrib1 inf_sup_distrib2)

end

class linear_aggregation_kleene_algebra = linear_aggregation_algebra + star +
  assumes star_def_2 [simp]: "x\<^sup>\<star> = top"
begin

subclass aggregation_kleene_algebra
  apply unfold_locales
  by simp

end

interpretation agg_square_m_kleene_algebra: m_kleene_algebra where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix::('a::enum,'b::linear_aggregation_kleene_algebra) square" and top = top_matrix and uminus = uminus_matrix and one = one_matrix and times = times_matrix and conv = conv_matrix and star = star_matrix and plus = plus_matrix and sum = sum_matrix and minarc = minarc_matrix ..

interpretation agg_square_m_kleene_algebra_2: m_kleene_algebra where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix::('a::enum,'b::linear_aggregation_kleene_algebra) square" and top = top_matrix and uminus = uminus_matrix and one = one_matrix and times = times_matrix and conv = conv_matrix and star = star_matrix and plus = plus_matrix and sum = sum_matrix_2 and minarc = minarc_matrix ..

end


theory ListTools
imports Main
begin

definition is_first :: "'a \<Rightarrow> 'a list \<Rightarrow> bool"
where
  "is_first x u = (\<exists> v. u = [x]@v)"

definition is_last :: "'a \<Rightarrow> 'a list \<Rightarrow> bool"
where
  "is_last x u = (\<exists> v. u = v@[x])"

definition is_prefix :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
where
  "is_prefix u v = (\<exists> w. u@w = v)"

definition is_proper_prefix :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
where
  "is_proper_prefix u v = (\<exists> w. w \<noteq> [] \<and> u@w = v)"

lemma is_prefix_eq_proper_prefix: "is_prefix a b = (a = b \<or> is_proper_prefix a b)"
by (metis append_Nil2 is_prefix_def is_proper_prefix_def)

lemma is_proper_prefix_eq_prefix: "is_proper_prefix a b = (a \<noteq> b \<and> is_prefix a b)"
by (metis append_self_conv is_prefix_eq_proper_prefix is_proper_prefix_def)

definition is_suffix :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
where
  "is_suffix u v = (\<exists> w. w@u = v)"

definition is_proper_suffix :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
where
  "is_proper_suffix u v = (\<exists> w. w \<noteq> [] \<and> w@u = v)"

lemma is_suffix_eq_proper_suffix: "is_suffix a b = (a = b \<or> is_proper_suffix a b)"
by (metis append_Nil is_proper_suffix_def is_suffix_def)

lemma is_proper_suffix_eq_suffix: "is_proper_suffix a b = (a \<noteq> b \<and> is_suffix a b)"
by (metis is_proper_suffix_def is_suffix_eq_proper_suffix self_append_conv2)

lemma is_prefix_unsplit: "is_prefix u a \<Longrightarrow> u @ (drop (length u) a) = a"
  by (metis append_eq_conv_conj is_prefix_def)

lemma le_take_same: "i \<le> j \<Longrightarrow> take j a = take j b \<Longrightarrow> take i a = take i b"
 by (metis min.absorb1 take_take)

lemma is_first_drop_length:
  assumes "k \<le> length a"
  and "k > length u"
  and "v = X#w"
  and "take k a = take k (u@v)"
  shows "is_first X (drop (length u) a)"
proof -
  let ?d = "k - length u"
  from assms have pos_d': "?d > 0" by auto
  from assms have take_d'_v: "take ?d (drop (length u) a) = take ?d v"
    by (metis append_eq_conv_conj drop_take)
  then have "take 1 (drop (length u) a) = take 1 v"
    by (metis One_nat_def Suc_leI le_take_same pos_d')
  then have "take 1 (drop (length u) a) = [X]"
    by (simp add: assms)
  then show ?thesis
    by (metis append_take_drop_id is_first_def)
qed

lemma is_first_cons: "is_first x (y#ys) = (x = y)"
  by (auto simp add: is_first_def)

lemma list_all_pos_neg_ex: "list_all P D \<Longrightarrow> \<not> (list_all Q D) \<Longrightarrow>
       \<exists> k. k < length D \<and> P(D ! k) \<and> \<not>(Q(D ! k))"
using list_all_length by blast

lemma split_list_at: "k < length D \<Longrightarrow> D = (take k D)@[D ! k]@(drop (Suc k) D)"
  by (metis append_Cons append_Nil id_take_nth_drop)

lemma take_eq_take_append: "i \<le> j \<Longrightarrow> j \<le> length a \<Longrightarrow> \<exists> u. take j a = take i a @ u"
  by (metis le_Suc_ex take_add)

lemma is_proper_suffix_length_cmp: "is_proper_suffix a b \<Longrightarrow> length a < length b"
by (metis add_diff_cancel_right' append_Nil append_eq_append_conv
  diff_is_0_eq is_proper_suffix_def leI length_append list.size(3))

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_list_count_nub
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun filter :: "('a => bool) => 'a list => 'a list" where
  "filter p (nil2) = nil2"
| "filter p (cons2 y xs) =
     (if p y then cons2 y (filter p xs) else filter p xs)"

(*fun did not finish the proof*)
function nubBy :: "('a => ('a => bool)) => 'a list => 'a list" where
  "nubBy x (nil2) = nil2"
| "nubBy x (cons2 z xs) =
     cons2 z (nubBy x (filter (% (y2 :: 'a) => (~ ((x z) y2))) xs))"
by pat_completeness auto

fun elem :: "'a => 'a list => bool" where
  "elem x (nil2) = False"
| "elem x (cons2 z xs) = ((z = x) | (elem x xs))"

fun count :: "'a => 'a list => int" where
  "count x (nil2) = 0"
| "count x (cons2 z ys) =
     (if (x = z) then 1 + (count x ys) else count x ys)"

theorem property0 :
  "((elem x xs) ==>
      ((count x (nubBy (% (y :: 'a) => % (z :: 'a) => (y = z)) xs)) =
         1))"
  oops

end


(*<*)
theory Trace
imports Basis
begin

declare Let_def[simp] if_split_asm[split]
(*>*)

section\<open>A trace based model\<close>

text\<open>The only clumsy aspect of the state based model is \<open>safe\<close>: we use a state component to record if the sequence of events
that lead to a state satisfies some property. That is, we simulate a
condition on traces via the state. Unsurprisingly, it is not trivial
to convince oneself that \<open>safe\<close> really has the informal meaning
set out at the beginning of subsection~\ref{sec:formalizing-safety}.
Hence we now describe an alternative, purely trace based model,
similar to Paulson's inductive protocol model~\cite{Paulson-JCS98}.
The events are:
\<close>

datatype event =
  Check_in guest room card | Enter guest room card | Exit guest room

text\<open>Instead of a state, we have a trace, i.e.\ list of events, and
extract the state from the trace:\<close>

consts
  initk :: "room \<Rightarrow> key"

primrec owns :: "event list \<Rightarrow> room \<Rightarrow> guest option" where
"owns [] r = None" |
"owns (e#s) r = (case e of
 Check_in g r' c \<Rightarrow> if r' = r then Some g else owns s r |
 Enter g r' c \<Rightarrow> owns s r |
 Exit g r' \<Rightarrow> owns s r)"

primrec currk :: "event list \<Rightarrow> room \<Rightarrow> key" where
"currk [] r = initk r" |
"currk (e#s) r = (let k = currk s r in
    case e of Check_in g r' c \<Rightarrow> if r' = r then snd c else k
            | Enter g r' c \<Rightarrow> k
            | Exit g r \<Rightarrow> k)"

primrec issued :: "event list \<Rightarrow> key set" where
"issued [] = range initk" |
"issued (e#s) = issued s \<union>
  (case e of Check_in g r c \<Rightarrow> {snd c} | Enter g r c \<Rightarrow> {} | Exit g r \<Rightarrow> {})"

primrec cards :: "event list \<Rightarrow> guest \<Rightarrow> card set" where
"cards [] g = {}" |
"cards (e#s) g = (let C = cards s g in
                    case e of Check_in g' r c \<Rightarrow> if g' = g then insert c C
                                                else C
                            | Enter g r c \<Rightarrow> C
                            | Exit g r \<Rightarrow> C)"

primrec roomk :: "event list \<Rightarrow> room \<Rightarrow> key" where
"roomk [] r = initk r" |
"roomk (e#s) r = (let k = roomk s r in
    case e of Check_in g r' c \<Rightarrow> k
            | Enter g r' (x,y) \<Rightarrow> if r' = r \<^cancel>\<open>\<and> x = k\<close> then y else k
            | Exit g r \<Rightarrow> k)"

primrec isin :: "event list \<Rightarrow> room \<Rightarrow> guest set" where
"isin [] r = {}" |
"isin (e#s) r = (let G = isin s r in
                 case e of Check_in g r c \<Rightarrow> G
                 | Enter g r' c \<Rightarrow> if r' = r then {g} \<union> G else G
                 | Exit g r' \<Rightarrow> if r'=r then G - {g} else G)"

primrec hotel :: "event list \<Rightarrow> bool" where
"hotel []  = True" |
"hotel (e # s) = (hotel s & (case e of
  Check_in g r (k,k') \<Rightarrow> k = currk s r \<and> k' \<notin> issued s |
  Enter g r (k,k') \<Rightarrow> (k,k') : cards s g & (roomk s r : {k, k'}) |
  Exit g r \<Rightarrow> g : isin s r))"

text\<open>Except for @{const initk}, which is completely unspecified,
all these functions are defined by primitive recursion over traces:
@{thm[display]owns.simps}
@{thm[display]currk.simps}
@{thm[display]issued.simps}
@{thm[display]cards.simps}
@{thm[display]roomk.simps}
@{thm[display]isin.simps}

However, not every trace is possible. Function @{const hotel} tells us
which traces correspond to real hotels:
@{thm[display]hotel.simps}
Alternatively we could have followed Paulson~\cite{Paulson-JCS98}
in defining @{const hotel} as an inductive set of traces.
The difference is only slight.

\subsection{Formalizing safety}
\label{sec:FormalSafetyTrace}

The principal advantage of the trace model is the intuitive
specification of safety. Using the auxiliary predicate \<open>no_Check_in\<close>
\<close>

(*<*)abbreviation no_Check_in :: "event list \<Rightarrow> room \<Rightarrow> bool" where(*>*)
"no_Check_in s r \<equiv> \<not>(\<exists>g c. Check_in g r c \<in> set s)"

text\<open>\medskip\noindent we define a trace to be \<open>safe\<^sub>0\<close> for a
room if the card obtained at the last @{const Check_in} was later
actually used to @{const Enter} the room:\<close>

(*<*)definition safe\<^sub>0 :: "event list \<Rightarrow> room \<Rightarrow> bool" where(*>*)
"safe\<^sub>0 s r = (\<exists>s\<^sub>1 s\<^sub>2 s\<^sub>3 g c.
 s = s\<^sub>3 @ [Enter g r c] @ s\<^sub>2 @ [Check_in g r c] @ s\<^sub>1 \<and> no_Check_in (s\<^sub>3 @ s\<^sub>2) r)"

text\<open>\medskip\noindent A trace is \<open>safe\<close> if additionally the room was
empty when it was entered:\<close>

(*<*)definition safe :: "event list \<Rightarrow> room \<Rightarrow> bool" where(*>*)
"safe s r = (\<exists>s\<^sub>1 s\<^sub>2 s\<^sub>3 g c.
 s = s\<^sub>3 @ [Enter g r c] @ s\<^sub>2 @ [Check_in g r c] @ s\<^sub>1 \<and>
 no_Check_in (s\<^sub>3 @ s\<^sub>2) r \<and> isin (s\<^sub>2 @ [Check_in g r c] @ s\<^sub>1) r = {})"

text\<open>\medskip\noindent The two notions of safety are distinguished because,
except for the main theorem, @{const safe\<^sub>0} suffices.

The alert reader may already have wondered why, in contrast to the
state based model, we do not require @{const initk} to be
injective. If @{const initk} is not injective, e.g.\ @{prop"initk
r\<^sub>1 = initk r\<^sub>2"} and @{prop"r\<^sub>1 \<noteq> r\<^sub>2"},
then @{term"[Enter g r\<^sub>2 (initk r\<^sub>1,k), Check_in g
r\<^sub>1 (initk r\<^sub>1,k)]"} is a legal trace and guest \<open>g\<close> ends up in a room he is not the owner of.  However, this is not a
safe trace for room \<open>r\<^sub>2\<close> according to our
definition. This reflects that hotel rooms are not safe until
the first time their owner has entered them. We no longer protect the
hotel from its guests.\<close>

(* state thm w/o "isin"
hotel s ==> s = Enter g # s' \<Longrightarrow> owns s' r = Some g \<or> s' = s1 @ Checkin g @ s2 \<and>
no checkin, no enter in s1

*)

(*<*)
lemma safe_safe: "safe s r \<Longrightarrow> safe\<^sub>0 s r"
by (simp add: safe\<^sub>0_def safe_def) blast

lemma initk_issued[simp]: "hotel s \<Longrightarrow> initk r \<in> issued s"
by (induct s) (auto split:event.split)

lemma currk_issued[simp]: "hotel s \<Longrightarrow> currk s r \<in> issued s"
by (induct s) (auto split:event.split)

lemma key1_issued[simp]: "hotel s \<Longrightarrow> (k,k') : cards s g \<Longrightarrow> k \<in> issued s"
by (induct s) (auto split:event.split)

lemma key2_issued[simp]: "hotel s \<Longrightarrow> (k,k') : cards s g \<Longrightarrow> k' \<in> issued s"
by (induct s) (auto split:event.split)

lemma roomk_issued[simp]: "hotel s \<Longrightarrow> roomk s r \<in> issued s"
by (induct s) (auto split:event.split)

lemma issued_app: "issued (s @ s') = issued s \<union> issued s'"
apply (induct s) apply (auto split:event.split)
apply (induct s') apply (auto split:event.split)
done

lemma owns_app[simp]: "no_Check_in s\<^sub>2 r \<Longrightarrow> owns (s\<^sub>2 @ s\<^sub>1) r = owns s\<^sub>1 r"
by (induct s\<^sub>2) (auto split:event.split)

lemma currk_app[simp]: "no_Check_in s\<^sub>2 r \<Longrightarrow> currk (s\<^sub>2 @ s\<^sub>1) r = currk s\<^sub>1 r"
by (induct s\<^sub>2) (auto split:event.split)

lemma currk_Check_in:
 "\<lbrakk> hotel (s\<^sub>2 @ Check_in g r (k, k')# s\<^sub>1);
    k' = currk (s\<^sub>2 @ Check_in g r (k, k') # s\<^sub>1) r' \<rbrakk> \<Longrightarrow> r' = r"
by (induct s\<^sub>2) (auto simp: issued_app split:event.splits)

lemma no_checkin_no_newkey:
"\<lbrakk> hotel(s\<^sub>2 @ [Check_in g r (k,k')] @ s\<^sub>1); no_Check_in s\<^sub>2 r \<rbrakk>
 \<Longrightarrow> (k',k'') \<notin> cards (s\<^sub>2 @ Check_in g r (k,k') # s\<^sub>1) g'"
apply(induct s\<^sub>2)
 apply fastforce
apply(fastforce split:event.splits dest: currk_Check_in)
done

lemma guest_key2_disj2[simp]:
"\<lbrakk> hotel s; (k\<^sub>1,k) \<in> cards s g\<^sub>1; (k\<^sub>2,k) \<in> cards s g\<^sub>2 \<rbrakk> \<Longrightarrow> g\<^sub>1=g\<^sub>2"
apply (induct s)
apply(auto split:event.splits)
done

lemma safe_roomk_currk[simp]:
 "hotel s \<Longrightarrow> safe\<^sub>0 s r \<Longrightarrow> roomk s r = currk s r"
apply(clarsimp simp:safe\<^sub>0_def)
apply(hypsubst_thin)
apply(erule rev_mp)+
apply(induct_tac s\<^sub>3)
apply(auto split:event.split)
apply(rename_tac guest ba)
apply(subgoal_tac "(b, ba)
        \<notin> cards ((list @ Enter g r (a, b) # s\<^sub>2) @ Check_in g r (a, b) # s\<^sub>1)
           guest")
apply simp
apply(rule no_checkin_no_newkey) apply simp_all
done

(* A short proof *)
lemma "\<lbrakk> hotel s; safe s r; g \<in> isin s r \<rbrakk> \<Longrightarrow> owns s r = Some g"
apply(clarsimp simp add:safe_def)
apply(hypsubst_thin)
apply(rename_tac g' k k')
apply(erule rev_mp)+
apply(induct_tac s\<^sub>3)
 apply simp
apply (auto split:event.split)
 apply(subgoal_tac
 "safe\<^sub>0 (list @ Enter g' r (k,k') # s\<^sub>2 @ Check_in g' r (k, k') # s\<^sub>1) r")
  prefer 2
  apply(simp add:safe\<^sub>0_def)apply blast
 apply(simp)
 apply(cut_tac s\<^sub>2 = "list @ Enter g' r (k, k') # s\<^sub>2" in no_checkin_no_newkey)
   apply simp
  apply simp
 apply simp
 apply fast
apply(subgoal_tac
 "safe\<^sub>0 (list @ Enter g' r (k,k') # s\<^sub>2 @ Check_in g' r (k, k') # s\<^sub>1) r")
 apply(drule (1) only_owner_enter_normal)
  apply blast
 apply simp
apply(simp add:safe\<^sub>0_def)
apply blast
done

lemma in_set_conv_decomp_firstD:
assumes "P x"
shows "x \<in> set xs \<Longrightarrow>
  \<exists>ys x zs. xs = ys @ x # zs \<and> P x \<and> (\<forall>y \<in> set ys. \<not> P y)"
  (is "_ \<Longrightarrow> \<exists>ys x zs. ?P xs ys x zs")
proof (induct xs)
  case Nil thus ?case by simp
next
  case (Cons a xs)
  show ?case
  proof cases
    assume "x = a \<or> P a" hence "?P (a#xs) [] a xs" using \<open>P x\<close> by auto
    thus ?case by blast
  next
    assume "\<not>(x = a \<or> P a)"
    with assms Cons show ?case by clarsimp (fastforce intro!: Cons_eq_appendI)
  qed
qed

lemma ownsD: "owns s r = Some g \<Longrightarrow>
 \<exists>s\<^sub>1 s\<^sub>2 g c. s = s\<^sub>2 @ [Check_in g r c] @ s\<^sub>1 \<and> no_Check_in s\<^sub>2 r"
apply(induct s)
 apply simp
apply (auto split:event.splits)
apply(rule_tac x = s in exI)
apply(rule_tac x = "[]" in exI)
apply simp
apply(rule_tac x = s\<^sub>1 in exI)
apply simp
apply(rule_tac x = s\<^sub>1 in exI)
apply simp
apply(rule_tac x = s\<^sub>1 in exI)
apply simp
done

lemma no_Check_in_owns[simp]: "no_Check_in s r \<Longrightarrow> owns s r = None"
by (induct s) (auto split:event.split)

theorem Enter_safe:
 "\<lbrakk> hotel(Enter g r c # s); safe\<^sub>0 s r \<rbrakk> \<Longrightarrow> owns s r = Some g"
apply(subgoal_tac "\<exists>s\<^sub>1 s\<^sub>2 g c. s = s\<^sub>2 @ [Check_in g r c] @ s\<^sub>1 \<and> no_Check_in s\<^sub>2 r")
 prefer 2
 apply(simp add:safe\<^sub>0_def)
 apply(elim exE conjE)
 apply(rule_tac x = s\<^sub>1 in exI)
 apply (simp)
apply(elim exE conjE)
apply(cases c)
apply(clarsimp)
apply(erule disjE)
apply (simp add:no_checkin_no_newkey)
apply simp
apply(frule only_owner_enter_normal)
apply assumption
apply simp
apply simp
done

lemma safe_future: "safe\<^sub>0 s r \<Longrightarrow> no_Check_in s' r \<Longrightarrow> safe\<^sub>0 (s' @ s) r"
apply(clarsimp simp:safe\<^sub>0_def)
apply(rule_tac x = s\<^sub>1 in exI)
apply(rule_tac x = s\<^sub>2 in exI)
apply simp
done

corollary Enter_safe_future:
 "\<lbrakk> hotel(Enter g r c # s' @ s); safe\<^sub>0 s r; no_Check_in s' r \<rbrakk>
 \<Longrightarrow> owns s r = Some g"
apply(drule (1) safe_future)
apply(drule (1) Enter_safe)
apply simp
done
(*>*)

text_raw\<open>
  \begin{figure}
  \begin{center}\begin{minipage}{\textwidth}
  \isastyle\isamarkuptrue
\<close>
theorem safe: assumes "hotel s" and "safe s r" and "g \<in> isin s r"
                    shows "owns s r = \<lfloor>g\<rfloor>"
proof -
  { fix s\<^sub>1 s\<^sub>2 s\<^sub>3 g' k k'
    let ?b = "[Enter g' r (k,k')] @ s\<^sub>2 @ [Check_in g' r (k,k')] @ s\<^sub>1"
    let ?s = "s\<^sub>3 @ ?b"
    assume 0: "isin (s\<^sub>2 @ [Check_in g' r (k,k')] @ s\<^sub>1) r = {}"
    have "\<lbrakk> hotel ?s; no_Check_in (s\<^sub>3 @ s\<^sub>2) r; g \<in> isin ?s r \<rbrakk> \<Longrightarrow> g' = g"
    proof(induct s\<^sub>3)
      case Nil thus ?case using 0 by simp
    next
      case (Cons e s\<^sub>3)
      let ?s = "s\<^sub>3 @ ?b" and ?t = "(e \<cdot> s\<^sub>3) @ ?b"
      show ?case
      proof(cases e)
        case [simp]: (Enter g'' r' c)
        show "g' = g"
        proof cases
          assume [simp]: "r' = r"
          show "g' = g"
          proof cases
            assume [simp]: "g'' = g"
            have 1: "hotel ?s" and 2: "c \<in> cards ?s g" using \<open>hotel ?t\<close> by auto
            have 3: "safe ?s r" using \<open>no_Check_in ((e \<cdot> s\<^sub>3) @ s\<^sub>2) r\<close> 0
              by(simp add:safe_def) blast
            obtain k\<^sub>1 k\<^sub>2 where [simp]: "c = (k\<^sub>1,k\<^sub>2)" by force
            have "roomk ?s r = k'"
              using safe_roomk_currk[OF 1 safe_safe[OF 3]]
                \<open>no_Check_in ((e \<cdot> s\<^sub>3) @ s\<^sub>2) r\<close> by auto
            hence "k\<^sub>1 \<noteq> roomk ?s r"
              using no_checkin_no_newkey[where s\<^sub>2 = "s\<^sub>3 @ [Enter g' r (k,k')] @ s\<^sub>2"]
                1 2 \<open>no_Check_in ((e \<cdot> s\<^sub>3) @ s\<^sub>2) r\<close> by auto
            hence "k\<^sub>2 = roomk ?s r" using \<open>hotel ?t\<close> by auto
            with only_owner_enter_normal[OF 1 safe_safe[OF 3]] 2
            have "owns ?t r =  \<lfloor>g\<rfloor>" by auto
            moreover have "owns ?t r = \<lfloor>g'\<rfloor>"
              using \<open>hotel ?t\<close> \<open>no_Check_in ((e \<cdot> s\<^sub>3) @ s\<^sub>2) r\<close> by simp
            ultimately show "g' = g" by simp
          next
            assume "g'' \<noteq> g" thus "g' = g" using Cons by auto
          qed
        next
          assume "r' \<noteq> r" thus "g' = g" using Cons by auto
        qed
      qed (insert Cons, auto)
    qed
  } with assms show "owns s r = \<lfloor>g\<rfloor>" by(auto simp:safe_def)
qed
text_raw\<open>
  \end{minipage}
  \end{center}
  \caption{Isar proof of Theorem~\ref{safe}}\label{fig:proof}
  \end{figure}
\<close>
text\<open>
\subsection{Verifying safety}

Lemma~\ref{state-lemmas} largely carries over after replacing
\mbox{@{prop"s : reach"}} by @{prop"hotel s"} and @{const safe} by
@{const safe\<^sub>0}. Only properties \ref{currk_inj} and
\ref{key1_not_currk} no longer hold because we no longer assume that
@{const roomk} is initially injective.
They are replaced by two somewhat similar properties:
\begin{lemma}\label{trace-lemmas}\mbox{}
\begin{enumerate}
\item @{thm[display,margin=80]currk_Check_in}
\item \label{no_checkin_no_newkey}
  @{thm[display,margin=100] no_checkin_no_newkey}
\end{enumerate}
\end{lemma}
Both are proved by induction on \<open>s\<^sub>2\<close>.
In addition we need some easy structural properties:
\begin{lemma}\label{app-lemmas}
\begin{enumerate}
\item @{thm issued_app}
\item @{thm owns_app}
\item \label{currk_app} @{thm currk_app}
\end{enumerate}
\end{lemma}

The main theorem again correspond closely to its state based
counterpart:
\begin{theorem}\label{safe}
@{thm[mode=IfThen] safe}
\end{theorem}
Let us examine the proof of this theorem to show how it differs from
the state based version. For the core of the proof let
@{prop"s = s\<^sub>3 @ [Enter g' r (k,k')] @ s\<^sub>2 @ [Check_in g' r (k,k')] @ s\<^sub>1"}
and assume
@{prop"isin (s\<^sub>2 @ [Check_in g' r (k,k')] @ s\<^sub>1) r = {}"} (0). By induction on
\<open>s\<^sub>3\<close> we prove
@{prop[display]"\<lbrakk>hotel s; no_Check_in (s\<^sub>3 @ s\<^sub>2) r; g \<in> isin s r \<rbrakk> \<Longrightarrow> g' = g"}
The actual theorem follows by definition of @{const safe}.
The base case of the induction follows from (0). For the induction step let
@{prop"t = (e#s\<^sub>3) @ [Enter g' r (k,k')] @ s\<^sub>2 @ [Check_in g' r (k,k')] @ s\<^sub>1"}.
We assume @{prop"hotel t"}, @{prop"no_Check_in ((e#s\<^sub>3) @ s\<^sub>2) r"},
and @{prop"g \<in> isin s r"}, and show @{prop"g' = g"}.
The proof is by case distinction on the event \<open>e\<close>.
The cases @{const Check_in} and @{const Exit} follow directly from the
induction hypothesis because the set of occupants of \<open>r\<close>
can only decrease. Now we focus on the case @{prop"e = Enter g'' r' c"}.
If @{prop"r' \<noteq> r"} the set of occupants of \<open>r\<close> remains unchanged
and the claim follow directly from the induction hypothesis.
If @{prop"g'' \<noteq> g"} then \<open>g\<close> must already have been in \<open>r\<close>
before the \<open>Enter\<close> event and the claim again follows directly
from the induction hypothesis. Now assume @{prop"r' = r"}
and @{prop"g'' = g"}.
From @{prop"hotel t"} we obtain @{prop"hotel s"} (1) and
@{prop"c \<in> cards s g"} (2), and
from @{prop"no_Check_in (s\<^sub>3 @ s\<^sub>2) r"} and (0)
we obtain @{prop"safe s r"} (3). Let @{prop"c = (k\<^sub>1,k\<^sub>2)"}.
From Lemma~\ref{state-lemmas}.\ref{safe_roomk_currk} and
Lemma~\ref{app-lemmas}.\ref{currk_app} we obtain
\<open>roomk s r = currk s r = k'\<close>.
Hence @{prop"k\<^sub>1 \<noteq> roomk s r"} by
Lemma~\ref{trace-lemmas}.\ref{no_checkin_no_newkey}
using (1), (2) and @{prop"no_Check_in (s\<^sub>3 @ s\<^sub>2) r"}.
Hence @{prop"k\<^sub>2 = roomk s r"} by @{prop"hotel t"}.
With Lemma~\ref{state-lemmas}.\ref{safe_only_owner_enter_normal}
and (1--3) we obtain
@{prop"owns t r =  \<lfloor>g\<rfloor>"}. At the same time we have @{prop"owns t r = \<lfloor>g'\<rfloor>"}
because @{prop"hotel t"} and @{prop"no_Check_in ((e # s\<^sub>3) @ s\<^sub>2) r"}: nobody
has checked in to room \<open>r\<close> after \<open>g'\<close>. Thus the claim
@{prop"g' = g"} follows.

The details of this proof differ from those of Theorem~\ref{safe-state}
but the structure is very similar.

\subsection{Eliminating \isa{isin}}

In the state based approach we needed @{const isin} to express our
safety guarantees. In the presence of traces, we can do away with it
and talk about @{const Enter} events instead. We show that if somebody
enters a safe room, he is the owner:
\begin{theorem}\label{Enter_safe}
@{thm[mode=IfThen] Enter_safe}
\end{theorem}
From @{prop"safe\<^sub>0 s r"} it follows that \<open>s\<close> must be of the form
@{term"s\<^sub>2 @ [Check_in g\<^sub>0 r c'] @ s\<^sub>1"} such that @{prop"no_Check_in s\<^sub>2 r"}.
Let @{prop"c = (x,y)"} and @{prop"c' = (k,k')"}.
By Lemma~\ref{state-lemmas}.\ref{safe_roomk_currk} we have
\<open>roomk s r = currk s r = k'\<close>.
From @{prop"hotel(Enter g r c # s)"} it follows that
@{prop"(x,y) \<in> cards s g"} and @{prop"k' \<in> {x,y}"}.
By Lemma~\ref{trace-lemmas}.\ref{no_checkin_no_newkey}
@{prop"x = k'"} would contradict @{prop"(x,y) \<in> cards s g"}.
Hence @{prop"y = k'"}.
With Lemma~\ref{state-lemmas}.\ref{safe_only_owner_enter_normal}
we obtain @{prop"owns s r = \<lfloor>g\<rfloor>"}.

Having dispensed with @{const isin} we could also eliminate @{const
Exit} to arrive at a model closer to the ones in~\cite{Jackson06}.

Finally one may quibble that all the safety theorems proved so far
assume safety of the room at that point in time when somebody enters
it.  That is, the owner of the room must be sure that once a room is
safe, it stays safe, in order to profit from those safety theorems.
Of course, this is the case as long as nobody else checks in to that room:
\begin{lemma}
@{thm[mode=IfThen]safe_future}
\end{lemma}
It follows easily that Theorem~\ref{Enter_safe} also extends until check-in:
\begin{corollary}
@{thm[mode=IfThen]Enter_safe_future}
\end{corollary}

\subsection{Completeness of @{const safe}}

Having proved correctness of @{const safe}, i.e.\ that safe behaviour
protects against intruders, one may wonder if @{const safe} is
complete, i.e.\ if it covers all safe behaviour, or if it is too
restrictive. It turns out that @{const safe} is incomplete for two
different reasons.  The trivial one is that in case @{const initk} is
injective, every room is protected against intruders right from the
start. That is, @{term"[Check_in g r c]"} will only allow @{term g} to
enter \<open>r\<close> until somebody else checks in to \<open>r\<close>. The
second, more subtle incompleteness is that even if there are previous
owners of a room, it may be safe to enter a room with an old card
\<open>c\<close>: one merely needs to make sure that no other guest checked
in after the check-in where one obtained \<open>c\<close>. However,
formalizing this is not only messy, it is also somewhat pointless:
this liberalization is not something a guest can take advantage of
because there is no (direct) way he can find out which of his cards
meets this criterion. But without this knowledge, the only safe thing
to do is to make sure he has used his latest card. This incompleteness
applies to the state based model as well.
\<close>

(*<*)
end
(*>*)


theory drinker
imports Main
begin

lemma
  fixes n::nat
  shows "(\<Sum>i=(0::nat)..n. i) = n * ( n + 1 ) div 2"
proof (induct n)
  case 0
  have "\<Sum>{(0::nat)..0} = 0" by simp
  also have " (0::nat) = 0 * (0 + 1) div 2" by simp
  finally show ?case .
next
  case (Suc n)
  have "\<Sum> {(0::nat)..Suc n} = \<Sum> {(0::nat)..n} + (Suc n)" by simp
  also have "... = ((n::nat) * ( n + 1 ) div 2) + (Suc n)" by (simp add: Suc.hyps)
  also have "... = ( n * (n + 1) + 2 * (n + 1)) div 2" by simp
  also have "... = (Suc n * (Suc n + 1)) div 2" by simp
  finally show ?case .
qed

qed

(*  = Suc n * (Suc n + 1) div 2
  *)
(*
  Here is another example of classical reasoning:
  the Drinker's Principle says
    that for some person, if he is drunk, everybody else is drunk!

  We first prove a classical part of de-Morgan's law.
*)

lemma de_Morgan:
  assumes "\<not> (\<forall>x. P x)"
  shows "\<exists>x. \<not> P x"
proof-
  assume "\<not> (\<exists>x. \<not> P x)"
  have "\<forall>x. P x"
  proof-
    fix x
    have "P x"
    proof-
      assume "\<not> P x"
      then have "\<exists>x. \<not> P x" ..
      from \<open>\<not> (\<exists>x. \<not> P x)\<close> \<open>\<exists>x. \<not> P x\<close> have False ..

    qed
  qed
  with \<open>\<not> (\<forall>x. P x)\<close> show ?thesis by contradiction
qed

lemma de_Morgan:
  assumes 0 : "\<not> (\<forall>x. P x)"
  shows "\<exists>x. \<not> P x"
proof (rule classical)
  assume "A" "B"
  then have "A\<and>B" ..

  fix x
  assume "\<not> (\<exists>x. \<not> P x)"
  have "False"
  proof cases
    assume "\<not> P x"
    then have "\<exists>x. \<not> P x" ..
    with \<open>\<not> (\<exists>x. \<not> P x)\<close> show ?thesis ..
  next
    assume "P x"
    then have "\<forall>x. P x" by blast
    with \<open>\<not> (\<forall>x. P x)\<close> show ?thesis ..

    proof-
      from this show ?thesis ..

lemma "\<And>Drunk::(Humain\<Rightarrow>bool). \<exists>x. (Drunk x \<longrightarrow> (\<forall>y. Drunk y))"

end