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

theory System_V imports Main begin

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

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

primrec semantics (infix \<open>\<Turnstile>\<close> 0) where
  \<open>(I \<Turnstile> \<bottom>) = False\<close> |
  \<open>(I \<Turnstile> \<cdot> n) = I n\<close> |
  \<open>(I \<Turnstile> (p \<rightarrow> q)) = ((I \<Turnstile> p) \<longrightarrow> (I \<Turnstile> q))\<close>

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

section \<open>Axiomatic System\<close>

inductive V (\<open>\<then>\<close>) where
  MP: \<open>\<then> p\<close> if \<open>\<then> q\<close> and \<open>\<then> (q \<rightarrow> p)\<close> |
  CC: \<open>\<then> p\<close> if \<open>\<then> ((p \<rightarrow> q) \<rightarrow> p)\<close> |
  Tran: \<open>\<then> ((q \<rightarrow> r) \<rightarrow> ((r \<rightarrow> p) \<rightarrow> (q \<rightarrow> p)))\<close> |
  Simp: \<open>\<then> (p \<rightarrow> (q \<rightarrow> p))\<close> |
  Expl: \<open>\<then> (\<bottom> \<rightarrow> p)\<close>

section \<open>Soundness\<close>

theorem soundness: \<open>valid p\<close> if \<open>\<then> p\<close>
  using that by induct auto

section \<open>Derived Rules\<close>

lemma MPA: \<open>\<then> (p \<rightarrow> ((p \<rightarrow> q) \<rightarrow> q))\<close>
  by (metis Simp Tran CC MP)

lemma Swap: \<open>\<then> ((p \<rightarrow> (q \<rightarrow> r)) \<rightarrow> (q \<rightarrow> (p \<rightarrow> r)))\<close>
  by (meson MPA Tran MP)

lemma Peirce: \<open>\<then> (((p \<rightarrow> q) \<rightarrow> p) \<rightarrow> p)\<close>
  by (metis Simp Swap Tran CC MP)

lemma Hilbert: \<open>\<then> ((p \<rightarrow> (p \<rightarrow> q)) \<rightarrow> (p \<rightarrow> q))\<close>
  by (meson Peirce Tran MP)

lemma Tran': \<open>\<then> ((r \<rightarrow> p) \<rightarrow> ((q \<rightarrow> r) \<rightarrow> (q \<rightarrow> p)))\<close>
  by (meson Swap Tran MP)

lemma Frege: \<open>\<then> ((p \<rightarrow> (q \<rightarrow> r)) \<rightarrow> ((p \<rightarrow> q) \<rightarrow> (p \<rightarrow> r)))\<close>
  by (meson Hilbert Tran' MP Swap)

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>\<then> (imply (p # ps) p)\<close>
  by (induct ps) (metis Frege Simp MP imply.simps, metis Frege Simp MP imply.simps(2))

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

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

lemma imply_MP: \<open>\<then> (imply ps p \<rightarrow> (imply ps (p \<rightarrow> q) \<rightarrow> imply ps q))\<close>
proof (induct ps)
  case Nil
  then show ?case
    by (metis Frege Simp MP imply.simps(1))
next
  case (Cons r ps)
  then have \<open>\<then> ((r \<rightarrow> imply ps p) \<rightarrow> (r \<rightarrow> (imply ps (p \<rightarrow> q) \<rightarrow> imply ps q)))\<close>
    by (meson Frege Simp MP)
  then have \<open>\<then> ((r \<rightarrow> imply ps p) \<rightarrow> ((r \<rightarrow> imply ps (p \<rightarrow> q)) \<rightarrow> (r \<rightarrow> imply ps q)))\<close>
    by (meson Frege Simp MP)
  then show ?case
    by simp
qed

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

lemma add_imply: \<open>\<then> q \<Longrightarrow> \<then> (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>\<then> (imply (ps @ qs) r) \<Longrightarrow> \<then> (imply (qs @ ps) r)\<close>
proof (induct qs arbitrary: ps)
  case Cons
  then show ?case
    using imply_Cons imply_head imply_mp' imply.simps(2) imply_append by metis
qed simp

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

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

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

lemma cut': \<open>\<then> (imply (p # ps) r) \<Longrightarrow> \<then> (imply (q # ps) p) \<Longrightarrow> \<then> (imply (q # ps) r)\<close>
  using cut deduct imply_Cons by meson

abbreviation Neg (\<open>\<sim>\<close>) where \<open>\<sim> p \<equiv> (p \<rightarrow> \<bottom>)\<close>

lemma Neg: \<open>\<then> (\<sim> (\<sim> p) \<rightarrow> p)\<close>
  by (meson Expl Peirce Tran' MP)

section \<open>Consistent\<close>

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

lemma UN_finite_bound:
  assumes \<open>finite A\<close> \<open>A \<subseteq> (\<Union>n. f n)\<close>
  shows \<open>\<exists>m :: nat. A \<subseteq> (\<Union>n \<le> m. f n)\<close>
  using assms
proof (induct rule: finite_induct)
  case (insert x A)
  then obtain m where \<open>A \<subseteq> (\<Union>n \<le> m. f n)\<close>
    by fast
  then have \<open>A \<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> A \<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>\<then> (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>\<then> (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 n where n: \<open>f n = p\<close>
    using \<open>surj f\<close> unfolding surj_def by metis
  then have \<open>p \<notin> extend S f (Suc n)\<close>
    using \<open>p \<notin> Extend S f\<close> unfolding Extend_def by blast
  then have \<open>\<not> consistent ({p} \<union> extend S f n)\<close>
    using n by fastforce
  moreover have \<open>{p} \<union> extend S f n \<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>

definition hintikka :: \<open>form set \<Rightarrow> bool\<close> where
  \<open>hintikka H \<equiv>
    \<bottom> \<notin> H \<and>
    (\<forall>n. \<cdot> n \<in> H \<longrightarrow> (\<sim> (\<cdot> n)) \<notin> H) \<and>
    (\<forall>p q. (p \<rightarrow> q) \<in> H \<longrightarrow> (\<sim> p) \<in> H \<or> q \<in> H) \<and>
    (\<forall>p q. (\<sim> (p \<rightarrow> q)) \<in> H \<longrightarrow> p \<in> H \<and> \<sim> q \<in> H)\<close>

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

lemma hintikka_model:
  assumes \<open>hintikka H\<close>
  shows \<open>(p \<in> H \<longrightarrow> (model H \<Turnstile> p)) \<and> (\<sim> p \<in> H \<longrightarrow> \<not> (model H \<Turnstile> p))\<close>
  using assms 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'. \<then> (imply (p # S') \<bottom>) \<and> set S' \<subseteq> S\<close>
proof -
  obtain S' where S': \<open>\<then> (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>\<then> (imply (p # S'') \<bottom>)\<close> \<open>set S'' = set S' - {p}\<close>
    using imply_weaken by (metis Diff_single_insert list.set(2) 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>
  unfolding hintikka_def
proof safe
  assume \<open>\<bottom> \<in> S\<close>
  then show False
    using assms(2) imply_head unfolding consistent_def
    by (metis all_not_in_conv empty_set insert_subset list.simps(15) subsetI)
next
  fix n
  assume \<open>\<cdot> n \<in> S\<close> \<open>(\<sim> (\<cdot> n)) \<in> S\<close>
  moreover have \<open>\<then> (imply [\<cdot> n, \<sim> (\<cdot> n)] \<bottom>)\<close>
    using deduct imply_head by blast
  ultimately show False
    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> \<open>q \<notin> S\<close>
  then obtain Sq' where Sq': \<open>\<then> (imply (q # Sq') \<bottom>)\<close> \<open>set Sq' \<subseteq> S\<close>
    using assms inconsistent_head by blast
  show \<open>\<sim> p \<in> S\<close>
  proof (rule ccontr)
    assume \<open>\<sim> p \<notin> S\<close>
    then obtain Sp' where Sp': \<open>\<then> (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>\<then> (imply (\<sim> p # S') \<bottom>)\<close> \<open>\<then> (imply (q # S') \<bottom>)\<close>
    proof -
      have \<open>set Sp' \<subseteq> set S'\<close>
        using S' by blast
      then show \<open>\<then> (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>\<then> (imply (q # S') \<bottom>)\<close>
        by (metis Sq'(1) deduct imply_weaken)
    qed
    then have \<open>\<then> (imply ((p \<rightarrow> q) # S') \<bottom>)\<close>
      using Neg add_imply cut' deduct imply_Cons imply_head imply_mp' by metis
    moreover have \<open>set ((p \<rightarrow> q) # S') \<subseteq> S\<close>
      using *(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\<close>
  proof (rule ccontr)
    assume \<open>p \<notin> S\<close>
    then obtain S' where S': \<open>\<then> (imply (p # S') \<bottom>)\<close> \<open>set S' \<subseteq> S\<close>
      using assms inconsistent_head by blast
    then have \<open>\<then> (imply ((\<sim> (p \<rightarrow> q)) # S') p)\<close>
      using Frege Simp Neg Tran MP add_imply deduct by metis
    then have \<open>\<then> (imply ((\<sim> (p \<rightarrow> q)) # S') \<bottom>)\<close>
      using cut' S'(1) 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
  fix p q
  assume *: \<open>(\<sim> (p \<rightarrow> q)) \<in> S\<close>
  show \<open>\<sim> q \<in> S\<close>
  proof (rule ccontr)
    assume \<open>\<sim> q \<notin> S\<close>
    then obtain S' where S': \<open>\<then> (imply (\<sim> q # S') \<bottom>)\<close> \<open>set S' \<subseteq> S\<close>
      using assms inconsistent_head by blast
    then have \<open>\<then> (imply ((\<sim> (p \<rightarrow> q)) # S') (\<sim> q))\<close>
      using Frege Simp Neg Tran MP add_imply deduct by metis
    then have \<open>\<then> (imply ((\<sim> (p \<rightarrow> q)) # S') \<bottom>)\<close>
      using cut' S'(1) 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
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 0) = Falsity\<close>
| \<open>form_of_btree (Branch (Leaf 0) (Leaf n)) = \<cdot> n\<close>
| \<open>form_of_btree (Branch (Leaf (Suc 0)) (Branch t1 t2)) =
     ((form_of_btree t1) \<rightarrow> (form_of_btree t2))\<close>
| \<open>form_of_btree (Leaf (Suc _)) = undefined\<close>
| \<open>form_of_btree (Branch (Leaf 0) (Branch _ _)) = undefined\<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 Falsity = Leaf 0\<close>
| \<open>btree_of_form (\<cdot> n) = Branch (Leaf 0) (Leaf n)\<close>
| \<open>btree_of_form (p \<rightarrow> 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. list_all (\<lambda>q. (I \<Turnstile> q)) ps \<longrightarrow> (I \<Turnstile> p)\<close>
  shows \<open>\<then> (imply ps p)\<close>
proof (rule ccontr)
  assume \<open>\<not> \<then> (imply ps p)\<close>
  then have *: \<open>\<not> \<then> (imply (\<sim> p # ps) \<bottom>)\<close>
    using Neg add_imply deduct imply_mp' by metis
  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
  then have \<open>model ?H \<Turnstile> p\<close> if \<open>p \<in> ?S\<close> for p
    using that Extend_subset hintikka_model 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 completeness: \<open>\<then> p\<close> if \<open>valid p\<close>
  using that imply_completeness[where ps=\<open>[]\<close>] by simp

section \<open>Main Result\<close>

theorem main: \<open>valid p \<longleftrightarrow> \<then> p\<close>
proof
  assume \<open>valid p\<close>
  with completeness show \<open>\<then> p\<close> .
next
  assume \<open>\<then> p\<close>
  with soundness show \<open>valid p\<close> .
qed

section \<open>Appendix Isabelle Workshop\<close>

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

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

theorem
  \<open>valid p \<longleftrightarrow> \<turnstile> p\<close>
  \<open>valid p \<longleftrightarrow> \<tturnstile> p\<close>
proof -
  have H: \<open>\<turnstile> ((r \<rightarrow> (r \<rightarrow> p)) \<rightarrow> (r \<rightarrow> p))\<close> for p r
    by (metis U.intros(1-3))
  have T: \<open>\<turnstile> ((r \<rightarrow> q) \<rightarrow> ((q \<rightarrow> p) \<rightarrow> (r \<rightarrow> p)))\<close> for p q r
    by (meson U.intros(1-3))
  have S: \<open>\<turnstile> ((r \<rightarrow> (q \<rightarrow> p)) \<rightarrow> (q \<rightarrow> (r \<rightarrow> p)))\<close> for p q r
    by (meson U.intros(1-3) T)
  have T': \<open>\<turnstile> ((q \<rightarrow> p) \<rightarrow> ((r \<rightarrow> q) \<rightarrow> (r \<rightarrow> p)))\<close> for p q r
    by (meson U.intros(1) S T)
  have F: \<open>\<turnstile> ((r \<rightarrow> (q \<rightarrow> p)) \<rightarrow> ((r \<rightarrow> q) \<rightarrow> (r \<rightarrow> p)))\<close> for p q r
    by (meson T' U.intros(1) S H)
  have F': \<open>\<turnstile> ((r \<rightarrow> q) \<rightarrow> ((r \<rightarrow> (q \<rightarrow> p)) \<rightarrow> (r \<rightarrow> p)))\<close> for p q r
    by (meson U.intros(1) S F)
  have \<open>\<tturnstile> ((r \<rightarrow> (q \<rightarrow> p)) \<rightarrow> ((r \<rightarrow> q) \<rightarrow> (r \<rightarrow> p)))\<close> for p q r
    by (use W.intros(1-3) in metis)
  with W.intros(1,3) have *: \<open>\<tturnstile> ((r \<rightarrow> q) \<rightarrow> ((q \<rightarrow> p) \<rightarrow> (r \<rightarrow> p)))\<close> for p q r
    by metis
  note main
  moreover have \<open>\<tturnstile> p\<close> if \<open>\<then> p\<close>
    using that by induct (use * W.intros in metis)+
  moreover have \<open>\<then> p\<close> if \<open>\<tturnstile> p\<close>
    using that by induct (use MP Frege Simp Neg Swap in metis)+
  ultimately show \<open>valid p \<longleftrightarrow> \<tturnstile> p\<close>
    by fast
  note this
  moreover have \<open>\<turnstile> p\<close> if \<open>\<tturnstile> p\<close>
    using that by induct (use F' U.intros(1,3,4) in metis)+
  moreover have \<open>\<tturnstile> p\<close> if \<open>\<turnstile> p\<close>
    using that by induct (use * W.intros in metis)+
  ultimately show \<open>valid p \<longleftrightarrow> \<turnstile> p\<close>
    by fast
qed

end


(*<*)
theory hw08tmpl
  imports Complex_Main "HOL-Library.Tree"
begin
(*>*)

text {* \NumHomework{Bounding Fibonacci}{June 8}

  We start by defining the Fibonacci sequence, and an alternative
  induction scheme for indexes greater 0:
*}

fun fib :: "nat \<Rightarrow> nat"
  where
    fib0: "fib 0 = 0"
  | fib1: "fib (Suc 0) = 1"
  | fib2: "fib (Suc (Suc n)) = fib (Suc n) + fib n"

lemma f_alt_induct [consumes 1, case_names 1 2 rec]:
  assumes "n > 0"
      and "P (Suc 0)" "P 2" "\<And>n. n > 0 \<Longrightarrow> P n \<Longrightarrow> P (Suc n) \<Longrightarrow> P (Suc (Suc n))"
  shows   "P n"
  using assms(1)
proof (induction n rule: fib.induct)
  case (3 n)
  thus ?case using assms by (cases n) (auto simp: eval_nat_numeral)
qed (auto simp: \<open>P (Suc 0)\<close> \<open>P 2\<close>)

text \<open>Show that the Fibonacci numbers grow exponentially, i.e., that they are
  bounded from below by \<open>1.5\<^sup>n/3\<close>.

  Use the alternative induction scheme defined above.
\<close>
lemma fib_lowerbound: "n > 0 \<Longrightarrow> real (fib n) \<ge> 1.5 ^ n / 3"
proof (induction n rule: f_alt_induct)
oops

text \<open>
  \NumHomework{AVL Trees}{June 8}

  AVL trees are binary search trees where, for each node, the heights of
  its subtrees differ by at most one. In this homework, you are to bound
  the minimal number of nodes in an AVL tree of a given height.

  First, define the AVL invariant on binary trees.
  Note: In practice, one additionally stores the heights or height difference
  in the nodes, but this is not required for this exercise.
\<close>

fun avl :: "'a tree \<Rightarrow> bool"
where
"avl _ = undefined"

text \<open>Show that an AVL tree of height \<open>h\<close> has at least \<open>fib (h+2)\<close> nodes:\<close>
lemma avl_fib_bound: "avl t \<Longrightarrow> height t = h \<Longrightarrow> fib (h+2) \<le> size1 t"
  oops

text \<open>Combine your results to get an exponential lower bound on the number
  of nodes in an AVL tree.\<close>
lemma avl_lowerbound:
  assumes "avl t"
  shows "1.5 ^ (height t + 2) / 3 \<le> real (size1 t)"
  oops

(*<*)
end
(*>*)


(* Title: Quantales
   Author: Georg Struth
   Maintainer: Georg Struth <g.struth@sheffield.ac.uk>
   Contributions by Brijesh Dongol, Victor Gomes, Ian Hayes
*)

section \<open>Quantales\<close>

theory Quantales
  imports
    "Order_Lattice_Props.Closure_Operators"
   Kleene_Algebra.Dioid
begin

subsection \<open>Families of Proto-Quantales\<close>

text \<open>Proto-Quanales are complete lattices equipped with an operation of composition or multiplication
that need not be associative. The notation in this component differs from Rosenthal's \cite{Rosenthal90}, but is consistent with the one we use
for semirings and Kleene algebras.\<close>

class proto_near_quantale = complete_lattice + times +
  assumes Sup_distr: "\<Squnion>X \<cdot> y = (\<Squnion>x \<in> X. x \<cdot> y)"

lemma Sup_pres_multr: "Sup_pres (\<lambda>(z::'a::proto_near_quantale). z \<cdot> y)"
  unfolding fun_eq_iff comp_def Sup_distr by simp

lemma sup_pres_multr: "sup_pres (\<lambda>(z::'a::proto_near_quantale). z \<cdot> y)"
  using Sup_pres_multr Sup_sup_pres by fastforce

lemma bot_pres_multr: "bot_pres (\<lambda>(z::'a::proto_near_quantale). z \<cdot> y)"
  by (metis SUP_empty Sup_distr Sup_empty)

context proto_near_quantale
begin

lemma mult_botl [simp]: "\<bottom> \<cdot> x = \<bottom>"
proof -
  have "\<bottom> \<cdot> x = (\<Squnion>a\<in>{}. a \<cdot> x)"
    using Sup_distr Sup_empty by blast
  thus ?thesis
    by simp
qed

lemma sup_distr: "(x \<squnion> y) \<cdot> z = (x \<cdot> z) \<squnion> (y \<cdot> z)"
  by (smt SUP_empty SUP_insert Sup_distr sup_Sup sup_bot.right_neutral)

lemma mult_isor: "x \<le> y \<Longrightarrow> x \<cdot> z \<le> y \<cdot> z"
  by (metis sup.absorb_iff1 sup_distr)

text \<open>Left and right residuals can be defined in every proto-nearquantale.\<close>

definition bres :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<rightarrow>" 60) where
  "x \<rightarrow> z = \<Squnion>{y. x \<cdot> y \<le> z}"

definition fres :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<leftarrow>" 60) where
  "z \<leftarrow> y = \<Squnion>{x. x \<cdot> y \<le> z}"

text \<open>The left one is a right adjoint  to composition. For the right one, additional assumptions are needed\<close>

lemma bres_galois_imp: "x \<cdot> y \<le> z \<Longrightarrow> y \<le> x \<rightarrow> z"
  by (simp add: Sup_upper bres_def)

lemma fres_galois: "(x \<cdot> y \<le> z) = (x \<le> z \<leftarrow> y)"
proof
  show "x \<cdot> y \<le> z \<Longrightarrow> x \<le> z \<leftarrow> y"
    by (simp add: Sup_upper fres_def)
next
  assume "x \<le> z \<leftarrow> y"
  hence "x \<cdot> y \<le> \<Squnion>{x. x \<cdot> y \<le> z} \<cdot> y"
    by (simp add: fres_def mult_isor)
  also have "... = \<Squnion>{x \<cdot> y |x. x \<cdot> y \<le> z}"
    by (simp add: Sup_distr setcompr_eq_image)
  also have "... \<le> z"
    by (rule Sup_least, auto)
  finally show "x \<cdot> y \<le> z" .
qed

end

lemma fres_adj: "(\<lambda>(x::'a::proto_near_quantale). x \<cdot> y) \<stileturn> (\<lambda>x. x \<leftarrow> y)"
  by (simp add: adj_def fres_galois)

context proto_near_quantale
begin

lemma fres_canc1: "(y \<leftarrow> x) \<cdot> x \<le> y"
  by (simp add: fres_galois)

lemma fres_canc2: "y \<le> (y \<cdot> x) \<leftarrow> x"
  using fres_galois by force

lemma inf_fres: "y \<cdot> x = \<Sqinter>{z. y \<le> z \<leftarrow> x}"
  by (metis (mono_tags, lifting) fres_canc2 Inf_eqI fres_galois mem_Collect_eq)

lemma bres_iso: "x \<le> y \<Longrightarrow> z \<rightarrow> x \<le> z \<rightarrow> y"
  using Sup_le_iff bres_def bres_galois_imp by force

lemma bres_anti: "x \<le> y \<Longrightarrow> y \<rightarrow> z \<le> x \<rightarrow> z"
  by (smt Sup_le_iff bres_def bres_galois_imp fres_galois order_trans mem_Collect_eq)

lemma fres_iso: "x \<le> y \<Longrightarrow> x \<leftarrow> z \<le> y \<leftarrow> z"
  using fres_galois dual_order.trans by blast

lemma bres_top_top [simp]: "\<top> \<rightarrow> \<top> = \<top>"
  by (simp add: bres_galois_imp dual_order.antisym)

lemma fres_top_top [simp]: "\<top> \<leftarrow> \<top> = \<top>"
  using fres_galois top_greatest top_le by blast

lemma bres_bot_bot [simp]: "\<bottom> \<rightarrow> \<bottom> = \<top>"
  by (simp add: bres_galois_imp top_le)

lemma left_sided_localp: "\<top> \<cdot> y = y \<Longrightarrow> x \<cdot> y \<le> y"
  by (metis mult_isor top_greatest)

lemma fres_sol: "((y \<leftarrow> x) \<cdot> x = y) = (\<exists>z. z \<cdot> x = y)"
  using dual_order.antisym fres_canc1 fres_canc2 mult_isor by fastforce

lemma sol_fres: "((y \<cdot> x) \<leftarrow> x = y) = (\<exists>z. y = z \<leftarrow> x)"
  by (metis fres_canc1 fres_canc2 fres_sol eq_iff fres_galois)

end

class proto_pre_quantale = proto_near_quantale +
  assumes Sup_subdistl: "(\<Squnion>y \<in> Y. x \<cdot> y) \<le> x \<cdot> \<Squnion>Y"

begin

lemma sup_subdistl: "(x \<cdot> y) \<squnion> (x \<cdot> z) \<le> x \<cdot> (y \<squnion> z)"
  by (smt SUP_empty SUP_insert Sup_subdistl sup_Sup sup_bot_right)

lemma mult_isol: "x \<le> y \<Longrightarrow> z \<cdot> x \<le> z \<cdot> y"
  by (metis le_iff_sup le_sup_iff sup_subdistl)

lemma fres_anti: "x \<le> y \<Longrightarrow> z \<leftarrow> y \<le> z \<leftarrow> x"
  using dual_order.trans fres_galois mult_isol by blast

end

class weak_proto_quantale = proto_near_quantale +
  assumes weak_Sup_distl: "Y \<noteq> {} \<Longrightarrow> x \<cdot> \<Squnion>Y = (\<Squnion>y \<in> Y. x \<cdot> y)"

begin

subclass proto_pre_quantale
proof unfold_locales
  have a: "\<And>x Y. Y = {} \<Longrightarrow> (\<Squnion>y \<in> Y. x \<cdot> y) \<le> x \<cdot> \<Squnion>Y"
    by simp
  have b: "\<And>x Y. Y \<noteq> {} \<Longrightarrow> (\<Squnion>y \<in> Y. x \<cdot> y) \<le> x \<cdot> \<Squnion>Y"
    by (simp add: weak_Sup_distl)
  show  "\<And>x Y. (\<Squnion>y \<in> Y. x \<cdot> y) \<le> x \<cdot> \<Squnion>Y"
    using a b by blast
qed

lemma  sup_distl: "x \<cdot> (y \<squnion> z) = (x \<cdot> y) \<squnion> (x \<cdot> z)"
  using weak_Sup_distl[where Y="{y, z}"] by (fastforce intro!: Sup_eqI)

lemma "y \<le> x \<rightarrow> z \<longrightarrow> x \<cdot> y \<le> z" (* nitpick [expect = genuine] *)
oops

end

class proto_quantale = proto_near_quantale +
  assumes Sup_distl: "x \<cdot> \<Squnion>Y = (\<Squnion>y \<in> Y. x \<cdot> y)"

lemma Sup_pres_multl: "Sup_pres (\<lambda>(z::'a::proto_quantale). x \<cdot> z)"
  unfolding fun_eq_iff comp_def Sup_distl by simp

lemma sup_pres_multl: "sup_pres (\<lambda>(z::'a::proto_quantale). x \<cdot> z)"
  by (metis (no_types, lifting) SUP_insert Sup_distl Sup_empty Sup_insert sup_bot_right)

lemma bot_pres_multl: "bot_pres (\<lambda>(z::'a::proto_quantale). x \<cdot> z)"
  by (metis SUP_empty Sup_distl Sup_empty)

context proto_quantale
begin

subclass weak_proto_quantale
  by standard (simp add: Sup_distl)

lemma mult_botr [simp]: "x \<cdot> \<bottom> = \<bottom>"
  by (smt image_empty Sup_distl Sup_empty)

text \<open>Now there is also an adjunction for the other residual.\<close>

lemma bres_galois: "x \<cdot> y \<le> z \<longleftrightarrow> y \<le> x \<rightarrow> z"
proof
  show "x \<cdot> y \<le> z \<Longrightarrow> y \<le> x \<rightarrow> z"
    by (simp add: Sup_upper bres_def)
next
  assume "y \<le> x \<rightarrow> z"
  hence "x \<cdot> y \<le> x \<cdot> \<Squnion>{y. x \<cdot> y \<le> z}"
    by (simp add: bres_def mult_isol)
  also have "... = \<Squnion>{x \<cdot> y |y. x \<cdot> y \<le> z}"
    by (simp add: Sup_distl setcompr_eq_image)
  also have "... \<le> z"
    by (rule Sup_least, safe)
  finally show "x \<cdot> y \<le> z" .
qed

end

lemma bres_adj: "(\<lambda>(y::'a::proto_quantale). x \<cdot> y) \<stileturn> (\<lambda>y. x \<rightarrow> y)"
  by (simp add: adj_def bres_galois)

context proto_quantale
begin

lemma bres_canc1: "x \<cdot> (x \<rightarrow> y) \<le> y"
  by (simp add: bres_galois)

lemma bres_canc2: "y \<le> x \<rightarrow> (x \<cdot> y)"
  by (simp add: bres_galois_imp)

lemma  inf_bres: "x \<cdot> y = \<Sqinter>{z. y \<le> x \<rightarrow> z}"
  using bres_galois fres_galois inf_fres by force

lemma bres_sol: "(x \<cdot> (x \<rightarrow> y) = y) = (\<exists>z. x \<cdot> z = y)"
  using bres_galois antisym mult_isol by force

lemma sol_bres: "(x \<rightarrow> (x \<cdot> y) = y) = (\<exists>z. y = x \<rightarrow> z)"
  by (metis bres_canc1 bres_canc2 bres_iso eq_iff)

end

lemma bres_fres_clop: "clop (\<lambda>x::'a::proto_quantale. y \<leftarrow> (x \<rightarrow> y))"
  unfolding clop_def comp_def mono_def le_fun_def
  by (metis bres_anti bres_canc1 bres_galois_imp fres_anti fres_galois id_apply)

lemma fres_bres_clop: "clop (\<lambda>x::'a::proto_quantale. (y \<leftarrow> x) \<rightarrow> y)"
  unfolding clop_def comp_def mono_def le_fun_def
  by (metis bres_anti bres_canc1 bres_galois_imp fres_anti fres_canc1 fres_galois id_apply)

subsection \<open>Families of Quantales\<close>

class near_quantale = proto_near_quantale + semigroup_mult

sublocale near_quantale \<subseteq> nsrnq: near_dioid "(\<squnion>)" "(\<cdot>)" "(\<le>)" "(<)"
  apply unfold_locales
       apply (simp add: sup_assoc)
      apply (simp add: sup_commute)
     apply (simp_all add: sup_distr)
   apply (simp add: le_iff_sup)
  by auto

context near_quantale
begin

lemma fres_curry: "(z \<leftarrow> y) \<leftarrow> x = z \<leftarrow> (x \<cdot> y)"
  by (metis eq_iff fres_canc1 fres_galois mult_assoc)

end

class unital_near_quantale = near_quantale + monoid_mult

sublocale unital_near_quantale \<subseteq> nsrnqo: near_dioid_one "(\<squnion>)" "(\<cdot>)" "1""(\<le>)" "(<)"
  by (unfold_locales, simp_all)

context unital_near_quantale
begin

definition iter :: "'a \<Rightarrow> 'a" where
  "iter x \<equiv> \<Sqinter>i. x ^ i"

lemma iter_ref [simp]: "iter x \<le> 1"
  by (metis iter_def Inf_lower power.power_0 rangeI)

lemma le_top: "x \<le> \<top> \<cdot> x"
  by (metis mult.left_neutral mult_isor top_greatest)

lemma top_times_top [simp]: "\<top> \<cdot> \<top> = \<top>"
  by (simp add: le_top top_le)

lemma bres_one: "1 \<le> x \<rightarrow> x"
  by (simp add: bres_galois_imp)

lemma fres_one: "1 \<le> x \<leftarrow> x"
  using fres_galois by fastforce

end

class pre_quantale = proto_pre_quantale + semigroup_mult

begin

subclass near_quantale ..

lemma fres_interchange: "z \<cdot> (x \<leftarrow> y) \<le> (z \<cdot> x) \<leftarrow> y"
  using Sup_upper fres_canc1 fres_def mult_isol mult_assoc by fastforce

end

sublocale pre_quantale \<subseteq>  psrpq: pre_dioid "(\<squnion>)" "(\<cdot>)" "(\<le>)" "(<)"
  by (unfold_locales, simp add: mult_isol)

class unital_pre_quantale = pre_quantale + monoid_mult

begin

subclass unital_near_quantale ..

text \<open>Abstract rules of Hoare logic without the star can be derived.\<close>

lemma h_w1: "x \<le> x' \<Longrightarrow>  x' \<cdot> y \<le> z \<Longrightarrow> x \<cdot> y \<le> z"
  by (simp add: fres_galois)

lemma h_w2: "x \<cdot> y \<le> z' \<Longrightarrow> z' \<le> z \<Longrightarrow> x \<cdot> y \<le> z"
  using order_trans by blast

lemma h_seq: "x \<cdot> v \<le> z \<Longrightarrow> y \<cdot> w \<le> v \<Longrightarrow> x \<cdot> y \<cdot> w \<le> z"
  using dual_order.trans mult_isol mult_assoc by presburger

lemma h_sup: "x \<cdot> w \<le> z \<Longrightarrow> y \<cdot> w \<le> z \<Longrightarrow> (x \<squnion> y) \<cdot> w \<le> z"
  by (simp add: fres_galois)

lemma h_Sup: "\<forall>x \<in> X. x \<cdot> w \<le> z \<Longrightarrow> \<Squnion>X \<cdot> w \<le> z"
  by (simp add: Sup_least fres_galois)

end

sublocale unital_pre_quantale \<subseteq>  psrpqo: pre_dioid_one "(\<squnion>)" "(\<cdot>)" "1" "(\<le>)" "(<)"..

class weak_quantale = weak_proto_quantale + semigroup_mult

begin

subclass pre_quantale ..

text \<open>The following counterexample shows an important consequence of weakness:
the absence of right annihilation.\<close>

lemma "x \<cdot> \<bottom> = \<bottom>" (*nitpick[expect=genuine]*)
  oops

end

class unital_weak_quantale = weak_quantale + monoid_mult

lemma (in unital_weak_quantale) "x \<cdot> \<bottom> = \<bottom>" (*nitpick[expect=genuine]*)
  oops

subclass (in unital_weak_quantale) unital_pre_quantale ..

sublocale unital_weak_quantale \<subseteq>  wswq: dioid_one_zerol "(\<squnion>)" "(\<cdot>)" "1" "\<bottom>" "(\<le>)" "(<)"
  by (unfold_locales, simp_all add: sup_distl)

class quantale = proto_quantale + semigroup_mult

begin

subclass weak_quantale ..

lemma Inf_subdistl: "x \<cdot> \<Sqinter>Y \<le> (\<Sqinter>y \<in> Y. x \<cdot> y)"
  by (auto intro!: Inf_greatest Inf_lower mult_isol)

lemma Inf_subdistr: "\<Sqinter> X \<cdot> y \<le> (\<Sqinter>x \<in> X. x \<cdot> y)"
  by (auto intro!: Inf_greatest Inf_lower mult_isor)

lemma fres_bot_bot [simp]: "\<bottom> \<leftarrow> \<bottom> = \<top>"
  by (simp add: fres_def)

lemma bres_interchange: "(x \<rightarrow> y) \<cdot> z \<le> x \<rightarrow> (y \<cdot> z)"
  by (metis bres_canc1 bres_galois mult_isor mult_assoc)

lemma bres_curry: "x \<rightarrow> (y \<rightarrow> z) = (y \<cdot> x) \<rightarrow> z"
  by (metis bres_canc1 bres_galois dual_order.antisym mult_assoc)

lemma fres_bres: "x \<rightarrow> (y \<leftarrow> z) = (x \<rightarrow> y) \<leftarrow> z"
proof-
  {fix w
  have "(w \<le> x \<rightarrow> (y \<leftarrow> z)) = (x \<cdot> w \<le> y \<leftarrow> z)"
    by (simp add: bres_galois)
  also have "... = (x \<cdot> w \<cdot> z \<le> y)"
    by (simp add: fres_galois)
  also have "... = (w \<cdot> z \<le> x \<rightarrow> y)"
    by (simp add: bres_galois mult_assoc)
  also have "... = (w \<le> (x \<rightarrow> y) \<leftarrow> z)"
    by (simp add: fres_galois)
  finally have "(w \<le> x \<rightarrow> (y \<leftarrow> z)) = (w \<le> (x \<rightarrow> y) \<leftarrow> z)".}
  thus ?thesis
    using eq_iff by blast
qed

end

class quantale_with_dual = quantale + complete_lattice_with_dual

class unital_quantale = quantale + monoid_mult

class unital_quantale_with_dual = unital_quantale + quantale_with_dual

subclass (in unital_quantale) unital_weak_quantale ..

sublocale unital_quantale \<subseteq> wswq: dioid_one_zero "(\<squnion>)" "(\<cdot>)" "1" "\<bottom>" "(\<le>)" "(<)"
  by (unfold_locales, simp)

class ab_quantale = quantale + ab_semigroup_mult

begin

lemma bres_fres_eq: "x \<rightarrow> y = y \<leftarrow> x"
  by (simp add: fres_def bres_def mult_commute)

end

class ab_unital_quantale = ab_quantale + unital_quantale

sublocale complete_heyting_algebra \<subseteq> chaq: ab_unital_quantale "(\<sqinter>)" _ _ _ _ _ _ _ _ \<top>
  by (unfold_locales, simp add: inf.assoc, simp_all add: inf.assoc ch_dist inf.commute)

class distrib_quantale = quantale + distrib_lattice

class bool_quantale = quantale + complete_boolean_algebra_alt

class distrib_unital_quantale = unital_quantale + distrib_lattice

class bool_unital_quantale = unital_quantale + complete_boolean_algebra_alt

class distrib_ab_quantale = distrib_quantale + ab_quantale

class bool_ab_quantale = bool_quantale + ab_quantale

class distrib_ab_unital_quantale = distrib_quantale + unital_quantale

class bool_ab_unital_quantale = bool_ab_quantale + unital_quantale

sublocale complete_boolean_algebra \<subseteq> cba_quantale: bool_ab_unital_quantale inf _ _ _ _ _ _ _ _ _ _ \<top>
  by (unfold_locales, simp add: inf.assoc, simp_all add: inf.commute Setcompr_eq_image inf_Sup Sup_inf)

context complete_boolean_algebra
begin

text \<open>In this setting, residuation is classical implication.\<close>

lemma cba_bres1: "x \<sqinter> y \<le> z \<longleftrightarrow> x \<le> cba_quantale.bres y z"
  using cba_quantale.bres_galois inf.commute by fastforce

lemma cba_bres2: "x \<le> -y \<squnion> z \<longleftrightarrow> x \<le> cba_quantale.bres y z"
  using cba_bres1 shunt1 by auto

lemma cba_bres_prop: "cba_quantale.bres x y = -x \<squnion> y"
  using cba_bres2 eq_iff by blast

end

subsection \<open>Quantales Based on Sup-Lattices and Inf-Lattices\<close>

text \<open>These classes are defined for convenience in instantiation and interpretation proofs, or likewise.
They are useful, e.g., in the context of predicate transformers, where only one of Sup or Inf may be well behaved.\<close>

class Sup_quantale = Sup_lattice + semigroup_mult +
  assumes Supq_distr: "\<Squnion>X \<cdot> y = (\<Squnion>x \<in> X. x \<cdot> y)"
  and Supq_distl: "x \<cdot> \<Squnion>Y = (\<Squnion>y \<in> Y. x \<cdot> y)"

class unital_Sup_quantale = Sup_quantale + monoid_mult

class Inf_quantale = Inf_lattice + monoid_mult +
  assumes Supq_distr: "\<Sqinter>X \<cdot> y = (\<Sqinter>x \<in> X. x \<cdot> y)"
  and Supq_distl: "x \<cdot> \<Sqinter>Y = (\<Sqinter>y \<in> Y. x \<cdot> y)"

class unital_Inf_quantale = Inf_quantale + monoid_mult

sublocale Inf_quantale \<subseteq> qdual: Sup_quantale _ Inf "(\<ge>)"
  by (unfold_locales, simp_all add: Supq_distr Supq_distl)

sublocale unital_Inf_quantale \<subseteq> uqdual: unital_Sup_quantale _ _ Inf  "(\<ge>)"..

sublocale Sup_quantale \<subseteq> supq: quantale _ Infs Sup_class.Sup infs "(\<le>)" le sups bots tops
  by (unfold_locales, simp_all add: Supq_distr Supq_distl)

sublocale unital_Sup_quantale \<subseteq> usupq: unital_quantale _ _ Infs Sup_class.Sup infs "(\<le>)" le sups bots tops..

subsection \<open>Products of Quantales\<close>

definition "Inf_prod X = ((\<Sqinter>x \<in> X. fst x), (\<Sqinter>x \<in> X. snd x))"

definition "inf_prod x y = (fst x \<sqinter> fst y, snd x \<sqinter> snd y)"

definition "bot_prod = (bot,bot)"

definition "Sup_prod X = ((\<Squnion>x \<in> X. fst x), (\<Squnion>x \<in> X. snd x))"

definition "sup_prod x y = (fst x \<squnion> fst y, snd x \<squnion> snd y)"

definition "top_prod = (top,top)"

definition "less_eq_prod x y \<equiv> less_eq (fst x) (fst y) \<and> less_eq (snd x) (snd y)"

definition "less_prod x y \<equiv> less_eq (fst x) (fst y) \<and> less_eq (snd x) (snd y) \<and> x \<noteq> y"

definition "times_prod' x y = (fst x \<cdot> fst y, snd x \<cdot> snd y)"

definition "one_prod = (1,1)"

definition "dual_prod x = (\<partial> (fst x),\<partial> (snd x))"

interpretation prod: complete_lattice Inf_prod Sup_prod inf_prod less_eq_prod less_prod sup_prod bot_prod "top_prod :: ('a::complete_lattice \<times> 'b::complete_lattice)"
  by standard (auto simp add: Inf_prod_def Sup_prod_def inf_prod_def sup_prod_def bot_prod_def top_prod_def less_eq_prod_def less_prod_def Sup_distl Sup_distr intro: Inf_lower Inf_greatest Sup_upper Sup_least)

interpretation prod: complete_lattice_with_dual Inf_prod Sup_prod inf_prod less_eq_prod less_prod sup_prod bot_prod "top_prod :: ('a::complete_lattice_with_dual \<times> 'b::complete_lattice_with_dual)" dual_prod
  by standard (simp_all add: dual_prod_def fun_eq_iff inj_def Sup_prod_def Inf_prod_def inj_dual_iff Sup_dual_def_var image_comp)

interpretation prod: proto_near_quantale Inf_prod Sup_prod inf_prod less_eq_prod less_prod sup_prod bot_prod "top_prod :: ('a::proto_near_quantale \<times> 'b::proto_near_quantale)" times_prod'
  by standard (simp add: times_prod'_def Sup_prod_def Sup_distr image_comp)

interpretation prod: proto_quantale Inf_prod Sup_prod inf_prod less_eq_prod less_prod sup_prod bot_prod "top_prod :: ('a::proto_quantale \<times> 'b::proto_quantale)" times_prod'
  by standard (simp add: times_prod'_def Sup_prod_def less_eq_prod_def Sup_distl image_comp)

interpretation prod: unital_quantale one_prod times_prod' Inf_prod Sup_prod inf_prod less_eq_prod less_prod sup_prod bot_prod "top_prod :: ('a::unital_quantale \<times> 'b::unital_quantale)"
  by standard (simp_all add: one_prod_def times_prod'_def ac_simps image_comp)

subsection \<open>Quantale Morphisms\<close>

text \<open>There are various ways of defining quantale morphisms, depending on the application. Following Rosenthal,
I present the most important one.\<close>

abbreviation comp_pres :: "('a::times \<Rightarrow> 'b::times) \<Rightarrow> bool" where
  "comp_pres f \<equiv> (\<forall>x y. f (x \<cdot> y) = f x \<cdot> f y)"

abbreviation un_pres :: "('a::one \<Rightarrow> 'b::one) \<Rightarrow> bool" where
  "un_pres f \<equiv> (f 1 = 1)"

definition "comp_closed_set X = (\<forall>x \<in> X. \<forall>y \<in> X. x \<cdot> y \<in> X)"

definition "un_closed_set X = (1 \<in> X)"

definition quantale_homset :: "('a::quantale \<Rightarrow> 'b::quantale) set" where
  "quantale_homset = {f. comp_pres f \<and> Sup_pres f}"

lemma quantale_homset_iff: "f \<in> quantale_homset = (comp_pres f \<and> Sup_pres f)"
  unfolding quantale_homset_def by clarsimp

definition unital_quantale_homset :: "('a::unital_quantale \<Rightarrow> 'b::unital_quantale) set" where
  "unital_quantale_homset = {f. comp_pres f \<and> Sup_pres f \<and> un_pres f}"

lemma unital_quantale_homset_iff: "f \<in> unital_quantale_homset = (comp_pres f \<and> Sup_pres f \<and> un_pres f)"
  unfolding unital_quantale_homset_def by clarsimp

text \<open>Though Infs can be defined from Sups in any quantale, quantale morphisms do not generally preserve Infs.
A different kind of morphism is needed if this is to be guaranteed.\<close>

lemma "f \<in> quantale_homset \<Longrightarrow> Inf_pres f" (*nitpick*)
  oops

text \<open>The images of quantale morphisms are closed under compositions and Sups, hence they form quantales.\<close>

lemma quantale_hom_q_pres: "f \<in> quantale_homset \<Longrightarrow> Sup_closed_set (range f) \<and> comp_closed_set (range f)"
  apply safe
   apply (simp add: Sup_pres_Sup_closed quantale_homset_iff)
  unfolding quantale_homset_iff comp_closed_set_def by (metis (no_types, lifting) imageE range_eqI)

text \<open>Yet the image need not be Inf-closed.\<close>

lemma "f \<in> quantale_homset \<Longrightarrow> Inf_closed_set (range f)" (*nitpick*)
  oops

text \<open>Of course Sups are preserved by quantale-morphisms, hence they are the same in subsets as in the original set.
Infs in the subset, however, exist, since they subset forms a quantale in which Infs can be defined, but these are generally
different from the Infs in the superstructure.

This fact is hidden in Isabelle's definition of complete lattices, where Infs are axiomatised. There is no easy way in general to
show that images of quantale morphisms form quantales, though the statement for Sup-quantales is straightforward. I show this for quantic nuclei
and left-sided elements.\<close>

typedef (overloaded) ('a,'b) quantale_homset = "quantale_homset::('a::quantale \<Rightarrow> 'b::quantale) set"
proof-
  have a: "comp_pres (\<lambda>x::'a::quantale. bot::'b)"
    by simp
  have b: "Sup_pres (\<lambda>x::'a::quantale. bot::'b)"
    unfolding fun_eq_iff comp_def by simp
  hence "(\<lambda>x::'a::quantale. bot::'b) \<in> quantale_homset"
    by (simp add: quantale_homset_iff)
  thus ?thesis
    by auto
qed

setup_lifting type_definition_quantale_homset

text \<open>Interestingly, the following type is not (gobally) inhabited.\<close>

typedef (overloaded) ('a,'b) unital_quantale_homset = "unital_quantale_homset::('a::unital_quantale \<Rightarrow> 'b::unital_quantale) set" (*nitpick*)
  oops

lemma quantale_hom_radj:
  fixes f :: "'a::quantale_with_dual \<Rightarrow> 'b::quantale_with_dual"
  shows "f \<in> quantale_homset \<Longrightarrow> f \<stileturn> radj f"
  unfolding quantale_homset_iff by (simp add: Sup_pres_ladj_aux)

lemma quantale_hom_prop1:
  fixes f :: "'a::quantale_with_dual \<Rightarrow> 'b::quantale_with_dual"
  shows "f \<in> quantale_homset \<Longrightarrow> radj f (f x \<rightarrow> y) = x \<rightarrow> radj f y"
proof-
  assume h: "f \<in> quantale_homset"
  have "f x \<cdot> f (radj f (f x \<rightarrow> y)) \<le> y"
    by (meson h adj_def bres_galois order_refl quantale_hom_radj)
  hence "f (x \<cdot> radj f (f x \<rightarrow> y)) \<le> y"
    by (metis h quantale_homset_iff)
  hence "x \<cdot> radj f (f x \<rightarrow> y) \<le> radj f y"
    using adj_def h quantale_hom_radj by blast
  hence le: "radj f (f x \<rightarrow> y) \<le> x \<rightarrow> radj f y"
    by (simp add: bres_galois)
  have "x \<cdot> (x \<rightarrow> radj f y) \<le> radj f y"
    by (simp add: bres_canc1)
  hence  "f (x \<cdot> (x \<rightarrow> radj f y)) \<le> y"
    using adj_def h quantale_hom_radj by blast
  hence "f x \<cdot> f (x \<rightarrow> radj f y) \<le> y"
    by (metis h quantale_homset_iff)
  hence "f (x \<rightarrow> radj f y) \<le> f x \<rightarrow> y"
    by (simp add: bres_galois)
  hence "x \<rightarrow> radj f y \<le> radj f (f x \<rightarrow> y)"
    using adj_def h quantale_hom_radj by blast
  thus ?thesis
    by (simp add: dual_order.antisym le)
qed

lemma quantale_hom_prop2:
  fixes f :: "'a::quantale_with_dual \<Rightarrow> 'b::quantale_with_dual"
  shows "f \<in> quantale_homset \<Longrightarrow> radj f (y \<leftarrow> f x) = radj f y \<leftarrow> x"
proof-
  assume h: "f \<in> quantale_homset"
  have "f (radj f (y \<leftarrow> f x)) \<cdot> f x \<le> y"
    by (meson adj_def fres_galois h order_refl quantale_hom_radj)
  hence "f (radj f (y \<leftarrow> f x) \<cdot> x) \<le> y"
    by (metis h quantale_homset_iff)
  hence "radj f (y \<leftarrow> f x) \<cdot> x\<le> radj f y"
    using adj_def h quantale_hom_radj by blast
  hence le: "radj f (y \<leftarrow> f x) \<le> radj f y \<leftarrow> x"
    by (simp add: fres_galois)
  have "(radj f y \<leftarrow> x) \<cdot> x \<le> radj f y"
    by (simp add: fres_canc1)
  hence  "f ((radj f y \<leftarrow> x) \<cdot> x) \<le> y"
    using adj_def h quantale_hom_radj by blast
  hence "f (radj f y \<leftarrow> x) \<cdot> f x\<le> y"
    by (metis h quantale_homset_iff)
  hence "f (radj f y \<leftarrow> x) \<le> y \<leftarrow> f x"
    by (simp add: fres_galois)
  hence "radj f y \<leftarrow> x\<le> radj f (y \<leftarrow> f x)"
    using adj_def h quantale_hom_radj by blast
  thus ?thesis
    by (simp add: dual_order.antisym le)
qed

definition quantale_closed_maps :: "('a::quantale \<Rightarrow> 'b::quantale) set" where
  "quantale_closed_maps = {f. (\<forall>x y. f x \<cdot> f y \<le> f (x \<cdot> y))}"

lemma quantale_closed_maps_iff: "f \<in> quantale_closed_maps = (\<forall> x y. f x \<cdot> f y \<le> f (x \<cdot> y))"
  unfolding quantale_closed_maps_def by clarsimp

definition quantale_closed_Sup_maps :: "('a::quantale \<Rightarrow> 'b::quantale) set" where
  "quantale_closed_Sup_maps = {f. (\<forall> x y. f x \<cdot> f y \<le> f (x \<cdot> y)) \<and> Sup_pres f}"

lemma quantale_closed_Sup_maps_iff: "f \<in> quantale_closed_Sup_maps = (\<forall> x y. f x \<cdot> f y \<le> f (x \<cdot> y) \<and> Sup_pres f)"
  unfolding quantale_closed_Sup_maps_def by clarsimp

definition quantale_closed_unital_maps :: "('a::unital_quantale \<Rightarrow> 'b::unital_quantale) set" where
  "quantale_closed_unital_maps = {f. (\<forall> x y. f x \<cdot> f y \<le> f (x \<cdot> y)) \<and> 1 \<le> f 1}"

lemma quantale_closed_unital_maps_iff: "f \<in> quantale_closed_unital_maps = (\<forall> x y. f x \<cdot> f y \<le> f (x \<cdot> y) \<and> 1 \<le> f 1)"
  unfolding quantale_closed_unital_maps_def by clarsimp

definition quantale_closed_unital_Sup_maps :: "('a::unital_quantale \<Rightarrow> 'b::unital_quantale) set" where
  "quantale_closed_unital_Sup_maps = {f. (\<forall> x y. f x \<cdot> f y \<le> f (x \<cdot> y)) \<and> Sup_pres f \<and> 1 \<le> f 1}"

lemma quantale_closed_unital_Sup_maps_iff: "f \<in> quantale_closed_unital_Sup_maps = (\<forall> x y. f x \<cdot> f y \<le> f (x \<cdot> y) \<and> Sup_pres f \<and> 1 \<le> f 1)"
  unfolding quantale_closed_unital_Sup_maps_def by clarsimp

text \<open>Closed maps are the right adjoints of quantale morphisms.\<close>

lemma quantale_hom_closed_map:
  fixes f :: "'a::quantale_with_dual \<Rightarrow> 'b::quantale_with_dual"
  shows "(f \<in> quantale_homset) \<Longrightarrow> (radj f \<in> quantale_closed_maps)"
proof-
  assume h: "f \<in> quantale_homset"
  have "\<forall>x y. f (radj f x) \<cdot> f (radj f y) \<le> x \<cdot> y"
    by (metis adj_def h order_refl psrpq.mult_isol_var quantale_hom_radj)
  hence "\<forall>x y. f (radj f x \<cdot> radj f y) \<le> x \<cdot> y"
    by (metis h quantale_homset_iff)
  hence "\<forall>x y. radj f x \<cdot> radj f y \<le> radj f (x \<cdot> y)"
    using adj_def h quantale_hom_radj by blast
  thus ?thesis
    by (simp add: quantale_closed_maps_iff)
qed

lemma unital_quantale_hom_closed_unital_map:
  fixes f :: "'a::unital_quantale_with_dual \<Rightarrow> 'b::unital_quantale_with_dual"
  shows "(f \<in> unital_quantale_homset) \<Longrightarrow> (radj f \<in> quantale_closed_unital_maps)"
  by (metis (no_types, hide_lams) adj_def order_refl quantale_closed_maps_iff quantale_closed_unital_maps_iff quantale_hom_closed_map quantale_hom_radj quantale_homset_iff unital_quantale_homset_iff)

 end


(*  Title:      HOL/Library/List_lexord.thy
    Author:     Norbert Voelker
*)

section {* Lexicographic order on lists *}

theory List_lexord
imports Main
begin

instantiation list :: (ord) ord
begin

definition
  list_less_def: "xs < ys \<longleftrightarrow> (xs, ys) \<in> lexord {(u, v). u < v}"

definition
  list_le_def: "(xs :: _ list) \<le> ys \<longleftrightarrow> xs < ys \<or> xs = ys"

instance ..

end

instance list :: (order) order
proof
  fix xs :: "'a list"
  show "xs \<le> xs" by (simp add: list_le_def)
next
  fix xs ys zs :: "'a list"
  assume "xs \<le> ys" and "ys \<le> zs"
  then show "xs \<le> zs"
    apply (auto simp add: list_le_def list_less_def)
    apply (rule lexord_trans)
    apply (auto intro: transI)
    done
next
  fix xs ys :: "'a list"
  assume "xs \<le> ys" and "ys \<le> xs"
  then show "xs = ys"
    apply (auto simp add: list_le_def list_less_def)
    apply (rule lexord_irreflexive [THEN notE])
    defer
    apply (rule lexord_trans)
    apply (auto intro: transI)
    done
next
  fix xs ys :: "'a list"
  show "xs < ys \<longleftrightarrow> xs \<le> ys \<and> \<not> ys \<le> xs"
    apply (auto simp add: list_less_def list_le_def)
    defer
    apply (rule lexord_irreflexive [THEN notE])
    apply auto
    apply (rule lexord_irreflexive [THEN notE])
    defer
    apply (rule lexord_trans)
    apply (auto intro: transI)
    done
qed

instance list :: (linorder) linorder
proof
  fix xs ys :: "'a list"
  have "(xs, ys) \<in> lexord {(u, v). u < v} \<or> xs = ys \<or> (ys, xs) \<in> lexord {(u, v). u < v}"
    by (rule lexord_linear) auto
  then show "xs \<le> ys \<or> ys \<le> xs"
    by (auto simp add: list_le_def list_less_def)
qed

instantiation list :: (linorder) distrib_lattice
begin

definition "(inf \<Colon> 'a list \<Rightarrow> _) = min"

definition "(sup \<Colon> 'a list \<Rightarrow> _) = max"

instance
  by default (auto simp add: inf_list_def sup_list_def max_min_distrib2)

end

lemma not_less_Nil [simp]: "\<not> x < []"
  by (simp add: list_less_def)

lemma Nil_less_Cons [simp]: "[] < a # x"
  by (simp add: list_less_def)

lemma Cons_less_Cons [simp]: "a # x < b # y \<longleftrightarrow> a < b \<or> a = b \<and> x < y"
  by (simp add: list_less_def)

lemma le_Nil [simp]: "x \<le> [] \<longleftrightarrow> x = []"
  unfolding list_le_def by (cases x) auto

lemma Nil_le_Cons [simp]: "[] \<le> x"
  unfolding list_le_def by (cases x) auto

lemma Cons_le_Cons [simp]: "a # x \<le> b # y \<longleftrightarrow> a < b \<or> a = b \<and> x \<le> y"
  unfolding list_le_def by auto

instantiation list :: (order) order_bot
begin

definition "bot = []"

instance
  by default (simp add: bot_list_def)

end

lemma less_list_code [code]:
  "xs < ([]\<Colon>'a\<Colon>{equal, order} list) \<longleftrightarrow> False"
  "[] < (x\<Colon>'a\<Colon>{equal, order}) # xs \<longleftrightarrow> True"
  "(x\<Colon>'a\<Colon>{equal, order}) # xs < y # ys \<longleftrightarrow> x < y \<or> x = y \<and> xs < ys"
  by simp_all

end


section \<open> Kleene Algebra and UTP \<close>

theory utp_kleene
  imports
    "KAT_and_DRA.KAT"
    "UTP1.utp"
begin

text \<open> This theory instantiates the Kleene Algebra~\cite{Kozen90} (KA) hierarchy, mechanised in
  Isabelle/HOL by Armstrong, Gomes, Struth et al~\cite{Armstrong2015,Gomes2016,Foster11a}., for
  Isabelle/UTP alphabetised relations~\cite{Foster16a,Hoare&98}. Specifically, we substantiate the
  required dioid and KA laws in the type class hierarchy, which allows us to make use of all theorems
  proved in the former work. Moreover, we also prove an important result that a subclass of UTP
  theories, which we call ``Kleene UTP theories'', always form Kleene algebras. The proof of the
  latter is obtained by lifting laws from the KA hierarchy. \<close>

subsection \<open> Syntax setup \<close>

text \<open> It is necessary to replace parts of the KA syntax to ensure compatibility with UTP. We
  therefore delete various bits of notation, and hide some constants. \<close>

purge_notation star ("_\<^sup>\<star>" [101] 100)

recall_syntax

purge_notation n_op ("n _" [90] 91)
purge_notation ts_ord (infix "\<sqsubseteq>" 50)

notation n_op ("\<^bold>n[_]")
notation t ("\<^bold>n\<^sup>2[_]")
notation ts_ord (infix "\<sqsubseteq>\<^sub>t" 50)

hide_const t

subsection \<open> Kleene Algebra Instantiations \<close>

text \<open> Next, import the laws of Kleene Algebra into the UTP relational calculus. We show
  that relations form a dioid and a Kleene algebra via two locales, the interpretation of which
  exports a large library of algebraic laws. \<close>

interpretation urel_dioid: dioid
  where plus = "(\<sqinter>)" and times = "(;;\<^sub>h)" and less_eq = less_eq and less = less
proof
  fix P Q R :: "'\<alpha> hrel"
  show "(P \<sqinter> Q) ;; R = (P ;; R) \<sqinter> (Q ;; R)"
    by (simp add: upred_semiring.distrib_right)
  show "(Q \<sqsubseteq> P) = (P \<sqinter> Q = Q)"
    by (simp add: semilattice_sup_class.le_iff_sup)
  show "(P < Q) = (Q \<sqsubseteq> P \<and> \<not> P = Q)"
    by (simp add: less_le)
  show "P \<sqinter> P = P"
    by simp
qed

interpretation urel_ka: kleene_algebra
  where plus = "(\<sqinter>)" and times = "(;;\<^sub>h)" and one = skip_r and zero = false\<^sub>h and less_eq = less_eq and less = less and star = ustar
proof
  fix P Q R :: "'\<alpha> hrel"
  show "II ;; P = P" by simp
  show "P ;; II = P" by simp
  show "false \<sqinter> P = P" by simp
  show "false ;; P = false" by simp
  show "P ;; false = false" by simp
  show "P\<^sup>\<star> \<sqsubseteq> II \<sqinter> (P ;; P\<^sup>\<star>)"
    using ustar_sub_unfoldl by blast
  show "Q \<sqsubseteq> R \<sqinter> (P ;; Q) \<Longrightarrow> Q \<sqsubseteq> P\<^sup>\<star> ;; R"
    by (simp add: ustar_inductl)
  show "Q \<sqsubseteq> R \<sqinter> (Q ;; P) \<Longrightarrow> Q \<sqsubseteq> R ;; P\<^sup>\<star>"
    by (simp add: ustar_inductr)
qed

text \<open> We also show that UTP relations form a Kleene Algebra with Tests~\cite{kozen1997kleene,Gomes2016} (KAT). \<close>

interpretation urel_kat: kat
  where plus = "(\<sqinter>)" and times = "(;;\<^sub>h)" and one = skip_r and zero = false\<^sub>h and less_eq = less_eq and less = less and star = ustar and n_op = "\<lambda>x. II \<and> (\<not> x)"
  by (unfold_locales, rel_auto+)

text \<open> We can now access the laws of KA and KAT for UTP relations as below. \<close>

thm urel_ka.star_inductr_var
thm urel_ka.star_trans
thm urel_ka.star_square
thm urel_ka.independence1

subsection \<open> Derived Laws \<close>

text \<open> We prove that UTP assumptions are tests. \<close>

lemma test_rassume [simp]: "urel_kat.test [b]\<^sup>\<top>"
  by (simp add: urel_kat.test_def, rel_auto)

text \<open> The KAT laws can be used to prove results like the one below. \<close>

lemma while_kat_form:
  "while b do P od = ([b]\<^sup>\<top> ;; P)\<^sup>\<star> ;; [(\<not> b)]\<^sup>\<top>" (is "?lhs = ?rhs")
proof -
  have 1:"(II::'a hrel) \<sqinter> ((II::'a hrel) ;; [(\<not> b)]\<^sup>\<top>) = II"
    by (metis assume_true test_rassume urel_kat.test_absorb1)
  have "?lhs = (([b]\<^sup>\<top> ;; P) \<sqinter> ([(\<not> b)]\<^sup>\<top> ;; II))\<^sup>\<star> ;; [(\<not> b)]\<^sup>\<top>"
    by (simp add: while_star_form rcond_rassume_expand)
  also have "... = (([b]\<^sup>\<top> ;; P)\<^sup>\<star> ;; [(\<not> b)]\<^sup>\<top>\<^sup>\<star>)\<^sup>\<star> ;; [(\<not> b)]\<^sup>\<top>"
    by (metis seqr_right_unit urel_ka.star_denest)
  also have "... = (([b]\<^sup>\<top> ;; P)\<^sup>\<star> ;; (II \<sqinter> [(\<not> b)]\<^sup>\<top>)\<^sup>\<star>)\<^sup>\<star> ;; [(\<not> b)]\<^sup>\<top>"
    by (metis urel_ka.star2)
  also have "... = (([b]\<^sup>\<top> ;; P)\<^sup>\<star> ;; (II)\<^sup>\<star>)\<^sup>\<star> ;; [(\<not> b)]\<^sup>\<top>"
    by (metis 1 seqr_left_unit)
  also have "... = (([b]\<^sup>\<top> ;; P)\<^sup>\<star>)\<^sup>\<star> ;; [(\<not> b)]\<^sup>\<top>"
    by (metis urel_ka.mult_oner urel_ka.star_one)
  also have "... = ?rhs"
    by (metis urel_ka.star_invol)
  finally show ?thesis .
qed

lemma uplus_invol [simp]: "(P\<^sup>+)\<^sup>+ = P\<^sup>+"
  by (metis RA1 uplus_def urel_ka.conway.dagger_trans_eq urel_ka.star_denest_var_2 urel_ka.star_invol)

lemma uplus_alt_def: "P\<^sup>+ = P\<^sup>\<star> ;; P"
  by (simp add: uplus_def urel_ka.star_slide_var)

subsection \<open> UTP Theories with Kleene Algebra \<close>

text \<open> A Kleene UTP theory is continuous UTP theory with left and right units, and the top element as
  a left zero. The star in such a context has already been defined by lifting the relational Kleene star. Here,
  we use the KA theorems obtained above to provide corresponding theorems for a Kleene UTP theory. \<close>

locale utp_theory_kleene = utp_theory_cont_unital_zerol
begin

lemma Star_def: "P\<^bold>\<star> = P\<^sup>\<star> ;; \<I>\<I>"
  by (simp add: utp_star_def)

lemma Star_alt_def:
  assumes "P is \<H>"
  shows "P\<^bold>\<star> = \<I>\<I> \<sqinter> P\<^sup>+"
proof -
  from assms have "P\<^sup>+ = P\<^sup>\<star> ;; P ;; \<I>\<I>"
    by (simp add: Unit_Right uplus_alt_def)
  then show ?thesis
    by (simp add: RA1 utp_star_def)
qed

lemma Star_Healthy [closure]:
  assumes "P is \<H>"
  shows "P\<^bold>\<star> is \<H>"
  by (simp add: assms closure Star_alt_def)

lemma Star_unfoldl:
  "P\<^bold>\<star> \<sqsubseteq> \<I>\<I> \<sqinter> (P ;; P\<^bold>\<star>)"
  by (simp add: RA1 utp_star_def)

lemma Star_inductl:
  assumes "R is \<H>" "Q \<sqsubseteq> (P ;; Q) \<sqinter> R"
  shows "Q \<sqsubseteq> P\<^bold>\<star>;;R"
proof -
  from assms(2) have "Q \<sqsubseteq> R" "Q \<sqsubseteq> P ;; Q"
    by auto
  thus ?thesis
    by (simp add: Unit_Left assms(1) upred_semiring.mult_assoc urel_ka.star_inductl utp_star_def)
qed

lemma Star_invol:
  assumes "P is \<H>"
  shows "P\<^bold>\<star>\<^bold>\<star> = P\<^bold>\<star>"
  by (metis (no_types) RA1 Unit_Left Unit_self assms urel_ka.star_invol urel_ka.star_sim3 utp_star_def)

lemma Star_test:
  assumes "P is \<H>" "utp_test P"
  shows "P\<^bold>\<star> = \<I>\<I>"
  by (metis utp_star_def Star_alt_def Unit_Right Unit_self assms semilattice_sup_class.sup.absorb1 semilattice_sup_class.sup_left_idem urel_ka.star_inductr_var_eq2 urel_ka.star_sim1 utp_test_def)

lemma Star_lemma_1:
  "P is \<H> \<Longrightarrow> \<I>\<I> ;; P\<^sup>\<star> ;; \<I>\<I> = P\<^sup>\<star> ;; \<I>\<I>"
  by (metis utp_star_def Star_Healthy Unit_Left)

lemma Star_lemma_2:
  assumes "P is \<H>" "Q is \<H>"
  shows "(P\<^sup>\<star> ;; Q\<^sup>\<star> ;; \<I>\<I>)\<^sup>\<star> ;; \<I>\<I> = (P\<^sup>\<star> ;; Q\<^sup>\<star>)\<^sup>\<star> ;; \<I>\<I>"
  by (metis (no_types) assms RA1 Star_lemma_1 Unit_self urel_ka.star_sim3)

lemma Star_denest:
  assumes "P is \<H>" "Q is \<H>"
  shows "(P \<sqinter> Q)\<^bold>\<star> = (P\<^bold>\<star> ;; Q\<^bold>\<star>)\<^bold>\<star>"
  by (metis (no_types, lifting) RA1 utp_star_def Star_lemma_1 Star_lemma_2 assms urel_ka.star_denest)

lemma Star_denest_disj:
  assumes "P is \<H>" "Q is \<H>"
  shows "(P \<or> Q)\<^bold>\<star> = (P\<^bold>\<star> ;; Q\<^bold>\<star>)\<^bold>\<star>"
  by (simp add: disj_upred_def Star_denest assms)

lemma Star_unfoldl_eq:
  assumes "P is \<H>"
  shows "\<I>\<I> \<sqinter> (P ;; P\<^bold>\<star>) = P\<^bold>\<star>"
  by (simp add: RA1 utp_star_def)

lemma uplus_Star_def:
  assumes "P is \<H>"
  shows "P\<^sup>+ = (P ;; P\<^bold>\<star>)"
  by (metis (full_types) RA1 utp_star_def Unit_Left Unit_Right assms uplus_def urel_ka.conway.dagger_slide)

lemma Star_trade_skip:
  "P is \<H> \<Longrightarrow> \<I>\<I> ;; P\<^sup>\<star> = P\<^sup>\<star> ;; \<I>\<I>"
  by (simp add: Unit_Left Unit_Right urel_ka.star_sim3)

lemma Star_slide:
  assumes "P is \<H>"
  shows "(P ;; P\<^bold>\<star>) = (P\<^bold>\<star> ;; P)" (is "?lhs = ?rhs")
proof -
  have "?lhs = P ;; P\<^sup>\<star> ;; \<I>\<I>"
    by (simp add: utp_star_def)
  also have "... = P ;; \<I>\<I> ;; P\<^sup>\<star>"
    by (simp add: Star_trade_skip assms)
  also have "... = P ;; P\<^sup>\<star>"
    by (simp add: RA1 Unit_Right assms)
  also have "... = P\<^sup>\<star> ;; P"
    by (simp add: urel_ka.star_slide_var)
  also have "... = ?rhs"
    by (metis RA1 utp_star_def Unit_Left assms)
  finally show ?thesis .
qed

lemma Star_unfoldr_eq:
  assumes "P is \<H>"
  shows "\<I>\<I> \<sqinter> (P\<^bold>\<star> ;; P) = P\<^bold>\<star>"
  using Star_slide Star_unfoldl_eq assms by auto

lemma Star_inductr:
  assumes "P is \<H>" "R is \<H>" "Q \<sqsubseteq> P \<sqinter> (Q ;; R)"
  shows "Q \<sqsubseteq> P;;R\<^bold>\<star>"
  by (metis (full_types) RA1 Star_def Star_trade_skip Unit_Right assms urel_ka.star_inductr')

lemma Star_Top: "\<^bold>\<top>\<^bold>\<star> = \<I>\<I>"
  by (simp add: Star_test top_healthy utest_Top)

end

end


(*
    $Id: ex.thy,v 1.4 2010/11/29 07:13:36 kleing Exp $
    Author: Martin Strecker
*)

header {* The Euclidean Algorithm -- Inductively *}

(*<*) theory ex imports Main begin (*>*)

subsection {* Rules without base case *}

text {* Show that the following *}

inductive_set evenempty :: "nat set" where
Add2Ie: "n \<in> evenempty \<Longrightarrow> Suc(Suc n) \<in> evenempty"

text {* defines the empty set: *}

lemma evenempty_empty: "evenempty = {}"
(*<*) oops (*>*)

subsection {* The Euclidean algorithm *}

text {* Define inductively the set @{text gcd}, which characterizes
the greatest common divisor of two natural numbers: *}

(*<*)consts(*>*)
  gcd :: "(nat \<times> nat \<times> nat) set"

text {* Here, @{text "(a,b,g) \<in> gcd"} means that @{text g} is the gcd
of @{text a} und @{text b}. The definition should closely follow the
Euclidean algorithm.

Reminder: The Euclidean algorithm repeatedly subtracts the smaller
from the larger number, until one of the numbers is 0. Then, the other
number is the gcd. *}

text {* Now, compute the gcd of 15 and 10: *}

schematic_lemma "(15, 10, ?g)  \<in> gcd"
(*<*) oops (*>*)

text {* How does your algorithm behave on special cases as the following? *}

schematic_lemma "(0, 0, ?g)  \<in> gcd"
(*<*) oops (*>*)

text {* Show that the gcd is really a divisor (for the proof, you need an
appropriate lemma): *}

lemma gcd_divides: "(a,b,g) \<in> gcd \<Longrightarrow> g dvd a \<and> g dvd b"
(*<*) oops (*>*)

text {* Show that the gcd is the greatest common divisor: *}

lemma gcd_greatest [rule_format]: "(a,b,g) \<in> gcd \<Longrightarrow>
  0 < a \<or> 0 < b \<longrightarrow> (\<forall> d. d dvd a \<longrightarrow> d dvd b \<longrightarrow> d \<le> g)"
(*<*) oops (*>*)

text {* Here as well, you will have to prove a suitable lemma. What is the
precondition @{text "0 < a \<or> 0 < b"} good for?

So far, we have only shown that @{text gcd} is correct, but your algorithm
might not compute a result for all values @{text "a,b"}.  Thus, show
completeness of the algorithm: *}

lemma gcd_defined: "\<forall> a b. \<exists> g. (a, b, g) \<in> gcd"
(*<*) oops (*>*)

text {* The following lemma, proved by course-of-value recursion over @{text
n}, may be useful.  Why does standard induction over natural numbers not work
here? *}

lemma gcd_defined_aux [rule_format]:
  "\<forall> a b. (a + b) \<le> n \<longrightarrow> (\<exists> g. (a, b, g) \<in> gcd)"
  apply (induct rule: nat_less_induct)
  apply clarify
(*<*) oops (*>*)

text {* The idea is to show that @{text gcd} yields a result for all @{text "a,
b"} whenever it is known that @{text gcd} yields a result for all @{text "a',
b'"} whose sum is smaller than @{text "a + b"}.

In order to prove this lemma, make case distinctions corresponding to the
different clauses of the algorithm, and show how to reduce computation of
@{text gcd} for @{text "a, b"} to computation of @{text gcd} for suitable
smaller @{text "a', b'"}. *}

(*<*) end (*>*)


theory Kyber_NTT_Values

imports Kyber_Values
        NTT_Scheme
        Powers3844

begin
section \<open>Specification of Kyber with NTT\<close>
text \<open>Calculations for NTT specifications\<close>

lemma "3844 * 6584 = (1 :: fin7681 mod_ring)"
by simp

lemma "62 * 1115 = (1 :: fin7681 mod_ring)"
by simp

lemma "256 * 7651 = (1:: fin7681 mod_ring)"
by simp

lemma "7681 = 30 * 256 + (1::int)" by simp

lemma powr256:  "3844 ^ 256 = (1::fin7681 mod_ring)"
proof -
  have calc1: "3844^16 = (7154::fin7681 mod_ring)" by simp
  have calc2: "7154^16 = (1::fin7681 mod_ring)" by simp
  have "(3844::fin7681 mod_ring)^256 = (3844^16)^16"
    by (metis (mono_tags, opaque_lifting) num_double numeral_times_numeral power_mult)
  also have "\<dots> = 1" unfolding calc1 calc2 by auto
  finally show ?thesis by blast
qed

lemma powr256':
"62 ^ 256 = (- 1::fin7681 mod_ring)"
proof -
  have calc1: "62^16 = (1366::fin7681 mod_ring)" by simp
  have calc2: "1366^16 = (-1::fin7681 mod_ring)" by simp
  have "(62::fin7681 mod_ring)^256 = (62^16)^16"
    by (metis (mono_tags, opaque_lifting) num_double numeral_times_numeral power_mult)
  also have "\<dots> = -1" unfolding calc1 calc2 by auto
  finally show ?thesis by blast
qed

(*
powrs 3844^l for l=1..<256 in Powrs_3844 file"
*)

interpretation kyber7681_ntt: kyber_ntt 256 7681 3 8
    "TYPE(fin7681)" "TYPE(3)" 3844 6584 62 1115 7651 30
proof (unfold_locales, goal_cases)
  case 5
  then show ?case using kyber7681.q_prime by fastforce
next
  case 7
  then show ?case using kyber7681.CARD_k by blast
next
  case 8
  then show ?case by (simp add: qr_poly'_fin7681_def)
next
  case 9
  then show ?case using powr256 by blast
next
  case 11
  then show ?case proof (safe, goal_cases)
    case (1 m)
    then show ?case using powr_less256[OF 1(2)]
    using linorder_not_less by blast
  qed
next
  case 15
  then show ?case using powr256' by blast
next
  case 17
  have mult: "256 * 7651 = (1::fin7681 mod_ring)" by simp
  have of_int: "of_int_mod_ring (int 256) = 256"
    by (metis o_def of_nat_numeral of_nat_of_int_mod_ring)
  show ?case unfolding of_int mult by simp
qed (auto)

end


(*  Title:      HOL/Order_Relation.thy
    Author:     Tobias Nipkow
    Author:     Andrei Popescu, TU Muenchen
*)

section \<open>Orders as Relations\<close>

theory Order_Relation
imports Wfrec
begin

subsection \<open>Orders on a set\<close>

definition "preorder_on A r \<equiv> refl_on A r \<and> trans r"

definition "partial_order_on A r \<equiv> preorder_on A r \<and> antisym r"

definition "linear_order_on A r \<equiv> partial_order_on A r \<and> total_on A r"

definition "strict_linear_order_on A r \<equiv> trans r \<and> irrefl r \<and> total_on A r"

definition "well_order_on A r \<equiv> linear_order_on A r \<and> wf(r - Id)"

lemmas order_on_defs =
  preorder_on_def partial_order_on_def linear_order_on_def
  strict_linear_order_on_def well_order_on_def

lemma preorder_on_empty[simp]: "preorder_on {} {}"
  by (simp add: preorder_on_def trans_def)

lemma partial_order_on_empty[simp]: "partial_order_on {} {}"
  by (simp add: partial_order_on_def)

lemma lnear_order_on_empty[simp]: "linear_order_on {} {}"
  by (simp add: linear_order_on_def)

lemma well_order_on_empty[simp]: "well_order_on {} {}"
  by (simp add: well_order_on_def)

lemma preorder_on_converse[simp]: "preorder_on A (r\<inverse>) = preorder_on A r"
  by (simp add: preorder_on_def)

lemma partial_order_on_converse[simp]: "partial_order_on A (r\<inverse>) = partial_order_on A r"
  by (simp add: partial_order_on_def)

lemma linear_order_on_converse[simp]: "linear_order_on A (r\<inverse>) = linear_order_on A r"
  by (simp add: linear_order_on_def)

lemma strict_linear_order_on_diff_Id: "linear_order_on A r \<Longrightarrow> strict_linear_order_on A (r - Id)"
  by (simp add: order_on_defs trans_diff_Id)

lemma linear_order_on_singleton [simp]: "linear_order_on {x} {(x, x)}"
  by (simp add: order_on_defs)

lemma linear_order_on_acyclic:
  assumes "linear_order_on A r"
  shows "acyclic (r - Id)"
  using strict_linear_order_on_diff_Id[OF assms]
  by (auto simp add: acyclic_irrefl strict_linear_order_on_def)

lemma linear_order_on_well_order_on:
  assumes "finite r"
  shows "linear_order_on A r \<longleftrightarrow> well_order_on A r"
  unfolding well_order_on_def
  using assms finite_acyclic_wf[OF _ linear_order_on_acyclic, of r] by blast

subsection \<open>Orders on the field\<close>

abbreviation "Refl r \<equiv> refl_on (Field r) r"

abbreviation "Preorder r \<equiv> preorder_on (Field r) r"

abbreviation "Partial_order r \<equiv> partial_order_on (Field r) r"

abbreviation "Total r \<equiv> total_on (Field r) r"

abbreviation "Linear_order r \<equiv> linear_order_on (Field r) r"

abbreviation "Well_order r \<equiv> well_order_on (Field r) r"

lemma subset_Image_Image_iff:
  "Preorder r \<Longrightarrow> A \<subseteq> Field r \<Longrightarrow> B \<subseteq> Field r \<Longrightarrow>
    r `` A \<subseteq> r `` B \<longleftrightarrow> (\<forall>a\<in>A.\<exists>b\<in>B. (b, a) \<in> r)"
  apply (simp add: preorder_on_def refl_on_def Image_def subset_eq)
  apply (simp only: trans_def)
  apply fast
  done

lemma subset_Image1_Image1_iff:
  "Preorder r \<Longrightarrow> a \<in> Field r \<Longrightarrow> b \<in> Field r \<Longrightarrow> r `` {a} \<subseteq> r `` {b} \<longleftrightarrow> (b, a) \<in> r"
  by (simp add: subset_Image_Image_iff)

lemma Refl_antisym_eq_Image1_Image1_iff:
  assumes "Refl r"
    and as: "antisym r"
    and abf: "a \<in> Field r" "b \<in> Field r"
  shows "r `` {a} = r `` {b} \<longleftrightarrow> a = b"
    (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?lhs
  then have *: "\<And>x. (a, x) \<in> r \<longleftrightarrow> (b, x) \<in> r"
    by (simp add: set_eq_iff)
  have "(a, a) \<in> r" "(b, b) \<in> r" using \<open>Refl r\<close> abf by (simp_all add: refl_on_def)
  then have "(a, b) \<in> r" "(b, a) \<in> r" using *[of a] *[of b] by simp_all
  then show ?rhs
    using \<open>antisym r\<close>[unfolded antisym_def] by blast
next
  assume ?rhs
  then show ?lhs by fast
qed

lemma Partial_order_eq_Image1_Image1_iff:
  "Partial_order r \<Longrightarrow> a \<in> Field r \<Longrightarrow> b \<in> Field r \<Longrightarrow> r `` {a} = r `` {b} \<longleftrightarrow> a = b"
  by (auto simp: order_on_defs Refl_antisym_eq_Image1_Image1_iff)

lemma Total_Id_Field:
  assumes "Total r"
    and not_Id: "\<not> r \<subseteq> Id"
  shows "Field r = Field (r - Id)"
  using mono_Field[of "r - Id" r] Diff_subset[of r Id]
proof auto
  fix a assume *: "a \<in> Field r"
  from not_Id have "r \<noteq> {}" by fast
  with not_Id obtain b and c where "b \<noteq> c \<and> (b,c) \<in> r" by auto
  then have "b \<noteq> c \<and> {b, c} \<subseteq> Field r" by (auto simp: Field_def)
  with * obtain d where "d \<in> Field r" "d \<noteq> a" by auto
  with * \<open>Total r\<close> have "(a, d) \<in> r \<or> (d, a) \<in> r" by (simp add: total_on_def)
  with \<open>d \<noteq> a\<close> show "a \<in> Field (r - Id)" unfolding Field_def by blast
qed

subsection \<open>Orders on a type\<close>

abbreviation "strict_linear_order \<equiv> strict_linear_order_on UNIV"

abbreviation "linear_order \<equiv> linear_order_on UNIV"

abbreviation "well_order \<equiv> well_order_on UNIV"

subsection \<open>Order-like relations\<close>

text \<open>
  In this subsection, we develop basic concepts and results pertaining
  to order-like relations, i.e., to reflexive and/or transitive and/or symmetric and/or
  total relations. We also further define upper and lower bounds operators.
\<close>

subsubsection \<open>Auxiliaries\<close>

lemma refl_on_domain: "refl_on A r \<Longrightarrow> (a, b) \<in> r \<Longrightarrow> a \<in> A \<and> b \<in> A"
  by (auto simp add: refl_on_def)

corollary well_order_on_domain: "well_order_on A r \<Longrightarrow> (a, b) \<in> r \<Longrightarrow> a \<in> A \<and> b \<in> A"
  by (auto simp add: refl_on_domain order_on_defs)

lemma well_order_on_Field: "well_order_on A r \<Longrightarrow> A = Field r"
  by (auto simp add: refl_on_def Field_def order_on_defs)

lemma well_order_on_Well_order: "well_order_on A r \<Longrightarrow> A = Field r \<and> Well_order r"
  using well_order_on_Field [of A] by auto

lemma Total_subset_Id:
  assumes "Total r"
    and "r \<subseteq> Id"
  shows "r = {} \<or> (\<exists>a. r = {(a, a)})"
proof -
  have "\<exists>a. r = {(a, a)}" if "r \<noteq> {}"
  proof -
    from that obtain a b where ab: "(a, b) \<in> r" by fast
    with \<open>r \<subseteq> Id\<close> have "a = b" by blast
    with ab have aa: "(a, a) \<in> r" by simp
    have "a = c \<and> a = d" if "(c, d) \<in> r" for c d
    proof -
      from that have "{a, c, d} \<subseteq> Field r"
        using ab unfolding Field_def by blast
      then have "((a, c) \<in> r \<or> (c, a) \<in> r \<or> a = c) \<and> ((a, d) \<in> r \<or> (d, a) \<in> r \<or> a = d)"
        using \<open>Total r\<close> unfolding total_on_def by blast
      with \<open>r \<subseteq> Id\<close> show ?thesis by blast
    qed
    then have "r \<subseteq> {(a, a)}" by auto
    with aa show ?thesis by blast
  qed
  then show ?thesis by blast
qed

lemma Linear_order_in_diff_Id:
  assumes "Linear_order r"
    and "a \<in> Field r"
    and "b \<in> Field r"
  shows "(a, b) \<in> r \<longleftrightarrow> (b, a) \<notin> r - Id"
  using assms unfolding order_on_defs total_on_def antisym_def Id_def refl_on_def by force

subsubsection \<open>The upper and lower bounds operators\<close>

text \<open>
  Here we define upper (``above") and lower (``below") bounds operators. We
  think of \<open>r\<close> as a \<^emph>\<open>non-strict\<close> relation. The suffix \<open>S\<close> at the names of
  some operators indicates that the bounds are strict -- e.g., \<open>underS a\<close> is
  the set of all strict lower bounds of \<open>a\<close> (w.r.t. \<open>r\<close>). Capitalization of
  the first letter in the name reminds that the operator acts on sets, rather
  than on individual elements.
\<close>

definition under :: "'a rel \<Rightarrow> 'a \<Rightarrow> 'a set"
  where "under r a \<equiv> {b. (b, a) \<in> r}"

definition underS :: "'a rel \<Rightarrow> 'a \<Rightarrow> 'a set"
  where "underS r a \<equiv> {b. b \<noteq> a \<and> (b, a) \<in> r}"

definition Under :: "'a rel \<Rightarrow> 'a set \<Rightarrow> 'a set"
  where "Under r A \<equiv> {b \<in> Field r. \<forall>a \<in> A. (b, a) \<in> r}"

definition UnderS :: "'a rel \<Rightarrow> 'a set \<Rightarrow> 'a set"
  where "UnderS r A \<equiv> {b \<in> Field r. \<forall>a \<in> A. b \<noteq> a \<and> (b, a) \<in> r}"

definition above :: "'a rel \<Rightarrow> 'a \<Rightarrow> 'a set"
  where "above r a \<equiv> {b. (a, b) \<in> r}"

definition aboveS :: "'a rel \<Rightarrow> 'a \<Rightarrow> 'a set"
  where "aboveS r a \<equiv> {b. b \<noteq> a \<and> (a, b) \<in> r}"

definition Above :: "'a rel \<Rightarrow> 'a set \<Rightarrow> 'a set"
  where "Above r A \<equiv> {b \<in> Field r. \<forall>a \<in> A. (a, b) \<in> r}"

definition AboveS :: "'a rel \<Rightarrow> 'a set \<Rightarrow> 'a set"
  where "AboveS r A \<equiv> {b \<in> Field r. \<forall>a \<in> A. b \<noteq> a \<and> (a, b) \<in> r}"

definition ofilter :: "'a rel \<Rightarrow> 'a set \<Rightarrow> bool"
  where "ofilter r A \<equiv> A \<subseteq> Field r \<and> (\<forall>a \<in> A. under r a \<subseteq> A)"

text \<open>
  Note: In the definitions of \<open>Above[S]\<close> and \<open>Under[S]\<close>, we bounded
  comprehension by \<open>Field r\<close> in order to properly cover the case of \<open>A\<close> being
  empty.
\<close>

lemma underS_subset_under: "underS r a \<subseteq> under r a"
  by (auto simp add: underS_def under_def)

lemma underS_notIn: "a \<notin> underS r a"
  by (simp add: underS_def)

lemma Refl_under_in: "Refl r \<Longrightarrow> a \<in> Field r \<Longrightarrow> a \<in> under r a"
  by (simp add: refl_on_def under_def)

lemma AboveS_disjoint: "A \<inter> (AboveS r A) = {}"
  by (auto simp add: AboveS_def)

lemma in_AboveS_underS: "a \<in> Field r \<Longrightarrow> a \<in> AboveS r (underS r a)"
  by (auto simp add: AboveS_def underS_def)

lemma Refl_under_underS: "Refl r \<Longrightarrow> a \<in> Field r \<Longrightarrow> under r a = underS r a \<union> {a}"
  unfolding under_def underS_def
  using refl_on_def[of _ r] by fastforce

lemma underS_empty: "a \<notin> Field r \<Longrightarrow> underS r a = {}"
  by (auto simp: Field_def underS_def)

lemma under_Field: "under r a \<subseteq> Field r"
  by (auto simp: under_def Field_def)

lemma underS_Field: "underS r a \<subseteq> Field r"
  by (auto simp: underS_def Field_def)

lemma underS_Field2: "a \<in> Field r \<Longrightarrow> underS r a \<subset> Field r"
  using underS_notIn underS_Field by fast

lemma underS_Field3: "Field r \<noteq> {} \<Longrightarrow> underS r a \<subset> Field r"
  by (cases "a \<in> Field r") (auto simp: underS_Field2 underS_empty)

lemma AboveS_Field: "AboveS r A \<subseteq> Field r"
  by (auto simp: AboveS_def Field_def)

lemma under_incr:
  assumes "trans r"
    and "(a, b) \<in> r"
  shows "under r a \<subseteq> under r b"
  unfolding under_def
proof auto
  fix x assume "(x, a) \<in> r"
  with assms trans_def[of r] show "(x, b) \<in> r" by blast
qed

lemma underS_incr:
  assumes "trans r"
    and "antisym r"
    and ab: "(a, b) \<in> r"
  shows "underS r a \<subseteq> underS r b"
  unfolding underS_def
proof auto
  assume *: "b \<noteq> a" and **: "(b, a) \<in> r"
  with \<open>antisym r\<close> antisym_def[of r] ab show False
    by blast
next
  fix x assume "x \<noteq> a" "(x, a) \<in> r"
  with ab \<open>trans r\<close> trans_def[of r] show "(x, b) \<in> r"
    by blast
qed

lemma underS_incl_iff:
  assumes LO: "Linear_order r"
    and INa: "a \<in> Field r"
    and INb: "b \<in> Field r"
  shows "underS r a \<subseteq> underS r b \<longleftrightarrow> (a, b) \<in> r"
    (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?rhs
  with \<open>Linear_order r\<close> show ?lhs
    by (simp add: order_on_defs underS_incr)
next
  assume *: ?lhs
  have "(a, b) \<in> r" if "a = b"
    using assms that by (simp add: order_on_defs refl_on_def)
  moreover have False if "a \<noteq> b" "(b, a) \<in> r"
  proof -
    from that have "b \<in> underS r a" unfolding underS_def by blast
    with * have "b \<in> underS r b" by blast
    then show ?thesis by (simp add: underS_notIn)
  qed
  ultimately show "(a,b) \<in> r"
    using assms order_on_defs[of "Field r" r] total_on_def[of "Field r" r] by blast
qed

lemma finite_Linear_order_induct[consumes 3, case_names step]:
  assumes "Linear_order r"
    and "x \<in> Field r"
    and "finite r"
    and step: "\<And>x. x \<in> Field r \<Longrightarrow> (\<And>y. y \<in> aboveS r x \<Longrightarrow> P y) \<Longrightarrow> P x"
  shows "P x"
  using assms(2)
proof (induct rule: wf_induct[of "r\<inverse> - Id"])
  case 1
  from assms(1,3) show "wf (r\<inverse> - Id)"
    using linear_order_on_well_order_on linear_order_on_converse
    unfolding well_order_on_def by blast
next
  case prems: (2 x)
  show ?case
    by (rule step) (use prems in \<open>auto simp: aboveS_def intro: FieldI2\<close>)
qed

subsection \<open>Variations on Well-Founded Relations\<close>

text \<open>
  This subsection contains some variations of the results from @{theory Wellfounded}:
    \<^item> means for slightly more direct definitions by well-founded recursion;
    \<^item> variations of well-founded induction;
    \<^item> means for proving a linear order to be a well-order.
\<close>

subsubsection \<open>Characterizations of well-foundedness\<close>

text \<open>
  A transitive relation is well-founded iff it is ``locally'' well-founded,
  i.e., iff its restriction to the lower bounds of of any element is
  well-founded.
\<close>

lemma trans_wf_iff:
  assumes "trans r"
  shows "wf r \<longleftrightarrow> (\<forall>a. wf (r \<inter> (r\<inverse>``{a} \<times> r\<inverse>``{a})))"
proof -
  define R where "R a = r \<inter> (r\<inverse>``{a} \<times> r\<inverse>``{a})" for a
  have "wf (R a)" if "wf r" for a
    using that R_def wf_subset[of r "R a"] by auto
  moreover
  have "wf r" if *: "\<forall>a. wf(R a)"
    unfolding wf_def
  proof clarify
    fix phi a
    assume **: "\<forall>a. (\<forall>b. (b, a) \<in> r \<longrightarrow> phi b) \<longrightarrow> phi a"
    define chi where "chi b \<longleftrightarrow> (b, a) \<in> r \<longrightarrow> phi b" for b
    with * have "wf (R a)" by auto
    then have "(\<forall>b. (\<forall>c. (c, b) \<in> R a \<longrightarrow> chi c) \<longrightarrow> chi b) \<longrightarrow> (\<forall>b. chi b)"
      unfolding wf_def by blast
    also have "\<forall>b. (\<forall>c. (c, b) \<in> R a \<longrightarrow> chi c) \<longrightarrow> chi b"
    proof (auto simp add: chi_def R_def)
      fix b
      assume "(b, a) \<in> r" and "\<forall>c. (c, b) \<in> r \<and> (c, a) \<in> r \<longrightarrow> phi c"
      then have "\<forall>c. (c, b) \<in> r \<longrightarrow> phi c"
        using assms trans_def[of r] by blast
      with ** show "phi b" by blast
    qed
    finally have  "\<forall>b. chi b" .
    with ** chi_def show "phi a" by blast
  qed
  ultimately show ?thesis unfolding R_def by blast
qed

text\<open>A transitive relation is well-founded if all initial segments are finite.\<close>
corollary wf_finite_segments:
  assumes "irrefl r" and "trans r" and "\<And>x. finite {y. (y, x) \<in> r}"
  shows "wf (r)"
proof (clarsimp simp: trans_wf_iff wf_iff_acyclic_if_finite converse_def assms)
  fix a
  have "trans (r \<inter> ({x. (x, a) \<in> r} \<times> {x. (x, a) \<in> r}))"
    using assms unfolding trans_def Field_def by blast
  then show "acyclic (r \<inter> {x. (x, a) \<in> r} \<times> {x. (x, a) \<in> r})"
    using assms acyclic_def assms irrefl_def by fastforce
qed

text \<open>The next lemma is a variation of \<open>wf_eq_minimal\<close> from Wellfounded,
  allowing one to assume the set included in the field.\<close>

lemma wf_eq_minimal2: "wf r \<longleftrightarrow> (\<forall>A. A \<subseteq> Field r \<and> A \<noteq> {} \<longrightarrow> (\<exists>a \<in> A. \<forall>a' \<in> A. (a', a) \<notin> r))"
proof-
  let ?phi = "\<lambda>A. A \<noteq> {} \<longrightarrow> (\<exists>a \<in> A. \<forall>a' \<in> A. (a',a) \<notin> r)"
  have "wf r \<longleftrightarrow> (\<forall>A. ?phi A)"
    apply (auto simp: ex_in_conv [THEN sym])
     apply (erule wfE_min)
      apply assumption
     apply blast
    apply (rule wfI_min)
    apply fast
    done
  also have "(\<forall>A. ?phi A) \<longleftrightarrow> (\<forall>B \<subseteq> Field r. ?phi B)"
  proof
    assume "\<forall>A. ?phi A"
    then show "\<forall>B \<subseteq> Field r. ?phi B" by simp
  next
    assume *: "\<forall>B \<subseteq> Field r. ?phi B"
    show "\<forall>A. ?phi A"
    proof clarify
      fix A :: "'a set"
      assume **: "A \<noteq> {}"
      define B where "B = A \<inter> Field r"
      show "\<exists>a \<in> A. \<forall>a' \<in> A. (a', a) \<notin> r"
      proof (cases "B = {}")
        case True
        with ** obtain a where a: "a \<in> A" "a \<notin> Field r"
          unfolding B_def by blast
        with a have "\<forall>a' \<in> A. (a',a) \<notin> r"
          unfolding Field_def by blast
        with a show ?thesis by blast
      next
        case False
        have "B \<subseteq> Field r" unfolding B_def by blast
        with False * obtain a where a: "a \<in> B" "\<forall>a' \<in> B. (a', a) \<notin> r"
          by blast
        have "(a', a) \<notin> r" if "a' \<in> A" for a'
        proof
          assume a'a: "(a', a) \<in> r"
          with that have "a' \<in> B" unfolding B_def Field_def by blast
          with a a'a show False by blast
        qed
        with a show ?thesis unfolding B_def by blast
      qed
    qed
  qed
  finally show ?thesis by blast
qed

subsubsection \<open>Characterizations of well-foundedness\<close>

text \<open>
  The next lemma and its corollary enable one to prove that a linear order is
  a well-order in a way which is more standard than via well-foundedness of
  the strict version of the relation.
\<close>

lemma Linear_order_wf_diff_Id:
  assumes "Linear_order r"
  shows "wf (r - Id) \<longleftrightarrow> (\<forall>A \<subseteq> Field r. A \<noteq> {} \<longrightarrow> (\<exists>a \<in> A. \<forall>a' \<in> A. (a, a') \<in> r))"
proof (cases "r \<subseteq> Id")
  case True
  then have *: "r - Id = {}" by blast
  have "wf (r - Id)" by (simp add: *)
  moreover have "\<exists>a \<in> A. \<forall>a' \<in> A. (a, a') \<in> r"
    if *: "A \<subseteq> Field r" and **: "A \<noteq> {}" for A
  proof -
    from \<open>Linear_order r\<close> True
    obtain a where a: "r = {} \<or> r = {(a, a)}"
      unfolding order_on_defs using Total_subset_Id [of r] by blast
    with * ** have "A = {a} \<and> r = {(a, a)}"
      unfolding Field_def by blast
    with a show ?thesis by blast
  qed
  ultimately show ?thesis by blast
next
  case False
  with \<open>Linear_order r\<close> have Field: "Field r = Field (r - Id)"
    unfolding order_on_defs using Total_Id_Field [of r] by blast
  show ?thesis
  proof
    assume *: "wf (r - Id)"
    show "\<forall>A \<subseteq> Field r. A \<noteq> {} \<longrightarrow> (\<exists>a \<in> A. \<forall>a' \<in> A. (a, a') \<in> r)"
    proof clarify
      fix A
      assume **: "A \<subseteq> Field r" and ***: "A \<noteq> {}"
      then have "\<exists>a \<in> A. \<forall>a' \<in> A. (a',a) \<notin> r - Id"
        using Field * unfolding wf_eq_minimal2 by simp
      moreover have "\<forall>a \<in> A. \<forall>a' \<in> A. (a, a') \<in> r \<longleftrightarrow> (a', a) \<notin> r - Id"
        using Linear_order_in_diff_Id [OF \<open>Linear_order r\<close>] ** by blast
      ultimately show "\<exists>a \<in> A. \<forall>a' \<in> A. (a, a') \<in> r" by blast
    qed
  next
    assume *: "\<forall>A \<subseteq> Field r. A \<noteq> {} \<longrightarrow> (\<exists>a \<in> A. \<forall>a' \<in> A. (a, a') \<in> r)"
    show "wf (r - Id)"
      unfolding wf_eq_minimal2
    proof clarify
      fix A
      assume **: "A \<subseteq> Field(r - Id)" and ***: "A \<noteq> {}"
      then have "\<exists>a \<in> A. \<forall>a' \<in> A. (a,a') \<in> r"
        using Field * by simp
      moreover have "\<forall>a \<in> A. \<forall>a' \<in> A. (a, a') \<in> r \<longleftrightarrow> (a', a) \<notin> r - Id"
        using Linear_order_in_diff_Id [OF \<open>Linear_order r\<close>] ** mono_Field[of "r - Id" r] by blast
      ultimately show "\<exists>a \<in> A. \<forall>a' \<in> A. (a',a) \<notin> r - Id"
        by blast
    qed
  qed
qed

corollary Linear_order_Well_order_iff:
  "Linear_order r \<Longrightarrow>
    Well_order r \<longleftrightarrow> (\<forall>A \<subseteq> Field r. A \<noteq> {} \<longrightarrow> (\<exists>a \<in> A. \<forall>a' \<in> A. (a, a') \<in> r))"
  unfolding well_order_on_def using Linear_order_wf_diff_Id[of r] by blast

end


theory Sort
  imports
    Main
    "HOL-Library.Multiset"
    "HOL-Library.Code_Target_Nat"
begin

fun sort_list :: \<open>'a :: linorder list \<Rightarrow> 'a list\<close> where
  \<open>sort_list [] = []\<close>
| \<open>sort_list (x # xs) = sort_list [y \<leftarrow> xs. \<not> x \<le> y] @ [x] @ sort_list [y \<leftarrow> xs. x \<le> y]\<close>

lemma sort_permutes [simp]: \<open>mset (sort_list xs) = mset xs\<close>
  by (induction xs rule: sort_list.induct) auto

lemma sort_set_permutes [simp]: \<open>set (sort_list xs) = set xs\<close>
  by (induction xs rule: sort_list.induct) auto

lemma sort_sorts: \<open>sorted (sort_list xs)\<close>
  by (induction xs rule: sort_list.induct) (auto simp add: sorted_append)

export_code sort_list in Haskell (string_classes)

end