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

theory System_A 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)
  | Dis form form (infixr \<open>\<^bold>\<or>\<close> 30)
  | Con form form (infixr \<open>\<^bold>\<and>\<close> 35)

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>
| \<open>(I \<Turnstile> (p \<^bold>\<or> q)) = ((I \<Turnstile> p) \<or> (I \<Turnstile> q))\<close>
| \<open>(I \<Turnstile> (p \<^bold>\<and> q)) = ((I \<Turnstile> p) \<and> (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>
| DisE: \<open>\<turnstile> ((p \<^bold>\<longrightarrow> r) \<^bold>\<longrightarrow> (q \<^bold>\<longrightarrow> r) \<^bold>\<longrightarrow> p \<^bold>\<or> q \<^bold>\<longrightarrow> r)\<close>
| DisI1: \<open>\<turnstile> (p \<^bold>\<longrightarrow> p \<^bold>\<or> q)\<close>
| DisI2: \<open>\<turnstile> (q \<^bold>\<longrightarrow> p \<^bold>\<or> q)\<close>
| ConE1: \<open>\<turnstile> (p \<^bold>\<and> q \<^bold>\<longrightarrow> p)\<close>
| ConE2: \<open>\<turnstile> (p \<^bold>\<and> q \<^bold>\<longrightarrow> q)\<close>
| ConI: \<open>\<turnstile> (p \<^bold>\<longrightarrow> q \<^bold>\<longrightarrow> p \<^bold>\<and> q)\<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> and
    DisP: \<open>(p \<^bold>\<or> q) \<in> H \<Longrightarrow> p \<in> H \<or> q \<in> H\<close> and
    DisN: \<open>(\<^bold>\<not> (p \<^bold>\<or> q)) \<in> H \<Longrightarrow> (\<^bold>\<not> p) \<in> H \<and> (\<^bold>\<not> q) \<in> H\<close> and
    ConP: \<open>(p \<^bold>\<and> q) \<in> H \<Longrightarrow> p \<in> H \<and> q \<in> H\<close> and
    ConN: \<open>(\<^bold>\<not> (p \<^bold>\<and> q)) \<in> H \<Longrightarrow> (\<^bold>\<not> p) \<in> H \<or> (\<^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
next
  fix p q
  assume *: \<open>(p \<^bold>\<or> q) \<in> S\<close>
  show \<open>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 - {q}\<close>
      using assms inconsistent_head by blast

    assume \<open>p \<notin> S\<close>
    then obtain Sp' where Sp': \<open>\<turnstile> imply (p # Sp') \<^bold>\<bottom>\<close> \<open>set Sp' \<subseteq> S - {p}\<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 (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 (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>
        by (metis Sq'(1) deduct imply_weaken)
    qed
    then have \<open>\<turnstile> imply ((p \<^bold>\<or> q) # S') \<^bold>\<bottom>\<close>
      by (metis Axiomatics.simps imply.simps(2))
    moreover have \<open>set ((p \<^bold>\<or> q) # S') \<subseteq> S\<close>
      using * 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>\<or> q)) \<in> S\<close>
  show \<open>(\<^bold>\<not> p) \<in> S \<and> (\<^bold>\<not> q) \<in> S\<close>
  proof (rule conjI; rule ccontr)
    assume \<open>(\<^bold>\<not> p) \<notin> S\<close>
    then obtain S' where S': \<open>\<turnstile> imply ((\<^bold>\<not> p) # S') \<^bold>\<bottom>\<close> \<open>set S' \<subseteq> S - {\<^bold>\<not> p}\<close>
      using assms inconsistent_head by blast
    moreover have \<open>\<turnstile> imply ((\<^bold>\<not> (p \<^bold>\<or> q)) # S') (\<^bold>\<not> p)\<close>
      using DisI1 Imp4 add_imply deduct MP by blast
    ultimately have \<open>\<turnstile> imply ((\<^bold>\<not> (p \<^bold>\<or> q)) # S') \<^bold>\<bottom>\<close>
      using cut' by blast
    moreover have \<open>set ((\<^bold>\<not> (p \<^bold>\<or> q)) # S') \<subseteq> S\<close>
      using * S'(2) by auto
    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 - {\<^bold>\<not> q}\<close>
      using assms inconsistent_head by blast
    moreover have \<open>\<turnstile> imply ((\<^bold>\<not> (p \<^bold>\<or> q)) # S') (\<^bold>\<not> q)\<close>
      using DisI2 Imp4 add_imply deduct MP by blast
    ultimately have \<open>\<turnstile> imply ((\<^bold>\<not> (p \<^bold>\<or> q)) # S') \<^bold>\<bottom>\<close>
      using cut' by blast
    moreover have \<open>set ((\<^bold>\<not> (p \<^bold>\<or> q)) # S') \<subseteq> S\<close>
      using *(1) S'(2) by auto
    ultimately show False
      using assms unfolding consistent_def by blast
  qed
next
  fix p q
  assume *: \<open>(p \<^bold>\<and> q) \<in> S\<close>
  show \<open>p \<in> S \<and> 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 - {p}\<close>
      using assms inconsistent_head by blast
    moreover have \<open>\<turnstile> imply ((p \<^bold>\<and> q) # S') p\<close>
      using ConE1 add_imply deduct by blast
    ultimately have \<open>\<turnstile> imply ((p \<^bold>\<and> q) # S') \<^bold>\<bottom>\<close>
      using cut' by blast
    moreover have \<open>set ((p \<^bold>\<and> q) # S') \<subseteq> S\<close>
      using *(1) S'(2) by auto
    ultimately show False
      using assms unfolding consistent_def by blast
  next
    assume \<open>q \<notin> S\<close>
    then obtain S' where S': \<open>\<turnstile> imply (q # S') \<^bold>\<bottom>\<close> \<open>set S' \<subseteq> S - {q}\<close>
      using assms inconsistent_head by blast
    moreover have \<open>\<turnstile> imply ((p \<^bold>\<and> q) # S') q\<close>
      using ConE2 add_imply deduct by blast
    ultimately have \<open>\<turnstile> imply ((p \<^bold>\<and> q) # S') \<^bold>\<bottom>\<close>
      using cut' by blast
    moreover have \<open>set ((p \<^bold>\<and> q) # S') \<subseteq> S\<close>
      using *(1) S'(2) S'(2) by auto
    ultimately show False
      using assms unfolding consistent_def by blast
  qed
next
  fix p q
  assume *: \<open>(\<^bold>\<not> (p \<^bold>\<and> q)) \<in> S\<close>
  show \<open>(\<^bold>\<not> p) \<in> S \<or> (\<^bold>\<not> q) \<in> S\<close>
  proof (rule disjCI, rule ccontr)
    assume \<open>(\<^bold>\<not> q) \<notin> S\<close>
    then obtain Sq' where Sq': \<open>\<turnstile> imply ((\<^bold>\<not> q) # Sq') \<^bold>\<bottom>\<close> \<open>set Sq' \<subseteq> S - {\<^bold>\<not> q}\<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 - {\<^bold>\<not> p}\<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 ((\<^bold>\<not> 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 ((\<^bold>\<not> q) # S') \<^bold>\<bottom>\<close>
        by (metis Sq'(1) deduct imply_weaken)
    qed
    then have \<open>\<turnstile> imply ((\<^bold>\<not> (p \<^bold>\<and> q)) # S') \<^bold>\<bottom>\<close>
      by (metis ConI Boole add_imply imply_Cons imply_head imply_mp')
    moreover have \<open>set ((\<^bold>\<not> (p \<^bold>\<and> 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
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


(*  Title:      HOL/Induct/ABexp.thy
    Author:     Stefan Berghofer, TU Muenchen
*)

section \<open>Arithmetic and boolean expressions\<close>

theory ABexp
imports MainRLT
begin

datatype 'a aexp =
    IF "'a bexp"  "'a aexp"  "'a aexp"
  | Sum "'a aexp"  "'a aexp"
  | Diff "'a aexp"  "'a aexp"
  | Var 'a
  | Num nat
and 'a bexp =
    Less "'a aexp"  "'a aexp"
  | And "'a bexp"  "'a bexp"
  | Neg "'a bexp"

text \<open>\medskip Evaluation of arithmetic and boolean expressions\<close>

primrec evala :: "('a \<Rightarrow> nat) \<Rightarrow> 'a aexp \<Rightarrow> nat"
  and evalb :: "('a \<Rightarrow> nat) \<Rightarrow> 'a bexp \<Rightarrow> bool"
where
  "evala env (IF b a1 a2) = (if evalb env b then evala env a1 else evala env a2)"
| "evala env (Sum a1 a2) = evala env a1 + evala env a2"
| "evala env (Diff a1 a2) = evala env a1 - evala env a2"
| "evala env (Var v) = env v"
| "evala env (Num n) = n"

| "evalb env (Less a1 a2) = (evala env a1 < evala env a2)"
| "evalb env (And b1 b2) = (evalb env b1 \<and> evalb env b2)"
| "evalb env (Neg b) = (\<not> evalb env b)"

text \<open>\medskip Substitution on arithmetic and boolean expressions\<close>

primrec substa :: "('a \<Rightarrow> 'b aexp) \<Rightarrow> 'a aexp \<Rightarrow> 'b aexp"
  and substb :: "('a \<Rightarrow> 'b aexp) \<Rightarrow> 'a bexp \<Rightarrow> 'b bexp"
where
  "substa f (IF b a1 a2) = IF (substb f b) (substa f a1) (substa f a2)"
| "substa f (Sum a1 a2) = Sum (substa f a1) (substa f a2)"
| "substa f (Diff a1 a2) = Diff (substa f a1) (substa f a2)"
| "substa f (Var v) = f v"
| "substa f (Num n) = Num n"

| "substb f (Less a1 a2) = Less (substa f a1) (substa f a2)"
| "substb f (And b1 b2) = And (substb f b1) (substb f b2)"
| "substb f (Neg b) = Neg (substb f b)"

lemma subst1_aexp:
  "evala env (substa (Var (v := a')) a) = evala (env (v := evala env a')) a"
and subst1_bexp:
  "evalb env (substb (Var (v := a')) b) = evalb (env (v := evala env a')) b"
    \<comment> \<open>one variable\<close>
  by (induct a and b) simp_all

lemma subst_all_aexp:
  "evala env (substa s a) = evala (\<lambda>x. evala env (s x)) a"
and subst_all_bexp:
  "evalb env (substb s b) = evalb (\<lambda>x. evala env (s x)) b"
  by (induct a and b) auto

end


theory ex_3_5
  imports Main
begin
datatype alpha = a | b
inductive S::"alpha list \<Rightarrow> bool" where
"S []" |
"S w \<Longrightarrow> S (a # w @ [b])" |
"\<lbrakk>S x; S y\<rbrakk> \<Longrightarrow> S (x @ y)"
inductive T::"alpha list \<Rightarrow> bool" where
"T []" |
"\<lbrakk>T x; T y\<rbrakk> \<Longrightarrow> T (x @ a # y @ [b])"

theorem S_T: "S w = T w"
proof
  show "S w \<Longrightarrow> T w"
  proof (induction rule:S.induct)
    show "T []" using T.intros(1) .
  next
    fix w assume IH:"T w"
    have "T []" using T.intros(1) .
    with IH T.intros(2) have "T ([] @ a # w @ [b])" by blast
    thus "T (a # w @ [b])" by simp
  next
    fix x y
    assume IH:"T x" "T y"
    have "\<lbrakk>T y; T x\<rbrakk> \<Longrightarrow> T (x @ y)"
    proof (induction rule:T.induct)
      case 1
      with T.intros show ?case by simp
    next
      case 2
      with T.intros(2) show ?case by fastforce
    qed
    thus "T (x @ y)" using IH by simp
  qed
next
  show "T w \<Longrightarrow> S w"
    apply (induction rule: T.induct)
    by (auto intro:S.intros)
qed
end


header{*Perfect Number Theorem*}

theory Perfect
imports Sigma
begin

definition  perfect :: "nat => bool" where
"perfect m == m>0 & 2*m = sigma m"

theorem perfect_number_theorem:
  assumes even: "even m" and perfect: "perfect m"
  shows "\<exists> n . m = 2^n*(2^(n+1) - 1) \<and> prime ((2::nat)^(n+1) - 1)"
proof
  from perfect have m0: "m>0" by (auto simp add: perfect_def)

  let ?n = "exponent 2 m"
  let ?A = "m div 2^?n"
  let ?np = "(2::nat)^(?n+1) - 1"

  from even m0 have n1: "?n >= 1 " by (simp add: exponent_ge)

  from m0 have  "2^?n dvd m" by (rule power_exponent_dvd)
  hence "m = 2^?n*?A" by (simp only: dvd_mult_div_cancel)
  with m0 have mdef: "m=2^?n*?A & coprime 2 ?A"
    by (simp add: coprime_exponent)
  moreover with m0 have a0: "?A>0" by (metis nat_0_less_mult_iff)
  moreover
  { from perfect have "2*m=sigma(m)" by (simp add: perfect_def)
    with mdef have "2^(?n+1)*?A=sigma(2^?n*?A)" by auto
  } ultimately have "2^(?n+1)*?A=sigma(2^?n)*sigma(?A)"
    by (simp add: sigma_semimultiplicative)
  hence formula: "2^(?n+1)*?A=(?np)*sigma(?A)"
    by (simp only: sigma_prime_power_two)

  from n1 have "(2::nat)^(?n+1) >= 2^2" by (simp only: power_increasing)
  hence nplarger: "?np>= 3" by auto

  let ?B = "?A div ?np"

  from formula have "?np dvd ?A * 2^(?n+1)"
    by (metis mult.commute dvd_def)
  hence             "?np dvd ?A"
    by (metis coprime_dvd_mult_nat coprime_minus_one_nat power_eq_0_iff zero_neq_numeral)
  hence bdef:       "?np*?B = ?A" by (simp add: dvd_mult_div_cancel)
  with a0 have  b0: "?B>0" by (metis gr0I mult_is_0)

  from nplarger a0 have bsmallera: "?B < ?A" by auto

  have "?B = 1"
  proof (rule ccontr)
    assume "~?B = 1"
    with b0 bsmallera have "1<?B" "?B<?A" by auto
    moreover from bdef have "?B : divisors ?A" by (rule mult_divisors2)
    ultimately have "1+?B+?A <= sigma ?A" by (rule sigma_third_divisor)
    with nplarger have "?np*(1+?A+?B) <= ?np*(sigma ?A)"
      by (auto simp only: nat_mult_le_cancel1)
    with bdef have "?np+?A*?np + ?A*1 <= ?np*(sigma ?A)"
      by (simp only: add_mult_distrib_three mult.commute)
    hence "?np+?A*(?np + 1) <= ?np*(sigma ?A)" by (simp only:add_mult_distrib2)
    with nplarger have "2^(?n+1)*?A < ?np*(sigma ?A)" by(simp add:mult.commute)
    with formula show "False" by auto
  qed

  with bdef have adef: "?A=?np" by auto
  with formula have "?np*2^(?n+1) =(?np)*sigma(?A)" by auto
  with nplarger adef have "?A + 1=sigma(?A)" by auto
  with a0 have "prime ?A" by (simp add: sigma_imp_prime)
  with mdef adef show "m = 2^?n*(?np) & prime ?np" by simp
qed

theorem Euclid_book9_prop36:
  assumes p: "prime (2^(n+1) - (1::nat))"
  shows "perfect ((2^n)*(2^(n+1) - 1))"
proof (unfold perfect_def, auto)
  from assms show "(2::nat)*2^n > Suc 0" by (auto simp add: prime_nat_def)
next
  have "2 ~= ((2::nat)^(n+1) - 1)" by simp arith
  then have "coprime (2::nat) (2^(n+1) - 1)"
    by (metis p primes_coprime_nat two_is_prime_nat)
  moreover with p have "2^(n+1) - 1 > (0::nat)"
    by (auto simp add: prime_nat_def)
  ultimately have  "sigma (2^n*(2^(n+1) - 1)) = (sigma(2^n))*(sigma(2^(n+1) - 1))"
    by (metis sigma_semimultiplicative two_is_prime_nat)
  also from assms have "... = (sigma(2^(n)))*(2^(n+1))"
    by (auto simp add: prime_imp_sigma)
  also have "... = (2^(n+1) - 1)*(2^(n+1))" by(simp add: sigma_prime_power_two)
  finally show "2*(2^n * (2*2^n - Suc 0)) = sigma(2^n*(2*2^n - Suc 0))" by auto
qed

end


(*  Title:      HOL/Number_Theory/Eratosthenes.thy
    Author:     Florian Haftmann, TU Muenchen
*)

section \<open>The sieve of Eratosthenes\<close>

theory Eratosthenes
  imports Main "HOL-Computational_Algebra.Primes"
begin

subsection \<open>Preliminary: strict divisibility\<close>

context dvd
begin

abbreviation dvd_strict :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl "dvd'_strict" 50)
where
  "b dvd_strict a \<equiv> b dvd a \<and> \<not> a dvd b"

end

subsection \<open>Main corpus\<close>

text \<open>The sieve is modelled as a list of booleans, where \<^const>\<open>False\<close> means \emph{marked out}.\<close>

type_synonym marks = "bool list"

definition numbers_of_marks :: "nat \<Rightarrow> marks \<Rightarrow> nat set"
where
  "numbers_of_marks n bs = fst ` {x \<in> set (enumerate n bs). snd x}"

lemma numbers_of_marks_simps [simp, code]:
  "numbers_of_marks n [] = {}"
  "numbers_of_marks n (True # bs) = insert n (numbers_of_marks (Suc n) bs)"
  "numbers_of_marks n (False # bs) = numbers_of_marks (Suc n) bs"
  by (auto simp add: numbers_of_marks_def intro!: image_eqI)

lemma numbers_of_marks_Suc:
  "numbers_of_marks (Suc n) bs = Suc ` numbers_of_marks n bs"
  by (auto simp add: numbers_of_marks_def enumerate_Suc_eq image_iff Bex_def)

lemma numbers_of_marks_replicate_False [simp]:
  "numbers_of_marks n (replicate m False) = {}"
  by (auto simp add: numbers_of_marks_def enumerate_replicate_eq)

lemma numbers_of_marks_replicate_True [simp]:
  "numbers_of_marks n (replicate m True) = {n..<n+m}"
  by (auto simp add: numbers_of_marks_def enumerate_replicate_eq image_def)

lemma in_numbers_of_marks_eq:
  "m \<in> numbers_of_marks n bs \<longleftrightarrow> m \<in> {n..<n + length bs} \<and> bs ! (m - n)"
  by (simp add: numbers_of_marks_def in_set_enumerate_eq image_iff add.commute)

lemma sorted_list_of_set_numbers_of_marks:
  "sorted_list_of_set (numbers_of_marks n bs) = map fst (filter snd (enumerate n bs))"
  by (auto simp add: numbers_of_marks_def distinct_map
    intro!: sorted_filter distinct_filter inj_onI sorted_distinct_set_unique)

text \<open>Marking out multiples in a sieve\<close>

definition mark_out :: "nat \<Rightarrow> marks \<Rightarrow> marks"
where
  "mark_out n bs = map (\<lambda>(q, b). b \<and> \<not> Suc n dvd Suc (Suc q)) (enumerate n bs)"

lemma mark_out_Nil [simp]: "mark_out n [] = []"
  by (simp add: mark_out_def)

lemma length_mark_out [simp]: "length (mark_out n bs) = length bs"
  by (simp add: mark_out_def)

lemma numbers_of_marks_mark_out:
    "numbers_of_marks n (mark_out m bs) = {q \<in> numbers_of_marks n bs. \<not> Suc m dvd Suc q - n}"
  by (auto simp add: numbers_of_marks_def mark_out_def in_set_enumerate_eq image_iff
    nth_enumerate_eq less_eq_dvd_minus)

text \<open>Auxiliary operation for efficient implementation\<close>

definition mark_out_aux :: "nat \<Rightarrow> nat \<Rightarrow> marks \<Rightarrow> marks"
where
  "mark_out_aux n m bs =
    map (\<lambda>(q, b). b \<and> (q < m + n \<or> \<not> Suc n dvd Suc (Suc q) + (n - m mod Suc n))) (enumerate n bs)"

lemma mark_out_code [code]: "mark_out n bs = mark_out_aux n n bs"
proof -
  have aux: False
    if A: "Suc n dvd Suc (Suc a)"
    and B: "a < n + n"
    and C: "n \<le> a"
    for a
  proof (cases "n = 0")
    case True
    with A B C show ?thesis by simp
  next
    case False
    define m where "m = Suc n"
    then have "m > 0" by simp
    from False have "n > 0" by simp
    from A obtain q where q: "Suc (Suc a) = Suc n * q" by (rule dvdE)
    have "q > 0"
    proof (rule ccontr)
      assume "\<not> q > 0"
      with q show False by simp
    qed
    with \<open>n > 0\<close> have "Suc n * q \<ge> 2" by (auto simp add: gr0_conv_Suc)
    with q have a: "a = Suc n * q - 2" by simp
    with B have "q + n * q < n + n + 2" by auto
    then have "m * q < m * 2" by (simp add: m_def)
    with \<open>m > 0\<close> have "q < 2" by simp
    with \<open>q > 0\<close> have "q = 1" by simp
    with a have "a = n - 1" by simp
    with \<open>n > 0\<close> C show False by simp
  qed
  show ?thesis
    by (auto simp add: mark_out_def mark_out_aux_def in_set_enumerate_eq intro: aux)
qed

lemma mark_out_aux_simps [simp, code]:
  "mark_out_aux n m [] = []"
  "mark_out_aux n 0 (b # bs) = False # mark_out_aux n n bs"
  "mark_out_aux n (Suc m) (b # bs) = b # mark_out_aux n m bs"
proof goal_cases
  case 1
  show ?case
    by (simp add: mark_out_aux_def)
next
  case 2
  show ?case
    by (auto simp add: mark_out_code [symmetric] mark_out_aux_def mark_out_def
      enumerate_Suc_eq in_set_enumerate_eq less_eq_dvd_minus)
next
  case 3
  { define v where "v = Suc m"
    define w where "w = Suc n"
    fix q
    assume "m + n \<le> q"
    then obtain r where q: "q = m + n + r" by (auto simp add: le_iff_add)
    { fix u
      from w_def have "u mod w < w" by simp
      then have "u + (w - u mod w) = w + (u - u mod w)"
        by simp
      then have "u + (w - u mod w) = w + u div w * w"
        by (simp add: minus_mod_eq_div_mult)
    }
    then have "w dvd v + w + r + (w - v mod w) \<longleftrightarrow> w dvd m + w + r + (w - m mod w)"
      by (simp add: add.assoc add.left_commute [of m] add.left_commute [of v]
        dvd_add_left_iff dvd_add_right_iff)
    moreover from q have "Suc q = m + w + r" by (simp add: w_def)
    moreover from q have "Suc (Suc q) = v + w + r" by (simp add: v_def w_def)
    ultimately have "w dvd Suc (Suc (q + (w - v mod w))) \<longleftrightarrow> w dvd Suc (q + (w - m mod w))"
      by (simp only: add_Suc [symmetric])
    then have "Suc n dvd Suc (Suc (Suc (q + n) - Suc m mod Suc n)) \<longleftrightarrow>
      Suc n dvd Suc (Suc (q + n - m mod Suc n))"
      by (simp add: v_def w_def Suc_diff_le trans_le_add2)
  }
  then show ?case
    by (auto simp add: mark_out_aux_def
      enumerate_Suc_eq in_set_enumerate_eq not_less)
qed

text \<open>Main entry point to sieve\<close>

fun sieve :: "nat \<Rightarrow> marks \<Rightarrow> marks"
where
  "sieve n [] = []"
| "sieve n (False # bs) = False # sieve (Suc n) bs"
| "sieve n (True # bs) = True # sieve (Suc n) (mark_out n bs)"

text \<open>
  There are the following possible optimisations here:

  \begin{itemize}

    \item \<^const>\<open>sieve\<close> can abort as soon as \<^term>\<open>n\<close> is too big to let
      \<^const>\<open>mark_out\<close> have any effect.

    \item Search for further primes can be given up as soon as the search
      position exceeds the square root of the maximum candidate.

  \end{itemize}

  This is left as an constructive exercise to the reader.
\<close>

lemma numbers_of_marks_sieve:
  "numbers_of_marks (Suc n) (sieve n bs) =
    {q \<in> numbers_of_marks (Suc n) bs. \<forall>m \<in> numbers_of_marks (Suc n) bs. \<not> m dvd_strict q}"
proof (induct n bs rule: sieve.induct)
  case 1
  show ?case by simp
next
  case 2
  then show ?case by simp
next
  case (3 n bs)
  have aux: "n \<in> Suc ` M \<longleftrightarrow> n > 0 \<and> n - 1 \<in> M" (is "?lhs \<longleftrightarrow> ?rhs") for M n
  proof
    show ?rhs if ?lhs using that by auto
    show ?lhs if ?rhs
    proof -
      from that have "n > 0" and "n - 1 \<in> M" by auto
      then have "Suc (n - 1) \<in> Suc ` M" by blast
      with \<open>n > 0\<close> show "n \<in> Suc ` M" by simp
    qed
  qed
  have aux1: False if "Suc (Suc n) \<le> m" and "m dvd Suc n" for m :: nat
  proof -
    from \<open>m dvd Suc n\<close> obtain q where "Suc n = m * q" ..
    with \<open>Suc (Suc n) \<le> m\<close> have "Suc (m * q) \<le> m" by simp
    then have "m * q < m" by arith
    then have "q = 0" by simp
    with \<open>Suc n = m * q\<close> show ?thesis by simp
  qed
  have aux2: "m dvd q"
    if 1: "\<forall>q>0. 1 < q \<longrightarrow> Suc n < q \<longrightarrow> q \<le> Suc (n + length bs) \<longrightarrow>
      bs ! (q - Suc (Suc n)) \<longrightarrow> \<not> Suc n dvd q \<longrightarrow> q dvd m \<longrightarrow> m dvd q"
    and 2: "\<not> Suc n dvd m" "q dvd m"
    and 3: "Suc n < q" "q \<le> Suc (n + length bs)" "bs ! (q - Suc (Suc n))"
    for m q :: nat
  proof -
    from 1 have *: "\<And>q. Suc n < q \<Longrightarrow> q \<le> Suc (n + length bs) \<Longrightarrow>
      bs ! (q - Suc (Suc n)) \<Longrightarrow> \<not> Suc n dvd q \<Longrightarrow> q dvd m \<Longrightarrow> m dvd q"
      by auto
    from 2 have "\<not> Suc n dvd q" by (auto elim: dvdE)
    moreover note 3
    moreover note \<open>q dvd m\<close>
    ultimately show ?thesis by (auto intro: *)
  qed
  from 3 show ?case
    apply (simp_all add: numbers_of_marks_mark_out numbers_of_marks_Suc Compr_image_eq
      inj_image_eq_iff in_numbers_of_marks_eq Ball_def imp_conjL aux)
    apply safe
    apply (simp_all add: less_diff_conv2 le_diff_conv2 dvd_minus_self not_less)
    apply (clarsimp dest!: aux1)
    apply (simp add: Suc_le_eq less_Suc_eq_le)
    apply (rule aux2)
    apply (clarsimp dest!: aux1)+
    done
qed

text \<open>Relation of the sieve algorithm to actual primes\<close>

definition primes_upto :: "nat \<Rightarrow> nat list"
where
  "primes_upto n = sorted_list_of_set {m. m \<le> n \<and> prime m}"

lemma set_primes_upto: "set (primes_upto n) = {m. m \<le> n \<and> prime m}"
  by (simp add: primes_upto_def)

lemma sorted_primes_upto [iff]: "sorted (primes_upto n)"
  by (simp add: primes_upto_def)

lemma distinct_primes_upto [iff]: "distinct (primes_upto n)"
  by (simp add: primes_upto_def)

lemma set_primes_upto_sieve:
  "set (primes_upto n) = numbers_of_marks 2 (sieve 1 (replicate (n - 1) True))"
proof -
  consider "n = 0 \<or> n = 1" | "n > 1" by arith
  then show ?thesis
  proof cases
    case 1
    then show ?thesis
      by (auto simp add: numbers_of_marks_sieve numeral_2_eq_2 set_primes_upto
        dest: prime_gt_Suc_0_nat)
  next
    case 2
    {
      fix m q
      assume "Suc (Suc 0) \<le> q"
        and "q < Suc n"
        and "m dvd q"
      then have "m < Suc n" by (auto dest: dvd_imp_le)
      assume *: "\<forall>m\<in>{Suc (Suc 0)..<Suc n}. m dvd q \<longrightarrow> q dvd m"
        and "m dvd q" and "m \<noteq> 1"
      have "m = q"
      proof (cases "m = 0")
        case True with \<open>m dvd q\<close> show ?thesis by simp
      next
        case False with \<open>m \<noteq> 1\<close> have "Suc (Suc 0) \<le> m" by arith
        with \<open>m < Suc n\<close> * \<open>m dvd q\<close> have "q dvd m" by simp
        with \<open>m dvd q\<close> show ?thesis by (simp add: dvd_antisym)
      qed
    }
    then have aux: "\<And>m q. Suc (Suc 0) \<le> q \<Longrightarrow>
      q < Suc n \<Longrightarrow>
      m dvd q \<Longrightarrow>
      \<forall>m\<in>{Suc (Suc 0)..<Suc n}. m dvd q \<longrightarrow> q dvd m \<Longrightarrow>
      m dvd q \<Longrightarrow> m \<noteq> q \<Longrightarrow> m = 1" by auto
    from 2 show ?thesis
      apply (auto simp add: numbers_of_marks_sieve numeral_2_eq_2 set_primes_upto
        dest: prime_gt_Suc_0_nat)
      apply (metis One_nat_def Suc_le_eq less_not_refl prime_nat_iff)
      apply (metis One_nat_def Suc_le_eq aux prime_nat_iff)
      done
  qed
qed

lemma primes_upto_sieve [code]:
  "primes_upto n = map fst (filter snd (enumerate 2 (sieve 1 (replicate (n - 1) True))))"
proof -
  have "primes_upto n = sorted_list_of_set (numbers_of_marks 2 (sieve 1 (replicate (n - 1) True)))"
    apply (rule sorted_distinct_set_unique)
    apply (simp_all only: set_primes_upto_sieve numbers_of_marks_def)
    apply auto
    done
  then show ?thesis
    by (simp add: sorted_list_of_set_numbers_of_marks)
qed

lemma prime_in_primes_upto: "prime n \<longleftrightarrow> n \<in> set (primes_upto n)"
  by (simp add: set_primes_upto)

subsection \<open>Application: smallest prime beyond a certain number\<close>

definition smallest_prime_beyond :: "nat \<Rightarrow> nat"
where
  "smallest_prime_beyond n = (LEAST p. prime p \<and> p \<ge> n)"

lemma prime_smallest_prime_beyond [iff]: "prime (smallest_prime_beyond n)" (is ?P)
  and smallest_prime_beyond_le [iff]: "smallest_prime_beyond n \<ge> n" (is ?Q)
proof -
  let ?least = "LEAST p. prime p \<and> p \<ge> n"
  from primes_infinite obtain q where "prime q \<and> q \<ge> n"
    by (metis finite_nat_set_iff_bounded_le mem_Collect_eq nat_le_linear)
  then have "prime ?least \<and> ?least \<ge> n"
    by (rule LeastI)
  then show ?P and ?Q
    by (simp_all add: smallest_prime_beyond_def)
qed

lemma smallest_prime_beyond_smallest: "prime p \<Longrightarrow> p \<ge> n \<Longrightarrow> smallest_prime_beyond n \<le> p"
  by (simp only: smallest_prime_beyond_def) (auto intro: Least_le)

lemma smallest_prime_beyond_eq:
  "prime p \<Longrightarrow> p \<ge> n \<Longrightarrow> (\<And>q. prime q \<Longrightarrow> q \<ge> n \<Longrightarrow> q \<ge> p) \<Longrightarrow> smallest_prime_beyond n = p"
  by (simp only: smallest_prime_beyond_def) (auto intro: Least_equality)

definition smallest_prime_between :: "nat \<Rightarrow> nat \<Rightarrow> nat option"
where
  "smallest_prime_between m n =
    (if (\<exists>p. prime p \<and> m \<le> p \<and> p \<le> n) then Some (smallest_prime_beyond m) else None)"

lemma smallest_prime_between_None:
  "smallest_prime_between m n = None \<longleftrightarrow> (\<forall>q. m \<le> q \<and> q \<le> n \<longrightarrow> \<not> prime q)"
  by (auto simp add: smallest_prime_between_def)

lemma smallest_prime_betwen_Some:
  "smallest_prime_between m n = Some p \<longleftrightarrow> smallest_prime_beyond m = p \<and> p \<le> n"
  by (auto simp add: smallest_prime_between_def dest: smallest_prime_beyond_smallest [of _ m])

definition smallest_prime_beyond_aux :: "nat \<Rightarrow> nat \<Rightarrow> nat"
where
  "smallest_prime_beyond_aux k n = smallest_prime_beyond n"

lemma [code]:
  "smallest_prime_beyond_aux k n =
    (case smallest_prime_between n (k * n) of
      Some p \<Rightarrow> p
    | None \<Rightarrow> smallest_prime_beyond_aux (Suc k) n)"
  by (simp add: smallest_prime_beyond_aux_def smallest_prime_betwen_Some split: option.split)

lemma [code]: "smallest_prime_beyond n = smallest_prime_beyond_aux 2 n"
  by (simp add: smallest_prime_beyond_aux_def)

end


section \<open>Missing Lemmas on Vector Spaces\<close>

text \<open>We provide some results on vector spaces which should be merged into other AFP entries.\<close>
theory Missing_VS_Connect
  imports
    Jordan_Normal_Form.VS_Connect
    Missing_Matrix
    Polynomial_Factorization.Missing_List
begin

context vec_space
begin
lemma span_diff: assumes A: "A \<subseteq> carrier_vec n"
  and a: "a \<in> span A" and b: "b \<in> span A"
shows "a - b \<in> span A"
proof -
  from A a have an: "a \<in> carrier_vec n" by auto
  from A b have bn: "b \<in> carrier_vec n" by auto
  have "a + (-1 \<cdot>\<^sub>v b) \<in> span A"
    by (rule span_add1[OF A a], insert b A, auto)
  also have "a + (-1 \<cdot>\<^sub>v b) = a - b" using an bn by auto
  finally show ?thesis by auto
qed

lemma lincomb_scalar_prod_left: assumes "W \<subseteq> carrier_vec n" "v \<in> carrier_vec n"
  shows "lincomb a W \<bullet> v = (\<Sum>w\<in>W. a w * (w \<bullet> v))"
  unfolding lincomb_def
  by (subst finsum_scalar_prod_sum, insert assms, auto intro!: sum.cong)

lemma lincomb_scalar_prod_right: assumes "W \<subseteq> carrier_vec n" "v \<in> carrier_vec n"
  shows "v \<bullet> lincomb a W = (\<Sum>w\<in>W. a w * (v \<bullet> w))"
  unfolding lincomb_def
  by (subst finsum_scalar_prod_sum', insert assms, auto intro!: sum.cong)

lemma lin_indpt_empty[simp]: "lin_indpt {}"
  using lin_dep_def by auto

lemma span_carrier_lin_indpt_card_n:
  assumes "W \<subseteq> carrier_vec n" "card W = n" "lin_indpt W"
  shows "span W = carrier_vec n"
  using assms basis_def dim_is_n dim_li_is_basis fin_dim_li_fin by simp

lemma ortho_span: assumes W: "W \<subseteq> carrier_vec n"
  and X: "X \<subseteq> carrier_vec n"
  and ortho: "\<And> w x. w \<in> W \<Longrightarrow> x \<in> X \<Longrightarrow> w \<bullet> x = 0"
  and w: "w \<in> span W" and x: "x \<in> X"
shows "w \<bullet> x = 0"
proof -
  from w W obtain c V where "finite V" and VW: "V \<subseteq> W" and w: "w = lincomb c V"
    by (meson in_spanE)
  show ?thesis unfolding w
    by (subst lincomb_scalar_prod_left, insert W VW X x ortho, auto intro!: sum.neutral)
qed

lemma ortho_span': assumes W: "W \<subseteq> carrier_vec n"
  and X: "X \<subseteq> carrier_vec n"
  and ortho: "\<And> w x. w \<in> W \<Longrightarrow> x \<in> X \<Longrightarrow> x \<bullet> w = 0"
  and w: "w \<in> span W" and x: "x \<in> X"
shows "x \<bullet> w = 0"
proof -
  from w W obtain c V where "finite V" and VW: "V \<subseteq> W" and w: "w = lincomb c V"
    by (meson in_spanE)
  show ?thesis unfolding w
    by (subst lincomb_scalar_prod_right, insert W VW X x ortho, auto intro!: sum.neutral)
qed

lemma ortho_span_span: assumes W: "W \<subseteq> carrier_vec n"
  and X: "X \<subseteq> carrier_vec n"
  and ortho: "\<And> w x. w \<in> W \<Longrightarrow> x \<in> X \<Longrightarrow> w \<bullet> x = 0"
  and w: "w \<in> span W" and x: "x \<in> span X"
shows "w \<bullet> x = 0"
  by (rule ortho_span[OF W _ ortho_span'[OF X W _ _] w x], insert W X ortho, auto)

lemma lincomb_in_span[intro]:
  assumes X: "X\<subseteq> carrier_vec n"
  shows "lincomb a X \<in> span X"
proof(cases "finite X")
  case False hence "lincomb a X = 0\<^sub>v n" using X
    by (simp add: lincomb_def)
  thus ?thesis using X by force
qed (insert X, auto)

lemma generating_card_n_basis: assumes X: "X \<subseteq> carrier_vec n"
  and span: "carrier_vec n \<subseteq> span X"
  and card: "card X = n"
shows "basis X"
proof -
  have fin: "finite X"
  proof (cases "n = 0")
    case False
    with card show "finite X" by (meson card_infinite)
  next
    case True
    with X have "X \<subseteq> carrier_vec 0" by auto
    also have "\<dots> = {0\<^sub>v 0}" by auto
    finally have "X \<subseteq> {0\<^sub>v 0}" .
    from finite_subset[OF this] show "finite X" by auto
  qed
  from X have "span X \<subseteq> carrier_vec n" by auto
  with span have span: "span X = carrier_vec n" by auto
  from dim_is_n card have card: "card X \<le> dim" by auto
  from dim_gen_is_basis[OF fin X span card] show "basis X" .
qed

lemma lincomb_list_append:
  assumes Ws: "set Ws \<subseteq> carrier_vec n"
  shows "set Vs \<subseteq> carrier_vec n \<Longrightarrow> lincomb_list f (Vs @ Ws) =
    lincomb_list f Vs + lincomb_list (\<lambda> i. f (i + length Vs)) Ws"
proof (induction Vs arbitrary: f)
  case Nil show ?case by(simp add: lincomb_list_carrier[OF Ws])
next
  case (Cons x Vs)
  have "lincomb_list f (x # (Vs @ Ws)) = f 0 \<cdot>\<^sub>v x + lincomb_list (f \<circ> Suc) (Vs @ Ws)"
    by (rule lincomb_list_Cons)
  also have "lincomb_list (f \<circ> Suc) (Vs @ Ws) =
             lincomb_list (f \<circ> Suc) Vs + lincomb_list (\<lambda> i. (f \<circ> Suc) (i + length Vs)) Ws"
    using Cons by auto
  also have "(\<lambda> i. (f \<circ> Suc) (i + length Vs)) = (\<lambda> i. f (i + length (x # Vs)))" by simp
  also have "f 0 \<cdot>\<^sub>v x + ((lincomb_list (f \<circ> Suc) Vs) + lincomb_list \<dots> Ws) =
             (f 0 \<cdot>\<^sub>v x + (lincomb_list (f \<circ> Suc) Vs)) + lincomb_list \<dots> Ws"
    using assoc_add_vec Cons.prems Ws lincomb_list_carrier by auto
  finally show ?case using lincomb_list_Cons by auto
qed

lemma lincomb_list_snoc[simp]:
  shows "set Vs \<subseteq> carrier_vec n \<Longrightarrow> x \<in> carrier_vec n \<Longrightarrow>
          lincomb_list f (Vs @ [x]) = lincomb_list f Vs + f (length Vs) \<cdot>\<^sub>v x"
  using lincomb_list_append by auto

lemma lincomb_list_smult:
  "set Vs \<subseteq> carrier_vec n \<Longrightarrow> lincomb_list (\<lambda> i. a * c i) Vs = a \<cdot>\<^sub>v lincomb_list c Vs"
proof (induction Vs rule: rev_induct)
  case (snoc x Vs)
  have x: "x \<in> carrier_vec n" and Vs: "set Vs \<subseteq> carrier_vec n" using snoc.prems by auto
  have "lincomb_list (\<lambda> i. a * c i) (Vs @ [x]) =
        lincomb_list (\<lambda> i. a * c i) Vs + (a * c (length Vs)) \<cdot>\<^sub>v x"
    using x Vs by auto
  also have "lincomb_list (\<lambda> i. a * c i) Vs = a \<cdot>\<^sub>v lincomb_list c Vs"
    by(rule snoc.IH[OF Vs])
  also have "(a * c (length Vs)) \<cdot>\<^sub>v x = a \<cdot>\<^sub>v (c (length Vs) \<cdot>\<^sub>v x)"
    using smult_smult_assoc x by auto
  also have "a \<cdot>\<^sub>v lincomb_list c Vs + \<dots> = a \<cdot>\<^sub>v (lincomb_list c Vs + c (length Vs) \<cdot>\<^sub>v x)"
    using smult_add_distrib_vec[of _ n _ a] lincomb_list_carrier[OF Vs] x by simp
  also have "lincomb_list c Vs + c (length Vs) \<cdot>\<^sub>v x = lincomb_list c (Vs @ [x])"
    using Vs x by auto
  finally show ?case by auto
qed simp

lemma lincomb_list_index:
  assumes i: "i < n"
  shows "set Xs \<subseteq> carrier_vec n \<Longrightarrow>
         lincomb_list c Xs $ i = sum (\<lambda> j. c j * (Xs ! j) $ i) {0..<length Xs}"
proof (induction Xs rule: rev_induct)
  case (snoc x Xs)
  hence x: "x \<in> carrier_vec n" and Xs: "set Xs \<subseteq> carrier_vec n" by auto
  hence "lincomb_list c (Xs @ [x]) = lincomb_list c Xs + c (length Xs) \<cdot>\<^sub>v x" by auto
  also have "\<dots> $ i = lincomb_list c Xs $ i + (c (length Xs) \<cdot>\<^sub>v x) $ i"
    using i index_add_vec(1) x by simp
  also have "(c (length Xs) \<cdot>\<^sub>v x) $ i = c (length Xs) * x $ i" using i x by simp
  also have "x $ i= (Xs @ [x]) ! (length Xs) $ i" by simp
  also have "lincomb_list c Xs $ i = (\<Sum>j = 0..<length Xs. c j * Xs ! j $ i)"
    by (rule snoc.IH[OF Xs])
  also have "\<dots> =  (\<Sum>j = 0..<length Xs. c j * (Xs @ [x]) ! j $ i)"
    by (rule R.finsum_restrict, force, rule restrict_ext, auto simp: append_Cons_nth_left)
  finally show ?case
    using sum.atLeast0_lessThan_Suc[of "\<lambda> j. c j * (Xs @ [x]) ! j $ i" "length Xs"]
    by fastforce
qed (simp add: i)

end
end


theory Utility_Functions
imports
  Complex_Main
  "HOL-Probability.Probability"
  Lotteries
  Preference_Profiles
begin

subsection \<open>Definition of von Neumann--Morgenstern utility functions\<close>

locale vnm_utility = finite_total_preorder_on +
  fixes u :: "'a \<Rightarrow> real"
  assumes utility_le_iff: "x \<in> carrier \<Longrightarrow> y \<in> carrier \<Longrightarrow> u x \<le> u y \<longleftrightarrow> x \<preceq>[le] y"
begin

lemma utility_le: "x \<preceq>[le] y \<Longrightarrow> u x \<le> u y"
  using not_outside[of x y] utility_le_iff by simp

lemma utility_less_iff:
  "x \<in> carrier \<Longrightarrow> y \<in> carrier \<Longrightarrow> u x < u y \<longleftrightarrow> x \<prec>[le] y"
  using utility_le_iff[of x y] utility_le_iff[of y x]
  by (auto simp: strongly_preferred_def)

lemma utility_less: "x \<prec>[le] y \<Longrightarrow> u x < u y"
  using not_outside[of x y] utility_less_iff by (simp add: strongly_preferred_def)

text \<open>
  The following lemma allows us to compute the expected utility by summing
  over all indifference classes, using the fact that alternatives in the same
  indifference class must have the same utility.
\<close>
lemma expected_utility_weak_ranking:
  assumes "p \<in> lotteries_on carrier"
  shows   "measure_pmf.expectation p u =
             (\<Sum>A\<leftarrow>weak_ranking le. u (SOME x. x \<in> A) * measure_pmf.prob p A)"
proof -
  from assms have "measure_pmf.expectation p u = (\<Sum>a\<in>carrier. u a * pmf p a)"
    by (subst integral_measure_pmf[OF finite_carrier])
       (auto simp: lotteries_on_def ac_simps)
  also have carrier: "carrier = \<Union>(set (weak_ranking le))" by (simp add: weak_ranking_Union)
  also from carrier have finite: "finite A" if "A \<in> set (weak_ranking le)" for A
    using that by (blast intro!: finite_subset[OF _ finite_carrier, of A])
  hence "(\<Sum>a\<in>\<Union>(set (weak_ranking le)). u a * pmf p a) =
           (\<Sum>A\<leftarrow>weak_ranking le. \<Sum>a\<in>A. u a * pmf p a)" (is "_ = sum_list ?xs")
    using weak_ranking_total_preorder
    by (subst sum.Union_disjoint)
       (auto simp: is_weak_ranking_iff disjoint_def sum.distinct_set_conv_list)
  also have "?xs  = map (\<lambda>A. \<Sum>a\<in>A. u (SOME a. a\<in>A) * pmf p a) (weak_ranking le)"
  proof (intro map_cong HOL.refl sum.cong)
    fix x A assume x: "x \<in> A" and A: "A \<in> set (weak_ranking le)"
    have "(SOME x. x \<in> A) \<in> A" by (rule someI_ex) (insert x, blast)
    from weak_ranking_eqclass1[OF A x this] weak_ranking_eqclass1[OF A this x] x this A
      have "u x = u (SOME x. x \<in> A)"
      by (intro antisym; subst utility_le_iff) (auto simp: carrier)
    thus "u x * pmf p x = u (SOME x. x \<in> A) * pmf p x" by simp
  qed
  also have "\<dots> = map (\<lambda>A. u (SOME a. a \<in> A) * measure_pmf.prob p A) (weak_ranking le)"
    using finite by (intro map_cong HOL.refl)
                    (auto simp: sum_distrib_left measure_measure_pmf_finite)
  finally show ?thesis .
qed

lemma scaled: "c > 0 \<Longrightarrow> vnm_utility carrier le (\<lambda>x. c * u x)"
  by unfold_locales (insert utility_le_iff, auto)

lemma add_right:
  assumes "\<And>x y. le x y \<Longrightarrow> f x \<le> f y"
  shows   "vnm_utility carrier le (\<lambda>x. u x + f x)"
proof
  fix x y assume xy: "x \<in> carrier" "y \<in> carrier"
  from assms[of x y] utility_le_iff[OF xy] assms[of y x] utility_le_iff[OF xy(2,1)]
    show "(u x + f x \<le> u y + f y) = le x y" by auto
qed

lemma add_left:
  "(\<And>x y. le x y \<Longrightarrow> f x \<le> f y) \<Longrightarrow> vnm_utility carrier le (\<lambda>x. f x + u x)"
  by (subst add.commute) (rule add_right)

text \<open>
  Given a consistent utility function, any function that assigns equal values to
  equivalent alternatives can be added to it (scaled with a sufficiently small @{term "\<epsilon>"}),
  again yielding a consistent utility function.
\<close>
lemma add_epsilon:
  assumes A: "\<And>x y. le x y \<Longrightarrow> le y x \<Longrightarrow> f x = f y"
  shows "\<exists>\<epsilon>>0. vnm_utility carrier le (\<lambda>x. u x + \<epsilon> * f x)"
proof -
  let ?A = "{(u y - u x) / (f x - f y) |x y. x \<prec>[le] y \<and> f x > f y}"
  have "?A = (\<lambda>(x,y). (u y - u x) / (f x - f y)) ` {(x,y) |x y. x \<prec>[le] y \<and> f x > f y}" by auto
  also have "finite {(x,y) |x y. x \<prec>[le] y \<and> f x > f y}"
    by (rule finite_subset[of _ "carrier \<times> carrier"])
       (insert not_outside, auto simp: strongly_preferred_def)
  hence "finite ((\<lambda>(x,y). (u y - u x) / (f x - f y)) ` {(x,y) |x y. x \<prec>[le] y \<and> f x > f y})"
    by simp
  finally have finite: "finite ?A" .

  define \<epsilon> where "\<epsilon> = Min (insert 1 ?A) / 2"
  from finite have "Min (insert 1 ?A) > 0"
    by (auto intro!: divide_pos_pos simp: utility_less)
  hence \<epsilon>: "\<epsilon> > 0" unfolding \<epsilon>_def by simp

  have mono: "u x + \<epsilon> * f x < u y + \<epsilon> * f y" if xy: "x \<prec>[le] y" for x y
  proof (cases "f x > f y")
    assume less: "f x > f y"
    from \<epsilon> have "\<epsilon> < Min (insert 1 ?A)" unfolding \<epsilon>_def by linarith
    also from less xy finite have "Min (insert 1 ?A) \<le> (u y - u x) / (f x - f y)" unfolding \<epsilon>_def
      by (intro Min_le) auto
    finally show ?thesis using less by (simp add: field_simps)
  next
    assume "\<not>f x > f y"
    with utility_less[OF xy] \<epsilon> show ?thesis
      by (simp add: algebra_simps not_less add_less_le_mono)
  qed
  have eq: "u x + \<epsilon> * f x = u y + \<epsilon> * f y" if xy: "x \<preceq>[le] y" "y \<preceq>[le] x" for x y
    using xy[THEN utility_le] A[OF xy] by simp
  have "vnm_utility carrier le (\<lambda>x. u x + \<epsilon> * f x)"
  proof
    fix x y assume xy: "x \<in> carrier" "y \<in> carrier"
    show "(u x + \<epsilon> * f x \<le> u y + \<epsilon> * f y) \<longleftrightarrow> le x y"
      using total[OF xy] mono[of x y] mono[of y x] eq[of x y]
      by (cases "le x y"; cases "le y x") (auto simp: strongly_preferred_def)
  qed
  from \<epsilon> this show ?thesis by blast
qed

lemma diff_epsilon:
  assumes "\<And>x y. le x y \<Longrightarrow> le y x \<Longrightarrow> f x = f y"
  shows "\<exists>\<epsilon>>0. vnm_utility carrier le (\<lambda>x. u x - \<epsilon> * f x)"
proof -
  from assms have "\<exists>\<epsilon>>0. vnm_utility carrier le (\<lambda>x. u x + \<epsilon> * -f x)"
    by (intro add_epsilon) (subst neg_equal_iff_equal)
  thus ?thesis by simp
qed

end

end


theory Ex026
  imports Main
begin

lemma "(A \<longrightarrow> (B \<longrightarrow> C)) \<longleftrightarrow> (B \<longrightarrow> (A \<longrightarrow> C))"
proof -
  {
    assume a:"A \<longrightarrow> (B \<longrightarrow> C)"
    {
      assume b:B
      {
        assume A
        with a have "B \<longrightarrow> C" by (rule mp)
        from this and b have C by (rule mp)
      }
      hence "A \<longrightarrow> C" by (rule impI)
    }
    hence " B \<longrightarrow> (A \<longrightarrow> C)" by (rule impI)
  }
  moreover
  {
    assume c:"B \<longrightarrow> (A \<longrightarrow> C)"
    {
      assume d:A
      {
        assume B
        with c have  "A \<longrightarrow> C" by (rule mp)
        from this and d have C by (rule mp)
      }
      hence "B \<longrightarrow> C" by (rule impI)
    }
    hence "A \<longrightarrow> (B \<longrightarrow> C)" by (rule impI)
  }
  ultimately show ?thesis by (rule iffI)
qed


theory Chapter18_3_Evaluation
imports Chapter18_2_Typechecking
begin

primrec is_val :: "expr => bool"
where "is_val (Var v) = False"
    | "is_val (Num n) = True"
    | "is_val Zero = False"
    | "is_val (Succ e) = False"
    | "is_val (IsZ et e0 es) = False"
    | "is_val (Lam e) = True"
    | "is_val (Appl e1 e2) = False"
    | "is_val (Fix e) = False"

inductive eval :: "expr => expr => bool"
and error :: "expr => bool"
where eval_zero [simp]: "eval Zero (Num 0)"
    | eval_suc_1 [simp]: "eval e e' ==> eval (Succ e) (Succ e')"
    | eval_suc_2 [simp]: "error d ==> error (Succ d)"
    | eval_suc_3 [simp]: "eval (Succ (Num n)) (Num (Suc n))"
    | eval_suc_4 [simp]: "error (Succ (Lam e)) "
    | eval_isz_1 [simp]: "eval et et' ==> eval (IsZ et e0 es) (IsZ et' e0 es)"
    | eval_isz_2 [simp]: "error d ==> error (IsZ d e0 es)"
    | eval_isz_3 [simp]: "eval (IsZ (Num 0) e0 es) e0"
    | eval_isz_4 [simp]: "eval (IsZ (Num (Suc et)) e0 es) (subst (Num et) first es)"
    | eval_isz_5 [simp]: "error (IsZ (Lam et) e0 es)"
    | eval_appl_1 [simp]: "eval e1 e1' ==> eval (Appl e1 e2) (Appl e1' e2)"
    | eval_appl_2 [simp]: "error e1 ==> error (Appl e1 e2)"
    | eval_appl_3 [simp]: "error (Appl (Num e1) e2)"
    | eval_appl_4 [simp]: "eval (Appl (Lam e1) e2) (subst e2 first e1)"
    | eval_fix [simp]: "eval (Fix e) (subst (Fix e) first e)"

theorem preservation: "eval e e' ==> is_ok del e ==> is_ok del e'" and "error f ==> True"
by (induction e e' and f arbitrary: del rule: eval_error.inducts, fastforce+)

theorem progress: "is_ok del e ==> del = empty_env ==> is_val e | (EX e'. eval e e') | error e"
proof (induction e arbitrary: del)
case Var
  thus ?case by simp
next case Num
  thus ?case by simp
next case Zero
  thus ?case by (metis eval_zero)
next case (Succ e)
  thus ?case
  proof (cases "is_val e")
  case True
    thus ?thesis by (cases e, simp_all, metis eval_suc_3)
  next case False
    with Succ eval_suc_1 show ?thesis by fastforce
  qed
next case (IsZ e1 e2 e3)
  thus ?case
  proof (cases "is_val e1")
  case True
    thus ?thesis
    proof (cases e1, simp_all)
      fix n
      show "Ex (eval (IsZ (Num n) e2 e3)) | error (IsZ (Num n) e2 e3)"
      by (cases n, metis eval_isz_3, metis eval_isz_4)
    qed
  next case False
    with IsZ eval_isz_1 show ?thesis by fastforce
  qed
next case Lam
  thus ?case by simp
next case (Appl e1 e2)
  thus ?case
  proof (cases "is_val e1")
  case True
    thus ?thesis by (cases e1, simp_all, metis eval_appl_4)
  next case False
    with Appl eval_appl_1 show ?thesis by fastforce
  qed
next case (Fix e)
  hence "eval (Fix e) (subst (Fix e) first e)" by simp
  thus ?case by fast
qed

end


theory Tree
imports "$HIPSTER_HOME/IsaHipster"

begin

datatype 'a Tree =
  Leaf 'a
  | Node "'a Tree""'a Tree"

fun mirror :: "'a Tree => 'a Tree"
where
  "mirror (Leaf x) = Leaf x"
| "mirror (Node l r) = Node (mirror r) (mirror l)"

fun tmap :: "('a => 'b) => 'a Tree => 'b Tree"
where
  "tmap f (Leaf x) = Leaf (f x)"
| "tmap f (Node l r) = Node (tmap f l) (tmap f r)"

ML\<open>Hipster_Explore.explore  @{context} ["Tree.tmap", "Tree.mirror"];\<close>
lemma lemma_a [thy_expl]: "mirror (tmap x2 y2) = tmap x2 (mirror y2)"
by (tactic \<open>Hipster_Tacs.induct_simp_metis @{context} @{thms Tree.tmap.simps Tree.mirror.simps thy_expl}\<close>)

lemma lemma_aa [thy_expl]: "mirror (mirror x2) = x2"
by (tactic \<open>Hipster_Tacs.induct_simp_metis @{context} @{thms Tree.tmap.simps Tree.mirror.simps thy_expl}\<close>)

fun rigthmost :: "'a Tree \<Rightarrow> 'a"
where
  "rigthmost (Leaf x) = x"
|  "rigthmost (Node l r) = rigthmost r"

fun leftmost :: "'a Tree \<Rightarrow> 'a"
where
  "leftmost (Leaf x) = x"
|  "leftmost (Node l r) = leftmost l"

ML\<open>Hipster_Explore.explore  @{context} ["Tree.mirror","Tree.tmap", "Tree.rigthmost", "Tree.leftmost"];\<close>
lemma lemma_ab [thy_expl]: "leftmost (mirror x2) = rigthmost x2"
by (tactic \<open>Hipster_Tacs.induct_simp_metis @{context} @{thms Tree.mirror.simps Tree.tmap.simps Tree.rigthmost.simps Tree.leftmost.simps thy_expl}\<close>)

fun flat_tree :: "'a Tree => 'a list"
where
  "flat_tree (Leaf x) = Cons x []"
| "flat_tree (Node l r) = (flat_tree l) @ (flat_tree r)"

ML\<open>Hipster_Explore.explore  @{context} ["Tree.flat_tree", "Tree.mirror", "Tree.tmap", "Tree.leftmost", "Tree.rigthmost","List.rev", "List.map", "List.hd", "List.append"];\<close>
lemma lemma_ac [thy_expl]: "flat_tree (tmap x2 y2) = map x2 (flat_tree y2)"
by hipster_induct_simp_metis
(*by (tactic {* Hipster_Tacs.induct_simp_metis @{context} @{thms Tree.flat_tree.simps Tree.mirror.simps Tree.tmap.simps Tree.leftmost.simps Tree.rigthmost.simps List.rev.simps List.map.simps List.hd.simps List.append.simps thy_expl} *})
*)

lemma lemma_ad [thy_expl]: "map x2 (rev xs2) = rev (map x2 xs2)"
by hipster_induct_simp_metis
(*by (tactic {* Hipster_Tacs.induct_simp_metis @{context} @{thms Tree.flat_tree.simps Tree.mirror.simps Tree.tmap.simps Tree.leftmost.simps Tree.rigthmost.simps List.rev.simps List.map.simps List.hd.simps List.append.simps thy_expl} *})
*)

lemma lemma_ae [thy_expl]: "flat_tree (mirror x2) = rev (flat_tree x2)"
by hipster_induct_simp_metis
(*by (tactic {* Hipster_Tacs.induct_simp_metis @{context} @{thms Tree.flat_tree.simps Tree.mirror.simps Tree.tmap.simps Tree.leftmost.simps Tree.rigthmost.simps List.rev.simps List.map.simps List.hd.simps List.append.simps thy_expl} *})
*)

lemma lemma_af [thy_expl]: "hd (xs2 @ xs2) = hd xs2"
by hipster_induct_simp_metis
(*by (tactic {* Hipster_Tacs.induct_simp_metis @{context} @{thms Tree.flat_tree.simps Tree.mirror.simps Tree.tmap.simps Tree.leftmost.simps Tree.rigthmost.simps List.rev.simps List.map.simps List.hd.simps List.append.simps thy_expl} *})
*)
lemma unknown [thy_expl]: "hd (flat_tree x) = leftmost x"
oops

lemma flat_tree_non_emp[simp] : "flat_tree t \<noteq> []"
by(induct t, simp_all)

(* This lemma is discoved by Hipster, but cannot be proved. It is returned with an oops.
   This is because it needs the above three non-equational lemma, which isn't
   generated by QuickSpec in this case.
*)
lemma unproved_from_hipster : "hd (flat_tree x) = leftmost x"
by(induct x, simp_all)

end


(* Title: Models of Partial Semigroups
   Author: Brijesh Dongol, Victor Gomes, Ian J Hayes, Georg Struth
   Maintainer: Victor Gomes <victor.gomes@cl.cam.ac.uk>
               Georg Struth <g.struth@sheffield.ac.uk>
*)

section \<open>Models of Partial Semigroups\<close>

theory Partial_Semigroup_Models
  imports Partial_Semigroups

begin

text \<open>So far this section collects three models that we need for applications. Other interesting models might be
added in the future. These might include binary relations, formal power series and matrices, paths in graphs under fusion,
program traces with alternating state and action symbols under fusion, partial orders under series and parallel products.\<close>

subsection \<open>Partial Monoids of Segments and Intervals\<close>

text \<open>Segments of a partial order are sub partial orders between two points. Segments generalise
intervals in that intervals are segments in linear orders. We formalise segments and intervals as pairs,
where the first coordinate is smaller than the second one. Algebras of segments and intervals are interesting
in Rota's work on the foundations of combinatorics as well as for interval logics and duration calculi.\<close>

text \<open>First we define the subtype of ordered pairs of one single type.\<close>

typedef 'a dprod = "{(x::'a, y::'a). True}"
  by simp

setup_lifting type_definition_dprod

text \<open>Such pairs form partial semigroups and partial monoids with respect to fusion.\<close>

instantiation dprod :: (type) partial_semigroup
begin

lift_definition D_dprod :: "'a dprod \<Rightarrow> 'a dprod \<Rightarrow> bool" is "\<lambda>x y. (snd x = fst y)" .

lift_definition times_dprod :: "'a dprod \<Rightarrow> 'a dprod \<Rightarrow> 'a dprod" is "\<lambda>x y. (fst x, snd y)"
  by simp

instance
  by standard (transfer, force)+

end

instantiation "dprod" :: (type) partial_monoid
begin

lift_definition E_dprod :: "'a dprod set" is "{x. fst x = snd x}"
  by simp

instance
  by standard (transfer,force)+

end

text \<open>Next we define the type of segments.\<close>

typedef (overloaded) 'a segment = "{x::('a::order \<times> 'a::order). fst x \<le> snd x}"
  by force

setup_lifting type_definition_segment

text \<open>Segments form partial monoids as well.\<close>

instantiation segment :: (order) partial_monoid
begin

lift_definition E_segment :: "'a segment set" is "{x. fst x = snd x}"
  by simp

lift_definition D_segment :: "'a::order segment \<Rightarrow> 'a segment \<Rightarrow> bool"
  is "\<lambda>x y. (snd x = fst y)" .

lift_definition times_segment :: "'a::order segment \<Rightarrow> 'a segment \<Rightarrow> 'a segment"
  is "\<lambda>x y. if snd x = fst y then (fst x, snd y) else x"
  by auto

instance
  by standard (transfer, force)+

end

text \<open>Next we define the function segm that maps segments-as-pairs to segments-as-sets.\<close>

definition segm :: "'a::order segment \<Rightarrow> 'a set" where
  "segm x = {y. fst (Rep_segment x) \<le> y \<and> y \<le> snd (Rep_segment x)}"

  thm Rep_segment

lemma segm_sub_morph: "snd (Rep_segment x) = fst (Rep_segment y) \<Longrightarrow> segm x \<union> segm y \<le> segm (x \<cdot> y)"
  apply (simp add: segm_def times_segment.rep_eq, safe)
  using Rep_segment dual_order.trans apply blast
  by (metis (mono_tags, lifting) Rep_segment dual_order.trans mem_Collect_eq)

text \<open>The function segm is not generally a morphism.\<close>

lemma "snd (Rep_segment x) = fst (Rep_segment y) \<Longrightarrow> segm x \<union> segm y = segm (x \<cdot> y)" (* nitpick [expect=genuine] *)
oops

text \<open>Intervals are segments over orders that satisfy Halpern and Shoham's  linear order property. This
is still more general than linearity of the poset.\<close>

class lip_order = order +
  assumes lip: "x \<le> y \<Longrightarrow> (\<forall>v w. (x \<le> v \<and> v \<le> y \<and> x \<le> w \<and> w \<le> y \<longrightarrow> v \<le> w \<or> w \<le> v))"

text \<open>The function segm is now a morphism.\<close>

lemma segm_morph: "snd (Rep_segment x::('a::lip_order \<times> 'a::lip_order)) = fst (Rep_segment y)
    \<Longrightarrow> segm x \<union> segm y = segm (x \<cdot> y)"
  apply (simp add: segm_def times_segment_def)
  apply (transfer, clarsimp simp add: Abs_segment_inverse lip, safe)
  apply force+
  by (meson lip order_trans)

subsection \<open>Cancellative PAM's of Partial Functions\<close>

text \<open>We show that partial functions under disjoint union form a positive cancellative PAM.
This is interesting for modeling the heap in separation logic.\<close>

type_synonym 'a pfun = "'a \<Rightarrow> 'a option"

definition ortho :: "'a pfun \<Rightarrow> 'a pfun \<Rightarrow> bool"
  where "ortho f g \<equiv> dom f \<inter> dom g = {}"

lemma pfun_comm: "ortho x y \<Longrightarrow> x ++ y = y ++ x"
  by (force simp: ortho_def intro!: map_add_comm)

lemma pfun_canc: "ortho z x \<Longrightarrow> ortho z y \<Longrightarrow> z ++ x = z ++ y \<Longrightarrow> x = y"
  apply (auto simp: ortho_def map_add_def option.case_eq_if fun_eq_iff)
  by (metis domIff dom_restrict option.collapse restrict_map_def)

interpretation pfun: positive_cancellative_pam_one map_add ortho "{Map.empty}" Map.empty
  apply (standard, auto simp: ortho_def pfun_canc)
  by (simp_all add: inf_commute map_add_comm ortho_def pfun_canc)

subsection \<open>PAM's of Disjoint Unions of Sets\<close>

text \<open>This simple disjoint union construction underlies important compositions of graphs or partial orders,
in particular in the context of complete joins and disjoint unions of graphs and of series and parallel products
of partial orders.\<close>

instantiation set :: (type) pas
begin

definition D_set :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool" where
  "D_set x y \<equiv> x \<inter> y = {}"

definition times_set :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a set" where
  "times_set x y = x \<union> y"

instance
  by standard (auto simp: D_set_def times_set_def)

end

instantiation set :: (type) pam
begin

definition E_set :: "'a set set" where
  "E_set = {{}}"

instance
  by standard (auto simp: D_set_def times_set_def E_set_def)

end

end


(* Title:      Algebras for Aggregation and Minimisation
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>Algebras for Aggregation and Minimisation\<close>

text \<open>
This theory gives algebras with operations for aggregation and minimisation.
In the weighted-graph model of matrices over (extended) numbers, the operations have the following meaning.
The binary operation $+$ adds the weights of corresponding edges of two graphs.
Addition does not have to be the standard addition on numbers, but can be any aggregation satisfying certain basic properties as demonstrated by various models of the algebras in another theory.
The unary operation \<open>sum\<close> adds the weights of all edges of a graph.
The result is a single aggregated weight using the same aggregation as $+$ but applied internally to the edges of a single graph.
The unary operation \<open>minarc\<close> finds an edge with a minimal weight in a graph.
It yields the position of such an edge as a regular element of a Stone relation algebra.

We give axioms for these operations which are sufficient to prove the correctness of Prim's and Kruskal's minimum spanning tree algorithms.
The operations have been proposed and axiomatised first in \<^cite>\<open>"Guttmann2016c"\<close> with simplified axioms given in \<^cite>\<open>"Guttmann2018a"\<close>.
The present version adds two axioms to prove total correctness of the spanning tree algorithms as discussed in \<^cite>\<open>"Guttmann2018b"\<close>.
\<close>

theory Aggregation_Algebras

imports Stone_Kleene_Relation_Algebras.Kleene_Relation_Algebras

begin

context sup
begin

no_notation
  sup (infixl "+" 65)

end

context plus
begin

notation
  plus (infixl "+" 65)

end

text \<open>
We first introduce s-algebras as a class with the operations $+$ and \<open>sum\<close>.
Axiom \<open>sum_plus_right_isotone\<close> states that for non-empty graphs, the operation $+$ is $\leq$-isotone in its second argument on the image of the aggregation operation \<open>sum\<close>.
Axiom \<open>sum_bot\<close> expresses that the empty graph contributes no weight.
Axiom \<open>sum_plus\<close> generalises the inclusion-exclusion principle to sets of weights.
Axiom \<open>sum_conv\<close> specifies that reversing edge directions does not change the aggregated weight.
In instances of \<open>s_algebra\<close>, aggregated weights can be partially ordered.
\<close>

class sum =
  fixes sum :: "'a \<Rightarrow> 'a"

class s_algebra = stone_relation_algebra + plus + sum +
  assumes sum_plus_right_isotone: "x \<noteq> bot \<and> sum x \<le> sum y \<longrightarrow> sum z + sum x \<le> sum z + sum y"
  assumes sum_bot: "sum x + sum bot = sum x"
  assumes sum_plus: "sum x + sum y = sum (x \<squnion> y) + sum (x \<sqinter> y)"
  assumes sum_conv: "sum (x\<^sup>T) = sum x"
begin

lemma sum_disjoint:
  assumes "x \<sqinter> y = bot"
    shows "sum ((x \<squnion> y) \<sqinter> z) = sum (x \<sqinter> z) + sum (y \<sqinter> z)"
  by (subst sum_plus) (metis assms inf.sup_monoid.add_assoc inf.sup_monoid.add_commute inf_bot_left inf_sup_distrib2 sum_bot)

lemma sum_disjoint_3:
  assumes "w \<sqinter> x = bot"
      and "w \<sqinter> y = bot"
      and "x \<sqinter> y = bot"
    shows "sum ((w \<squnion> x \<squnion> y) \<sqinter> z) = sum (w \<sqinter> z) + sum (x \<sqinter> z) + sum (y \<sqinter> z)"
  by (metis assms inf_sup_distrib2 sup_idem sum_disjoint)

lemma sum_symmetric:
  assumes "y = y\<^sup>T"
    shows "sum (x\<^sup>T \<sqinter> y) = sum (x \<sqinter> y)"
  by (metis assms sum_conv conv_dist_inf)

lemma sum_commute:
  "sum x + sum y = sum y + sum x"
  by (metis inf_commute sum_plus sup_commute)

end

text \<open>
We next introduce the operation \<open>minarc\<close>.
Axiom \<open>minarc_below\<close> expresses that the result of \<open>minarc\<close> is contained in the graph ignoring the weights.
Axiom \<open>minarc_arc\<close> states that the result of \<open>minarc\<close> is a single unweighted edge if the graph is not empty.
Axiom \<open>minarc_min\<close> specifies that any edge in the graph weighs at least as much as the edge at the position indicated by the result of \<open>minarc\<close>, where weights of edges between different nodes are compared by applying the operation \<open>sum\<close> to single-edge graphs.
Axiom \<open>sum_linear\<close> requires that aggregated weights are linearly ordered, which is necessary for both Prim's and Kruskal's minimum spanning tree algorithms.
Axiom \<open>finite_regular\<close> ensures that there are only finitely many unweighted graphs, and therefore only finitely many edges and nodes in a graph; again this is necessary for the minimum spanning tree algorithms we consider.
\<close>

class minarc =
  fixes minarc :: "'a \<Rightarrow> 'a"

class m_algebra = s_algebra + minarc +
  assumes minarc_below: "minarc x \<le> --x"
  assumes minarc_arc: "x \<noteq> bot \<longrightarrow> arc (minarc x)"
  assumes minarc_min: "arc y \<and> y \<sqinter> x \<noteq> bot \<longrightarrow> sum (minarc x \<sqinter> x) \<le> sum (y \<sqinter> x)"
  assumes sum_linear: "sum x \<le> sum y \<or> sum y \<le> sum x"
  assumes finite_regular: "finite { x . regular x }"
begin

text \<open>
Axioms \<open>minarc_below\<close> and \<open>minarc_arc\<close> suffice to derive the Tarski rule in Stone relation algebras.
\<close>

subclass stone_relation_algebra_tarski
proof unfold_locales
  fix x
  let ?a = "minarc x"
  assume 1: "regular x"
  assume "x \<noteq> bot"
  hence "arc ?a"
    by (simp add: minarc_arc)
  hence "top = top * ?a * top"
    by (simp add: comp_associative)
  also have "... \<le> top * --x * top"
    by (simp add: minarc_below mult_isotone)
  finally show "top * x * top = top"
    using 1 order.antisym by simp
qed

lemma minarc_bot:
  "minarc bot = bot"
  by (metis bot_unique minarc_below regular_closed_bot)

lemma minarc_bot_iff:
  "minarc x = bot \<longleftrightarrow> x = bot"
  using covector_bot_closed inf_bot_right minarc_arc vector_bot_closed minarc_bot by fastforce

lemma minarc_meet_bot:
  assumes "minarc x \<sqinter> x = bot"
    shows "minarc x = bot"
proof -
  have "minarc x \<le> -x"
    using assms pseudo_complement by auto
  thus ?thesis
    by (metis minarc_below inf_absorb1 inf_import_p inf_p)
qed

lemma minarc_meet_bot_iff:
  "minarc x \<sqinter> x = bot \<longleftrightarrow> x = bot"
  using inf_bot_right minarc_bot_iff minarc_meet_bot by blast

lemma minarc_regular:
  "regular (minarc x)"
proof (cases "x = bot")
  assume "x = bot"
  thus ?thesis
    by (simp add: minarc_bot)
next
  assume "x \<noteq> bot"
  thus ?thesis
    by (simp add: arc_regular minarc_arc)
qed

lemma minarc_selection:
  "selection (minarc x \<sqinter> y) y"
  using inf_assoc minarc_regular selection_closed_id by auto

(*
lemma sum_bot: "sum bot = bot" nitpick [expect=genuine] oops
lemma plus_bot: "x + bot = x" nitpick [expect=genuine] oops
lemma "sum x = bot \<longrightarrow> x = bot" nitpick [expect=genuine] oops
*)

end

class m_kleene_algebra = m_algebra + stone_kleene_relation_algebra

end


theory Homework5_2sol
imports Main
begin

  (*
    ISSUED: Wednesday, October 18
    DUE: Wednesday, October 25, 11:59pm
    POINTS: 5
  *)

  (*
    In a directed graph, a path from node q to node v is the list of nodes
    visited on the way from q to v, including the first node, and excluding
    the last node.

    Inductively, we can characterize paths as follows:
  *)
  inductive path :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a \<Rightarrow> bool" where
    "path E q [] q"
  | "\<lbrakk> E p q; path E q w r \<rbrakk> \<Longrightarrow> path E p (p#w) r"

  (*
    Functionally, we have the following characterization:
  *)
  lemma path_Nil_conv: "path E p [] q \<longleftrightarrow> q=p"
    by (auto elim: path.cases intro: path.intros)

  lemma path_Cons_conv: "path E p (x#xs) q \<longleftrightarrow> (x=p \<and> (\<exists>r. E p r \<and> path E r xs q))"
    by (auto elim: path.cases intro: path.intros)

  (* Prove the equivalence rule for appending two paths.
    Hint: Induction on w1, use the path_Nil_conv and path_Cons_conv
      lemmas as simp-rules. Proof should be straightforward, probably no Isar required.
  *)
  lemma path_append_conv: "path E p (w1@w2) q \<longleftrightarrow> (\<exists>r. path E p w1 r \<and> path E r w2 q)"
    by (induction w1 arbitrary: p) (auto simp: path_Nil_conv path_Cons_conv)

  (*
    A path is called simple, if it visits each node at most once
    (except for circular path, that, of course, visit their common
      start and end node twice)

    For our path definition, a path is simple if and only if it contains
    no node twice (Isabelle constant: distinct). Recall, the end node is excluded.

    Show: If there is a path from p to q, then there is also a
      simple path from p to q.

    Proof sketch (informal):
      Induction on the length of the path (rule: length_induct)
        Assume we have a path xs from p to q.
        IH: For all shorter path, we can find a simple path
        To show: There is a simple path from p to q

        If xs is already distinct, we are done.
        Otherwise, xs must have the form xs = xs1@[x]@xs2@[x]@xs3 (thm not_distinct_decomp)
        hence, we obtain nodes p1 p2 such that
          p -xs1\<rightarrow> x   x\<rightarrow>p1   p1 -xs2\<rightarrow> x   x\<rightarrow>p2   p2 -xs3\<rightarrow> q

        Here, p -xs\<rightarrow> q denotes a path, and p\<rightarrow>q a single edge.

        by "dropping" the loop, we obtain a path  p -xs1@[x]@xs3\<rightarrow> q
        this path is shorter than the original path, so by IH, we have a simple path from p to q.
        QED.

    Prove the lemma formally. Most probably, you will need Isar!
  *)
  lemma
    assumes "path E p xs q"
    shows "\<exists>ys. distinct ys \<and> path E p ys q"
    using assms
  proof (induction xs rule: length_induct)
    case (1 xs)

    note PREMS="1.prems"
    note IH="1.IH"

    thm PREMS (* We may assume that we have a path*)
    thm IH    (* For shorter path, there exists distinct paths *)
    term ?case (* We have to show that there exists a distinct path *)

    show ?case
    (*<*)
    proof cases
      assume "distinct xs"
      thus ?thesis using "1.prems" by auto
    next
      assume "\<not>distinct xs"
      then obtain xs1 xs2 xs3 x where XS: "xs=xs1@[x]@xs2@[x]@xs3"
        using not_distinct_decomp by blast
      with "1.prems" obtain p1 p2 where
        "path E p xs1 x" "E x p1" "path E p1 xs2 x" "E x p2" "path E p2 xs3 q"
        by (auto simp: path_Nil_conv path_append_conv path_Cons_conv)
      hence "path E p (xs1@[x]@xs3) q"
        by (auto simp: path_Nil_conv path_append_conv path_Cons_conv)
      with "1.IH" XS obtain ys where "distinct ys" "path E p ys q"
        by force
      thus ?case by blast
    qed
    (*>*)
  qed

end