(* Author: Lukas Bulwahn <lukas.bulwahn-at-gmail.com> *)

section \<open>Derangements\<close>

theory Derangements
imports
  Complex_Main
  "HOL-Library.Permutations"
begin

subsection \<open>Preliminaries\<close>

subsubsection \<open>Additions to @{theory HOL.Finite_Set} Theory\<close>

lemma card_product_dependent:
  assumes "finite S" "\<forall>x \<in> S. finite (T x)"
  shows "card {(x, y). x \<in> S \<and> y \<in> T x} = (\<Sum>x \<in> S. card (T x))"
using card_SigmaI[OF assms, symmetric] by (auto intro!: arg_cong[where f=card] simp add: Sigma_def)

subsubsection \<open>Additions to @{theory "HOL-Library.Permutations"} Theory\<close>

lemma permutes_imp_bij':
  assumes "p permutes S"
  shows "bij p"
using assms by (meson bij_def permutes_inj permutes_surj)

lemma permutesE:
  assumes "p permutes S"
  obtains "bij p" "\<forall>x. x \<notin> S \<longrightarrow> p x = x"
using assms by (simp add: permutes_def permutes_imp_bij')

lemma bij_imp_permutes':
  assumes "bij p" "\<forall>x. x \<notin> A \<longrightarrow> p x = x"
  shows  "p permutes A"
using assms bij_imp_permutes permutes_superset by force

lemma permutes_swap:
  assumes "p permutes S"
  shows "Fun.swap x y p permutes (insert x (insert y S))"
proof -
  from assms have "p permutes (insert x (insert y S))" by (meson permutes_subset subset_insertI)
  moreover have "Fun.swap x y id permutes (insert x (insert y S))" by (simp add: permutes_swap_id)
  ultimately show "Fun.swap x y p permutes (insert x (insert y S))"
    by (metis comp_id comp_swap permutes_compose)
qed

lemma bij_extends:
  "bij p \<Longrightarrow> p x = x \<Longrightarrow> bij (p(x := y, inv p y := x))"
unfolding bij_def
proof (rule conjI; erule conjE)
  assume a: "inj p" "p x = x"
  show "inj (p(x := y, inv p y := x))"
  proof (intro injI)
    fix z z'
    assume "(p(x := y, inv p y := x)) z = (p(x := y, inv p y := x)) z'"
    from this a show "z = z'"
      by (auto split: if_split_asm simp add: inv_f_eq inj_eq)
  qed
next
  assume a: "inj p" "surj p" "p x = x"
  {
    fix x'
    from a have "(p(x := y, inv p y := x)) (((inv p)(y := x, x := inv p y)) x') = x'"
      by (auto split: if_split_asm) (metis surj_f_inv_f)+
  }
  from this show "surj (p(x := y, inv p y := x))" by (metis surjI)
qed

lemma permutes_add_one:
  assumes "p permutes S" "x \<notin> S" "y \<in> S"
  shows "p(x := y, inv p y := x) permutes (insert x S)"
proof (rule bij_imp_permutes')
  from assms show "bij (p(x := y, inv p y := x))"
    by (meson bij_extends permutes_def permutes_imp_bij')
  from assms show "\<forall>z. z \<notin> insert x S \<longrightarrow> (p(x := y, inv p y := x)) z = z"
    by (metis fun_upd_apply insertCI permutes_def permutes_inverses(1))
qed

lemma permutations_skip_one:
  assumes "p permutes S" "x : S"
  shows "p(x := x, inv p x := p x) permutes (S - {x})"
proof (rule bij_imp_permutes')
  from assms show "\<forall>z. z \<notin> S - {x} \<longrightarrow> (p(x := x, inv p x := p x)) z = z"
    by (auto elim: permutesE simp add: bij_inv_eq_iff)
      (simp add: assms(1) permutes_in_image permutes_inv)
  from assms have "inj (p(x := x, inv p x := p x))"
    by (intro injI) (auto split: if_split_asm; metis permutes_inverses(2))+
  from assms this show "bij (p(x := x, inv p x := p x))"
    by (metis UNIV_I bij_betw_imageI bij_betw_swap_iff permutes_inj permutes_surj surj_f_inv_f swap_def)
qed

lemma permutes_drop_cycle_size_two:
  assumes "p permutes S" "p (p x) = x"
  shows "Fun.swap x (p x) p permutes (S - {x, p x})"
using assms by (auto intro!: bij_imp_permutes' elim!: permutesE) (metis swap_apply(1,3))

subsection \<open>Fixpoint-Free Permutations\<close>

definition derangements :: "nat set \<Rightarrow> (nat \<Rightarrow> nat) set"
where
  "derangements S = {p. p permutes S \<and> (\<forall>x \<in> S. p x \<noteq> x)}"

lemma derangementsI:
  assumes "p permutes S" "\<And>x. x \<in> S \<Longrightarrow> p x \<noteq> x"
  shows "p \<in> derangements S"
using assms unfolding derangements_def by auto

lemma derangementsE:
  assumes "d : derangements S"
  obtains "d permutes S" "\<forall>x\<in>S. d x \<noteq> x"
using assms unfolding derangements_def by auto

subsection \<open>Properties of Derangements\<close>

lemma derangements_inv:
  assumes d: "d \<in> derangements S"
  shows "inv d \<in> derangements S"
using assms
by (auto intro!: derangementsI elim!: derangementsE simp add: permutes_inv permutes_inv_eq)

lemma derangements_in_image:
  assumes "d \<in> derangements A" "x \<in> A"
  shows "d x \<in> A"
using assms by (auto elim: derangementsE simp add: permutes_in_image)

lemma derangements_in_image_strong:
  assumes "d \<in> derangements A" "x \<in> A"
  shows "d x \<in> A - {x}"
using assms by (auto elim: derangementsE simp add: permutes_in_image)

lemma derangements_inverse_in_image:
  assumes "d \<in> derangements A" "x \<in> A"
  shows "inv d x \<in> A"
using assms by (auto intro: derangements_in_image derangements_inv)

lemma derangements_fixpoint:
  assumes "d \<in> derangements A" "x \<notin> A"
  shows "d x = x"
using assms by (auto elim!: derangementsE simp add: permutes_def)

lemma finite_derangements:
  assumes "finite A"
  shows "finite (derangements A)"
using assms unfolding derangements_def
by (auto simp add: finite_permutations)

subsection \<open>Construction of Derangements\<close>

lemma derangements_empty[simp]:
  "derangements {} = {id}"
unfolding derangements_def by auto

lemma derangements_singleton[simp]:
  "derangements {x} = {}"
unfolding derangements_def by auto

lemma derangements_swap:
  assumes "d \<in> derangements S" "x \<notin> S" "y \<notin> S" "x \<noteq> y"
  shows "Fun.swap x y d \<in> derangements (insert x (insert y S))"
proof (rule derangementsI)
  from assms show "Fun.swap x y d permutes (insert x (insert y S))"
    by (auto intro: permutes_swap elim: derangementsE)
  from assms have s: "d x = x" "d y = y"
    by (auto intro: derangements_fixpoint)
  {
    fix x'
    assume "x' : insert x (insert y S)"
    from s assms \<open>x \<noteq> y\<close> this show "Fun.swap x y d x' \<noteq> x'"
      by (cases "x' = x"; cases "x' = y") (auto dest: derangements_no_fixpoint)
  }
qed

lemma derangements_skip_one:
  assumes d: "d \<in> derangements S" and "x \<in> S" "d (d x) \<noteq> x"
  shows "d(x := x, inv d x := d x) \<in> derangements (S - {x})"
proof -
  from d have bij: "bij d"
    by (auto elim: derangementsE simp add: permutes_imp_bij')
  from d \<open>x : S\<close> have that: "d x : S - {x}"
    by (auto dest: derangements_in_image derangements_no_fixpoint)
  from d \<open>d (d x) \<noteq> x\<close> bij have "\<forall>x'\<in>S - {x}. (d(x := x, inv d x := d x)) x' \<noteq> x'"
    by (auto elim!: derangementsE simp add: bij_inv_eq_iff)
  from d \<open>x : S\<close> this show derangements: "d(x:=x, inv d x:= d x) : derangements (S - {x})"
    by (meson derangementsE derangementsI permutations_skip_one)
qed

lemma derangements_add_one:
  assumes "d \<in> derangements S" "x \<notin> S" "y \<in> S"
  shows "d(x := y, inv d y := x) \<in> derangements (insert x S)"
proof (rule derangementsI)
  from assms show "d(x := y, inv d y := x) permutes (insert x S)"
   by (auto intro: permutes_add_one elim: derangementsE)
next
  fix z
  assume "z : insert x S"
  from assms this derangements_inverse_in_image[OF assms(1), of y]
  show "(d(x := y, inv d y := x)) z \<noteq> z" by (auto elim: derangementsE)
qed

lemma derangements_drop_minimal_cycle:
  assumes "d \<in> derangements S" "d (d x) = x"
  shows "Fun.swap x (d x) d \<in> derangements (S - {x, d x})"
proof (rule derangementsI)
  from assms show "Fun.swap x (d x) d permutes (S - {x, d x})"
    by (meson derangementsE permutes_drop_cycle_size_two)
next
  fix y
  assume "y \<in> S - {x, d x}"
  from assms this show "Fun.swap x (d x) d y \<noteq> y"
    by (auto elim: derangementsE)
qed

subsection \<open>Cardinality of Derangements\<close>

subsubsection \<open>Recursive Characterization\<close>

fun count_derangements :: "nat \<Rightarrow> nat"
where
  "count_derangements 0 = 1"
| "count_derangements (Suc 0) = 0"
| "count_derangements (Suc (Suc n)) = (n + 1) * (count_derangements (Suc n) + count_derangements n)"

lemma card_derangements:
  assumes "finite S" "card S = n"
  shows "card (derangements S) = count_derangements n"
using assms
proof (induct n arbitrary: S rule: count_derangements.induct)
  case 1
  from this show ?case by auto
next
  case 2
  from this derangements_singleton finite_derangements show ?case
    using Finite_Set.card_0_eq card_eq_SucD count_derangements.simps(2) by fastforce
next
  case (3 n)
  from 3(4) obtain x where "x \<in> S" using card_eq_SucD insertI1 by auto
  let ?D1 = "(\<lambda>(y, d). Fun.swap x y d) ` {(y, d). y \<in> S & y \<noteq> x & d : derangements (S - {x, y})}"
  let ?D2 = "(\<lambda>(y, f). f(x:=y, inv f y := x)) ` ((S - {x}) \<times> derangements (S - {x}))"
  from \<open>x \<in> S\<close> have subset1: "?D1 \<subseteq> derangements S"
  proof (auto)
    fix y d
    assume "y \<in> S" "y \<noteq> x"
    assume d: "d \<in> derangements (S - {x, y})"
    from \<open>x : S\<close> \<open>y : S\<close> have S: "S = insert x (insert y (S - {x, y}))" by auto
    from d \<open>x : S\<close> \<open>y : S\<close> \<open>y \<noteq> x\<close> show "Fun.swap x y d \<in> derangements S"
      by (subst S) (auto intro!: derangements_swap)
  qed
  have subset2: "?D2 \<subseteq> derangements S"
  proof (rule subsetI, erule imageE, simp split: prod.split_asm, (erule conjE)+)
    fix d y
    assume "d : derangements (S - {x})" "y : S" "y \<noteq> x"
    from this have "d(x := y, inv d y := x) \<in> derangements (insert x (S - {x}))"
      by (intro derangements_add_one) auto
    from this \<open>x : S\<close> show "d(x := y, inv d y := x) \<in> derangements S"
      using insert_Diff by fastforce
  qed
  have split: "derangements S = ?D1 \<union> ?D2"
  proof
    from subset1 subset2 show "?D1 \<union> ?D2 \<subseteq> derangements S" by simp
  next
    show "derangements S \<subseteq> ?D1 \<union> ?D2"
    proof
      fix d
      assume d: "d : derangements S"
      show "d : ?D1 \<union> ?D2"
      proof (cases "d (d x) = x")
        case True
        from \<open>x : S\<close> d have "d x \<in> S" "d x \<noteq> x"
          by (auto simp add: derangements_in_image derangements_no_fixpoint)
        from d True have "Fun.swap x (d x) d \<in> derangements (S - {x, d x})"
          by (rule derangements_drop_minimal_cycle)
        from \<open>d x \<in> S\<close> \<open>d x \<noteq> x\<close> this have "d : ?D1"
          by (auto intro: image_eqI[where x = "(d x, Fun.swap x (d x) d)"])
        from this show ?thesis by auto
      next
        case False
        from d have bij: "bij d"
          by (auto elim: derangementsE simp add: permutes_imp_bij')
        from d \<open>x : S\<close> have that: "d x : S - {x}"
          by (intro derangements_in_image_strong)
        from d \<open>x : S\<close> False have derangements: "d(x:=x, inv d x:= d x) : derangements (S - {x})"
          by (auto intro: derangements_skip_one)
        from this have "bij (d(x := x, inv d x:= d x))"
          by (metis derangementsE permutes_imp_bij')+
        from this have a: "inv (d(x := x, inv d x := d x)) (d x) = inv d x"
          by (metis bij_inv_eq_iff fun_upd_same)
        from bij have x: "d (inv d x) = x" by (meson bij_inv_eq_iff)
        from d derangements_inv[of d] \<open>x : S\<close> have "inv d x \<noteq> x" "d x \<noteq> x"
          by (auto dest: derangements_no_fixpoint)
        from this a x have d_eq: "d = d(inv d x := d x, x := d x, inv (d(x := x, inv d x := d x)) (d x) := x)"
          by auto
        from derangements that have "(d x, d(x:=x, inv d x:=d x)) : ((S - {x}) \<times> derangements (S - {x}))" by auto
        from d_eq this have "d : ?D2"
          by (auto intro: image_eqI[where x = "(d x, d(x:=x, inv d x:=d x))"])
        from this show ?thesis by auto
      qed
    qed
  qed
  have no_intersect: "?D1 \<inter> ?D2 = {}"
  proof -
    have that: "\<And>d. d \<in> ?D1 \<Longrightarrow> d (d x) = x"
      using Diff_iff Diff_insert2 derangements_fixpoint insertI1 swap_apply(2) by fastforce
    have "\<And>d. d \<in> ?D2 \<Longrightarrow> d (d x) \<noteq> x"
    proof -
      fix d
      assume a: "d \<in> ?D2"
      from a obtain y d' where d: "d = d'(x := y, inv d' y := x)"
        "d' \<in> derangements (S - {x})" "y \<in> S - {x}"
        by auto
      from d(2) have inv: "inv d' \<in> derangements (S - {x})"
        by (rule derangements_inv)
      from d have inv_x: "inv d' y \<noteq> x"
        by (auto dest: derangements_inverse_in_image)
      from inv have inv_y: "inv d' y \<noteq> y"
        using d(3) derangements_no_fixpoint by blast
      from d inv_x have 1: "d x = y" by auto
      from d inv_y have 2: "d y = d' y" by auto
      from d(2, 3) have 3: "d' y \<in> S - {x}"
        by (auto dest: derangements_in_image)
      from 1 2 3 show "d (d x) \<noteq> x" by auto
    qed
    from this that show ?thesis by blast
  qed
  have inj: "inj_on (\<lambda>(y, f). Fun.swap x y f) {(y, f). y \<in> S & y \<noteq> x & f : derangements (S - {x, y})}"
    unfolding inj_on_def
    by (clarify; metis DiffD2 derangements_fixpoint insertI1 insert_commute swap_apply(1) swap_nilpotent)
  have eq: "{(y, f). y \<in> S & y \<noteq> x & f : derangements (S - {x, y})} = {(y, f). y \<in> S - {x} & f : derangements (S - {x, y})}"
    by simp
  have eq': "{(y, f). y \<in> S & y \<noteq> x & f : derangements (S - {x, y})} = Sigma (S - {x}) (%y. derangements (S - {x, y}))"
    unfolding Sigma_def by auto
  have card: "\<And> y. y \<in> S - {x} \<Longrightarrow> card (derangements (S - {x, y})) = count_derangements n"
  proof -
    fix y
    assume "y \<in> S - {x}"
    from 3(3, 4) \<open>x \<in> S\<close> this have "card (S - {x, y}) = n"
      by (metis Diff_insert2 card_Diff_singleton diff_Suc_1 finite_Diff)
    from 3(3) 3(2)[OF _ this] show "card (derangements (S - {x, y})) = count_derangements n" by auto
  qed
  from 3(3, 4) \<open>x : S\<close> have card2: "card (S - {x}) = Suc n" by (simp add: card.insert_remove insert_absorb)
  from inj have "card ?D1 = card {(y, f). y \<in> S - {x} \<and> f \<in> derangements (S - {x, y})}"
    by (simp add: card_image)
  also from 3(3) have "... = (\<Sum>y\<in>S - {x}. card (derangements (S - {x, y})))"
    by (subst card_product_dependent) (simp add: finite_derangements)+
  finally have card_1: "card ?D1 =(Suc n) * count_derangements n"
    using card card2 by auto
  have inj_2: "inj_on (\<lambda>(y, f). f(x := y, inv f y := x)) ((S - {x}) \<times> derangements (S - {x}))"
  proof -
    {
      fix d d' y y'
      assume 1: "d \<in> derangements (S - {x})" "d' \<in> derangements (S - {x})"
      assume 2: "y \<in> S" "y \<noteq> x" "y' \<in> S" "y' \<noteq> x"
      assume eq: "d(x := y, inv d y := x) = d'(x := y', inv d' y' := x)"
      from 1 2 eq \<open>x \<in> S\<close> have y: "y = y'"
        by (metis Diff_insert_absorb derangements_in_image derangements_inv
          fun_upd_same fun_upd_twist insert_iff mk_disjoint_insert)
      have "d = d'"
      proof
        fix z
        from 1 have d_x: "d x = d' x"
          by (auto dest!: derangements_fixpoint)
        from 1 have bij: "bij d" "bij d'"
          by (metis derangementsE permutes_imp_bij')+
        from this have d_d: "d (inv d y) = y" "d' (inv d' y') = y'"
          by (simp add: bij_is_surj surj_f_inv_f)+
        from 1 2 bij have neq: "d (inv d' y') \<noteq> x \<and> d' (inv d y) \<noteq> x"
          by (metis Diff_iff bij_inv_eq_iff derangements_fixpoint singletonI)
        from eq have "(d(x := y, inv d y := x)) z = (d'(x := y', inv d' y' := x)) z" by auto
        from y d_x d_d neq this show "d z = d' z" by (auto split: if_split_asm)
      qed
      from y this have "y = y' & d = d'" by auto
    }
    from this show ?thesis
      unfolding inj_on_def by auto
  qed
  from 3(3) 3(1)[OF _ card2] have card3: "card (derangements (S - {x})) = count_derangements (Suc n)"
    by auto
  from 3(3) inj_2 have card_2: "card ?D2 = (Suc n) * count_derangements (Suc n)"
    by (simp only: card_image) (auto simp add: card_cartesian_product card3 card2)
  from \<open>finite S\<close>have finite1: "finite ?D1"
    unfolding eq' by (auto intro: finite_derangements)
  from \<open>finite S\<close> have finite2: "finite ?D2"
    by (auto intro: finite_cartesian_product finite_derangements)
  show ?case
    by (simp add: split card_Un_disjoint finite1 finite2 no_intersect card_1 card_2 field_simps)
qed

subsubsection \<open>Closed-Form Characterization\<close>

lemma count_derangements:
  "real (count_derangements n) = fact n * (\<Sum>k \<in> {0..n}. (-1) ^ k / fact k)"
proof (induct n rule: count_derangements.induct)
  case (3 n)
  let ?f = "\<lambda>n. fact n * (\<Sum>k = 0..n. (- 1) ^ k / fact k)"
  have "real (count_derangements (Suc (Suc n))) = (n + 1) * (count_derangements (n + 1) + count_derangements n)"
    unfolding count_derangements.simps by simp
  also have "... = real (n + 1) * (real (count_derangements (n + 1)) + real (count_derangements n))"
    by (simp only: of_nat_mult of_nat_add)
  also have "... = (n + 1) * (?f (n + 1) + ?f n)"
    unfolding 3(2) 3(1)[unfolded Suc_eq_plus1] ..
  also have "(n + 1) * (?f (n + 1) + ?f n) = ?f (n + 2)"
  proof -
    define f where "f n = ((fact n) :: real) * (\<Sum>k = 0..n. (- 1) ^ k / fact k)" for n
    have f_eq: "\<And>n. f (n + 1) = (n + 1) * f n + (- 1) ^ (n + 1)"
    proof -
      fix n
      have "?f (n + 1) = (n + 1) * fact n * (\<Sum>k = 0..n. (- 1) ^ k / fact k) + fact (n + 1) * ((- 1) ^ (n + 1) / fact (n + 1))"
        by (simp add: field_simps)
      also have "... = (n + 1) * ?f n + (- 1) ^ (n + 1)" by (simp del: One_nat_def)
      finally show "?thesis n" unfolding f_def by simp
    qed
    from this have f_eq': "\<And> n. (n + 1) * f n = f (n + 1) + (- 1) ^ n" by auto
    from f_eq'[of n] have "(n + 1) * (f (n + 1) + f n) = ((n + 1) * f (n + 1)) + f (n + 1) + (- 1) ^ n"
      by (simp only: distrib_left of_nat_add of_nat_1)
    also have "... = (n + 2) * f (n + 1) + (- 1) ^ (n + 2)"
      by (simp del: One_nat_def add_2_eq_Suc' add: algebra_simps) simp
    also from f_eq[of "n + 1"] have "... = f (n + 2)" by simp
    finally show ?thesis unfolding f_def by simp
  qed
  finally show ?case by simp
qed (auto)

subsubsection \<open>Approximation of Cardinality\<close>

lemma two_power_fact_le_fact:
  assumes "n \<ge> 1"
  shows   "2^k * fact n \<le> (fact (n + k) :: 'a :: {semiring_char_0,linordered_semidom})"
proof (induction k)
  case (Suc k)
  have "2 ^ Suc k * fact n = 2 * (2 ^ k * fact n)" by (simp add: algebra_simps)
  also note Suc.IH
  also from assms have "of_nat 1 + of_nat 1 \<le> of_nat n + (of_nat (Suc k) :: 'a)"
    by (intro add_mono) (unfold of_nat_le_iff, simp_all)
  hence "2 * (fact (n + k) :: 'a) \<le> of_nat (n + Suc k) * fact (n + k)"
    by (intro mult_right_mono) (simp_all add: add_ac)
  also have "\<dots> = fact (n + Suc k)" by simp
  finally show ?case by - (simp add: mult_left_mono)
qed simp_all

lemma exp1_approx:
  assumes "n > 0"
  shows   "exp (1::real) - (\<Sum>k<n. 1 / fact k) \<in> {0..2 / fact n}"
proof (unfold atLeastAtMost_iff, safe)
  have "(\<lambda>k. 1^k / fact k) sums exp (1::real)"
    using exp_converges[of "1::real"] by (simp add: field_simps)
  from sums_split_initial_segment[OF this, of n]
    have sums: "(\<lambda>k. 1 / fact (n+k)) sums (exp 1 - (\<Sum>k<n. 1 / fact k :: real))"
    by (simp add:  algebra_simps power_add)
  from assms show "(exp 1 - (\<Sum>k<n. 1 / fact k :: real)) \<ge> 0"
    by (intro sums_le[OF _ sums_zero sums]) auto
  show "(exp 1 - (\<Sum>k<n. 1 / fact k :: real)) \<le> 2 / fact n"
  proof (rule sums_le[OF allI])
    from assms have "(\<lambda>k. (1 / fact n) * (1 / 2)^k :: real) sums ((1 / fact n) * (1 / (1 - 1 / 2)))"
      by (intro sums_mult geometric_sums) simp_all
    also have "\<dots> = 2 / fact n" by simp
    finally show "(\<lambda>k. 1 / fact n * (1 / 2) ^ k) sums (2 / fact n :: real)" .
  next
    fix k show "(1 / fact (n+k)) \<le> (1 / fact n) * (1 / 2 :: real)^k" for k
      using two_power_fact_le_fact[of n k] assms by (auto simp: field_simps)
  qed fact+
qed

lemma exp1_bounds: "exp 1 \<in> {8 / 3..11 / 4 :: real}"
  using exp1_approx[of 4] by (simp add: eval_nat_numeral)

lemma count_derangements_approximation:
  assumes "n \<noteq> 0"
  shows "abs(real (count_derangements n) - fact n / exp 1) < 1 / 2"
proof (cases "n \<ge> 5")
  case False
  from assms this have n: "n = 1 \<or> n = 2 \<or> n = 3 \<or> n = 4" by auto
  from exp1_bounds have 1: "abs(real (count_derangements 1) - fact 1 / exp 1) < 1 / 2"
    by simp
  from exp1_bounds have 2: "abs(real (count_derangements 2) - fact 2 / exp 1) < 1 / 2"
    by (auto simp add: eval_nat_numeral abs_real_def)
  from exp1_bounds have 3: "abs(real (count_derangements 3) - fact 3 / exp 1) < 1 / 2"
    by (auto simp add: eval_nat_numeral abs_if field_simps)
  from exp1_bounds have 4: "abs(real (count_derangements 4) - fact 4 / exp 1) < 1 / 2"
    by (auto simp: abs_if field_simps eval_nat_numeral)
  from 1 2 3 4 n show ?thesis by auto
next
  case True
  from Maclaurin_exp_le[of "- 1" "n + 1"]
  obtain t where t: "abs (t :: real) \<le> abs (- 1)"
    and exp: "exp (- 1) = (\<Sum>m<n + 1. (- 1) ^ m / fact m) + exp t / fact (n + 1) * (- 1) ^ (n + 1)"
    by blast
  from exp have sum_eq_exp:
    "(\<Sum>k = 0..n. (- 1) ^ k / fact k) = exp (- 1) - exp t / fact (n + 1) * (- 1) ^ (n + 1)"
    by (simp add: atLeast0AtMost ivl_disj_un(2)[symmetric])
  have fact_plus1: "fact (n + 1) = (n + 1) * fact n" by simp
  have eq: "\<bar>real (count_derangements n) - fact n / exp 1\<bar> = exp t / (n + 1)"
    by (simp del: One_nat_def
             add: count_derangements sum_eq_exp exp_minus inverse_eq_divide algebra_simps abs_mult)
       (simp add: fact_plus1)
  from t have "exp t \<le> exp 1" by simp
  also from exp1_bounds have "\<dots> < 3" by simp
  finally show ?thesis using \<open>n \<ge> 5\<close> by (simp add: eq)
qed

theorem derangements_formula:
  assumes "n \<noteq> 0" "finite S" "card S = n"
  shows "int (card (derangements S)) = round (fact n / exp 1 :: real)"
  using count_derangements_approximation[of n] assms
  by (intro round_unique' [symmetric]) (auto simp: card_derangements abs_minus_commute)

theorem derangements_formula':
  assumes "n \<noteq> 0" "finite S" "card S = n"
  shows "card (derangements S) = nat (round (fact n / exp 1 :: real))"
  using derangements_formula[OF assms] by simp

end


(*
  File:      Epistemic_Logic.thy
  Author:    Asta Halkjær From

  This work is a formalization of epistemic logic.
  It includes proofs of soundness and completeness for the axiom system K.
  The completeness proof is based on the textbook "Reasoning About Knowledge"
  by Fagin, Halpern, Moses and Vardi (MIT Press 1995).
  The extensions of system K (T, KB, K4, S4, S5) and their completeness proofs
  are based on the textbook "Modal Logic" by Blackburn, de Rijke and Venema
  (Cambridge University Press 2001).
*)

theory Epistemic_Logic imports Maximal_Consistent_Sets begin

section \<open>Syntax\<close>

type_synonym id = string

datatype 'i fm
  = FF (\<open>\<^bold>\<bottom>\<close>)
  | Pro id
  | Dis \<open>'i fm\<close> \<open>'i fm\<close> (infixr \<open>\<^bold>\<or>\<close> 60)
  | Con \<open>'i fm\<close> \<open>'i fm\<close> (infixr \<open>\<^bold>\<and>\<close> 65)
  | Imp \<open>'i fm\<close> \<open>'i fm\<close> (infixr \<open>\<^bold>\<longrightarrow>\<close> 55)
  | K 'i \<open>'i fm\<close>

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

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

abbreviation \<open>L i p \<equiv> \<^bold>\<not> K i (\<^bold>\<not> p)\<close>

section \<open>Semantics\<close>

record ('i, 'w) frame =
  \<W> :: \<open>'w set\<close>
  \<K> :: \<open>'i \<Rightarrow> 'w \<Rightarrow> 'w set\<close>

record ('i, 'w) kripke =
  \<open>('i, 'w) frame\<close> +
  \<pi> :: \<open>'w \<Rightarrow> id \<Rightarrow> bool\<close>

primrec semantics :: \<open>('i, 'w) kripke \<Rightarrow> 'w \<Rightarrow> 'i fm \<Rightarrow> bool\<close> (\<open>_, _ \<Turnstile> _\<close> [50, 50, 50] 50) where
  \<open>M, w \<Turnstile> \<^bold>\<bottom> \<longleftrightarrow> False\<close>
| \<open>M, w \<Turnstile> Pro x \<longleftrightarrow> \<pi> M w x\<close>
| \<open>M, w \<Turnstile> p \<^bold>\<or> q \<longleftrightarrow> M, w \<Turnstile> p \<or> M, w \<Turnstile> q\<close>
| \<open>M, w \<Turnstile> p \<^bold>\<and> q \<longleftrightarrow> M, w \<Turnstile> p \<and> M, w \<Turnstile> q\<close>
| \<open>M, w \<Turnstile> p \<^bold>\<longrightarrow> q \<longleftrightarrow> M, w \<Turnstile> p \<longrightarrow> M, w \<Turnstile> q\<close>
| \<open>M, w \<Turnstile> K i p \<longleftrightarrow> (\<forall>v \<in> \<W> M \<inter> \<K> M i w. M, v \<Turnstile> p)\<close>

abbreviation validStar :: \<open>(('i, 'w) kripke \<Rightarrow> bool) \<Rightarrow> 'i fm set \<Rightarrow> 'i fm \<Rightarrow> bool\<close>
  (\<open>_; _ \<TTurnstile>\<star> _\<close> [50, 50, 50] 50) where
  \<open>P; G \<TTurnstile>\<star> p \<equiv> \<forall>M. P M \<longrightarrow>
    (\<forall>w \<in> \<W> M. (\<forall>q \<in> G. M, w \<Turnstile> q) \<longrightarrow> M, w \<Turnstile> p)\<close>

section \<open>S5 Axioms\<close>

definition reflexive :: \<open>('i, 'w, 'c) frame_scheme \<Rightarrow> bool\<close> where
  \<open>reflexive M \<equiv> \<forall>i. \<forall>w \<in> \<W> M. w \<in> \<K> M i w\<close>

definition symmetric :: \<open>('i, 'w, 'c) frame_scheme \<Rightarrow> bool\<close> where
  \<open>symmetric M \<equiv> \<forall>i. \<forall>v \<in> \<W> M. \<forall>w \<in> \<W> M. v \<in> \<K> M i w \<longleftrightarrow> w \<in> \<K> M i v\<close>

definition transitive :: \<open>('i, 'w, 'c) frame_scheme \<Rightarrow> bool\<close> where
  \<open>transitive M \<equiv> \<forall>i. \<forall>u \<in> \<W> M. \<forall>v \<in> \<W> M. \<forall>w \<in> \<W> M.
    w \<in> \<K> M i v \<and> u \<in> \<K> M i w \<longrightarrow> u \<in> \<K> M i v\<close>

abbreviation refltrans :: \<open>('i, 'w, 'c) frame_scheme \<Rightarrow> bool\<close> where
  \<open>refltrans M \<equiv> reflexive M \<and> transitive M\<close>

abbreviation equivalence :: \<open>('i, 'w, 'c) frame_scheme \<Rightarrow> bool\<close> where
  \<open>equivalence M \<equiv> reflexive M \<and> symmetric M \<and> transitive M\<close>

definition Euclidean :: \<open>('i, 'w, 'c) frame_scheme \<Rightarrow> bool\<close> where
  \<open>Euclidean M \<equiv> \<forall>i. \<forall>u \<in> \<W> M. \<forall>v \<in> \<W> M. \<forall>w \<in> \<W> M.
    v \<in> \<K> M i u \<longrightarrow> w \<in> \<K> M i u \<longrightarrow> w \<in> \<K> M i v\<close>

lemma Imp_intro [intro]: \<open>(M, w \<Turnstile> p \<Longrightarrow> M, w \<Turnstile> q) \<Longrightarrow> M, w \<Turnstile> p \<^bold>\<longrightarrow> q\<close>
  by simp

theorem distribution: \<open>M, w \<Turnstile> K i p \<^bold>\<and> K i (p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> K i q\<close>
proof
  assume \<open>M, w \<Turnstile> K i p \<^bold>\<and> K i (p \<^bold>\<longrightarrow> q)\<close>
  then have \<open>M, w \<Turnstile> K i p\<close> \<open>M, w \<Turnstile> K i (p \<^bold>\<longrightarrow> q)\<close>
    by simp_all
  then have \<open>\<forall>v \<in> \<W> M \<inter> \<K> M i w. M, v \<Turnstile> p\<close> \<open>\<forall>v \<in> \<W> M \<inter> \<K> M i w. M, v \<Turnstile> p \<^bold>\<longrightarrow> q\<close>
    by simp_all
  then have \<open>\<forall>v \<in> \<W> M \<inter> \<K> M i w. M, v \<Turnstile> q\<close>
    by simp
  then show \<open>M, w \<Turnstile> K i q\<close>
    by simp
qed

theorem generalization:
  fixes M :: \<open>('i, 'w) kripke\<close>
  assumes \<open>\<forall>(M :: ('i, 'w) kripke). \<forall>w \<in> \<W> M. M, w \<Turnstile> p\<close> \<open>w \<in> \<W> M\<close>
  shows \<open>M, w \<Turnstile> K i p\<close>
proof -
  have \<open>\<forall>w' \<in> \<W> M \<inter> \<K> M i w. M, w' \<Turnstile> p\<close>
    using assms by blast
  then show \<open>M, w \<Turnstile> K i p\<close>
    by simp
qed

theorem truth:
  assumes \<open>reflexive M\<close> \<open>w \<in> \<W> M\<close>
  shows \<open>M, w \<Turnstile> K i p \<^bold>\<longrightarrow> p\<close>
proof
  assume \<open>M, w \<Turnstile> K i p\<close>
  then have \<open>\<forall>v \<in> \<W> M \<inter> \<K> M i w. M, v \<Turnstile> p\<close>
    by simp
  moreover have \<open>w \<in> \<K> M i w\<close>
    using \<open>reflexive M\<close> \<open>w \<in> \<W> M\<close> unfolding reflexive_def by blast
  ultimately show \<open>M, w \<Turnstile> p\<close>
    using \<open>w \<in> \<W> M\<close> by simp
qed

theorem pos_introspection:
  assumes \<open>transitive M\<close> \<open>w \<in> \<W> M\<close>
  shows \<open>M, w \<Turnstile> K i p \<^bold>\<longrightarrow> K i (K i p)\<close>
proof
  assume \<open>M, w \<Turnstile> K i p\<close>
  then have \<open>\<forall>v \<in> \<W> M \<inter> \<K> M i w. M, v \<Turnstile> p\<close>
    by simp
  then have \<open>\<forall>v \<in> \<W> M \<inter> \<K> M i w. \<forall>u \<in> \<W> M \<inter> \<K> M i v. M, u \<Turnstile> p\<close>
    using \<open>transitive M\<close> \<open>w \<in> \<W> M\<close> unfolding transitive_def by blast
  then have \<open>\<forall>v \<in> \<W> M \<inter> \<K> M i w. M, v \<Turnstile> K i p\<close>
    by simp
  then show \<open>M, w \<Turnstile> K i (K i p)\<close>
    by simp
qed

theorem neg_introspection:
  assumes \<open>symmetric M\<close> \<open>transitive M\<close> \<open>w \<in> \<W> M\<close>
  shows \<open>M, w \<Turnstile> \<^bold>\<not> K i p \<^bold>\<longrightarrow> K i (\<^bold>\<not> K i p)\<close>
proof
  assume \<open>M, w \<Turnstile> \<^bold>\<not> (K i p)\<close>
  then obtain u where \<open>u \<in> \<K> M i w\<close> \<open>\<not> (M, u \<Turnstile> p)\<close> \<open>u \<in> \<W> M\<close>
    by auto
  moreover have \<open>\<forall>v \<in> \<W> M \<inter> \<K> M i w. u \<in> \<W> M \<inter> \<K> M i v\<close>
    using \<open>u \<in> \<K> M i w\<close> \<open>symmetric M\<close> \<open>transitive M\<close> \<open>u \<in> \<W> M\<close> \<open>w \<in> \<W> M\<close>
    unfolding symmetric_def transitive_def by blast
  ultimately have \<open>\<forall>v \<in> \<W> M \<inter> \<K> M i w. M, v \<Turnstile> \<^bold>\<not> K i p\<close>
    by auto
  then show \<open>M, w \<Turnstile> K i (\<^bold>\<not> K i p)\<close>
    by simp
qed

section \<open>Normal Modal Logic\<close>

primrec eval :: \<open>(id \<Rightarrow> bool) \<Rightarrow> ('i fm \<Rightarrow> bool) \<Rightarrow> 'i fm \<Rightarrow> bool\<close> where
  \<open>eval _ _ \<^bold>\<bottom> = False\<close>
| \<open>eval g _ (Pro x) = g x\<close>
| \<open>eval g h (p \<^bold>\<or> q) = (eval g h p \<or> eval g h q)\<close>
| \<open>eval g h (p \<^bold>\<and> q) = (eval g h p \<and> eval g h q)\<close>
| \<open>eval g h (p \<^bold>\<longrightarrow> q) = (eval g h p \<longrightarrow> eval g h q)\<close>
| \<open>eval _ h (K i p) = h (K i p)\<close>

abbreviation \<open>tautology p \<equiv> \<forall>g h. eval g h p\<close>

inductive AK :: \<open>('i fm \<Rightarrow> bool) \<Rightarrow> 'i fm \<Rightarrow> bool\<close> (\<open>_ \<turnstile> _\<close> [50, 50] 50)
  for A :: \<open>'i fm \<Rightarrow> bool\<close> where
    A1: \<open>tautology p \<Longrightarrow> A \<turnstile> p\<close>
  | A2: \<open>A \<turnstile> K i p \<^bold>\<and> K i (p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> K i q\<close>
  | Ax: \<open>A p \<Longrightarrow> A \<turnstile> p\<close>
  | R1: \<open>A \<turnstile> p \<Longrightarrow> A \<turnstile> p \<^bold>\<longrightarrow> q \<Longrightarrow> A \<turnstile> q\<close>
  | R2: \<open>A \<turnstile> p \<Longrightarrow> A \<turnstile> K i p\<close>

primrec imply :: \<open>'i fm list \<Rightarrow> 'i fm \<Rightarrow> 'i fm\<close> (infixr \<open>\<^bold>\<leadsto>\<close> 56) where
  \<open>([] \<^bold>\<leadsto> q) = q\<close>
| \<open>(p # ps \<^bold>\<leadsto> q) = (p \<^bold>\<longrightarrow> ps \<^bold>\<leadsto> q)\<close>

abbreviation AK_assms (\<open>_; _ \<turnstile> _\<close> [50, 50, 50] 50) where
  \<open>A; G \<turnstile> p \<equiv> \<exists>qs. set qs \<subseteq> G \<and> (A \<turnstile> qs \<^bold>\<leadsto> p)\<close>

section \<open>Soundness\<close>

lemma eval_semantics:
  \<open>eval (pi w) (\<lambda>q. \<lparr>\<W> = W, \<K> = r, \<pi> = pi\<rparr>, w \<Turnstile> q) p = (\<lparr>\<W> = W, \<K> = r, \<pi> = pi\<rparr>, w \<Turnstile> p)\<close>
  by (induct p) simp_all

lemma tautology:
  assumes \<open>tautology p\<close>
  shows \<open>M, w \<Turnstile> p\<close>
proof -
  from assms have \<open>eval (g w) (\<lambda>q. \<lparr>\<W> = W, \<K> = r, \<pi> = g\<rparr>, w \<Turnstile> q) p\<close> for W g r
    by simp
  then have \<open>\<lparr>\<W> = W, \<K> = r, \<pi> = g\<rparr>, w \<Turnstile> p\<close> for W g r
    using eval_semantics by fast
  then show \<open>M, w \<Turnstile> p\<close>
    by (metis kripke.cases)
qed

theorem soundness:
  assumes \<open>\<And>M w p. A p \<Longrightarrow> P M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile> p\<close>
  shows \<open>A \<turnstile> p \<Longrightarrow> P M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile> p\<close>
  by (induct p arbitrary: w rule: AK.induct) (auto simp: assms tautology)

section \<open>Derived rules\<close>

lemma K_A2': \<open>A \<turnstile> K i (p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> K i p \<^bold>\<longrightarrow> K i q\<close>
proof -
  have \<open>A \<turnstile> K i p \<^bold>\<and> K i (p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> K i q\<close>
    using A2 by fast
  moreover have \<open>A \<turnstile> (P \<^bold>\<and> Q \<^bold>\<longrightarrow> R) \<^bold>\<longrightarrow> (Q \<^bold>\<longrightarrow> P \<^bold>\<longrightarrow> R)\<close> for P Q R
    by (simp add: A1)
  ultimately show ?thesis
    using R1 by fast
qed

lemma K_map:
  assumes \<open>A \<turnstile> p \<^bold>\<longrightarrow> q\<close>
  shows \<open>A \<turnstile> K i p \<^bold>\<longrightarrow> K i q\<close>
proof -
  note \<open>A \<turnstile> p \<^bold>\<longrightarrow> q\<close>
  then have \<open>A \<turnstile> K i (p \<^bold>\<longrightarrow> q)\<close>
    using R2 by fast
  moreover have \<open>A \<turnstile> K i (p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> K i p \<^bold>\<longrightarrow> K i q\<close>
    using K_A2' by fast
  ultimately show ?thesis
    using R1 by fast
qed

lemma K_LK: \<open>A \<turnstile> (L i (\<^bold>\<not> p) \<^bold>\<longrightarrow> \<^bold>\<not> K i p)\<close>
proof -
  have \<open>A \<turnstile> (p \<^bold>\<longrightarrow> \<^bold>\<not> \<^bold>\<not> p)\<close>
    by (simp add: A1)
  moreover have \<open>A \<turnstile> ((P \<^bold>\<longrightarrow> Q) \<^bold>\<longrightarrow> (\<^bold>\<not> Q \<^bold>\<longrightarrow> \<^bold>\<not> P))\<close> for P Q
    using A1 by force
  ultimately show ?thesis
    using K_map R1 by fast
qed

lemma K_imply_head: \<open>A \<turnstile> (p # ps \<^bold>\<leadsto> p)\<close>
proof -
  have \<open>tautology (p # ps \<^bold>\<leadsto> p)\<close>
    by (induct ps) simp_all
  then show ?thesis
    using A1 by blast
qed

lemma K_imply_Cons:
  assumes \<open>A \<turnstile> ps \<^bold>\<leadsto> q\<close>
  shows \<open>A \<turnstile> p # ps \<^bold>\<leadsto> q\<close>
proof -
  have \<open>A \<turnstile> (ps \<^bold>\<leadsto> q \<^bold>\<longrightarrow> p # ps \<^bold>\<leadsto> q)\<close>
    by (simp add: A1)
  with R1 assms show ?thesis .
qed

lemma K_right_mp:
  assumes \<open>A \<turnstile> ps \<^bold>\<leadsto> p\<close> \<open>A \<turnstile> ps \<^bold>\<leadsto> (p \<^bold>\<longrightarrow> q)\<close>
  shows \<open>A \<turnstile> ps \<^bold>\<leadsto> q\<close>
proof -
  have \<open>tautology (ps \<^bold>\<leadsto> p \<^bold>\<longrightarrow> ps \<^bold>\<leadsto> (p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> ps \<^bold>\<leadsto> q)\<close>
    by (induct ps) simp_all
  with A1 have \<open>A \<turnstile> ps \<^bold>\<leadsto> p \<^bold>\<longrightarrow> ps \<^bold>\<leadsto> (p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> ps \<^bold>\<leadsto> q\<close> .
  then show ?thesis
    using assms R1 by blast
qed

lemma tautology_imply_superset:
  assumes \<open>set ps \<subseteq> set qs\<close>
  shows \<open>tautology (ps \<^bold>\<leadsto> r \<^bold>\<longrightarrow> qs \<^bold>\<leadsto> r)\<close>
proof (rule ccontr)
  assume \<open>\<not> tautology (ps \<^bold>\<leadsto> r \<^bold>\<longrightarrow> qs \<^bold>\<leadsto> r)\<close>
  then obtain g h where \<open>\<not> eval g h (ps \<^bold>\<leadsto> r \<^bold>\<longrightarrow> qs \<^bold>\<leadsto> r)\<close>
    by blast
  then have \<open>eval g h (ps \<^bold>\<leadsto> r)\<close> \<open>\<not> eval g h (qs \<^bold>\<leadsto> r)\<close>
    by simp_all
  then consider (np) \<open>\<exists>p \<in> set ps. \<not> eval g h p\<close> | (r) \<open>\<forall>p \<in> set ps. eval g h p\<close> \<open>eval g h r\<close>
    by (induct ps) auto
  then show False
  proof cases
    case np
    then have \<open>\<exists>p \<in> set qs. \<not> eval g h p\<close>
      using \<open>set ps \<subseteq> set qs\<close> by blast
    then have \<open>eval g h (qs \<^bold>\<leadsto> r)\<close>
      by (induct qs) simp_all
    then show ?thesis
      using \<open>\<not> eval g h (qs \<^bold>\<leadsto> r)\<close> by blast
  next
    case r
    then have \<open>eval g h (qs \<^bold>\<leadsto> r)\<close>
      by (induct qs) simp_all
    then show ?thesis
      using \<open>\<not> eval g h (qs \<^bold>\<leadsto> r)\<close> by blast
  qed
qed

lemma K_imply_weaken:
  assumes \<open>A \<turnstile> ps \<^bold>\<leadsto> q\<close> \<open>set ps \<subseteq> set ps'\<close>
  shows \<open>A \<turnstile> ps' \<^bold>\<leadsto> q\<close>
proof -
  have \<open>tautology (ps \<^bold>\<leadsto> q \<^bold>\<longrightarrow> ps' \<^bold>\<leadsto> q)\<close>
    using \<open>set ps \<subseteq> set ps'\<close> tautology_imply_superset by blast
  then have \<open>A \<turnstile> ps \<^bold>\<leadsto> q \<^bold>\<longrightarrow> ps' \<^bold>\<leadsto> q\<close>
    using A1 by blast
  then show ?thesis
    using \<open>A \<turnstile> ps \<^bold>\<leadsto> q\<close> R1 by blast
qed

lemma imply_append: \<open>(ps @ ps' \<^bold>\<leadsto> q) = (ps \<^bold>\<leadsto> ps' \<^bold>\<leadsto> q)\<close>
  by (induct ps) simp_all

lemma K_ImpI:
  assumes \<open>A \<turnstile> p # G \<^bold>\<leadsto> q\<close>
  shows \<open>A \<turnstile> G \<^bold>\<leadsto> (p \<^bold>\<longrightarrow> q)\<close>
proof -
  have \<open>set (p # G) \<subseteq> set (G @ [p])\<close>
    by simp
  then have \<open>A \<turnstile> G @ [p] \<^bold>\<leadsto> q\<close>
    using assms K_imply_weaken by blast
  then have \<open>A \<turnstile> G \<^bold>\<leadsto> [p] \<^bold>\<leadsto> q\<close>
    using imply_append by metis
  then show ?thesis
    by simp
qed

lemma K_Boole:
  assumes \<open>A \<turnstile> (\<^bold>\<not> p) # G \<^bold>\<leadsto> \<^bold>\<bottom>\<close>
  shows \<open>A \<turnstile> G \<^bold>\<leadsto> p\<close>
proof -
  have \<open>A \<turnstile> G \<^bold>\<leadsto> \<^bold>\<not> \<^bold>\<not> p\<close>
    using assms K_ImpI by blast
  moreover have \<open>tautology (G \<^bold>\<leadsto> \<^bold>\<not> \<^bold>\<not> p \<^bold>\<longrightarrow> G \<^bold>\<leadsto> p)\<close>
    by (induct G) simp_all
  then have \<open>A \<turnstile> (G \<^bold>\<leadsto> \<^bold>\<not> \<^bold>\<not> p \<^bold>\<longrightarrow> G \<^bold>\<leadsto> p)\<close>
    using A1 by blast
  ultimately show ?thesis
    using R1 by blast
qed

lemma K_DisE:
  assumes \<open>A \<turnstile> p # G \<^bold>\<leadsto> r\<close> \<open>A \<turnstile> q # G \<^bold>\<leadsto> r\<close> \<open>A \<turnstile> G \<^bold>\<leadsto> p \<^bold>\<or> q\<close>
  shows \<open>A \<turnstile> G \<^bold>\<leadsto> r\<close>
proof -
  have \<open>tautology (p # G \<^bold>\<leadsto> r \<^bold>\<longrightarrow> q # G \<^bold>\<leadsto> r \<^bold>\<longrightarrow> G \<^bold>\<leadsto> p \<^bold>\<or> q \<^bold>\<longrightarrow> G \<^bold>\<leadsto> r)\<close>
    by (induct G) auto
  then have \<open>A \<turnstile> p # G \<^bold>\<leadsto> r \<^bold>\<longrightarrow> q # G \<^bold>\<leadsto> r \<^bold>\<longrightarrow> G \<^bold>\<leadsto> p \<^bold>\<or> q \<^bold>\<longrightarrow> G \<^bold>\<leadsto> r\<close>
    using A1 by blast
  then show ?thesis
    using assms R1 by blast
qed

lemma K_mp: \<open>A \<turnstile> p # (p \<^bold>\<longrightarrow> q) # G \<^bold>\<leadsto> q\<close>
  by (meson K_imply_head K_imply_weaken K_right_mp set_subset_Cons)

lemma K_swap:
  assumes \<open>A \<turnstile> p # q # G \<^bold>\<leadsto> r\<close>
  shows \<open>A \<turnstile> q # p # G \<^bold>\<leadsto> r\<close>
  using assms K_ImpI by (metis imply.simps(1-2))

lemma K_DisL:
  assumes \<open>A \<turnstile> p # ps \<^bold>\<leadsto> q\<close> \<open>A \<turnstile> p' # ps \<^bold>\<leadsto> q\<close>
  shows \<open>A \<turnstile> (p \<^bold>\<or> p') # ps \<^bold>\<leadsto> q\<close>
proof -
  have \<open>A \<turnstile> p # (p \<^bold>\<or> p') # ps \<^bold>\<leadsto> q\<close> \<open>A \<turnstile> p' # (p \<^bold>\<or> p') # ps \<^bold>\<leadsto> q\<close>
    using assms K_swap K_imply_Cons by blast+
  moreover have \<open>A \<turnstile> (p \<^bold>\<or> p') # ps \<^bold>\<leadsto> p \<^bold>\<or> p'\<close>
    using K_imply_head by blast
  ultimately show ?thesis
    using K_DisE by blast
qed

lemma K_distrib_K_imp:
  assumes \<open>A \<turnstile> K i (G \<^bold>\<leadsto> q)\<close>
  shows \<open>A \<turnstile> map (K i) G \<^bold>\<leadsto> K i q\<close>
proof -
  have \<open>A \<turnstile> (K i (G \<^bold>\<leadsto> q) \<^bold>\<longrightarrow> map (K i) G \<^bold>\<leadsto> K i q)\<close>
  proof (induct G)
    case Nil
    then show ?case
      by (simp add: A1)
  next
    case (Cons a G)
    have \<open>A \<turnstile> K i a \<^bold>\<and> K i (a # G \<^bold>\<leadsto> q) \<^bold>\<longrightarrow> K i (G \<^bold>\<leadsto> q)\<close>
      by (simp add: A2)
    moreover have
      \<open>A \<turnstile> ((K i a \<^bold>\<and> K i (a # G \<^bold>\<leadsto> q) \<^bold>\<longrightarrow> K i (G \<^bold>\<leadsto> q)) \<^bold>\<longrightarrow>
        (K i (G \<^bold>\<leadsto> q) \<^bold>\<longrightarrow> map (K i) G \<^bold>\<leadsto> K i q) \<^bold>\<longrightarrow>
        (K i a \<^bold>\<and> K i (a # G \<^bold>\<leadsto> q) \<^bold>\<longrightarrow> map (K i) G \<^bold>\<leadsto> K i q))\<close>
      by (simp add: A1)
    ultimately have \<open>A \<turnstile> K i a \<^bold>\<and> K i (a # G \<^bold>\<leadsto> q) \<^bold>\<longrightarrow> map (K i) G \<^bold>\<leadsto> K i q\<close>
      using Cons R1 by blast
    moreover have
      \<open>A \<turnstile> ((K i a \<^bold>\<and> K i (a # G \<^bold>\<leadsto> q) \<^bold>\<longrightarrow> map (K i) G \<^bold>\<leadsto> K i q) \<^bold>\<longrightarrow>
        (K i (a # G \<^bold>\<leadsto> q) \<^bold>\<longrightarrow> K i a \<^bold>\<longrightarrow> map (K i) G \<^bold>\<leadsto> K i q))\<close>
      by (simp add: A1)
    ultimately have \<open>A \<turnstile> (K i (a # G \<^bold>\<leadsto> q) \<^bold>\<longrightarrow> K i a \<^bold>\<longrightarrow> map (K i) G \<^bold>\<leadsto> K i q)\<close>
      using R1 by blast
    then show ?case
      by simp
  qed
  then show ?thesis
    using assms R1 by blast
qed

lemma K_trans: \<open>A \<turnstile> (p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> (q \<^bold>\<longrightarrow> r) \<^bold>\<longrightarrow> p \<^bold>\<longrightarrow> r\<close>
  by (auto intro: A1)

lemma K_L_dual: \<open>A \<turnstile> \<^bold>\<not> L i (\<^bold>\<not> p) \<^bold>\<longrightarrow> K i p\<close>
proof -
  have \<open>A \<turnstile> K i p \<^bold>\<longrightarrow> K i p\<close> \<open>A \<turnstile> \<^bold>\<not> \<^bold>\<not> p \<^bold>\<longrightarrow> p\<close>
    by (auto intro: A1)
  then have \<open>A \<turnstile> K i (\<^bold>\<not> \<^bold>\<not> p) \<^bold>\<longrightarrow> K i p\<close>
    by (auto intro: K_map)
  moreover have \<open>A \<turnstile> (P \<^bold>\<longrightarrow> Q) \<^bold>\<longrightarrow> (\<^bold>\<not> \<^bold>\<not> P \<^bold>\<longrightarrow> Q)\<close> for P Q
    by (auto intro: A1)
  ultimately show \<open>A \<turnstile> \<^bold>\<not> \<^bold>\<not> K i (\<^bold>\<not> \<^bold>\<not> p) \<^bold>\<longrightarrow> K i p\<close>
    by (auto intro: R1)
qed

section \<open>Strong Soundness\<close>

corollary soundness_imply:
  assumes \<open>\<And>M w p. A p \<Longrightarrow> P M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile> p\<close>
  shows \<open>A \<turnstile> ps \<^bold>\<leadsto> p \<Longrightarrow> P; set ps \<TTurnstile>\<star> p\<close>
proof (induct ps arbitrary: p)
  case Nil
  then show ?case
    using soundness[of A P p] assms by simp
next
  case (Cons a ps)
  then show ?case
    using K_ImpI by fastforce
qed

theorem strong_soundness:
  assumes \<open>\<And>M w p. A p \<Longrightarrow> P M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile> p\<close>
  shows \<open>A; G \<turnstile> p \<Longrightarrow> P; G \<TTurnstile>\<star> p\<close>
proof safe
  fix qs w and M :: \<open>('a, 'b) kripke\<close>
  assume \<open>A \<turnstile> qs \<^bold>\<leadsto> p\<close>
  moreover assume \<open>set qs \<subseteq> G\<close> \<open>\<forall>q \<in> G. M, w \<Turnstile> q\<close>
  then have \<open>\<forall>q \<in> set qs. M, w \<Turnstile> q\<close>
    using \<open>set qs \<subseteq> G\<close> by blast
  moreover assume \<open>P M\<close> \<open>w \<in> \<W> M\<close>
  ultimately show \<open>M, w \<Turnstile> p\<close>
    using soundness_imply[of A P qs p] assms by blast
qed

section \<open>Completeness\<close>

subsection \<open>Consistent sets\<close>

definition consistent :: \<open>('i fm \<Rightarrow> bool) \<Rightarrow> 'i fm set \<Rightarrow> bool\<close> where
  \<open>consistent A S \<equiv> \<not> (A; S \<turnstile> \<^bold>\<bottom>)\<close>

lemma inconsistent_subset:
  assumes \<open>consistent A V\<close> \<open>\<not> consistent A ({p} \<union> V)\<close>
  obtains V' where \<open>set V' \<subseteq> V\<close> \<open>A \<turnstile> p # V' \<^bold>\<leadsto> \<^bold>\<bottom>\<close>
proof -
  obtain V' where V': \<open>set V' \<subseteq> ({p} \<union> V)\<close> \<open>p \<in> set V'\<close> \<open>A \<turnstile> V' \<^bold>\<leadsto> \<^bold>\<bottom>\<close>
    using assms unfolding consistent_def by blast
  then have *: \<open>A \<turnstile> p # V' \<^bold>\<leadsto> \<^bold>\<bottom>\<close>
    using K_imply_Cons by blast

  let ?S = \<open>removeAll p V'\<close>
  have \<open>set (p # V') \<subseteq> set (p # ?S)\<close>
    by auto
  then have \<open>A \<turnstile> p # ?S \<^bold>\<leadsto> \<^bold>\<bottom>\<close>
    using * K_imply_weaken by blast
  moreover have \<open>set ?S \<subseteq> V\<close>
    using V'(1) by (metis Diff_subset_conv set_removeAll)
  ultimately show ?thesis
    using that by blast
qed

lemma consistent_consequent:
  assumes \<open>consistent A V\<close> \<open>p \<in> V\<close> \<open>A \<turnstile> p \<^bold>\<longrightarrow> q\<close>
  shows \<open>consistent A ({q} \<union> V)\<close>
proof -
  have \<open>\<forall>V'. set V' \<subseteq> V \<longrightarrow> \<not> (A \<turnstile> p # V' \<^bold>\<leadsto> \<^bold>\<bottom>)\<close>
    using \<open>consistent A V\<close> \<open>p \<in> V\<close> unfolding consistent_def
    by (metis insert_subset list.simps(15))
  then have \<open>\<forall>V'. set V' \<subseteq> V \<longrightarrow> \<not> (A \<turnstile> q # V' \<^bold>\<leadsto> \<^bold>\<bottom>)\<close>
    using \<open>A \<turnstile> (p \<^bold>\<longrightarrow> q)\<close> K_imply_head K_right_mp by (metis imply.simps(1-2))
  then show ?thesis
    using \<open>consistent A V\<close> inconsistent_subset by metis
qed

lemma consistent_consequent':
  assumes \<open>consistent A V\<close> \<open>p \<in> V\<close> \<open>tautology (p \<^bold>\<longrightarrow> q)\<close>
  shows \<open>consistent A ({q} \<union> V)\<close>
  using assms consistent_consequent A1 by blast

lemma consistent_disjuncts:
  assumes \<open>consistent A V\<close> \<open>(p \<^bold>\<or> q) \<in> V\<close>
  shows \<open>consistent A ({p} \<union> V) \<or> consistent A ({q} \<union> V)\<close>
proof (rule ccontr)
  assume \<open>\<not> ?thesis\<close>
  then have \<open>\<not> consistent A ({p} \<union> V)\<close> \<open>\<not> consistent A ({q} \<union> V)\<close>
    by blast+

  then obtain S' T' where
    S': \<open>set S' \<subseteq> V\<close> \<open>A \<turnstile> p # S' \<^bold>\<leadsto> \<^bold>\<bottom>\<close> and
    T': \<open>set T' \<subseteq> V\<close> \<open>A \<turnstile> q # T' \<^bold>\<leadsto> \<^bold>\<bottom>\<close>
    using \<open>consistent A V\<close> inconsistent_subset by metis

  from S' have p: \<open>A \<turnstile> p # S' @ T' \<^bold>\<leadsto> \<^bold>\<bottom>\<close>
    by (metis K_imply_weaken Un_upper1 append_Cons set_append)
  moreover from T' have q: \<open>A \<turnstile> q # S' @ T' \<^bold>\<leadsto> \<^bold>\<bottom>\<close>
    by (metis K_imply_head K_right_mp R1 imply.simps(2) imply_append)
  ultimately have \<open>A \<turnstile> (p \<^bold>\<or> q) # S' @ T' \<^bold>\<leadsto> \<^bold>\<bottom>\<close>
    using K_DisL by blast
  then have \<open>A \<turnstile> S' @ T' \<^bold>\<leadsto> \<^bold>\<bottom>\<close>
    using S'(1) T'(1) p q \<open>consistent A V\<close> \<open>(p \<^bold>\<or> q) \<in> V\<close> unfolding consistent_def
    by (metis Un_subset_iff insert_subset list.simps(15) set_append)
  moreover have \<open>set (S' @ T') \<subseteq> V\<close>
    by (simp add: S'(1) T'(1))
  ultimately show False
    using \<open>consistent A V\<close> unfolding consistent_def by blast
qed

lemma exists_finite_inconsistent:
  assumes \<open>\<not> consistent A ({\<^bold>\<not> p} \<union> V)\<close>
  obtains W where \<open>{\<^bold>\<not> p} \<union> W \<subseteq> {\<^bold>\<not> p} \<union> V\<close> \<open>(\<^bold>\<not> p) \<notin> W\<close> \<open>finite W\<close> \<open>\<not> consistent A ({\<^bold>\<not> p} \<union> W)\<close>
proof -
  obtain W' where W': \<open>set W' \<subseteq> {\<^bold>\<not> p} \<union> V\<close> \<open>A \<turnstile> W' \<^bold>\<leadsto> \<^bold>\<bottom>\<close>
    using assms unfolding consistent_def by blast
  let ?S = \<open>removeAll (\<^bold>\<not> p) W'\<close>
  have \<open>\<not> consistent A ({\<^bold>\<not> p} \<union> set ?S)\<close>
    unfolding consistent_def using W'(2) by auto
  moreover have \<open>finite (set ?S)\<close>
    by blast
  moreover have \<open>{\<^bold>\<not> p} \<union> set ?S \<subseteq> {\<^bold>\<not> p} \<union> V\<close>
    using W'(1) by auto
  moreover have \<open>(\<^bold>\<not> p) \<notin> set ?S\<close>
    by simp
  ultimately show ?thesis
    by (meson that)
qed

lemma inconsistent_imply:
  assumes \<open>\<not> consistent A ({\<^bold>\<not> p} \<union> set G)\<close>
  shows \<open>A \<turnstile> G \<^bold>\<leadsto> p\<close>
  using assms K_Boole K_imply_weaken unfolding consistent_def
  by (metis insert_is_Un list.simps(15))

subsection \<open>Maximal consistent sets\<close>

lemma fm_any_size: \<open>\<exists>p :: 'i fm. size p = n\<close>
proof (induct n)
  case 0
  then show ?case
    using fm.size(7) by blast
next
  case (Suc n)
  then show ?case
    by (metis add.commute add_0 add_Suc_right fm.size(12))
qed

lemma infinite_UNIV_fm: \<open>infinite (UNIV :: 'i fm set)\<close>
  using fm_any_size by (metis (full_types) finite_imageI infinite_UNIV_nat surj_def)

interpretation MCS \<open>consistent A\<close> for A :: \<open>'i fm \<Rightarrow> bool\<close>
proof
  show \<open>infinite (UNIV :: 'i fm set)\<close>
    using infinite_UNIV_fm .
next
  fix S S'
  assume \<open>consistent A S\<close> \<open>S' \<subseteq> S\<close>
  then show \<open>consistent A S'\<close>
    unfolding consistent_def by simp
next
  fix S
  assume \<open>\<not> consistent A S\<close>
  then show \<open>\<exists>S' \<subseteq> S. finite S' \<and> \<not> consistent A S'\<close>
    unfolding consistent_def by blast
qed

theorem deriv_in_maximal:
  assumes \<open>consistent A V\<close> \<open>maximal A V\<close> \<open>A \<turnstile> p\<close>
  shows \<open>p \<in> V\<close>
  using assms R1 inconsistent_subset unfolding consistent_def maximal_def
  by (metis imply.simps(2))

theorem exactly_one_in_maximal:
  assumes \<open>consistent A V\<close> \<open>maximal A V\<close>
  shows \<open>p \<in> V \<longleftrightarrow> (\<^bold>\<not> p) \<notin> V\<close>
proof
  assume \<open>p \<in> V\<close>
  then show \<open>(\<^bold>\<not> p) \<notin> V\<close>
    using assms K_mp unfolding consistent_def maximal_def
    by (metis empty_subsetI insert_subset list.set(1) list.simps(15))
next
  assume \<open>(\<^bold>\<not> p) \<notin> V\<close>
  have \<open>A \<turnstile> (p \<^bold>\<or> \<^bold>\<not> p)\<close>
    by (simp add: A1)
  then have \<open>(p \<^bold>\<or> \<^bold>\<not> p) \<in> V\<close>
    using assms deriv_in_maximal by blast
  then have \<open>consistent A ({p} \<union> V) \<or> consistent A ({\<^bold>\<not> p} \<union> V)\<close>
    using assms consistent_disjuncts by blast
  then show \<open>p \<in> V\<close>
    using \<open>maximal A V\<close> \<open>(\<^bold>\<not> p) \<notin> V\<close> unfolding maximal_def by blast
qed

theorem consequent_in_maximal:
  assumes \<open>consistent A V\<close> \<open>maximal A V\<close> \<open>p \<in> V\<close> \<open>(p \<^bold>\<longrightarrow> q) \<in> V\<close>
  shows \<open>q \<in> V\<close>
proof -
  have \<open>\<forall>V'. set V' \<subseteq> V \<longrightarrow> \<not> (A \<turnstile> p # (p \<^bold>\<longrightarrow> q) # V' \<^bold>\<leadsto> \<^bold>\<bottom>)\<close>
    using \<open>consistent A V\<close> \<open>p \<in> V\<close> \<open>(p \<^bold>\<longrightarrow> q) \<in> V\<close> unfolding consistent_def
    by (metis insert_subset list.simps(15))
  then have \<open>\<forall>V'. set V' \<subseteq> V \<longrightarrow> \<not> (A \<turnstile> q # V' \<^bold>\<leadsto> \<^bold>\<bottom>)\<close>
    by (meson K_mp K_ImpI K_imply_weaken K_right_mp set_subset_Cons)
  then have \<open>consistent A ({q} \<union> V)\<close>
    using \<open>consistent A V\<close> inconsistent_subset by metis
  then show ?thesis
    using \<open>maximal A V\<close> unfolding maximal_def by fast
qed

theorem ax_in_maximal:
  assumes \<open>consistent A V\<close> \<open>maximal A V\<close> \<open>A p\<close>
  shows \<open>p \<in> V\<close>
  using assms deriv_in_maximal Ax by blast

theorem mcs_properties:
  assumes \<open>consistent A V\<close> and \<open>maximal A V\<close>
  shows \<open>A \<turnstile> p \<Longrightarrow> p \<in> V\<close>
    and \<open>p \<in> V \<longleftrightarrow> (\<^bold>\<not> p) \<notin> V\<close>
    and \<open>p \<in> V \<Longrightarrow> (p \<^bold>\<longrightarrow> q) \<in> V \<Longrightarrow> q \<in> V\<close>
  using assms deriv_in_maximal exactly_one_in_maximal consequent_in_maximal by blast+

lemma maximal_extension:
  fixes V :: \<open>'i fm set\<close>
  assumes \<open>consistent A V\<close>
  obtains W where \<open>V \<subseteq> W\<close> \<open>consistent A W\<close> \<open>maximal A W\<close>
proof -
  let ?W = \<open>Extend A V\<close>
  have \<open>V \<subseteq> ?W\<close>
    using Extend_subset by blast
  moreover have \<open>consistent A ?W\<close>
    using assms consistent_Extend by blast
  moreover have \<open>maximal A ?W\<close>
    using assms maximal_Extend by blast
  ultimately show ?thesis
    using that by blast
qed

subsection \<open>Canonical model\<close>

abbreviation pi :: \<open>'i fm set \<Rightarrow> id \<Rightarrow> bool\<close> where
  \<open>pi V x \<equiv> Pro x \<in> V\<close>

abbreviation known :: \<open>'i fm set \<Rightarrow> 'i \<Rightarrow> 'i fm set\<close> where
  \<open>known V i \<equiv> {p. K i p \<in> V}\<close>

abbreviation reach :: \<open>('i fm \<Rightarrow> bool) \<Rightarrow> 'i \<Rightarrow> 'i fm set \<Rightarrow> 'i fm set set\<close> where
  \<open>reach A i V \<equiv> {W. known V i \<subseteq> W}\<close>

abbreviation mcss :: \<open>('i fm \<Rightarrow> bool) \<Rightarrow> 'i fm set set\<close> where
  \<open>mcss A \<equiv> {W. consistent A W \<and> maximal A W}\<close>

abbreviation canonical :: \<open>('i fm \<Rightarrow> bool) \<Rightarrow> ('i, 'i fm set) kripke\<close> where
  \<open>canonical A \<equiv> \<lparr>\<W> = mcss A, \<K> = reach A, \<pi> = pi\<rparr>\<close>

lemma truth_lemma:
  fixes p :: \<open>'i fm\<close>
  assumes \<open>consistent A V\<close> and \<open>maximal A V\<close>
  shows \<open>p \<in> V \<longleftrightarrow> canonical A, V \<Turnstile> p\<close>
  using assms
proof (induct p arbitrary: V)
  case FF
  then show ?case
  proof safe
    assume \<open>\<^bold>\<bottom> \<in> V\<close>
    then have False
      using \<open>consistent A V\<close> K_imply_head unfolding consistent_def
      by (metis bot.extremum insert_subset list.set(1) list.simps(15))
    then show \<open>canonical A, V \<Turnstile> \<^bold>\<bottom>\<close> ..
  next
    assume \<open>canonical A, V \<Turnstile> \<^bold>\<bottom>\<close>
    then show \<open>\<^bold>\<bottom> \<in> V\<close>
      by simp
  qed
next
  case (Pro x)
  then show ?case
    by simp
next
  case (Dis p q)
  then show ?case
  proof safe
    assume \<open>(p \<^bold>\<or> q) \<in> V\<close>
    then have \<open>consistent A ({p} \<union> V) \<or> consistent A ({q} \<union> V)\<close>
      using \<open>consistent A V\<close> consistent_disjuncts by blast
    then have \<open>p \<in> V \<or> q \<in> V\<close>
      using \<open>maximal A V\<close> unfolding maximal_def by fast
    then show \<open>canonical A, V \<Turnstile> (p \<^bold>\<or> q)\<close>
      using Dis by simp
  next
    assume \<open>canonical A, V \<Turnstile> (p \<^bold>\<or> q)\<close>
    then consider \<open>canonical A, V \<Turnstile> p\<close> | \<open>canonical A, V \<Turnstile> q\<close>
      by auto
    then have \<open>p \<in> V \<or> q \<in> V\<close>
      using Dis by auto
    moreover have \<open>A \<turnstile> p \<^bold>\<longrightarrow> p \<^bold>\<or> q\<close> \<open>A \<turnstile> q \<^bold>\<longrightarrow> p \<^bold>\<or> q\<close>
      by (auto simp: A1)
    ultimately show \<open>(p \<^bold>\<or> q) \<in> V\<close>
      using Dis.prems deriv_in_maximal consequent_in_maximal by blast
  qed
next
  case (Con p q)
  then show ?case
  proof safe
    assume \<open>(p \<^bold>\<and> q) \<in> V\<close>
    then have \<open>consistent A ({p} \<union> V)\<close> \<open>consistent A ({q} \<union> V)\<close>
      using \<open>consistent A V\<close> consistent_consequent' by fastforce+
    then have \<open>p \<in> V\<close> \<open>q \<in> V\<close>
      using \<open>maximal A V\<close> unfolding maximal_def by fast+
    then show \<open>canonical A, V \<Turnstile> (p \<^bold>\<and> q)\<close>
      using Con by simp
  next
    assume \<open>canonical A, V \<Turnstile> (p \<^bold>\<and> q)\<close>
    then have \<open>canonical A, V \<Turnstile> p\<close> \<open>canonical A, V \<Turnstile> q\<close>
      by auto
    then have \<open>p \<in> V\<close> \<open>q \<in> V\<close>
      using Con by auto
    moreover have \<open>A \<turnstile> p \<^bold>\<longrightarrow> q \<^bold>\<longrightarrow> p \<^bold>\<and> q\<close>
      by (auto simp: A1)
    ultimately show \<open>(p \<^bold>\<and> q) \<in> V\<close>
      using Con.prems deriv_in_maximal consequent_in_maximal by blast
  qed
next
  case (Imp p q)
  then show ?case
  proof safe
    assume \<open>(p \<^bold>\<longrightarrow> q) \<in> V\<close>
    then have \<open>consistent A ({\<^bold>\<not> p \<^bold>\<or> q} \<union> V)\<close>
      using \<open>consistent A V\<close> consistent_consequent' by fastforce
    then have \<open>consistent A ({\<^bold>\<not> p} \<union> V) \<or> consistent A ({q} \<union> V)\<close>
      using \<open>consistent A V\<close> \<open>maximal A V\<close> consistent_disjuncts unfolding maximal_def by blast
    then have \<open>(\<^bold>\<not> p) \<in> V \<or> q \<in> V\<close>
      using \<open>maximal A V\<close> unfolding maximal_def by fast
    then have \<open>p \<notin> V \<or> q \<in> V\<close>
      using Imp.prems exactly_one_in_maximal by blast
    then show \<open>canonical A, V \<Turnstile> (p \<^bold>\<longrightarrow> q)\<close>
      using Imp by simp
  next
    assume \<open>canonical A, V \<Turnstile> (p \<^bold>\<longrightarrow> q)\<close>
    then consider \<open>\<not> canonical A, V \<Turnstile> p\<close> | \<open>canonical A, V \<Turnstile> q\<close>
      by auto
    then have \<open>p \<notin> V \<or> q \<in> V\<close>
      using Imp by auto
    then have \<open>(\<^bold>\<not> p) \<in> V \<or> q \<in> V\<close>
      using Imp.prems exactly_one_in_maximal by blast
    moreover have \<open>A \<turnstile> \<^bold>\<not> p \<^bold>\<longrightarrow> p \<^bold>\<longrightarrow> q\<close> \<open>A \<turnstile> q \<^bold>\<longrightarrow> p \<^bold>\<longrightarrow> q\<close>
      by (auto simp: A1)
    ultimately show \<open>(p \<^bold>\<longrightarrow> q) \<in> V\<close>
      using Imp.prems deriv_in_maximal consequent_in_maximal by blast
  qed
next
  case (K i p)
  then show ?case
  proof safe
    assume \<open>K i p \<in> V\<close>
    then show \<open>canonical A, V \<Turnstile> K i p\<close>
      using K.hyps by auto
  next
    assume \<open>canonical A, V \<Turnstile> K i p\<close>

    have \<open>\<not> consistent A ({\<^bold>\<not> p} \<union> known V i)\<close>
    proof
      assume \<open>consistent A ({\<^bold>\<not> p} \<union> known V i)\<close>
      then obtain W where W: \<open>{\<^bold>\<not> p} \<union> known V i \<subseteq> W\<close> \<open>consistent A W\<close> \<open>maximal A W\<close>
        using \<open>consistent A V\<close> maximal_extension by blast
      then have \<open>canonical A, W \<Turnstile> \<^bold>\<not> p\<close>
        using K \<open>consistent A V\<close> exactly_one_in_maximal by auto
      moreover have \<open>W \<in> reach A i V\<close> \<open>W \<in> mcss A\<close>
        using W by simp_all
      ultimately have \<open>canonical A, V \<Turnstile> \<^bold>\<not> K i p\<close>
        by auto
      then show False
        using \<open>canonical A, V \<Turnstile> K i p\<close> by auto
    qed

    then obtain W where W:
      \<open>{\<^bold>\<not> p} \<union> W \<subseteq> {\<^bold>\<not> p} \<union> known V i\<close> \<open>(\<^bold>\<not> p) \<notin> W\<close> \<open>finite W\<close> \<open>\<not> consistent A ({\<^bold>\<not> p} \<union> W)\<close>
      using exists_finite_inconsistent by metis

    obtain L where L: \<open>set L = W\<close>
      using \<open>finite W\<close> finite_list by blast

    then have \<open>A \<turnstile> L \<^bold>\<leadsto> p\<close>
      using W(4) inconsistent_imply by blast
    then have \<open>A \<turnstile> K i (L \<^bold>\<leadsto> p)\<close>
      using R2 by fast
    then have \<open>A \<turnstile> map (K i) L \<^bold>\<leadsto> K i p\<close>
      using K_distrib_K_imp by fast
    then have \<open>(map (K i) L \<^bold>\<leadsto> K i p) \<in> V\<close>
      using deriv_in_maximal K.prems(1, 2) by blast
    then show \<open>K i p \<in> V\<close>
      using L W(1-2)
    proof (induct L arbitrary: W)
      case (Cons a L)
      then have \<open>K i a \<in> V\<close>
        by auto
      then have \<open>(map (K i) L \<^bold>\<leadsto> K i p) \<in> V\<close>
        using Cons(2) \<open>consistent A V\<close> \<open>maximal A V\<close> consequent_in_maximal by auto
      then show ?case
        using Cons by auto
    qed simp
  qed
qed

lemma canonical_model:
  assumes \<open>consistent A S\<close> and \<open>p \<in> S\<close>
  defines \<open>V \<equiv> Extend A S\<close> and \<open>M \<equiv> canonical A\<close>
  shows \<open>M, V \<Turnstile> p\<close> and \<open>consistent A V\<close> and \<open>maximal A V\<close>
proof -
  have \<open>consistent A V\<close>
    using \<open>consistent A S\<close> unfolding V_def using consistent_Extend by blast
  have \<open>maximal A V\<close>
    unfolding V_def using maximal_Extend by blast
  { fix x
    assume \<open>x \<in> S\<close>
    then have \<open>x \<in> V\<close>
      unfolding V_def using Extend_subset by blast
    then have \<open>M, V \<Turnstile> x\<close>
      unfolding M_def using truth_lemma \<open>consistent A V\<close> \<open>maximal A V\<close> by blast }
  then show \<open>M, V \<Turnstile> p\<close>
    using \<open>p \<in> S\<close> by blast+
  show \<open>consistent A V\<close> \<open>maximal A V\<close>
    by fact+
qed

subsection \<open>Completeness\<close>

abbreviation valid :: \<open>(('i, 'i fm set) kripke \<Rightarrow> bool) \<Rightarrow> 'i fm set \<Rightarrow> 'i fm \<Rightarrow> bool\<close>
  (\<open>_; _ \<TTurnstile> _\<close> [50, 50, 50] 50)
  where \<open>P; G \<TTurnstile> p \<equiv> P; G \<TTurnstile>\<star> p\<close>

theorem strong_completeness:
  assumes \<open>P; G \<TTurnstile> p\<close> and \<open>P (canonical A)\<close>
  shows \<open>A; G \<turnstile> p\<close>
proof (rule ccontr)
  assume \<open>\<nexists>qs. set qs \<subseteq> G \<and> (A \<turnstile> qs \<^bold>\<leadsto> p)\<close>
  then have *: \<open>\<forall>qs. set qs \<subseteq> G \<longrightarrow> \<not> (A \<turnstile> (\<^bold>\<not> p) # qs \<^bold>\<leadsto> \<^bold>\<bottom>)\<close>
    using K_Boole by blast

  let ?S = \<open>{\<^bold>\<not> p} \<union> G\<close>
  let ?V = \<open>Extend A ?S\<close>
  let ?M = \<open>canonical A\<close>

  have \<open>consistent A ?S\<close>
    using * by (metis K_imply_Cons consistent_def inconsistent_subset)
  then have \<open>?M, ?V \<Turnstile> (\<^bold>\<not> p)\<close> \<open>\<forall>q \<in> G. ?M, ?V \<Turnstile> q\<close>
    using canonical_model by fastforce+
  moreover have \<open>?V \<in> mcss A\<close>
    using \<open>consistent A ?S\<close> consistent_Extend maximal_Extend by blast
  ultimately have \<open>?M, ?V \<Turnstile> p\<close>
    using assms by simp
  then show False
    using \<open>?M, ?V \<Turnstile> (\<^bold>\<not> p)\<close> by simp
qed

corollary completeness:
  assumes \<open>P; {} \<TTurnstile> p\<close> and \<open>P (canonical A)\<close>
  shows \<open>A \<turnstile> p\<close>
  using assms strong_completeness[where G=\<open>{}\<close>] by simp

corollary completeness\<^sub>A:
  assumes \<open>(\<lambda>_. True); {} \<TTurnstile> p\<close>
  shows \<open>A \<turnstile> p\<close>
  using assms completeness by blast

section \<open>System K\<close>

abbreviation SystemK (\<open>_ \<turnstile>\<^sub>K _\<close> [50] 50) where
  \<open>G \<turnstile>\<^sub>K p \<equiv> (\<lambda>_. False); G \<turnstile> p\<close>

lemma strong_soundness\<^sub>K: \<open>G \<turnstile>\<^sub>K p \<Longrightarrow> P; G \<TTurnstile>\<star> p\<close>
  using strong_soundness[of \<open>\<lambda>_. False\<close> \<open>\<lambda>_. True\<close>] by fast

abbreviation validK (\<open>_ \<TTurnstile>\<^sub>K _\<close> [50, 50] 50) where
  \<open>G \<TTurnstile>\<^sub>K p \<equiv> (\<lambda>_. True); G \<TTurnstile> p\<close>

lemma strong_completeness\<^sub>K: \<open>G \<TTurnstile>\<^sub>K p \<Longrightarrow> G \<turnstile>\<^sub>K p\<close>
  using strong_completeness[of \<open>\<lambda>_. True\<close>] by blast

theorem main\<^sub>K: \<open>G \<TTurnstile>\<^sub>K p \<longleftrightarrow> G \<turnstile>\<^sub>K p\<close>
  using strong_soundness\<^sub>K[of G p] strong_completeness\<^sub>K[of G p] by fast

corollary \<open>G \<TTurnstile>\<^sub>K p \<Longrightarrow> (\<lambda>_. True); G \<TTurnstile>\<star> p\<close>
  using strong_soundness\<^sub>K[of G p] strong_completeness\<^sub>K[of G p] by fast

section \<open>System T\<close>

text \<open>Also known as System M\<close>

inductive AxT :: \<open>'i fm \<Rightarrow> bool\<close> where
  \<open>AxT (K i p \<^bold>\<longrightarrow> p)\<close>

abbreviation SystemT (\<open>_ \<turnstile>\<^sub>T _\<close> [50, 50] 50) where
  \<open>G \<turnstile>\<^sub>T p \<equiv> AxT; G \<turnstile> p\<close>

lemma soundness_AxT: \<open>AxT p \<Longrightarrow> reflexive M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile> p\<close>
  by (induct p rule: AxT.induct) (meson truth)

lemma strong_soundness\<^sub>T: \<open>G \<turnstile>\<^sub>T p \<Longrightarrow> reflexive; G \<TTurnstile>\<star> p\<close>
  using strong_soundness soundness_AxT .

lemma AxT_reflexive:
  assumes \<open>AxT \<le> A\<close> and \<open>consistent A V\<close> and \<open>maximal A V\<close>
  shows \<open>V \<in> reach A i V\<close>
proof -
  have \<open>(K i p \<^bold>\<longrightarrow> p) \<in> V\<close> for p
    using assms ax_in_maximal AxT.intros by fast
  then have \<open>p \<in> V\<close> if \<open>K i p \<in> V\<close> for p
    using that assms consequent_in_maximal by blast
  then show ?thesis
    using assms by blast
qed

lemma reflexive\<^sub>T:
  assumes \<open>AxT \<le> A\<close>
  shows \<open>reflexive (canonical A)\<close>
  unfolding reflexive_def
proof safe
  fix i V
  assume \<open>V \<in> \<W> (canonical A)\<close>
  then have \<open>consistent A V\<close> \<open>maximal A V\<close>
    by simp_all
  with AxT_reflexive assms have \<open>V \<in> reach A i V\<close> .
  then show \<open>V \<in> \<K> (canonical A) i V\<close>
    by simp
qed

abbreviation validT (\<open>_ \<TTurnstile>\<^sub>T _\<close> [50, 50] 50) where
  \<open>G \<TTurnstile>\<^sub>T p \<equiv> reflexive; G \<TTurnstile> p\<close>

lemma strong_completeness\<^sub>T: \<open>G \<TTurnstile>\<^sub>T p \<Longrightarrow> G \<turnstile>\<^sub>T p\<close>
  using strong_completeness reflexive\<^sub>T by blast

theorem main\<^sub>T: \<open>G \<TTurnstile>\<^sub>T p \<longleftrightarrow> G \<turnstile>\<^sub>T p\<close>
  using strong_soundness\<^sub>T[of G p] strong_completeness\<^sub>T[of G p] by fast

corollary \<open>G \<TTurnstile>\<^sub>T p \<longrightarrow> reflexive; G \<TTurnstile>\<star> p\<close>
  using strong_soundness\<^sub>T[of G p] strong_completeness\<^sub>T[of G p] by fast

section \<open>System KB\<close>

inductive AxB :: \<open>'i fm \<Rightarrow> bool\<close> where
  \<open>AxB (p \<^bold>\<longrightarrow> K i (L i p))\<close>

abbreviation SystemKB (\<open>_ \<turnstile>\<^sub>K\<^sub>B _\<close> [50, 50] 50) where
  \<open>G \<turnstile>\<^sub>K\<^sub>B p \<equiv> AxB; G \<turnstile> p\<close>

lemma soundness_AxB: \<open>AxB p \<Longrightarrow> symmetric M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile> p\<close>
  unfolding symmetric_def by (induct p rule: AxB.induct) auto

lemma strong_soundness\<^sub>K\<^sub>B: \<open>G \<turnstile>\<^sub>K\<^sub>B p \<Longrightarrow> symmetric; G \<TTurnstile>\<star> p\<close>
  using strong_soundness soundness_AxB .

lemma AxB_symmetric':
  assumes \<open>AxB \<le> A\<close> \<open>consistent A V\<close> \<open>maximal A V\<close> \<open>consistent A W\<close> \<open>maximal A W\<close>
    and \<open>W \<in> reach A i V\<close>
  shows \<open>V \<in> reach A i W\<close>
proof -
  have \<open>\<forall>p. K i p \<in> W \<longrightarrow> p \<in> V\<close>
  proof (safe, rule ccontr)
    fix p
    assume \<open>K i p \<in> W\<close> \<open>p \<notin> V\<close>
    then have \<open>(\<^bold>\<not> p) \<in> V\<close>
      using assms(2-3) exactly_one_in_maximal by fast
    then have \<open>K i (L i (\<^bold>\<not> p)) \<in> V\<close>
      using assms(1-3) ax_in_maximal AxB.intros consequent_in_maximal by fast
    then have \<open>L i (\<^bold>\<not> p) \<in> W\<close>
      using \<open>W \<in> reach A i V\<close> by fast
    then have \<open>(\<^bold>\<not> K i p) \<in> W\<close>
      using assms(4-5) by (meson K_LK consistent_consequent maximal_def)
    then show False
      using \<open>K i p \<in> W\<close> assms(4-5) exactly_one_in_maximal by fast
  qed
  then have \<open>known W i \<subseteq> V\<close>
    by blast
  then show ?thesis
    using assms(2-3) by simp
qed

lemma symmetric\<^sub>K\<^sub>B:
  assumes \<open>AxB \<le> A\<close>
  shows \<open>symmetric (canonical A)\<close>
  unfolding symmetric_def
proof (intro allI ballI)
  fix i V W
  assume \<open>V \<in> \<W> (canonical A)\<close> \<open>W \<in> \<W> (canonical A)\<close>
  then have \<open>consistent A V\<close> \<open>maximal A V\<close> \<open>consistent A W\<close> \<open>maximal A W\<close>
    by simp_all
  with AxB_symmetric' assms have \<open>W \<in> reach A i V \<longleftrightarrow> V \<in> reach A i W\<close>
    by metis
  then show \<open>(W \<in> \<K> (canonical A) i V) = (V \<in> \<K> (canonical A) i W)\<close>
    by simp
qed

abbreviation validKB (\<open>_ \<TTurnstile>\<^sub>K\<^sub>B _\<close> [50, 50] 50) where
  \<open>G \<TTurnstile>\<^sub>K\<^sub>B p \<equiv> symmetric; G \<TTurnstile> p\<close>

lemma strong_completeness\<^sub>K\<^sub>B: \<open>G \<TTurnstile>\<^sub>K\<^sub>B p \<Longrightarrow> G \<turnstile>\<^sub>K\<^sub>B p\<close>
  using strong_completeness symmetric\<^sub>K\<^sub>B by blast

theorem main\<^sub>K\<^sub>B: \<open>G \<TTurnstile>\<^sub>K\<^sub>B p \<longleftrightarrow> G \<turnstile>\<^sub>K\<^sub>B p\<close>
  using strong_soundness\<^sub>K\<^sub>B[of G p] strong_completeness\<^sub>K\<^sub>B[of G p] by fast

corollary \<open>G \<TTurnstile>\<^sub>K\<^sub>B p \<longrightarrow> symmetric; G \<TTurnstile>\<star> p\<close>
  using strong_soundness\<^sub>K\<^sub>B[of G p] strong_completeness\<^sub>K\<^sub>B[of G p] by fast

section \<open>System K4\<close>

inductive Ax4 :: \<open>'i fm \<Rightarrow> bool\<close> where
  \<open>Ax4 (K i p \<^bold>\<longrightarrow> K i (K i p))\<close>

abbreviation SystemK4 (\<open>_ \<turnstile>\<^sub>K\<^sub>4 _\<close> [50, 50] 50) where
  \<open>G \<turnstile>\<^sub>K\<^sub>4 p \<equiv> Ax4; G \<turnstile> p\<close>

lemma soundness_Ax4: \<open>Ax4 p \<Longrightarrow> transitive M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile> p\<close>
  by (induct p rule: Ax4.induct) (meson pos_introspection)

lemma strong_soundness\<^sub>K\<^sub>4: \<open>G \<turnstile>\<^sub>K\<^sub>4 p \<Longrightarrow> transitive; G \<TTurnstile>\<star> p\<close>
  using strong_soundness soundness_Ax4 .

lemma Ax4_transitive:
  assumes \<open>Ax4 \<le> A\<close> \<open>consistent A V\<close> \<open>maximal A V\<close>
    and \<open>W \<in> reach A i V\<close> \<open>U \<in> reach A i W\<close>
  shows \<open>U \<in> reach A i V\<close>
proof -
  have \<open>(K i p \<^bold>\<longrightarrow> K i (K i p)) \<in> V\<close> for p
    using assms(1-3) ax_in_maximal Ax4.intros by fast
  then have \<open>K i (K i p) \<in> V\<close> if \<open>K i p \<in> V\<close> for p
    using that assms(2-3) consequent_in_maximal by blast
  then show ?thesis
    using assms(4-5) by blast
qed

lemma transitive\<^sub>K\<^sub>4:
  assumes \<open>Ax4 \<le> A\<close>
  shows \<open>transitive (canonical A)\<close>
  unfolding transitive_def
proof safe
  fix i U V W
  assume \<open>V \<in> \<W> (canonical A)\<close>
  then have \<open>consistent A V\<close> \<open>maximal A V\<close>
    by simp_all
  moreover assume
    \<open>W \<in> \<K> (canonical A) i V\<close>
    \<open>U \<in> \<K> (canonical A) i W\<close>
  ultimately have \<open>U \<in> reach A i V\<close>
    using Ax4_transitive assms by simp
  then show \<open>U \<in> \<K> (canonical A) i V\<close>
    by simp
qed

abbreviation validK4 (\<open>_ \<TTurnstile>\<^sub>K\<^sub>4 _\<close> [50, 50] 50) where
  \<open>G \<TTurnstile>\<^sub>K\<^sub>4 p \<equiv> transitive; G \<TTurnstile> p\<close>

lemma strong_completeness\<^sub>K\<^sub>4: \<open>G \<TTurnstile>\<^sub>K\<^sub>4 p \<Longrightarrow> G \<turnstile>\<^sub>K\<^sub>4 p\<close>
  using strong_completeness transitive\<^sub>K\<^sub>4 by blast

theorem main\<^sub>K\<^sub>4: \<open>G \<TTurnstile>\<^sub>K\<^sub>4 p \<longleftrightarrow> G \<turnstile>\<^sub>K\<^sub>4 p\<close>
  using strong_soundness\<^sub>K\<^sub>4[of G p] strong_completeness\<^sub>K\<^sub>4[of G p] by fast

corollary \<open>G \<TTurnstile>\<^sub>K\<^sub>4 p \<longrightarrow> transitive; G \<TTurnstile>\<star> p\<close>
  using strong_soundness\<^sub>K\<^sub>4[of G p] strong_completeness\<^sub>K\<^sub>4[of G p] by fast

section \<open>System K5\<close>

inductive Ax5 :: \<open>'i fm \<Rightarrow> bool\<close> where
  \<open>Ax5 (L i p \<^bold>\<longrightarrow> K i (L i p))\<close>

abbreviation SystemK5 (\<open>_ \<turnstile>\<^sub>K\<^sub>5 _\<close> [50, 50] 50) where
  \<open>G \<turnstile>\<^sub>K\<^sub>5 p \<equiv> Ax5; G \<turnstile> p\<close>

lemma soundness_Ax5: \<open>Ax5 p \<Longrightarrow> Euclidean M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile> p\<close>
  by (induct p rule: Ax5.induct) (unfold Euclidean_def semantics.simps, blast)

lemma strong_soundness\<^sub>K\<^sub>5: \<open>G \<turnstile>\<^sub>K\<^sub>5 p \<Longrightarrow> Euclidean; G \<TTurnstile>\<star> p\<close>
  using strong_soundness soundness_Ax5 .

lemma Ax5_Euclidean:
  assumes \<open>Ax5 \<le> A\<close>
    \<open>consistent A U\<close> \<open>maximal A U\<close>
    \<open>consistent A V\<close> \<open>maximal A V\<close>
    \<open>consistent A W\<close> \<open>maximal A W\<close>
    and \<open>V \<in> reach A i U\<close> \<open>W \<in> reach A i U\<close>
  shows \<open>W \<in> reach A i V\<close>
  using assms
proof -
  { fix p
    assume \<open>K i p \<in> V\<close> \<open>p \<notin> W\<close>
    then have \<open>(\<^bold>\<not> p) \<in> W\<close>
      using assms(6-7) exactly_one_in_maximal by fast
    then have \<open>L i (\<^bold>\<not> p) \<in> U\<close>
      using assms(2-3, 6-7, 9) exactly_one_in_maximal by blast
    then have \<open>K i (L i (\<^bold>\<not> p)) \<in> U\<close>
      using assms(1-3) ax_in_maximal Ax5.intros consequent_in_maximal by fast
    then have \<open>L i (\<^bold>\<not> p) \<in> V\<close>
      using assms(8) by blast
    then have \<open>\<^bold>\<not> K i p \<in> V\<close>
      using assms(4-5) K_LK consequent_in_maximal deriv_in_maximal by fast
    then have False
      using assms(4-5) \<open>K i p \<in> V\<close> exactly_one_in_maximal by fast
  }
  then show ?thesis
    by blast
qed

lemma Euclidean\<^sub>K\<^sub>5:
  assumes \<open>Ax5 \<le> A\<close>
  shows \<open>Euclidean (canonical A)\<close>
  unfolding Euclidean_def
proof safe
  fix i U V W
  assume \<open>U \<in> \<W> (canonical A)\<close> \<open>V \<in> \<W> (canonical A)\<close> \<open>W \<in> \<W> (canonical A)\<close>
  then have
    \<open>consistent A U\<close> \<open>maximal A U\<close>
    \<open>consistent A V\<close> \<open>maximal A V\<close>
    \<open>consistent A W\<close> \<open>maximal A W\<close>
    by simp_all
  moreover assume
    \<open>V \<in> \<K> (canonical A) i U\<close>
    \<open>W \<in> \<K> (canonical A) i U\<close>
  ultimately have \<open>W \<in> reach A i V\<close>
    using Ax5_Euclidean assms by simp
  then show \<open>W \<in> \<K> (canonical A) i V\<close>
    by simp
qed

abbreviation validK5 (\<open>_ \<TTurnstile>\<^sub>K\<^sub>5 _\<close> [50, 50] 50) where
  \<open>G \<TTurnstile>\<^sub>K\<^sub>5 p \<equiv> Euclidean; G \<TTurnstile> p\<close>

lemma strong_completeness\<^sub>K\<^sub>5: \<open>G \<TTurnstile>\<^sub>K\<^sub>5 p \<Longrightarrow> G \<turnstile>\<^sub>K\<^sub>5 p\<close>
  using strong_completeness Euclidean\<^sub>K\<^sub>5 by blast

theorem main\<^sub>K\<^sub>5: \<open>G \<TTurnstile>\<^sub>K\<^sub>5 p \<longleftrightarrow> G \<turnstile>\<^sub>K\<^sub>5 p\<close>
  using strong_soundness\<^sub>K\<^sub>5[of G p] strong_completeness\<^sub>K\<^sub>5[of G p] by fast

corollary \<open>G \<TTurnstile>\<^sub>K\<^sub>5 p \<longrightarrow> Euclidean; G \<TTurnstile>\<star> p\<close>
  using strong_soundness\<^sub>K\<^sub>5[of G p] strong_completeness\<^sub>K\<^sub>5[of G p] by fast

section \<open>System S4\<close>

abbreviation Or :: \<open>('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool\<close> (infixl \<open>\<oplus>\<close> 65) where
  \<open>(A \<oplus> A') p \<equiv> A p \<or> A' p\<close>

abbreviation SystemS4 (\<open>_ \<turnstile>\<^sub>S\<^sub>4 _\<close> [50, 50] 50) where
  \<open>G \<turnstile>\<^sub>S\<^sub>4 p \<equiv> AxT \<oplus> Ax4; G \<turnstile> p\<close>

lemma soundness_AxT4: \<open>(AxT \<oplus> Ax4) p \<Longrightarrow> reflexive M \<and> transitive M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile> p\<close>
  using soundness_AxT soundness_Ax4 by fast

lemma strong_soundness\<^sub>S\<^sub>4: \<open>G \<turnstile>\<^sub>S\<^sub>4 p \<Longrightarrow> refltrans; G \<TTurnstile>\<star> p\<close>
  using strong_soundness soundness_AxT4 .

abbreviation validS4 (\<open>_ \<TTurnstile>\<^sub>S\<^sub>4 _\<close> [50, 50] 50) where
  \<open>G \<TTurnstile>\<^sub>S\<^sub>4 p \<equiv> refltrans; G \<TTurnstile> p\<close>

lemma strong_completeness\<^sub>S\<^sub>4: \<open>G \<TTurnstile>\<^sub>S\<^sub>4 p \<Longrightarrow> G \<turnstile>\<^sub>S\<^sub>4 p\<close>
  using strong_completeness[of refltrans] reflexive\<^sub>T[of \<open>AxT \<oplus> Ax4\<close>] transitive\<^sub>K\<^sub>4[of \<open>AxT \<oplus> Ax4\<close>]
  by blast

theorem main\<^sub>S\<^sub>4: \<open>G \<TTurnstile>\<^sub>S\<^sub>4 p \<longleftrightarrow> G \<turnstile>\<^sub>S\<^sub>4 p\<close>
  using strong_soundness\<^sub>S\<^sub>4[of G p] strong_completeness\<^sub>S\<^sub>4[of G p] by fast

corollary \<open>G \<TTurnstile>\<^sub>S\<^sub>4 p \<longrightarrow> refltrans; G \<TTurnstile>\<star> p\<close>
  using strong_soundness\<^sub>S\<^sub>4[of G p] strong_completeness\<^sub>S\<^sub>4[of G p] by fast

section \<open>System S5\<close>

subsection \<open>T + B + 4\<close>

abbreviation SystemS5 (\<open>_ \<turnstile>\<^sub>S\<^sub>5 _\<close> [50, 50] 50) where
  \<open>G \<turnstile>\<^sub>S\<^sub>5 p \<equiv> AxT \<oplus> AxB \<oplus> Ax4; G \<turnstile> p\<close>

abbreviation AxTB4 :: \<open>'i fm \<Rightarrow> bool\<close> where
  \<open>AxTB4 \<equiv> AxT \<oplus> AxB \<oplus> Ax4\<close>

lemma soundness_AxTB4: \<open>AxTB4 p \<Longrightarrow> equivalence M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile> p\<close>
  using soundness_AxT soundness_AxB soundness_Ax4 by fast

lemma strong_soundness\<^sub>S\<^sub>5: \<open>G \<turnstile>\<^sub>S\<^sub>5 p \<Longrightarrow> equivalence; G \<TTurnstile>\<star> p\<close>
  using strong_soundness soundness_AxTB4 .

abbreviation validS5 (\<open>_ \<TTurnstile>\<^sub>S\<^sub>5 _\<close> [50, 50] 50) where
  \<open>G \<TTurnstile>\<^sub>S\<^sub>5 p \<equiv> equivalence; G \<TTurnstile> p\<close>

lemma strong_completeness\<^sub>S\<^sub>5: \<open>G \<TTurnstile>\<^sub>S\<^sub>5 p \<Longrightarrow> G \<turnstile>\<^sub>S\<^sub>5 p\<close>
  using strong_completeness[of equivalence]
    reflexive\<^sub>T[of AxTB4] symmetric\<^sub>K\<^sub>B[of AxTB4] transitive\<^sub>K\<^sub>4[of AxTB4]
  by blast

theorem main\<^sub>S\<^sub>5: \<open>G \<TTurnstile>\<^sub>S\<^sub>5 p \<longleftrightarrow> G \<turnstile>\<^sub>S\<^sub>5 p\<close>
  using strong_soundness\<^sub>S\<^sub>5[of G p] strong_completeness\<^sub>S\<^sub>5[of G p] by fast

corollary \<open>G \<TTurnstile>\<^sub>S\<^sub>5 p \<longrightarrow> equivalence; G \<TTurnstile>\<star> p\<close>
  using strong_soundness\<^sub>S\<^sub>5[of G p] strong_completeness\<^sub>S\<^sub>5[of G p] by fast

subsection \<open>T + 5\<close>

abbreviation SystemS5' (\<open>_ \<turnstile>\<^sub>S\<^sub>5'' _\<close> [50, 50] 50) where
  \<open>G \<turnstile>\<^sub>S\<^sub>5' p \<equiv> AxT \<oplus> Ax5; G \<turnstile> p\<close>

abbreviation AxT5 :: \<open>'i fm \<Rightarrow> bool\<close> where
  \<open>AxT5 \<equiv> AxT \<oplus> Ax5\<close>

lemma symm_trans_Euclid: \<open>symmetric M \<Longrightarrow> transitive M \<Longrightarrow> Euclidean M\<close>
  unfolding symmetric_def transitive_def Euclidean_def by blast

lemma soundness_AxT5: \<open>AxT5 p \<Longrightarrow> equivalence M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile> p\<close>
  using soundness_AxT[of p M w] soundness_Ax5[of p M w] symm_trans_Euclid by blast

lemma strong_soundness\<^sub>S\<^sub>5': \<open>G \<turnstile>\<^sub>S\<^sub>5' p \<Longrightarrow> equivalence; G \<TTurnstile>\<star> p\<close>
  using strong_soundness soundness_AxT5 .

lemma refl_Euclid_equiv: \<open>reflexive M \<Longrightarrow> Euclidean M \<Longrightarrow> equivalence M\<close>
  unfolding reflexive_def symmetric_def transitive_def Euclidean_def by metis

lemma strong_completeness\<^sub>S\<^sub>5': \<open>G \<TTurnstile>\<^sub>S\<^sub>5 p \<Longrightarrow> G \<turnstile>\<^sub>S\<^sub>5' p\<close>
  using strong_completeness[of equivalence]
    reflexive\<^sub>T[of AxT5] Euclidean\<^sub>K\<^sub>5[of AxT5] refl_Euclid_equiv by blast

theorem main\<^sub>S\<^sub>5': \<open>G \<TTurnstile>\<^sub>S\<^sub>5 p \<longleftrightarrow> G \<turnstile>\<^sub>S\<^sub>5' p\<close>
  using strong_soundness\<^sub>S\<^sub>5'[of G p] strong_completeness\<^sub>S\<^sub>5'[of G p] by fast

subsection \<open>Equivalence between systems\<close>

subsubsection \<open>Axiom 5 from B and 4\<close>

lemma K4_L:
  assumes \<open>Ax4 \<le> A\<close>
  shows \<open>A \<turnstile> L i (L i p) \<^bold>\<longrightarrow> L i p\<close>
proof -
  have \<open>A \<turnstile> K i (\<^bold>\<not> p) \<^bold>\<longrightarrow> K i (K i (\<^bold>\<not> p))\<close>
    using assms by (auto intro: Ax Ax4.intros)
  then show ?thesis
    by (meson K_LK K_trans R1)
qed

lemma KB4_5:
  assumes \<open>AxB \<le> A\<close> \<open>Ax4 \<le> A\<close>
  shows \<open>A \<turnstile> L i p \<^bold>\<longrightarrow> K i (L i p)\<close>
proof -
  have \<open>A \<turnstile> L i p \<^bold>\<longrightarrow> K i (L i (L i p))\<close>
    using assms by (auto intro: Ax AxB.intros)
  moreover have \<open>A \<turnstile> L i (L i p) \<^bold>\<longrightarrow> L i p\<close>
    using assms by (auto intro: K4_L)
  then have \<open>A \<turnstile> K i (L i (L i p)) \<^bold>\<longrightarrow> K i (L i p)\<close>
    using K_map by fast
  ultimately show ?thesis
    using K_trans R1 by metis
qed

subsubsection \<open>Axioms B and 4 from T and 5\<close>

lemma T_L:
  assumes \<open>AxT \<le> A\<close>
  shows \<open>A \<turnstile> p \<^bold>\<longrightarrow> L i p\<close>
proof -
  have \<open>A \<turnstile> K i (\<^bold>\<not> p) \<^bold>\<longrightarrow> \<^bold>\<not> p\<close>
    using assms by (auto intro: Ax AxT.intros)
  moreover have \<open>A \<turnstile> (P \<^bold>\<longrightarrow> \<^bold>\<not> Q) \<^bold>\<longrightarrow> Q \<^bold>\<longrightarrow> \<^bold>\<not> P\<close> for P Q
    by (auto intro: A1)
  ultimately show ?thesis
    by (auto intro: R1)
qed

lemma S5'_B:
  assumes \<open>AxT \<le> A\<close> \<open>Ax5 \<le> A\<close>
  shows \<open>A \<turnstile> p \<^bold>\<longrightarrow> K i (L i p)\<close>
proof -
  have \<open>A \<turnstile> L i p \<^bold>\<longrightarrow> K i (L i p)\<close>
    using assms(2) by (auto intro: Ax Ax5.intros)
  moreover have \<open>A \<turnstile> p \<^bold>\<longrightarrow> L i p\<close>
    using assms(1) by (auto intro: T_L)
  ultimately show ?thesis
    using K_trans R1 by metis
qed

lemma K5_L:
  assumes \<open>Ax5 \<le> A\<close>
  shows \<open>A \<turnstile> L i (K i p) \<^bold>\<longrightarrow> K i p\<close>
proof -
  have \<open>A \<turnstile> L i (\<^bold>\<not> p) \<^bold>\<longrightarrow> K i (L i (\<^bold>\<not> p))\<close>
    using assms by (auto intro: Ax Ax5.intros)
  then have \<open>A \<turnstile> L i (\<^bold>\<not> p) \<^bold>\<longrightarrow> K i (\<^bold>\<not> K i p)\<close>
    using K_LK by (metis K_map K_trans R1)
  moreover have \<open>A \<turnstile> (P \<^bold>\<longrightarrow> Q) \<^bold>\<longrightarrow> \<^bold>\<not> Q \<^bold>\<longrightarrow> \<^bold>\<not> P\<close> for P Q
    by (auto intro: A1)
  ultimately have \<open>A \<turnstile> \<^bold>\<not> K i (\<^bold>\<not> K i p) \<^bold>\<longrightarrow> \<^bold>\<not> L i (\<^bold>\<not> p)\<close>
    using R1 by blast
  then have \<open>A \<turnstile> \<^bold>\<not> K i (\<^bold>\<not> K i p) \<^bold>\<longrightarrow> K i p\<close>
    using K_L_dual R1 K_trans by metis
  then show ?thesis
    by blast
qed

lemma S5'_4:
  assumes \<open>AxT \<le> A\<close> \<open>Ax5 \<le> A\<close>
  shows \<open>A \<turnstile> K i p \<^bold>\<longrightarrow> K i (K i p)\<close>
proof -
  have \<open>A \<turnstile> L i (K i p) \<^bold>\<longrightarrow> K i (L i (K i p))\<close>
    using assms(2) by (auto intro: Ax Ax5.intros)
  moreover have \<open>A \<turnstile> K i p \<^bold>\<longrightarrow> L i (K i p)\<close>
    using assms(1) by (auto intro: T_L)
  ultimately have \<open>A \<turnstile> K i p \<^bold>\<longrightarrow> K i (L i (K i p))\<close>
    using K_trans R1 by metis
  moreover have \<open>A \<turnstile> L i (K i p) \<^bold>\<longrightarrow> K i p\<close>
    using assms(2) K5_L by metis
  then have \<open>A \<turnstile> K i (L i (K i p)) \<^bold>\<longrightarrow> K i (K i p)\<close>
    using K_map by fast
  ultimately show ?thesis
    using R1 K_trans by metis
qed

lemma S5_S5': \<open>AxTB4 \<turnstile> p \<Longrightarrow> AxT5 \<turnstile> p\<close>
proof (induct p rule: AK.induct)
  case (Ax p)
  moreover have \<open>AxT5 \<turnstile> p\<close> if \<open>AxT p\<close>
    using that AK.Ax by metis
  moreover have \<open>AxT5 \<turnstile> p\<close> if \<open>AxB p\<close>
    using that S5'_B by (metis (no_types, lifting) AxB.cases predicate1I)
  moreover have \<open>AxT5 \<turnstile> p\<close> if \<open>Ax4 p\<close>
    using that S5'_4 by (metis (no_types, lifting) Ax4.cases predicate1I)
  ultimately show ?case
    by blast
qed (auto intro: AK.intros)

lemma S5'_S5: \<open>AxT5 \<turnstile> p \<Longrightarrow> AxTB4 \<turnstile> p\<close>
proof (induct p rule: AK.induct)
  case (Ax p)
  moreover have \<open>AxTB4 \<turnstile> p\<close> if \<open>AxT p\<close>
    using that AK.Ax by metis
  moreover have \<open>AxTB4 \<turnstile> p\<close> if \<open>Ax5 p\<close>
    using that KB4_5 by (metis (no_types, lifting) Ax5.cases predicate1I)
  ultimately show ?case
    by blast
qed (auto intro: AK.intros)

corollary S5_S5'_assms: \<open>G \<turnstile>\<^sub>S\<^sub>5 p \<longleftrightarrow> G \<turnstile>\<^sub>S\<^sub>5' p\<close>
  using S5_S5' S5'_S5 by blast

section \<open>Acknowledgements\<close>

text \<open>
The formalization is inspired by Berghofer's formalization of Henkin-style completeness.

  \<^item> Stefan Berghofer:
  First-Order Logic According to Fitting.
  \<^url>\<open>https://www.isa-afp.org/entries/FOL-Fitting.shtml\<close>
\<close>

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

section "Normalising Word Numerals"

theory Norm_Words
imports "Signed_Words"
begin

text \<open>
  Normalise word numerals, including negative ones apart from @{term "-1"}, to the
  interval \<open>[0..2^len_of 'a)\<close>. Only for concrete word lengths.
\<close>

lemma neg_num_bintr:
  "(- numeral x :: 'a::len word) =
  word_of_int (bintrunc (LENGTH('a)) (-numeral x))"
  by (simp only: word_ubin.Abs_norm word_neg_numeral_alt)

ML \<open>
  fun is_refl (Const (@{const_name Pure.eq}, _) $ x $ y) = (x = y)
    | is_refl _ = false;

  fun signed_dest_wordT (Type (@{type_name word}, [Type (@{type_name signed}, [T])])) = Word_Lib.dest_binT T
    | signed_dest_wordT T = Word_Lib.dest_wordT T

  fun typ_size_of t = signed_dest_wordT (type_of (Thm.term_of t));

  fun num_len (Const (@{const_name Num.Bit0}, _) $ n) = num_len n + 1
    | num_len (Const (@{const_name Num.Bit1}, _) $ n) = num_len n + 1
    | num_len (Const (@{const_name Num.One}, _)) = 1
    | num_len (Const (@{const_name numeral}, _) $ t) = num_len t
    | num_len (Const (@{const_name uminus}, _) $ t) = num_len t
    | num_len t = raise TERM ("num_len", [t])

  fun unsigned_norm is_neg _ ctxt ct =
  (if is_neg orelse num_len (Thm.term_of ct) > typ_size_of ct then let
      val btr = if is_neg
                then @{thm neg_num_bintr} else @{thm num_abs_bintr}
      val th = [Thm.reflexive ct, mk_eq btr] MRS transitive_thm

      (* will work in context of theory Word as well *)
      val ss = simpset_of (@{context} addsimps @{thms bintrunc_numeral})
      val cnv = simplify (put_simpset ss ctxt) th
    in if is_refl (Thm.prop_of cnv) then NONE else SOME cnv end
    else NONE)
  handle TERM ("num_len", _) => NONE
       | TYPE ("dest_binT", _, _) => NONE
\<close>

simproc_setup
  unsigned_norm ("numeral n::'a::len word") = \<open>unsigned_norm false\<close>

simproc_setup
  unsigned_norm_neg0 ("-numeral (num.Bit0 num)::'a::len word") = \<open>unsigned_norm true\<close>

simproc_setup
  unsigned_norm_neg1 ("-numeral (num.Bit1 num)::'a::len word") = \<open>unsigned_norm true\<close>

declare word_pow_0 [simp]

lemma minus_one_norm:
  "(-1 :: 'a :: len word) = of_nat (2 ^ LENGTH('a) - 1)"
  by (simp add:of_nat_diff)

lemmas minus_one_norm_num =
  minus_one_norm [where 'a="'b::len bit0"] minus_one_norm [where 'a="'b::len0 bit1"]

lemma "f (7 :: 2 word) = f 3" by simp

lemma "f (-2) = f (21 + 1 :: 3 word)" by simp

lemma "f (-2) = f (13 + 1 :: 'a::len word)"
  apply simp (* does not touch generic word length *)
  oops

lemma "f (-2) = f (0xFFFFFFFE :: 32 word)" by simp

lemma "(-1 :: 2 word) = 3" by simp

lemma "f (-2) = f (0xFFFFFFFE :: 32 signed word)" by simp

text \<open>
  We leave @{term "-1"} untouched by default, because it is often useful
  and its normal form can be large.
  To include it in the normalisation, add @{thm [source] minus_one_norm_num}.
  The additional normalisation is restricted to concrete numeral word lengths,
  like the rest.
\<close>
context
  notes minus_one_norm_num [simp]
begin

lemma "f (-1) = f (15 :: 4 word)" by simp

lemma "f (-1) = f (7 :: 3 word)" by simp

lemma "f (-1) = f (0xFFFF :: 16 word)" by simp

lemma "f (-1) = f (0xFFFF + 1 :: 'a::len word)"
  apply simp (* does not touch generic -1 *)
  oops

end

end