section \<open>The Theorem of Farkas, Minkowsky and Weyl\<close>

text \<open>We prove the theorem of Farkas, Minkowsky and Weyl that a cone is finitely generated
  iff it is polyhedral. Moreover, we provide quantative bounds.\<close>

theory Farkas_Minkowsky_Weyl
  imports Fundamental_Theorem_Linear_Inequalities
begin

context gram_schmidt
begin

text \<open>We first prove the one direction of the theorem
  for the case that the span of the vectors is the full n-dimensional space.\<close>

lemma farkas_minkowsky_weyl_theorem_1_full_dim:
  assumes X: "X \<subseteq> carrier_vec n"
    and fin: "finite X"
    and span: "span X = carrier_vec n"
  shows "\<exists> nr A. A \<in> carrier_mat nr n \<and> cone X = polyhedral_cone A
  \<and> (X \<subseteq> \<int>\<^sub>v \<inter> Bounded_vec Bnd \<longrightarrow> A \<in> \<int>\<^sub>m \<inter> Bounded_mat (det_bound (n-1) Bnd))"
proof -
  define cond where "cond = (\<lambda> W. Suc (card W) = n \<and> lin_indpt W \<and> W \<subseteq> X)"
  {
    fix W
    assume "cond W"
    hence *: "finite W" "Suc (card W) = n" "lin_indpt W" "W \<subseteq> carrier_vec n" and WX: "W \<subseteq> X" unfolding cond_def
      using finite_subset[OF _ fin] X by auto
    note nv = normal_vector[OF *]
    hence "normal_vector W \<in> carrier_vec n" "\<And> w. w \<in> W \<Longrightarrow> normal_vector W \<bullet> w = 0"
      "normal_vector W \<noteq> 0\<^sub>v n" "X \<subseteq> \<int>\<^sub>v \<inter> Bounded_vec Bnd \<Longrightarrow> normal_vector W \<in> \<int>\<^sub>v \<inter> Bounded_vec (det_bound (n - 1) Bnd)"
      using WX by blast+
  } note condD = this
  define Ns where "Ns = { normal_vector W | W. cond W \<and> (\<forall> w \<in> X. normal_vector W \<bullet> w \<ge> 0) }
       \<union> { - normal_vector W | W. cond W \<and> (\<forall> w \<in> X. (- normal_vector W) \<bullet> w \<ge> 0)}"
  have "Ns \<subseteq> normal_vector ` {W . W \<subseteq> X} \<union> (\<lambda> W. - normal_vector W) ` {W. W \<subseteq> X}" unfolding Ns_def cond_def by blast
  moreover have "finite \<dots>" using \<open>finite X\<close> by auto
  ultimately have "finite Ns" by (metis finite_subset)
  from finite_list[OF this] obtain ns where ns: "set ns = Ns" by auto
  have Ns: "Ns \<subseteq> carrier_vec n" unfolding Ns_def using condD by auto
  define A where "A = mat_of_rows n ns"
  define nr where "nr = length ns"
  have A: "- A \<in> carrier_mat nr n" unfolding A_def nr_def by auto
  show ?thesis
  proof (intro exI conjI impI, rule A)
    have not_conj: "\<not> (a \<and> b) \<longleftrightarrow> (a \<longrightarrow> \<not> b)" for a b by auto
    have id: "Ns = { nv . \<exists> W. W \<subseteq> X \<and> nv \<in> {normal_vector W, - normal_vector W} \<and>
             Suc (card W) = n \<and> lin_indpt W \<and> (\<forall>a\<^sub>i\<in>X. 0 \<le> nv \<bullet> a\<^sub>i)}"
      unfolding Ns_def cond_def by auto
    have "polyhedral_cone (- A) = { b. b \<in> carrier_vec n \<and> (- A) *\<^sub>v b \<le> 0\<^sub>v nr}" unfolding polyhedral_cone_def
      using A by auto
    also have "\<dots> = {b. b \<in> carrier_vec n \<and> (\<forall> i < nr. row (- A) i \<bullet> b \<le> 0)}"
      unfolding less_eq_vec_def using A by auto
    also have "\<dots> = {b. b \<in> carrier_vec n \<and> (\<forall> i < nr. - (ns ! i) \<bullet> b \<le> 0)}" using A Ns[folded ns]
      by (intro Collect_cong conj_cong refl all_cong arg_cong[of _ _ "\<lambda> x. x \<bullet> _ \<le> _"],
          force simp: A_def mat_of_rows_def nr_def set_conv_nth)
    also have "\<dots> = {b. b \<in> carrier_vec n \<and> (\<forall> n \<in> Ns. - n \<bullet> b \<le> 0)}"
      unfolding ns[symmetric] nr_def by (auto simp: set_conv_nth)
    also have "\<dots> = {b. b \<in> carrier_vec n \<and> (\<forall> n \<in> Ns. n \<bullet> b \<ge> 0)}"
      by (intro Collect_cong conj_cong refl ball_cong, insert Ns, auto)
    also have "\<dots> = cone X"
      unfolding fundamental_theorem_of_linear_inequalities_full_dim(2)[OF X fin span]
      by (intro Collect_cong conj_cong refl, unfold not_le[symmetric] not_ex not_conj not_not id, blast)
    finally show "cone X = polyhedral_cone (- A)" ..
    {
      assume XI: "X \<subseteq> \<int>\<^sub>v \<inter> Bounded_vec Bnd"
      {
        fix v
        assume "v \<in> set (rows (- A))"
        hence "-v \<in> set (rows A)" unfolding rows_def by auto
        hence "-v \<in> Ns" unfolding A_def using ns Ns by auto
        from this[unfolded Ns_def] obtain W where cW: "cond W"
          and v: "-v = normal_vector W \<or> v = normal_vector W" by auto
        from cW[unfolded cond_def] have WX: "W \<subseteq> X" by auto
        from v have v: "v = normal_vector W \<or> v = - normal_vector W"
          by (metis uminus_uminus_vec)
        from condD(4)[OF cW XI]
        have "normal_vector W \<in> \<int>\<^sub>v \<inter> Bounded_vec (det_bound (n - 1) Bnd)" by auto
        hence "v \<in> \<int>\<^sub>v \<inter> Bounded_vec (det_bound (n - 1) Bnd)" using v by auto
      }
      hence "set (rows (- A)) \<subseteq> \<int>\<^sub>v \<inter> Bounded_vec (det_bound (n - 1) Bnd)" by blast
      thus "- A \<in> \<int>\<^sub>m \<inter> Bounded_mat (det_bound (n - 1) Bnd)" by simp
    }
  qed
qed

text \<open>We next generalize the theorem to the case where X does not span the full space.
  To this end, we extend X by unit-vectors until the full space is spanned, and then
  add the normal-vectors of these unit-vectors which are orthogonal to span X as additional
  constraints to the resulting matrix.\<close>
lemma farkas_minkowsky_weyl_theorem_1:
  assumes X: "X \<subseteq> carrier_vec n"
    and finX: "finite X"
  shows "\<exists> nr A. A \<in> carrier_mat nr n \<and> cone X = polyhedral_cone A \<and>
    (X \<subseteq> \<int>\<^sub>v \<inter> Bounded_vec Bnd \<longrightarrow> A \<in> \<int>\<^sub>m \<inter> Bounded_mat (det_bound (n-1) (max 1 Bnd)))"
proof -
  from exists_lin_indpt_sublist[OF X]
  obtain Ls where lin_Ls: "lin_indpt_list Ls" and
    spanL: "span (set Ls) = span X" and LX: "set Ls \<subseteq> X" by auto
  define Ns where "Ns = normal_vectors Ls"
  define Bs where "Bs = basis_extension Ls"
  from basis_extension[OF lin_Ls, folded Bs_def]
  have BU: "set Bs \<subseteq> set (unit_vecs n)"
    and lin_Ls_Bs: "lin_indpt_list (Ls @ Bs)"
    and len_Ls_Bs: "length (Ls @ Bs) = n"
    by auto
  note nv = normal_vectors[OF lin_Ls, folded Ns_def]
  from nv(1-6) nv(7)[of Bnd]
  have N: "set Ns \<subseteq> carrier_vec n"
    and LN': "lin_indpt_list (Ls @ Ns)" "length (Ls @ Ns) = n"
    and ortho: "\<And> l w. l \<in> set Ls \<Longrightarrow> w \<in> set Ns \<Longrightarrow> w \<bullet> l = 0"
    and Ns_bnd: "set Ls \<subseteq> \<int>\<^sub>v \<inter> Bounded_vec Bnd
     \<Longrightarrow> set Ns \<subseteq> \<int>\<^sub>v \<inter> Bounded_vec (det_bound (n-1) (max 1 Bnd))"
    by auto
  from lin_indpt_list_length_eq_n[OF LN']
  have spanLN: "span (set Ls \<union> set Ns) = carrier_vec n" by auto
  let ?Bnd = "Bounded_vec (det_bound (n-1) (max 1 Bnd))"
  let ?Bndm = "Bounded_mat (det_bound (n-1) (max 1 Bnd))"
  define Y where "Y = X \<union> set Bs"
  from lin_Ls_Bs[unfolded lin_indpt_list_def] have
    Ls: "set Ls \<subseteq> carrier_vec n" and
    Bs: "set Bs \<subseteq> carrier_vec n" and
    distLsBs: "distinct (Ls @ Bs)" and
    lin': "lin_indpt (set (Ls @ Bs))" by auto
  have LN: "set Ls \<inter> set Ns = {}"
  proof (rule ccontr)
    assume "\<not> ?thesis"
    then obtain x where xX: "x \<in> set Ls" and xW: "x \<in> set Ns" by auto
    from ortho[OF xX xW] have "x \<bullet> x = 0" by auto
    hence "sq_norm x = 0" by (auto simp: sq_norm_vec_as_cscalar_prod)
    with xX LX X have "x = 0\<^sub>v n" by auto
    with vs_zero_lin_dep[OF _ lin'] Ls Bs xX show False by auto
  qed
  have Y: "Y \<subseteq> carrier_vec n" using X Bs unfolding Y_def by auto
  have CLB: "carrier_vec n = span (set (Ls @ Bs))"
    using lin_Ls_Bs len_Ls_Bs lin_indpt_list_length_eq_n by blast
  also have "\<dots> \<subseteq> span Y"
    by (rule span_is_monotone, insert LX, auto simp: Y_def)
  finally have span: "span Y = carrier_vec n" using Y by auto
  have finY: "finite Y" using finX unfolding Y_def by auto
  from farkas_minkowsky_weyl_theorem_1_full_dim[OF Y finY span]
  obtain A nr where A: "A \<in> carrier_mat nr n" and YA: "cone Y = polyhedral_cone A"
    and Y_Ints: "Y \<subseteq> \<int>\<^sub>v \<inter> Bounded_vec (max 1 Bnd) \<Longrightarrow> A \<in> \<int>\<^sub>m \<inter> ?Bndm" by blast
  have fin: "finite ({row A i | i. i < nr} \<union> set Ns \<union> uminus ` set Ns)" by auto
  from finite_list[OF this] obtain rs where rs_def: "set rs = {row A i |i. i < nr} \<union> set Ns \<union> uminus ` set Ns" by auto
  from A N have rs: "set rs \<subseteq> carrier_vec n" unfolding rs_def by auto
  let ?m = "length rs"
  define B where "B = mat_of_rows n rs"
  have B: "B \<in> carrier_mat ?m n" unfolding B_def by auto
  show ?thesis
  proof (intro exI conjI impI, rule B)
    have id: "(\<forall>r\<in>{rs ! i |i. i < ?m}. P r) = (\<forall> r < ?m. P (rs ! r))" for P by auto
    have "polyhedral_cone B = { x \<in> carrier_vec n. B *\<^sub>v x \<le> 0\<^sub>v ?m}" unfolding polyhedral_cone_def
      using B by auto
    also have "\<dots> = { x \<in> carrier_vec n. \<forall> i < ?m. row B i \<bullet> x \<le> 0}"
      unfolding less_eq_vec_def using B by auto
    also have "\<dots> = { x \<in> carrier_vec n. \<forall> r \<in> set rs. r \<bullet> x \<le> 0}" using rs unfolding set_conv_nth id
      by (intro Collect_cong conj_cong refl all_cong arg_cong[of _ _ "\<lambda> x. x \<bullet> _ \<le> 0"], auto simp: B_def)
    also have "\<dots> = {x \<in> carrier_vec n. \<forall> i < nr. row A i \<bullet> x \<le> 0}
           \<inter> {x \<in> carrier_vec n. \<forall> w \<in> set Ns \<union> uminus ` set Ns. w \<bullet> x \<le> 0}"
      unfolding rs_def by blast
    also have "{x \<in> carrier_vec n. \<forall> i < nr. row A i \<bullet> x \<le> 0} = polyhedral_cone A"
      unfolding polyhedral_cone_def using A by (auto simp: less_eq_vec_def)
    also have "\<dots> = cone Y" unfolding YA ..
    also have "{x \<in> carrier_vec n. \<forall> w \<in> set Ns \<union> uminus ` set Ns. w \<bullet> x \<le> 0}
      = {x \<in> carrier_vec n. \<forall> w \<in> set Ns. w \<bullet> x = 0}"
      (is "?l = ?r")
    proof
      show "?r \<subseteq> ?l" using N by auto
      {
        fix x w
        assume "x \<in> ?l" "w \<in> set Ns"
        with N have x: "x \<in> carrier_vec n" and w: "w \<in> carrier_vec n"
          and one: "w \<bullet> x \<le> 0" and two: "(-w) \<bullet> x \<le> 0" by auto
        from two have "w \<bullet> x \<ge> 0"
          by (subst (asm) scalar_prod_uminus_left, insert w x, auto)
        with one have "w \<bullet> x = 0" by auto
      }
      thus "?l \<subseteq> ?r" by blast
    qed
    finally have "polyhedral_cone B = cone Y \<inter> {x \<in> carrier_vec n. \<forall>w\<in>set Ns. w \<bullet> x = 0}" .
    also have "\<dots> = cone X" unfolding Y_def
      by (rule orthogonal_cone(1)[OF X N finX spanLN ortho refl spanL LX lin_Ls_Bs len_Ls_Bs])
    finally show "cone X = polyhedral_cone B" ..
    assume X_I: "X \<subseteq> \<int>\<^sub>v \<inter> Bounded_vec Bnd"
    with LX have "set Ls \<subseteq> \<int>\<^sub>v \<inter> Bounded_vec Bnd" by auto
    from Ns_bnd[OF this] have N_I_Bnd: "set Ns \<subseteq> \<int>\<^sub>v \<inter> ?Bnd" by auto
    from lin_Ls_Bs have linLs: "lin_indpt_list Ls" unfolding lin_indpt_list_def
      using subset_li_is_li[of _ "set Ls"] by auto
    from X_I LX have L_I: "set Ls \<subseteq> \<int>\<^sub>v" by auto
    have Y_I: "Y \<subseteq> \<int>\<^sub>v \<inter> Bounded_vec (max 1 Bnd)" unfolding Y_def using X_I BU
        Bounded_vec_mono[of Bnd "max 1 Bnd"] by (auto simp: unit_vecs_def Ints_vec_def)
    from Y_Ints[OF Y_I]
    have A_I_Bnd: "set (rows A) \<subseteq> \<int>\<^sub>v \<inter> ?Bnd" by auto
    have "set (rows B) = set (rows (mat_of_rows n rs))" unfolding B_def by auto
    also have "\<dots> = set rs" using rs by auto
    also have "\<dots> = set (rows A) \<union> set Ns \<union> uminus ` set Ns" unfolding rs_def rows_def using A by auto
    also have "\<dots> \<subseteq> \<int>\<^sub>v \<inter> ?Bnd" using A_I_Bnd N_I_Bnd by auto
    finally show "B \<in> \<int>\<^sub>m \<inter> ?Bndm" by simp
  qed
qed

text \<open>Now for the other direction.\<close>

lemma farkas_minkowsky_weyl_theorem_2:
  assumes A: "A \<in> carrier_mat nr n"
  shows "\<exists> X. X \<subseteq> carrier_vec n \<and> finite X \<and> polyhedral_cone A = cone X
    \<and> (A \<in> \<int>\<^sub>m \<inter> Bounded_mat Bnd \<longrightarrow> X \<subseteq> \<int>\<^sub>v \<inter> Bounded_vec (det_bound (n-1) (max 1 Bnd)))"
proof -
  let ?rows_A = "{row A i | i. i < nr}"
  let ?Bnd = "Bounded_vec (det_bound (n-1) (max 1 Bnd))"
  have rows_A_n: "?rows_A \<subseteq> carrier_vec n" using row_carrier_vec A by auto
  hence "\<exists> mr B. B \<in> carrier_mat mr n \<and> cone ?rows_A = polyhedral_cone B
    \<and> (?rows_A \<subseteq> \<int>\<^sub>v \<inter> Bounded_vec Bnd \<longrightarrow> set (rows B) \<subseteq> \<int>\<^sub>v \<inter> ?Bnd)"
    using farkas_minkowsky_weyl_theorem_1[of ?rows_A] by auto
  then obtain mr B
    where mr: "B \<in> carrier_mat mr n" and B: "cone ?rows_A = polyhedral_cone B"
      and Bnd: "?rows_A \<subseteq> \<int>\<^sub>v \<inter> Bounded_vec Bnd \<Longrightarrow> set (rows B) \<subseteq> \<int>\<^sub>v \<inter> ?Bnd"
    by blast
  let ?rows_B = "{row B i | i. i < mr}"
  have rows_B: "?rows_B \<subseteq> carrier_vec n" using mr by auto
  have "cone ?rows_B = polyhedral_cone A"
  proof
    have "?rows_B \<subseteq> polyhedral_cone A"
    proof
      fix r
      assume "r \<in> ?rows_B"
      then obtain j where r: "r = row B j" and j: "j < mr" by auto
      then have rn: "r \<in> carrier_vec n" using mr row_carrier by auto
      moreover have "A *\<^sub>v r \<le> 0\<^sub>v nr" unfolding less_eq_vec_def
      proof (standard, unfold index_zero_vec)
        show "dim_vec (A *\<^sub>v r) = nr" using A by auto
      next
        show "\<forall>i< nr. (A *\<^sub>v r) $ i \<le> 0\<^sub>v nr $ i"
        proof (standard, rule impI)
          fix i
          assume i: "i < nr"
          then have "row A i \<in> ?rows_A" by auto
          then have "row A i \<in> cone ?rows_A"
            using set_in_cone rows_A_n by blast
          then have "row A i \<in> polyhedral_cone B" using B by auto
          then have Br: "B *\<^sub>v (row A i) \<le> 0\<^sub>v mr"
            unfolding polyhedral_cone_def using rows_A_n mr by auto

          then have "(A *\<^sub>v r) $ i = (row A i) \<bullet> r" using A i index_mult_mat_vec by auto
          also have "\<dots> = r \<bullet> (row A i)"
            using comm_scalar_prod[OF _ rn] row_carrier A by auto
          also have "\<dots> = (row B j) \<bullet> (row A i)" using r by auto
          also have "\<dots> = (B *\<^sub>v (row A i)) $ j" using index_mult_mat_vec mr j by auto
          also have "\<dots> \<le> 0" using Br j unfolding less_eq_vec_def by auto
          also have "\<dots> = 0\<^sub>v nr $ i" using i by auto
          finally show "(A *\<^sub>v r) $ i \<le> 0\<^sub>v nr $ i" by auto
        qed
      qed
      then show "r \<in> polyhedral_cone A"
        unfolding polyhedral_cone_def
        using A rn by auto
    qed
    then show "cone ?rows_B \<subseteq> polyhedral_cone A"
      using cone_in_polyhedral_cone A by auto

  next

    show "polyhedral_cone A \<subseteq> cone ?rows_B"
    proof (rule ccontr)
      assume "\<not> polyhedral_cone A \<subseteq> cone ?rows_B"
      then obtain y where yA: "y \<in> polyhedral_cone A"
        and yB: "y \<notin> cone ?rows_B" by auto
      then have yn: "y \<in> carrier_vec n" unfolding polyhedral_cone_def by auto
      have finRB: "finite ?rows_B" by auto
      from farkas_minkowsky_weyl_theorem_1[OF rows_B finRB]
      obtain nr' A' where A': "A' \<in> carrier_mat nr' n" and cone: "cone ?rows_B = polyhedral_cone A'"
        by blast
      from yB[unfolded cone polyhedral_cone_def] yn A'
      have "\<not> (A' *\<^sub>v y \<le> 0\<^sub>v nr')" by auto
      then obtain i where i: "i < nr'" and "row A' i \<bullet> y > 0"
        unfolding less_eq_vec_def using A' yn by auto
      define w where "w = row A' i"
      have w: "w \<in> carrier_vec n" using i A' yn unfolding w_def by auto
      from \<open>row A' i \<bullet> y > 0\<close> comm_scalar_prod[OF w yn] have wy: "w \<bullet> y > 0" "y \<bullet> w > 0" unfolding w_def by auto
      {
        fix b
        assume "b \<in> ?rows_B"
        hence "b \<in> cone ?rows_B" using set_in_cone[OF rows_B] by auto
        from this[unfolded cone polyhedral_cone_def] A'
        have b: "b \<in> carrier_vec n" and "A' *\<^sub>v b \<le> 0\<^sub>v nr'" by auto
        from this(2)[unfolded less_eq_vec_def, THEN conjunct2, rule_format, of i]
        have "w \<bullet> b \<le> 0" unfolding w_def using i A' by auto
        hence "b \<bullet> w \<le> 0" using comm_scalar_prod[OF b w] by auto
      }
      hence wA: "w \<in> cone ?rows_A" unfolding B polyhedral_cone_def using mr w
        by (auto simp: less_eq_vec_def)
      from wy have yw: "-y \<bullet> w < 0"
        by (subst scalar_prod_uminus_left, insert yn w, auto)
      have "?rows_A \<subseteq> carrier_vec n" "finite ?rows_A" using assms by auto
      from fundamental_theorem_of_linear_inequalities_A_imp_D[OF this wA, unfolded not_ex,
          rule_format, of "-y" ] yn yw
      obtain i where i: "i < nr" and "- y \<bullet> row A i < 0" by auto
      hence "y \<bullet> row A i > 0" by (subst (asm) scalar_prod_uminus_left, insert i assms yn, auto)
      hence "row A i \<bullet> y > 0" using comm_scalar_prod[OF _ yn, of "row A i"] i assms yn by auto
      with yA show False unfolding polyhedral_cone_def less_eq_vec_def using i assms by auto
    qed
  qed
  moreover have "?rows_B \<subseteq> carrier_vec n"
    using row_carrier_vec mr by auto
  moreover have "finite ?rows_B" by auto
  moreover {
    have rA: "set (rows A) = ?rows_A" using A unfolding rows_def by auto
    have rB: "set (rows B) = ?rows_B" using mr unfolding rows_def by auto
    assume "A \<in> \<int>\<^sub>m \<inter> Bounded_mat Bnd"
    hence "set (rows A) \<subseteq> \<int>\<^sub>v \<inter> Bounded_vec Bnd" by simp
    from Bnd[OF this[unfolded rA]]
    have "?rows_B \<subseteq> \<int>\<^sub>v \<inter> ?Bnd" unfolding rA rB .
  }
  ultimately show ?thesis by blast
qed

lemma farkas_minkowsky_weyl_theorem:
  "(\<exists> X. X \<subseteq> carrier_vec n \<and> finite X \<and> P = cone X)
  \<longleftrightarrow> (\<exists> A nr. A \<in> carrier_mat nr n \<and> P = polyhedral_cone A)"
  using farkas_minkowsky_weyl_theorem_1 farkas_minkowsky_weyl_theorem_2 by metis
end
end


(* Title:      Kleene Algebra
   Author:     Alasdair Armstrong, Georg Struth, Tjark Weber
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
               Tjark Weber <tjark.weber at it.uu.se>
*)

section \<open>Models of Omega Algebras\<close>

theory Omega_Algebra_Models
imports Omega_Algebra Kleene_Algebra_Models
begin

text \<open>The trace, path and language model are not really interesting
in this setting.\<close>

subsection \<open>Relation Omega Algebras\<close>

text \<open>In the relational model, the omega of a relation relates all
those elements in the domain of the relation, from which an infinite
chain starts, with all other elements; all other elements are not
related to anything~\<^cite>\<open>"hofnerstruth10nontermination"\<close>. Thus, the
omega of a relation is most naturally defined coinductively.\<close>

coinductive_set omega :: "('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set" for R where
  "\<lbrakk> (x, y) \<in> R; (y, z) \<in> omega R \<rbrakk> \<Longrightarrow> (x, z) \<in> omega R"

(* FIXME: The equivalent, but perhaps more elegant point-free version
  "x \<in> R O omega R \<Longrightarrow> x \<in> omega R"
fails due to missing monotonicity lemmas. *)

text \<open>Isabelle automatically derives a case rule and a coinduction
theorem for @{const omega}. We prove slightly more elegant
variants.\<close>

lemma omega_cases: "(x, z) \<in> omega R \<Longrightarrow>
  (\<And>y. (x, y) \<in> R \<Longrightarrow> (y, z) \<in> omega R \<Longrightarrow> P) \<Longrightarrow> P"
by (metis omega.cases)

lemma omega_coinduct: "X x z \<Longrightarrow>
  (\<And>x z. X x z \<Longrightarrow> \<exists>y. (x, y) \<in> R \<and> (X y z \<or> (y, z) \<in> omega R)) \<Longrightarrow>
  (x, z) \<in> omega R"
by (metis (full_types) omega.coinduct)

lemma omega_weak_coinduct: "X x z \<Longrightarrow>
  (\<And>x z. X x z \<Longrightarrow> \<exists>y. (x, y) \<in> R \<and> X y z) \<Longrightarrow>
  (x, z) \<in> omega R"
by (metis omega.coinduct)

interpretation rel_omega_algebra: omega_algebra "(\<union>)" "(O)" Id "{}" "(\<subseteq>)" "(\<subset>)" rtrancl omega
proof
  fix x :: "'a rel"
  show "omega x \<subseteq> x O omega x"
    by (auto elim: omega_cases)
next
  fix x y z :: "'a rel"
  assume *: "y \<subseteq> z \<union> x O y"
  {
    fix a b
    assume 1: "(a,b) \<in> y" and 2: "(a,b) \<notin> x\<^sup>* O z"
    have "(a,b) \<in> omega x"
    proof (rule omega_weak_coinduct[where X="\<lambda>a b. (a,b) \<in> x O y \<and> (a,b) \<notin> x\<^sup>* O z"])
      show "(a,b) \<in> x O y \<and> (a,b) \<notin> x\<^sup>* O z"
        using "*" "1" "2" by auto
    next
      fix a c
      assume 1: "(a,c) \<in> x O y \<and> (a,c) \<notin> x\<^sup>* O z"
      then obtain b where 2: "(a,b) \<in> x" and "(b,c) \<in> y"
        by auto
      then have "(b,c) \<in> x O y"
        using "*" "1" by blast
      moreover have "(b,c) \<notin> x\<^sup>* O z"
        using "1" "2" by (meson relcomp.cases relcomp.intros converse_rtrancl_into_rtrancl)
      ultimately show "\<exists>b. (a,b) \<in> x \<and> (b,c) \<in> x O y \<and> (b,c) \<notin> x\<^sup>* O z"
        using "2" by blast
    qed
  }
  then show "y \<subseteq> omega x \<union> x\<^sup>* O z"
    by auto
qed

end


(*
 * Finite Set lemmas.
 * (C)opyright Peter Gammie, peteg42 at gmail.com, commenced July 2006.
 * License: BSD
 *)

(*<*)
theory FSext

imports Main

begin
(*>*)

(* **************************************** *)

section\<open>General Lemmas\<close>

subsection\<open>Extra Finite-Set Lemmas\<close>

text\<open>Small variant of @{thm [source] "Finite_Set.finite_subset_induct"}:
also assume @{term "F \<subseteq> A"} in the induction hypothesis.\<close>

text\<open>A slight improvement on @{thm [source] "List.finite_list"} - add
@{term "distinct"}.\<close>

lemma finite_list: "finite A \<Longrightarrow> \<exists>l. set l = A \<and> distinct l"
proof(induct rule: finite_induct)
  case (insert x F)
  then obtain l where "set l = F \<and> distinct l" by auto
  with insert have "set (x#l) = insert x F \<and> distinct (x#l)" by auto
  thus ?case by blast
qed auto

subsection\<open>Extra bijection lemmas\<close>

lemma bij_betw_onto: "bij_betw f A B \<Longrightarrow> f ` A = B" unfolding bij_betw_def by simp

lemma inj_on_UnI: "\<lbrakk> inj_on f A; inj_on f B; f ` (A - B) \<inter> f ` (B - A) = {} \<rbrakk> \<Longrightarrow> inj_on f (A \<union> B)"
  by (auto iff: inj_on_Un)

lemma card_compose_bij:
  assumes bijf: "bij_betw f A A"
  shows "card { a \<in> A. P (f a) } = card { a \<in> A. P a }"
proof -
  from bijf have T: "f ` { a \<in> A. P (f a) } = { a \<in> A. P a }"
    unfolding bij_betw_def by auto
  from bijf have "card { a \<in> A. P (f a) } = card (f ` { a \<in> A. P (f a) })"
    unfolding bij_betw_def by (auto intro: subset_inj_on card_image[symmetric])
  with T show ?thesis by simp
qed

lemma card_eq_bij:
  assumes cardAB: "card A = card B"
      and finiteA: "finite A" and finiteB: "finite B"
  obtains f where "bij_betw f A B"
proof -
  from finiteA obtain g where G: "bij_betw g A {0..<card A}"
    by (blast dest: ex_bij_betw_finite_nat)
  from finiteB obtain h where H: "bij_betw h {0..<card B} B"
    by (blast dest: ex_bij_betw_nat_finite)
  from G H cardAB have I: "inj_on (h \<circ> g) A"
    unfolding bij_betw_def by - (rule comp_inj_on, simp_all)
  from G H cardAB have "(h \<circ> g) ` A = B"
    unfolding bij_betw_def by auto (metis image_cong image_image)
  with I have "bij_betw (h \<circ> g) A B"
    unfolding bij_betw_def by blast
  thus thesis ..
qed

lemma bij_combine:
  assumes ABCD: "A \<subseteq> B" "C \<subseteq> D"
      and bijf: "bij_betw f A C"
      and bijg: "bij_betw g (B - A) (D - C)"
  obtains h
    where "bij_betw h B D"
      and "\<And>x. x \<in> A \<Longrightarrow> h x = f x"
      and "\<And>x. x \<in> B - A \<Longrightarrow> h x = g x"
proof -
  let ?h = "\<lambda>x. if x \<in> A then f x else g x"
  have "inj_on ?h (A \<union> (B - A))"
  proof(rule inj_on_UnI)
    from bijf show "inj_on ?h A"
      by - (rule inj_onI, auto dest: inj_onD bij_betw_imp_inj_on)
    from bijg show "inj_on ?h (B - A)"
      by - (rule inj_onI, auto dest: inj_onD bij_betw_imp_inj_on)
    from bijf bijg show "?h ` (A - (B - A)) \<inter> ?h ` (B - A - A) = {}"
      by (simp, blast dest: bij_betw_onto)
  qed
  with ABCD have "inj_on ?h B" by (auto iff: Un_absorb1)
  moreover
  have "?h ` B = D"
  proof -
    from ABCD have "?h ` B = f ` A \<union> g ` (B - A)" by (auto iff: image_Un Un_absorb1)
    also from ABCD bijf bijg have "\<dots> = D" by (blast dest: bij_betw_onto)
    finally show ?thesis .
  qed
  ultimately have "bij_betw ?h B D"
              and "\<And>x. x \<in> A \<Longrightarrow> ?h x = f x"
              and "\<And>x. x \<in> B - A \<Longrightarrow> ?h x = g x"
    unfolding bij_betw_def by auto
  thus thesis ..
qed

lemma bij_complete:
  assumes finiteC: "finite C"
      and ABC: "A \<subseteq> C" "B \<subseteq> C"
      and bijf: "bij_betw f A B"
  obtains f' where "bij_betw f' C C"
      and "\<And>x. x \<in> A \<Longrightarrow> f' x = f x"
      and "\<And>x. x \<in> C - A \<Longrightarrow> f' x \<in> C - B"
proof -
  from finiteC ABC bijf have "card B = card A"
    unfolding bij_betw_def
    by (auto iff: inj_on_iff_eq_card [symmetric] intro: finite_subset)
  with finiteC ABC bijf have "card (C - A) = card (C - B)"
    by (auto iff: finite_subset card_Diff_subset)
  with finiteC obtain g where bijg: "bij_betw g (C - A) (C - B)"
    by - (drule card_eq_bij, auto)
  from ABC bijf bijg
  obtain f' where bijf': "bij_betw f' C C"
              and f'f: "\<And>x. x \<in> A \<Longrightarrow> f' x = f x"
              and f'g: "\<And>x. x \<in> C - A \<Longrightarrow> f' x = g x"
    by - (drule bij_combine, auto)
  from f'g bijg have "\<And>x. x \<in> C - A \<Longrightarrow> f' x \<in> C - B"
    by (blast dest: bij_betw_onto)
  with bijf' f'f show thesis ..
qed

lemma card_greater:
  assumes finiteA: "finite A"
      and c: "card { x \<in> A. P x } > card { x \<in> A. Q x }"
  obtains C
    where "card ({ x \<in> A. P x } - C) = card { x \<in> A. Q x }"
      and "C \<noteq> {}"
      and "C \<subseteq> { x \<in> A. P x }"
proof -
  let ?PA = "{ x \<in> A . P x }"
  let ?QA = "{ x \<in> A . Q x }"
  from finiteA obtain p where P: "bij_betw p {0..<card ?PA} ?PA"
    using ex_bij_betw_nat_finite[where M="?PA"]
    by (blast intro: finite_subset)
  let ?CN = "{card ?QA..<card ?PA}"
  let ?C = "p ` ?CN"
  have "card ({ x \<in> A. P x } - ?C) = card ?QA"
  proof -
    have nat_add_sub_shuffle: "\<And>x y z. \<lbrakk> (x::nat) > y; x - y = z \<rbrakk> \<Longrightarrow> x - z = y" by simp
    from P have T: "p ` {card ?QA..<card ?PA} \<subseteq> ?PA"
      unfolding bij_betw_def by auto
    from P have "card ?PA - card ?QA = card ?C"
      unfolding bij_betw_def
      by (auto iff: card_image subset_inj_on[where A="?CN"])
    with c have "card ?PA - card ?C = card ?QA" by (rule nat_add_sub_shuffle)
    with finiteA P T have "card (?PA - ?C) = card ?QA"
      unfolding bij_betw_def by (auto iff: finite_subset card_Diff_subset)
    thus ?thesis .
  qed
  moreover
  from P c have "?C \<noteq> {}"
    unfolding bij_betw_def by auto
  moreover
  from P have "?C \<subseteq> { x \<in> A. P x }"
    unfolding bij_betw_def by auto
  ultimately show thesis ..
qed

subsection\<open>Collections of witnesses: @{term "hasw"}, @{term "has"}\<close>

text \<open>

Given a set of cardinality at least $n$, we can find up to $n$ distinct
witnesses. The built-in @{term "card"} function unfortunately satisfies:

\begin{center}
 @{thm [source] "Finite_Set.card_infinite"}: @{thm "Finite_Set.card_infinite"
 [no_vars]}
\end{center}

These lemmas handle the infinite case uniformly.

Thanks to Gerwin Klein suggesting this approach.

\<close>

definition hasw :: "'a list \<Rightarrow> 'a set \<Rightarrow> bool" where
  "hasw xs S \<equiv> set xs \<subseteq> S \<and> distinct xs"

definition has :: "nat \<Rightarrow> 'a set \<Rightarrow> bool" where
  "has n S \<equiv> \<exists>xs. hasw xs S \<and> length xs = n"

declare hasw_def[simp]

lemma hasI[intro]: "hasw xs S \<Longrightarrow> has (length xs) S" by (unfold has_def, auto)

lemma card_has:
  assumes cardS: "card S = n"
  shows "has n S"
proof(cases "n = 0")
  case True thus ?thesis by (simp add: has_def)
next
  case False
  with cardS card_eq_0_iff[where A=S] have finiteS: "finite S" by simp
  show ?thesis
  proof(rule ccontr)
    assume nhas: "\<not> has n S"
    with distinct_card[symmetric]
    have nxs: "\<not> (\<exists> xs. set xs \<subseteq> S \<and> distinct xs \<and> card (set xs) = n)"
      by (auto simp add: has_def)
    from finite_list finiteS
    obtain xs where "S = set xs" by blast
    with cardS nxs show False by auto
  qed
qed

lemma card_has_rev:
  assumes finiteS: "finite S"
  shows "has n S \<Longrightarrow> card S \<ge> n" (is "?lhs \<Longrightarrow> ?rhs")
proof -
  assume ?lhs
  then obtain xs
    where "set xs \<subseteq> S \<and> n = length xs"
      and dxs: "distinct xs" by (unfold has_def hasw_def, blast)
  with card_mono[OF finiteS] distinct_card[OF dxs, symmetric]
  show ?rhs by simp
qed

lemma has_0: "has 0 S" by (simp add: has_def)

lemma has_suc_subset: "has (Suc n) S \<Longrightarrow> {} \<subset> S"
  by (rule psubsetI, (simp add: has_suc_notempty)+)

lemma has_notempty_1:
  assumes Sne: "S \<noteq> {}"
  shows "has 1 S"
proof -
  from Sne obtain x where "x \<in> S" by blast
  hence "set [x] \<subseteq> S \<and> distinct [x] \<and> length [x] = 1" by auto
  thus ?thesis by (unfold has_def hasw_def, blast)
qed

lemma has_le_has:
  assumes h: "has n S"
      and nn': "n' \<le> n"
  shows "has n' S"
proof -
  from h obtain xs where "hasw xs S" "length xs = n" by (unfold has_def, blast)
  with nn' set_take_subset[where n="n'" and xs="xs"]
  have "hasw (take n' xs) S" "length (take n' xs) = n'"
    by (simp_all add: min_def, blast+)
  thus ?thesis by (unfold has_def, blast)
qed

lemma has_ge_has_not:
  assumes h: "\<not>has n S"
      and nn': "n \<le> n'"
  shows "\<not>has n' S"
  using h nn' by (blast dest: has_le_has)

lemma has_eq:
  assumes h: "has n S"
      and hn': "\<not>has (Suc n) S"
  shows "card S = n"
proof -
  from h obtain xs
    where xs: "hasw xs S" and lenxs: "length xs = n" by (unfold has_def, blast)
  have "set xs = S"
  proof
    from xs show "set xs \<subseteq> S" by simp
  next
    show "S \<subseteq> set xs"
    proof(rule ccontr)
      assume "\<not> S \<subseteq> set xs"
      then obtain x where "x \<in> S" "x \<notin> set xs" by blast
      with lenxs xs have "hasw (x # xs) S" "length (x # xs) = Suc n" by simp_all
      with hn' show False by (unfold has_def, blast)
    qed
  qed
  with xs lenxs distinct_card show "card S = n" by auto
qed

lemma has_extend_witness:
  assumes h: "has n S"
  shows "\<lbrakk> set xs \<subseteq> S; length xs < n \<rbrakk> \<Longrightarrow> set xs \<subset> S"
proof(induct xs)
  case Nil
  with h has_suc_notempty show ?case by (cases n, auto)
next
  case (Cons x xs)
  have "set (x # xs) \<noteq> S"
  proof
    assume Sxxs: "set (x # xs) = S"
    hence finiteS: "finite S" by auto
    from h obtain xs'
      where Sxs': "set xs' \<subseteq> S"
        and dlxs': "distinct xs' \<and> length xs' = n"
      by (unfold has_def hasw_def, blast)
    with distinct_card have "card (set xs') = n" by auto
    with finiteS Sxs' card_mono have "card S \<ge> n" by auto
    moreover
    from Sxxs Cons card_length[where xs="x # xs"]
    have "card S < n" by auto
    ultimately show False by simp
  qed
  with Cons show ?case by auto
qed

lemma has_extend_witness':
  "\<lbrakk> has n S; hasw xs S; length xs < n \<rbrakk> \<Longrightarrow> \<exists>x. hasw (x # xs) S"
  by (simp, blast dest: has_extend_witness)

lemma has_witness_two:
  assumes hasnS: "has n S"
      and nn': "2 \<le> n"
  shows "\<exists>x y. hasw [x,y] S"
proof -
  have has2S: "has 2 S" by (rule has_le_has[OF hasnS nn'])
  from has_extend_witness'[OF has2S, where xs="[]"]
  obtain x where "x \<in> S" by auto
  with has_extend_witness'[OF has2S, where xs="[x]"]
  show ?thesis by auto
qed

lemma has_witness_three:
  assumes hasnS: "has n S"
      and nn': "3 \<le> n"
  shows "\<exists>x y z. hasw [x,y,z] S"
proof -
  from nn' obtain x y where "hasw [x,y] S"
    using has_witness_two[OF hasnS] by auto
  with nn' show ?thesis
    using has_extend_witness'[OF hasnS, where xs="[x,y]"] by auto
qed

lemma finite_set_singleton_contra:
  assumes finiteS: "finite S"
      and Sne: "S \<noteq> {}"
      and cardS: "card S > 1 \<Longrightarrow> False"
  shows "\<exists>j. S = {j}"
proof -
  from cardS Sne card_0_eq[OF finiteS] have Scard: "card S = 1" by auto
  from has_extend_witness[where xs="[]", OF card_has[OF this]]
  obtain j where "{j} \<subseteq> S" by auto
  from card_seteq[OF finiteS this] Scard show ?thesis by auto
qed

(*<*)
end
(*>*)


(* Author: Tobias Nipkow *)

theory Radix_Sort
imports
  "HOL-Library.List_Lexorder"
  "HOL-Library.Sublist"
  "HOL-Library.Multiset"
begin

text \<open>The \<open>Radix_Sort\<close> locale provides a sorting function \<open>radix_sort\<close> that sorts
lists of lists. It is parameterized by a sorting function \<open>sort1 f\<close> that also sorts
lists of lists, but only w.r.t. the column selected by \<open>f\<close>.
Working with lists, \<open>f\<close> is instantiated with \<^term>\<open>\<lambda>xs. xs ! n\<close> to select the \<open>n\<close>-th element.
A more efficient implementation would sort lists of arrays because arrays support
constant time access to every element.\<close>

locale Radix_Sort =
fixes sort1 :: "('a list \<Rightarrow> 'a::linorder) \<Rightarrow> 'a list list \<Rightarrow> 'a list list"
assumes sorted: "sorted (map f (sort1 f xss))"
assumes mset: "mset (sort1 f xss) = mset xss"
assumes stable: "stable_sort_key sort1"
begin

lemma set_sort1[simp]: "set(sort1 f xss) = set xss"
by (metis mset set_mset_mset)

abbreviation "sort_col i xss \<equiv> sort1 (\<lambda>xs. xs ! i) xss"
abbreviation "sorted_col i xss \<equiv> sorted (map (\<lambda>xs. xs ! i) xss)"

fun radix_sort :: "nat \<Rightarrow> 'a list list \<Rightarrow> 'a list list" where
"radix_sort 0 xss = xss" |
"radix_sort (Suc i) xss = radix_sort i (sort_col i xss)"

lemma mset_radix_sort: "mset (radix_sort i xss) = mset xss"
by(induction i arbitrary: xss) (auto simp: mset)

abbreviation "sorted_from i xss \<equiv> sorted (map (drop i) xss)"

definition "cols xss n = (\<forall>xs \<in> set xss. length xs = n)"

lemma cols_sort1: "cols xss n \<Longrightarrow> cols (sort1 f xss) n"
by(simp add: cols_def)

lemma sorted_from_Suc2:
  "\<lbrakk> cols xss n; i < n;
    sorted_col i xss;
    \<And>x. sorted_from (i+1) [ys \<leftarrow> xss. ys!i = x] \<rbrakk>
  \<Longrightarrow> sorted_from i xss"
proof(induction xss rule: induct_list012)
  case 1 show ?case by simp
next
  case 2 show ?case by simp
next
  case (3 xs1 xs2 xss)
  have lxs1: "length xs1 = n" and lxs2: "length xs2 = n"
    using "3.prems"(1) by(auto simp: cols_def)
  have *: "drop i xs1 \<le> drop i xs2"
  proof -
    have "drop i xs1 = xs1!i # drop (i+1) xs1"
      using \<open>i < n\<close> by (simp add: Cons_nth_drop_Suc lxs1)
    also have "\<dots> \<le> xs2!i # drop (i+1) xs2"
      using "3.prems"(3) "3.prems"(4)[of "xs2!i"] by(auto)
    also have "\<dots> = drop i xs2"
      using \<open>i < n\<close> by (simp add: Cons_nth_drop_Suc lxs2)
    finally show ?thesis .
  qed
  have "sorted_from i (xs2 # xss)"
  proof(rule "3.IH"[OF _ "3.prems"(2)])
    show "cols (xs2 # xss) n" using "3.prems"(1) by(simp add: cols_def)
    show "sorted_col i (xs2 # xss)" using "3.prems"(3) by simp
    show "\<And>x. sorted_from (i+1) [ys\<leftarrow>xs2 # xss . ys ! i = x]"
      using "3.prems"(4)
        sorted_antimono_suffix[OF map_mono_suffix[OF filter_mono_suffix[OF suffix_ConsI[OF suffix_order.refl]]]]
      by fastforce
  qed
  with * show ?case by (auto)
qed

lemma sorted_from_radix_sort_step:
assumes "cols xss n" and "i < n" and "sorted_from (i+1) xss"
shows "sorted_from i (sort_col i xss)"
proof (rule sorted_from_Suc2[OF cols_sort1[OF assms(1)] assms(2)])
  show "sorted_col i (sort_col i xss)" by(simp add: sorted)
  fix x show "sorted_from (i+1) [ys \<leftarrow> sort_col i xss . ys ! i = x]"
  proof -
    from assms(3)
    have "sorted_from (i+1) (filter (\<lambda>ys. ys!i = x) xss)"
      by(rule sorted_filter)
    thus "sorted (map (drop (i+1)) (filter (\<lambda>ys. ys!i = x) (sort_col i xss)))"
      by (metis stable stable_sort_key_def)
  qed
qed

lemma sorted_from_radix_sort:
  "\<lbrakk> cols xss n;  i \<le> n;  sorted_from i xss \<rbrakk> \<Longrightarrow> sorted_from 0 (radix_sort i xss)"
proof(induction i arbitrary: xss)
  case 0 thus ?case by simp
next
  case (Suc i)
  thus ?case by(simp add: sorted_from_radix_sort_step cols_sort1)
qed

corollary sorted_radix_sort: "cols xss n \<Longrightarrow> sorted (radix_sort n xss)"
apply(frule sorted_from_radix_sort[OF _ le_refl])
 apply(auto simp add: cols_def sorted_iff_nth_mono)
done

end

end


(* Title:      Infinite Matrix Model of Kleene Algebra
   Author:     Alasdair Armstrong, Georg Struth, Tjark Weber
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
               Tjark Weber <tjark.weber at it.uu.se>
*)

section \<open>Infinite Matrices\<close>

theory Inf_Matrix
imports Finite_Suprema
begin

text \<open>Matrices are functions from two index sets into some suitable
algebra. We consider arbitrary index sets, not necessarily the
positive natural numbers up to some bounds; our coefficient algebra is
a dioid. Our only restriction is that summation in the product of
matrices is over a finite index set. This follows essentially Droste
and Kuich's introductory article in the Handbook of Weighted Automata~\<^cite>\<open>"weightedautomata09"\<close>.

Under these assumptions we show that dioids are closed under matrix
formation. Our proofs are similar to those for formal power series,
but simpler.\<close>

type_synonym ('a, 'b, 'c) matrix = "'a \<Rightarrow> 'b \<Rightarrow> 'c"

definition mat_one :: "('a, 'a, 'c::dioid_one_zero) matrix" ("\<epsilon>") where
  "\<epsilon> i j \<equiv> (if (i = j) then 1 else 0)"

definition mat_zero :: "('a, 'b, 'c::dioid_one_zero) matrix" ("\<delta>") where
  "\<delta> \<equiv> \<lambda>j i. 0"

definition mat_add :: "('a, 'b, 'c::dioid_one_zero) matrix \<Rightarrow> ('a, 'b, 'c) matrix \<Rightarrow> ('a, 'b, 'c) matrix" (infixl "\<oplus>" 70) where
  "(f \<oplus> g)  \<equiv> \<lambda>i j. (f i j) + (g i j)"

lemma mat_add_assoc: "(f \<oplus> g) \<oplus> h =  f \<oplus> (g \<oplus> h)"
  by (auto simp add: mat_add_def join.sup_assoc)

lemma mat_add_idem[simp]: "f \<oplus> f = f"
  by (auto simp add: mat_add_def)

lemma mat_zerol[simp]: "f \<oplus> \<delta> = f"
  by (auto simp add: mat_add_def mat_zero_def)

lemma mat_zeror[simp]: "\<delta> \<oplus> f = f"
  by (auto simp add: mat_add_def mat_zero_def)

definition mat_mult :: "('a, 'k::finite, 'c::dioid_one_zero) matrix \<Rightarrow> ('k, 'b, 'c) matrix \<Rightarrow> ('a, 'b, 'c) matrix" (infixl "\<otimes>" 60) where
  "(f \<otimes> g) i j  \<equiv> \<Sum> {(f i k) \<cdot> (g k j) | k. k \<in> UNIV}"

lemma mat_annil[simp]: "\<delta> \<otimes> f = \<delta>"
  by (rule ext, auto simp add: mat_mult_def mat_zero_def)

lemma mat_annir[simp]: "f \<otimes> \<delta>  = \<delta>"
  by (rule ext, auto simp add: mat_mult_def mat_zero_def)

lemma mat_distl: "f \<otimes> (g \<oplus> h) = (f \<otimes> g) \<oplus> (f \<otimes> h)"
proof -
  {
    fix i j
    have "(f \<otimes> (g \<oplus> h)) i j  = \<Sum>{f i k \<cdot> (g k j + h k j) |k. k \<in> UNIV}"
      by (simp only: mat_mult_def mat_add_def)
    also have "... = \<Sum>{f i k \<cdot> g k j + f i k \<cdot> h k j |k. k \<in> UNIV}"
      by (simp only: distrib_left)
    also have "... = \<Sum>{f i k \<cdot> g k j |k. k \<in> UNIV} + \<Sum>{f i k \<cdot> h k j |k. k \<in> UNIV}"
      by (simp only: fset_to_im sum_fun_sum finite_UNIV)
    finally have "(f \<otimes> (g \<oplus> h)) i j  = ((f \<otimes> g) \<oplus> (f \<otimes> h)) i j"
      by (simp only: mat_mult_def mat_add_def)
  }
  thus ?thesis
    by auto
qed

lemma mat_distr: "(f \<oplus> g) \<otimes> h = (f \<otimes> h) \<oplus> (g \<otimes> h)"
proof -
  {
    fix i j
    have "((f \<oplus> g) \<otimes> h) i j  = \<Sum>{(f i k + g i k) \<cdot> h k j |k. k \<in> UNIV}"
      by (simp only: mat_mult_def mat_add_def)
    also have "... = \<Sum>{f i k \<cdot> h k j + g i k \<cdot> h k j |k. k \<in> UNIV}"
      by (simp only: distrib_right)
    also have "... = \<Sum>{f i k \<cdot> h k j |k. k \<in> UNIV} + \<Sum>{g i k \<cdot> h k j |k. k \<in> UNIV}"
      by (simp only: fset_to_im sum_fun_sum finite_UNIV)
    finally have "((f \<oplus> g) \<otimes> h) i j  = ((f \<otimes> h) \<oplus> (g \<otimes> h)) i j"
      by (simp only: mat_mult_def mat_add_def)
  }
  thus ?thesis
    by auto
qed

lemma logic_aux1: "(\<exists>k. (i = k \<longrightarrow> x = f i j) \<and> (i \<noteq> k \<longrightarrow> x = 0)) \<longleftrightarrow> (\<exists>k. i = k \<and> x = f i j) \<or> (\<exists>k. i \<noteq> k \<and> x = 0)"
  by blast

lemma logic_aux2: "(\<exists>k. (k = j \<longrightarrow> x = f i j) \<and> (k \<noteq> j \<longrightarrow> x = 0)) \<longleftrightarrow> (\<exists>k. k = j \<and> x = f i j) \<or> (\<exists>k. k \<noteq> j \<and> x = 0)"
  by blast

lemma mat_onel[simp]: "\<epsilon> \<otimes> f = f"
proof -
  {
    fix i j
    have "(\<epsilon> \<otimes> f) i j = \<Sum>{x. (\<exists>k. (i = k \<longrightarrow> x = f i j) \<and> (i \<noteq> k \<longrightarrow> x = 0))}"
      by (auto simp add: mat_mult_def mat_one_def)
    also have "... = \<Sum>({x. \<exists>k. (i = k \<and> x = f i j)} \<union> {x. \<exists>k. (i \<noteq> k \<and> x = 0)})"
      by (simp only: Collect_disj_eq logic_aux1)
    also have "... = \<Sum>{x. \<exists>k. (i = k \<and> x = f i j)} + \<Sum>{x. \<exists>k. (i \<noteq> k \<and> x = 0)}"
      by (rule sum_union, auto)
    finally have "(\<epsilon> \<otimes> f) i j = f i j"
      by (auto simp add: sum.neutral)
  }
  thus ?thesis
    by auto
qed

lemma mat_oner[simp]: "f \<otimes> \<epsilon> = f"
proof -
  {
    fix i j
    have "(f \<otimes> \<epsilon>) i j = \<Sum>{x. (\<exists>k. (k = j \<longrightarrow> x = f i j) \<and> (k \<noteq> j \<longrightarrow> x = 0))}"
      by (auto simp add: mat_mult_def mat_one_def)
    also have "... = \<Sum>({x. \<exists>k. (k = j \<and> x = f i j)} \<union> {x. \<exists>k. (k \<noteq> j \<and> x = 0)})"
      by (simp only: Collect_disj_eq logic_aux2)
    also have "... = \<Sum>{x. \<exists>k. (k = j \<and> x = f i j)} + \<Sum>{x. \<exists>k. (k \<noteq> j \<and> x = 0)}"
      by (rule sum_union, auto)
    finally have "(f \<otimes> \<epsilon>) i j = f i j"
      by (auto simp add: sum.neutral)
  }
  thus ?thesis
    by auto
qed

lemma mat_rearrange:
  fixes F :: "'a \<Rightarrow> 'k1 \<Rightarrow> 'k2 \<Rightarrow> 'b \<Rightarrow> 'c::dioid_one_zero"
  assumes fUNk1: "finite (UNIV::'k1 set)"
  assumes fUNk2: "finite (UNIV::'k2 set)"
  shows "\<Sum>{\<Sum>{F i k1 k2 j |k2. k2 \<in> (UNIV::'k2 set)} |k1. k1 \<in> (UNIV::'k1 set)} = \<Sum>{\<Sum>{F i k1 k2 j |k1. k1 \<in> UNIV} |k2. k2 \<in> UNIV}"
proof -
  {
    fix z :: 'c
    let ?lhs = "\<Sum>{\<Sum>{F i k1 k2 j |k2. k2 \<in> UNIV} |k1. k1 \<in> UNIV}"
    let ?rhs = "\<Sum>{\<Sum>{F i k1 k2 j |k1. k1 \<in> UNIV} |k2. k2 \<in> UNIV}"
    have "?lhs \<le> z \<longleftrightarrow> (\<forall>k1 k2. F i k1 k2 j \<le> z)"
      by (simp only: fset_to_im sum_fun_image_sup fUNk1 fUNk2, auto)
    hence "?lhs \<le> z \<longleftrightarrow> ?rhs \<le> z"
      by (simp only: fset_to_im sum_fun_image_sup fUNk1 fUNk2, auto)
  }
  thus ?thesis
    by (simp add: eq_iff)
qed

lemma mat_mult_assoc: "f \<otimes> (g \<otimes> h) = (f \<otimes> g) \<otimes> h"
proof -
  {
    fix i j
    have "(f \<otimes> (g \<otimes> h)) i j = \<Sum>{f i k1 \<cdot> \<Sum>{g k1 k2 \<cdot> h k2 j |k2. k2 \<in> UNIV} |k1. k1 \<in> UNIV}"
      by (simp only: mat_mult_def)
    also have "... = \<Sum>{\<Sum>{f i k1 \<cdot> g k1 k2 \<cdot> h k2 j |k2. k2 \<in> UNIV} |k1. k1 \<in> UNIV}"
      by (simp only: fset_to_im sum_fun_distl finite_UNIV mult.assoc)
    also have "... = \<Sum>{\<Sum>{(f i k1 \<cdot> g k1 k2) \<cdot> h k2 j|k1. k1 \<in> UNIV} |k2. k2 \<in> UNIV}"
      by (rule mat_rearrange, auto simp add: finite_UNIV)
    also have "... = \<Sum>{\<Sum>{f i k1 \<cdot> g k1 k2 |k1. k1 \<in> UNIV} \<cdot> h k2 j |k2. k2 \<in> UNIV}"
      by (simp only: fset_to_im sum_fun_distr finite_UNIV)
    finally have "(f \<otimes> (g \<otimes> h)) i j  = ((f \<otimes> g) \<otimes> h) i j "
      by (simp only: mat_mult_def)
  }
  thus ?thesis
    by auto
qed

definition mat_less_eq :: "('a, 'b, 'c::dioid_one_zero) matrix \<Rightarrow> ('a, 'b, 'c) matrix \<Rightarrow> bool" where
  "mat_less_eq f g   = (f \<oplus> g  = g)"

definition mat_less :: "('a, 'b, 'c::dioid_one_zero) matrix \<Rightarrow> ('a, 'b, 'c) matrix \<Rightarrow> bool" where
  "mat_less f g  = (mat_less_eq f g \<and> f \<noteq> g)"

interpretation matrix_dioid: dioid_one_zero  mat_add mat_mult mat_one mat_zero mat_less_eq mat_less
  by (unfold_locales) (metis mat_add_assoc mat_add_comm mat_mult_assoc[symmetric] mat_distr mat_onel mat_oner mat_zeror mat_annil mat_annir mat_less_eq_def mat_less_def mat_add_idem mat_distl)+

text \<open>As in the case of formal power series we currently do not
implement the Kleene star of matrices, since this is complicated.\<close>

end