(*
   Authors: Asta Halkjær From, Agnes Moesgård Eschen & Jørgen Villadsen, DTU Compute
*)

theory System_L1 imports Main begin

text \<open>System L1 from Jan Lukasiewicz: Elements of Mathematical Logic (English Tr. 1963)\<close>

text \<open>thesXX derivations are taken from the above book\<close>

section \<open>Syntax / Axiomatics / Semantics\<close>

datatype form = Pro nat (\<open>\<cdot>\<close>) | Neg form (\<open>\<sim>\<close>) | Imp form form (infix \<open>\<rightarrow>\<close> 0)

inductive Axiomatics (\<open>\<turnstile>\<close>) where
  \<open>\<turnstile> q\<close> if \<open>\<turnstile> p\<close> and \<open>\<turnstile> (p \<rightarrow> q)\<close> |
  \<open>\<turnstile> ((p \<rightarrow> q) \<rightarrow> ((q \<rightarrow> r) \<rightarrow> (p \<rightarrow> r)))\<close> |
  \<open>\<turnstile> (((\<sim> p) \<rightarrow> p) \<rightarrow> p)\<close> |
  \<open>\<turnstile> (p \<rightarrow> ((\<sim> p) \<rightarrow> q))\<close>

abbreviation Truth (\<open>\<top>\<close>) where \<open>\<top> \<equiv> (undefined \<rightarrow> undefined)\<close>

theorem \<open>\<turnstile> \<top>\<close> using Axiomatics.intros by metis

primrec semantics (infix \<open>\<Turnstile>\<close> 0) where
  \<open>(I \<Turnstile> \<cdot> n) = I n\<close> |
  \<open>(I \<Turnstile> \<sim> p) = (if I \<Turnstile> p then False else True)\<close> |
  \<open>(I \<Turnstile> (p \<rightarrow> q)) = (if I \<Turnstile> p then (I \<Turnstile> q) else True)\<close>

theorem \<open>I \<Turnstile> p\<close> if \<open>\<turnstile> p\<close> using that by induct auto

definition \<open>valid p \<equiv> \<forall>I. (I \<Turnstile> p)\<close>

theorem \<open>valid p = \<turnstile> p\<close> oops \<comment> \<open>Proof at end\<close>

abbreviation Falsity (\<open>\<bottom>\<close>) where \<open>\<bottom> \<equiv> \<sim> \<top>\<close>

theorem \<open>\<turnstile> (\<bottom> \<rightarrow> p)\<close> using Axiomatics.intros by metis

lemmas MP = Axiomatics.intros(1)
lemmas Trans = Axiomatics.intros(2)
lemmas Cont1 = Axiomatics.intros(3)
lemmas Cont2 = Axiomatics.intros(4)

section \<open>Soundness\<close>

theorem L1_soundness: \<open>\<turnstile> p \<Longrightarrow> I \<Turnstile> p\<close>
  by (induct rule: Axiomatics.induct) auto

section \<open>Derived Rules\<close>

lemma thes04: \<open>\<turnstile> ((((q \<rightarrow> r) \<rightarrow> (p \<rightarrow> r)) \<rightarrow> s) \<rightarrow> ((p \<rightarrow> q) \<rightarrow> s))\<close>
  using MP Trans by metis

lemma thes05: \<open>\<turnstile> ((p \<rightarrow> (q \<rightarrow> r)) \<rightarrow> ((s \<rightarrow> q) \<rightarrow> (p \<rightarrow> (s \<rightarrow> r))))\<close>
  using MP thes04 by metis

lemma thes06: \<open>\<turnstile> ((p \<rightarrow> q) \<rightarrow> (((p \<rightarrow> r) \<rightarrow> s) \<rightarrow> ((q \<rightarrow> r) \<rightarrow> s)))\<close>
  using MP Trans thes04 by metis

lemma thes07: \<open>\<turnstile> ((t \<rightarrow> ((p \<rightarrow> r) \<rightarrow> s)) \<rightarrow> ((p \<rightarrow> q) \<rightarrow> (t \<rightarrow> ((q \<rightarrow> r) \<rightarrow> s))))\<close>
  using MP thes05 thes06 by metis

lemma thes09: \<open>\<turnstile> ((((\<sim> p) \<rightarrow> q) \<rightarrow> r) \<rightarrow> (p \<rightarrow> r))\<close>
  using MP Trans Cont2 by metis

lemma thes10: \<open>\<turnstile> (p \<rightarrow> ((((\<sim> p) \<rightarrow> p) \<rightarrow> p) \<rightarrow> ((q \<rightarrow> p) \<rightarrow> p)))\<close>
  using MP thes06 thes09 by metis

lemma thes11: \<open>\<turnstile> ((q \<rightarrow> (((\<sim> p) \<rightarrow> p) \<rightarrow> p)) \<rightarrow> (((\<sim> p) \<rightarrow> p) \<rightarrow> p))\<close>
  using MP Cont1 thes10 by metis

lemma thes12: \<open>\<turnstile> (t \<rightarrow> (((\<sim> p) \<rightarrow> p) \<rightarrow> p))\<close>
  using MP thes09 thes11 by metis

lemma thes13: \<open>\<turnstile> (((\<sim> p) \<rightarrow> q) \<rightarrow> (t \<rightarrow> ((q \<rightarrow> p) \<rightarrow> p)))\<close>
  using MP thes07 thes12 by metis

lemma thes14: \<open>\<turnstile> (((t \<rightarrow> ((q \<rightarrow> p) \<rightarrow> p)) \<rightarrow> r) \<rightarrow> (((\<sim> p) \<rightarrow> q) \<rightarrow> r))\<close>
  using MP Trans thes13 by metis

lemma thes15: \<open>\<turnstile> (((\<sim> p) \<rightarrow> q) \<rightarrow> ((q \<rightarrow> p) \<rightarrow> p))\<close>
  using MP Cont1 thes14 by metis

lemma thes16: \<open>\<turnstile> (p \<rightarrow> p)\<close>
  using MP thes09 Cont1 by metis

lemma thes17: \<open>\<turnstile> (p \<rightarrow> ((q \<rightarrow> p) \<rightarrow> p))\<close>
  using MP thes09 thes15 by metis

lemma thes18: \<open>\<turnstile> (q \<rightarrow> (p \<rightarrow> q))\<close>
  using MP Cont2 thes05 thes17 by metis

lemma thes19: \<open>\<turnstile> (((p \<rightarrow> q) \<rightarrow> r) \<rightarrow> (q \<rightarrow> r))\<close>
  using MP Trans thes18 by metis

lemma thes20: \<open>\<turnstile> (p \<rightarrow> ((p \<rightarrow> q) \<rightarrow> q))\<close>
  using MP thes15 thes19 by metis

lemma thes21: \<open>\<turnstile> ((p \<rightarrow> (q \<rightarrow> r)) \<rightarrow> (q \<rightarrow> (p \<rightarrow> r)))\<close>
  using MP thes05 thes20 by metis

lemma thes22: \<open>\<turnstile> ((q \<rightarrow> r) \<rightarrow> ((p \<rightarrow> q) \<rightarrow> (p \<rightarrow> r)))\<close>
  using MP Trans thes21 by metis

lemma thes23: \<open>\<turnstile> (((q \<rightarrow> (p \<rightarrow> r)) \<rightarrow> s) \<rightarrow> ((p \<rightarrow> (q \<rightarrow> r)) \<rightarrow> s))\<close>
  using MP Trans thes21 by metis

lemma thes24: \<open>\<turnstile> ((((p \<rightarrow> q) \<rightarrow> p) \<rightarrow> p))\<close>
  using MP Cont2 thes15 thes23 by metis

lemma thes25: \<open>\<turnstile> (((p \<rightarrow> r) \<rightarrow> s) \<rightarrow> ((p \<rightarrow> q) \<rightarrow> ((q \<rightarrow> r) \<rightarrow> s)))\<close>
  using MP thes06 thes21 by metis

lemma thes26: \<open>\<turnstile> (((p \<rightarrow> q) \<rightarrow> r) \<rightarrow> ((r \<rightarrow> p) \<rightarrow> p))\<close>
  using MP thes24 thes25 by metis

lemma thes28: \<open>\<turnstile> ((((r \<rightarrow> p) \<rightarrow> p) \<rightarrow> s) \<rightarrow> (((p \<rightarrow> q) \<rightarrow> r) \<rightarrow> s))\<close>
  using MP Trans thes26 by metis

lemma thes29: \<open>\<turnstile> (((p \<rightarrow> q) \<rightarrow> r) \<rightarrow> ((p \<rightarrow> r) \<rightarrow> r))\<close>
  using MP thes26 thes28 by metis

lemma thes31: \<open>\<turnstile> ((p \<rightarrow> s) \<rightarrow> (((p \<rightarrow> q) \<rightarrow> r) \<rightarrow> ((s \<rightarrow> r) \<rightarrow> r)))\<close>
  using MP thes07 thes29 by metis

lemma thes32: \<open>\<turnstile> (((p \<rightarrow> q) \<rightarrow> r) \<rightarrow> ((p \<rightarrow> s) \<rightarrow> ((s \<rightarrow> r) \<rightarrow> r)))\<close>
  using MP thes21 thes31 by metis

lemma thes33: \<open>\<turnstile> ((p \<rightarrow> s) \<rightarrow> ((s \<rightarrow> (q \<rightarrow> (p \<rightarrow> r))) \<rightarrow> (q \<rightarrow> (p \<rightarrow> r))))\<close>
  using MP thes18 thes32 by metis

lemma thes34: \<open>\<turnstile> ((s \<rightarrow> (q \<rightarrow> (p \<rightarrow> r))) \<rightarrow> ((p \<rightarrow> s) \<rightarrow> (q \<rightarrow> (p \<rightarrow> r))))\<close>
  using MP thes21 thes33 by metis

lemma thes35: \<open>\<turnstile> ((p \<rightarrow> (q \<rightarrow> r)) \<rightarrow> ((p \<rightarrow> q) \<rightarrow> (p \<rightarrow> r)))\<close>
  using MP thes22 thes34 by metis

lemma thes36: \<open>\<turnstile> ((\<sim> p) \<rightarrow> (p \<rightarrow> q))\<close>
  using MP Cont2 thes21 by metis

lemma thes37: \<open>\<turnstile> (((p \<rightarrow> q) \<rightarrow> r) \<rightarrow> ((\<sim> p) \<rightarrow> r))\<close>
  using MP Trans thes36 by metis

lemma thes39: \<open>\<turnstile> ((\<sim> (\<sim> p)) \<rightarrow> p)\<close>
  using MP Cont1 thes37 by metis

lemma thes41: \<open>\<turnstile> ((p \<rightarrow> q) \<rightarrow> ((\<sim> (\<sim> p)) \<rightarrow> q))\<close>
  using MP Trans thes39 by metis

lemma thes42: \<open>\<turnstile> ((((\<sim> (\<sim> p))\<rightarrow> q) \<rightarrow> r) \<rightarrow> ((p \<rightarrow> q) \<rightarrow> r))\<close>
  using MP Trans thes41 by metis

lemma thes43: \<open>\<turnstile> ((p \<rightarrow> q) \<rightarrow> ((q \<rightarrow> (\<sim> p)) \<rightarrow> (\<sim> p)))\<close>
  using MP thes15 thes42 by metis

lemma thes44: \<open>\<turnstile> ((s \<rightarrow> (q \<rightarrow> (\<sim> p))) \<rightarrow> ((p \<rightarrow> q) \<rightarrow> (s \<rightarrow> (\<sim> p))))\<close>
  using MP thes05 thes43 by metis

lemma thes45: \<open>\<turnstile> ((s \<rightarrow> (q \<rightarrow> p)) \<rightarrow> (((\<sim> p) \<rightarrow> q) \<rightarrow> (s \<rightarrow> p)))\<close>
  using MP thes05 thes15 by metis

lemma thes46: \<open>\<turnstile> ((p \<rightarrow> q) \<rightarrow> ((\<sim> q) \<rightarrow> (\<sim> p)))\<close>
  using MP thes36 thes44 by metis

lemma thes47: \<open>\<turnstile> ((p \<rightarrow> (\<sim> q)) \<rightarrow> (q \<rightarrow> (\<sim> p)))\<close>
  using MP Cont2 thes44 by metis

lemma thes48: \<open>\<turnstile> (((\<sim> p) \<rightarrow> q) \<rightarrow> ((\<sim> q) \<rightarrow> p))\<close>
  using MP thes36 thes45 by metis

lemma thes66: \<open>\<turnstile> ((\<sim> (p \<rightarrow> q)) \<rightarrow> p)\<close>
  using MP thes36 thes48 by metis

lemma thes67: \<open>\<turnstile> ((\<sim> (p \<rightarrow> q)) \<rightarrow> \<sim> q)\<close>
  using MP thes18 thes46 by metis

lemma \<sim>: \<open>\<turnstile> ((p \<rightarrow> \<bottom>) \<rightarrow> \<sim> p)\<close>
  using MP thes21 thes16 thes47 by metis

primrec imply :: \<open>form list \<Rightarrow> form \<Rightarrow> form\<close> where
  \<open>imply [] q = q\<close>
| \<open>imply (p # ps) q = (p \<rightarrow> imply ps q)\<close>

lemma imply_head: \<open>\<turnstile> (imply (p # ps) p)\<close>
  by (induct ps) (simp add: thes16, metis MP Trans thes18 imply.simps(2))

lemma imply_Cons: \<open>\<turnstile> (imply ps q) \<Longrightarrow> \<turnstile> (imply (p # ps) q)\<close>
  using MP thes18 imply.simps(2) by metis

lemma imply_mem: \<open>p \<in> set ps \<Longrightarrow> \<turnstile> (imply ps p)\<close>
  using imply_head imply_Cons by (induct ps) auto

lemma imply_MP: \<open>\<turnstile> (imply ps p \<rightarrow> (imply ps (p \<rightarrow> q) \<rightarrow> imply ps q))\<close>
  using imply.simps by (induct ps) (metis thes20, metis MP Trans thes35 thes21)

lemma imply_mp': \<open>\<turnstile> (imply ps p) \<Longrightarrow> \<turnstile> (imply ps (p \<rightarrow> q)) \<Longrightarrow> \<turnstile> (imply ps q)\<close>
  using imply_MP by (meson MP)

lemma add_imply: \<open>\<turnstile> q \<Longrightarrow> \<turnstile> (imply ps q)\<close>
  using imply_Cons by (induct ps) simp_all

lemma imply_append: \<open>imply (ps @ qs) r = imply ps (imply qs r)\<close>
  by (induct ps) simp_all

lemma imply_swap: \<open>\<turnstile> (imply (ps @ qs) r) \<Longrightarrow> \<turnstile> (imply (qs @ ps) r)\<close>
proof (induct qs arbitrary: ps)
  case (Cons q qs)
  then show ?case
    by (metis imply_Cons imply_head imply_mp' imply.simps(2) imply_append)
qed simp

lemma deduct: \<open>\<turnstile> (imply (p # ps) q) \<longleftrightarrow> \<turnstile> (imply ps (p \<rightarrow> q))\<close>
  using imply_swap by (metis imply.simps(1-2) imply_append)

theorem imply_weaken: \<open>\<turnstile> (imply ps q) \<Longrightarrow> set ps \<subseteq> set ps' \<Longrightarrow> \<turnstile> (imply ps' q)\<close>
proof (induct ps arbitrary: q)
  case (Cons p ps)
  note \<open>\<turnstile> (imply (p # ps) q)\<close>
  then have \<open>\<turnstile> (imply ps (p \<rightarrow> q))\<close>
    using deduct by blast
  then have \<open>\<turnstile> (imply ps' (p \<rightarrow> q))\<close>
    using Cons by simp
  then show ?case
    using Cons(3) by (meson imply_mem imply_mp' list.set_intros(1) subset_code(1))
qed (simp add: add_imply)

lemma cut: \<open>\<turnstile> (imply ps p) \<Longrightarrow> \<turnstile> (imply (p # ps) q) \<Longrightarrow> \<turnstile> (imply ps q)\<close>
  using deduct imply_mp' by blast

lemma imply4: \<open>\<turnstile> (imply (p # q # ps) r) \<Longrightarrow> \<turnstile> (imply (q # p # ps) r)\<close>
  by (metis thes21 MP imply.simps(2))

lemma cut': \<open>\<turnstile> (imply (p # ps) r) \<Longrightarrow> \<turnstile> (imply (q # ps) p) \<Longrightarrow> \<turnstile> (imply (q # ps) r)\<close>
  using imply_Cons cut imply4 by blast

lemma imply_lift: \<open>\<turnstile> (p \<rightarrow> q) \<Longrightarrow> \<turnstile> (imply ps p \<rightarrow> imply ps q)\<close>
  by (metis thes16 add_imply imply.simps(2) imply_mp')

lemma imply_DNeg: \<open>\<turnstile> (imply ps (\<sim> (\<sim> p)) \<rightarrow> imply ps p)\<close>
  using thes39 imply_lift by simp

lemma Boole: \<open>\<turnstile> (imply ((\<sim> p) # ps) \<bottom>) \<Longrightarrow> \<turnstile> (imply ps p)\<close>
  by (meson \<sim> MP imply_DNeg deduct imply_lift)

lemma imply_front: \<open>\<turnstile> (imply S p) \<Longrightarrow> set S - {q} \<subseteq> set S' \<Longrightarrow> \<turnstile> (imply (q # S') p)\<close>
  by (metis Diff_single_insert imply_weaken list.set(2))

section \<open>Consistent\<close>

definition consistent :: \<open>form set \<Rightarrow> bool\<close> where
  \<open>consistent S \<equiv> \<nexists>S'. set S' \<subseteq> S \<and> \<turnstile> (imply S' \<bottom>)\<close>

lemma UN_finite_bound:
  assumes \<open>finite p\<close> \<open>p \<subseteq> (\<Union>n. f n)\<close>
  shows \<open>\<exists>m :: nat. p \<subseteq> (\<Union>n \<le> m. f n)\<close>
  using assms
proof (induct rule: finite_induct)
  case (insert x p)
  then obtain m where \<open>p \<subseteq> (\<Union>n \<le> m. f n)\<close>
    by fast
  then have \<open>p \<subseteq> (\<Union>n \<le> (m + k). f n)\<close> for k
    by fastforce
  moreover obtain m' where \<open>x \<in> f m'\<close>
    using insert(4) by blast
  ultimately have \<open>{x} \<union> p \<subseteq> (\<Union>n \<le> m + m'. f n)\<close>
    by auto
  then show ?case
    by blast
qed simp

section \<open>Extension\<close>

primrec extend :: \<open>form set \<Rightarrow> (nat \<Rightarrow> form) \<Rightarrow> nat \<Rightarrow> form set\<close> where
  \<open>extend S f 0 = S\<close>
| \<open>extend S f (Suc n) =
    (if consistent ({f n} \<union> extend S f n)
     then {f n} \<union> extend S f n
     else extend S f n)\<close>

definition Extend :: \<open>form set \<Rightarrow> (nat \<Rightarrow> form) \<Rightarrow> form set\<close> where
  \<open>Extend S f \<equiv> \<Union>n. extend S f n\<close>

lemma Extend_subset: \<open>S \<subseteq> Extend S f\<close>
  unfolding Extend_def by (metis Union_upper extend.simps(1) range_eqI)

lemma extend_bound: \<open>(\<Union>n \<le> m. extend S f n) = extend S f m\<close>
  by (induct m) (simp_all add: atMost_Suc)

lemma consistent_extend: \<open>consistent S \<Longrightarrow> consistent (extend S f n)\<close>
  by (induct n) simp_all

lemma consistent_Extend:
  assumes \<open>consistent S\<close>
  shows \<open>consistent (Extend S f)\<close>
  unfolding Extend_def
proof (rule ccontr)
  assume \<open>\<not> consistent (\<Union>n. extend S f n)\<close>
  then obtain S' where \<open>\<turnstile> (imply S' \<bottom>)\<close> \<open>set S' \<subseteq> (\<Union>n. extend S f n)\<close>
    unfolding consistent_def by blast
  then obtain m where \<open>set S' \<subseteq> (\<Union>n \<le> m. extend S f n)\<close>
    using UN_finite_bound by (metis List.finite_set)
  then have \<open>set S' \<subseteq> extend S f m\<close>
    using extend_bound by blast
  moreover have \<open>consistent (extend S f m)\<close>
    using assms consistent_extend by blast
  ultimately show False
    unfolding consistent_def using \<open>\<turnstile> (imply S' \<bottom>)\<close> by blast
qed

section \<open>Maximal\<close>

definition maximal :: \<open>form set \<Rightarrow> bool\<close> where
  \<open>maximal S \<equiv> \<forall>p. p \<notin> S \<longrightarrow> \<not> consistent ({p} \<union> S)\<close>

lemma maximal_Extend:
  assumes \<open>surj f\<close>
  shows \<open>maximal (Extend S f)\<close>
proof (rule ccontr)
  assume \<open>\<not> maximal (Extend S f)\<close>
  then obtain p where \<open>p \<notin> Extend S f\<close> \<open>consistent ({p} \<union> Extend S f)\<close>
    unfolding maximal_def using assms consistent_Extend by blast
  obtain k where n: \<open>f k = p\<close>
    using \<open>surj f\<close> unfolding surj_def by metis
  then have \<open>p \<notin> extend S f (Suc k)\<close>
    using \<open>p \<notin> Extend S f\<close> unfolding Extend_def by blast
  then have \<open>\<not> consistent ({p} \<union> extend S f k)\<close>
    using n by fastforce
  moreover have \<open>{p} \<union> extend S f k \<subseteq> {p} \<union> Extend S f\<close>
    unfolding Extend_def by blast
  ultimately have \<open>\<not> consistent ({p} \<union> Extend S f)\<close>
    unfolding consistent_def by fastforce
  then show False
    using \<open>consistent ({p} \<union> Extend S f)\<close> by blast
qed

section \<open>Hintikka\<close>

locale Hintikka =
  fixes H :: \<open>form set\<close>
  assumes
    NoFalsity: \<open>\<bottom> \<notin> H\<close> and
    ProP: \<open>\<cdot> n \<in> H \<Longrightarrow> (\<sim> (\<cdot> n)) \<notin> H\<close> and
    ImpP: \<open>(p \<rightarrow> q) \<in> H \<Longrightarrow> (\<sim> p) \<in> H \<or> q \<in> H\<close> and
    ImpN: \<open>(\<sim> (p \<rightarrow> q)) \<in> H \<Longrightarrow> p \<in> H \<and> (\<sim> q) \<in> H\<close> and
    NegN: \<open>(\<sim> (\<sim> p)) \<in> H \<Longrightarrow> p \<in> H\<close>

abbreviation (input) \<open>model H n \<equiv> \<cdot> n \<in> H\<close>

lemma Hintikka_model:
  \<open>Hintikka H \<Longrightarrow> (p \<in> H \<longrightarrow> (model H \<Turnstile> p)) \<and> ((\<sim> p) \<in> H \<longrightarrow> \<not> (model H \<Turnstile> p))\<close>
  by (induct p) (simp; unfold Hintikka_def, blast)+

lemma inconsistent_head:
  assumes \<open>maximal S\<close> \<open>consistent S\<close> \<open>p \<notin> S\<close>
  shows \<open>\<exists>S'. \<turnstile> (imply (p # S') \<bottom>) \<and> set S' \<subseteq> S\<close>
proof -
  obtain S' where S': \<open>\<turnstile> (imply S' \<bottom>)\<close> \<open>set S' \<subseteq> {p} \<union> S\<close> \<open>p \<in> set S'\<close>
    using assms unfolding maximal_def consistent_def by fast
  then obtain S'' where S'': \<open>\<turnstile> (imply (p # S'') \<bottom>)\<close> \<open>set S'' = set S' - {p}\<close>
    by (metis imply_front set_removeAll subset_refl)
  then show ?thesis
    using S'(2) by fast
qed

lemma Hintikka_Extend:
  assumes \<open>maximal S\<close> \<open>consistent S\<close>
  shows \<open>Hintikka S\<close>
proof
  show \<open>\<bottom> \<notin> S\<close>
    using assms(2) imply_head imply_mem unfolding consistent_def
    by (metis List.set_insert empty_set insert_Diff insert_is_Un singletonI sup.cobounded1)
next
  fix n
  assume \<open>\<cdot> n \<in> S\<close>
  moreover have \<open>\<turnstile> (imply [\<cdot> n, \<sim> (\<cdot> n)] \<bottom>)\<close>
    by (simp add: Cont2)
  ultimately show \<open>(\<sim> (\<cdot> n)) \<notin> S\<close>
    using assms(2) unfolding consistent_def
    by (metis bot.extremum empty_set insert_subset list.set(2))
next
  fix p q
  assume *: \<open>(p \<rightarrow> q) \<in> S\<close>
  show \<open>\<sim> p \<in> S \<or> q \<in> S\<close>
  proof (rule disjCI, rule ccontr)
    assume **: \<open>q \<notin> S\<close>
    then obtain Sq' where Sq': \<open>\<turnstile> (imply (q # Sq') \<bottom>)\<close> \<open>set Sq' \<subseteq> S\<close>
      using assms inconsistent_head by blast
    assume \<open>(\<sim> p) \<notin> S\<close>
    then obtain Sp' where Sp': \<open>\<turnstile> (imply ((\<sim> p) # Sp') \<bottom>)\<close> \<open>set Sp' \<subseteq> S\<close>
      using assms inconsistent_head by blast

    obtain S' where S': \<open>set S' = set Sp' \<union> set Sq'\<close>
      by (meson set_append)
    then have \<open>\<turnstile> (imply ((\<sim> p) # S') \<bottom>)\<close> \<open>\<turnstile> (imply (q # S') \<bottom>)\<close>
    proof -
      have \<open>set Sp' \<subseteq> set S'\<close>
        using S' by blast
      then show \<open>\<turnstile> (imply ((\<sim> p) # S') \<bottom>)\<close>
        by (metis Sp'(1) deduct imply_weaken)
      have \<open>set Sq' \<subseteq> set S'\<close>
        using S' by blast
      then show \<open>\<turnstile> (imply (q # S') \<bottom>)\<close>
        using ** by (metis Sq'(1) deduct imply_weaken)
    qed
    then have \<open>\<turnstile> (imply ((p \<rightarrow> q) # S') \<bottom>)\<close>
      using Boole imply_Cons imply_head imply_mp' cut' by metis
    moreover have \<open>set ((p \<rightarrow> q) # S') \<subseteq> S\<close> if \<open>q \<notin> S\<close>
      using that *(1) S' Sp'(2) Sq'(2) by auto
    ultimately show False
      using ** assms unfolding consistent_def by blast
  qed
next
  fix p q
  assume *: \<open>(\<sim> (p \<rightarrow> q)) \<in> S\<close>
  show \<open>p \<in> S \<and> (\<sim> q) \<in> S\<close>
  proof (rule conjI; rule ccontr)
    assume \<open>p \<notin> S\<close>
    then obtain S' where S': \<open>\<turnstile> (imply (p # S') \<bottom>)\<close> \<open>set S' \<subseteq> S\<close>
      using assms inconsistent_head by blast
    moreover have \<open>\<turnstile> (imply ((\<sim> (p \<rightarrow> q)) # S') p)\<close>
      using add_imply thes66 deduct by blast
    ultimately have \<open>\<turnstile> (imply ((\<sim> (p \<rightarrow> q)) # S') \<bottom>)\<close>
      using cut' by blast
    moreover have \<open>set ((\<sim> (p \<rightarrow> q)) # S') \<subseteq> S\<close>
      using *(1) S'(2) by fastforce
    ultimately show False
      using assms unfolding consistent_def by blast
  next
    assume \<open>(\<sim> q) \<notin> S\<close>
    then obtain S' where S': \<open>\<turnstile> (imply ((\<sim> q) # S') \<bottom>)\<close> \<open>set S' \<subseteq> S\<close>
      using assms inconsistent_head by blast
    moreover have \<open>\<turnstile> (imply ((\<sim> (p \<rightarrow> q)) # S') (\<sim> q))\<close>
      using add_imply thes67 deduct by blast
    ultimately have \<open>\<turnstile> (imply ((\<sim> (p \<rightarrow> q)) # S') \<bottom>)\<close>
      using cut' by blast
    moreover have \<open>set ((\<sim> (p \<rightarrow> q)) # S') \<subseteq> S\<close>
      using *(1) S'(2) by fastforce
    ultimately show False
      using assms unfolding consistent_def by blast
  qed
next
next
  fix p
  assume *: \<open>(\<sim> (\<sim> p)) \<in> S\<close>
  show \<open>p \<in> S\<close>
  proof (rule ccontr)
    assume \<open>p \<notin> S\<close>
    then obtain SNA where SNA: \<open>\<turnstile> (imply (p # SNA) \<bottom>)\<close> \<open>set SNA \<subseteq> S\<close>
      using assms inconsistent_head by blast
    from * obtain SA where SA: \<open>\<turnstile> (imply SA p)\<close> \<open>set SA \<subseteq> S\<close>
      using imply_DNeg MP
      by (metis empty_set empty_subsetI imply_head insert_absorb insert_mono list.simps(15))
    obtain S' where S': \<open>set S' = set SA \<union> set SNA\<close> \<open>set S' \<subseteq> S\<close>
      using SA(2) SNA(2) by (metis Un_subset_iff set_union)
    with SNA SA have \<open>\<turnstile> (imply (p # S') \<bottom>)\<close> \<open>\<turnstile> (imply S' p)\<close>
      using deduct imply_weaken by simp_all
    with S' assms show \<open>False\<close> unfolding consistent_def
      using cut by meson
  qed
qed

section \<open>Countable Formulas\<close>

primrec diag :: \<open>nat \<Rightarrow> (nat \<times> nat)\<close> where
  \<open>diag 0 = (0, 0)\<close>
| \<open>diag (Suc n) =
     (let (x, y) = diag n
      in case y of
          0 \<Rightarrow> (0, Suc x)
        | Suc y \<Rightarrow> (Suc x, y))\<close>

theorem diag_le1: \<open>fst (diag (Suc n)) < Suc n\<close>
  by (induct n) (simp_all add: Let_def split_def split: nat.split)

theorem diag_le2: \<open>snd (diag (Suc (Suc n))) < Suc (Suc n)\<close>
proof (induct n)
  case 0
  then show ?case by simp
next
  case (Suc n')
  then show ?case
  proof (induct n')
    case 0
    then show ?case by simp
  next
    case (Suc _)
    then show ?case
      using diag_le1 by (simp add: Let_def split_def split: nat.split)
  qed
qed

theorem diag_le3: \<open>fst (diag n) = Suc x \<Longrightarrow> snd (diag n) < n\<close>
proof (induct n)
  case 0
  then show ?case by simp
next
  case (Suc n')
  then show ?case
  proof (induct n')
    case 0
    then show ?case by simp
  next
    case (Suc n'')
    then show ?case using diag_le2 by simp
  qed
qed

theorem diag_le4: \<open>fst (diag n) = Suc x \<Longrightarrow> x < n\<close>
proof (induct n)
  case 0
  then show ?case by simp
next
  case (Suc n')
  then have \<open>fst (diag (Suc n')) < Suc n'\<close>
    using diag_le1 by blast
  then show ?case using Suc by simp
qed

function undiag :: \<open>nat \<times> nat \<Rightarrow> nat\<close> where
  \<open>undiag (0, 0) = 0\<close>
| \<open>undiag (0, Suc y) = Suc (undiag (y, 0))\<close>
| \<open>undiag (Suc x, y) = Suc (undiag (x, Suc y))\<close>
  by pat_completeness auto
termination
  by (relation \<open>measure (\<lambda>(x, y). ((x + y) * (x + y + 1)) div 2 + x)\<close>) auto

theorem diag_undiag [simp]: \<open>diag (undiag (x, y)) = (x, y)\<close>
  by (induct rule: undiag.induct) simp_all

datatype btree = Leaf nat | Branch btree btree

function diag_btree :: \<open>nat \<Rightarrow> btree\<close> where
  \<open>diag_btree n = (case fst (diag n) of
       0 \<Rightarrow> Leaf (snd (diag n))
     | Suc x \<Rightarrow> Branch (diag_btree x) (diag_btree (snd (diag n))))\<close>
  by auto
termination
  by (relation \<open>measure id\<close>) (auto intro: diag_le3 diag_le4)

primrec undiag_btree :: \<open>btree \<Rightarrow> nat\<close> where
  \<open>undiag_btree (Leaf n) = undiag (0, n)\<close>
| \<open>undiag_btree (Branch t1 t2) = undiag (Suc (undiag_btree t1), undiag_btree t2)\<close>

theorem diag_undiag_btree [simp]: \<open>diag_btree (undiag_btree t) = t\<close>
  by (induct t) simp_all

declare diag_btree.simps [simp del] undiag_btree.simps [simp del]

fun form_of_btree :: \<open>btree \<Rightarrow> form\<close> where
  \<open>form_of_btree (Leaf n) = undefined\<close>
| \<open>form_of_btree (Branch (Leaf 0) (Leaf n)) = \<cdot> n\<close>
| \<open>form_of_btree (Branch (Leaf (Suc 0)) (Branch t1 t2)) =
     Imp (form_of_btree t1) (form_of_btree t2)\<close>
| \<open>form_of_btree (Branch (Leaf 0) (Branch t _)) = \<sim> (form_of_btree t)\<close>
| \<open>form_of_btree (Branch (Leaf (Suc 0)) (Leaf _)) = undefined\<close>
| \<open>form_of_btree (Branch (Leaf (Suc (Suc _))) _) = undefined\<close>
| \<open>form_of_btree (Branch (Branch _ _) _) = undefined\<close>

primrec btree_of_form :: \<open>form \<Rightarrow> btree\<close> where
  \<open>btree_of_form (\<cdot> n) = Branch (Leaf 0) (Leaf n)\<close>
| \<open>btree_of_form (\<sim> p) = Branch (Leaf 0) (Branch (btree_of_form p) (Leaf 0))\<close>
| \<open>btree_of_form (Imp p q) = Branch (Leaf (Suc 0))
     (Branch (btree_of_form p) (btree_of_form q))\<close>

definition diag_form :: \<open>nat \<Rightarrow> form\<close> where
  \<open>diag_form n = form_of_btree (diag_btree n)\<close>

definition undiag_form :: \<open>form \<Rightarrow> nat\<close> where
  \<open>undiag_form p = undiag_btree (btree_of_form p)\<close>

theorem diag_undiag_form [simp]: \<open>diag_form (undiag_form p) = p\<close>
  unfolding diag_form_def undiag_form_def by (induct p) simp_all

abbreviation \<open>from_nat \<equiv> diag_form\<close>
abbreviation \<open>to_nat \<equiv> undiag_form\<close>

lemma surj_from_nat: \<open>surj from_nat\<close>
  by (metis diag_undiag_form surj_def)

section \<open>Completeness\<close>

lemma imply_completeness:
  assumes valid: \<open>\<forall>I s. list_all (\<lambda>q. (I \<Turnstile> q)) ps \<longrightarrow> (I \<Turnstile> p)\<close>
  shows \<open>\<turnstile> (imply ps p)\<close>
proof (rule ccontr)
  assume \<open>\<not> \<turnstile> (imply ps p)\<close>
  then have *: \<open>\<not> \<turnstile> (imply ((\<sim> p) # ps) \<bottom>)\<close>
    using Boole by blast

  let ?S = \<open>set ((\<sim> p) # ps)\<close>
  let ?H = \<open>Extend ?S from_nat\<close>

  have \<open>consistent ?S\<close>
    unfolding consistent_def using * imply_weaken by blast
  then have \<open>consistent ?H\<close> \<open>maximal ?H\<close>
    using consistent_Extend maximal_Extend surj_from_nat by blast+
  then have \<open>Hintikka ?H\<close>
    using Hintikka_Extend by blast

  have \<open>model ?H \<Turnstile> p\<close> if \<open>p \<in> ?S\<close> for p
    using that Extend_subset Hintikka_model \<open>Hintikka ?H\<close> by blast
  then have \<open>model ?H \<Turnstile> (\<sim> p)\<close> \<open>list_all (\<lambda>p. (model ?H \<Turnstile> p)) ps\<close>
    unfolding list_all_def by fastforce+
  then have \<open>model ?H \<Turnstile> p\<close>
    using valid by blast
  then show False
    using \<open>model ?H \<Turnstile> (\<sim> p)\<close> by simp
qed

theorem L1_completeness: \<open>\<forall>I. (I \<Turnstile> p) \<Longrightarrow> \<turnstile> p\<close>
  using imply_completeness[where ps=\<open>[]\<close>] by simp

section \<open>Soundness and Completeness\<close>

theorem main: \<open>valid p = \<turnstile> p\<close>
  unfolding valid_def using L1_soundness L1_completeness by blast

lemmas L1 = Axiomatics.intros main

end


(*  Title:      HOL/Library/Infinite_Set.thy
    Author:     Stephan Merz
*)

section \<open>Infinite Sets and Related Concepts\<close>

theory Infinite_Set
imports Main
begin

text \<open>The set of natural numbers is infinite.\<close>

lemma infinite_nat_iff_unbounded_le: "infinite (S::nat set) \<longleftrightarrow> (\<forall>m. \<exists>n\<ge>m. n \<in> S)"
  using frequently_cofinite[of "\<lambda>x. x \<in> S"]
  by (simp add: cofinite_eq_sequentially frequently_def eventually_sequentially)

lemma infinite_nat_iff_unbounded: "infinite (S::nat set) \<longleftrightarrow> (\<forall>m. \<exists>n>m. n \<in> S)"
  using frequently_cofinite[of "\<lambda>x. x \<in> S"]
  by (simp add: cofinite_eq_sequentially frequently_def eventually_at_top_dense)

lemma finite_nat_iff_bounded: "finite (S::nat set) \<longleftrightarrow> (\<exists>k. S \<subseteq> {..<k})"
  using infinite_nat_iff_unbounded_le[of S] by (simp add: subset_eq) (metis not_le)

lemma finite_nat_iff_bounded_le: "finite (S::nat set) \<longleftrightarrow> (\<exists>k. S \<subseteq> {.. k})"
  using infinite_nat_iff_unbounded[of S] by (simp add: subset_eq) (metis not_le)

lemma finite_nat_bounded: "finite (S::nat set) \<Longrightarrow> \<exists>k. S \<subseteq> {..<k}"
  by (simp add: finite_nat_iff_bounded)

text \<open>
  For a set of natural numbers to be infinite, it is enough to know
  that for any number larger than some \<open>k\<close>, there is some larger
  number that is an element of the set.
\<close>

lemma unbounded_k_infinite: "\<forall>m>k. \<exists>n>m. n \<in> S \<Longrightarrow> infinite (S::nat set)"
apply (clarsimp simp add: finite_nat_set_iff_bounded)
apply (drule_tac x="Suc (max m k)" in spec)
using less_Suc_eq by fastforce

lemma nat_not_finite: "finite (UNIV::nat set) \<Longrightarrow> R"
  by simp

lemma range_inj_infinite:
  "inj (f::nat \<Rightarrow> 'a) \<Longrightarrow> infinite (range f)"
proof
  assume "finite (range f)" and "inj f"
  then have "finite (UNIV::nat set)"
    by (rule finite_imageD)
  then show False by simp
qed

text \<open>The set of integers is also infinite.\<close>

lemma infinite_int_iff_infinite_nat_abs: "infinite (S::int set) \<longleftrightarrow> infinite ((nat o abs) ` S)"
  by (auto simp: transfer_nat_int_set_relations o_def image_comp dest: finite_image_absD)

proposition infinite_int_iff_unbounded_le: "infinite (S::int set) \<longleftrightarrow> (\<forall>m. \<exists>n. \<bar>n\<bar> \<ge> m \<and> n \<in> S)"
  apply (simp add: infinite_int_iff_infinite_nat_abs infinite_nat_iff_unbounded_le o_def image_def)
  apply (metis abs_ge_zero nat_le_eq_zle le_nat_iff)
  done

proposition infinite_int_iff_unbounded: "infinite (S::int set) \<longleftrightarrow> (\<forall>m. \<exists>n. \<bar>n\<bar> > m \<and> n \<in> S)"
  apply (simp add: infinite_int_iff_infinite_nat_abs infinite_nat_iff_unbounded o_def image_def)
  apply (metis (full_types) nat_le_iff nat_mono not_le)
  done

proposition finite_int_iff_bounded: "finite (S::int set) \<longleftrightarrow> (\<exists>k. abs ` S \<subseteq> {..<k})"
  using infinite_int_iff_unbounded_le[of S] by (simp add: subset_eq) (metis not_le)

proposition finite_int_iff_bounded_le: "finite (S::int set) \<longleftrightarrow> (\<exists>k. abs ` S \<subseteq> {.. k})"
  using infinite_int_iff_unbounded[of S] by (simp add: subset_eq) (metis not_le)

subsection "Infinitely Many and Almost All"

text \<open>
  We often need to reason about the existence of infinitely many
  (resp., all but finitely many) objects satisfying some predicate, so
  we introduce corresponding binders and their proof rules.
\<close>

(* The following two lemmas are available as filter-rules, but not in the simp-set *)
lemma not_INFM [simp]: "\<not> (INFM x. P x) \<longleftrightarrow> (MOST x. \<not> P x)" by (fact not_frequently)
lemma not_MOST [simp]: "\<not> (MOST x. P x) \<longleftrightarrow> (INFM x. \<not> P x)" by (fact not_eventually)

lemma INFM_const [simp]: "(INFM x::'a. P) \<longleftrightarrow> P \<and> infinite (UNIV::'a set)"
  by (simp add: frequently_const_iff)

lemma MOST_const [simp]: "(MOST x::'a. P) \<longleftrightarrow> P \<or> finite (UNIV::'a set)"
  by (simp add: eventually_const_iff)

lemma INFM_imp_distrib: "(INFM x. P x \<longrightarrow> Q x) \<longleftrightarrow> ((MOST x. P x) \<longrightarrow> (INFM x. Q x))"
  by (simp only: imp_conv_disj frequently_disj_iff not_eventually)

lemma MOST_imp_iff: "MOST x. P x \<Longrightarrow> (MOST x. P x \<longrightarrow> Q x) \<longleftrightarrow> (MOST x. Q x)"
  by (auto intro: eventually_rev_mp eventually_mono)

lemma INFM_conjI: "INFM x. P x \<Longrightarrow> MOST x. Q x \<Longrightarrow> INFM x. P x \<and> Q x"
  by (rule frequently_rev_mp[of P]) (auto elim: eventually_mono)

text \<open>Properties of quantifiers with injective functions.\<close>

lemma INFM_inj: "INFM x. P (f x) \<Longrightarrow> inj f \<Longrightarrow> INFM x. P x"
  using finite_vimageI[of "{x. P x}" f] by (auto simp: frequently_cofinite)

lemma MOST_inj: "MOST x. P x \<Longrightarrow> inj f \<Longrightarrow> MOST x. P (f x)"
  using finite_vimageI[of "{x. \<not> P x}" f] by (auto simp: eventually_cofinite)

text \<open>Properties of quantifiers with singletons.\<close>

lemma not_INFM_eq [simp]:
  "\<not> (INFM x. x = a)"
  "\<not> (INFM x. a = x)"
  unfolding frequently_cofinite by simp_all

lemma MOST_neq [simp]:
  "MOST x. x \<noteq> a"
  "MOST x. a \<noteq> x"
  unfolding eventually_cofinite by simp_all

lemma INFM_neq [simp]:
  "(INFM x::'a. x \<noteq> a) \<longleftrightarrow> infinite (UNIV::'a set)"
  "(INFM x::'a. a \<noteq> x) \<longleftrightarrow> infinite (UNIV::'a set)"
  unfolding frequently_cofinite by simp_all

lemma MOST_eq [simp]:
  "(MOST x::'a. x = a) \<longleftrightarrow> finite (UNIV::'a set)"
  "(MOST x::'a. a = x) \<longleftrightarrow> finite (UNIV::'a set)"
  unfolding eventually_cofinite by simp_all

lemma MOST_eq_imp:
  "MOST x. x = a \<longrightarrow> P x"
  "MOST x. a = x \<longrightarrow> P x"
  unfolding eventually_cofinite by simp_all

text \<open>Properties of quantifiers over the naturals.\<close>

lemma MOST_nat: "(\<forall>\<^sub>\<infinity>n. P (n::nat)) \<longleftrightarrow> (\<exists>m. \<forall>n>m. P n)"
  by (auto simp add: eventually_cofinite finite_nat_iff_bounded_le subset_eq not_le[symmetric])

lemma MOST_nat_le: "(\<forall>\<^sub>\<infinity>n. P (n::nat)) \<longleftrightarrow> (\<exists>m. \<forall>n\<ge>m. P n)"
  by (auto simp add: eventually_cofinite finite_nat_iff_bounded subset_eq not_le[symmetric])

lemma INFM_nat: "(\<exists>\<^sub>\<infinity>n. P (n::nat)) \<longleftrightarrow> (\<forall>m. \<exists>n>m. P n)"
  by (simp add: frequently_cofinite infinite_nat_iff_unbounded)

lemma INFM_nat_le: "(\<exists>\<^sub>\<infinity>n. P (n::nat)) \<longleftrightarrow> (\<forall>m. \<exists>n\<ge>m. P n)"
  by (simp add: frequently_cofinite infinite_nat_iff_unbounded_le)

lemma MOST_INFM: "infinite (UNIV::'a set) \<Longrightarrow> MOST x::'a. P x \<Longrightarrow> INFM x::'a. P x"
  by (simp add: eventually_frequently)

lemma MOST_Suc_iff: "(MOST n. P (Suc n)) \<longleftrightarrow> (MOST n. P n)"
  by (simp add: cofinite_eq_sequentially eventually_sequentially_Suc)

lemma
  shows MOST_SucI: "MOST n. P n \<Longrightarrow> MOST n. P (Suc n)"
    and MOST_SucD: "MOST n. P (Suc n) \<Longrightarrow> MOST n. P n"
  by (simp_all add: MOST_Suc_iff)

lemma MOST_ge_nat: "MOST n::nat. m \<le> n"
  by (simp add: cofinite_eq_sequentially eventually_ge_at_top)

(* legacy names *)
lemma Inf_many_def: "Inf_many P \<longleftrightarrow> infinite {x. P x}" by (fact frequently_cofinite)
lemma Alm_all_def: "Alm_all P \<longleftrightarrow> \<not> (INFM x. \<not> P x)" by simp
lemma INFM_iff_infinite: "(INFM x. P x) \<longleftrightarrow> infinite {x. P x}" by (fact frequently_cofinite)
lemma MOST_iff_cofinite: "(MOST x. P x) \<longleftrightarrow> finite {x. \<not> P x}" by (fact eventually_cofinite)
lemma INFM_EX: "(\<exists>\<^sub>\<infinity>x. P x) \<Longrightarrow> (\<exists>x. P x)" by (fact frequently_ex)
lemma ALL_MOST: "\<forall>x. P x \<Longrightarrow> \<forall>\<^sub>\<infinity>x. P x" by (fact always_eventually)
lemma INFM_mono: "\<exists>\<^sub>\<infinity>x. P x \<Longrightarrow> (\<And>x. P x \<Longrightarrow> Q x) \<Longrightarrow> \<exists>\<^sub>\<infinity>x. Q x" by (fact frequently_elim1)
lemma MOST_mono: "\<forall>\<^sub>\<infinity>x. P x \<Longrightarrow> (\<And>x. P x \<Longrightarrow> Q x) \<Longrightarrow> \<forall>\<^sub>\<infinity>x. Q x" by (fact eventually_mono)
lemma INFM_disj_distrib: "(\<exists>\<^sub>\<infinity>x. P x \<or> Q x) \<longleftrightarrow> (\<exists>\<^sub>\<infinity>x. P x) \<or> (\<exists>\<^sub>\<infinity>x. Q x)" by (fact frequently_disj_iff)
lemma MOST_rev_mp: "\<forall>\<^sub>\<infinity>x. P x \<Longrightarrow> \<forall>\<^sub>\<infinity>x. P x \<longrightarrow> Q x \<Longrightarrow> \<forall>\<^sub>\<infinity>x. Q x" by (fact eventually_rev_mp)
lemma MOST_conj_distrib: "(\<forall>\<^sub>\<infinity>x. P x \<and> Q x) \<longleftrightarrow> (\<forall>\<^sub>\<infinity>x. P x) \<and> (\<forall>\<^sub>\<infinity>x. Q x)" by (fact eventually_conj_iff)
lemma MOST_conjI: "MOST x. P x \<Longrightarrow> MOST x. Q x \<Longrightarrow> MOST x. P x \<and> Q x" by (fact eventually_conj)
lemma INFM_finite_Bex_distrib: "finite A \<Longrightarrow> (INFM y. \<exists>x\<in>A. P x y) \<longleftrightarrow> (\<exists>x\<in>A. INFM y. P x y)" by (fact frequently_bex_finite_distrib)
lemma MOST_finite_Ball_distrib: "finite A \<Longrightarrow> (MOST y. \<forall>x\<in>A. P x y) \<longleftrightarrow> (\<forall>x\<in>A. MOST y. P x y)" by (fact eventually_ball_finite_distrib)
lemma INFM_E: "INFM x. P x \<Longrightarrow> (\<And>x. P x \<Longrightarrow> thesis) \<Longrightarrow> thesis" by (fact frequentlyE)
lemma MOST_I: "(\<And>x. P x) \<Longrightarrow> MOST x. P x" by (rule eventuallyI)
lemmas MOST_iff_finiteNeg = MOST_iff_cofinite

subsection "Enumeration of an Infinite Set"

text \<open>
  The set's element type must be wellordered (e.g. the natural numbers).
\<close>

text \<open>
  Could be generalized to
    @{term "enumerate' S n = (SOME t. t \<in> s \<and> finite {s\<in>S. s < t} \<and> card {s\<in>S. s < t} = n)"}.
\<close>

primrec (in wellorder) enumerate :: "'a set \<Rightarrow> nat \<Rightarrow> 'a"
where
  enumerate_0: "enumerate S 0 = (LEAST n. n \<in> S)"
| enumerate_Suc: "enumerate S (Suc n) = enumerate (S - {LEAST n. n \<in> S}) n"

lemma enumerate_Suc': "enumerate S (Suc n) = enumerate (S - {enumerate S 0}) n"
  by simp

lemma enumerate_in_set: "infinite S \<Longrightarrow> enumerate S n \<in> S"
  apply (induct n arbitrary: S)
   apply (fastforce intro: LeastI dest!: infinite_imp_nonempty)
  apply simp
  apply (metis DiffE infinite_remove)
  done

declare enumerate_0 [simp del] enumerate_Suc [simp del]

lemma enumerate_step: "infinite S \<Longrightarrow> enumerate S n < enumerate S (Suc n)"
  apply (induct n arbitrary: S)
   apply (rule order_le_neq_trans)
    apply (simp add: enumerate_0 Least_le enumerate_in_set)
   apply (simp only: enumerate_Suc')
   apply (subgoal_tac "enumerate (S - {enumerate S 0}) 0 \<in> S - {enumerate S 0}")
    apply (blast intro: sym)
   apply (simp add: enumerate_in_set del: Diff_iff)
  apply (simp add: enumerate_Suc')
  done

lemma enumerate_mono: "m < n \<Longrightarrow> infinite S \<Longrightarrow> enumerate S m < enumerate S n"
  apply (erule less_Suc_induct)
  apply (auto intro: enumerate_step)
  done

lemma le_enumerate:
  assumes S: "infinite S"
  shows "n \<le> enumerate S n"
  using S
proof (induct n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  then have "n \<le> enumerate S n" by simp
  also note enumerate_mono[of n "Suc n", OF _ \<open>infinite S\<close>]
  finally show ?case by simp
qed

lemma enumerate_Suc'':
  fixes S :: "'a::wellorder set"
  assumes "infinite S"
  shows "enumerate S (Suc n) = (LEAST s. s \<in> S \<and> enumerate S n < s)"
  using assms
proof (induct n arbitrary: S)
  case 0
  then have "\<forall>s \<in> S. enumerate S 0 \<le> s"
    by (auto simp: enumerate.simps intro: Least_le)
  then show ?case
    unfolding enumerate_Suc' enumerate_0[of "S - {enumerate S 0}"]
    by (intro arg_cong[where f = Least] ext) auto
next
  case (Suc n S)
  show ?case
    using enumerate_mono[OF zero_less_Suc \<open>infinite S\<close>, of n] \<open>infinite S\<close>
    apply (subst (1 2) enumerate_Suc')
    apply (subst Suc)
    using \<open>infinite S\<close>
    apply simp
    apply (intro arg_cong[where f = Least] ext)
    apply (auto simp: enumerate_Suc'[symmetric])
    done
qed

lemma enumerate_Ex:
  assumes S: "infinite (S::nat set)"
  shows "s \<in> S \<Longrightarrow> \<exists>n. enumerate S n = s"
proof (induct s rule: less_induct)
  case (less s)
  show ?case
  proof cases
    let ?y = "Max {s'\<in>S. s' < s}"
    assume "\<exists>y\<in>S. y < s"
    then have y: "\<And>x. ?y < x \<longleftrightarrow> (\<forall>s'\<in>S. s' < s \<longrightarrow> s' < x)"
      by (subst Max_less_iff) auto
    then have y_in: "?y \<in> {s'\<in>S. s' < s}"
      by (intro Max_in) auto
    with less.hyps[of ?y] obtain n where "enumerate S n = ?y"
      by auto
    with S have "enumerate S (Suc n) = s"
      by (auto simp: y less enumerate_Suc'' intro!: Least_equality)
    then show ?case by auto
  next
    assume *: "\<not> (\<exists>y\<in>S. y < s)"
    then have "\<forall>t\<in>S. s \<le> t" by auto
    with \<open>s \<in> S\<close> show ?thesis
      by (auto intro!: exI[of _ 0] Least_equality simp: enumerate_0)
  qed
qed

lemma bij_enumerate:
  fixes S :: "nat set"
  assumes S: "infinite S"
  shows "bij_betw (enumerate S) UNIV S"
proof -
  have "\<And>n m. n \<noteq> m \<Longrightarrow> enumerate S n \<noteq> enumerate S m"
    using enumerate_mono[OF _ \<open>infinite S\<close>] by (auto simp: neq_iff)
  then have "inj (enumerate S)"
    by (auto simp: inj_on_def)
  moreover have "\<forall>s \<in> S. \<exists>i. enumerate S i = s"
    using enumerate_Ex[OF S] by auto
  moreover note \<open>infinite S\<close>
  ultimately show ?thesis
    unfolding bij_betw_def by (auto intro: enumerate_in_set)
qed

text\<open>A pair of weird and wonderful lemmas from HOL Light\<close>
lemma finite_transitivity_chain:
  assumes "finite A"
      and R: "\<And>x. ~ R x x" "\<And>x y z. \<lbrakk>R x y; R y z\<rbrakk> \<Longrightarrow> R x z"
      and A: "\<And>x. x \<in> A \<Longrightarrow> \<exists>y. y \<in> A \<and> R x y"
  shows "A = {}"
using \<open>finite A\<close> A
proof (induction A)
  case (insert a A)
  with R show ?case
    by (metis empty_iff insert_iff)
qed simp

corollary Union_maximal_sets:
  assumes "finite \<F>"
    shows "\<Union>{T \<in> \<F>. \<forall>U\<in>\<F>. \<not> T \<subset> U} = \<Union>\<F>"
    (is "?lhs = ?rhs")
proof
  show "?rhs \<subseteq> ?lhs"
  proof (rule Union_subsetI)
    fix S
    assume "S \<in> \<F>"
    have "{T \<in> \<F>. S \<subseteq> T} = {}" if "~ (\<exists>y. y \<in> {T \<in> \<F>. \<forall>U\<in>\<F>. \<not> T \<subset> U} \<and> S \<subseteq> y)"
      apply (rule finite_transitivity_chain [of _ "\<lambda>T U. S \<subseteq> T \<and> T \<subset> U"])
      using assms that apply auto
      by (blast intro: dual_order.trans psubset_imp_subset)
    then show "\<exists>y. y \<in> {T \<in> \<F>. \<forall>U\<in>\<F>. \<not> T \<subset> U} \<and> S \<subseteq> y"
      using \<open>S \<in> \<F>\<close> by blast
  qed
qed force

end


(*  Title:      HOL/Library/Nat_Bijection.thy
    Author:     Brian Huffman
    Author:     Florian Haftmann
    Author:     Stefan Richter
    Author:     Tobias Nipkow
    Author:     Alexander Krauss
*)

section \<open>Bijections between natural numbers and other types\<close>

theory Nat_Bijection
  imports "MainRLT"
begin

subsection \<open>Type \<^typ>\<open>nat \<times> nat\<close>\<close>

text \<open>Triangle numbers: 0, 1, 3, 6, 10, 15, ...\<close>

definition triangle :: "nat \<Rightarrow> nat"
  where "triangle n = (n * Suc n) div 2"

lemma triangle_0 [simp]: "triangle 0 = 0"
  by (simp add: triangle_def)

lemma triangle_Suc [simp]: "triangle (Suc n) = triangle n + Suc n"
  by (simp add: triangle_def)

definition prod_encode :: "nat \<times> nat \<Rightarrow> nat"
  where "prod_encode = (\<lambda>(m, n). triangle (m + n) + m)"

text \<open>In this auxiliary function, \<^term>\<open>triangle k + m\<close> is an invariant.\<close>

fun prod_decode_aux :: "nat \<Rightarrow> nat \<Rightarrow> nat \<times> nat"
  where "prod_decode_aux k m =
    (if m \<le> k then (m, k - m) else prod_decode_aux (Suc k) (m - Suc k))"

declare prod_decode_aux.simps [simp del]

definition prod_decode :: "nat \<Rightarrow> nat \<times> nat"
  where "prod_decode = prod_decode_aux 0"

lemma prod_encode_prod_decode_aux: "prod_encode (prod_decode_aux k m) = triangle k + m"
proof (induction k m rule: prod_decode_aux.induct)
  case (1 k m)
  then show ?case
    by (simp add: prod_encode_def prod_decode_aux.simps)
qed

lemma prod_decode_inverse [simp]: "prod_encode (prod_decode n) = n"
  by (simp add: prod_decode_def prod_encode_prod_decode_aux)

lemma prod_decode_triangle_add: "prod_decode (triangle k + m) = prod_decode_aux k m"
proof (induct k arbitrary: m)
  case 0
  then show ?case
    by (simp add: prod_decode_def)
next
  case (Suc k)
  then show ?case
    by (metis ab_semigroup_add_class.add_ac(1) add_diff_cancel_left' le_add1 not_less_eq_eq prod_decode_aux.simps triangle_Suc)
qed

lemma prod_encode_inverse [simp]: "prod_decode (prod_encode x) = x"
  unfolding prod_encode_def
proof (induct x)
  case (Pair a b)
  then show ?case
    by (simp add: prod_decode_triangle_add prod_decode_aux.simps)
qed

lemma inj_prod_encode: "inj_on prod_encode A"
  by (rule inj_on_inverseI) (rule prod_encode_inverse)

lemma inj_prod_decode: "inj_on prod_decode A"
  by (rule inj_on_inverseI) (rule prod_decode_inverse)

lemma surj_prod_encode: "surj prod_encode"
  by (rule surjI) (rule prod_decode_inverse)

lemma surj_prod_decode: "surj prod_decode"
  by (rule surjI) (rule prod_encode_inverse)

lemma bij_prod_encode: "bij prod_encode"
  by (rule bijI [OF inj_prod_encode surj_prod_encode])

lemma bij_prod_decode: "bij prod_decode"
  by (rule bijI [OF inj_prod_decode surj_prod_decode])

lemma prod_encode_eq: "prod_encode x = prod_encode y \<longleftrightarrow> x = y"
  by (rule inj_prod_encode [THEN inj_eq])

lemma prod_decode_eq: "prod_decode x = prod_decode y \<longleftrightarrow> x = y"
  by (rule inj_prod_decode [THEN inj_eq])

text \<open>Ordering properties\<close>

lemma le_prod_encode_1: "a \<le> prod_encode (a, b)"
  by (simp add: prod_encode_def)

lemma le_prod_encode_2: "b \<le> prod_encode (a, b)"
  by (induct b) (simp_all add: prod_encode_def)

subsection \<open>Type \<^typ>\<open>nat + nat\<close>\<close>

definition sum_encode :: "nat + nat \<Rightarrow> nat"
  where "sum_encode x = (case x of Inl a \<Rightarrow> 2 * a | Inr b \<Rightarrow> Suc (2 * b))"

definition sum_decode :: "nat \<Rightarrow> nat + nat"
  where "sum_decode n = (if even n then Inl (n div 2) else Inr (n div 2))"

lemma sum_encode_inverse [simp]: "sum_decode (sum_encode x) = x"
  by (induct x) (simp_all add: sum_decode_def sum_encode_def)

lemma sum_decode_inverse [simp]: "sum_encode (sum_decode n) = n"
  by (simp add: even_two_times_div_two sum_decode_def sum_encode_def)

lemma inj_sum_encode: "inj_on sum_encode A"
  by (rule inj_on_inverseI) (rule sum_encode_inverse)

lemma inj_sum_decode: "inj_on sum_decode A"
  by (rule inj_on_inverseI) (rule sum_decode_inverse)

lemma surj_sum_encode: "surj sum_encode"
  by (rule surjI) (rule sum_decode_inverse)

lemma surj_sum_decode: "surj sum_decode"
  by (rule surjI) (rule sum_encode_inverse)

lemma bij_sum_encode: "bij sum_encode"
  by (rule bijI [OF inj_sum_encode surj_sum_encode])

lemma bij_sum_decode: "bij sum_decode"
  by (rule bijI [OF inj_sum_decode surj_sum_decode])

lemma sum_encode_eq: "sum_encode x = sum_encode y \<longleftrightarrow> x = y"
  by (rule inj_sum_encode [THEN inj_eq])

lemma sum_decode_eq: "sum_decode x = sum_decode y \<longleftrightarrow> x = y"
  by (rule inj_sum_decode [THEN inj_eq])

subsection \<open>Type \<^typ>\<open>int\<close>\<close>

definition int_encode :: "int \<Rightarrow> nat"
  where "int_encode i = sum_encode (if 0 \<le> i then Inl (nat i) else Inr (nat (- i - 1)))"

definition int_decode :: "nat \<Rightarrow> int"
  where "int_decode n = (case sum_decode n of Inl a \<Rightarrow> int a | Inr b \<Rightarrow> - int b - 1)"

lemma int_encode_inverse [simp]: "int_decode (int_encode x) = x"
  by (simp add: int_decode_def int_encode_def)

lemma int_decode_inverse [simp]: "int_encode (int_decode n) = n"
  unfolding int_decode_def int_encode_def
  using sum_decode_inverse [of n] by (cases "sum_decode n") simp_all

lemma inj_int_encode: "inj_on int_encode A"
  by (rule inj_on_inverseI) (rule int_encode_inverse)

lemma inj_int_decode: "inj_on int_decode A"
  by (rule inj_on_inverseI) (rule int_decode_inverse)

lemma surj_int_encode: "surj int_encode"
  by (rule surjI) (rule int_decode_inverse)

lemma surj_int_decode: "surj int_decode"
  by (rule surjI) (rule int_encode_inverse)

lemma bij_int_encode: "bij int_encode"
  by (rule bijI [OF inj_int_encode surj_int_encode])

lemma bij_int_decode: "bij int_decode"
  by (rule bijI [OF inj_int_decode surj_int_decode])

lemma int_encode_eq: "int_encode x = int_encode y \<longleftrightarrow> x = y"
  by (rule inj_int_encode [THEN inj_eq])

lemma int_decode_eq: "int_decode x = int_decode y \<longleftrightarrow> x = y"
  by (rule inj_int_decode [THEN inj_eq])

subsection \<open>Type \<^typ>\<open>nat list\<close>\<close>

fun list_encode :: "nat list \<Rightarrow> nat"
  where
    "list_encode [] = 0"
  | "list_encode (x # xs) = Suc (prod_encode (x, list_encode xs))"

function list_decode :: "nat \<Rightarrow> nat list"
  where
    "list_decode 0 = []"
  | "list_decode (Suc n) = (case prod_decode n of (x, y) \<Rightarrow> x # list_decode y)"
  by pat_completeness auto

termination list_decode
proof -
  have "\<And>n x y. (x, y) = prod_decode n \<Longrightarrow> y < Suc n"
    by (metis le_imp_less_Suc le_prod_encode_2 prod_decode_inverse)
  then show ?thesis
    using "termination" by blast
qed

lemma list_encode_inverse [simp]: "list_decode (list_encode x) = x"
  by (induct x rule: list_encode.induct) simp_all

lemma list_decode_inverse [simp]: "list_encode (list_decode n) = n"
proof (induct n rule: list_decode.induct)
  case (2 n)
  then show ?case
    by (metis list_encode.simps(2) list_encode_inverse prod_decode_inverse surj_pair)
qed auto

lemma inj_list_encode: "inj_on list_encode A"
  by (rule inj_on_inverseI) (rule list_encode_inverse)

lemma inj_list_decode: "inj_on list_decode A"
  by (rule inj_on_inverseI) (rule list_decode_inverse)

lemma surj_list_encode: "surj list_encode"
  by (rule surjI) (rule list_decode_inverse)

lemma surj_list_decode: "surj list_decode"
  by (rule surjI) (rule list_encode_inverse)

lemma bij_list_encode: "bij list_encode"
  by (rule bijI [OF inj_list_encode surj_list_encode])

lemma bij_list_decode: "bij list_decode"
  by (rule bijI [OF inj_list_decode surj_list_decode])

lemma list_encode_eq: "list_encode x = list_encode y \<longleftrightarrow> x = y"
  by (rule inj_list_encode [THEN inj_eq])

lemma list_decode_eq: "list_decode x = list_decode y \<longleftrightarrow> x = y"
  by (rule inj_list_decode [THEN inj_eq])

subsection \<open>Finite sets of naturals\<close>

subsubsection \<open>Preliminaries\<close>

lemma finite_vimage_Suc_iff: "finite (Suc -` F) \<longleftrightarrow> finite F"
proof
  have "F \<subseteq> insert 0 (Suc ` Suc -` F)"
    using nat.nchotomy by force
  moreover
  assume "finite (Suc -` F)"
  then have "finite (insert 0 (Suc ` Suc -` F))"
    by blast
  ultimately show "finite F"
    using finite_subset by blast
qed (force intro: finite_vimageI inj_Suc)

lemma vimage_Suc_insert_0: "Suc -` insert 0 A = Suc -` A"
  by auto

lemma vimage_Suc_insert_Suc: "Suc -` insert (Suc n) A = insert n (Suc -` A)"
  by auto

lemma div2_even_ext_nat:
  fixes x y :: nat
  assumes "x div 2 = y div 2"
    and "even x \<longleftrightarrow> even y"
  shows "x = y"
proof -
  from \<open>even x \<longleftrightarrow> even y\<close> have "x mod 2 = y mod 2"
    by (simp only: even_iff_mod_2_eq_zero) auto
  with assms have "x div 2 * 2 + x mod 2 = y div 2 * 2 + y mod 2"
    by simp
  then show ?thesis
    by simp
qed

subsubsection \<open>From sets to naturals\<close>

definition set_encode :: "nat set \<Rightarrow> nat"
  where "set_encode = sum ((^) 2)"

lemma set_encode_empty [simp]: "set_encode {} = 0"
  by (simp add: set_encode_def)

lemma set_encode_inf: "\<not> finite A \<Longrightarrow> set_encode A = 0"
  by (simp add: set_encode_def)

lemma set_encode_insert [simp]: "finite A \<Longrightarrow> n \<notin> A \<Longrightarrow> set_encode (insert n A) = 2^n + set_encode A"
  by (simp add: set_encode_def)

lemma even_set_encode_iff: "finite A \<Longrightarrow> even (set_encode A) \<longleftrightarrow> 0 \<notin> A"
  by (induct set: finite) (auto simp: set_encode_def)

lemma set_encode_vimage_Suc: "set_encode (Suc -` A) = set_encode A div 2"
proof (induction A rule: infinite_finite_induct)
  case (infinite A)
  then show ?case
    by (simp add: finite_vimage_Suc_iff set_encode_inf)
next
  case (insert x A)
  show ?case
  proof (cases x)
    case 0
    with insert show ?thesis
      by (simp add: even_set_encode_iff vimage_Suc_insert_0)
  next
    case (Suc y)
    with insert show ?thesis
      by (simp add: finite_vimageI add.commute vimage_Suc_insert_Suc)
  qed
qed auto

lemmas set_encode_div_2 = set_encode_vimage_Suc [symmetric]

subsubsection \<open>From naturals to sets\<close>

definition set_decode :: "nat \<Rightarrow> nat set"
  where "set_decode x = {n. odd (x div 2 ^ n)}"

lemma set_decode_0 [simp]: "0 \<in> set_decode x \<longleftrightarrow> odd x"
  by (simp add: set_decode_def)

lemma set_decode_Suc [simp]: "Suc n \<in> set_decode x \<longleftrightarrow> n \<in> set_decode (x div 2)"
  by (simp add: set_decode_def div_mult2_eq)

lemma set_decode_zero [simp]: "set_decode 0 = {}"
  by (simp add: set_decode_def)

lemma set_decode_div_2: "set_decode (x div 2) = Suc -` set_decode x"
  by auto

lemma set_decode_plus_power_2:
  "n \<notin> set_decode z \<Longrightarrow> set_decode (2 ^ n + z) = insert n (set_decode z)"
proof (induct n arbitrary: z)
  case 0
  show ?case
  proof (rule set_eqI)
    show "q \<in> set_decode (2 ^ 0 + z) \<longleftrightarrow> q \<in> insert 0 (set_decode z)" for q
      by (induct q) (use 0 in simp_all)
  qed
next
  case (Suc n)
  show ?case
  proof (rule set_eqI)
    show "q \<in> set_decode (2 ^ Suc n + z) \<longleftrightarrow> q \<in> insert (Suc n) (set_decode z)" for q
      by (induct q) (use Suc in simp_all)
  qed
qed

lemma finite_set_decode [simp]: "finite (set_decode n)"
proof (induction n rule: less_induct)
  case (less n)
  show ?case
  proof (cases "n = 0")
    case False
    then show ?thesis
      using less.IH [of "n div 2"] finite_vimage_Suc_iff set_decode_div_2 by auto
  qed auto
qed

subsubsection \<open>Proof of isomorphism\<close>

lemma set_decode_inverse [simp]: "set_encode (set_decode n) = n"
proof (induction n rule: less_induct)
  case (less n)
  show ?case
  proof (cases "n = 0")
    case False
    then have "set_encode (set_decode (n div 2)) = n div 2"
      using less.IH by auto
    then show ?thesis
      by (metis div2_even_ext_nat even_set_encode_iff finite_set_decode set_decode_0 set_decode_div_2 set_encode_div_2)
  qed auto
qed

lemma set_encode_inverse [simp]: "finite A \<Longrightarrow> set_decode (set_encode A) = A"
proof (induction rule: finite_induct)
  case (insert x A)
  then show ?case
    by (simp add: set_decode_plus_power_2)
qed auto

lemma inj_on_set_encode: "inj_on set_encode (Collect finite)"
  by (rule inj_on_inverseI [where g = "set_decode"]) simp

lemma set_encode_eq: "finite A \<Longrightarrow> finite B \<Longrightarrow> set_encode A = set_encode B \<longleftrightarrow> A = B"
  by (rule iffI) (simp_all add: inj_onD [OF inj_on_set_encode])

lemma subset_decode_imp_le:
  assumes "set_decode m \<subseteq> set_decode n"
  shows "m \<le> n"
proof -
  have "n = m + set_encode (set_decode n - set_decode m)"
  proof -
    obtain A B where
      "m = set_encode A" "finite A"
      "n = set_encode B" "finite B"
      by (metis finite_set_decode set_decode_inverse)
  with assms show ?thesis
    by auto (simp add: set_encode_def add.commute sum.subset_diff)
  qed
  then show ?thesis
    by (metis le_add1)
qed

end


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

section \<open>Matrix Relation Algebras\<close>

text \<open>
This theory gives matrix models of Stone relation algebras and more general structures.
We consider only square matrices.
The main result is that matrices over Stone relation algebras form a Stone relation algebra.

We use the monoid structure underlying semilattices to provide finite sums, which are necessary for defining the composition of two matrices.
See \<^cite>\<open>"ArmstrongFosterStruthWeber2016" and "ArmstrongGomesStruthWeber2016"\<close> for similar liftings to matrices for semirings and relation algebras.
A technical difference is that those theories are mostly based on semirings whereas our hierarchy is mostly based on lattices (and our semirings directly inherit from semilattices).

Relation algebras have both a semiring and a lattice structure such that semiring addition and lattice join coincide.
In particular, finite sums and finite suprema coincide.
Isabelle/HOL has separate theories for semirings and lattices, based on separate addition and join operations and different operations for finite sums and finite suprema.
Reusing results from both theories is beneficial for relation algebras, but not always easy to realise.
\<close>

theory Matrix_Relation_Algebras

imports Relation_Algebras

begin

subsection \<open>Finite Suprema\<close>

text \<open>
We consider finite suprema in idempotent semirings and Stone relation algebras.
We mostly use the first of the following notations, which denotes the supremum of expressions \<open>t(x)\<close> over all \<open>x\<close> from the type of \<open>x\<close>.
For finite types, this is implemented in Isabelle/HOL as the repeated application of binary suprema.
\<close>

syntax
  "_sum_sup_monoid" :: "idt \<Rightarrow> 'a::bounded_semilattice_sup_bot \<Rightarrow> 'a" ("(\<Squnion>\<^sub>_ _)" [0,10] 10)
  "_sum_sup_monoid_bounded" :: "idt \<Rightarrow> 'b set \<Rightarrow> 'a::bounded_semilattice_sup_bot \<Rightarrow> 'a" ("(\<Squnion>\<^bsub>_\<in>_\<^esub> _)" [0,51,10] 10)
translations
  "\<Squnion>\<^sub>x t" => "XCONST sup_monoid.sum (\<lambda>x . t) { x . CONST True }"
  "\<Squnion>\<^bsub>x\<in>X\<^esub> t" => "XCONST sup_monoid.sum (\<lambda>x . t) X"

context idempotent_semiring
begin

text \<open>
The following induction principles are useful for comparing two suprema.
The first principle works because types are not empty.
\<close>

lemma one_sup_induct [case_names one sup]:
  fixes f g :: "'b::finite \<Rightarrow> 'a"
  assumes one: "\<And>i . P (f i) (g i)"
      and sup: "\<And>j I . j \<notin> I \<Longrightarrow> P (\<Squnion>\<^bsub>i\<in>I\<^esub> f i) (\<Squnion>\<^bsub>i\<in>I\<^esub> g i) \<Longrightarrow> P (f j \<squnion> (\<Squnion>\<^bsub>i\<in>I\<^esub> f i)) (g j \<squnion> (\<Squnion>\<^bsub>i\<in>I\<^esub> g i))"
    shows "P (\<Squnion>\<^sub>k f k) (\<Squnion>\<^sub>k g k)"
proof -
  let ?X = "{ k::'b . True }"
  have "finite ?X" and "?X \<noteq> {}"
    by auto
  thus ?thesis
  proof (induct rule: finite_ne_induct)
    case (singleton i) thus ?case
      using one by simp
  next
    case (insert j I) thus ?case
      using sup by simp
  qed
qed

lemma bot_sup_induct [case_names bot sup]:
  fixes f g :: "'b::finite \<Rightarrow> 'a"
  assumes bot: "P bot bot"
      and sup: "\<And>j I . j \<notin> I \<Longrightarrow> P (\<Squnion>\<^bsub>i\<in>I\<^esub> f i) (\<Squnion>\<^bsub>i\<in>I\<^esub> g i) \<Longrightarrow> P (f j \<squnion> (\<Squnion>\<^bsub>i\<in>I\<^esub> f i)) (g j \<squnion> (\<Squnion>\<^bsub>i\<in>I\<^esub> g i))"
    shows "P (\<Squnion>\<^sub>k f k) (\<Squnion>\<^sub>k g k)"
  apply (induct rule: one_sup_induct)
  using bot sup apply fastforce
  using sup by blast

text \<open>
Now many properties of finite suprema follow by simple applications of the above induction rules.
In particular, we show distributivity of composition, isotonicity and the upper-bound property.
\<close>

lemma comp_right_dist_sum:
  fixes f :: "'b::finite \<Rightarrow> 'a"
  shows "(\<Squnion>\<^sub>k f k * x) = (\<Squnion>\<^sub>k f k) * x"
proof (induct rule: one_sup_induct)
  case one show ?case
    by simp
next
  case (sup j I) thus ?case
    using mult_right_dist_sup by auto
qed

lemma comp_left_dist_sum:
  fixes f :: "'b::finite \<Rightarrow> 'a"
  shows "(\<Squnion>\<^sub>k x * f k) = x * (\<Squnion>\<^sub>k f k)"
proof (induct rule: one_sup_induct)
  case one show ?case
    by simp
next
  case (sup j I) thus ?case
    by (simp add: mult_left_dist_sup)
qed

lemma leq_sum:
  fixes f g :: "'b::finite \<Rightarrow> 'a"
  shows "(\<forall>k . f k \<le> g k) \<Longrightarrow> (\<Squnion>\<^sub>k f k) \<le> (\<Squnion>\<^sub>k g k)"
proof (induct rule: one_sup_induct)
  case one thus ?case
    by simp
next
  case (sup j I) thus ?case
    using sup_mono by blast
qed

lemma ub_sum:
  fixes f :: "'b::finite \<Rightarrow> 'a"
  shows "f i \<le> (\<Squnion>\<^sub>k f k)"
proof -
  have "i \<in> { k . True }"
    by simp
  thus "f i \<le> (\<Squnion>\<^sub>k f (k::'b))"
    by (metis finite_code sup_monoid.sum.insert sup_ge1 mk_disjoint_insert)
qed

lemma lub_sum:
  fixes f :: "'b::finite \<Rightarrow> 'a"
  assumes "\<forall>k . f k \<le> x"
    shows "(\<Squnion>\<^sub>k f k) \<le> x"
proof (induct rule: one_sup_induct)
  case one show ?case
    by (simp add: assms)
next
  case (sup j I) thus ?case
    using assms le_supI by blast
qed

lemma lub_sum_iff:
  fixes f :: "'b::finite \<Rightarrow> 'a"
  shows "(\<forall>k . f k \<le> x) \<longleftrightarrow> (\<Squnion>\<^sub>k f k) \<le> x"
  using order.trans ub_sum lub_sum by blast

end

context stone_relation_algebra
begin

text \<open>
In Stone relation algebras, we can also show that converse,  double complement and meet distribute over finite suprema.
\<close>

lemma conv_dist_sum:
  fixes f :: "'b::finite \<Rightarrow> 'a"
  shows "(\<Squnion>\<^sub>k (f k)\<^sup>T) = (\<Squnion>\<^sub>k f k)\<^sup>T"
proof (induct rule: one_sup_induct)
  case one show ?case
    by simp
next
  case (sup j I) thus ?case
    by (simp add: conv_dist_sup)
qed

lemma pp_dist_sum:
  fixes f :: "'b::finite \<Rightarrow> 'a"
  shows "(\<Squnion>\<^sub>k --f k) = --(\<Squnion>\<^sub>k f k)"
proof (induct rule: one_sup_induct)
  case one show ?case
    by simp
next
  case (sup j I) thus ?case
    by simp
qed

lemma inf_right_dist_sum:
  fixes f :: "'b::finite \<Rightarrow> 'a"
  shows "(\<Squnion>\<^sub>k f k \<sqinter> x) = (\<Squnion>\<^sub>k f k) \<sqinter> x"
  by (rule comp_inf.comp_right_dist_sum)

end

subsection \<open>Square Matrices\<close>

text \<open>
Because our semiring and relation algebra type classes only work for homogeneous relations, we only look at square matrices.
\<close>

type_synonym ('a,'b) square = "'a \<times> 'a \<Rightarrow> 'b"

text \<open>
We use standard matrix operations.
The Stone algebra structure is lifted componentwise.
Composition is matrix multiplication using given composition and supremum operations.
Its unit lifts given zero and one elements into an identity matrix.
Converse is matrix transpose with an additional componentwise transpose.
\<close>

definition less_eq_matrix :: "('a,'b::ord) square \<Rightarrow> ('a,'b) square \<Rightarrow> bool"                                           (infix "\<preceq>" 50)   where "f \<preceq> g = (\<forall>e . f e \<le> g e)"
definition less_matrix    :: "('a,'b::ord) square \<Rightarrow> ('a,'b) square \<Rightarrow> bool"                                           (infix "\<prec>" 50)   where "f \<prec> g = (f \<preceq> g \<and> \<not> g \<preceq> f)"
definition sup_matrix     :: "('a,'b::sup) square \<Rightarrow> ('a,'b) square \<Rightarrow> ('a,'b) square"                                 (infixl "\<oplus>" 65)  where "f \<oplus> g = (\<lambda>e . f e \<squnion> g e)"
definition inf_matrix     :: "('a,'b::inf) square \<Rightarrow> ('a,'b) square \<Rightarrow> ('a,'b) square"                                 (infixl "\<otimes>" 67)  where "f \<otimes> g = (\<lambda>e . f e \<sqinter> g e)"
definition minus_matrix   :: "('a,'b::{uminus,inf}) square \<Rightarrow> ('a,'b) square \<Rightarrow> ('a,'b) square"                        (infixl "\<ominus>" 65)  where "f \<ominus> g = (\<lambda>e . f e \<sqinter> -g e)"
definition implies_matrix :: "('a,'b::implies) square \<Rightarrow> ('a,'b) square \<Rightarrow> ('a,'b) square"                             (infixl "\<oslash>" 65)  where "f \<oslash> g = (\<lambda>e . f e \<leadsto> g e)"
definition times_matrix   :: "('a,'b::{times,bounded_semilattice_sup_bot}) square \<Rightarrow> ('a,'b) square \<Rightarrow> ('a,'b) square" (infixl "\<odot>" 70)  where "f \<odot> g = (\<lambda>(i,j) . \<Squnion>\<^sub>k f (i,k) * g (k,j))"
definition uminus_matrix  :: "('a,'b::uminus) square \<Rightarrow> ('a,'b) square"                                                ("\<ominus> _" [80] 80)  where "\<ominus>f    = (\<lambda>e . -f e)"
definition conv_matrix    :: "('a,'b::conv) square \<Rightarrow> ('a,'b) square"                                                  ("_\<^sup>t" [100] 100) where "f\<^sup>t      = (\<lambda>(i,j) . (f (j,i))\<^sup>T)"
definition bot_matrix     :: "('a,'b::bot) square"                                                                     ("mbot")         where "mbot   = (\<lambda>e . bot)"
definition top_matrix     :: "('a,'b::top) square"                                                                     ("mtop")         where "mtop   = (\<lambda>e . top)"
definition one_matrix     :: "('a,'b::{one,bot}) square"                                                               ("mone")         where "mone   = (\<lambda>(i,j) . if i = j then 1 else bot)"

subsection \<open>Stone Algebras\<close>

text \<open>
We first lift the Stone algebra structure.
Because all operations are componentwise, this also works for infinite matrices.
\<close>

interpretation matrix_order: order where less_eq = less_eq_matrix and less = "less_matrix :: ('a,'b::order) square \<Rightarrow> ('a,'b) square \<Rightarrow> bool"
  apply unfold_locales
  apply (simp add: less_matrix_def)
  apply (simp add: less_eq_matrix_def)
  apply (meson less_eq_matrix_def order_trans)
  by (meson less_eq_matrix_def antisym ext)

interpretation matrix_semilattice_sup: semilattice_sup where sup = sup_matrix and less_eq = less_eq_matrix and less = "less_matrix :: ('a,'b::semilattice_sup) square \<Rightarrow> ('a,'b) square \<Rightarrow> bool"
  apply unfold_locales
  apply (simp add: sup_matrix_def less_eq_matrix_def)
  apply (simp add: sup_matrix_def less_eq_matrix_def)
  by (simp add: sup_matrix_def less_eq_matrix_def)

interpretation matrix_semilattice_inf: semilattice_inf where inf = inf_matrix and less_eq = less_eq_matrix and less = "less_matrix :: ('a,'b::semilattice_inf) square \<Rightarrow> ('a,'b) square \<Rightarrow> bool"
  apply unfold_locales
  apply (simp add: inf_matrix_def less_eq_matrix_def)
  apply (simp add: inf_matrix_def less_eq_matrix_def)
  by (simp add: inf_matrix_def less_eq_matrix_def)

interpretation matrix_bounded_semilattice_sup_bot: bounded_semilattice_sup_bot where sup = sup_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a,'b::bounded_semilattice_sup_bot) square"
  apply unfold_locales
  by (simp add: bot_matrix_def less_eq_matrix_def)

interpretation matrix_bounded_semilattice_inf_top: bounded_semilattice_inf_top where inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and top = "top_matrix :: ('a,'b::bounded_semilattice_inf_top) square"
  apply unfold_locales
  by (simp add: less_eq_matrix_def top_matrix_def)

interpretation matrix_lattice: lattice where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = "less_matrix :: ('a,'b::lattice) square \<Rightarrow> ('a,'b) square \<Rightarrow> bool" ..

interpretation matrix_distrib_lattice: distrib_lattice where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = "less_matrix :: ('a,'b::distrib_lattice) square \<Rightarrow> ('a,'b) square \<Rightarrow> bool"
  apply unfold_locales
  by (simp add: sup_inf_distrib1 sup_matrix_def inf_matrix_def)

interpretation matrix_bounded_lattice: bounded_lattice where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a,'b::bounded_lattice) square" and top = top_matrix ..

interpretation matrix_bounded_distrib_lattice: bounded_distrib_lattice where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a,'b::bounded_distrib_lattice) square" and top = top_matrix ..

interpretation matrix_p_algebra: p_algebra where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a,'b::p_algebra) square" and top = top_matrix and uminus = uminus_matrix
  apply unfold_locales
  apply (unfold inf_matrix_def bot_matrix_def less_eq_matrix_def uminus_matrix_def)
  by (meson pseudo_complement)

interpretation matrix_pd_algebra: pd_algebra where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a,'b::pd_algebra) square" and top = top_matrix and uminus = uminus_matrix ..

text \<open>
In particular, matrices over Stone algebras form a Stone algebra.
\<close>

interpretation matrix_stone_algebra: stone_algebra where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a,'b::stone_algebra) square" and top = top_matrix and uminus = uminus_matrix
  by unfold_locales (simp add: sup_matrix_def uminus_matrix_def top_matrix_def)

interpretation matrix_heyting_stone_algebra: heyting_stone_algebra where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a,'b::heyting_stone_algebra) square" and top = top_matrix and uminus = uminus_matrix and implies = implies_matrix
  apply unfold_locales
  apply (unfold inf_matrix_def sup_matrix_def bot_matrix_def top_matrix_def less_eq_matrix_def uminus_matrix_def implies_matrix_def)
  apply (simp add: implies_galois)
  apply (simp add: uminus_eq)
  by simp

interpretation matrix_boolean_algebra: boolean_algebra where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a,'b::boolean_algebra) square" and top = top_matrix and uminus = uminus_matrix and minus = minus_matrix
  apply unfold_locales
  apply simp
  apply (simp add: sup_matrix_def uminus_matrix_def top_matrix_def)
  by (simp add: inf_matrix_def uminus_matrix_def minus_matrix_def)

subsection \<open>Semirings\<close>

text \<open>
Next, we lift the semiring structure.
Because of composition, this requires a restriction to finite matrices.
\<close>

interpretation matrix_monoid: monoid_mult where times = times_matrix and one = "one_matrix :: ('a::finite,'b::idempotent_semiring) square"
proof
  fix f g h :: "('a,'b) square"
  show "(f \<odot> g) \<odot> h = f \<odot> (g \<odot> h)"
  proof (rule ext, rule prod_cases)
    fix i j
    have "((f \<odot> g) \<odot> h) (i,j) = (\<Squnion>\<^sub>l (f \<odot> g) (i,l) * h (l,j))"
      by (simp add: times_matrix_def)
    also have "... = (\<Squnion>\<^sub>l (\<Squnion>\<^sub>k f (i,k) * g (k,l)) * h (l,j))"
      by (simp add: times_matrix_def)
    also have "... = (\<Squnion>\<^sub>l \<Squnion>\<^sub>k (f (i,k) * g (k,l)) * h (l,j))"
      by (metis (no_types) comp_right_dist_sum)
    also have "... = (\<Squnion>\<^sub>l \<Squnion>\<^sub>k f (i,k) * (g (k,l) * h (l,j)))"
      by (simp add: mult.assoc)
    also have "... = (\<Squnion>\<^sub>k \<Squnion>\<^sub>l f (i,k) * (g (k,l) * h (l,j)))"
      using sup_monoid.sum.swap by auto
    also have "... = (\<Squnion>\<^sub>k f (i,k) * (\<Squnion>\<^sub>l g (k,l) * h (l,j)))"
      by (metis (no_types) comp_left_dist_sum)
    also have "... = (\<Squnion>\<^sub>k f (i,k) * (g \<odot> h) (k,j))"
      by (simp add: times_matrix_def)
    also have "... = (f \<odot> (g \<odot> h)) (i,j)"
      by (simp add: times_matrix_def)
    finally show "((f \<odot> g) \<odot> h) (i,j) = (f \<odot> (g \<odot> h)) (i,j)"
      .
  qed
next
  fix f :: "('a,'b) square"
  show "mone \<odot> f = f"
  proof (rule ext, rule prod_cases)
    fix i j
    have "(mone \<odot> f) (i,j) = (\<Squnion>\<^sub>k mone (i,k) * f (k,j))"
      by (simp add: times_matrix_def)
    also have "... = (\<Squnion>\<^sub>k (if i = k then 1 else bot) * f (k,j))"
      by (simp add: one_matrix_def)
    also have "... = (\<Squnion>\<^sub>k if i = k then 1 * f (k,j) else bot * f (k,j))"
      by (metis (full_types, opaque_lifting))
    also have "... = (\<Squnion>\<^sub>k if i = k then f (k,j) else bot)"
      by (meson mult_left_one mult_left_zero)
    also have "... = f (i,j)"
      by simp
    finally show "(mone \<odot> f) (i,j) = f (i,j)"
      .
  qed
next
  fix f :: "('a,'b) square"
  show "f \<odot> mone = f"
  proof (rule ext, rule prod_cases)
    fix i j
    have "(f \<odot> mone) (i,j) = (\<Squnion>\<^sub>k f (i,k) * mone (k,j))"
      by (simp add: times_matrix_def)
    also have "... = (\<Squnion>\<^sub>k f (i,k) * (if k = j then 1 else bot))"
      by (simp add: one_matrix_def)
    also have "... = (\<Squnion>\<^sub>k if k = j then f (i,k) * 1 else f (i,k) * bot)"
      by (metis (full_types, opaque_lifting))
    also have "... = (\<Squnion>\<^sub>k if k = j then f (i,k) else bot)"
      by (meson mult.right_neutral semiring.mult_zero_right)
    also have "... = f (i,j)"
      by simp
    finally show "(f \<odot> mone) (i,j) = f (i,j)"
      .
  qed
qed

interpretation matrix_idempotent_semiring: idempotent_semiring where sup = sup_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a::finite,'b::idempotent_semiring) square" and one = one_matrix and times = times_matrix
proof
  fix f g h :: "('a,'b) square"
  show "f \<odot> g \<oplus> f \<odot> h \<preceq> f \<odot> (g \<oplus> h)"
  proof (unfold less_eq_matrix_def, rule allI, rule prod_cases)
    fix i j
    have "(f \<odot> g \<oplus> f \<odot> h) (i,j) = (f \<odot> g) (i,j) \<squnion> (f \<odot> h) (i,j)"
      by (simp add: sup_matrix_def)
    also have "... = (\<Squnion>\<^sub>k f (i,k) * g (k,j)) \<squnion> (\<Squnion>\<^sub>k f (i,k) * h (k,j))"
      by (simp add: times_matrix_def)
    also have "... = (\<Squnion>\<^sub>k f (i,k) * g (k,j) \<squnion> f (i,k) * h (k,j))"
      by (simp add: sup_monoid.sum.distrib)
    also have "... = (\<Squnion>\<^sub>k f (i,k) * (g (k,j) \<squnion> h (k,j)))"
      by (simp add: mult_left_dist_sup)
    also have "... = (\<Squnion>\<^sub>k f (i,k) * (g \<oplus> h) (k,j))"
      by (simp add: sup_matrix_def)
    also have "... = (f \<odot> (g \<oplus> h)) (i,j)"
      by (simp add: times_matrix_def)
    finally show "(f \<odot> g \<oplus> f \<odot> h) (i,j) \<le> (f \<odot> (g \<oplus> h)) (i,j)"
      by simp
  qed
next
  fix f g h :: "('a,'b) square"
  show "(f \<oplus> g) \<odot> h = f \<odot> h \<oplus> g \<odot> h"
  proof (rule ext, rule prod_cases)
    fix i j
    have "((f \<oplus> g) \<odot> h) (i,j) = (\<Squnion>\<^sub>k (f \<oplus> g) (i,k) * h (k,j))"
      by (simp add: times_matrix_def)
    also have "... = (\<Squnion>\<^sub>k (f (i,k) \<squnion> g (i,k)) * h (k,j))"
      by (simp add: sup_matrix_def)
    also have "... = (\<Squnion>\<^sub>k f (i,k) * h (k,j) \<squnion> g (i,k) * h (k,j))"
      by (meson mult_right_dist_sup)
    also have "... = (\<Squnion>\<^sub>k f (i,k) * h (k,j)) \<squnion> (\<Squnion>\<^sub>k g (i,k) * h (k,j))"
      by (simp add: sup_monoid.sum.distrib)
    also have "... = (f \<odot> h) (i,j) \<squnion> (g \<odot> h) (i,j)"
      by (simp add: times_matrix_def)
    also have "... = (f \<odot> h \<oplus> g \<odot> h) (i,j)"
      by (simp add: sup_matrix_def)
    finally show "((f \<oplus> g) \<odot> h) (i,j) = (f \<odot> h \<oplus> g \<odot> h) (i,j)"
      .
  qed
next
  fix f :: "('a,'b) square"
  show "mbot \<odot> f = mbot"
  proof (rule ext, rule prod_cases)
    fix i j
    have "(mbot \<odot> f) (i,j) = (\<Squnion>\<^sub>k mbot (i,k) * f (k,j))"
      by (simp add: times_matrix_def)
    also have "... = (\<Squnion>\<^sub>k bot * f (k,j))"
      by (simp add: bot_matrix_def)
    also have "... = bot"
      by simp
    also have "... = mbot (i,j)"
      by (simp add: bot_matrix_def)
    finally show "(mbot \<odot> f) (i,j) = mbot (i,j)"
      .
  qed
next
  fix f :: "('a,'b) square"
  show "mone \<odot> f = f"
    by simp
next
  fix f :: "('a,'b) square"
  show "f \<preceq> f \<odot> mone"
    by simp
next
  fix f g h :: "('a,'b) square"
  show "f \<odot> (g \<oplus> h) = f \<odot> g \<oplus> f \<odot> h"
  proof (rule ext, rule prod_cases)
    fix i j
    have "(f \<odot> (g \<oplus> h)) (i,j) = (\<Squnion>\<^sub>k f (i,k) * (g \<oplus> h) (k,j))"
      by (simp add: times_matrix_def)
    also have "... = (\<Squnion>\<^sub>k f (i,k) * (g (k,j) \<squnion> h (k,j)))"
      by (simp add: sup_matrix_def)
    also have "... = (\<Squnion>\<^sub>k f (i,k) * g (k,j) \<squnion> f (i,k) * h (k,j))"
      by (meson mult_left_dist_sup)
    also have "... = (\<Squnion>\<^sub>k f (i,k) * g (k,j)) \<squnion> (\<Squnion>\<^sub>k f (i,k) * h (k,j))"
      by (simp add: sup_monoid.sum.distrib)
    also have "... = (f \<odot> g) (i,j) \<squnion> (f \<odot> h) (i,j)"
      by (simp add: times_matrix_def)
    also have "... = (f \<odot> g \<oplus> f \<odot> h) (i,j)"
      by (simp add: sup_matrix_def)
    finally show "(f \<odot> (g \<oplus> h)) (i,j) = (f \<odot> g \<oplus> f \<odot> h) (i,j)"
      .
  qed
next
  fix f :: "('a,'b) square"
  show "f \<odot> mbot = mbot"
  proof (rule ext, rule prod_cases)
    fix i j
    have "(f \<odot> mbot) (i,j) = (\<Squnion>\<^sub>k f (i,k) * mbot (k,j))"
      by (simp add: times_matrix_def)
    also have "... = (\<Squnion>\<^sub>k f (i,k) * bot)"
      by (simp add: bot_matrix_def)
    also have "... = bot"
      by simp
    also have "... = mbot (i,j)"
      by (simp add: bot_matrix_def)
    finally show "(f \<odot> mbot) (i,j) = mbot (i,j)"
      .
  qed
qed

interpretation matrix_bounded_idempotent_semiring: bounded_idempotent_semiring where sup = sup_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a::finite,'b::bounded_idempotent_semiring) square" and top = top_matrix and one = one_matrix and times = times_matrix
proof
  fix f :: "('a,'b) square"
  show "f \<oplus> mtop = mtop"
  proof
    fix e
    have "(f \<oplus> mtop) e = f e \<squnion> mtop e"
      by (simp add: sup_matrix_def)
    also have "... = f e \<squnion> top"
      by (simp add: top_matrix_def)
    also have "... = top"
      by simp
    also have "... = mtop e"
      by (simp add: top_matrix_def)
    finally show "(f \<oplus> mtop) e = mtop e"
      .
  qed
qed

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

text \<open>
Finally, we show that matrices over Stone relation algebras form a Stone relation algebra.
\<close>

interpretation matrix_stone_relation_algebra: stone_relation_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::stone_relation_algebra) square" and top = top_matrix and uminus = uminus_matrix and one = one_matrix and times = times_matrix and conv = conv_matrix
proof
  fix f g h :: "('a,'b) square"
  show "(f \<odot> g) \<odot> h = f \<odot> (g \<odot> h)"
    by (simp add: matrix_monoid.mult_assoc)
next
  fix f g h :: "('a,'b) square"
  show "(f \<oplus> g) \<odot> h = f \<odot> h \<oplus> g \<odot> h"
    by (simp add: matrix_idempotent_semiring.mult_right_dist_sup)
next
  fix f :: "('a,'b) square"
  show "mbot \<odot> f = mbot"
    by simp
next
  fix f :: "('a,'b) square"
  show "mone \<odot> f = f"
    by simp
next
  fix f :: "('a,'b) square"
  show "f\<^sup>t\<^sup>t = f"
  proof (rule ext, rule prod_cases)
    fix i j
    have "(f\<^sup>t\<^sup>t) (i,j) = ((f\<^sup>t) (j,i))\<^sup>T"
      by (simp add: conv_matrix_def)
    also have "... = f (i,j)"
      by (simp add: conv_matrix_def)
    finally show "(f\<^sup>t\<^sup>t) (i,j) = f (i,j)"
      .
  qed
next
  fix f g :: "('a,'b) square"
  show "(f \<oplus> g)\<^sup>t = f\<^sup>t \<oplus> g\<^sup>t"
  proof (rule ext, rule prod_cases)
    fix i j
    have "((f \<oplus> g)\<^sup>t) (i,j) = ((f \<oplus> g) (j,i))\<^sup>T"
      by (simp add: conv_matrix_def)
    also have "... = (f (j,i) \<squnion> g (j,i))\<^sup>T"
      by (simp add: sup_matrix_def)
    also have "... = (f\<^sup>t) (i,j) \<squnion> (g\<^sup>t) (i,j)"
      by (simp add: conv_matrix_def conv_dist_sup)
    also have "... = (f\<^sup>t \<oplus> g\<^sup>t) (i,j)"
      by (simp add: sup_matrix_def)
    finally show "((f \<oplus> g)\<^sup>t) (i,j) = (f\<^sup>t \<oplus> g\<^sup>t) (i,j)"
      .
  qed
next
  fix f g :: "('a,'b) square"
  show "(f \<odot> g)\<^sup>t = g\<^sup>t \<odot> f\<^sup>t"
  proof (rule ext, rule prod_cases)
    fix i j
    have "((f \<odot> g)\<^sup>t) (i,j) = ((f \<odot> g) (j,i))\<^sup>T"
      by (simp add: conv_matrix_def)
    also have "... = (\<Squnion>\<^sub>k f (j,k) * g (k,i))\<^sup>T"
      by (simp add: times_matrix_def)
    also have "... = (\<Squnion>\<^sub>k (f (j,k) * g (k,i))\<^sup>T)"
      by (metis (no_types) conv_dist_sum)
    also have "... = (\<Squnion>\<^sub>k (g (k,i))\<^sup>T * (f (j,k))\<^sup>T)"
      by (simp add: conv_dist_comp)
    also have "... = (\<Squnion>\<^sub>k (g\<^sup>t) (i,k) * (f\<^sup>t) (k,j))"
      by (simp add: conv_matrix_def)
    also have "... = (g\<^sup>t \<odot> f\<^sup>t) (i,j)"
      by (simp add: times_matrix_def)
    finally show "((f \<odot> g)\<^sup>t) (i,j) = (g\<^sup>t \<odot> f\<^sup>t) (i,j)"
      .
  qed
next
  fix f g h :: "('a,'b) square"
  show "(f \<odot> g) \<otimes> h \<preceq> f \<odot> (g \<otimes> (f\<^sup>t \<odot> h))"
  proof (unfold less_eq_matrix_def, rule allI, rule prod_cases)
    fix i j
    have "((f \<odot> g) \<otimes> h) (i,j) = (f \<odot> g) (i,j) \<sqinter> h (i,j)"
      by (simp add: inf_matrix_def)
    also have "... = (\<Squnion>\<^sub>k f (i,k) * g (k,j)) \<sqinter> h (i,j)"
      by (simp add: times_matrix_def)
    also have "... = (\<Squnion>\<^sub>k f (i,k) * g (k,j) \<sqinter> h (i,j))"
      by (metis (no_types) inf_right_dist_sum)
    also have "... \<le> (\<Squnion>\<^sub>k f (i,k) * (g (k,j) \<sqinter> (f (i,k))\<^sup>T * h (i,j)))"
      by (rule leq_sum, meson dedekind_1)
    also have "... = (\<Squnion>\<^sub>k f (i,k) * (g (k,j) \<sqinter> (f\<^sup>t) (k,i) * h (i,j)))"
      by (simp add: conv_matrix_def)
    also have "... \<le> (\<Squnion>\<^sub>k f (i,k) * (g (k,j) \<sqinter> (\<Squnion>\<^sub>l (f\<^sup>t) (k,l) * h (l,j))))"
      by (rule leq_sum, rule allI, rule comp_right_isotone, rule inf.sup_right_isotone, rule ub_sum)
    also have "... = (\<Squnion>\<^sub>k f (i,k) * (g (k,j) \<sqinter> (f\<^sup>t \<odot> h) (k,j)))"
      by (simp add: times_matrix_def)
    also have "... = (\<Squnion>\<^sub>k f (i,k) * (g \<otimes> (f\<^sup>t \<odot> h)) (k,j))"
      by (simp add: inf_matrix_def)
    also have "... = (f \<odot> (g \<otimes> (f\<^sup>t \<odot> h))) (i,j)"
      by (simp add: times_matrix_def)
    finally show "((f \<odot> g) \<otimes> h) (i,j) \<le> (f \<odot> (g \<otimes> (f\<^sup>t \<odot> h))) (i,j)"
      .
  qed
next
  fix f g :: "('a,'b) square"
  show "\<ominus>\<ominus>(f \<odot> g) = \<ominus>\<ominus>f \<odot> \<ominus>\<ominus>g"
  proof (rule ext, rule prod_cases)
    fix i j
    have "(\<ominus>\<ominus>(f \<odot> g)) (i,j) = --((f \<odot> g) (i,j))"
      by (simp add: uminus_matrix_def)
    also have "... = --(\<Squnion>\<^sub>k f (i,k) * g (k,j))"
      by (simp add: times_matrix_def)
    also have "... = (\<Squnion>\<^sub>k --(f (i,k) * g (k,j)))"
      by (metis (no_types) pp_dist_sum)
    also have "... = (\<Squnion>\<^sub>k --(f (i,k)) * --(g (k,j)))"
      by (meson pp_dist_comp)
    also have "... = (\<Squnion>\<^sub>k (\<ominus>\<ominus>f) (i,k) * (\<ominus>\<ominus>g) (k,j))"
      by (simp add: uminus_matrix_def)
    also have "... = (\<ominus>\<ominus>f \<odot> \<ominus>\<ominus>g) (i,j)"
      by (simp add: times_matrix_def)
    finally show "(\<ominus>\<ominus>(f \<odot> g)) (i,j) = (\<ominus>\<ominus>f \<odot> \<ominus>\<ominus>g) (i,j)"
      .
  qed
next
  let ?o = "mone :: ('a,'b) square"
  show "\<ominus>\<ominus>?o = ?o"
  proof (rule ext, rule prod_cases)
    fix i j
    have "(\<ominus>\<ominus>?o) (i,j) = --(?o (i,j))"
      by (simp add: uminus_matrix_def)
    also have "... = --(if i = j then 1 else bot)"
      by (simp add: one_matrix_def)
    also have "... = (if i = j then --1 else --bot)"
      by simp
    also have "... = (if i = j then 1 else bot)"
      by auto
    also have "... = ?o (i,j)"
      by (simp add: one_matrix_def)
    finally show "(\<ominus>\<ominus>?o) (i,j) = ?o (i,j)"
      .
  qed
qed

end