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

section \<open>Bell Numbers and Spivey's Generalized Recurrence\<close>

theory Bell_Numbers
imports
  "HOL-Library.FuncSet"
  "HOL-Library.Monad_Syntax"
  "HOL-Library.Stirling"
  Card_Partitions.Injectivity_Solver
  Card_Partitions.Card_Partitions
begin

subsection \<open>Preliminaries\<close>

subsubsection \<open>Additions to FuncSet\<close>

(* this is clearly to be added to FuncSet *)
lemma extensional_funcset_ext:
  assumes "f \<in> A \<rightarrow>\<^sub>E B" "g \<in> A \<rightarrow>\<^sub>E B"
  assumes "\<And>x. x \<in> A \<Longrightarrow> f x = g x"
  shows "f = g"
using assms by (metis PiE_iff extensionalityI)

subsubsection \<open>Additions for Injectivity Proofs\<close>

lemma inj_on_impl_inj_on_image:
  assumes "inj_on f A"
  assumes "\<And>x. x \<in> X \<Longrightarrow> x \<subseteq> A"
  shows "inj_on ((`) f) X"
using assms by (meson inj_onI inj_on_image_eq_iff)

lemma injectivity_union:
  assumes "A \<union> B = C \<union> D"
  assumes "P A" "P C"
  assumes "Q B" "Q D"
    "\<And>S T. P S \<Longrightarrow> Q T \<Longrightarrow> S \<inter> T = {}"
  shows "A = C \<and> B = D"
using assms Int_Un_distrib Int_commute inf_sup_absorb by blast+

lemma injectivity_image:
  assumes "f ` A = g ` A"
  assumes "\<forall>x\<in>A. invert (f x) = x \<and> invert (g x) = x"
  shows "\<forall>x\<in>A. f x = g x"
using assms by (metis (no_types, lifting) image_iff)

lemma injectivity_image_union:
  assumes "(\<lambda>X. X \<union> F X) ` P = (\<lambda>X. X \<union> G X) ` P'"
  assumes "\<forall>X \<in> P. X \<subseteq> A" "\<forall>X \<in> P'. X \<subseteq> A"
  assumes "\<forall>X \<in> P. \<forall>y\<in>F X. y \<notin> A" "\<forall>X \<in> P'. \<forall>y\<in>G X. y \<notin> A"
  shows "P = P'"
proof
  show "P \<subseteq> P'"
  proof
    fix X
    assume "X \<in> P"
    from assms(1) this obtain X' where "X' \<in> P'" and "X \<union> F X = X' \<union> G X'"
      by (metis imageE image_eqI)
    moreover from assms(2,4) \<open>X \<in> P\<close> have X: "(X \<union> F X) \<inter> A = X" by auto
    moreover from assms(3,5) \<open>X' \<in> P'\<close> have X': "(X' \<union> G X') \<inter> A = X'" by auto
    ultimately have "X = X'" by simp
    from this \<open>X' \<in> P'\<close> show "X \<in> P'" by auto
  qed
next
  show "P' \<subseteq> P"
  proof
    fix X'
    assume "X' \<in> P'"
    from assms(1) this obtain X where "X \<in> P" and "X \<union> F X = X' \<union> G X'"
      by (metis imageE image_eqI)
    moreover from assms(2,4) \<open>X \<in> P\<close> have X: "(X \<union> F X) \<inter> A = X" by auto
    moreover from assms(3,5) \<open>X' \<in> P'\<close> have X': "(X' \<union> G X') \<inter> A = X'" by auto
    ultimately have "X = X'" by simp
    from this \<open>X \<in> P\<close> show "X' \<in> P" by auto
  qed
qed

subsection \<open>Definition of Bell Numbers\<close>

definition Bell :: "nat \<Rightarrow> nat"
where
  "Bell n = card {P. partition_on {0..<n} P}"

lemma Bell_altdef:
  assumes "finite A"
  shows "Bell (card A) = card {P. partition_on A P}"
proof -
  from \<open>finite A\<close> obtain f where bij: "bij_betw f {0..<card A} A"
    using ex_bij_betw_nat_finite by blast
  from this have inj: "inj_on f {0..<card A}"
    using bij_betw_imp_inj_on by blast
  from bij have image_f_eq: "A = f ` {0..<card A}"
    using bij_betw_imp_surj_on by blast
  have "\<forall>x \<in> {P. partition_on {0..<card A} P}. x \<subseteq> Pow {0..<card A}"
    by (auto elim: partition_onE)
  from this inj have "inj_on ((`) ((`) f)) {P. partition_on {0..<card A} P}"
    by (intro inj_on_impl_inj_on_image[of _ "Pow {0..<card A}"]
     inj_on_impl_inj_on_image[of _ "{0..<card A}"]) blast+
  moreover from inj have "(`) ((`) f) ` {P. partition_on {0..<card A} P} = {P. partition_on A P}"
    by (subst image_f_eq, auto elim!: set_of_partition_on_map)
  ultimately have "bij_betw ((`) ((`) f)) {P. partition_on {0..<card A} P} {P. partition_on A P}"
    by (auto intro: bij_betw_imageI)
  from this \<open>finite A\<close> show ?thesis
    unfolding Bell_def
    by (subst bij_betw_iff_card[symmetric]) (auto intro: finitely_many_partition_on)
qed

lemma Bell_0:
  "Bell 0 = 1"
by (auto simp add: Bell_def partition_on_empty)

subsection \<open>Construction of the Partitions\<close>

definition construct_partition_on :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a set set set"
where
  "construct_partition_on B C =
    do {
       k  \<leftarrow> {0..card B};
       j  \<leftarrow> {0..card C};
       P  \<leftarrow> {P. partition_on C P \<and> card P = j};
       B' \<leftarrow> {B'. B' \<subseteq> B \<and> card B' = k};
       Q  \<leftarrow> {Q. partition_on B' Q};
       f  \<leftarrow> (B - B') \<rightarrow>\<^sub>E P;
       P'  \<leftarrow> {(\<lambda>X. X \<union> {x \<in> B - B'. f x = X}) ` P};
       {P' \<union> Q}
    }"

lemma construct_partition_on:
  assumes "finite B" "finite C"
  assumes "B \<inter> C = {}"
  shows "construct_partition_on B C = {P. partition_on (B \<union> C) P}"
proof (rule set_eqI')
  fix Q'
  assume "Q' \<in> construct_partition_on B C"
  from this obtain j k P P' Q B' f
    where "j \<le> card C"
    and "k \<le> card B"
    and P: "partition_on C P \<and> card P = j"
    and B': "B' \<subseteq> B \<and> card B' = k"
    and Q: "partition_on B' Q"
    and f: "f \<in> B - B' \<rightarrow>\<^sub>E P"
    and P': "P' = (\<lambda>X. X \<union> {x \<in> B - B'. f x = X}) ` P"
    and Q': "Q' = P' \<union> Q"
    unfolding construct_partition_on_def by auto
  from P f have "partition_on (B - B' \<union> C) P'"
    unfolding P' using \<open>B \<inter> C = {}\<close>
    by (intro partition_on_insert_elements) auto
  from this Q have "partition_on ((B - B' \<union> C) \<union> B') Q'"
    unfolding Q' using B' \<open>B \<inter> C = {}\<close> by (auto intro: partition_on_union)
  from this have "partition_on (B \<union> C) Q'"
    using B' by (metis Diff_partition sup.assoc sup.commute)
  from this show "Q' \<in> {P. partition_on (B \<union> C) P}" by auto
next
  fix Q'
  assume Q': "Q' \<in> {Q'. partition_on (B \<union> C) Q'}"
  from Q' have "{} \<notin> Q'" by (auto elim!: partition_onE)
  obtain Q where Q: "Q = ((\<lambda>X. if X \<subseteq> B then X else {}) ` Q') - {{}}" by blast
  obtain P' where P': "P' = ((\<lambda>X. if X \<subseteq> B then {} else X) ` Q') - {{}}" by blast
  from P' Q \<open>{} \<notin> Q'\<close> have Q'_prop: "Q' = P' \<union> Q" by auto
  have P'_nosubset: "\<forall>X \<in> P'. \<not> X \<subseteq> B"
    unfolding P' by auto
  moreover have "\<forall>X \<in> P'. X \<subseteq> B \<union> C"
    using Q' P' by (auto elim: partition_onE)
  ultimately have P'_witness: "\<forall>X \<in> P'. \<exists>x. x \<in> X \<inter> C"
    using \<open>B \<inter> C = {}\<close> by fastforce
  obtain B' where B': "B' = \<Union>Q" by blast
  have Q_prop: "partition_on B' Q"
    using B' Q' Q'_prop partition_on_split2 mem_Collect_eq by blast
  have "\<Union>P' = B - B' \<union> C"
  proof
    have "\<Union>Q' = B \<union> C" "\<forall>X\<in>Q'. \<forall>X'\<in>Q'. X \<noteq> X' \<longrightarrow> X \<inter> X' = {}"
      using Q' unfolding partition_on_def disjoint_def by auto
    from this show "\<Union>P' \<subseteq> B - B' \<union> C"
      unfolding P' B' Q by auto blast
  next
    show "B - B' \<union> C \<subseteq> \<Union>P'"
    proof
      fix x
      assume "x \<in> B - B' \<union> C"
      from this obtain X where X: "x \<in> X" "X \<in> Q'"
        using Q' by (metis Diff_iff Un_iff mem_Collect_eq partition_on_partition_on_unique)
      have "\<forall>X \<in> Q'. X \<subseteq> B \<longrightarrow> X \<subseteq> B'"
        unfolding B' Q by auto
      from this X \<open>x \<in> B - B' \<union> C\<close> have "\<not> X \<subseteq> B"
        using \<open>B \<inter> C = {}\<close> by auto
      from this \<open>X \<in> Q'\<close> have "X \<in> P'" using P' by auto
      from this \<open>x \<in> X\<close> show "x \<in> \<Union>P'" by auto
    qed
  qed
  from this have partition_on_P': "partition_on (B - B' \<union> C) P'"
    using partition_on_split1 Q'_prop Q' mem_Collect_eq by fastforce
  obtain P where P: "P = (\<lambda>X. X \<inter> C) ` P'" by blast
  from P partition_on_P' P'_witness have "partition_on C P"
    using partition_on_intersect_on_elements by auto
  obtain f where f: "f = (\<lambda>x. if x \<in> B - B' then (THE X. x \<in> X \<and> X \<in> P') \<inter> C else undefined)" by blast
  have P'_prop: "P' = (\<lambda>X. X \<union> {x \<in> B - B'. f x = X}) ` P"
  proof
    {
      fix X
      assume "X \<in> P'"
      have X_subset: "X \<subseteq> (B - B') \<union> C"
        using partition_on_P' \<open>X \<in> P'\<close> by (auto elim: partition_onE)
      have "X = X \<inter> C \<union> {x \<in> B - B'. f x = X \<inter> C}"
      proof
        {
          fix x
          assume  "x \<in> X"
          from this X_subset have "x \<in> (B - B') \<union> C" by auto
          from this have "x \<in> X \<inter> C \<union> {xa \<in> B - B'. f xa = X \<inter> C}"
          proof
            assume "x \<in> C"
            from this \<open>x \<in> X\<close> show ?thesis by simp
          next
            assume "x \<in> B - B'"
            from partition_on_P' \<open>x \<in> X\<close> \<open>X \<in> P'\<close> have "(THE X. x \<in> X \<and> X \<in> P') = X"
              by (simp add: partition_on_the_part_eq)
            from \<open>x \<in> B - B'\<close> this show ?thesis unfolding f by auto
          qed
        }
        from this show "X \<subseteq> X \<inter> C \<union> {x \<in> B - B'. f x = X \<inter> C}" by auto
      next
        show "X \<inter> C \<union> {xa \<in> B - B'. f xa = X \<inter> C} \<subseteq> X"
        proof
          fix x
          assume "x \<in> X \<inter> C \<union> {x \<in> B - B'. f x = X \<inter> C}"
          from this show "x \<in> X"
          proof
            assume "x \<in> X \<inter> C"
            from this show ?thesis by simp
          next
            assume x_in: "x \<in> {x \<in> B - B'. f x = X \<inter> C}"
            from this have ex1: "\<exists>!X. x \<in> X \<and> X \<in> P'"
              using partition_on_P' by (auto intro!: partition_on_partition_on_unique)
            from x_in X_subset have eq: "(THE X. x \<in> X \<and> X \<in> P') \<inter> C = X \<inter> C"
              unfolding f by auto
           from P'_nosubset \<open>X \<in> P'\<close> have "\<not> X \<subseteq> B" by simp
           from this have "X \<inter> C \<noteq> {}"
             using X_subset assms(3) by blast
           from this obtain y where y: "y \<in> X \<inter> C" by auto
           from this eq have y_in: "y \<in> (THE X. x \<in> X \<and> X \<in> P') \<inter> C" by simp
           from y y_in have "y \<in> X" "y \<in> (THE X. x \<in> X \<and> X \<in> P')" by auto
           moreover from y have "\<exists>!X. y \<in> X \<and> X \<in> P'"
             using partition_on_P' by (simp add: partition_on_partition_on_unique)
           moreover have "(THE X. x \<in> X \<and> X \<in> P') \<in> P'"
             using ex1 by (rule the1I2) auto
           ultimately have "(THE X. x \<in> X \<and> X \<in> P') = X" using \<open>X \<in> P'\<close> by auto
           from this ex1 show ?thesis by (auto intro: the1I2)
          qed
        qed
      qed
      from \<open>X \<in> P'\<close> this have "X \<in> (\<lambda>X. X \<union> {x \<in> B - B'. f x = X}) ` P"
        unfolding P by simp
    }
    from this show "P' \<subseteq> (\<lambda>X. X \<union> {x \<in> B - B'. f x = X}) ` P" ..
  next
    {
      fix x
      assume x_in_image: "x \<in> (\<lambda>X. X \<union> {x \<in> B - B'. f x = X}) ` P"
      {
        fix X
        assume "X \<in> P'"
        have "{x \<in> B - B'. f x = X \<inter> C} =  {x \<in> B - B'. x \<in> X}"
        proof -
          {
            fix x
            assume "x \<in> B - B'"
            from this have ex1: "\<exists>!X. x \<in> X \<and> X \<in> P'"
              using partition_on_P' by (auto intro!: partition_on_partition_on_unique)
            from this have in_p: "(THE X. x \<in> X \<and> X \<in> P') \<in> P'"
              and x_in: "x \<in> (THE X. x \<in> X \<and> X \<in> P')"
              by (metis (mono_tags, lifting) theI)+
            have "f x = X \<inter> C \<longleftrightarrow> (THE X. x \<in> X \<and> X \<in> P') \<inter> C = X \<inter> C"
              using \<open>x \<in> B - B'\<close> unfolding f by auto
            also have "... \<longleftrightarrow> (THE X. x \<in> X \<and> X \<in> P') = X"
            proof
              assume "(THE X. x \<in> X \<and> X \<in> P') = X"
              from this show "(THE X. x \<in> X \<and> X \<in> P') \<inter> C = X \<inter> C" by auto
            next
              assume "(THE X. x \<in> X \<and> X \<in> P') \<inter> C = X \<inter> C"
              have "(THE X. x \<in> X \<and> X \<in> P') \<inter> X \<noteq> {}"
                using P'_witness \<open>(THE X. x \<in> X \<and> X \<in> P') \<inter> C = X \<inter> C\<close> \<open>X \<in> P'\<close> by fastforce
              from this show "(THE X. x \<in> X \<and> X \<in> P') = X"
                using partition_on_P'[unfolded partition_on_def disjoint_def] in_p \<open>X \<in> P'\<close> by metis
            qed
            also have "... \<longleftrightarrow> x \<in> X"
              using ex1 \<open>X \<in> P'\<close> x_in by (auto; metis (no_types, lifting) the_equality)
            finally have "f x = X \<inter> C \<longleftrightarrow> x \<in> X" .
          }
          from this show ?thesis by auto
        qed
        moreover have  "X \<subseteq> B - B' \<union> C"
          using partition_on_P' \<open>X \<in> P'\<close> by (blast elim: partition_onE)
        ultimately have "X \<inter> C \<union> {x \<in> B. x \<notin> B' \<and> f x = X \<inter> C} = X" by auto
      }
      from this x_in_image have "x \<in> P'" unfolding P by auto
    }
    from this show "(\<lambda>X. X \<union> {x \<in> B - B'. f x = X}) ` P \<subseteq> P'" ..
  qed
  from partition_on_P' have f_prop: "f \<in> (B - B') \<rightarrow>\<^sub>E P"
    unfolding f P by (auto simp add: partition_on_the_part_mem)
  from Q B' have "B' \<subseteq> B" by auto
  obtain k where k: "k = card B'" by blast
  from \<open>finite B\<close> \<open>B' \<subseteq> B\<close> k have k_prop: "k \<in> {0..card B}" by (simp add: card_mono)
  obtain j where j: "j = card P" by blast
  from j \<open>partition_on C P\<close> have j_prop: "j \<in> {0..card C}"
    by (simp add: assms(2) partition_on_le_set_elements)
  from \<open>partition_on C P\<close> j have P_prop: "partition_on C P \<and> card P = j" by auto
  from k \<open>B' \<subseteq> B\<close> have B'_prop: "B' \<subseteq> B \<and> card B' = k" by auto
  show "Q' \<in> construct_partition_on B C"
    using j_prop k_prop P_prop B'_prop Q_prop P'_prop f_prop Q'_prop
    unfolding construct_partition_on_def
    by (auto simp del: atLeastAtMost_iff) blast
qed

subsection \<open>Injectivity of the Set Construction\<close>

lemma injectivity:
  assumes "B \<inter> C = {}"
  assumes P: "(partition_on C P \<and> card P = j) \<and> (partition_on C P' \<and> card P' = j')"
  assumes B': "(B' \<subseteq> B \<and> card B' = k) \<and> (B'' \<subseteq> B \<and> card B'' = k')"
  assumes Q: "partition_on B' Q \<and> partition_on B'' Q'"
  assumes f: "f \<in> B - B' \<rightarrow>\<^sub>E P \<and> g \<in> B - B'' \<rightarrow>\<^sub>E P'"
  assumes P': "P'' = (\<lambda>X. X \<union> {x \<in> B - B'. f x = X}) ` P \<and>
    P''' = (\<lambda>X. X \<union> {x \<in> B - B''. g x = X}) ` P'"
  assumes eq_result: "P'' \<union> Q = P''' \<union> Q'"
  shows "f = g" and "Q = Q'" and "B' = B''"
    and "P = P'" and "j = j'" and "k = k'"
proof -
  have P_nonempty_sets: "\<forall>X\<in>P. \<exists>c\<in>C. c \<in> X" "\<forall>X\<in>P'. \<exists>c\<in>C. c \<in> X"
    using P by (force elim: partition_onE)+
  have 1: "\<forall>X\<in>P''. \<exists>c\<in>C. c \<in> X" "\<forall>X\<in>P'''. \<exists>c\<in>C. c \<in> X"
    using P' P_nonempty_sets by fastforce+
  have 2: "\<forall>X\<in>Q. \<forall>x\<in>X. x \<notin> C" "\<forall>X\<in>Q'. \<forall>x\<in>X. x \<notin> C"
    using \<open>B \<inter> C = {}\<close> Q B' by (auto elim: partition_onE)
  from eq_result have "P'' = P'''" and "Q = Q'"
    by (auto dest: injectivity_union[OF _ 1 2])
  from this Q show "Q = Q'" and "B' = B''"
    by (auto intro!: partition_on_eq_implies_eq_carrier)
  have subset_C: "\<forall>X\<in>P. X \<subseteq> C" "\<forall>X\<in>P'. X \<subseteq> C"
    using P by (auto elim: partition_onE)
  have eq_image: "(\<lambda>X. X \<union> {x \<in> B - B'. f x = X}) ` P = (\<lambda>X. X \<union> {x \<in> B - B''. g x = X}) ` P'"
    using P' \<open>P'' = P'''\<close> by auto
  from this \<open>B \<inter> C = {}\<close>  show "P = P'"
    by (auto dest: injectivity_image_union[OF _ subset_C])
  have eq2: "(\<lambda>X. X \<union> {x \<in> B - B'. f x = X}) ` P = (\<lambda>X. X \<union> {x \<in> B - B'. g x = X}) ` P"
    using \<open>P = P'\<close> \<open>B' = B''\<close> eq_image by simp
  from P have P_props: "\<forall>X \<in> P. X \<subseteq> C" "\<forall>X \<in> P. X \<noteq> {}" by (auto elim: partition_onE)
  have invert: "\<forall>X\<in>P. (X \<union> {x \<in> B - B'. f x = X}) \<inter> C = X \<and> (X \<union> {x \<in> B - B'. g x = X}) \<inter> C = X"
    using \<open>B \<inter> C = {}\<close> P_props by auto
  have eq3: "\<forall>X \<in> P. (X \<union> {x \<in> B - B'. f x = X}) = (X \<union> {x \<in> B - B'. g x = X})"
    using injectivity_image[OF eq2 invert] by blast
  have eq4: "\<forall>X \<in> P. {x \<in> B - B'. f x = X} = {x \<in> B - B'. g x = X}"
  proof
    fix X
    assume "X \<in> P"
    from this P have "X \<subseteq> C" by (auto elim: partition_onE)
    have disjoint: "X \<inter> {x \<in> B - B'. f x = X} = {}" "X \<inter> {x \<in> B - B'. g x = X} = {}"
      using \<open>B \<inter> C = {}\<close> \<open>X \<subseteq> C\<close> by auto
    from eq3 \<open>X \<in> P\<close> have "X \<union> {x \<in> B - B'. f x = X} = X \<union> {x \<in> B - B'. g x = X}" by auto
    from this disjoint show "{x \<in> B - B'. f x = X} = {x \<in> B - B'. g x = X}"
      by (auto intro: injectivity_union)
  qed
  from eq4 f have eq5: "\<forall>b\<in>B - B'. f b = g b" by blast
  from eq5 f \<open>B' = B''\<close> \<open>P = P'\<close> show eq6: "f = g" by (auto intro: extensional_funcset_ext)
  from P \<open>P = P'\<close> show "j = j'" by simp
  from B' \<open>B' = B''\<close> show "k = k'" by simp
qed

subsection \<open>The Generalized Bell Recurrence Relation\<close>

theorem Bell_eq:
  "Bell (n + m) = (\<Sum>k\<le>n. \<Sum>j\<le>m. j ^ (n - k) * Stirling m j * (n choose k) * Bell k)"
proof -
  define A where "A = {0..<n + m}"
  define B where "B = {0..<n}"
  define C where "C = {n..<n + m}"
  have "A = B \<union> C" "B \<inter> C = {}" "finite B" "card B = n" "finite C" "card C = m"
    unfolding A_def B_def C_def by auto
  have step1: "Bell (n + m) = card {P. partition_on A P}"
    unfolding Bell_def A_def ..
  from \<open>A = B \<union> C\<close> \<open>B \<inter> C = {}\<close> \<open>finite B\<close> \<open>finite C\<close>
  have step2: "card {P. partition_on A P} = card (construct_partition_on B C)"
    by (simp add: construct_partition_on)
  note injectivity = injectivity[OF \<open>B \<inter> C = {}\<close>]
  let ?expr = "do {
    k  \<leftarrow> {0..card B};
    j  \<leftarrow> {0..card C};
    P  \<leftarrow> {P. partition_on C P \<and> card P = j};
    B' \<leftarrow> {B'. B' \<subseteq> B \<and> card B' = k};
    Q  \<leftarrow> {Q. partition_on B' Q};
    f  \<leftarrow> (B - B') \<rightarrow>\<^sub>E P;
    P'  \<leftarrow> {(\<lambda>X. X \<union> {x \<in> B - B'. f x = X}) ` P};
    {P' \<union> Q}
  }"
  let "?S \<bind> ?comp" = ?expr
  {
    fix k
    assume k: "k \<in> {..card B}"
    let ?expr = "?comp k"
    let "?S \<bind> ?comp" = ?expr
    {
      fix j
      assume "j \<in> {.. card C}"
      let ?expr = "?comp j"
      let "?S \<bind> ?comp" = ?expr
      from \<open>finite C\<close> have "finite ?S"
        by (intro finite_Collect_conjI disjI1 finitely_many_partition_on)
      {
        fix P
        assume P: "P \<in> {P. partition_on C P \<and> card P = j}"
        from this have "partition_on C P" by simp
        let ?expr = "?comp P"
        let "?S \<bind> ?comp" = ?expr
        have "finite P"
         using P \<open>finite C\<close> by (auto intro: finite_elements)
        from \<open>finite B\<close> have "finite ?S" by (auto simp add: finite_subset)
        moreover
        {
          fix B'
          assume B': "B' \<in> {B'. B' \<subseteq> B \<and> card B' = k}"
          from this have "B' \<subseteq> B" by simp
          let ?expr = "?comp B'"
          let "?S \<bind> ?comp" = ?expr
          from \<open>finite B\<close> have "finite B'"
            using B' by (auto simp add: finite_subset)
          from \<open>finite B'\<close> have "finite {Q. partition_on B' Q}"
            by (rule finitely_many_partition_on)
          moreover
          {
            fix Q
            assume Q: "Q \<in> {Q. partition_on B' Q}"
            let ?expr = "?comp Q"
            let "?S \<bind> ?comp" = ?expr
            {
              fix f
              assume "f \<in> B - B' \<rightarrow>\<^sub>E P"
              let ?expr = "?comp f"
              let "?S \<bind> ?comp" = ?expr
              have "disjoint_family_on ?comp ?S"
                by (auto intro: disjoint_family_onI)
              from this have "card ?expr = 1"
                by (simp add: card_bind_constant)
              moreover have "finite ?expr"
                by (simp add: finite_bind)
              ultimately have "finite ?expr \<and> card ?expr = 1" by blast
            }
            moreover have "finite ?S"
              using \<open>finite B\<close> \<open>finite P\<close> by (auto intro: finite_PiE)
            moreover have "disjoint_family_on ?comp ?S"
              using P B' Q
              by (injectivity_solver rule: local.injectivity(1))
            moreover have "card ?S = j ^ (n - k)"
            proof -
              have "card (B - B') = n - k"
                using B' \<open>finite B'\<close> \<open>card B = n\<close>
                by (subst card_Diff_subset) auto
              from this show ?thesis
                using \<open>finite B\<close> P
                by (subst card_PiE) (simp add: prod_constant)+
            qed
            ultimately have "card ?expr = j ^ (n - k)"
              by (simp add: card_bind_constant)
            moreover have "finite ?expr"
              using \<open>finite ?S\<close> \<open>finite {P. partition_on C P \<and> card P = j}\<close>
              by (auto intro!: finite_bind)
            ultimately have "finite ?expr \<and> card ?expr = j ^ (n - k)" by blast
          } note inner = this
          moreover have "card ?S = Bell k"
            using B' \<open>finite B'\<close> by (auto simp add: Bell_altdef[symmetric])
          moreover have "disjoint_family_on ?comp ?S"
            using P B'
            by (injectivity_solver rule: local.injectivity(2))
          ultimately have "card ?expr = j ^ (n - k) * Bell k"
            by (subst card_bind_constant) auto
          moreover have "finite ?expr"
            using inner \<open>finite ?S\<close> by (auto intro: finite_bind)
          ultimately have "finite ?expr \<and> card ?expr = j ^ (n - k) * Bell k" by blast
        } note inner = this
        moreover have "card ?S = n choose k"
          using \<open>card B = n\<close> \<open>finite B\<close> by (simp add: n_subsets)
        moreover have "disjoint_family_on ?comp ?S"
          using P
          by (injectivity_solver rule: local.injectivity(3))
        ultimately have "card ?expr = j ^ (n - k) * (n choose k) * Bell k"
          by (subst card_bind_constant) auto
        moreover have "finite ?expr"
          using inner \<open>finite ?S\<close> by (auto intro: finite_bind)
        ultimately have "finite ?expr \<and> card ?expr = j ^ (n - k) * (n choose k) * Bell k" by blast
      } note inner = this
      moreover note \<open>finite ?S\<close>
      moreover have "card ?S = Stirling m j"
        using \<open>finite C\<close> \<open>card C = m\<close> by (simp add: card_partition_on)
      moreover have "disjoint_family_on ?comp ?S"
        by (injectivity_solver rule: local.injectivity(4))
      ultimately have "card ?expr = j ^ (n - k) * Stirling m j * (n choose k) * Bell k"
        by (subst card_bind_constant) auto
      moreover have "finite ?expr"
        using inner \<open>finite ?S\<close> by (auto intro: finite_bind)
      ultimately have "finite ?expr \<and> card ?expr = j ^ (n - k) * Stirling m j * (n choose k) * Bell k" by blast
    } note inner = this
    moreover have "finite ?S" by simp
    moreover have "disjoint_family_on ?comp ?S"
      by (injectivity_solver rule: local.injectivity(5))
    ultimately have "card ?expr = (\<Sum>j\<le>m. j ^ (n - k) * Stirling m j * (n choose k) * Bell k)" (is "_ = ?formula")
      using \<open>card C = m\<close> by (subst card_bind) (auto intro: sum.cong)
    moreover have "finite ?expr"
      using inner \<open>finite ?S\<close> by (auto intro: finite_bind)
    ultimately have "finite ?expr \<and> card ?expr = ?formula" by blast
  }
  moreover have "finite ?S" by simp
  moreover have "disjoint_family_on ?comp ?S"
    by (injectivity_solver rule: local.injectivity(6))
  ultimately have step3: "card (construct_partition_on B C) = (\<Sum>k\<le>n. \<Sum>j\<le>m. j ^ (n - k) * Stirling m j * (n choose k) * Bell k)"
    unfolding construct_partition_on_def
    using \<open>card B = n\<close> by (subst card_bind) (auto intro: sum.cong)
  from step1 step2 step3 show ?thesis by auto
qed

subsection \<open>Corollaries of the Generalized Bell Recurrence\<close>

corollary Bell_Stirling_eq:
  "Bell m = (\<Sum>j\<le>m. Stirling m j)"
proof -
  have "Bell m = Bell (0 + m)" by simp
  also have "... = (\<Sum>j\<le>m. Stirling m j)"
    unfolding Bell_eq[of 0] by (simp add: Bell_0)
  finally show ?thesis .
qed

corollary Bell_recursive_eq:
  "Bell (n + 1) = (\<Sum>k\<le>n. (n choose k) * Bell k)"
unfolding Bell_eq[of _ 1] by simp

end


theory LValues_Typed
  imports LValues
begin

typedef ('mem, 'val) lvalue = \<open>{xopt :: ('mem,'val) lvalue_raw option.
  case xopt of None \<Rightarrow> True | Some x \<Rightarrow>
    valid_lvalue x \<and> lv_range x = UNIV \<and> lv_domain x = UNIV}\<close>
  by (rule exI[of _ None], simp)
setup_lifting type_definition_lvalue

lift_definition valid_lvalue :: "('mem,'val) lvalue \<Rightarrow> bool" is "\<lambda>x. x \<noteq> None".

(* lift_definition compatible_lvalues :: "('mem,'val1) lvalue \<Rightarrow> ('mem,'val2) lvalue \<Rightarrow> bool" is
  \<open>\<lambda>x y. case (x,y) of (Some x, Some y) \<Rightarrow> LValues.compatible_lvalues x y | _ \<Rightarrow> False\<close>. *)

lift_definition lvalue_pair :: "('mem,'val1) lvalue \<Rightarrow> ('mem,'val2) lvalue \<Rightarrow> ('mem,'val1\<times>'val2) lvalue" is
  \<open>\<lambda>x y. case (x,y) of (Some x, Some y) \<Rightarrow>
    if LValues.compatible_lvalues x y then Some (LValues.lvalue_pair x y) else None
    | _ \<Rightarrow> None\<close>
  apply (rename_tac x y; case_tac x; case_tac y)
  by auto

abbreviation compatible_lvalues where
  "compatible_lvalues x y \<equiv> valid_lvalue (lvalue_pair x y)"

lemma compatible_valid1: "compatible_lvalues x y \<Longrightarrow> valid_lvalue x"
  apply transfer apply (rename_tac x y; case_tac x) by auto

lemma compatible_valid2: "compatible_lvalues x y \<Longrightarrow> valid_lvalue y"
  apply transfer apply (rename_tac x y; case_tac x; case_tac y) by auto

lift_definition lvalue_chain :: "('mem,'val1) lvalue \<Rightarrow> ('val1,'val2) lvalue \<Rightarrow> ('mem,'val2) lvalue" is
  \<open>\<lambda>x y. case (x,y) of (Some x, Some y) \<Rightarrow> Some (LValues.lvalue_chain x y)
    | _ \<Rightarrow> None\<close>
  apply (rename_tac x y; case_tac x; case_tac y) by auto

lemma "valid_lvalue x \<Longrightarrow> valid_lvalue y \<Longrightarrow> valid_lvalue (lvalue_chain x y)"
  apply transfer by auto

lift_definition the_invalid_lvalue :: "('mem,'val) lvalue" is "None"
  by auto

typedef 'mem memory_rest = "UNIV :: 'mem set set"..
setup_lifting type_definition_memory_rest
instance memory_rest :: (finite) finite
  apply intro_classes apply (rule finite_surj[where f=Abs_memory_rest and A=UNIV])
  using type_definition.Abs_image type_definition_memory_rest by force+

lift_definition split_memory :: "('mem,'val) lvalue \<Rightarrow> 'mem \<Rightarrow> ('val\<times>'mem memory_rest)" is
  "\<lambda>x m. case x of None \<Rightarrow> (undefined, {m})
                 | Some x \<Rightarrow> LValues.split_memory x m".

lift_definition join_memory :: "('mem,'val) lvalue \<Rightarrow> ('val\<times>'mem memory_rest) \<Rightarrow> 'mem" is
  "\<lambda>x m. case x of None \<Rightarrow> undefined
                 | Some x \<Rightarrow> LValues.join_memory x m".

lift_definition memory_except :: "('mem,'val) lvalue \<Rightarrow> 'mem memory_rest set" is
  "\<lambda>x. case x of Some x \<Rightarrow> LValues.memory_except x | None \<Rightarrow> undefined".

lemma split_memory_range:
  assumes [simp]: "valid_lvalue x"
  shows "split_memory x m \<in> UNIV \<times> memory_except x"
proof -
  have "snd (split_memory x m) \<in> memory_except x"
    using assms apply (transfer fixing: m) apply (case_tac x)
    by (auto simp add: LValues.memory_except_def LValues.split_memory_def quotientI)
  then show ?thesis
    by (simp add: mem_Times_iff)
qed

lemma split_memory_range':
  assumes [simp]: "valid_lvalue x"
  shows "range (split_memory x) = UNIV \<times> memory_except x"
  using assms apply (auto; transfer) apply auto
  apply (simp add: LValues.memory_except_def LValues.split_memory_def quotientI)
  by (metis UNIV_I bij_betw_def bij_split_memory mem_Times_iff snd_conv)

lift_definition setter :: "('mem,'val) lvalue \<Rightarrow> 'val \<Rightarrow> 'mem \<Rightarrow> 'mem" is
  "\<lambda>x. case x of Some x \<Rightarrow> lv_setter x | None \<Rightarrow> \<lambda>_. id".

lift_definition getter :: "('mem,'val) lvalue \<Rightarrow> 'mem \<Rightarrow> 'val" is
  "\<lambda>x. case x of Some x \<Rightarrow> lv_getter x | None \<Rightarrow> \<lambda>_. undefined".

lemma getter_pair[simp]:
  fixes x y
  assumes "compatible_lvalues x y"
  shows "getter (lvalue_pair x y) m = (getter x m, getter y m)"
  using assms apply (transfer fixing: m)
  apply (rename_tac x y; case_tac x; case_tac y)
     apply auto
  by (simp add: LValues.lvalue_pair_def)

lemma getter_setter[simp]:
  fixes x
  assumes "valid_lvalue x"
  shows "getter x (setter x a m) = a"
  using assms apply (transfer fixing: m)
  by auto

lemma getter_setter_compat[simp]:
  fixes x y
  assumes "compatible_lvalues x y"
  shows "getter x (setter y a m) = getter x m"
  using assms apply transfer
  apply (rename_tac x y a m; case_tac x; case_tac y)
  apply auto
  by (metis get_set_diff iso_tuple_UNIV_I option.distinct(1))

lift_definition unit_lvalue :: "('mem,unit) lvalue" is "Some (LValues.unit_lvalue UNIV)"
  by auto

lemma valid_unit_lvalue[simp]: "valid_lvalue unit_lvalue"
  apply transfer by simp

lemma unit_setter[simp]: "setter unit_lvalue x = id"
  apply transfer by simp

lemma unit_lvalue_compat[simp]:
  assumes [simp]: "valid_lvalue x"
  shows "compatible_lvalues unit_lvalue x"
  using assms apply transfer by auto

lemma unit_lvalue_compat'[simp]:
  assumes [simp]: "valid_lvalue x"
  shows "compatible_lvalues x unit_lvalue"
  using assms apply transfer by auto

lift_definition mk_lvalue :: "('mem\<Rightarrow>'val) \<Rightarrow> ('val\<Rightarrow>'mem\<Rightarrow>'mem) \<Rightarrow> ('mem,'val) lvalue" is
  "\<lambda>g s. let x = \<lparr> lv_domain=UNIV, lv_range=UNIV, lv_getter=g, lv_setter=s \<rparr> in
    if LValues.valid_lvalue x then Some x else None"
  by (smt option.simps(4) option.simps(5) select_convs(1) select_convs(2))

lemma mk_lvalue_valid:
  assumes [simp]: "\<And>a m. g (s a m) = a"
  assumes [simp]: "\<And>m. s (g m) m = m"
  assumes [simp]: "\<And>a b m. s a (s b m) = s a m"
  shows "valid_lvalue (mk_lvalue g s)"
  apply (transfer fixing: g s) apply (simp add: Let_def)
  apply (rule valid_lvalueI)
  by auto

lemma getter_mk_lvalue[simp]:
  assumes "valid_lvalue (mk_lvalue g s)"
  shows "getter (mk_lvalue g s) = g"
  using assms apply transfer by (auto simp: Let_def)

lemma setter_mk_lvalue[simp]:
  assumes "valid_lvalue (mk_lvalue g s)"
  shows "setter (mk_lvalue g s) = s"
  using assms apply transfer by (auto simp: Let_def)

lemma mk_lvalue_compat:
  assumes "valid_lvalue (mk_lvalue g s)"
  assumes "valid_lvalue (mk_lvalue g' s')"
  assumes [simp]: "\<And>a b m. s a (s' b m) = s' b (s a m)"
  shows "compatible_lvalues (mk_lvalue g s) (mk_lvalue g' s')"
  using assms(1,2) apply (transfer fixing: g s g' s')
  apply (auto simp: Let_def)
  apply (meson option.distinct(1))
  apply (meson option.distinct(1))
  apply (rule LValues.compatible_lvalues.intros)
  apply auto
  apply (meson option.distinct(1))
  by (meson option.distinct(1))

lemma setter_pair [simp]:
  assumes "compatible_lvalues x y"
  shows "setter (lvalue_pair x y) (a,b) m = setter y b (setter x a m)"
  using assms apply (transfer fixing: m a b)
  apply (rename_tac x y; case_tac x; case_tac y)
  by auto

lemma setter_pair':
  assumes "compatible_lvalues x y"
  shows "setter (lvalue_pair x y) ab m = setter y (snd ab) (setter x (fst ab) m)"
  by (metis LValues_Typed.setter_pair assms prod.exhaust_sel)

lift_definition fst_lvalue :: "('a*'b, 'a) lvalue" is
  "Some \<lparr> lv_domain=UNIV, lv_range=UNIV, lv_getter=fst, lv_setter=\<lambda>a (_,b). (a,b) \<rparr>"
  apply auto apply (rule valid_lvalueI) by auto

lift_definition snd_lvalue :: "('a*'b, 'b) lvalue" is
  "Some \<lparr> lv_domain=UNIV, lv_range=UNIV, lv_getter=snd, lv_setter=\<lambda>b (a,_). (a,b) \<rparr>"
  apply auto apply (rule valid_lvalueI) by auto

lemma valid_fst[simp]: "valid_lvalue fst_lvalue"
  apply transfer by simp

lemma valid_snd[simp]: "valid_lvalue snd_lvalue"
  apply transfer by simp

lemma compat_fst_snd[simp]: "compatible_lvalues fst_lvalue snd_lvalue"
  apply transfer apply auto
  apply (rule compatible_lvalues.intros)
     apply auto
   apply (rule valid_lvalueI; auto)
  by (rule valid_lvalueI; auto)

lift_definition function_lvalue :: "'a \<Rightarrow> ('a\<Rightarrow>'b, 'b) lvalue" is
  "\<lambda>i. Some \<lparr> lv_domain=UNIV, lv_range=UNIV, lv_getter=\<lambda>m. m i, lv_setter=\<lambda>a m. m(i:=a) \<rparr>"
  apply auto apply (rule valid_lvalueI) by auto

lemma valid_function_lvalue[simp]: "valid_lvalue (function_lvalue a)"
  apply transfer by auto

lemma compat_function_lvalue[simp]: "x \<noteq> y \<Longrightarrow> compatible_lvalues (function_lvalue x) (function_lvalue y)"
  apply (transfer fixing: x y) apply auto
  apply (rule compatible_lvalues.intros)
     apply auto
   apply (rule valid_lvalueI) apply auto
  apply (rule valid_lvalueI) by auto

lemma fst_split_memory[simp]:
  assumes "valid_lvalue x"
  shows "fst (split_memory x m) = getter x m"
  using assms apply transfer by auto

lemma split_pair_eq_typed:
  fixes x y
  assumes [simp]: "compatible_lvalues x y"
  defines "xy \<equiv> lvalue_pair x y"
  shows "snd (split_memory x m1) = snd (split_memory x m2)
     \<longleftrightarrow> snd (split_memory xy m1) = snd (split_memory xy m2)
         \<and> getter y m1 = getter y m2"
  unfolding xy_def using assms(1)
  apply (transfer fixing: m1 m2)
  apply (rename_tac x y; case_tac x; case_tac y)
     apply simp_all
  apply (subst split_pair_eq)
  apply auto
  by (meson option.distinct(1))

nonterminal lvalue_expr
nonterminal lvalue_expr_chain
nonterminal lvalue_expr_atom

syntax "" :: "id \<Rightarrow> lvalue_expr_atom" ("_")
syntax "" :: "lvalue_expr \<Rightarrow> lvalue_expr_atom" ("'(_')")

(* syntax "" :: "lvalue_expr_atom \<Rightarrow> lvalue_expr_indexed" ("_") *)
(* syntax "lvalue_index" :: "lvalue_expr_atom \<Rightarrow> 'a \<Rightarrow> lvalue_expr_indexed" ("_[_]") *)

syntax "" :: "lvalue_expr_atom \<Rightarrow> lvalue_expr_chain" ("_")
syntax "_lvalue_index" :: "lvalue_expr_chain \<Rightarrow> 'a \<Rightarrow> lvalue_expr_chain" ("_[_]")
syntax "lvalue_chain" :: "lvalue_expr_chain \<Rightarrow> lvalue_expr_atom \<Rightarrow> lvalue_expr_chain" (infixl "\<rightarrow>" 90)

syntax "" :: "lvalue_expr_chain \<Rightarrow> lvalue_expr" ("_")
syntax "lvalue_pair" :: "lvalue_expr_chain \<Rightarrow> lvalue_expr \<Rightarrow> lvalue_expr" (infixr "," 80)
syntax "_lvalue_expr" :: "lvalue_expr \<Rightarrow> 'a" ("\<lbrakk>_\<rbrakk>")

(* translations "_lvalue_id x" \<rightharpoonup> "x" *)
(* translations "_lvalue_paren x" \<rightharpoonup> "x" *)
(* translations "_lvalue_pair x y" \<rightharpoonup> "CONST lvalue_pair x y" *)
translations "_lvalue_index x i" \<rightharpoonup> "CONST lvalue_chain x (CONST function_lvalue i)"
translations "_lvalue_expr x" \<rightharpoonup> "x :: (_,_) lvalue"
(* translations "_lvalue_chain x y" \<rightharpoonup> "CONST lvalue_chain x y" *)

term "\<lbrakk>x[3]\<rbrakk>"
term "\<lbrakk>x\<rightarrow>fst_lvalue, y\<rbrakk>"
term "\<lbrakk>(x,z)\<rightarrow>x, y\<rbrakk>"

end


(*<*)
theory LoweOntologicalArgument_1

imports QML
begin
nitpick_params[box=false, user_axioms=true, show_all, expect=genuine, format = 3,  atoms e = a b c d]
sledgehammer_params[verbose=true]
(*>*)

section \<open>E. J. Lowe's Modal Ontological Argument\<close>

subsection \<open>Introduction\<close>
text\<open>\noindent{E. J. Lowe presented his argument in an article named "A Modal Version of the Ontological Argument",
which has been published as a chapter in \<^cite>\<open>"moreland2013"\<close>.
The structure of this argument is very representative of philosophical arguments.
It features eight premises from which new inferences are drawn until arriving at a final conclusion:
the necessary existence of God
(which in this case amounts to the existence of some "necessary concrete being").}\<close>

text\<open>\noindent{(P1) God is, by definition, a necessary concrete being.}\<close>
text\<open>\noindent{(P2) Some necessary abstract beings exist.}\<close>
text\<open>\noindent{(P3) All abstract beings are dependent beings.}\<close>
text\<open>\noindent{(P4) All dependent beings depend for their existence on independent beings.}\<close>
text\<open>\noindent{(P5) No contingent being can explain the existence of a necessary being.}\<close>
text\<open>\noindent{(P6) The existence of any dependent being needs to be explained.}\<close>
text\<open>\noindent{(P7) Dependent beings of any kind cannot explain their own existence.}\<close>
text\<open>\noindent{(P8) The existence of dependent beings can only be explained by beings on which they depend
for their existence.}\<close>

text\<open>\noindent{We will consider in our treatment only a representative subset of the conclusions,
as presented in Lowe's article.}\<close>

text\<open>\noindent{(C1) All abstract beings depend for their existence on concrete beings.
(Follows from P3 and P4 together with D3 and D4.)}\<close>
text\<open>\noindent{(C5) In every possible world there exist concrete beings. (Follows from C1 and P2.)}\<close>
text\<open>\noindent{(C7) The existence of necessary abstract beings needs to be explained. (Follows from P2, P3 and P6.)}\<close>
text\<open>\noindent{(C8) The existence of necessary abstract beings can only be explained by concrete beings.
(Follows from C1, P3, P7 and P8.)}\<close>
text\<open>\noindent{(C9) The existence of necessary abstract beings is explained by one or more necessary concrete beings.
(Follows from C7, C8 and P5.)}\<close>
text\<open>\noindent{(C10) A necessary concrete being exists. (Follows from C9.)}\<close>

text\<open>\noindent{Lowe also introduces some informal definitions which should help the reader understand
the meaning of the concepts involved in his argument
(necessity, concreteness, ontological dependence, metaphysical explanation, etc.).
In the following discussion, we will see that most of these definitions do not bear the significance
Lowe claims.}\<close>

text\<open>\noindent{(D1) x is a necessary being := x exists in every possible world.}\<close>
text\<open>\noindent{(D2) x is a contingent being := x exists in some but not every possible world.}\<close>
text\<open>\noindent{(D3) x is a concrete being := x exists in space and time, or at least in time.}\<close>
text\<open>\noindent{(D4) x is an abstract being := x does not exist in space or time.}\<close>
text\<open>\noindent{(D5) x depends for its existence on y := necessarily, x exists only if y exists.}\<close>
text\<open>\noindent{(D6) (For any predicates F and G) F depend for their existence on G := necessarily, Fs exist only if Gs exist.}\<close>

text\<open>\noindent{We will work \emph{iteratively} on Lowe's argument by temporarily fixing truth-values
and inferential relationships among its sentences, and then, after choosing a logic for formalization,
working back and forth on the formalization of its axioms and theorems
by making gradual adjustments while getting automatic real-time feedback about the suitability of our changes,
vis-a-vis the argument's validity.
In this fashion, by engaging in an \emph{iterative} process of trial and error, we work our way
towards a proper understanding
of the concepts involved in the argument, far beyond of what a mere natural-language based discussion would allow.}\<close>

subsection \<open>Initial Formalization\<close>

text\<open>\noindent{We start our first iterations with a formalized version of Lowe's argument in modal logic using the
semantic embedding presented in the previous section.
We first turn to the formalization of premise P1: "God is, by definition, a necessary concrete being".
In order to understand the concept of \emph{necessariness} (i.e. being a "necessary being")
employed in this argument,
we have a look at the definitions D1 and D2 provided by Lowe.
They relate the concepts of necessariness and contingency (i.e. being a "contingent being") with existence:\footnote{
Here, the concepts of necessariness and contingency are meant as properties of beings, in contrast to the
concepts of necessity and possibility which are modals. We will see later how both pairs of
concepts can be related in order to validate this argument.}}\<close>

text\<open>\noindent{(D1) \emph{x is a necessary being := x exists in every possible world.}}\<close>
text\<open>\noindent{(D2) \emph{x is a contingent being := x exists in some but not every possible world.}}\<close>

text\<open>\noindent{The two definitions above, aimed at explicating the concepts of necessariness and contingency
by reducing them to existence and quantification over possible worlds,
have a direct impact on the choice of a logic for formalization.
They not only call for some kind of modal logic with possible-world semantics but also lead us to consider
the complex issue of existence, since we need to restrict the domain of quantification at every world.}\<close>
text\<open>\noindent{For this argument not to become trivialized, we guarded our quantifiers so they range only over
those entities existing (i.e. being actualized) at a given world.
This approach is known as \emph{actualist quantification}
and is implemented in our semantic embedding by defining a world-dependent meta-logical `existence' predicate
(called "actualizedAt" below), which is the one used as a guard in the definition of the quantifiers.
Note that the type \emph{e} characterizes the domain of all beings (existing and non-existing), and
the type \emph{wo} (which is an abbreviation for \<open>w\<Rightarrow>bool\<close>) characterizes sets of worlds.
The term "isActualized" thus relates beings to worlds.}\<close>

consts isActualized::"e\<Rightarrow>wo" (infix "actualizedAt"(*<*)70(*>*))

abbreviation forallAct::"(e\<Rightarrow>wo)\<Rightarrow>wo" ("\<^bold>\<forall>\<^sup>A")
  where "\<^bold>\<forall>\<^sup>A\<Phi> \<equiv> \<lambda>w.\<forall>x. (x actualizedAt w)\<longrightarrow>(\<Phi> x w)"
abbreviation existsAct::"(e\<Rightarrow>wo)\<Rightarrow>wo" ("\<^bold>\<exists>\<^sup>A")
  where "\<^bold>\<exists>\<^sup>A\<Phi> \<equiv> \<lambda>w.\<exists>x. (x actualizedAt w) \<and> (\<Phi> x w)"

text\<open>\noindent{We also define the corresponding binder syntax below.}\<close>
abbreviation mforallActB::"(e\<Rightarrow>wo)\<Rightarrow>wo" (binder"\<^bold>\<forall>\<^sup>A"[8]9)
  where "\<^bold>\<forall>\<^sup>Ax. (\<phi> x) \<equiv> \<^bold>\<forall>\<^sup>A\<phi>"
abbreviation mexistsActB::"(e\<Rightarrow>wo)\<Rightarrow>wo" (binder"\<^bold>\<exists>\<^sup>A"[8]9)
  where "\<^bold>\<exists>\<^sup>Ax. (\<phi> x) \<equiv> \<^bold>\<exists>\<^sup>A\<phi>"

text\<open>\noindent{We use Isabelle's Nitpick tool \<^cite>\<open>"Nitpick"\<close> to verify that actualist quantification validates
neither the Barcan formula nor its converse.}\<close>

lemma "\<lfloor>(\<^bold>\<forall>\<^sup>Ax. \<^bold>\<box>(\<phi> x)) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>\<^sup>Ax. \<phi> x)\<rfloor>"
  nitpick oops \<comment> \<open>Countermodel found: formula not valid\<close>
lemma "\<lfloor>\<^bold>\<box>(\<^bold>\<forall>\<^sup>Ax. \<phi> x) \<^bold>\<rightarrow> (\<^bold>\<forall>\<^sup>Ax. \<^bold>\<box>(\<phi> x))\<rfloor>"
  nitpick oops \<comment> \<open>Countermodel found: formula not valid\<close>

text\<open>\noindent{With actualist quantification in place we can:
(i) formalize the concept of existence in the usual form (by using a restricted particular quantifier),
(ii) formalize necessariness as existing necessarily, and
(iii) formalize contingency as existing possibly but not necessarily.
}\<close>

definition Existence::"e\<Rightarrow>wo" ("E!") where "E! x  \<equiv> \<^bold>\<exists>\<^sup>Ay. y \<^bold>\<approx> x"

definition Necessary::"e\<Rightarrow>wo" where "Necessary x \<equiv>  \<^bold>\<box>E! x"
definition Contingent::"e\<Rightarrow>wo" where "Contingent x\<equiv> \<^bold>\<diamond>E! x \<^bold>\<and> \<^bold>\<not>Necessary x"

text\<open>\noindent{Note that we have just chosen our logic for formalization: a free quantified modal logic \emph{K}
with positive semantics.
The logic is \emph{free} because the domain of quantification (for actualist quantifiers) is a proper subset of
our universe of discourse, so we can refer to non-actual objects. The semantics is \emph{positive} because
we have placed no restriction regarding predication on non-actual objects, so they are also allowed
to exemplify properties and relations.
We are also in a position to embed stronger normal modal logics (\emph{KB, KB5, S4, S5, ...})
by restricting the accessibility relation \emph{R} with additional axioms.}\<close>

text\<open>\noindent{Having chosen our logic, we can now turn to the formalization of the concepts of abstractness and concreteness.
As seen previously, Lowe has already provided us with an explication of these concepts:}\<close>

text\<open>\noindent{(D3) \emph{x is a concrete being := x exists in space and time, or at least in time.}}\<close>
text\<open>\noindent{(D4) \emph{x is an abstract being := x does not exist in space or time.}}\<close>

text\<open>\noindent{Lowe himself acknowledges that the explication of these concepts in terms of existence
"in space and time" is superfluous, since we are only interested in them being complementary.\footnote{
We quote from Lowe's original article:
"Observe that, according to these definitions, a being cannot be both concrete and abstract:
being concrete and being abstract are mutually exclusive properties of beings.
Also, all beings are either concrete or abstract ... the abstract/concrete distinction is exhaustive.
Consequently, a being is concrete if and only if it is not abstract."}
Thus we start by formalizing concreteness as a \emph{primitive} world-dependent predicate and then derive
abstractness from it, namely as its negation.
}\<close>
consts Concrete::"e\<Rightarrow>wo"
abbreviation Abstract::"e\<Rightarrow>wo" where "Abstract x \<equiv>  \<^bold>\<not>(Concrete x)"

text\<open>\noindent{We can now formalize the definition of Godlikeness (P1) as follows: }\<close>
abbreviation Godlike::"e\<Rightarrow>wo" where "Godlike x \<equiv> Necessary x \<^bold>\<and> Concrete x"

text\<open>\noindent{We also formalize premise P2 ("Some necessary abstract beings exist") as shown below:}\<close>
axiomatization where
P2: "\<lfloor>\<^bold>\<exists>\<^sup>Ax. Necessary x \<^bold>\<and> Abstract x\<rfloor>" (* Some necessary abstract beings exist.*)

text\<open>\noindent{Let's now turn to premises P3 ("All abstract beings are dependent beings") and P4
("All dependent beings depend for their existence on independent beings").
We have here three new concepts to be explicated: two predicates "dependent" and "independent"
and a relation "depends (for its existence) on", which has been called
\emph{ontological dependence} by Lowe.
Following our linguistic intuitions concerning their interrelation, we start by proposing
the following formalization:}\<close>

consts dependence::"e\<Rightarrow>e\<Rightarrow>wo" (infix "dependsOn"(*<*)100(*>*))
definition Dependent::"e\<Rightarrow>wo" where "Dependent x \<equiv> \<^bold>\<exists>\<^sup>Ay. x dependsOn y"
abbreviation Independent::"e\<Rightarrow>wo" where "Independent x  \<equiv> \<^bold>\<not>(Dependent x)"

text\<open>\noindent{We have formalized ontological dependence as a \emph{primitive} world-dependent relation
and refrained from any explication (as suggested by Lowe).\footnote{
An explication of this concept has been suggested by Lowe in definition D5
("x depends for its existence on y := necessarily, x exists only if y exists").
Concerning this alleged definition, he has written in a footnote to the same article:
"Note, however, that the two definitions (D5) and (D6) presented below are not in fact formally called upon in the
version of the ontological argument that I am now developing, so that in the remainder of
this chapter the notion of existential dependence may, for all intents and purposes, be taken
as primitive. There is an advantage in this, inasmuch as finding a perfectly apt definition of
existential dependence is no easy task, as I explain in `Ontological Dependence.'"
Lowe refers hereby to his article on ontological dependence in the Stanford Encyclopedia of Philosophy
\<^cite>\<open>"sep-dependence-ontological"\<close> for further discussion.}

We have called an entity \emph{dependent} if and only if there \emph{actually exists} an object y such that
x \emph{depends for its existence} on it;
accordingly, we have called an entity \emph{independent} if and only if it is not dependent.}\<close>

text\<open>\noindent{As a consequence, premises P3 ("All abstract beings are dependent beings") and P4
("All dependent beings depend for their existence on independent beings") become formalized as follows.}\<close>

axiomatization where
P3: "\<lfloor>\<^bold>\<forall>\<^sup>Ax. Abstract x \<^bold>\<rightarrow> Dependent x\<rfloor>" and (* All abstract beings are dependent beings.*)
P4: "\<lfloor>\<^bold>\<forall>\<^sup>Ax. Dependent x \<^bold>\<rightarrow> (\<^bold>\<exists>\<^sup>Ay. Independent y \<^bold>\<and> x dependsOn y)\<rfloor>" (* All dependent beings depend for their existence on independent beings.*)

text\<open>\noindent{Concerning premises P5 ("No contingent being can explain the existence of a necessary being") and
P6 ("The existence of any dependent being needs to be explained"), a suitable formalization
for expressions of the form: "the entity X explains the existence of Y" and
"the existence of X is explained" needs to be found.
These expressions rely on a single binary relation, which will initially be taken as \emph{primitive}.
This relation has been called \emph{metaphysical explanation} by Lowe.}\<close>

consts explanation::"e\<Rightarrow>e\<Rightarrow>wo" (infix "explains"(*<*)100(*>*))
definition Explained::"e\<Rightarrow>wo" where "Explained x \<equiv> \<^bold>\<exists>\<^sup>Ay. y explains x"

axiomatization where
P5: "\<lfloor>\<^bold>\<not>(\<^bold>\<exists>\<^sup>Ax. \<^bold>\<exists>\<^sup>Ay. Contingent y \<^bold>\<and> Necessary x \<^bold>\<and> y explains x)\<rfloor>" (* No contingent being can explain the existence of a necessary being. *)

text\<open>\noindent{Premise P6, together with the last two premises: P7
("Dependent beings of any kind cannot explain their own existence") and
P8 ("The existence of dependent beings can only be explained by beings on which they depend for their existence"),
were introduced by Lowe in order to relate the concept of \emph{metaphysical explanation}
to \emph{ontological dependence}.\footnote{Note that we use non-guarded quantifiers for the formalization of
the last three premises in order to test argument's validity under the strongest assumptions.
As before, we turn a blind eye to modal expressions like "can", "needs to", etc.}}\<close>

axiomatization where
P6: "\<lfloor>\<^bold>\<forall>x. Dependent x \<^bold>\<rightarrow> Explained x\<rfloor>" and (* The existence of any dependent being needs to be explained. *)
P7: "\<lfloor>\<^bold>\<forall>x. Dependent x \<^bold>\<rightarrow> \<^bold>\<not>(x explains x)\<rfloor>" and (* Dependent beings of any kind cannot explain their own existence. *)
P8: "\<lfloor>\<^bold>\<forall>x y. y explains x \<^bold>\<rightarrow> x dependsOn y\<rfloor>" (* The existence of dependent beings can only be explained by beings on which they depend for their existence. *)

text\<open>\noindent{Although the last three premises seem to couple very tightly the concepts of (metaphysical) explanation
and (ontological) dependence, both concepts are not meant by Lowe to be equivalent.\footnote{
Lowe says: "Existence-explanation is not simply the inverse of existential dependence.
If x depends for its existence on y, this only means that x cannot exist without y
existing. This is not at all the same as saying that x exists because y exists, or that
x exists in virtue of the fact that y exists."}
We have used Nitpick in order to test this claim. Since a countermodel has been found, we have proven
that the (inverse) equivalence of metaphysical explanation and ontological dependence
is not implied by the axioms.}\<close>
lemma "\<lfloor>\<^bold>\<forall>x y. x explains y \<^bold>\<leftrightarrow> y dependsOn x\<rfloor>" nitpick[user_axioms] oops

text\<open>\noindent{For any being, however, having its existence "explained"
is equivalent to its existence being "dependent" (on some other being).
This follows already from premises P6 and P8, as shown above by Isabelle's prover.}\<close>
lemma "\<lfloor>\<^bold>\<forall>x. Explained x \<^bold>\<leftrightarrow> Dependent x\<rfloor>"
  using P6 P8 Dependent_def Explained_def by auto

text\<open>\noindent{The Nitpick model finder is also useful to check axioms' consistency at any stage during the
formalization of an argument.
We instruct Nitpick to generate a model satisfying some tautological sentence
(here we use a trivial `True' proposition) while taking into account all previously defined axioms.}\<close>
lemma True nitpick[satisfy, user_axioms] oops

text\<open>\noindent{In this case, Nitpick was able to find a model satisfying the given tautology; this means that
all axioms defined so far are consistent. The model found has a cardinality of two for the set of
individual objects and a single world.}\<close>

text\<open>\noindent{We can also use model finders to perform `sanity checks'. We can instruct Nitpick
to find a countermodel for some specifically tailored formula which we want to make sure is not valid.
We check below, for instance, that our axioms are not too strong as to imply \emph{metaphysical necessitism}
(i.e. all beings necessarily exist)
or \emph{modal collapse}. Since both would trivially validate the argument.}\<close>

lemma "\<lfloor>\<^bold>\<forall>x. E! x\<rfloor>"
  nitpick[user_axioms] oops \<comment> \<open>Countermodel found: necessitism is not valid\<close>

lemma "\<lfloor>\<phi> \<^bold>\<rightarrow> \<^bold>\<box>\<phi>\<rfloor>"
  nitpick[user_axioms] oops \<comment> \<open>Countermodel found: modal collapse is not valid\<close>

text\<open>\noindent{By using Isabelle's \emph{Sledgehammer} tool \<^cite>\<open>"Sledgehammer"\<close>, we can verify the validity
of the selected conclusions C1, C5 and C7, and even find the premises they rely upon.}\<close>

text\<open>\noindent{(C1) \emph{All abstract beings depend for their existence on concrete beings.}}\<close>
theorem C1:  "\<lfloor>\<^bold>\<forall>\<^sup>Ax. Abstract x \<^bold>\<rightarrow> (\<^bold>\<exists>y. Concrete y \<^bold>\<and> x dependsOn y)\<rfloor>"
  using P3 P4 by blast
text\<open>\noindent{(C5) \emph{In every possible world there exist concrete beings.} }\<close>
theorem C5: "\<lfloor>\<^bold>\<exists>\<^sup>Ax. Concrete x\<rfloor>"
  using P2 P3 P4 by blast
text\<open>\noindent{(C7) \emph{The existence of necessary abstract beings needs to be explained.}}\<close>
theorem C7: "\<lfloor>\<^bold>\<forall>\<^sup>Ax. (Necessary x \<^bold>\<and> Abstract x) \<^bold>\<rightarrow> Explained x\<rfloor>"
  using P3 P6 by simp

text\<open>\noindent{The last three conclusions are shown by Nitpick to be non-valid even in an \emph{S5} logic.
\emph{S5} can be easily introduced by postulating that the accessibility relation \emph{R} is an equivalence relation.
This exploits the well-known \emph{Sahlqvist correspondence} which links modal axioms to constraints
on a model's accessibility relation.}\<close>

axiomatization where
  S5: "equivalence R" \<comment> \<open>@{text "\<box>\<phi>\<rightarrow>\<phi>, \<phi>\<rightarrow>\<box>\<diamond>\<phi> and \<box>\<phi>\<rightarrow>\<box>\<box>\<phi>"}\<close>

text\<open>\noindent{(C8) \emph{The existence  of  necessary  abstract  beings  can  only  be  explained  by  concrete  beings.} }\<close>
lemma C8: "\<lfloor>\<^bold>\<forall>\<^sup>Ax.(Necessary x \<^bold>\<and> Abstract x)\<^bold>\<rightarrow>(\<^bold>\<forall>\<^sup>Ay. y explains x\<^bold>\<rightarrow>Concrete y)\<rfloor>"
  nitpick[user_axioms] oops \<comment> \<open>Countermodel found\<close>
text\<open>\noindent{(C9) \emph{The existence of necessary abstract beings is explained by one or more necessary concrete (Godlike) beings.} }\<close>
lemma C9: "\<lfloor>\<^bold>\<forall>\<^sup>Ax.(Necessary x \<^bold>\<and> Abstract x)\<^bold>\<rightarrow>(\<^bold>\<exists>\<^sup>Ay. y explains x \<^bold>\<and> Godlike y)\<rfloor>"
  nitpick[user_axioms] oops \<comment> \<open>Countermodel found\<close>
text\<open>\noindent{(C10) \emph{A necessary concrete (Godlike) being exists.} }\<close>
theorem C10:  "\<lfloor>\<^bold>\<exists>\<^sup>Ax. Godlike x\<rfloor>"
  nitpick[user_axioms] oops \<comment> \<open>Countermodel found\<close>

text\<open>\noindent{By employing the Isabelle proof assistant we prove non-valid a first formalization attempt of
Lowe's modal ontological argument. This is, however, just the first of many iterations in our
interpretive endeavor. Based on the information recollected so far, we can proceed to make the adjustments
necessary to validate the argument. We will see how these changes have an impact on our understanding of
all concepts (necessariness, concreteness, dependence, explanation, etc.).
}\<close>

(*<*)
end
(*>*)


theory Simps_Case_Conv_Examples imports
  "~~/src/HOL/Library/Simps_Case_Conv"
begin

section \<open>Tests for the Simps<->Case conversion tools\<close>

fun foo where
  "foo (x # xs) Nil = 0" |
  "foo (x # xs) (y # ys) = foo [] []" |
  "foo Nil (y # ys) = 1" |
  "foo Nil Nil = 3"

fun bar where
  "bar x 0 y = 0 + x" |
  "bar x (Suc n) y = n + x"

definition
  split_rule_test :: "((nat => 'a) + ('b * (('b => 'a) option))) => ('a => nat) => nat"
where
 "split_rule_test x f = f (case x of Inl af \<Rightarrow> af 1
    | Inr (b, None) => inv f 0
    | Inr (b, Some g) => g b)"

definition test where "test x y = (case x of None => (case y of [] => 1 | _ # _ => 2) | Some x => x)"

definition nosplit where "nosplit x = x @ (case x of [] \<Rightarrow> [1] | xs \<Rightarrow> xs)"

text \<open>Function with complete, non-overlapping patterns\<close>
case_of_simps foo_cases1: foo.simps
lemma
  fixes xs :: "'a list" and ys :: "'b list"
  shows "foo xs ys = (case (xs, ys) of
    ( [], []) \<Rightarrow> 3
    | ([], y # ys) \<Rightarrow> 1
    | (x # xs, []) \<Rightarrow> 0
    | (x # xs, y # ys) \<Rightarrow> foo ([] :: 'a list) ([] :: 'b list))"
  by (fact foo_cases1)

text \<open>Redundant equations are ignored\<close>
case_of_simps foo_cases2: foo.simps foo.simps
lemma
  fixes xs :: "'a list" and ys :: "'b list"
  shows "foo xs ys = (case (xs, ys) of
    ( [], []) \<Rightarrow> 3
    | ([], y # ys) \<Rightarrow> 1
    | (x # xs, []) \<Rightarrow> 0
    | (x # xs, y # ys) \<Rightarrow> foo ([] :: 'a list) ([] :: 'b list))"
  by (fact foo_cases2)

text \<open>Variable patterns\<close>
case_of_simps bar_cases: bar.simps
print_theorems

text \<open>Case expression not at top level\<close>
simps_of_case split_rule_test_simps: split_rule_test_def
lemma
  "split_rule_test (Inl x) f = f (x 1)"
  "split_rule_test (Inr (x, None)) f = f (inv f 0)"
  "split_rule_test (Inr (x, Some y)) f = f (y x)"
  by (fact split_rule_test_simps)+

text \<open>Argument occurs both as case parameter and seperately\<close>
simps_of_case nosplit_simps1: nosplit_def
lemma
  "nosplit [] = [] @ [1]"
  "nosplit (x # xs) = (x # xs) @ x # xs"
  by (fact nosplit_simps1)+

text \<open>Nested case expressions\<close>
simps_of_case test_simps1: test_def
lemma
  "test None [] = 1"
  "test None (x # xs) = 2"
  "test (Some x) y = x"
  by (fact test_simps1)+

text \<open>Single-constructor patterns\<close>
case_of_simps fst_conv_simps: fst_conv
lemma "fst x = (case x of (a,b) \<Rightarrow> a)"
  by (fact fst_conv_simps)

text \<open>Partial split of case\<close>
simps_of_case nosplit_simps2: nosplit_def (splits: list.split)
lemma
  "nosplit [] = [] @ [1]"
  "nosplit (x # xs) = (x # xs) @ x # xs"
  by (fact nosplit_simps1)+

simps_of_case test_simps2: test_def (splits: option.split)
lemma
  "test None y = (case y of [] \<Rightarrow> 1 | x # xs \<Rightarrow> 2)"
  "test (Some x) y = x"
  by (fact test_simps2)+

text \<open>Reversal\<close>
case_of_simps test_def1: test_simps1
lemma
  "test x y = (case (x,y) of
    (None, []) \<Rightarrow> 1
  | (None, _#_) \<Rightarrow> 2
  | (Some x, _) \<Rightarrow> x)"
  by (fact test_def1)

text \<open>Case expressions on RHS\<close>
case_of_simps test_def2: test_simps2
lemma "test xs y = (case (xs, y) of (None, []) \<Rightarrow> 1 | (None, x # xa) \<Rightarrow> 2 | (Some x, y) \<Rightarrow> x)"
  by (fact test_def2)

text \<open>Partial split of simps\<close>
case_of_simps foo_cons_def: foo.simps(1,2)
lemma
  fixes xs :: "'a list" and ys :: "'b list"
  shows "foo (x # xs) ys = (case (x,xs,ys) of
      (_,_,[]) \<Rightarrow> 0
    | (_,_,_ # _) \<Rightarrow> foo ([] :: 'a list) ([] :: 'b list))"
  by (fact foo_cons_def)

end