(* Title:      General Refinement Algebras
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>General Refinement Algebras\<close>

theory General_Refinement_Algebras

imports Omega_Algebras

begin

class general_refinement_algebra = left_kleene_algebra + Omega +
  assumes Omega_unfold: "y\<^sup>\<Omega> \<le> 1 \<squnion> y * y\<^sup>\<Omega>"
  assumes Omega_induct: "x \<le> z \<squnion> y * x \<longrightarrow> x \<le> y\<^sup>\<Omega> * z"
begin

lemma Omega_unfold_equal:
  "y\<^sup>\<Omega> = 1 \<squnion> y * y\<^sup>\<Omega>"
  by (smt Omega_induct Omega_unfold sup_right_isotone order.antisym mult_right_isotone mult_1_right)

lemma Omega_sup_1:
  "(x \<squnion> y)\<^sup>\<Omega> = x\<^sup>\<Omega> * (y * x\<^sup>\<Omega>)\<^sup>\<Omega>"
  apply (rule order.antisym)
  apply (smt Omega_induct Omega_unfold_equal sup_assoc sup_commute sup_right_isotone mult_assoc mult_right_dist_sup mult_right_isotone mult_1_right order_refl)
  by (smt Omega_induct Omega_unfold_equal sup_assoc sup_commute mult_assoc mult_left_one mult_right_dist_sup mult_1_right order_refl)

lemma Omega_left_slide:
  "(x * y)\<^sup>\<Omega> * x \<le> x * (y * x)\<^sup>\<Omega>"
proof -
  have "1 \<squnion> y * (x * y)\<^sup>\<Omega> * x \<le> 1 \<squnion> y * x * (1 \<squnion> (y * (x * y)\<^sup>\<Omega>) * x)"
    by (smt Omega_unfold_equal sup_right_isotone mult_assoc mult_left_one mult_left_sub_dist_sup mult_right_dist_sup mult_right_isotone mult_1_right)
  thus ?thesis
    by (smt Omega_induct Omega_unfold_equal le_sup_iff mult_assoc mult_left_one mult_right_dist_sup mult_right_isotone mult_1_right)
qed

end

text \<open>Theorem 50.3\<close>

sublocale general_refinement_algebra < Omega: left_conway_semiring where circ = Omega
  apply unfold_locales
  using Omega_unfold_equal apply simp
  apply (simp add: Omega_left_slide)
  by (simp add: Omega_sup_1)

context general_refinement_algebra
begin

lemma star_below_Omega:
  "x\<^sup>\<star> \<le> x\<^sup>\<Omega>"
  by (metis Omega_induct mult_1_right order_refl star.circ_left_unfold)

lemma star_mult_Omega:
  "x\<^sup>\<Omega> = x\<^sup>\<star> * x\<^sup>\<Omega>"
  by (metis Omega.left_plus_below_circ sup_commute sup_ge1 order.eq_iff star.circ_loop_fixpoint star_left_induct_mult_iff)

lemma Omega_one_greatest:
  "x \<le> 1\<^sup>\<Omega>"
  by (metis Omega_induct sup_bot_left mult_left_one order_refl order_trans zero_right_mult_decreasing)

lemma greatest_left_zero:
  "1\<^sup>\<Omega> * x = 1\<^sup>\<Omega>"
  by (simp add: Omega_one_greatest Omega_induct order.antisym)

proposition circ_right_unfold: "1 \<squnion> x\<^sup>\<Omega> * x = x\<^sup>\<Omega>" nitpick [expect=genuine,card=8] oops
proposition circ_slide: "(x * y)\<^sup>\<Omega> * x = x * (y * x)\<^sup>\<Omega>" nitpick [expect=genuine,card=6] oops
proposition circ_simulate: "z * x \<le> y * z \<Longrightarrow> z * x\<^sup>\<Omega> \<le> y\<^sup>\<Omega> * z" nitpick [expect=genuine,card=6] oops
proposition circ_simulate_right: "z * x \<le> y * z \<squnion> w \<Longrightarrow> z * x\<^sup>\<Omega> \<le> y\<^sup>\<Omega> * (z \<squnion> w * x\<^sup>\<Omega>)" nitpick [expect=genuine,card=6] oops
proposition circ_simulate_right_1: "z * x \<le> y * z \<Longrightarrow> z * x\<^sup>\<Omega> \<le> y\<^sup>\<Omega> * z" nitpick [expect=genuine,card=6] oops
proposition circ_simulate_right_plus: "z * x \<le> y * y\<^sup>\<Omega> * z \<squnion> w \<Longrightarrow> z * x\<^sup>\<Omega> \<le> y\<^sup>\<Omega> * (z \<squnion> w * x\<^sup>\<Omega>)" nitpick [expect=genuine,card=6] oops
proposition circ_simulate_right_plus_1: "z * x \<le> y * y\<^sup>\<Omega> * z \<Longrightarrow> z * x\<^sup>\<Omega> \<le> y\<^sup>\<Omega> * z" nitpick [expect=genuine,card=6] oops
proposition circ_simulate_left_1: "x * z \<le> z * y \<Longrightarrow> x\<^sup>\<Omega> * z \<le> z * y\<^sup>\<Omega> \<squnion> x\<^sup>\<Omega> * bot" oops (* holds in LKA, counterexample exists in GRA *)
proposition circ_simulate_left_plus_1: "x * z \<le> z * y\<^sup>\<Omega> \<Longrightarrow> x\<^sup>\<Omega> * z \<le> z * y\<^sup>\<Omega> \<squnion> x\<^sup>\<Omega> * bot" oops (* holds in LKA, counterexample exists in GRA *)
proposition circ_simulate_absorb: "y * x \<le> x \<Longrightarrow> y\<^sup>\<Omega> * x \<le> x \<squnion> y\<^sup>\<Omega> * bot" nitpick [expect=genuine,card=8] oops (* holds in LKA, counterexample exists in GRA *)

end

class bounded_general_refinement_algebra = general_refinement_algebra + bounded_left_kleene_algebra
begin

lemma Omega_one:
  "1\<^sup>\<Omega> = top"
  by (simp add: Omega_one_greatest order.antisym)

lemma top_left_zero:
  "top * x = top"
  using Omega_one greatest_left_zero by blast

end

sublocale bounded_general_refinement_algebra < Omega: bounded_left_conway_semiring where circ = Omega ..

class left_demonic_refinement_algebra = general_refinement_algebra +
  assumes Omega_isolate: "y\<^sup>\<Omega> \<le> y\<^sup>\<Omega> * bot \<squnion> y\<^sup>\<star>"
begin

lemma Omega_isolate_equal:
  "y\<^sup>\<Omega> = y\<^sup>\<Omega> * bot \<squnion> y\<^sup>\<star>"
  using Omega_isolate order.antisym le_sup_iff star_below_Omega zero_right_mult_decreasing by auto

proposition Omega_sum_unfold_1: "(x \<squnion> y)\<^sup>\<Omega> = y\<^sup>\<Omega> \<squnion> y\<^sup>\<star> * x * (x \<squnion> y)\<^sup>\<Omega>" oops
proposition Omega_sup_3: "(x \<squnion> y)\<^sup>\<Omega> = (x\<^sup>\<star> * y)\<^sup>\<Omega> * x\<^sup>\<Omega>" oops

end

class bounded_left_demonic_refinement_algebra = left_demonic_refinement_algebra + bounded_left_kleene_algebra
begin

proposition Omega_mult: "(x * y)\<^sup>\<Omega> = 1 \<squnion> x * (y * x)\<^sup>\<Omega> * y" oops
proposition Omega_sup: "(x \<squnion> y)\<^sup>\<Omega> = (x\<^sup>\<Omega> * y)\<^sup>\<Omega> * x\<^sup>\<Omega>" oops
proposition Omega_simulate: "z * x \<le> y * z \<Longrightarrow> z * x\<^sup>\<Omega> \<le> y\<^sup>\<Omega> * z" nitpick [expect=genuine,card=6] oops
proposition Omega_separate_2: "y * x \<le> x * (x \<squnion> y) \<Longrightarrow> (x \<squnion> y)\<^sup>\<Omega> = x\<^sup>\<Omega> * y\<^sup>\<Omega>" oops
proposition Omega_circ_simulate_right_plus: "z * x \<le> y * y\<^sup>\<Omega> * z \<squnion> w \<Longrightarrow> z * x\<^sup>\<Omega> \<le> y\<^sup>\<Omega> * (z \<squnion> w * x\<^sup>\<Omega>)" nitpick [expect=genuine,card=6] oops
proposition Omega_circ_simulate_left_plus: "x * z \<le> z * y\<^sup>\<Omega> \<squnion> w \<Longrightarrow> x\<^sup>\<Omega> * z \<le> (z \<squnion> x\<^sup>\<Omega> * w) * y\<^sup>\<Omega>" oops

end

sublocale bounded_left_demonic_refinement_algebra < Omega: bounded_left_conway_semiring where circ = Omega ..

class demonic_refinement_algebra = left_zero_kleene_algebra + left_demonic_refinement_algebra
begin

lemma Omega_mult:
  "(x * y)\<^sup>\<Omega> = 1 \<squnion> x * (y * x)\<^sup>\<Omega> * y"
  by (smt (verit, del_insts) Omega.circ_left_slide Omega_induct Omega_unfold_equal order.eq_iff mult_assoc mult_left_dist_sup mult_1_right)

lemma Omega_sup:
  "(x \<squnion> y)\<^sup>\<Omega> = (x\<^sup>\<Omega> * y)\<^sup>\<Omega> * x\<^sup>\<Omega>"
  by (smt Omega_sup_1 Omega_mult mult_assoc mult_left_dist_sup mult_left_one mult_right_dist_sup mult_1_right)

lemma Omega_simulate:
  "z * x \<le> y * z \<Longrightarrow> z * x\<^sup>\<Omega> \<le> y\<^sup>\<Omega> * z"
  by (smt Omega_induct Omega_unfold_equal sup_right_isotone mult_assoc mult_left_dist_sup mult_left_isotone mult_1_right)

end

text \<open>Theorem 2.4\<close>

sublocale demonic_refinement_algebra < Omega1: itering_1 where circ = Omega
  apply unfold_locales
  apply (simp add: Omega_simulate mult_assoc)
  by (simp add: Omega_simulate)

sublocale demonic_refinement_algebra < Omega1: left_zero_conway_semiring_1 where circ = Omega ..

context demonic_refinement_algebra
begin

lemma Omega_sum_unfold_1:
  "(x \<squnion> y)\<^sup>\<Omega> = y\<^sup>\<Omega> \<squnion> y\<^sup>\<star> * x * (x \<squnion> y)\<^sup>\<Omega>"
  by (smt Omega1.circ_sup_9 Omega.circ_loop_fixpoint Omega_isolate_equal sup_assoc sup_commute mult_assoc mult_left_zero mult_right_dist_sup)

lemma Omega_sup_3:
  "(x \<squnion> y)\<^sup>\<Omega> = (x\<^sup>\<star> * y)\<^sup>\<Omega> * x\<^sup>\<Omega>"
  apply (rule order.antisym)
  apply (metis Omega_sum_unfold_1 Omega_induct eq_refl sup_commute)
  by (simp add: Omega.circ_isotone Omega_sup mult_left_isotone star_below_Omega)

lemma Omega_separate_2:
  "y * x \<le> x * (x \<squnion> y) \<Longrightarrow> (x \<squnion> y)\<^sup>\<Omega> = x\<^sup>\<Omega> * y\<^sup>\<Omega>"
  apply (rule order.antisym)
  apply (smt (verit, del_insts) Omega_induct Omega_sum_unfold_1 sup_right_isotone mult_assoc mult_left_isotone star_mult_Omega star_simulation_left)
  by (simp add: Omega.circ_sub_dist_3)

lemma Omega_circ_simulate_right_plus:
  assumes "z * x \<le> y * y\<^sup>\<Omega> * z \<squnion> w"
    shows "z * x\<^sup>\<Omega> \<le> y\<^sup>\<Omega> * (z \<squnion> w * x\<^sup>\<Omega>)"
proof -
  have "z * x\<^sup>\<Omega> = z \<squnion> z * x * x\<^sup>\<Omega>"
    using Omega1.circ_back_loop_fixpoint Omega1.circ_plus_same sup_commute mult_assoc by auto
  also have "... \<le> y * y\<^sup>\<Omega> * z * x\<^sup>\<Omega> \<squnion> z \<squnion> w * x\<^sup>\<Omega>"
    by (smt assms sup_assoc sup_commute sup_right_isotone le_iff_sup mult_right_dist_sup)
  finally have "z * x\<^sup>\<Omega> \<le> (y * y\<^sup>\<Omega>)\<^sup>\<Omega> * (z \<squnion> w * x\<^sup>\<Omega>)"
    by (smt Omega_induct sup_assoc sup_commute mult_assoc)
  thus ?thesis
    by (simp add: Omega.left_plus_circ)
qed

lemma Omega_circ_simulate_left_plus:
  assumes "x * z \<le> z * y\<^sup>\<Omega> \<squnion> w"
    shows "x\<^sup>\<Omega> * z \<le> (z \<squnion> x\<^sup>\<Omega> * w) * y\<^sup>\<Omega>"
proof -
  have "x * ((z \<squnion> x\<^sup>\<Omega> * w) * y\<^sup>\<Omega>) \<le> (z * y\<^sup>\<Omega> \<squnion> w \<squnion> x * x\<^sup>\<Omega> * w) * y\<^sup>\<Omega>"
    by (smt assms mult_assoc mult_left_dist_sup sup_left_isotone mult_left_isotone)
  also have "... \<le> z * y\<^sup>\<Omega> * y\<^sup>\<Omega> \<squnion> w * y\<^sup>\<Omega> \<squnion> x\<^sup>\<Omega> * w * y\<^sup>\<Omega>"
    by (smt Omega.left_plus_below_circ sup_right_isotone mult_left_isotone mult_right_dist_sup)
  finally have 1: "x * ((z \<squnion> x\<^sup>\<Omega> * w) * y\<^sup>\<Omega>) \<le> (z \<squnion> x\<^sup>\<Omega> * w) * y\<^sup>\<Omega>"
    by (metis Omega.circ_transitive_equal mult_assoc Omega.circ_reflexive sup_assoc le_iff_sup mult_left_one mult_right_dist_sup)
  have "x\<^sup>\<Omega> * z  = x\<^sup>\<Omega> * bot \<squnion> x\<^sup>\<star> * z"
    by (metis Omega_isolate_equal mult_assoc mult_left_zero mult_right_dist_sup)
  also have "... \<le> x\<^sup>\<Omega> * w * y\<^sup>\<Omega> \<squnion> x\<^sup>\<star> * (z \<squnion> x\<^sup>\<Omega> * w) * y\<^sup>\<Omega>"
    by (metis Omega1.circ_back_loop_fixpoint bot_least idempotent_bot_closed le_supI2 mult_isotone mult_left_sub_dist_sup_left semiring.add_mono zero_right_mult_decreasing mult_assoc)
  also have "... \<le> (z \<squnion> x\<^sup>\<Omega> * w) * y\<^sup>\<Omega>"
    using 1 by (metis le_supI mult_right_sub_dist_sup_right star_left_induct_mult mult_assoc)
  finally show ?thesis
    .
qed

lemma Omega_circ_simulate_right:
  assumes "z * x \<le> y * z \<squnion> w"
    shows "z * x\<^sup>\<Omega> \<le> y\<^sup>\<Omega> * (z \<squnion> w * x\<^sup>\<Omega>)"
proof -
  have "y * z \<squnion> w \<le> y * y\<^sup>\<Omega> * z \<squnion> w"
    using Omega.circ_mult_increasing mult_left_isotone sup_left_isotone by auto
  thus ?thesis
    using Omega_circ_simulate_right_plus assms order.trans by blast
qed

end

sublocale demonic_refinement_algebra < Omega: itering where circ = Omega
  apply unfold_locales
  apply (simp add: Omega_sup)
  using Omega_mult apply blast
  apply (simp add: Omega_circ_simulate_right_plus)
  using Omega_circ_simulate_left_plus by auto

class bounded_demonic_refinement_algebra = demonic_refinement_algebra + bounded_left_zero_kleene_algebra
begin

lemma Omega_one:
  "1\<^sup>\<Omega> = top"
  by (simp add: Omega_one_greatest order.antisym)

lemma top_left_zero:
  "top * x = top"
  using Omega_one greatest_left_zero by auto

end

sublocale bounded_demonic_refinement_algebra < Omega: bounded_itering where circ = Omega ..

class general_refinement_algebra_omega = left_omega_algebra + Omega +
  assumes omega_left_zero: "x\<^sup>\<omega> \<le> x\<^sup>\<omega> * y"
  assumes Omega_def: "x\<^sup>\<Omega> = x\<^sup>\<omega> \<squnion> x\<^sup>\<star>"
begin

lemma omega_left_zero_equal:
  "x\<^sup>\<omega> * y = x\<^sup>\<omega>"
  by (simp add: order.antisym omega_left_zero omega_sub_vector)

subclass left_demonic_refinement_algebra
  apply unfold_locales
  apply (metis Omega_def sup_commute eq_refl mult_1_right omega_loop_fixpoint)
  apply (metis Omega_def mult_right_dist_sup omega_induct omega_left_zero_equal)
  by (metis Omega_def mult_right_sub_dist_sup_right sup_commute sup_right_isotone omega_left_zero_equal)

end

class left_demonic_refinement_algebra_omega = bounded_left_omega_algebra + Omega +
  assumes top_left_zero: "top * x = top"
  assumes Omega_def: "x\<^sup>\<Omega> = x\<^sup>\<omega> \<squnion> x\<^sup>\<star>"
begin

subclass general_refinement_algebra_omega
  apply unfold_locales
  apply (metis mult_assoc omega_vector order_refl top_left_zero)
  by (rule Omega_def)

end

class demonic_refinement_algebra_omega = left_demonic_refinement_algebra_omega + bounded_left_zero_omega_algebra
begin

lemma Omega_mult:
  "(x * y)\<^sup>\<Omega> = 1 \<squnion> x * (y * x)\<^sup>\<Omega> * y"
  by (metis Omega_def comb1.circ_mult_1 omega_left_zero_equal omega_translate)

lemma Omega_sup:
  "(x \<squnion> y)\<^sup>\<Omega> = (x\<^sup>\<Omega> * y)\<^sup>\<Omega> * x\<^sup>\<Omega>"
proof -
  have "(x\<^sup>\<Omega> * y)\<^sup>\<Omega> * x\<^sup>\<Omega> = (x\<^sup>\<star> * y)\<^sup>\<star> * x\<^sup>\<omega> \<squnion> (x\<^sup>\<star> * y)\<^sup>\<omega> \<squnion> (x\<^sup>\<star> * y)\<^sup>\<star> * x\<^sup>\<omega>\<^sup>\<star> * x\<^sup>\<Omega>"
    by (smt sup_commute Omega_def mult_assoc mult_right_dist_sup mult_bot_add_omega omega_left_zero_equal star.circ_sup_1)
  thus ?thesis
    using Omega_def Omega_sup_1 comb2.circ_slide_1 omega_left_zero_equal by auto
qed

lemma Omega_simulate:
  "z * x \<le> y * z \<Longrightarrow> z * x\<^sup>\<Omega> \<le> y\<^sup>\<Omega> * z"
  using Omega_def comb2.circ_simulate omega_left_zero_equal by auto

subclass demonic_refinement_algebra ..

end

(* hold in GRA and LKA *)
proposition circ_circ_mult: "1\<^sup>\<Omega> * x\<^sup>\<Omega> = x\<^sup>\<Omega>\<^sup>\<Omega>" oops
proposition sub_mult_one_circ: "x * 1\<^sup>\<Omega> \<le> 1\<^sup>\<Omega> * x" oops
proposition circ_circ_mult_1: "x\<^sup>\<Omega> * 1\<^sup>\<Omega> = x\<^sup>\<Omega>\<^sup>\<Omega>" oops
proposition "y * x \<le> x \<Longrightarrow> y\<^sup>\<circ> * x \<le> 1\<^sup>\<circ> * x" oops

(* unknown *)
proposition circ_simulate_2: "y * x\<^sup>\<Omega> \<le> x\<^sup>\<Omega> * y\<^sup>\<Omega> \<longleftrightarrow> y\<^sup>\<Omega> * x\<^sup>\<Omega> \<le> x\<^sup>\<Omega> * y\<^sup>\<Omega>" oops (* holds in LKA *)
proposition circ_simulate_3: "y * x\<^sup>\<Omega> \<le> x\<^sup>\<Omega> \<Longrightarrow> y\<^sup>\<Omega> * x\<^sup>\<Omega> \<le> x\<^sup>\<Omega> * y\<^sup>\<Omega>" oops (* holds in LKA *)
proposition circ_separate_mult_1: "y * x \<le> x * y \<Longrightarrow> (x * y)\<^sup>\<Omega> \<le> x\<^sup>\<Omega> * y\<^sup>\<Omega>" oops
proposition "x\<^sup>\<circ> = (x * x)\<^sup>\<circ> * (x \<squnion> 1)" oops
proposition "y\<^sup>\<circ> * x\<^sup>\<circ> \<le> x\<^sup>\<circ> * y\<^sup>\<circ> \<Longrightarrow> (x \<squnion> y)\<^sup>\<circ> = x\<^sup>\<circ> * y\<^sup>\<circ>" oops
proposition "y * x \<le> (1 \<squnion> x) * y\<^sup>\<circ> \<Longrightarrow> (x \<squnion> y)\<^sup>\<circ> = x\<^sup>\<circ> * y\<^sup>\<circ>" oops

end


(* 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{Guttmann2018a}.
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 inf.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: 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, hide_lams) 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


(*  Title:      CTT/ex/Equality.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1991  University of Cambridge
*)

section "Equality reasoning by rewriting"

theory Equality
  imports "../CTT"
begin

lemma split_eq: "p : Sum(A,B) \<Longrightarrow> split(p,pair) = p : Sum(A,B)"
  apply (rule EqE)
  apply (rule elim_rls, assumption)
  apply rew
  done

lemma when_eq: "\<lbrakk>A type; B type; p : A+B\<rbrakk> \<Longrightarrow> when(p,inl,inr) = p : A + B"
  apply (rule EqE)
  apply (rule elim_rls, assumption)
   apply rew
  done

text \<open>in the "rec" formulation of addition, $0+n=n$\<close>
lemma "p:N \<Longrightarrow> rec(p,0, \<lambda>y z. succ(y)) = p : N"
  apply (rule EqE)
  apply (rule elim_rls, assumption)
   apply rew
  done

text \<open>the harder version, $n+0=n$: recursive, uses induction hypothesis\<close>
lemma "p:N \<Longrightarrow> rec(p,0, \<lambda>y z. succ(z)) = p : N"
  apply (rule EqE)
  apply (rule elim_rls, assumption)
   apply hyp_rew
  done

text \<open>Associativity of addition\<close>
lemma "\<lbrakk>a:N; b:N; c:N\<rbrakk>
  \<Longrightarrow> rec(rec(a, b, \<lambda>x y. succ(y)), c, \<lambda>x y. succ(y)) =
    rec(a, rec(b, c, \<lambda>x y. succ(y)), \<lambda>x y. succ(y)) : N"
  apply (NE a)
    apply hyp_rew
  done

text \<open>Martin-Löf (1984) page 62: pairing is surjective\<close>
lemma "p : Sum(A,B) \<Longrightarrow> <split(p,\<lambda>x y. x), split(p,\<lambda>x y. y)> = p : Sum(A,B)"
  apply (rule EqE)
  apply (rule elim_rls, assumption)
  apply (tactic \<open>DEPTH_SOLVE_1 (rew_tac \<^context> [])\<close>) (*!!!!!!!*)
  done

lemma "\<lbrakk>a : A; b : B\<rbrakk> \<Longrightarrow> (\<^bold>\<lambda>u. split(u, \<lambda>v w.<w,v>)) ` <a,b> = <b,a> : \<Sum>x:B. A"
  by rew

text \<open>a contrived, complicated simplication, requires sum-elimination also\<close>
lemma "(\<^bold>\<lambda>f. \<^bold>\<lambda>x. f`(f`x)) ` (\<^bold>\<lambda>u. split(u, \<lambda>v w.<w,v>)) =
      \<^bold>\<lambda>x. x  :  \<Prod>x:(\<Sum>y:N. N). (\<Sum>y:N. N)"
  apply (rule reduction_rls)
    apply (rule_tac [3] intrL_rls)
     apply (rule_tac [4] EqE)
     apply (erule_tac [4] SumE)
    (*order of unifiers is essential here*)
     apply rew
  done

end


(*  Title:      HOL/Library/Function_Division.thy
    Author:     Florian Haftmann, TUM
*)

section {* Pointwise instantiation of functions to division *}

theory Function_Division
imports Function_Algebras
begin

subsection {* Syntactic with division *}

instantiation "fun" :: (type, inverse) inverse
begin

definition "inverse f = inverse \<circ> f"

definition "(f / g) = (\<lambda>x. f x / g x)"

instance ..

end

lemma inverse_fun_apply [simp]:
  "inverse f x = inverse (f x)"
  by (simp add: inverse_fun_def)

lemma divide_fun_apply [simp]:
  "(f / g) x = f x / g x"
  by (simp add: divide_fun_def)

text {*
  Unfortunately, we cannot lift this operations to algebraic type
  classes for division: being different from the constant
  zero function @{term "f \<noteq> 0"} is too weak as precondition.
  So we must introduce our own set of lemmas.
*}

abbreviation zero_free :: "('b \<Rightarrow> 'a::field) \<Rightarrow> bool" where
  "zero_free f \<equiv> \<not> (\<exists>x. f x = 0)"

lemma fun_left_inverse:
  fixes f :: "'b \<Rightarrow> 'a::field"
  shows "zero_free f \<Longrightarrow> inverse f * f = 1"
  by (simp add: fun_eq_iff)

lemma fun_right_inverse:
  fixes f :: "'b \<Rightarrow> 'a::field"
  shows "zero_free f \<Longrightarrow> f * inverse f = 1"
  by (simp add: fun_eq_iff)

lemma fun_divide_inverse:
  fixes f g :: "'b \<Rightarrow> 'a::field"
  shows "f / g = f * inverse g"
  by (simp add: fun_eq_iff divide_inverse)

text {* Feel free to extend this. *}

text {*
  Another possibility would be a reformulation of the division type
  classes to user a @{term zero_free} predicate rather than
  a direct @{term "a \<noteq> 0"} condition.
*}

end


theory Bin_Search
imports "../sepref/IICF/IICF" "List-Index.List_Index"
begin
  (* TODO: Move to Find-Index. DONE, see AFP-4943a3cb91e3 *)
  lemma find_index_conv_takeWhile: "find_index P xs = size(takeWhile (Not o P) xs)"
    by(induct xs) auto

  lemma find_index_first: "i < find_index P xs \<Longrightarrow> \<not>P (xs!i)"
    unfolding find_index_conv_takeWhile
    using takeWhile_take_has_property_nth by fastforce

  lemma index_first: "i<index xs x \<Longrightarrow> x\<noteq>xs!i"
    using find_index_first unfolding index_def by blast

  lemma find_index_append: "find_index P (xs @ ys) =
    (if \<exists>x\<in>set xs. P x then find_index P xs else size xs + find_index P ys)"
    by (induct xs) simp_all

  lemma find_index_eqI:
    assumes "i\<le>length xs"
    assumes "\<forall>j<i. \<not>P (xs!j)"
    assumes "i<length xs \<Longrightarrow> P (xs!i)"
    shows "find_index P xs = i"
    by (metis (mono_tags, lifting) antisym_conv2 assms find_index_eq_size_conv find_index_first find_index_less_size_conv linorder_neqE_nat nth_find_index)

  lemma find_index_eq_iff:
    "find_index P xs = i \<longleftrightarrow> (i\<le>length xs \<and> (\<forall>j<i. \<not>P (xs!j)) \<and> (i<length xs \<longrightarrow> P (xs!i)))"
    by (auto intro: find_index_eqI simp: nth_find_index find_index_le_size find_index_first)

  lemma index_eqI:
    assumes "i\<le>length xs"
    assumes "\<forall>j<i. xs!j \<noteq> x"
    assumes "i<length xs \<Longrightarrow> xs!i = x"
    shows "index xs x = i"
    unfolding index_def by (simp add: find_index_eqI assms)

  lemma index_eq_iff:
    "index xs x = i \<longleftrightarrow> (i\<le>length xs \<and> (\<forall>j<i. xs!j \<noteq> x) \<and> (i<length xs \<longrightarrow> xs!i = x))"
    by (auto intro: index_eqI simp: index_le_size index_less_size_conv dest: index_first)

  subsection \<open>Binary Search\<close>

  subsubsection \<open>Abstract Algorithm\<close>

  abbreviation "bin_search_invar xs x \<equiv> (\<lambda>(l,h).
        0\<le>l \<and> l\<le>h \<and> h\<le>length xs
      \<and> (\<forall>i<l. xs!i<x) \<and> (\<forall>i\<in>{h..<length xs}. x \<le> xs!i))"

  definition "bin_search xs x \<equiv> do {
    (l,h) \<leftarrow> WHILEIT (bin_search_invar xs x)
      (\<lambda>(l,h). l<h)
      (\<lambda>(l,h). do {
        ASSERT (l<length xs \<and> h\<le>length xs \<and> l\<le>h);
        let m = l + (h-l) div 2;
        if xs!m < x then RETURN (m+1,h) else RETURN (l,m)
      })
      (0,length xs);
    RETURN l
  }"

  definition "fi_spec xs x = SPEC (\<lambda>i. i=find_index (\<lambda>y. x\<le>y) xs)"

  lemma bin_search_correct:
    assumes "sorted xs"
    shows "bin_search xs x \<le> SPEC (\<lambda>i. i=find_index (\<lambda>y. x\<le>y) xs)"
    unfolding bin_search_def
    apply (refine_vcg WHILEIT_rule[where R="measure (\<lambda>(l,h). h-l)"])
    apply (all \<open>(auto;fail)?\<close>)

    apply (clarsimp simp: less_Suc_eq_le)
    subgoal for l h i
      apply (frule sorted_nth_mono[OF assms, of i "l + (h-l) div 2"])
      by auto
    subgoal by clarsimp (meson assms leI le_less_trans sorted_iff_nth_mono)

    apply clarsimp
    subgoal for i
      by (simp add: find_index_eqI less_le_not_le)

    done

  lemma bin_search_correct': "(uncurry bin_search,uncurry fi_spec)
    \<in>[\<lambda>(xs,_). sorted xs]\<^sub>f Id \<times>\<^sub>r Id \<rightarrow> \<langle>nat_rel\<rangle>nres_rel"
    using bin_search_correct unfolding fi_spec_def
    by (fastforce intro!: frefI nres_relI)

  subsubsection \<open>Implementation\<close>

  type_synonym size_t = 64
  type_synonym elem_t = 64

  lemma rdomp_larray_imp_len_bound:
    "rdomp (larray_assn' TYPE('a::len2) A) xs \<Longrightarrow> length xs < max_snat LENGTH('a)"
    unfolding larray_assn_def raw_larray_assn_def larray1_rel_def
    apply (auto simp: rdomp_hrcomp_conv in_br_conv snat_rel_def snat.rel_def)
    by (simp add: list_rel_pres_length)

  sepref_definition bin_search_impl [llvm_code] is "uncurry bin_search"
    :: "(larray_assn' TYPE(size_t) (sint_assn' TYPE(elem_t)))\<^sup>k
        *\<^sub>a (sint_assn' TYPE(elem_t))\<^sup>k
       \<rightarrow>\<^sub>a snat_assn' TYPE(size_t)"
    unfolding bin_search_def
    apply (rule hfref_with_rdomI)
    apply (annot_snat_const "TYPE(size_t)")
    supply rdomp_larray_imp_len_bound[dest]
    supply [simp] = max_snat_def
    apply sepref
    done

  export_llvm bin_search_impl is bin_search file "code/bin_search.ll"
  lemmas bs_impl_correct = bin_search_impl.refine[FCOMP bin_search_correct']

  subsubsection \<open>Combined Correctness Theorem\<close>

  theorem bin_search_impl_correct:
    "llvm_htriple
      (larray_assn sint_assn xs xsi ** sint_assn x xi ** \<up>(sorted xs))
      (bin_search_impl xsi xi)
      (\<lambda>ii. EXS i. larray_assn sint_assn xs xsi ** sint_assn x xi ** snat_assn i ii
                  ** \<up>(i=find_index (\<lambda>y. x\<le>y) xs))"
  proof -

    from bin_search_correct have R:
        "(uncurry bin_search, uncurry (\<lambda>xs x. SPEC (\<lambda>i. i = find_index ((\<le>) x) xs)))
      \<in> [\<lambda>(xs,x). sorted xs]\<^sub>f Id \<rightarrow> \<langle>Id\<rangle>nres_rel"
      apply (intro frefI nres_relI)
      apply fastforce
      done

    note bin_search_impl.refine
    note R = bin_search_impl.refine[FCOMP R]
    note R = R[THEN hfrefD, THEN hn_refineD, of "(xs,x)" "(xsi,xi)", simplified]
    note [vcg_rules] = R

    show ?thesis by vcg'
  qed

end


(*
    Author:     Wenda Li <wl302@cam.ac.uk / liwenda1990@hotmail.com>
*)
section \<open>Extra lemmas related to polynomials\<close>

theory CC_Polynomials_Extra imports
  Winding_Number_Eval.Missing_Algebraic
  Winding_Number_Eval.Missing_Transcendental
  Sturm_Tarski.PolyMisc
  Budan_Fourier.BF_Misc
  "Polynomial_Interpolation.Ring_Hom_Poly" (*Move to the standard distribution?*)
begin

subsection \<open>Misc\<close>

lemma poly_linepath_comp':
  fixes a::"'a::{real_normed_vector,comm_semiring_0,real_algebra_1}"
  shows "poly p (linepath a b t) = poly (p \<circ>\<^sub>p [:a, b-a:]) (of_real t)"
  by (auto simp add:poly_pcompose linepath_def scaleR_conv_of_real algebra_simps)

lemma path_poly_comp[intro]:
  fixes p::"'a::real_normed_field poly"
  shows "path g \<Longrightarrow> path (poly p o g)"
  apply (elim path_continuous_image)
  by (auto intro:continuous_intros)

lemma cindex_poly_noroot:
  assumes "a<b" "\<forall>x. a<x \<and> x<b \<longrightarrow> poly p x\<noteq>0"
  shows "cindex_poly a b q p = 0"
  unfolding cindex_poly_def
  apply (rule sum.neutral)
  using assms by (auto intro:jump_poly_not_root)

subsection \<open>More polynomial homomorphism interpretations\<close>

interpretation of_real_poly_hom:map_poly_inj_idom_hom of_real ..

interpretation Re_poly_hom:map_poly_comm_monoid_add_hom Re
  by unfold_locales simp_all

interpretation Im_poly_hom:map_poly_comm_monoid_add_hom Im
  by unfold_locales simp_all

subsection \<open>More about @{term order}\<close>

lemma order_normalize[simp]:"order x (normalize p) = order x p"
  by (metis dvd_normalize_iff normalize_eq_0_iff order_1 order_2 order_unique_lemma)

lemma order_gcd:
  assumes "p\<noteq>0" "q\<noteq>0"
  shows "order x (gcd p q) = min (order x p) (order x q)"
proof -
  define xx op oq where "xx=[:- x, 1:]" and "op = order x p" and "oq = order x q"
  obtain pp where pp:"p = xx ^ op * pp" "\<not> xx dvd pp"
    using order_decomp[OF \<open>p\<noteq>0\<close>,of x,folded xx_def op_def] by auto
  obtain qq where qq:"q = xx ^ oq * qq" "\<not> xx dvd qq"
    using order_decomp[OF \<open>q\<noteq>0\<close>,of x,folded xx_def oq_def] by auto
  define pq where "pq = gcd pp qq"

  have p_unfold:"p = (pq * xx ^ (min op oq)) * ((pp div pq) * xx ^ (op - min op oq))"
        and [simp]:"coprime xx (pp div pq)" and "pp\<noteq>0"
  proof -
    have "xx ^ op = xx ^ (min op oq) * xx ^ (op - min op oq)"
      by (simp flip:power_add)
    moreover have "pp = pq * (pp div pq)"
      unfolding pq_def by simp
    ultimately show "p = (pq * xx ^ (min op oq)) * ((pp div pq) * xx ^ (op - min op oq))"
      unfolding pq_def pp by(auto simp:algebra_simps)
    show "coprime xx (pp div pq)"
      apply (rule prime_elem_imp_coprime[OF
                    prime_elem_linear_poly[of 1 "-x",simplified],folded xx_def])
      using \<open>pp = pq * (pp div pq)\<close> pp(2) by auto
  qed (use pp \<open>p\<noteq>0\<close> in auto)
  have q_unfold:"q = (pq * xx ^ (min op oq)) * ((qq div pq) * xx ^ (oq - min op oq))"
         and [simp]:"coprime xx (qq div pq)"
  proof -
    have "xx ^ oq = xx ^ (min op oq) * xx ^ (oq - min op oq)"
      by (simp flip:power_add)
    moreover have "qq = pq * (qq div pq)"
      unfolding pq_def by simp
    ultimately show "q = (pq * xx ^ (min op oq)) * ((qq div pq) * xx ^ (oq - min op oq))"
      unfolding pq_def qq by(auto simp:algebra_simps)
    show "coprime xx (qq div pq)"
      apply (rule prime_elem_imp_coprime[OF
                    prime_elem_linear_poly[of 1 "-x",simplified],folded xx_def])
      using \<open>qq = pq * (qq div pq)\<close> qq(2) by auto
  qed

  have "gcd p q=normalize (pq * xx ^ (min op oq))"
  proof -
    have "coprime (pp div pq * xx ^ (op - min op oq)) (qq div pq * xx ^ (oq - min op oq))"
    proof (cases "op>oq")
      case True
      then have "oq - min op oq = 0" by auto
      moreover have "coprime (xx ^ (op - min op oq)) (qq div pq)" by auto
      moreover have "coprime (pp div pq) (qq div pq)"
        apply (rule div_gcd_coprime[of pp qq,folded pq_def])
        using \<open>pp\<noteq>0\<close> by auto
      ultimately show ?thesis by auto
    next
      case False
      then have "op - min op oq = 0" by auto
      moreover have "coprime (pp div pq) (xx ^ (oq - min op oq))"
        by (auto simp:coprime_commute)
      moreover have "coprime (pp div pq) (qq div pq)"
        apply (rule div_gcd_coprime[of pp qq,folded pq_def])
        using \<open>pp\<noteq>0\<close> by auto
      ultimately show ?thesis by auto
    qed
    then show ?thesis unfolding p_unfold q_unfold
      apply (subst gcd_mult_left)
      by auto
  qed
  then have "order x (gcd p q) = order x pq + order x (xx ^ (min op oq))"
    apply simp
    apply (subst order_mult)
    using assms(1) p_unfold by auto
  also have "... = order x (xx ^ (min op oq))"
    using pp(2) qq(2) unfolding pq_def xx_def
    by (auto simp add: order_0I poly_eq_0_iff_dvd)
  also have "... = min op oq"
    unfolding xx_def by (rule order_power_n_n)
  also have "... = min (order x p) (order x q)" unfolding op_def oq_def by simp
  finally show ?thesis .
qed

lemma pderiv_power: "pderiv (p ^ n) = smult (of_nat n) (p ^ (n-1)) * pderiv p"
  apply (cases n)
  using pderiv_power_Suc by auto

(*TODO: to replace the one (with the same name) in the library, as this version does
  not require 'a to be a field?*)
lemma order_pderiv:
  fixes p::"'a::{idom,semiring_char_0} poly"
  assumes "p\<noteq>0" "poly p x=0"
  shows "order x p = Suc (order x (pderiv p))" using assms
proof -
  define xx op where "xx=[:- x, 1:]" and "op = order x p"
  have "op \<noteq>0" unfolding op_def using assms order_root by blast
  obtain pp where pp:"p = xx ^ op * pp" "\<not> xx dvd pp"
    using order_decomp[OF \<open>p\<noteq>0\<close>,of x,folded xx_def op_def] by auto
  have p_der:"pderiv p = smult (of_nat op) (xx^(op -1)) * pp + xx^op*pderiv pp"
    unfolding pp(1) by (auto simp:pderiv_mult pderiv_power xx_def algebra_simps pderiv_pCons)
  have "xx^(op -1) dvd (pderiv p)"
    unfolding p_der
    by (metis One_nat_def Suc_pred assms(1) assms(2) dvd_add dvd_mult_right dvd_triv_left
        neq0_conv op_def order_root power_Suc smult_dvd_cancel)
  moreover have "\<not> xx^op dvd (pderiv p)"
  proof
    assume "xx ^ op dvd pderiv p"
    then have "xx ^ op dvd smult (of_nat op) (xx^(op -1) * pp)"
      unfolding p_der by (simp add: dvd_add_left_iff)
    then have "xx ^ op dvd (xx^(op -1)) * pp"
      apply (elim dvd_monic[rotated])
      using \<open>op\<noteq>0\<close> by (auto simp:lead_coeff_power xx_def)
    then have "xx ^ (op-1) * xx dvd (xx^(op -1))"
      using \<open>\<not> xx dvd pp\<close> by (simp add: \<open>op \<noteq> 0\<close> mult.commute power_eq_if)
    then have "xx dvd 1"
      using assms(1) pp(1) by auto
    then show False unfolding xx_def by (meson assms(1) dvd_trans one_dvd order_decomp)
  qed
  ultimately have "op - 1 = order x (pderiv p)"
    using order_unique_lemma[of x "op-1" "pderiv p",folded xx_def] \<open>op\<noteq>0\<close>
    by auto
  then show ?thesis using \<open>op\<noteq>0\<close> unfolding op_def by auto
qed

subsection \<open>More about @{term rsquarefree}\<close>

lemma rsquarefree_0[simp]: "\<not> rsquarefree 0"
  unfolding rsquarefree_def by simp

lemma rsquarefree_times:
  assumes "rsquarefree (p*q)"
  shows "rsquarefree q" using assms
proof (induct p rule:poly_root_induct_alt)
  case 0
  then show ?case by simp
next
  case (no_proots p)
  then have [simp]:"p\<noteq>0" "q\<noteq>0" "\<And>a. order a p = 0"
    using order_0I by auto
  have "order a (p * q) = 0 \<longleftrightarrow> order a q = 0"
       "order a (p * q) = 1 \<longleftrightarrow> order a q = 1"
       for a
    subgoal by (subst order_mult) auto
    subgoal by (subst order_mult) auto
    done
  then show ?case using \<open>rsquarefree (p * q)\<close>
    unfolding rsquarefree_def by simp
next
  case (root a p)
  define pq aa where "pq = p * q" and "aa = [:- a, 1:]"
  have [simp]:"pq\<noteq>0" "aa\<noteq>0" "order a aa=1"
    subgoal using pq_def root.prems by auto
    subgoal by (simp add: aa_def)
    subgoal by (metis aa_def order_power_n_n power_one_right)
    done
  have "rsquarefree (aa * pq)"
    unfolding aa_def pq_def using root(2) by (simp add:algebra_simps)
  then have "rsquarefree pq"
    unfolding rsquarefree_def by (auto simp add:order_mult)
  from root(1)[OF this[unfolded pq_def]] show ?case .
qed

lemma rsquarefree_smult_iff:
  assumes "s\<noteq>0"
  shows "rsquarefree (smult s p) \<longleftrightarrow> rsquarefree p"
  unfolding rsquarefree_def using assms by (auto simp add:order_smult)

lemma card_proots_within_rsquarefree:
  assumes "rsquarefree p"
  shows "proots_count p s = card (proots_within p s)" using assms
proof (induct rule:poly_root_induct[of _ "\<lambda>x. x\<in>s"])
  case 0
  then have False by simp
  then show ?case by simp
next
  case (no_roots p)
  then show ?case
    by (metis all_not_in_conv card.empty proots_count_def proots_within_iff sum.empty)
next
  case (root a p)
  have "proots_count ([:a, - 1:] * p) s = 1 + proots_count p s"
    apply (subst proots_count_times)
    subgoal using root.prems rsquarefree_def by blast
    subgoal by (metis (no_types, opaque_lifting) add.inverse_inverse add.inverse_neutral
                  minus_pCons proots_count_pCons_1_iff proots_count_uminus root.hyps(1))
    done
  also have "... = 1 + card (proots_within p s)"
  proof -
    have "rsquarefree p" using \<open>rsquarefree ([:a, - 1:] * p)\<close>
      by (elim rsquarefree_times)
    from root(2)[OF this] show ?thesis by simp
  qed
  also have "... = card (proots_within ([:a, - 1:] * p) s)" unfolding proots_within_times
  proof (subst card_Un_disjoint)
    have [simp]:"p\<noteq>0" using root.prems by auto
    show "finite (proots_within [:a, - 1:] s)" "finite (proots_within p s)"
      by auto
    show " 1 + card (proots_within p s) = card (proots_within [:a, - 1:] s)
               + card (proots_within p s)"
      using \<open>a \<in> s\<close>
      apply (subst proots_within_pCons_1_iff)
      by simp
    have "poly p a\<noteq>0"
    proof (rule ccontr)
      assume "\<not> poly p a \<noteq> 0"
      then have "order a p >0" by (simp add: order_root)
      moreover have "order a [:a,-1:] = 1"
        by (metis (no_types, opaque_lifting) add.inverse_inverse add.inverse_neutral minus_pCons
            order_power_n_n order_uminus power_one_right)
      ultimately have "order a  ([:a, - 1:] * p) > 1"
        apply (subst order_mult)
        subgoal using root.prems by auto
        subgoal by auto
        done
      then show False using \<open>rsquarefree ([:a, - 1:] * p)\<close>
        unfolding rsquarefree_def using gr_implies_not0 less_not_refl2 by blast
    qed
    then show " proots_within [:a, - 1:] s \<inter> proots_within p s = {}"
      using proots_within_pCons_1_iff(2) by auto
  qed
  finally show ?case .
qed

lemma rsquarefree_gcd_pderiv:
  fixes p::"'a::{factorial_ring_gcd,semiring_gcd_mult_normalize,semiring_char_0} poly"
  assumes "p\<noteq>0"
  shows "rsquarefree (p div (gcd p (pderiv p)))"
proof (cases "pderiv p = 0")
  case True
  have "poly (unit_factor p) x \<noteq>0" for x
    using unit_factor_is_unit[OF \<open>p\<noteq>0\<close>]
    by (meson assms dvd_trans order_decomp poly_eq_0_iff_dvd unit_factor_dvd)
  then have "order x (unit_factor p) = 0" for x
    using order_0I by blast
  then show ?thesis using True \<open>p\<noteq>0\<close> unfolding rsquarefree_def by simp
next
  case False
  define q where "q = p div (gcd p (pderiv p))"
  have "q\<noteq>0" unfolding q_def by (simp add: assms dvd_div_eq_0_iff)

  have order_pq:"order x p = order x q + min (order x p) (order x (pderiv p))"
    for x
  proof -
    have *:"p = q * gcd p (pderiv p)"
      unfolding q_def by simp
    show ?thesis
      apply (subst *)
      using \<open>q\<noteq>0\<close> \<open>p\<noteq>0\<close> \<open>pderiv p\<noteq>0\<close> by (simp add:order_mult order_gcd)
  qed
  have "order x q = 0 \<or> order x q=1" for x
  proof (cases "poly p x=0")
    case True
    from order_pderiv[OF \<open>p\<noteq>0\<close> this]
    have "order x p = order x (pderiv p) + 1" by simp
    then show ?thesis using order_pq[of x] by auto
  next
    case False
    then have "order x p = 0" by (simp add: order_0I)
    then have "order x q = 0" using order_pq[of x] by simp
    then show ?thesis by simp
  qed
  then show ?thesis using \<open>q\<noteq>0\<close> unfolding rsquarefree_def q_def
    by auto
qed

lemma poly_gcd_pderiv_iff:
  fixes p::"'a::{semiring_char_0,factorial_ring_gcd,semiring_gcd_mult_normalize} poly"
  shows "poly (p div (gcd p (pderiv p))) x =0 \<longleftrightarrow> poly p x=0"
proof (cases "pderiv p=0")
  case True
  then obtain a where "p=[:a:]" using pderiv_iszero by auto
  then show ?thesis by (auto simp add: unit_factor_poly_def)
next
  case False
  then have "p\<noteq>0" using pderiv_0 by blast
  define q where "q = p div (gcd p (pderiv p))"
  have "q\<noteq>0" unfolding q_def by (simp add: \<open>p\<noteq>0\<close> dvd_div_eq_0_iff)

  have order_pq:"order x p = order x q + min (order x p) (order x (pderiv p))" for x
  proof -
    have *:"p = q * gcd p (pderiv p)"
      unfolding q_def by simp
    show ?thesis
      apply (subst *)
      using \<open>q\<noteq>0\<close> \<open>p\<noteq>0\<close> \<open>pderiv p\<noteq>0\<close> by (simp add:order_mult order_gcd)
  qed

  have "order x q =0 \<longleftrightarrow> order x p = 0"
  proof (cases "poly p x=0")
    case True
    from order_pderiv[OF \<open>p\<noteq>0\<close> this]
    have "order x p = order x (pderiv p) + 1" by simp
    then show ?thesis using order_pq[of x] by auto
  next
    case False
    then have "order x p = 0" by (simp add: order_0I)
    then have "order x q = 0" using order_pq[of x] by simp
    then show ?thesis using \<open>order x p = 0\<close> by simp
  qed
  then show ?thesis
    apply (fold q_def)
    unfolding order_root using \<open>p\<noteq>0\<close> \<open>q\<noteq>0\<close> by auto
qed

subsection \<open>Composition of a polynomial and a circular path\<close>

lemma poly_circlepath_tan_eq:
  fixes z0::complex and r::real and p::"complex poly"
  defines "q1\<equiv> fcompose p [:(z0+r)*\<i>,z0-r:] [:\<i>,1:]" and "q2 \<equiv> [:\<i>,1:] ^ degree p"
  assumes "0\<le>t" "t\<le>1" "t\<noteq>1/2"
  shows "poly p (circlepath z0 r t) = poly q1 (tan (pi*t)) / poly q2 (tan (pi*t))"
    (is "?L = ?R")
proof -
  have "?L = poly p (z0+ r*exp (2 * of_real pi * \<i>  * t))"
    unfolding circlepath by simp
  also have "... = ?R"
  proof -
    define f where "f = (poly p \<circ> (\<lambda>x::real. z0 + r * exp (\<i> * x)))"
    have f_eq:"f t = ((\<lambda>x::real. poly q1 x / poly q2 x) o  (\<lambda>x. tan (x/2)) ) t"
      when "cos (t / 2) \<noteq> 0" for t
    proof -
      have "f t = poly p (z0 + r * (cos t + \<i> * sin t)) "
        unfolding f_def exp_Euler  by (auto simp add:cos_of_real sin_of_real)
      also have "... = poly p ((\<lambda>x. ((z0-r)*x+(z0+r)*\<i>) / (\<i>+x)) (tan (t/2)))"
      proof -
        define tt where "tt=complex_of_real (tan (t / 2))"
        define rr where "rr = complex_of_real r"
        have "cos t = (1-tt*tt) / (1 + tt * tt)"
             "sin t = 2*tt  / (1 + tt * tt)"
          unfolding sin_tan_half[of "t/2",simplified] cos_tan_half[of "t/2",OF that, simplified] tt_def
          by (auto simp add:power2_eq_square)
        moreover have "1 + tt * tt \<noteq> 0" unfolding tt_def
          apply (fold of_real_mult)
          by (metis (no_types, opaque_lifting) mult_numeral_1 numeral_One of_real_add of_real_eq_0_iff
              of_real_numeral sum_squares_eq_zero_iff zero_neq_one)
        ultimately have "z0 +  r * ( (cos t) + \<i> * (sin t))
            =(z0*(1+tt*tt)+rr*(1-tt*tt)+\<i>*rr*2*tt ) / (1 + tt * tt) "
          apply (fold rr_def,simp add:add_divide_distrib)
          by (simp add:algebra_simps)
        also have "... = ((z0-rr)*tt+z0*\<i>+rr*\<i>) / (tt + \<i>)"
        proof -
          have "tt + \<i> \<noteq> 0"
            using \<open>1 + tt * tt \<noteq> 0\<close>
            by (metis i_squared neg_eq_iff_add_eq_0 square_eq_iff)
          then show ?thesis
            using \<open>1 + tt * tt \<noteq> 0\<close> by (auto simp add:divide_simps algebra_simps)
        qed
        finally have "z0 +  r * ( (cos t) + \<i> * (sin t)) = ((z0-rr)*tt+z0*\<i>+rr*\<i>) / (tt + \<i>)" .
        then show ?thesis unfolding tt_def rr_def
          by (auto simp add:algebra_simps power2_eq_square)
      qed
      also have "... = (poly p o ((\<lambda>x. ((z0-r)*x+(z0+r)*\<i>) / (\<i>+x)) o (\<lambda>x. tan (x/2)) )) t"
        unfolding comp_def by (auto simp:tan_of_real)
      also have "... = ((\<lambda>x::real. poly q1 x / poly q2 x) o  (\<lambda>x. tan (x/2)) ) t"
        unfolding q2_def q1_def
        apply (subst fcompose_poly[symmetric])
        subgoal for x
          apply simp
          by (metis Re_complex_of_real add_cancel_right_left complex_i_not_zero imaginary_unit.sel(1) plus_complex.sel(1) rcis_zero_arg rcis_zero_mod)
        subgoal by (auto simp:tan_of_real algebra_simps)
        done
      finally show ?thesis .
    qed

    have "cos (pi * t) \<noteq>0" unfolding cos_zero_iff_int2
    proof
      assume "\<exists>i. pi * t = real_of_int i * pi + pi / 2"
      then obtain i where "pi * t = real_of_int i * pi + pi / 2" by auto
      then have "pi * t=pi * (real_of_int i + 1 / 2)" by (simp add:algebra_simps)
      then have "t=real_of_int i + 1 / 2" by auto
      then show False using \<open>0\<le>t\<close> \<open>t\<le>1\<close> \<open>t\<noteq>1/2\<close> by auto
    qed
    from f_eq[of "2*pi*t",simplified,OF this]
    show "?thesis"
      unfolding f_def comp_def by (auto simp add:algebra_simps)
  qed
  finally show ?thesis .
qed

subsection \<open>Combining two real polynomials into a complex one\<close>

definition cpoly_of:: "real poly \<Rightarrow> real poly \<Rightarrow> complex poly" where
  "cpoly_of pR pI = map_poly of_real pR + smult \<i> (map_poly of_real pI)"

lemma cpoly_of_eq_0_iff[iff]:
  "cpoly_of pR pI = 0 \<longleftrightarrow> pR = 0 \<and> pI = 0"
proof -
  have "pR = 0 \<and> pI = 0" when "cpoly_of pR pI = 0"
  proof -
    have "complex_of_real (coeff pR n) + \<i> * complex_of_real (coeff pI n) = 0" for n
      using that unfolding poly_eq_iff cpoly_of_def by (auto simp:coeff_map_poly)
    then have "coeff pR n = 0 \<and> coeff pI n = 0" for n
      by (metis Complex_eq Im_complex_of_real Re_complex_of_real complex.sel(1) complex.sel(2)
          of_real_0)
    then show ?thesis unfolding poly_eq_iff by auto
  qed
  then show ?thesis by (auto simp:cpoly_of_def)
qed

lemma cpoly_of_decompose:
    "p = cpoly_of (map_poly Re p) (map_poly Im p)"
  unfolding cpoly_of_def
  apply (induct p)
  by (auto simp add:map_poly_pCons map_poly_map_poly complex_eq)

lemma cpoly_of_dist_right:
    "cpoly_of (pR*g) (pI*g) = cpoly_of pR pI * (map_poly of_real g)"
  unfolding cpoly_of_def by (simp add: distrib_right)

lemma poly_cpoly_of_real:
    "poly (cpoly_of pR pI) (of_real x) = Complex (poly pR x) (poly pI x)"
  unfolding cpoly_of_def by (simp add: Complex_eq)

lemma poly_cpoly_of_real_iff:
  shows "poly (cpoly_of pR pI) (of_real t) =0 \<longleftrightarrow> poly pR t = 0 \<and> poly pI t=0 "
  unfolding  poly_cpoly_of_real using Complex_eq_0 by blast

lemma order_cpoly_gcd_eq:
  assumes "pR\<noteq>0 \<or> pI\<noteq>0"
  shows "order t (cpoly_of pR pI) = order t (gcd pR pI)"
proof -
  define g where "g = gcd pR pI"
  have [simp]:"g\<noteq>0" unfolding g_def using assms by auto
  obtain pr pi where pri: "pR = pr * g" "pI = pi * g" "coprime pr pi"
    unfolding g_def using assms(1) gcd_coprime_exists \<open>g \<noteq> 0\<close> g_def by blast
  then have "pr \<noteq>0 \<or> pi \<noteq>0" using assms mult_zero_left by blast

  have "order t (cpoly_of pR pI) = order t (cpoly_of pr pi * (map_poly of_real g))"
    unfolding pri cpoly_of_dist_right by simp
  also have "... = order t (cpoly_of pr pi) + order t g"
    apply (subst order_mult)
    using \<open>pr \<noteq>0 \<or> pi \<noteq>0\<close> by (auto simp:map_poly_order_of_real)
  also have "... = order t g"
  proof -
    have "poly (cpoly_of pr pi) t \<noteq>0" unfolding poly_cpoly_of_real_iff
      using \<open>coprime pr pi\<close> coprime_poly_0 by blast
    then have "order t (cpoly_of pr pi) = 0" by (simp add: order_0I)
    then show ?thesis by auto
  qed
  finally show ?thesis unfolding g_def .
qed

lemma cpoly_of_times:
  shows "cpoly_of pR pI * cpoly_of qR qI = cpoly_of (pR * qR - pI * qI) (pI*qR+pR*qI)"
proof -
  define PR PI where "PR = map_poly complex_of_real pR"
                 and "PI = map_poly complex_of_real pI"
  define QR QI where "QR = map_poly complex_of_real qR"
                 and "QI = map_poly complex_of_real qI"
  show ?thesis
    unfolding cpoly_of_def
    by (simp add:algebra_simps of_real_poly_hom.hom_minus smult_add_right
          flip: PR_def PI_def QR_def QI_def)
qed

lemma map_poly_Re_cpoly[simp]:
  "map_poly Re (cpoly_of pR pI) = pR"
  unfolding cpoly_of_def smult_map_poly
  apply (simp add:map_poly_map_poly Re_poly_hom.hom_add comp_def)
  by (metis coeff_map_poly leading_coeff_0_iff)

lemma map_poly_Im_cpoly[simp]:
  "map_poly Im (cpoly_of pR pI) = pI"
  unfolding cpoly_of_def smult_map_poly
  apply (simp add:map_poly_map_poly Im_poly_hom.hom_add comp_def)
  by (metis coeff_map_poly leading_coeff_0_iff)

end