(* Author: Asta Halkjær From, DTU Compute *)

theory System_A_ESSLLI imports "HOL-Library.Countable" begin

section \<open>Syntax\<close>

datatype form
  = Falsity (\<open>\<^bold>\<bottom>\<close>)
  | Pro nat
  | Imp form form (infixr \<open>\<^bold>\<longrightarrow>\<close> 25)

abbreviation Truth (\<open>\<^bold>\<top>\<close>) where \<open>\<^bold>\<top> \<equiv> \<^bold>\<bottom> \<^bold>\<longrightarrow> \<^bold>\<bottom>\<close>

abbreviation Neg (\<open>\<^bold>\<not> _\<close> [40] 40) where \<open>\<^bold>\<not> p \<equiv> p \<^bold>\<longrightarrow> \<^bold>\<bottom>\<close>

section \<open>Semantics\<close>

primrec semantics :: \<open>(nat \<Rightarrow> bool) \<Rightarrow> form \<Rightarrow> bool\<close> (\<open>_ \<Turnstile> _\<close> [50, 50] 50) where
  \<open>(I \<Turnstile> \<^bold>\<bottom>) = False\<close>
| \<open>(I \<Turnstile> Pro n) = I n\<close>
| \<open>(I \<Turnstile> (p \<^bold>\<longrightarrow> q)) = ((I \<Turnstile> p) \<longrightarrow> (I \<Turnstile> q))\<close>

section \<open>Axiomatics\<close>

inductive Axiomatics :: \<open>form \<Rightarrow> bool\<close> (\<open>\<turnstile> _\<close> [50] 50) where
  MP: \<open>\<turnstile> p \<Longrightarrow> \<turnstile> (p \<^bold>\<longrightarrow> q) \<Longrightarrow> \<turnstile> q\<close>
| Imp1: \<open>\<turnstile> (p \<^bold>\<longrightarrow> q \<^bold>\<longrightarrow> p)\<close>
| Imp2: \<open>\<turnstile> ((p \<^bold>\<longrightarrow> q \<^bold>\<longrightarrow> r) \<^bold>\<longrightarrow> (p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> p \<^bold>\<longrightarrow> r)\<close>
| Neg: \<open>\<turnstile> (((p \<^bold>\<longrightarrow> \<^bold>\<bottom>) \<^bold>\<longrightarrow> \<^bold>\<bottom>) \<^bold>\<longrightarrow> p)\<close>

section \<open>Soundness\<close>

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

section \<open>Derived Rules\<close>

lemma Imp3: \<open>\<turnstile> (p \<^bold>\<longrightarrow> p)\<close>
  by (metis Imp1 Imp2 MP)

lemma Imp4: \<open>\<turnstile> ((p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> (q \<^bold>\<longrightarrow> r) \<^bold>\<longrightarrow> p \<^bold>\<longrightarrow> r)\<close>
  by (metis Imp1 Imp2 MP)

lemma Imp2': \<open>\<turnstile> ((p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> (p \<^bold>\<longrightarrow> q \<^bold>\<longrightarrow> r) \<^bold>\<longrightarrow> p \<^bold>\<longrightarrow> r)\<close>
  by (metis Imp1 Imp2 Imp3 Imp4 MP)

lemma Imp2'': \<open>\<turnstile> ((p \<^bold>\<longrightarrow> q \<^bold>\<longrightarrow> r) \<^bold>\<longrightarrow> q \<^bold>\<longrightarrow> p \<^bold>\<longrightarrow> r)\<close>
  by (metis Imp1 Imp2' MP)

lemma FalsityE: \<open>\<turnstile> (p \<^bold>\<longrightarrow> \<^bold>\<not> p \<^bold>\<longrightarrow> q)\<close>
proof -
  obtain r where \<open>\<turnstile> ((r \<^bold>\<longrightarrow> p) \<^bold>\<longrightarrow> \<^bold>\<not> p \<^bold>\<longrightarrow> q)\<close>
    by (metis Imp1 Imp2 MP Neg)
  then show ?thesis
    by (metis Imp1 Imp2 MP)
qed

lemma ImpE1: \<open>\<turnstile> (\<^bold>\<not> (p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> p)\<close>
  by (metis FalsityE Imp4 MP Neg)

lemma ImpE2: \<open>\<turnstile> (\<^bold>\<not> (p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> \<^bold>\<not> q)\<close>
  by (metis Imp1 Imp4 MP)

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

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

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

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

lemma imply_MP: \<open>\<turnstile> (imply ps p \<^bold>\<longrightarrow> imply ps (p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> imply ps q)\<close>
proof (induct ps)
  case Nil
  then show ?case
    by (metis Imp1 Imp2 MP imply.simps(1))
next
  case (Cons r ps)
  then show ?case
  proof -
    have \<open>\<turnstile> ((r \<^bold>\<longrightarrow> imply ps p) \<^bold>\<longrightarrow> r \<^bold>\<longrightarrow> imply ps (p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> imply ps q)\<close>
      by (meson Cons.hyps Imp1 Imp2 MP)
    then have \<open>\<turnstile> ((r \<^bold>\<longrightarrow> imply ps p) \<^bold>\<longrightarrow> (r \<^bold>\<longrightarrow> imply ps (p \<^bold>\<longrightarrow> q)) \<^bold>\<longrightarrow> r \<^bold>\<longrightarrow> imply ps q)\<close>
      by (meson Imp2' Imp2'' Imp4 MP)
    then show ?thesis
      by simp
  qed
qed

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

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

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

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

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

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

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

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

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

lemma imply_lift: \<open>\<turnstile> (p \<^bold>\<longrightarrow> q) \<Longrightarrow> \<turnstile> (imply ps p \<^bold>\<longrightarrow> imply ps q)\<close>
proof (induct ps)
  case (Cons r ps)
  then show ?case
    by (metis Axiomatics.simps imply.simps(2))
qed simp

lemma Neg': \<open>\<turnstile> (imply ps (\<^bold>\<not> \<^bold>\<not> p) \<^bold>\<longrightarrow> imply ps p)\<close>
  using Neg imply_lift by simp

lemma Boole: \<open>\<turnstile> imply ((\<^bold>\<not> p) # ps) \<^bold>\<bottom> \<Longrightarrow> \<turnstile> imply ps p\<close>
  using deduct MP Neg' by blast

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

section \<open>Consistent\<close>

definition consistent :: \<open>form set \<Rightarrow> bool\<close> where
  \<open>consistent S \<equiv> \<nexists>S'. set S' \<subseteq> S \<and> \<turnstile> imply S' \<^bold>\<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>\<turnstile> imply S' \<^bold>\<bottom>\<close> \<open>set S' \<subseteq> (\<Union>n. extend S f n)\<close>
    unfolding consistent_def by blast
  then obtain m where \<open>set S' \<subseteq> (\<Union>n \<le> m. extend S f n)\<close>
    using UN_finite_bound by (metis List.finite_set)
  then have \<open>set S' \<subseteq> extend S f m\<close>
    using extend_bound by blast
  moreover have \<open>consistent (extend S f m)\<close>
    using assms consistent_extend by blast
  ultimately show False
    unfolding consistent_def using \<open>\<turnstile> imply S' \<^bold>\<bottom>\<close> by blast
qed

section \<open>Maximal\<close>

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

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

section \<open>Hintikka\<close>

locale Hintikka =
  fixes H :: \<open>form set\<close>
  assumes
    NoFalsity: \<open>\<^bold>\<bottom> \<notin> H\<close> and
    Pro: \<open>Pro n \<in> H \<Longrightarrow> (\<^bold>\<not> Pro n) \<notin> H\<close> and
    ImpP: \<open>(p \<^bold>\<longrightarrow> q) \<in> H \<Longrightarrow> (\<^bold>\<not> p) \<in> H \<or> q \<in> H\<close> and
    ImpN: \<open>(\<^bold>\<not> (p \<^bold>\<longrightarrow> q)) \<in> H \<Longrightarrow> p \<in> H \<and> (\<^bold>\<not> q) \<in> H\<close>

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

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

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

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

    assume \<open>(\<^bold>\<not> p) \<notin> S\<close>
    then obtain Sp' where Sp': \<open>\<turnstile> imply ((\<^bold>\<not> p) # Sp') \<^bold>\<bottom>\<close> \<open>set Sp' \<subseteq> S\<close>
      using assms inconsistent_head by blast

    obtain S' where S': \<open>set S' = set Sp' \<union> set Sq'\<close>
      by (meson set_append)
    then have \<open>\<turnstile> imply ((\<^bold>\<not> p) # S') \<^bold>\<bottom>\<close> \<open>\<turnstile> imply (q # S') \<^bold>\<bottom>\<close>
    proof -
      have \<open>set Sp' \<subseteq> set S'\<close>
        using S' by blast
      then show \<open>\<turnstile> imply ((\<^bold>\<not> p) # S') \<^bold>\<bottom>\<close>
        by (metis Sp'(1) deduct imply_weaken)
      have \<open>set Sq' \<subseteq> set S'\<close>
        using S' by blast
      then show \<open>\<turnstile> imply (q # S') \<^bold>\<bottom>\<close>
        using ** by (metis Sq'(1) deduct imply_weaken)
    qed
    then have \<open>\<turnstile> imply ((p \<^bold>\<longrightarrow> q) # S') \<^bold>\<bottom>\<close>
      using Boole imply_Cons imply_head imply_mp' cut' by metis
    moreover have \<open>set ((p \<^bold>\<longrightarrow> q) # S') \<subseteq> S\<close> if \<open>q \<notin> S\<close>
      using that *(1) S' Sp'(2) Sq'(2) by auto
    ultimately show False
      using ** assms unfolding consistent_def by blast
  qed
next
  fix p q
  assume *: \<open>(\<^bold>\<not> (p \<^bold>\<longrightarrow> q)) \<in> S\<close>
  show \<open>p \<in> S \<and> (\<^bold>\<not> q) \<in> S\<close>
  proof (rule conjI; rule ccontr)
    assume \<open>p \<notin> S\<close>
    then obtain S' where S': \<open>\<turnstile> imply (p # S') \<^bold>\<bottom>\<close> \<open>set S' \<subseteq> S\<close>
      using assms inconsistent_head by blast
    moreover have \<open>\<turnstile> imply ((\<^bold>\<not> (p \<^bold>\<longrightarrow> q)) # S') p\<close>
      using add_imply ImpE1 deduct by blast
    ultimately have \<open>\<turnstile> imply ((\<^bold>\<not> (p \<^bold>\<longrightarrow> q)) # S') \<^bold>\<bottom>\<close>
      using cut' by blast
    moreover have \<open>set ((\<^bold>\<not> (p \<^bold>\<longrightarrow> q)) # S') \<subseteq> S\<close>
      using *(1) S'(2) by fastforce
    ultimately show False
      using assms unfolding consistent_def by blast
  next
    assume \<open>(\<^bold>\<not> q) \<notin> S\<close>
    then obtain S' where S': \<open>\<turnstile> imply ((\<^bold>\<not> q) # S') \<^bold>\<bottom>\<close> \<open>set S' \<subseteq> S\<close>
      using assms inconsistent_head by blast
    moreover have \<open>\<turnstile> imply ((\<^bold>\<not> (p \<^bold>\<longrightarrow> q)) # S') (\<^bold>\<not> q)\<close>
      using add_imply ImpE2 deduct by blast
    ultimately have \<open>\<turnstile> imply ((\<^bold>\<not> (p \<^bold>\<longrightarrow> q)) # S') \<^bold>\<bottom>\<close>
      using cut' by blast
    moreover have \<open>set ((\<^bold>\<not> (p \<^bold>\<longrightarrow> 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>

instance form :: countable by countable_datatype

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>\<turnstile> imply ps p\<close>
proof (rule ccontr)
  assume \<open>\<not> \<turnstile> imply ps p\<close>
  then have *: \<open>\<not> \<turnstile> imply ((\<^bold>\<not> p) # ps) \<^bold>\<bottom>\<close>
    using Boole by blast

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

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

  have \<open>model ?H \<Turnstile> p\<close> if \<open>p \<in> ?S\<close> for p
    using that Extend_subset Hintikka_model \<open>Hintikka ?H\<close> by blast
  then have \<open>model ?H \<Turnstile> (\<^bold>\<not> 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> (\<^bold>\<not> p)\<close> by simp
qed

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

section \<open>Main Result\<close>

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

theorem main: \<open>valid p \<longleftrightarrow> \<turnstile> p\<close>
  using completeness soundness by fast

end


section \<open>Type Application\<close>

theory TypeApp
imports HOLCF
begin

subsection \<open>Class of type constructors\<close>

text \<open>In HOLCF, the type @{typ "udom defl"} consists of deflations
over the universal domain---each value of type @{typ "udom defl"}
represents a bifinite domain. In turn, values of the continuous
function type @{typ "udom defl \<rightarrow> udom defl"} represent functions from
domains to domains, i.e.~type constructors.\<close>

text \<open>Class \<open>tycon\<close>, defined below, will be populated with
dummy types: For example, if the type \<open>foo\<close> is an instance of
class \<open>tycon\<close>, then users will never deal with any values \<open>x::foo\<close> in practice. Such types are only used with the overloaded
constant \<open>tc\<close>, which associates each type \<open>'a::tycon\<close>
with a value of type @{typ "udom defl \<rightarrow> udom defl"}. \medskip\<close>

class tycon =
  fixes tc :: "('a::type) itself \<Rightarrow> udom defl \<rightarrow> udom defl"

text \<open>Type @{typ "'a itself"} is defined in Isabelle's meta-logic;
it is inhabited by a single value, written @{term "TYPE('a)"}. We
define the syntax \<open>TC('a)\<close> to abbreviate \<open>tc
TYPE('a)\<close>. \medskip\<close>

syntax  "_TC" :: "type \<Rightarrow> logic"  ("(1TC/(1'(_')))")

translations "TC('a)" \<rightleftharpoons> "CONST tc TYPE('a)"

subsection \<open>Type constructor for type application\<close>

text \<open>We now define a binary type constructor that models type
application: Type \<open>('a, 't) app\<close> is the result of applying the
type constructor \<open>'t\<close> (from class \<open>tycon\<close>) to the type
argument \<open>'a\<close> (from class \<open>domain\<close>).\<close>

text \<open>We define type \<open>('a, 't) app\<close> using \<open>domaindef\<close>,
a low-level type-definition command provided by HOLCF (similar to
\<open>typedef\<close> in Isabelle/HOL) that defines a new domain type
represented by the given deflation. Note that in HOLCF, \<open>DEFL('a)\<close> is an abbreviation for \<open>defl TYPE('a)\<close>, where
\<open>defl :: ('a::domain) itself \<Rightarrow> udom defl\<close> is an overloaded
function from the \<open>domain\<close> type class that yields the deflation
representing the given type. \medskip\<close>

domaindef ('a,'t) app = "TC('t::tycon)\<cdot>DEFL('a::domain)"

text \<open>We define the infix syntax \<open>'a\<cdot>'t\<close> for the type \<open>('a,'t) app\<close>. Note that for consistency with Isabelle's existing
type syntax, we have used postfix order for type application: type
argument on the left, type constructor on the right. \medskip\<close>

type_notation app ("(_\<cdot>_)" [999,1000] 999)

text \<open>The \<open>domaindef\<close> command generates the theorem \<open>DEFL_app\<close>: @{thm DEFL_app [where 'a="'a::domain" and 't="'t::tycon"]},
which we can use to derive other useful lemmas. \medskip\<close>

lemma TC_DEFL: "TC('t::tycon)\<cdot>DEFL('a) = DEFL('a\<cdot>'t)"
by (rule DEFL_app [symmetric])

lemma DEFL_app_mono [simp, intro]:
  "DEFL('a) \<sqsubseteq> DEFL('b) \<Longrightarrow> DEFL('a\<cdot>'t::tycon) \<sqsubseteq> DEFL('b\<cdot>'t)"
 apply (simp add: DEFL_app)
 apply (erule monofun_cfun_arg)
done

end


theory Type_Preservation
  imports "../Nominal"
begin

text {*

  This theory shows how to prove the type preservation
  property for the simply-typed lambda-calculus and
  beta-reduction.

*}

atom_decl name

nominal_datatype lam =
  Var "name"
| App "lam" "lam"
| Lam "\<guillemotleft>name\<guillemotright>lam" ("Lam [_]._")

text {* Capture-Avoiding Substitution *}

nominal_primrec
  subst :: "lam \<Rightarrow> name \<Rightarrow> lam \<Rightarrow> lam"  ("_[_::=_]")
where
  "(Var x)[y::=s] = (if x=y then s else (Var x))"
| "(App t\<^sub>1 t\<^sub>2)[y::=s] = App (t\<^sub>1[y::=s]) (t\<^sub>2[y::=s])"
| "x\<sharp>(y,s) \<Longrightarrow> (Lam [x].t)[y::=s] = Lam [x].(t[y::=s])"
apply(finite_guess)+
apply(rule TrueI)+
apply(simp add: abs_fresh)
apply(fresh_guess)+
done

lemma  subst_eqvt[eqvt]:
  fixes pi::"name prm"
  shows "pi\<bullet>(t1[x::=t2]) = (pi\<bullet>t1)[(pi\<bullet>x)::=(pi\<bullet>t2)]"
by (nominal_induct t1 avoiding: x t2 rule: lam.strong_induct)
   (auto simp add: perm_bij fresh_atm fresh_bij)

lemma fresh_fact:
  fixes z::"name"
  shows "\<lbrakk>z\<sharp>s; (z=y \<or> z\<sharp>t)\<rbrakk> \<Longrightarrow> z\<sharp>t[y::=s]"
by (nominal_induct t avoiding: z y s rule: lam.strong_induct)
   (auto simp add: abs_fresh fresh_prod fresh_atm)

text {* Types *}

nominal_datatype ty =
    TVar "string"
  | TArr "ty" "ty" ("_ \<rightarrow> _")

lemma ty_fresh:
  fixes x::"name"
  and   T::"ty"
  shows "x\<sharp>T"
by (induct T rule: ty.induct)
   (auto simp add: fresh_string)

text {* Typing Contexts *}

type_synonym ctx = "(name\<times>ty) list"

abbreviation
  "sub_ctx" :: "ctx \<Rightarrow> ctx \<Rightarrow> bool" ("_ \<subseteq> _")
where
  "\<Gamma>\<^sub>1 \<subseteq> \<Gamma>\<^sub>2 \<equiv> \<forall>x. x \<in> set \<Gamma>\<^sub>1 \<longrightarrow> x \<in> set \<Gamma>\<^sub>2"

text {* Validity of Typing Contexts *}

inductive
  valid :: "(name\<times>ty) list \<Rightarrow> bool"
where
    v1[intro]: "valid []"
  | v2[intro]: "\<lbrakk>valid \<Gamma>; x\<sharp>\<Gamma>\<rbrakk>\<Longrightarrow> valid ((x,T)#\<Gamma>)"

equivariance valid

lemma valid_elim[dest]:
  assumes a: "valid ((x,T)#\<Gamma>)"
  shows "x\<sharp>\<Gamma> \<and> valid \<Gamma>"
using a by (cases) (auto)

lemma valid_insert:
  assumes a: "valid (\<Delta>@[(x,T)]@\<Gamma>)"
  shows "valid (\<Delta> @ \<Gamma>)"
using a
by (induct \<Delta>)
   (auto simp add:  fresh_list_append fresh_list_cons dest!: valid_elim)

lemma fresh_set:
  shows "y\<sharp>xs = (\<forall>x\<in>set xs. y\<sharp>x)"
by (induct xs) (simp_all add: fresh_list_nil fresh_list_cons)

lemma context_unique:
  assumes a1: "valid \<Gamma>"
  and     a2: "(x,T) \<in> set \<Gamma>"
  and     a3: "(x,U) \<in> set \<Gamma>"
  shows "T = U"
using a1 a2 a3
by (induct) (auto simp add: fresh_set fresh_prod fresh_atm)

text {* Typing Relation *}

inductive
  typing :: "ctx \<Rightarrow> lam \<Rightarrow> ty \<Rightarrow> bool" ("_ \<turnstile> _ : _")
where
  t_Var[intro]: "\<lbrakk>valid \<Gamma>; (x,T)\<in>set \<Gamma>\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Var x : T"
| t_App[intro]: "\<lbrakk>\<Gamma> \<turnstile> t\<^sub>1 : T\<^sub>1\<rightarrow>T\<^sub>2; \<Gamma> \<turnstile> t\<^sub>2 : T\<^sub>1\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> App t\<^sub>1 t\<^sub>2 : T\<^sub>2"
| t_Lam[intro]: "\<lbrakk>x\<sharp>\<Gamma>; (x,T\<^sub>1)#\<Gamma> \<turnstile> t : T\<^sub>2\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Lam [x].t : T\<^sub>1\<rightarrow>T\<^sub>2"

equivariance typing
nominal_inductive typing
  by (simp_all add: abs_fresh ty_fresh)

lemma t_Lam_inversion[dest]:
  assumes ty: "\<Gamma> \<turnstile> Lam [x].t : T"
  and     fc: "x\<sharp>\<Gamma>"
  shows "\<exists>T\<^sub>1 T\<^sub>2. T = T\<^sub>1 \<rightarrow> T\<^sub>2 \<and> (x,T\<^sub>1)#\<Gamma> \<turnstile> t : T\<^sub>2"
using ty fc
by (cases rule: typing.strong_cases)
   (auto simp add: alpha lam.inject abs_fresh ty_fresh)

lemma t_App_inversion[dest]:
  assumes ty: "\<Gamma> \<turnstile> App t1 t2 : T"
  shows "\<exists>T'. \<Gamma> \<turnstile> t1 : T' \<rightarrow> T \<and> \<Gamma> \<turnstile> t2 : T'"
using ty
by (cases) (auto simp add: lam.inject)

lemma weakening:
  fixes \<Gamma>1 \<Gamma>2::"ctx"
  assumes a: "\<Gamma>1 \<turnstile> t : T"
  and     b: "valid \<Gamma>2"
  and     c: "\<Gamma>1 \<subseteq> \<Gamma>2"
  shows "\<Gamma>2 \<turnstile> t : T"
using a b c
by (nominal_induct \<Gamma>1 t T avoiding: \<Gamma>2 rule: typing.strong_induct)
   (auto | atomize)+

lemma type_substitution_aux:
  assumes a: "(\<Delta>@[(x,T')]@\<Gamma>) \<turnstile> e : T"
  and     b: "\<Gamma> \<turnstile> e' : T'"
  shows "(\<Delta>@\<Gamma>) \<turnstile> e[x::=e'] : T"
using a b
proof (nominal_induct "\<Delta>@[(x,T')]@\<Gamma>" e T avoiding: x e' \<Delta> rule: typing.strong_induct)
  case (t_Var y T x e' \<Delta>)
  then have a1: "valid (\<Delta>@[(x,T')]@\<Gamma>)"
       and  a2: "(y,T) \<in> set (\<Delta>@[(x,T')]@\<Gamma>)"
       and  a3: "\<Gamma> \<turnstile> e' : T'" .
  from a1 have a4: "valid (\<Delta>@\<Gamma>)" by (rule valid_insert)
  { assume eq: "x=y"
    from a1 a2 have "T=T'" using eq by (auto intro: context_unique)
    with a3 have "\<Delta>@\<Gamma> \<turnstile> Var y[x::=e'] : T" using eq a4 by (auto intro: weakening)
  }
  moreover
  { assume ineq: "x\<noteq>y"
    from a2 have "(y,T) \<in> set (\<Delta>@\<Gamma>)" using ineq by simp
    then have "\<Delta>@\<Gamma> \<turnstile> Var y[x::=e'] : T" using ineq a4 by auto
  }
  ultimately show "\<Delta>@\<Gamma> \<turnstile> Var y[x::=e'] : T" by blast
qed (force simp add: fresh_list_append fresh_list_cons)+

corollary type_substitution:
  assumes a: "(x,T')#\<Gamma> \<turnstile> e : T"
  and     b: "\<Gamma> \<turnstile> e' : T'"
  shows "\<Gamma> \<turnstile> e[x::=e'] : T"
using a b
by (auto intro: type_substitution_aux[where \<Delta>="[]",simplified])

text {* Beta Reduction *}

inductive
  "beta" :: "lam\<Rightarrow>lam\<Rightarrow>bool" (" _ \<longrightarrow>\<^sub>\<beta> _")
where
  b1[intro]: "t1 \<longrightarrow>\<^sub>\<beta> t2 \<Longrightarrow> App t1 s \<longrightarrow>\<^sub>\<beta> App t2 s"
| b2[intro]: "s1 \<longrightarrow>\<^sub>\<beta> s2 \<Longrightarrow> App t s1 \<longrightarrow>\<^sub>\<beta> App t s2"
| b3[intro]: "t1 \<longrightarrow>\<^sub>\<beta> t2 \<Longrightarrow> Lam [x].t1 \<longrightarrow>\<^sub>\<beta> Lam [x].t2"
| b4[intro]: "x\<sharp>s \<Longrightarrow> App (Lam [x].t) s \<longrightarrow>\<^sub>\<beta> t[x::=s]"

equivariance beta
nominal_inductive beta
  by (auto simp add: abs_fresh fresh_fact)

theorem type_preservation:
  assumes a: "t \<longrightarrow>\<^sub>\<beta> t'"
  and     b: "\<Gamma> \<turnstile> t : T"
  shows "\<Gamma> \<turnstile> t' : T"
using a b
proof (nominal_induct avoiding: \<Gamma> T rule: beta.strong_induct)
  case (b1 t1 t2 s \<Gamma> T)
  have "\<Gamma> \<turnstile> App t1 s : T" by fact
  then obtain T' where a1: "\<Gamma> \<turnstile> t1 : T' \<rightarrow> T" and a2: "\<Gamma> \<turnstile> s : T'" by auto
  have ih: "\<Gamma> \<turnstile> t1 : T' \<rightarrow> T \<Longrightarrow> \<Gamma> \<turnstile> t2 : T' \<rightarrow> T" by fact
  with a1 a2 show "\<Gamma> \<turnstile> App t2 s : T" by auto
next
  case (b2 s1 s2 t \<Gamma> T)
  have "\<Gamma> \<turnstile> App t s1 : T" by fact
  then obtain T' where a1: "\<Gamma> \<turnstile> t : T' \<rightarrow> T" and a2: "\<Gamma> \<turnstile> s1 : T'" by auto
  have ih: "\<Gamma> \<turnstile> s1 : T' \<Longrightarrow> \<Gamma> \<turnstile> s2 : T'" by fact
  with a1 a2 show "\<Gamma> \<turnstile> App t s2 : T" by auto
next
  case (b3 t1 t2 x \<Gamma> T)
  have vc: "x\<sharp>\<Gamma>" by fact
  have "\<Gamma> \<turnstile> Lam [x].t1 : T" by fact
  then obtain T1 T2 where a1: "(x,T1)#\<Gamma> \<turnstile> t1 : T2" and a2: "T = T1 \<rightarrow> T2" using vc by auto
  have ih: "(x,T1)#\<Gamma> \<turnstile> t1 : T2 \<Longrightarrow> (x,T1)#\<Gamma> \<turnstile> t2 : T2" by fact
  with a1 a2 show "\<Gamma> \<turnstile> Lam [x].t2 : T" using vc by auto
next
  case (b4 x s t \<Gamma> T)
  have vc: "x\<sharp>\<Gamma>" by fact
  have "\<Gamma> \<turnstile> App (Lam [x].t) s : T" by fact
  then obtain T' where a1: "\<Gamma> \<turnstile> Lam [x].t : T' \<rightarrow> T" and a2: "\<Gamma> \<turnstile> s : T'" by auto
  from a1 obtain T1 T2 where a3: "(x,T')#\<Gamma> \<turnstile> t : T" using vc by (auto simp add: ty.inject)
  from a3 a2 show "\<Gamma> \<turnstile> t[x::=s] : T" by (simp add: type_substitution)
qed

theorem type_preservation_automatic:
  assumes a: "t \<longrightarrow>\<^sub>\<beta> t'"
  and     b: "\<Gamma> \<turnstile> t : T"
  shows "\<Gamma> \<turnstile> t' : T"
using a b
by (nominal_induct avoiding: \<Gamma> T rule: beta.strong_induct)
   (auto dest!: t_Lam_inversion t_App_inversion simp add: ty.inject type_substitution)

end


(*  Title:      Environments.thy
    Author:     Florian Kammuller and Henry Sudhof, 2008
*)

theory Environments imports Main begin

subsection {* Type Environments*}
text{*Some basic properties of our variable environments.*}

(* We use a wrapped map and an error element *)
datatype 'a environment =
  Env "(string ~=> 'a)"
| Malformed

(* Adding an entry to an environment. Overwriting an entry switches to the error state*)
primrec
  add :: "('a environment) \<Rightarrow> string \<Rightarrow> 'a \<Rightarrow> 'a environment"
  ("_<_:_>" [90, 50, 0] 91)
where
  add_def: "(Env e)<x:a> =
     (if (x \<notin> dom e) then (Env (e(x \<mapsto> a))) else Malformed)"
| add_mal: "Malformed<x:a> = Malformed"

notation (xsymbols)
  add  ("_\<lparr>_:_\<rparr>" [90, 0, 0] 91)

(* domains of environments, i.e. the set of used variable names *)
primrec
  env_dom :: "('a environment) \<Rightarrow> string set"
where
  env_dom_def: "env_dom (Env e) = dom e"
| env_dom_mal: "env_dom (Malformed) = {}"

(* Retrieving an entry from an environment *)
primrec
  env_get :: "('a environment) \<Rightarrow> string  \<Rightarrow> 'a option" ("_!_")
where
  env_get_def: "env_get (Env e) x = e x "
| env_get_mal: "env_get (Malformed) x = None "

(* Environment well-formedness. For now weaker than usually recommended for LN; just finiteness and not being the error value *)
primrec ok::"('a environment) \<Rightarrow> bool"
where
  OK_Env [intro]: "ok (Env e) = (finite (dom e))"
| OK_Mal [intro]: "ok Malformed = False"

(* commutativity of add *)
lemma subst_add:
  fixes x y
  assumes "x \<noteq> y"
  shows "e\<lparr>x:a\<rparr>\<lparr>y:b\<rparr> = e\<lparr>y:b\<rparr>\<lparr>x:a\<rparr>"
proof (cases e)
  case Malformed thus ?thesis by simp
next
  case (Env f) with assms show ?thesis
  proof (cases "x \<in> dom f", simp)
    case False with assms Env show ?thesis
    proof (cases "y \<in> dom f", simp_all, intro ext)
      fix xa :: string
      case False with assms show "(f(x \<mapsto> a,y \<mapsto> b)) xa = (f(y \<mapsto> b,x \<mapsto> a)) xa"
      proof (cases "xa = x", simp)
        case False with assms show ?thesis
          by (cases "xa = y", simp_all)
      qed
    qed
  qed
qed

(* A well-formed environment is finite *)
lemma ok_finite[simp]: "ok e \<Longrightarrow> finite (env_dom e)"
  by (cases e, simp+)

(* A well-formed environment is not malformed *)
lemma ok_ok[simp]: "ok e \<Longrightarrow> \<exists>x. e = (Env x)"
  by (cases e, simp+)

(* If something is in the set of variable names, then it has a value assigned to it *)
lemma env_defined:
  fixes x :: string and e :: "'a environment"
  assumes "x \<in> env_dom e"
  shows "\<exists>T . e!x = Some T"
proof (cases e)
  case Malformed with assms show ?thesis by simp (* contradiction *)
next
  case Env with assms show ?thesis by (simp, force)
qed

(* adding of new elements does not remove elements *)
lemma env_bigger: "\<lbrakk> a \<notin> env_dom e; x \<in> (env_dom e) \<rbrakk> \<Longrightarrow> x \<in> env_dom (e\<lparr>a:X\<rparr>)"
  by (cases e, simp_all)

(* Added for convenience *)
lemma env_bigger2:
  "\<lbrakk> a \<notin> env_dom e; b \<notin> (env_dom e); x \<in> (env_dom e); a \<noteq> b \<rbrakk>
  \<Longrightarrow> x \<in> env_dom (e\<lparr>a:X\<rparr>\<lparr>b:Y\<rparr>)"
  by (cases e, simp_all)

(* If there is an entry, then the environment is sane. *)
lemma not_malformed: "x \<in> (env_dom e) \<Longrightarrow> \<exists>fun. e = Env fun"
  by (cases e, simp_all)

(* Smaller environments are well formed. *)
lemma not_malformed_smaller:
  fixes e :: "'a environment" and a :: string and X :: 'a
  assumes "ok (e\<lparr>a:X\<rparr>)"
  shows "ok e"
proof (cases e)
  case Malformed with assms show ?thesis by simp (* contradiction *)
next
  case (Env f) with ok_finite[OF assms] assms show ?thesis
    by (cases "a \<notin> dom f", simp_all)
qed

(* Elements not in a bigger environment are not in a smaller one either *)
lemma not_in_smaller:
  fixes e :: "'a environment" and a :: string and X :: 'a
  assumes "ok (e\<lparr>a:X\<rparr>)"
  shows "a \<notin> env_dom e"
proof (cases e)
  case Malformed thus ?thesis by simp
next
  case (Env f) with assms show ?thesis
    by (cases "a \<notin> dom f", simp_all)
qed

(* A variable that got added is in the environment *)
lemma in_add:
  fixes e :: "'a environment" and a :: string and X :: 'a
  assumes "ok (e\<lparr>a:X\<rparr>)"
  shows "a \<in> env_dom (e\<lparr>a:X\<rparr>)"
proof (cases e)
  case Malformed with assms show ?thesis by simp (* contradiction *)
next
  case (Env f) with assms show ?thesis
    by (cases "a \<notin> dom f", simp_all)
qed

(* Similar to subst_add, but using a more convenient premise *)
lemma ok_add_reverse:
  fixes
  e :: "'a environment" and a :: string and X :: 'a and
  b :: string and Y :: 'a
  assumes "ok (e\<lparr>a:X\<rparr>\<lparr>b:Y\<rparr>)"
  shows "(e\<lparr>b:Y\<rparr>\<lparr>a:X\<rparr>) = (e\<lparr>a:X\<rparr>\<lparr>b:Y\<rparr>)"
proof (cases e)
  case Malformed with assms show ?thesis by simp (* contradiction *)
next
  case (Env f)
  with
    not_in_smaller[OF `ok (e\<lparr>a:X\<rparr>\<lparr>b:Y\<rparr>)`] in_add[OF assms]
    not_in_smaller[OF not_malformed_smaller[OF assms]]
    in_add[OF not_malformed_smaller[OF assms]]
  show ?thesis
    by (simp, intro conjI impI, elim conjE, auto simp: fun_upd_twist)
qed

lemma not_in_env_bigger:
  fixes e :: "'a environment" and a :: string and X :: 'a and x :: string
  assumes "x \<notin> (env_dom e)" and "x \<noteq> a"
  shows "x \<notin> env_dom (e\<lparr>a:X\<rparr>)"
proof (cases e)
  case Malformed thus ?thesis by simp
next
  case (Env f) with assms show ?thesis
    by (cases "a \<notin> dom f", simp_all)
qed

lemma not_in_env_bigger_2:
  fixes
  e :: "'a environment" and a :: string and X :: 'a and
  b :: string and Y :: 'a and x :: string
  assumes "x \<notin> (env_dom e)" and "x \<noteq> a" and "x \<noteq> b"
  shows "x \<notin> env_dom (e\<lparr>a:X\<rparr>\<lparr>b:Y\<rparr>)"
proof (cases e)
  case Malformed thus ?thesis by simp
next
  case (Env f) with assms show ?thesis
    by (cases "a \<notin> dom f", simp_all)
qed

lemma not_in_env_smaller:
  fixes e :: "'a environment" and a :: string and X :: 'a and x :: string
  assumes "x \<notin> (env_dom (e\<lparr>a:X\<rparr>))" and "x \<noteq> a" and "ok (e\<lparr>a:X\<rparr>)"
  shows "x \<notin> env_dom e"
proof (cases e)
  case Malformed with assms(3) show ?thesis by simp (* contradiction *)
next
  case (Env f) with assms show ?thesis
    by (cases "a \<notin> dom f", simp_all)
qed

(* Conditions derivable from the well-formedness *)
lemma ok_add_2:
  fixes
  e :: "'a environment" and a :: string and X :: 'a and
  b :: string and Y :: 'a
  assumes "ok (e\<lparr>a:X\<rparr>\<lparr>b:Y\<rparr>)"
  shows "ok e \<and> a \<notin> env_dom e \<and> b \<notin> env_dom e \<and> a \<noteq> b"
proof -
  {
    assume "ok (e\<lparr>b:X\<rparr>\<lparr>b:Y\<rparr>)"
    from not_in_smaller[OF this] in_add[OF not_malformed_smaller[OF this]]
    have False by simp
  } with assms have "a \<noteq> b" by auto
  moreover
  from assms ok_add_reverse[OF assms] have "ok (e\<lparr>b:Y\<rparr>\<lparr>a:X\<rparr>)" by simp
  note not_in_smaller[OF not_malformed_smaller[OF this]]
  ultimately
  show ?thesis
    using
      not_malformed_smaller[OF not_malformed_smaller[OF assms]]
      not_in_smaller[OF not_malformed_smaller[OF assms]]
  by simp
qed

(* A variable that got added is in the environment *)
lemma in_add_2:
  fixes
  e :: "'a environment" and a :: string and X :: 'a and
  b :: string and Y :: 'a
  assumes "ok (e\<lparr>a:X\<rparr>\<lparr>b:Y\<rparr>)"
  shows "a \<in> env_dom (e\<lparr>a:X\<rparr>\<lparr>b:Y\<rparr>) \<and> b \<in> env_dom (e\<lparr>a:X\<rparr>\<lparr>b:Y\<rparr>)"
proof -
  from ok_add_2[OF assms] show ?thesis
    by (elim conjE, intro conjI, (cases e, simp_all)+)
qed

(* Convenience version *)
lemma ok_add_3:
  fixes
  e :: "'a environment" and a :: string and X :: 'a and
  b :: string and Y :: 'a and c :: string and Z :: 'a
  assumes "ok (e\<lparr>a:X\<rparr>\<lparr>b:Y\<rparr>\<lparr>c:Z\<rparr>)"
  shows
  "a \<notin> env_dom e \<and> b \<notin> env_dom e \<and> c \<notin> env_dom e \<and> a \<noteq> b \<and> b \<noteq> c \<and> a \<noteq> c"
proof -
  {
    assume "ok (e\<lparr>a:X\<rparr>\<lparr>c:Y\<rparr>\<lparr>c:Z\<rparr>)"
    from not_in_smaller[OF this] in_add[OF not_malformed_smaller[OF this]]
    have False by simp
  } with assms have "b \<noteq> c" by auto
  moreover
  from assms ok_add_reverse[OF assms] have "ok (e\<lparr>a:X\<rparr>\<lparr>c:Z\<rparr>\<lparr>b:Y\<rparr>)" by simp
  note ok_add_2[OF not_malformed_smaller[OF this]]
  ultimately
  show ?thesis using ok_add_2[OF not_malformed_smaller[OF assms]]
    by simp
qed

lemma in_env_smaller:
  fixes e :: "'a environment" and a :: string and X :: 'a and x :: string
  assumes "x \<in> (env_dom (e\<lparr>a:X\<rparr>))" and "x \<noteq> a"
  shows "x \<in> env_dom e"
proof -
  from not_malformed[OF assms(1)] obtain f where f: "e\<lparr>a:X\<rparr> = Env f" by auto
  with assms show ?thesis
  proof (cases e)
    case Malformed with `e\<lparr>a:X\<rparr> = Env f`
    have False by simp
    then show ?thesis ..
  next
    case (Env f') with assms f show ?thesis
      by (simp, cases "a \<in> dom f'", simp_all, force)
  qed
qed

lemma in_env_smaller2:
  fixes
  e :: "'a environment" and a :: string and X :: 'a and
  b :: string and Y :: 'a and x :: string
  assumes "x \<in> (env_dom (e\<lparr>a:X\<rparr>\<lparr>b:Y\<rparr>))" and "x \<noteq> a" and "x \<noteq> b"
  shows "x \<in> env_dom e"
  by (simp add: in_env_smaller[OF in_env_smaller[OF assms(1) assms(3)] assms(2)])

lemma get_env_bigger:
  fixes e :: "'a environment" and a :: string and X :: 'a and x :: string
  assumes "x \<in> (env_dom (e\<lparr>a:X\<rparr>))" and "x \<noteq> a"
  shows "e!x = e\<lparr>a:X\<rparr>!x"
proof -
  from not_malformed[OF assms(1)] obtain f where f: "e\<lparr>a:X\<rparr> = Env f" by auto
  thus ?thesis proof (cases e)
    case Malformed with `e\<lparr>a:X\<rparr> = Env f`
    show ?thesis by simp (* contradiction *)
  next
    case (Env f') with assms f show ?thesis
      by (cases "a \<notin> dom f'", auto)
  qed
qed

lemma get_env_bigger2:
  fixes
  e :: "'a environment" and a :: string and X :: 'a and
  b :: string and Y :: 'a and x :: string
  assumes "x \<in> (env_dom (e\<lparr>a:X\<rparr>\<lparr>b:Y\<rparr>))" and "x \<noteq> a" and "x \<noteq> b"
  shows "e!x = e\<lparr>a:X\<rparr>\<lparr>b:Y\<rparr>!x"
  by (simp add: get_env_bigger[OF assms(1) assms(3)]
                get_env_bigger[OF in_env_smaller[OF assms(1) assms(3)] assms(2)])

lemma get_env_smaller: "\<lbrakk> x \<in> env_dom e; a \<notin> env_dom e \<rbrakk> \<Longrightarrow> e\<lparr>a:X\<rparr>!x = e!x"
  by (cases e, auto)

lemma get_env_smaller2:
  "\<lbrakk> x \<in> env_dom e; a \<notin> env_dom e; b \<notin> env_dom e; a \<noteq> b \<rbrakk>
  \<Longrightarrow> e\<lparr>a:X\<rparr>\<lparr>b:Y\<rparr>!x = e!x"
  by (cases e, auto)

lemma add_get_eq: "\<lbrakk> xa \<notin> env_dom e; ok e; the e\<lparr>xa:U\<rparr>!xa = T \<rbrakk> \<Longrightarrow> U = T"
  by (cases e, auto)

lemma add_get: "\<lbrakk> xa \<notin> env_dom e; ok e \<rbrakk> \<Longrightarrow> the e\<lparr>xa:U\<rparr>!xa = U"
  by (cases e, auto)

lemma add_get2_1:
  fixes e :: "'a environment" and x :: string and A :: 'a and y :: string and B :: 'a
  assumes "ok (e\<lparr>x:A\<rparr>\<lparr>y:B\<rparr>)"
  shows "the e\<lparr>x:A\<rparr>\<lparr>y:B\<rparr>!x = A"
proof -
  from ok_add_2[OF assms] show ?thesis
    by (cases e, elim conjE, simp_all)
qed

lemma add_get2_2:
  fixes e :: "'a environment" and x :: string and A :: 'a and y :: string and B :: 'a
  assumes "ok (e\<lparr>x:A\<rparr>\<lparr>y:B\<rparr>)"
  shows "the e\<lparr>x:A\<rparr>\<lparr>y:B\<rparr>!y = B"
proof -
  from ok_add_2[OF assms] show ?thesis
    by (cases e, elim conjE, simp_all)
qed

lemma ok_add_ok: "\<lbrakk> ok e; x \<notin> env_dom e \<rbrakk> \<Longrightarrow> ok (e\<lparr>x:X\<rparr>)"
  by (cases e, auto)

lemma env_add_dom:
  fixes e :: "'a environment" and x :: string
  assumes "ok e" and "x \<notin> env_dom e"
  shows "env_dom (e\<lparr>x:X\<rparr>) = env_dom e \<union> {x}"
proof (auto simp: in_add[OF ok_add_ok[OF assms]], rule ccontr)
  fix y assume "y \<in> env_dom (e<x:X>)" and "y \<notin> env_dom e" and "y \<noteq> x"
  from in_env_smaller[OF this(1) this(3)] this(2) show False by simp
next
  fix y assume "y \<in> env_dom e"
  from env_bigger[OF not_in_smaller[OF ok_add_ok[OF assms]] this]
  show "y \<in> env_dom (e\<lparr>x:X\<rparr>)" by assumption
qed

lemma env_add_dom_2:
  fixes e :: "'a environment" and x :: string and y :: string
  assumes "ok e" and "x \<notin> env_dom e" and "y \<notin> env_dom e" and "x \<noteq> y"
  shows "env_dom (e\<lparr>x:X\<rparr>\<lparr>y:Y\<rparr>) = env_dom e \<union> {x,y}"
proof -
  from env_add_dom[OF assms(1-2)] assms(3-4)
  have "y \<notin> env_dom (e\<lparr>x:X\<rparr>)" by simp
  from
    env_add_dom[OF assms(1-2)]
    env_add_dom[OF ok_add_ok[OF assms(1-2)] this]
  show ?thesis by auto
qed

fun
   env_app :: "('a environment) \<Rightarrow>  ('a environment) \<Rightarrow> ('a environment)" ("_+_")
where
  "env_app (Env a) (Env b) =
  (if (ok (Env a) \<and> ok (Env b) \<and> env_dom (Env b) \<inter> env_dom (Env a) = {})
   then  Env (a ++ b) else Malformed )"

lemma env_app_dom:
  fixes e1 :: "'a environment" and e2 :: "'a environment"
  assumes "ok e1" and "env_dom e1 \<inter> env_dom e2 = {}" and "ok e2"
  shows "env_dom (e1+e2) = env_dom e1 \<union> env_dom e2"
proof -
  from ok_ok[OF `ok e1`] ok_ok[OF `ok e2`]
  obtain f1 f2 where "e1 = Env f1" and "e2 = Env f2" by auto
  with assms(2) ok_finite[OF `ok e1`] ok_finite[OF `ok e2`]
  show ?thesis by auto
qed

lemma env_app_same[simp]:
  fixes e1 :: "'a environment" and e2 :: "'a environment" and x :: string
  assumes
  "ok e1" and "x \<in> env_dom e1" and
  "env_dom e1 \<inter> env_dom e2 = {}" and "ok e2"
  shows "the (e1+e2!x) = the e1!x"
proof -
  from ok_ok[OF `ok e1`] ok_ok[OF `ok e2`]
  obtain f1 f2 where "e1 = Env f1" and "e2 = Env f2" by auto
  with assms(2-3) ok_finite[OF `ok e1`] ok_finite[OF `ok e2`]
  show ?thesis proof (auto)
    fix y :: 'a assume "dom f1 \<inter> dom f2 = {}" and "f1 x = Some y"
    from map_add_comm[OF this(1)] this(2) have "(f1 ++ f2) x = Some y"
      by (simp add: map_add_Some_iff)
    thus "the ((f1 ++ f2) x) = y" by auto
  qed
qed

lemma env_app_ok[simp]:
  fixes e1 :: "'a environment" and e2 :: "'a environment"
  assumes "ok e1" and "env_dom e1 \<inter> env_dom e2 = {}" and "ok e2"
  shows "ok (e1+e2)"
proof -
  from ok_ok[OF `ok e1`] ok_ok[OF `ok e2`]
  obtain f1 f2 where "e1 = Env f1" and "e2 = Env f2" by auto
  with assms show ?thesis by (simp,force)
qed

lemma env_app_add[simp]:
  fixes e1 :: "'a environment" and e2 :: "'a environment" and x :: string
  assumes
  "ok e1" and "env_dom e1 \<inter> env_dom e2 = {}" and "ok e2" and
  "x \<notin> env_dom e1" and "x \<notin> env_dom e2"
  shows "(e1+e2)\<lparr>x:X\<rparr> = e1\<lparr>x:X\<rparr>+e2"
proof -
  from ok_ok[OF `ok e1`] ok_ok[OF `ok e2`]
  obtain f1 f2 where "e1 = Env f1" and "e2 = Env f2" by auto
  with assms show ?thesis proof (clarify, simp, intro impI ext)
    fix xa :: string
    assume "x \<notin> dom f1" and "x \<notin> dom f2"
    thus "((f1 ++ f2)(x \<mapsto> X)) xa = (f1(x \<mapsto> X) ++ f2) xa"
    proof (cases "x = xa", simp_all)
      case False thus "(f1 ++ f2) xa = (f1(x \<mapsto> X) ++ f2) xa"
        by (simp add: map_add_def split: option.split)
    next
      case True with `x \<notin> dom f1` `x \<notin> dom f2`
      have "(f1(xa \<mapsto> X) ++ f2) xa = Some X"
        by (auto simp: map_add_Some_iff)
      thus "Some X = (f1(xa \<mapsto> X) ++ f2) xa" by simp
    qed
  qed
qed

lemma env_app_add2[simp]:
  fixes
  e1 :: "'a environment" and e2 :: "'a environment" and
  x :: string and y :: string
  assumes
  "ok e1" and "env_dom e1 \<inter> env_dom e2 = {}" and "ok e2" and
  "x \<notin> env_dom e1" and "x \<notin> env_dom e2" and "y \<notin> env_dom e1" and
  "y \<notin> env_dom e2" and "x \<noteq> y"
  shows "(e1+e2)\<lparr>x:X\<rparr>\<lparr>y:Y\<rparr> = e1\<lparr>x:X\<rparr>\<lparr>y:Y\<rparr>+e2"
proof -
  from ok_ok[OF `ok e1`] ok_ok[OF `ok e2`]
  obtain f1 f2 where "e1 = Env f1" and "e2 = Env f2" by auto
  with assms show ?thesis proof (clarify, simp, intro impI ext)
    fix xa :: string
    assume "x \<notin> dom f1" and "x \<notin> dom f2" and "y \<notin> dom f1" and "y \<notin> dom f2"
    with `x \<noteq> y`
    show "((f1 ++ f2)(x \<mapsto> X, y \<mapsto> Y)) xa = (f1(x \<mapsto> X, y \<mapsto> Y) ++ f2) xa"
    proof (cases "x = xa", simp)
      case True
      with `x \<noteq> y` `x \<notin> dom f1` `x \<notin> dom f2` `y \<notin> dom f1` `y \<notin> dom f2`
      have "(f1(xa \<mapsto> X,y \<mapsto> Y) ++ f2) xa = Some X"
        by (auto simp: map_add_Some_iff)
      thus "Some X = (f1(xa \<mapsto> X,y \<mapsto> Y) ++ f2) xa" by simp
    next
      case False thus ?thesis
      proof (cases "y = xa", simp_all)
        case False with `x \<noteq> xa`
        show "(f1 ++ f2) xa = (f1(x \<mapsto> X,y \<mapsto> Y) ++ f2) xa"
          by (simp add: map_add_def split: option.split)
      next
        case True
        with `x \<noteq> y` `x \<notin> dom f1` `x \<notin> dom f2` `y \<notin> dom f1` `y \<notin> dom f2`
        have "(f1(x \<mapsto> X,xa \<mapsto> Y) ++ f2) xa = Some Y"
          by (auto simp: map_add_Some_iff)
        thus "Some Y = (f1(x \<mapsto> X, xa \<mapsto> Y) ++ f2) xa" by simp
      qed
    qed
  qed
qed

end


(* Section 3.3 *)

theory ECompiling
imports Main
begin

(* Binary operation *)
type_synonym 'v binop = "'v \<Rightarrow> 'v \<Rightarrow> 'v"

(* Expression language *)
datatype ('a, 'v) expr = Cex 'v (* Constants *)
                       | Vex 'a (* Variables *)
                       | Bex "'v binop" "('a, 'v) expr" "('a, 'v) expr" (* Application *)

(* Value of expression wrt environment *)
primrec "value" :: "('a, 'v) expr \<Rightarrow> ('a \<Rightarrow> 'v) \<Rightarrow> 'v" where
"value (Cex c) env = c" |
"value (Vex v) env = env v" |
"value (Bex f e1 e2) env = f (value e1 env) (value e2 env)"

(* Stack machine instructions *)
datatype ('a, 'v) instr = Const 'v
                        | Load 'a
                        | Apply "'v binop"

(* Execution of stack machine instructions *)
primrec exec :: "('a, 'v) instr list \<Rightarrow> ('a \<Rightarrow> 'v) \<Rightarrow> 'v list \<Rightarrow> 'v list" where
"exec [] s vs = vs" |
"exec (i # is) s vs = (case i of
    Const c \<Rightarrow> exec is s (c # vs)
  | Load a \<Rightarrow> exec is s (s a # vs)
  | Apply f \<Rightarrow> exec is s (f (hd vs) (hd (tl vs)) # tl (tl vs)))"

(* Compile an expression into a list of instructions *)
primrec compile :: "('a, 'v) expr \<Rightarrow> ('a, 'v) instr list" where
"compile (Cex c) = [Const c]" |
"compile (Vex v) = [Load v]" |
"compile (Bex f e1 e2) = compile e2 @ compile e1 @ [Apply f]"

(*
Goal:
theorem "exec (compile e) s [] = [value e s]"
*)

(* First prove execution with concatenated lists *)
lemma exec_app[simp]: "\<forall>vs. exec (xs @ ys) s vs = exec ys s (exec xs s vs)"
apply (induct_tac xs)
apply simp
apply (simp split: instr.split)
done

(* Generalized goal: executing a compiled program results in the value of the program *)
theorem "\<forall>vs. exec (compile e) s vs = value e s # vs"
apply (induct_tac e)
apply simp_all
done


(* Title:      Axioms and Algorithmic Proofs
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>Axioms and Algorithmic Proofs\<close>

text \<open>
In this theory we verify the correctness of three basic graph algorithms.
We use them to constructively prove a number of graph properties.
\<close>

theory Algorithms

imports "HOL-Hoare.Hoare_Logic" Forests

begin

context stone_kleene_relation_algebra_arc
begin

text \<open>
Assuming the arc axiom we can define the function \<open>choose_arc\<close> that selects an arc in a non-empty graph.
\<close>

definition "choose_arc x \<equiv> if x = bot then bot else SOME y . arc y \<and> y \<le> --x"

lemma choose_arc_below:
  "choose_arc x \<le> --x"
proof (cases "x = bot")
  case True
  thus ?thesis
    using choose_arc_def by auto
next
  let ?P = "\<lambda>y . arc y \<and> y \<le> --x"
  case False
  have "?P (SOME y . ?P y)"
    apply (rule someI_ex)
    using someI_ex False arc_axiom by auto
  thus ?thesis
    using False choose_arc_def by auto
qed

lemma choose_arc_arc:
  assumes "x \<noteq> bot"
  shows "arc (choose_arc x)"
proof -
  let ?P = "\<lambda>y . arc y \<and> y \<le> --x"
  have "?P (SOME y . ?P y)"
    apply (rule someI_ex)
    using someI_ex assms arc_axiom by auto
  thus ?thesis
    using assms choose_arc_def by auto
qed

lemma choose_arc_bot:
  "choose_arc bot = bot"
  by (metis bot_unique choose_arc_below regular_closed_bot)

lemma choose_arc_bot_iff:
  "choose_arc x = bot \<longleftrightarrow> x = bot"
  using covector_bot_closed inf_bot_right choose_arc_arc vector_bot_closed choose_arc_bot by fastforce

lemma choose_arc_regular:
  "regular (choose_arc x)"
proof (cases "x = bot")
  assume "x = bot"
  thus ?thesis
    by (simp add: choose_arc_bot)
next
  assume "x \<noteq> bot"
  thus ?thesis
    by (simp add: arc_regular choose_arc_arc)
qed

subsection \<open>Constructing a spanning tree\<close>

definition "spanning_forest f g \<equiv> forest f \<and> f \<le> --g \<and> components g \<le> forest_components f \<and> regular f"
definition "kruskal_spanning_invariant f g h \<equiv> symmetric g \<and> h = h\<^sup>T \<and> g \<sqinter> --h = h \<and> spanning_forest f (-h \<sqinter> g)"

lemma spanning_forest_spanning:
  "spanning_forest f g \<Longrightarrow> spanning (--g) f"
  by (smt (z3) cancel_separate_1 order_trans star.circ_increasing spanning_forest_def)

lemma spanning_forest_spanning_regular:
  assumes "regular f"
      and "regular g"
  shows "spanning_forest f g \<longleftrightarrow> spanning g f"
  by (smt (z3) assms cancel_separate_1 components_increasing dual_order.trans forest_components_star star_isotone spanning_forest_def)

text \<open>
We prove total correctness of Kruskal's spanning tree algorithm (ignoring edge weights) \<^cite>\<open>"Kruskal1956"\<close>.
The algorithm and proof are adapted from the AFP theory \<open>Relational_Minimum_Spanning_Trees.Kruskal\<close> to work in Stone-Kleene relation algebras \<^cite>\<open>"Guttmann2017c" and "Guttmann2018c"\<close>.
\<close>

lemma kruskal_vc_1:
  assumes "symmetric g"
    shows "kruskal_spanning_invariant bot g g"
proof (unfold kruskal_spanning_invariant_def, intro conjI)
  show "symmetric g"
    using assms by simp
next
  show "g = g\<^sup>T"
    using assms by simp
next
  show "g \<sqinter> --g = g"
    using inf.sup_monoid.add_commute selection_closed_id by simp
next
  show "spanning_forest bot (-g \<sqinter> g)"
    using star.circ_transitive_equal spanning_forest_def by simp
qed

text \<open>
For the remainder of this theory we assume there are finitely many regular elements.
This means that the graphs are finite and is needed for proving termination of the algorithms.
\<close>

context
  assumes finite_regular: "finite { x . regular x }"
begin

lemma kruskal_vc_2:
  assumes "kruskal_spanning_invariant f g h"
      and "h \<noteq> bot"
    shows "(choose_arc h \<le> -forest_components f \<longrightarrow> kruskal_spanning_invariant ((f \<sqinter> -(top * choose_arc h * f\<^sup>T\<^sup>\<star>)) \<squnion> (f \<sqinter> top * choose_arc h * f\<^sup>T\<^sup>\<star>)\<^sup>T \<squnion> choose_arc h) g (h \<sqinter> -choose_arc h \<sqinter> -choose_arc h\<^sup>T)
                                               \<and> card { x . regular x \<and> x \<le> --h \<and> x \<le> -choose_arc h \<and> x \<le> -choose_arc h\<^sup>T } < card { x . regular x \<and> x \<le> --h }) \<and>
           (\<not> choose_arc h \<le> -forest_components f \<longrightarrow> kruskal_spanning_invariant f g (h \<sqinter> -choose_arc h \<sqinter> -choose_arc h\<^sup>T)
                                                 \<and> card { x . regular x \<and> x \<le> --h \<and> x \<le> -choose_arc h \<and> x \<le> -choose_arc h\<^sup>T } < card { x . regular x \<and> x \<le> --h })"
proof -
  let ?e = "choose_arc h"
  let ?f = "(f \<sqinter> -(top * ?e * f\<^sup>T\<^sup>\<star>)) \<squnion> (f \<sqinter> top * ?e * f\<^sup>T\<^sup>\<star>)\<^sup>T \<squnion> ?e"
  let ?h = "h \<sqinter> -?e \<sqinter> -?e\<^sup>T"
  let ?F = "forest_components f"
  let ?n1 = "card { x . regular x \<and> x \<le> --h }"
  let ?n2 = "card { x . regular x \<and> x \<le> --h \<and> x \<le> -?e \<and> x \<le> -?e\<^sup>T }"
  have 1: "regular f \<and> regular ?e"
    by (metis assms(1) kruskal_spanning_invariant_def spanning_forest_def choose_arc_regular)
  hence 2: "regular ?f \<and> regular ?F \<and> regular (?e\<^sup>T)"
    using regular_closed_star regular_conv_closed regular_mult_closed by simp
  have 3: "\<not> ?e \<le> -?e"
    using assms(2) inf.orderE choose_arc_bot_iff by fastforce
  have 4: "?n2 < ?n1"
    apply (rule psubset_card_mono)
    using finite_regular apply simp
    using 1 3 kruskal_spanning_invariant_def choose_arc_below by auto
  show "(?e \<le> -?F \<longrightarrow> kruskal_spanning_invariant ?f g ?h \<and> ?n2 < ?n1) \<and> (\<not> ?e \<le> -?F \<longrightarrow> kruskal_spanning_invariant f g ?h \<and> ?n2 < ?n1)"
  proof (rule conjI)
    have 5: "injective ?f"
      apply (rule kruskal_injective_inv)
      using assms(1) kruskal_spanning_invariant_def spanning_forest_def apply simp
      apply (simp add: covector_mult_closed)
      apply (simp add: comp_associative comp_isotone star.right_plus_below_circ)
      apply (meson mult_left_isotone order_lesseq_imp star_outer_increasing top.extremum)
      using assms(1,2) kruskal_spanning_invariant_def kruskal_injective_inv_2 choose_arc_arc spanning_forest_def apply simp
      using assms(2) arc_injective choose_arc_arc apply blast
      using assms(1,2) kruskal_spanning_invariant_def kruskal_injective_inv_3 choose_arc_arc spanning_forest_def by simp
    show "?e \<le> -?F \<longrightarrow> kruskal_spanning_invariant ?f g ?h \<and> ?n2 < ?n1"
    proof
      assume 6: "?e \<le> -?F"
      have 7: "equivalence ?F"
        using assms(1) kruskal_spanning_invariant_def forest_components_equivalence spanning_forest_def by simp
      have "?e\<^sup>T * top * ?e\<^sup>T = ?e\<^sup>T"
        using assms(2) by (simp add: arc_top_arc choose_arc_arc)
      hence "?e\<^sup>T * top * ?e\<^sup>T \<le> -?F"
        using 6 7 conv_complement conv_isotone by fastforce
      hence 8: "?e * ?F * ?e = bot"
        using le_bot triple_schroeder_p by simp
      show "kruskal_spanning_invariant ?f g ?h \<and> ?n2 < ?n1"
      proof (unfold kruskal_spanning_invariant_def, intro conjI)
        show "symmetric g"
          using assms(1) kruskal_spanning_invariant_def by simp
      next
        show "?h = ?h\<^sup>T"
          using assms(1) by (simp add: conv_complement conv_dist_inf inf_commute inf_left_commute kruskal_spanning_invariant_def)
      next
        show "g \<sqinter> --?h = ?h"
          using 1 2 by (metis assms(1) kruskal_spanning_invariant_def inf_assoc pp_dist_inf)
      next
        show "spanning_forest ?f (-?h \<sqinter> g)"
        proof (unfold spanning_forest_def, intro conjI)
          show "injective ?f"
            using 5 by simp
        next
          show "acyclic ?f"
            apply (rule kruskal_acyclic_inv)
            using assms(1) kruskal_spanning_invariant_def spanning_forest_def apply simp
            apply (simp add: covector_mult_closed)
            using 8 assms(1) kruskal_spanning_invariant_def spanning_forest_def kruskal_acyclic_inv_1 apply simp
            using 8 apply (metis comp_associative mult_left_sub_dist_sup_left star.circ_loop_fixpoint sup_commute le_bot)
            using 6 by (simp add: p_antitone_iff)
        next
          show "?f \<le> --(-?h \<sqinter> g)"
            apply (rule kruskal_subgraph_inv)
            using assms(1) kruskal_spanning_invariant_def spanning_forest_def apply simp
            using assms(1) apply (metis kruskal_spanning_invariant_def choose_arc_below order.trans pp_isotone_inf)
            using assms(1) kruskal_spanning_invariant_def apply simp
            using assms(1) kruskal_spanning_invariant_def by simp
        next
          show "components (-?h \<sqinter> g) \<le> forest_components ?f"
            apply (rule kruskal_spanning_inv)
            using 5 apply simp
            using 1 regular_closed_star regular_conv_closed regular_mult_closed apply simp
            using 1 apply simp
            using assms(1) kruskal_spanning_invariant_def spanning_forest_def by simp
        next
          show "regular ?f"
            using 2 by simp
        qed
      next
        show "?n2 < ?n1"
          using 4 by simp
      qed
    qed
  next
    show "\<not> ?e \<le> -?F \<longrightarrow> kruskal_spanning_invariant f g ?h \<and> ?n2 < ?n1"
    proof
      assume "\<not> ?e \<le> -?F"
      hence 9: "?e \<le> ?F"
        using 2 assms(2) arc_in_partition choose_arc_arc by fastforce
      show "kruskal_spanning_invariant f g ?h \<and> ?n2 < ?n1"
      proof (unfold kruskal_spanning_invariant_def, intro conjI)
        show "symmetric g"
          using assms(1) kruskal_spanning_invariant_def by simp
      next
        show "?h = ?h\<^sup>T"
          using assms(1) by (simp add: conv_complement conv_dist_inf inf_commute inf_left_commute kruskal_spanning_invariant_def)
      next
        show "g \<sqinter> --?h = ?h"
          using 1 2 by (metis assms(1) kruskal_spanning_invariant_def inf_assoc pp_dist_inf)
      next
        show "spanning_forest f (-?h \<sqinter> g)"
        proof (unfold spanning_forest_def, intro conjI)
          show "injective f"
            using assms(1) kruskal_spanning_invariant_def spanning_forest_def by simp
        next
          show "acyclic f"
            using assms(1) kruskal_spanning_invariant_def spanning_forest_def by simp
        next
          have "f \<le> --(-h \<sqinter> g)"
            using assms(1) kruskal_spanning_invariant_def spanning_forest_def by simp
          also have "... \<le> --(-?h \<sqinter> g)"
            using comp_inf.mult_right_isotone inf.sup_monoid.add_commute inf_left_commute p_antitone_inf pp_isotone by auto
          finally show "f \<le> --(-?h \<sqinter> g)"
            by simp
        next
          show "components (-?h \<sqinter> g) \<le> ?F"
            apply (rule kruskal_spanning_inv_1)
            using 9 apply simp
            using 1 apply simp
            using assms(1) kruskal_spanning_invariant_def spanning_forest_def apply simp
            using assms(1) kruskal_spanning_invariant_def forest_components_equivalence spanning_forest_def by simp
        next
          show "regular f"
            using 1 by simp
        qed
      next
        show "?n2 < ?n1"
          using 4 by simp
      qed
    qed
  qed
qed

theorem kruskal_spanning:
  "VARS e f h
  [ symmetric g ]
  f := bot;
  h := g;
  WHILE h \<noteq> bot
    INV { kruskal_spanning_invariant f g h }
    VAR { card { x . regular x \<and> x \<le> --h } }
     DO e := choose_arc h;
        IF e \<le> -forest_components f THEN
          f := (f \<sqinter> -(top * e * f\<^sup>T\<^sup>\<star>)) \<squnion> (f \<sqinter> top * e * f\<^sup>T\<^sup>\<star>)\<^sup>T \<squnion> e
        ELSE
          SKIP
        FI;
        h := h \<sqinter> -e \<sqinter> -e\<^sup>T
     OD
  [ spanning_forest f g ]"
  apply vcg_tc_simp
  using kruskal_vc_1 apply simp
  using kruskal_vc_2 apply simp
  using kruskal_spanning_invariant_def by auto

lemma kruskal_exists_spanning:
  "symmetric g \<Longrightarrow> \<exists>f . spanning_forest f g"
  using tc_extract_function kruskal_spanning by blast

text \<open>Theorem 16\<close>

lemma symmetric_spannable:
  "symmetric g \<Longrightarrow> spannable (--g)"
  using kruskal_exists_spanning spanning_forest_spanning spannable_def by blast

subsection \<open>Breadth-first search\<close>

text \<open>
We prove total correctness of a simple breadth-first search algorithm.
It is a variant of an algorithm discussed in \<^cite>\<open>"Berghammer1999"\<close>.
\<close>

theorem bfs_reachability:
  "VARS p q t
  [ regular r \<and> regular s \<and> vector s ]
  t := bot;
  q := s;
  p := -s \<sqinter> r\<^sup>T * s;
  WHILE p \<noteq> bot
    INV { regular r \<and> regular q \<and> vector q \<and> asymmetric t \<and> t \<le> r \<and> t \<le> q \<and> q = t\<^sup>T\<^sup>\<star> * s \<and> p = -q \<sqinter> r\<^sup>T * q }
    VAR { card { x . regular x \<and> x \<le> --(-q \<sqinter> r\<^sup>T\<^sup>\<star> * s) } }
     DO t := t \<squnion> (r \<sqinter> q * p\<^sup>T);
        q := q \<squnion> p;
        p := -q \<sqinter> r\<^sup>T * p
     OD
  [ asymmetric t \<and> t \<le> r \<and> q = t\<^sup>T\<^sup>\<star> * s \<and> q = r\<^sup>T\<^sup>\<star> * s ]"
proof vcg_tc
  fix p q t
  assume "regular r \<and> regular s \<and> vector s"
  thus "regular r \<and> regular s \<and> vector s \<and> asymmetric bot \<and> bot \<le> r \<and> bot \<le> s \<and> s = bot\<^sup>T\<^sup>\<star> * s \<and> -s \<sqinter> r\<^sup>T * s = -s \<sqinter> r\<^sup>T * s"
    by (simp add: star.circ_zero)
next
  fix p q t
  assume 1: "(regular r \<and> regular q \<and> vector q \<and> asymmetric t \<and> t \<le> r \<and> t \<le> q \<and> q = t\<^sup>T\<^sup>\<star> * s \<and> p = -q \<sqinter> r\<^sup>T * q) \<and> \<not> p \<noteq> bot"
  have "q = r\<^sup>T\<^sup>\<star> * s"
    apply (rule order.antisym)
    using 1 conv_order mult_left_isotone star_isotone apply simp
    using 1 by (metis inf.sup_monoid.add_commute mult_1_left mult_left_isotone mult_right_isotone order_lesseq_imp pseudo_complement star.circ_reflexive star_left_induct_mult)
  thus "asymmetric t \<and> t \<le> r \<and> q = t\<^sup>T\<^sup>\<star> * s \<and> q = r\<^sup>T\<^sup>\<star> * s"
    using 1 by simp
next
  fix n p q t
  assume 2: "((regular r \<and> regular q \<and> vector q \<and> asymmetric t \<and> t \<le> r \<and> t \<le> q \<and> q = t\<^sup>T\<^sup>\<star> * s \<and> p = -q \<sqinter> r\<^sup>T * q) \<and> p \<noteq> bot) \<and> card { x . regular x \<and> x \<le> --(-q \<sqinter> r\<^sup>T\<^sup>\<star> * s) } = n"
  hence 3: "vector p"
    using vector_complement_closed vector_inf_closed vector_mult_closed by blast
  show "(-(q \<squnion> p) \<sqinter> r\<^sup>T * p, q \<squnion> p, t \<squnion> (r \<sqinter> q * p\<^sup>T))
        \<in> { trip . (case trip of (p, q, t) \<Rightarrow> regular r \<and> regular q \<and> vector q \<and> asymmetric t \<and> t \<le> r \<and> t \<le> q \<and> q = t\<^sup>T\<^sup>\<star> * s \<and> p = -q \<sqinter> r\<^sup>T * q) \<and>
                   (case trip of (p, q, t) \<Rightarrow> card { x . regular x \<and> x \<le> --(-q \<sqinter> r\<^sup>T\<^sup>\<star> * s) }) < n }"
    apply (rule CollectI, rule conjI)
    subgoal proof (intro case_prodI, intro conjI)
      show "regular r"
        using 2 by blast
      show "regular (q \<squnion> p)"
        using 2 regular_conv_closed regular_mult_closed by force
      show "vector (q \<squnion> p)"
        using 2 vector_complement_closed vector_inf_closed vector_mult_closed vector_sup_closed by force
      show "asymmetric (t \<squnion> (r \<sqinter> q * p\<^sup>T))"
      proof -
        have "t \<sqinter> (r \<sqinter> q * p\<^sup>T)\<^sup>T \<le> t \<sqinter> p * q\<^sup>T"
          by (metis comp_inf.mult_right_isotone conv_dist_comp conv_involutive conv_order inf.cobounded2)
        also have "... \<le> t \<sqinter> p"
          using 3 by (metis comp_inf.mult_right_isotone comp_inf.star.circ_sup_sub_sup_one_1 inf.boundedE le_sup_iff mult_right_isotone)
        finally have 4: "t \<sqinter> (r \<sqinter> q * p\<^sup>T)\<^sup>T = bot"
          using 2 by (metis order.antisym bot_least inf.sup_monoid.add_assoc pseudo_complement)
        hence 5: "r \<sqinter> q * p\<^sup>T \<sqinter> t\<^sup>T = bot"
          using conv_inf_bot_iff inf_commute by force
        have "r \<sqinter> q * p\<^sup>T \<sqinter> (r \<sqinter> q * p\<^sup>T)\<^sup>T \<le> q * p\<^sup>T \<sqinter> p * q\<^sup>T"
          by (metis comp_inf.comp_isotone conv_dist_comp conv_involutive conv_order inf.cobounded2)
        also have "... \<le> q \<sqinter> p"
          using 2 3 by (metis comp_inf.comp_isotone inf.cobounded1 vector_covector)
        finally have 6: "r \<sqinter> q * p\<^sup>T \<sqinter> (r \<sqinter> q * p\<^sup>T)\<^sup>T = bot"
          using 2 by (metis inf.cobounded1 inf.sup_monoid.add_commute le_bot pseudo_complement)
        have "(t \<squnion> (r \<sqinter> q * p\<^sup>T)) \<sqinter> (t \<squnion> (r \<sqinter> q * p\<^sup>T))\<^sup>T = (t \<sqinter> t\<^sup>T) \<squnion> (t \<sqinter> (r \<sqinter> q * p\<^sup>T)\<^sup>T) \<squnion> (r \<sqinter> q * p\<^sup>T \<sqinter> t\<^sup>T) \<squnion> (r \<sqinter> q * p\<^sup>T \<sqinter> (r \<sqinter> q * p\<^sup>T)\<^sup>T)"
          by (simp add: sup.commute sup.left_commute conv_dist_sup inf_sup_distrib1 inf_sup_distrib2)
        also have "... = bot"
          using 2 4 5 6 by auto
        finally show ?thesis
          .
      qed
      show "t \<squnion> (r \<sqinter> q * p\<^sup>T) \<le> r"
        using 2 by (meson inf.cobounded1 le_supI)
      show "t \<squnion> (r \<sqinter> q * p\<^sup>T) \<le> q \<squnion> p"
        using 2 by (metis comp_inf.star.circ_sup_sub_sup_one_1 inf.absorb2 inf.coboundedI2 inf.sup_monoid.add_commute le_sup_iff mult_right_isotone sup_left_divisibility)
      show "q \<squnion> p = (t \<squnion> (r \<sqinter> q * p\<^sup>T))\<^sup>T\<^sup>\<star> * s"
      proof (rule order.antisym)
        have 7: "q \<le> (t \<squnion> (r \<sqinter> q * p\<^sup>T))\<^sup>T\<^sup>\<star> * s"
          using 2 by (metis conv_order mult_left_isotone star_isotone sup_left_divisibility)
        have "-q \<sqinter> (r \<sqinter> q * p\<^sup>T)\<^sup>T * q \<le> (t \<squnion> (r \<sqinter> q * p\<^sup>T))\<^sup>T * t\<^sup>T\<^sup>\<star> * s"
          using 2 comp_associative conv_dist_sup inf.coboundedI2 mult_right_sub_dist_sup_right by auto
        also have "... \<le> (t \<squnion> (r \<sqinter> q * p\<^sup>T))\<^sup>T\<^sup>\<star> * s"
          by (simp add: conv_dist_sup mult_left_isotone star.circ_increasing star.circ_mult_upper_bound star.circ_sub_dist)
        finally have 8: "-q \<sqinter> (r \<sqinter> q * p\<^sup>T)\<^sup>T * q \<le> (t \<squnion> (r \<sqinter> q * p\<^sup>T))\<^sup>T\<^sup>\<star> * s"
          .
        have 9: "(r \<sqinter> -q)\<^sup>T * q = bot"
          using 2 by (metis conv_dist_inf covector_inf_comp_3 pp_inf_p semiring.mult_not_zero vector_complement_closed)
        have "-q \<sqinter> (r \<sqinter> -(q * p\<^sup>T))\<^sup>T * q = -q \<sqinter> (r \<sqinter> (-q \<squnion> -p\<^sup>T))\<^sup>T * q"
          using 2 3 by (metis p_dist_inf vector_covector)
        also have "... = (-q \<sqinter> (r \<sqinter> -q)\<^sup>T * q) \<squnion> (-q \<sqinter> (r \<sqinter> -p\<^sup>T)\<^sup>T * q)"
          by (simp add: conv_dist_sup inf_sup_distrib1 mult_right_dist_sup)
        also have "... = -q \<sqinter> (r \<sqinter> -p\<^sup>T)\<^sup>T * q"
          using 9 by simp
        also have "... = -q \<sqinter> -p \<sqinter> r\<^sup>T * q"
          using 3 by (metis conv_complement conv_dist_inf conv_involutive inf.sup_monoid.add_assoc inf_vector_comp vector_complement_closed)
        finally have 10: "-q \<sqinter> (r \<sqinter> -(q * p\<^sup>T))\<^sup>T * q = bot"
          using 2 inf_import_p pseudo_complement by auto
        have "r = (r \<sqinter> q * p\<^sup>T) \<squnion> (r \<sqinter> -(q * p\<^sup>T))"
          using 2 by (smt (z3) maddux_3_11_pp pp_dist_comp regular_closed_inf regular_conv_closed)
        hence "p = -q \<sqinter> ((r \<sqinter> q * p\<^sup>T) \<squnion> (r \<sqinter> -(q * p\<^sup>T)))\<^sup>T * q"
          using 2 by auto
        also have "... = (-q \<sqinter> (r \<sqinter> q * p\<^sup>T)\<^sup>T * q) \<squnion> (-q \<sqinter> (r \<sqinter> -(q * p\<^sup>T))\<^sup>T * q)"
          by (simp add: conv_dist_sup inf_sup_distrib1 semiring.distrib_right)
        also have "... \<le> (t \<squnion> (r \<sqinter> q * p\<^sup>T))\<^sup>T\<^sup>\<star> * s"
          using 8 10 le_sup_iff bot_least by blast
        finally show "q \<squnion> p \<le> (t \<squnion> (r \<sqinter> q * p\<^sup>T))\<^sup>T\<^sup>\<star> * s"
          using 7 by simp
        have 11: "t\<^sup>T * q \<le> r\<^sup>T * q"
          using 2 conv_order mult_left_isotone by auto
        have "t\<^sup>T * p \<le> t\<^sup>T * top"
          by (simp add: mult_right_isotone)
        also have "... = t\<^sup>T * q \<squnion> t\<^sup>T * -q"
          using 2 regular_complement_top semiring.distrib_left by force
        also have "... = t\<^sup>T * q"
        proof -
          have "t\<^sup>T * -q = bot"
            using 2 by (metis bot_least conv_complement_sub conv_dist_comp conv_involutive mult_right_isotone regular_closed_bot stone sup.absorb2 sup_commute)
          thus ?thesis
            by simp
        qed
        finally have 12: "t\<^sup>T * p \<le> r\<^sup>T * q"
          using 11 order.trans by blast
        have 13: "(r \<sqinter> q * p\<^sup>T)\<^sup>T * q \<le> r\<^sup>T * q"
          by (simp add: conv_dist_inf mult_left_isotone)
        have "(r \<sqinter> q * p\<^sup>T)\<^sup>T * p \<le> p"
          using 3 by (metis conv_dist_comp conv_dist_inf conv_involutive inf.coboundedI2 mult_isotone mult_right_isotone top.extremum)
        hence 14: "(r \<sqinter> q * p\<^sup>T)\<^sup>T * p \<le> r\<^sup>T * q"
          using 2 le_infE by blast
        have "(t \<squnion> (r \<sqinter> q * p\<^sup>T))\<^sup>T * (q \<squnion> p) = t\<^sup>T * q \<squnion> t\<^sup>T * p \<squnion> (r \<sqinter> q * p\<^sup>T)\<^sup>T * q \<squnion> (r \<sqinter> q * p\<^sup>T)\<^sup>T * p"
          by (metis conv_dist_sup semiring.distrib_left semiring.distrib_right sup_assoc)
        also have "... \<le> r\<^sup>T * q"
          using 11 12 13 14 by simp
        finally have "(t \<squnion> (r \<sqinter> q * p\<^sup>T))\<^sup>T * (q \<squnion> p) \<le> q \<squnion> p"
          using 2 by (metis maddux_3_21_pp sup.boundedE sup_right_divisibility)
        thus "(t \<squnion> (r \<sqinter> q * p\<^sup>T))\<^sup>T\<^sup>\<star> * s \<le> q \<squnion> p"
          using 2 by (smt (verit, ccfv_SIG) star.circ_loop_fixpoint star_left_induct sup.bounded_iff sup_left_divisibility)
      qed
      show "-(q \<squnion> p) \<sqinter> r\<^sup>T * p = -(q \<squnion> p) \<sqinter> r\<^sup>T * (q \<squnion> p)"
      proof (rule order.antisym)
        show "-(q \<squnion> p) \<sqinter> r\<^sup>T * p \<le> -(q \<squnion> p) \<sqinter> r\<^sup>T * (q \<squnion> p)"
          using inf.sup_right_isotone mult_left_sub_dist_sup_right by blast
        have 15: "- (q \<squnion> p) \<sqinter> r\<^sup>T * (q \<squnion> p) = - (q \<squnion> p) \<sqinter> r\<^sup>T * q \<squnion> - (q \<squnion> p) \<sqinter> r\<^sup>T * p"
          by (simp add: comp_inf.semiring.distrib_left mult_left_dist_sup)
        have "- (q \<squnion> p) \<sqinter> r\<^sup>T * q \<le> - (q \<squnion> p) \<sqinter> r\<^sup>T * p"
          using 2 by (metis bot_least p_dist_inf p_dist_sup p_inf_sup_below pseudo_complement)
        thus "- (q \<squnion> p) \<sqinter> r\<^sup>T * (q \<squnion> p) \<le> - (q \<squnion> p) \<sqinter> r\<^sup>T * p"
          using 15 sup.absorb2 by force
      qed
    qed
    subgoal proof clarsimp
      have "card { x . regular x \<and> x \<le> -q \<and> x \<le> -p \<and> x \<le> --(r\<^sup>T\<^sup>\<star> * s) } < card { x . regular x \<and> x \<le> --(-q \<sqinter> r\<^sup>T\<^sup>\<star> * s) }"
      proof (rule psubset_card_mono)
        show "finite { x . regular x \<and> x \<le> --(-q \<sqinter> r\<^sup>T\<^sup>\<star> * s) }"
          using finite_regular by simp
        show "{ x . regular x \<and> x \<le> -q \<and> x \<le> -p \<and> x \<le> --(r\<^sup>T\<^sup>\<star> * s) } \<subset> { x . regular x \<and> x \<le> --(-q \<sqinter> r\<^sup>T\<^sup>\<star> * s) }"
        proof -
          have "\<forall>x . x \<le> -q \<and> x \<le> --(r\<^sup>T\<^sup>\<star> * s) \<longrightarrow> x \<le> --(-q \<sqinter> r\<^sup>T\<^sup>\<star> * s)"
            by auto
          hence 16: "{ x . regular x \<and> x \<le> -q \<and> x \<le> -p \<and> x \<le> --(r\<^sup>T\<^sup>\<star> * s) } \<subseteq> { x . regular x \<and> x \<le> --(-q \<sqinter> r\<^sup>T\<^sup>\<star> * s) }"
            by blast
          have 17: "regular p"
            using 2 regular_conv_closed regular_mult_closed by force
          hence 18: "\<not> p \<le> -p"
            using 2 by (metis inf.absorb1 pp_inf_p)
          have 19: "p \<le> -q"
            using 2 by simp
          have "r\<^sup>T * q \<le> r\<^sup>T\<^sup>\<star> * s"
            using 2 by (metis (no_types, lifting) comp_associative conv_dist_sup mult_left_isotone star.circ_increasing star.circ_mult_upper_bound star.circ_sub_dist sup_left_divisibility)
          hence 20: "p \<le> --(r\<^sup>T\<^sup>\<star> * s)"
            using 2 le_infI2 order_lesseq_imp pp_increasing by blast
          hence 21: "p \<le> --(-q \<sqinter> r\<^sup>T\<^sup>\<star> * s)"
            using 2 by simp
          show ?thesis
            using 16 17 18 19 20 21 by blast
        qed
      qed
      thus "card { x . regular x \<and> x \<le> -q \<and> x \<le> -p \<and> x \<le> --(r\<^sup>T\<^sup>\<star> * s) } < n"
        using 2 by auto
    qed
    done
qed

text \<open>Theorem 18\<close>

lemma bfs_reachability_exists:
  "regular r \<and> regular s \<and> vector s \<Longrightarrow> \<exists>t . asymmetric t \<and> t \<le> r \<and> t\<^sup>T\<^sup>\<star> * s = r\<^sup>T\<^sup>\<star> * s"
  using tc_extract_function bfs_reachability by blast

text \<open>Theorem 17\<close>

lemma orientable_path:
  "arc x \<Longrightarrow> x \<le> --y\<^sup>\<star> \<Longrightarrow> \<exists>z . z \<le> y \<and> asymmetric z \<and> x \<le> --z\<^sup>\<star>"
proof -
  assume 1: "arc x" and 2: "x \<le> --y\<^sup>\<star>"
  hence "regular (--y) \<and> regular (x * top) \<and> vector (x * top)"
    using bijective_regular mult_assoc by auto
  from this obtain t where 3: "asymmetric t \<and> t \<le> --y \<and> t\<^sup>T\<^sup>\<star> * (x * top) = (--y)\<^sup>T\<^sup>\<star> * (x * top)"
    using bfs_reachability_exists by blast
  let ?z = "t \<sqinter> y"
  have "x\<^sup>T * top * x\<^sup>T \<le> (--y)\<^sup>T\<^sup>\<star>"
    using 1 2 by (metis arc_top_arc conv_complement conv_isotone conv_star_commute arc_conv_closed pp_dist_star)
  hence "x\<^sup>T \<le> (--y)\<^sup>T\<^sup>\<star> * x * top"
    using 1 comp_associative conv_dist_comp shunt_bijective by force
  also have "... = t\<^sup>T\<^sup>\<star> * x * top"
    using 3 mult_assoc by force
  finally have "x\<^sup>T * top * x\<^sup>T \<le> t\<^sup>T\<^sup>\<star>"
    using 1 comp_associative conv_dist_comp shunt_bijective by force
  hence "x\<^sup>T \<le> t\<^sup>T\<^sup>\<star>"
    using 1 by (metis arc_top_arc arc_conv_closed)
  also have "... \<le> (--?z)\<^sup>T\<^sup>\<star>"
    using 3 by (metis conv_order inf.orderE inf_pp_semi_commute star_isotone)
  finally have "x \<le> --?z\<^sup>\<star>"
    using conv_order conv_star_commute pp_dist_star by fastforce
  thus "\<exists>z . z \<le> y \<and> asymmetric z \<and> x \<le> --z\<^sup>\<star>"
    using 3 asymmetric_inf_closed inf.cobounded2 by blast
qed

subsection \<open>Extending partial orders to linear orders\<close>

text \<open>
We prove total correctness of Szpilrajn's algorithm \<^cite>\<open>"Szpilrajn1930"\<close>.
A partial-correctness proof using Prover9 is given in \<^cite>\<open>"BerghammerStruth2010"\<close>.
\<close>

theorem szpilrajn:
  "VARS e t
  [ order p \<and> regular p ]
  t := p;
  WHILE t \<squnion> t\<^sup>T \<noteq> top
    INV { order t \<and> regular t \<and> p \<le> t }
    VAR { card { x . regular x \<and> x \<le> -(t \<squnion> t\<^sup>T) } }
     DO e := choose_arc (-(t \<squnion> t\<^sup>T));
        t := t \<squnion> t * e * t
     OD
  [ linear_order t \<and> p \<le> t ]"
proof vcg_tc_simp
  fix t
  let ?e = "choose_arc (-t \<sqinter> -t\<^sup>T)"
  let ?tet = "t * ?e * t"
  let ?t = "t \<squnion> ?tet"
  let ?s1 = "{ x . regular x \<and> x \<le> -t \<and> x \<le> -?tet \<and> x \<le> -?t\<^sup>T }"
  let ?s2 = "{ x . regular x \<and> x \<le> -t \<and> x \<le> -t\<^sup>T }"
  assume 1: "reflexive t \<and> transitive t \<and> antisymmetric t \<and> regular t \<and> p \<le> t \<and> \<not> linear t"
  show "reflexive ?t \<and>
        transitive ?t \<and>
        antisymmetric ?t \<and>
        ?t = t \<squnion> --?tet \<and>
        p \<le> ?t \<and>
        card ?s1 < card ?s2"
  proof (intro conjI)
    show "reflexive ?t"
      using 1 by (simp add: sup.coboundedI1)
    have "-t \<sqinter> -t\<^sup>T \<noteq> bot"
      using 1 regular_closed_top regular_conv_closed by force
    hence 2: "arc ?e"
      using choose_arc_arc by blast
    have "?t * ?t = t * t \<squnion> t * ?tet \<squnion> ?tet * t \<squnion> ?tet * ?tet"
      by (smt (z3) mult_left_dist_sup mult_right_dist_sup sup_assoc)
    also have "... \<le> ?t"
    proof (intro sup_least)
      show "t * t \<le> ?t"
        using 1 sup.coboundedI1 by blast
      show "t * ?tet \<le> ?t"
        using 1 by (metis le_supI2 mult_left_isotone mult_assoc)
      show "?tet * t \<le> ?t"
        using 1 mult_right_isotone sup.coboundedI2 mult_assoc by auto
      have "?e * t * t * ?e \<le> ?e"
        using 2 by (smt arc_top_arc mult_assoc mult_right_isotone mult_left_isotone top_greatest)
      hence "transitive ?tet"
        by (smt mult_assoc mult_right_isotone mult_left_isotone)
      thus "?tet * ?tet \<le> ?t"
        using le_supI2 by auto
    qed
    finally show "transitive ?t"
      .
    have 3: "?e \<le> -t\<^sup>T"
      by (metis choose_arc_below inf.cobounded2 order_lesseq_imp p_dist_sup regular_closed_p)
    have 4: "?e \<le> -t"
      by (metis choose_arc_below inf.cobounded1 order_trans regular_closed_inf regular_closed_p)
    have "?t \<sqinter> ?t\<^sup>T = (t \<sqinter> t\<^sup>T) \<squnion> (t \<sqinter> ?tet\<^sup>T) \<squnion> (?tet \<sqinter> t\<^sup>T) \<squnion> (?tet \<sqinter> ?tet\<^sup>T)"
      by (smt (z3) conv_dist_sup inf_sup_distrib1 inf_sup_distrib2 sup_monoid.add_assoc)
    also have "... \<le> 1"
    proof (intro sup_least)
      show "antisymmetric t"
        using 1 by simp
      have "t * t * t = t"
        using 1 preorder_idempotent by fastforce
      also have "... \<le> -?e\<^sup>T"
        using 3 by (metis p_antitone_iff conv_complement conv_order conv_involutive)
      finally have "t\<^sup>T * ?e\<^sup>T * t\<^sup>T \<le> -t"
        using triple_schroeder_p by blast
      hence "t \<sqinter> ?tet\<^sup>T = bot"
        by (simp add: comp_associative conv_dist_comp p_antitone pseudo_complement_pp)
      thus "t \<sqinter> ?tet\<^sup>T \<le> 1"
        by simp
      thus "?tet \<sqinter> t\<^sup>T \<le> 1"
        by (smt conv_isotone inf_commute conv_one conv_dist_inf conv_involutive)
      have "?e * t * ?e \<le> ?e"
        using 2 by (smt arc_top_arc mult_assoc mult_right_isotone mult_left_isotone top_greatest)
      also have "... \<le> -t\<^sup>T"
        using 3 by simp
      finally have "?tet \<le> -?e\<^sup>T"
        by (metis conv_dist_comp schroeder_3_p triple_schroeder_p)
      hence "t * t * ?e * t * t \<le> -?e\<^sup>T"
        using 1 by (metis preorder_idempotent mult_assoc)
      hence "t\<^sup>T * ?e\<^sup>T * t\<^sup>T \<le> -?tet"
        using triple_schroeder_p mult_assoc by auto
      hence "?tet \<sqinter> ?tet\<^sup>T = bot"
        by (simp add: conv_dist_comp p_antitone pseudo_complement_pp mult_assoc)
      thus "antisymmetric ?tet"
        by simp
    qed
    finally show "antisymmetric ?t"
      .
    show "?t = t \<squnion> --?tet"
      using 1 choose_arc_regular regular_mult_closed by auto
    show "p \<le> ?t"
      using 1 by (simp add: le_supI1)
    show "card ?s1 < card ?s2"
    proof (rule psubset_card_mono)
      show "finite { x . regular x \<and> x \<le> -t \<and> x \<le> -t\<^sup>T }"
        using finite_regular by simp
      show "{ x . regular x \<and> x \<le> -t \<and> x \<le> -?tet \<and> x \<le> -?t\<^sup>T } \<subset> { x . regular x \<and> x \<le> -t \<and> x \<le> -t\<^sup>T }"
      proof -
        have "\<forall>x . regular x \<and> x \<le> -t \<and> x \<le> -?tet \<and> x \<le> -?t\<^sup>T \<longrightarrow> regular x \<and> x \<le> -t \<and> x \<le> -t\<^sup>T"
          using conv_dist_sup by auto
        hence 5: "{ x . regular x \<and> x \<le> -t \<and> x \<le> -?tet \<and> x \<le> -?t\<^sup>T } \<subseteq> { x . regular x \<and> x \<le> -t \<and> x \<le> -t\<^sup>T }"
          by blast
        have 6: "regular ?e \<and> ?e \<le> -t \<and> ?e \<le> -t\<^sup>T"
          using 2 3 4 choose_arc_regular by blast
        have "\<not> ?e \<le> -?tet"
        proof
          assume 7: "?e \<le> -?tet"
          have "?e \<le> ?e * t"
            using 1 by (meson mult_right_isotone mult_sub_right_one order.trans)
          also have "?e * t \<le> -(t\<^sup>T * ?e)"
            using 7 p_antitone_iff schroeder_3_p mult_assoc by auto
          also have "... \<le> -(1\<^sup>T * ?e)"
            using 1 conv_isotone mult_left_isotone p_antitone by blast
          also have "... = -?e"
            by simp
          finally show False
            using 1 2 by (smt (z3) bot_least eq_refl inf.absorb1 pseudo_complement semiring.mult_not_zero top_le)
        qed
        thus ?thesis
          using 5 6 by blast
      qed
    qed
  qed
qed

text \<open>Theorem 15\<close>

lemma szpilrajn_exists:
  "order p \<and> regular p \<Longrightarrow> \<exists>t . linear_order t \<and> p \<le> t"
  using tc_extract_function szpilrajn by blast

lemma complement_one_transitively_orientable:
  "transitively_orientable (-1)"
proof -
  have "\<exists>t . linear_order t"
    using szpilrajn_exists bijective_one_closed bijective_regular order_one_closed by blast
  thus ?thesis
    using exists_split_characterisations(4) by blast
qed

end

end

end