section\<open>A poset of successions\<close>

theory Succession_Poset
  imports
    ZF_Trans_Interpretations
    Proper_Extension
begin

text\<open>In this theory we define a separative poset. Its underlying set is the
set of finite binary sequences (that is, with codomain $2={0,1}$);
of course, one can see that set as
the set \<^term>\<open>\<omega>-||>2\<close> or equivalently as the set of partial functions
\<^term>\<open>Fn(\<omega>,\<omega>,2)\<close>, i.e. the set of partial functions bounded by \<^term>\<open>\<omega>\<close>.

The order relation of the poset is that of being less defined as functions
(cf. \<^term>\<open>Fnlerel(A\<^bsup><\<omega>\<^esup>)\<close>), so it could be surprising that we have not used
\<^term>\<open>Fn(\<omega>,\<omega>,2)\<close> for the set. The only reason why we keep this alternative
definition is because we can prove \<^term>\<open>A\<^bsup><\<omega>\<^esup> \<in> M\<close> (and therefore
\<^term>\<open>Fnlerel(A\<^bsup><\<omega>\<^esup>) \<in> M\<close>) using only one instance of separation.\<close>

definition seq_upd :: "i \<Rightarrow> i \<Rightarrow> i" where
  "seq_upd(f,a) \<equiv> \<lambda> j \<in> succ(domain(f)) . if j < domain(f) then f`j else a"

lemma seq_upd_succ_type :
  assumes "n\<in>nat" "f\<in>n\<rightarrow>A" "a\<in>A"
  shows "seq_upd(f,a)\<in> succ(n) \<rightarrow> A"
proof -
  from assms
  have equ: "domain(f) = n"
    using domain_of_fun by simp
  {
    fix j
    assume "j\<in>succ(domain(f))"
    with equ \<open>n\<in>_\<close>
    have "j\<le>n"
      using ltI by auto
    with \<open>n\<in>_\<close>
    consider (lt) "j<n" | (eq) "j=n"
      using leD by auto
    then
    have "(if j < n then f`j else a) \<in> A"
    proof cases
      case lt
      with \<open>f\<in>_\<close>
      show ?thesis
        using apply_type ltD[OF lt] by simp
    next
      case eq
      with \<open>a\<in>_\<close>
      show ?thesis
        by auto
    qed
  }
  with equ
  show ?thesis
    unfolding seq_upd_def
    using lam_type[of "succ(domain(f))"]
    by auto
qed

lemma seq_upd_type :
  assumes "f\<in>A\<^bsup><\<omega>\<^esup>" "a\<in>A"
  shows "seq_upd(f,a) \<in> A\<^bsup><\<omega>\<^esup>"
proof -
  from \<open>f\<in>_\<close>
  obtain y where "y\<in>nat" "f\<in>y\<rightarrow>A"
    unfolding seqspace_def by blast
  with \<open>a\<in>A\<close>
  have "seq_upd(f,a)\<in>succ(y)\<rightarrow>A"
    using seq_upd_succ_type by simp
  with \<open>y\<in>_\<close>
  show ?thesis
    unfolding seqspace_def by auto
qed

lemma seq_upd_apply_domain [simp]:
  assumes "f:n\<rightarrow>A" "n\<in>nat"
  shows "seq_upd(f,a)`n = a"
  unfolding seq_upd_def using assms domain_of_fun by auto

lemma zero_in_seqspace :
  shows "0 \<in> A\<^bsup><\<omega>\<^esup>"
  unfolding seqspace_def
  by force

definition
  seqlerel :: "i \<Rightarrow> i" where
  "seqlerel(A) \<equiv> Fnlerel(A\<^bsup><\<omega>\<^esup>)"

definition
  seqle :: "i" where
  "seqle \<equiv> seqlerel(2)"

lemma seqleI[intro!]:
  "\<langle>f,g\<rangle> \<in> 2\<^bsup><\<omega>\<^esup>\<times>2\<^bsup><\<omega>\<^esup> \<Longrightarrow> g \<subseteq> f  \<Longrightarrow> \<langle>f,g\<rangle> \<in> seqle"
  unfolding seqle_def seqlerel_def seqspace_def Rrel_def Fnlerel_def
  by blast

lemma seqleD[dest!]:
  "z \<in> seqle \<Longrightarrow> \<exists>x y. \<langle>x,y\<rangle> \<in> 2\<^bsup><\<omega>\<^esup>\<times>2\<^bsup><\<omega>\<^esup> \<and> y \<subseteq> x \<and> z = \<langle>x,y\<rangle>"
  unfolding Rrel_def seqle_def seqlerel_def Fnlerel_def
  by blast

lemma upd_leI :
  assumes "f\<in>2\<^bsup><\<omega>\<^esup>" "a\<in>2"
  shows "\<langle>seq_upd(f,a),f\<rangle>\<in>seqle"  (is "\<langle>?f,_\<rangle>\<in>_")
proof
  show " \<langle>?f, f\<rangle> \<in> 2\<^bsup><\<omega>\<^esup> \<times> 2\<^bsup><\<omega>\<^esup>"
    using assms seq_upd_type by auto
next
  show  "f \<subseteq> seq_upd(f,a)"
  proof
    fix x
    assume "x \<in> f"
    moreover from \<open>f \<in> 2\<^bsup><\<omega>\<^esup>\<close>
    obtain n where "n\<in>nat" "f : n \<rightarrow> 2"
      by blast
    moreover from calculation
    obtain y where "y\<in>n" "x=\<langle>y,f`y\<rangle>"
      using Pi_memberD[of f n "\<lambda>_ . 2"]
      by blast
    moreover from \<open>f:n\<rightarrow>2\<close>
    have "domain(f) = n"
      using domain_of_fun by simp
    ultimately
    show "x \<in> seq_upd(f,a)"
      unfolding seq_upd_def lam_def
      by (auto intro:ltI)
  qed
qed

lemma preorder_on_seqle: "preorder_on(2\<^bsup><\<omega>\<^esup>,seqle)"
  unfolding preorder_on_def refl_def trans_on_def by blast

lemma zero_seqle_max: "x\<in>2\<^bsup><\<omega>\<^esup> \<Longrightarrow> \<langle>x,0\<rangle> \<in> seqle"
  using zero_in_seqspace
  by auto

interpretation sp:forcing_notion "2\<^bsup><\<omega>\<^esup>" "seqle" "0"
  using preorder_on_seqle zero_seqle_max zero_in_seqspace
  by unfold_locales simp_all

notation sp.Leq (infixl "\<preceq>s" 50)
notation sp.Incompatible (infixl "\<bottom>s" 50)

lemma seqspace_separative:
  assumes "f\<in>2\<^bsup><\<omega>\<^esup>"
  shows "seq_upd(f,0) \<bottom>s seq_upd(f,1)" (is "?f \<bottom>s ?g")
proof
  assume "sp.compat(?f, ?g)"
  then
  obtain h where "h \<in> 2\<^bsup><\<omega>\<^esup>" "?f \<subseteq> h" "?g \<subseteq> h"
    by blast
  moreover from \<open>f\<in>_\<close>
  obtain y where "y\<in>nat" "f:y\<rightarrow>2"
    by blast
  moreover from this
  have "?f: succ(y) \<rightarrow> 2" "?g: succ(y) \<rightarrow> 2"
    using seq_upd_succ_type by blast+
  moreover from this
  have "\<langle>y,?f`y\<rangle> \<in> ?f" "\<langle>y,?g`y\<rangle> \<in> ?g"
    using apply_Pair by auto
  ultimately
  have "\<langle>y,0\<rangle> \<in> h" "\<langle>y,1\<rangle> \<in> h"
    by auto
  moreover from \<open>h \<in> 2\<^bsup><\<omega>\<^esup>\<close>
  obtain n where "n\<in>nat" "h:n\<rightarrow>2"
    by blast
  ultimately
  show "False"
    using fun_is_function[of h n "\<lambda>_. 2"]
    unfolding seqspace_def function_def by auto
qed

definition seqleR_fm :: "i \<Rightarrow> i" where
  "seqleR_fm(fg) \<equiv> Exists(Exists(And(pair_fm(0,1,fg+\<^sub>\<omega>2),subset_fm(1,0))))"

lemma type_seqleR_fm : "fg \<in> nat \<Longrightarrow> seqleR_fm(fg) \<in> formula"
  unfolding seqleR_fm_def
  by simp

arity_theorem for "seqleR_fm"

lemma (in M_ctm1) seqleR_fm_sats :
  assumes "fg\<in>nat" "env\<in>list(M)"
  shows "(M, env \<Turnstile> seqleR_fm(fg)) \<longleftrightarrow> (\<exists>f[##M]. \<exists>g[##M]. pair(##M,f,g,nth(fg,env)) \<and> f \<supseteq> g)"
  unfolding seqleR_fm_def
  using assms trans_M sats_subset_fm pair_iff_sats
  by auto

context M_ctm1
begin

lemma seqle_in_M: "seqle \<in> M"
  using arity_seqleR_fm seqleR_fm_sats type_seqleR_fm
    cartprod_closed seqspace_closed nat_into_M nat_in_M pair_in_M_iff
  unfolding seqle_def seqlerel_def Rrel_def Fnlerel_def
  by (rule_tac Collect_in_M[of "seqleR_fm(0)" "[]"],auto)

subsection\<open>Cohen extension is proper\<close>

interpretation ctm_separative "2\<^bsup><\<omega>\<^esup>" seqle 0
proof (unfold_locales)
  fix f
  let ?q="seq_upd(f,0)" and ?r="seq_upd(f,1)"
  assume "f \<in> 2\<^bsup><\<omega>\<^esup>"
  then
  have "?q \<preceq>s f \<and> ?r \<preceq>s f \<and> ?q \<bottom>s ?r"
    using upd_leI seqspace_separative by auto
  moreover from calculation
  have "?q \<in> 2\<^bsup><\<omega>\<^esup>"  "?r \<in> 2\<^bsup><\<omega>\<^esup>"
    using seq_upd_type[of f 2] by auto
  ultimately
  show "\<exists>q\<in>2\<^bsup><\<omega>\<^esup>. \<exists>r\<in>2\<^bsup><\<omega>\<^esup>. q \<preceq>s f \<and> r \<preceq>s f \<and> q \<bottom>s r"
    by (rule_tac bexI)+ \<comment> \<open>why the heck auto-tools don't solve this?\<close>
next
  show "2\<^bsup><\<omega>\<^esup> \<in> M"
    using nat_into_M seqspace_closed by simp
next
  show "seqle \<in> M"
    using seqle_in_M .
qed

lemma cohen_extension_is_proper: "\<exists>G. M_generic(G) \<and> M \<noteq> M[G]"
  using proper_extension generic_filter_existence zero_in_seqspace
  by force

end \<comment> \<open>\<^locale>\<open>M_ctm1\<close>\<close>

end


(*
  File: Set_Thms.thy
  Author: Bohua Zhan

  Setup of proof steps related to sets.
*)

section \<open>Setup for sets and multisets\<close>

theory Set_Thms
imports Logic_Thms "HOL-Library.Multiset"
begin

subsection \<open>Set\<close>

subsubsection \<open>Injective functions\<close>

setup \<open>add_backward_prfstep @{thm injI}\<close>

subsubsection \<open>AC property of intersection and union\<close>

setup \<open>fold Auto2_HOL_Extra_Setup.ACUtil.add_ac_data [
  {cfhead = @{cterm inf}, unit = SOME @{cterm inf},
   assoc_th = @{thm inf_assoc}, comm_th = @{thm inf_commute},
   unitl_th = @{thm inf_top_left}, unitr_th = @{thm inf_top_right}},

  {cfhead = @{cterm sup}, unit = SOME @{cterm bot},
   assoc_th = @{thm sup_assoc}, comm_th = @{thm sup_commute},
   unitl_th = @{thm sup_bot_left}, unitr_th = @{thm sup_bot_right}}]
\<close>

subsubsection \<open>Collection and bounded quantification\<close>

setup \<open>add_rewrite_rule @{thm Set.mem_Collect_eq}\<close>
lemma ball_single [rewrite]: "(\<forall>x\<in>{x}. P x) = P x" by auto

subsubsection \<open>Membership\<close>

setup \<open>add_rewrite_rule @{thm Set.singleton_iff}\<close>
setup \<open>add_forward_prfstep (equiv_forward_th @{thm Set.empty_iff})\<close>
lemma set_membership_distinct [forward]: "x \<in> s \<Longrightarrow> y \<notin> s \<Longrightarrow> x \<noteq> y" by auto
lemma non_empty_exist_elt [backward]: "U \<noteq> {} \<Longrightarrow> \<exists>x. x \<in> U" by blast
lemma non_univ_exist_compl [backward]: "U \<noteq> UNIV \<Longrightarrow> \<exists>x. x \<notin> U" by blast
setup \<open>add_resolve_prfstep @{thm Set.UNIV_I}\<close>

subsubsection \<open>Insert\<close>

setup \<open>add_backward_prfstep_cond (equiv_backward_th @{thm Set.insert_iff}) [with_cond "?A \<noteq> {}"]\<close>
setup \<open>add_forward_prfstep_cond (equiv_forward_th @{thm Set.insert_iff})
  [with_score 500, with_cond "?A \<noteq> {}"]\<close>
setup \<open>add_forward_prfstep_cond (equiv_forward_th @{thm Set.insert_subset}) [with_cond "?A \<noteq> {}"]\<close>
setup \<open>add_backward_prfstep_cond (equiv_backward_th @{thm Set.insert_subset})
  [with_score 500, with_cond "?A \<noteq> {}"]\<close>

subsubsection \<open>Extensionality\<close>

lemma set_ext [forward]: "\<forall>a. a \<in> S \<longleftrightarrow> a \<in> T \<Longrightarrow> S = T" by auto
setup \<open>add_backward_prfstep_cond @{thm set_ext} [with_score 500, with_filt (order_filter "S" "T")]\<close>

lemma set_pair_ext [forward]: "\<forall>a b. (a, b) \<in> S \<longleftrightarrow> (a, b) \<in> T \<Longrightarrow> S = T" by auto

subsubsection \<open>Union\<close>

setup \<open>add_forward_prfstep_cond (equiv_forward_th @{thm Set.Un_iff}) [with_score 500]\<close>
setup \<open>add_backward_prfstep (equiv_backward_th @{thm Set.Un_iff})\<close>

lemma UnD1 [forward]: "c \<in> A \<union> B \<Longrightarrow> c \<notin> A \<Longrightarrow> c \<in> B" by auto
lemma UnD2 [forward]: "c \<in> A \<union> B \<Longrightarrow> c \<notin> B \<Longrightarrow> c \<in> A" by auto
lemma UnD1_single [forward]: "c \<in> {a} \<union> B \<Longrightarrow> c \<noteq> a \<Longrightarrow> c \<in> B" by auto
lemma UnD2_single [forward]: "c \<in> A \<union> {b} \<Longrightarrow> c \<noteq> b \<Longrightarrow> c \<in> A" by auto
setup \<open>add_forward_prfstep_cond @{thm Set.UnI1} [with_term "?A \<union> ?B"]\<close>
setup \<open>add_forward_prfstep_cond @{thm Set.UnI2} [with_term "?A \<union> ?B"]\<close>
lemma UnI1_single: "a \<in> {a} \<union> B" by auto
lemma UnI2_single: "b \<in> A \<union> {b}" by auto
setup \<open>add_forward_prfstep_cond @{thm UnI1_single} [with_term "{?a} \<union> ?B"]\<close>
setup \<open>add_forward_prfstep_cond @{thm UnI2_single} [with_term "?A \<union> {?b}"]\<close>

lemma union_single_eq [rewrite, backward]: "x \<in> p \<Longrightarrow> {x} \<union> p = p" by auto

subsubsection \<open>Intersection\<close>

setup \<open>add_forward_prfstep (equiv_forward_th @{thm Set.Int_iff})\<close>
setup \<open>add_backward_prfstep_cond (equiv_backward_th @{thm Set.Int_iff}) [with_score 500]\<close>

setup \<open>add_rewrite_rule @{thm Set.Int_empty_left}\<close>
setup \<open>add_rewrite_rule @{thm Set.Int_empty_right}\<close>
setup \<open>add_rewrite_rule @{thm Set.Int_absorb}\<close>
lemma set_disjoint_mp [forward, backward2]: "A \<inter> B = {} \<Longrightarrow> p \<in> A \<Longrightarrow> p \<notin> B" by auto
lemma set_disjoint_single [rewrite]: "{x} \<inter> B = {} \<longleftrightarrow> x \<notin> B" by simp

subsubsection \<open>subset\<close>

setup \<open>add_forward_prfstep @{thm subsetI}\<close>
setup \<open>add_backward_prfstep_cond @{thm subsetI} [with_score 500]\<close>

setup \<open>add_resolve_prfstep @{thm empty_subsetI}\<close>
setup \<open>add_forward_prfstep @{thm subsetD}\<close>
lemma subset_single [rewrite]: "{a} \<subseteq> B \<longleftrightarrow> a \<in> B" by simp
setup \<open>add_resolve_prfstep @{thm Set.basic_monos(1)}\<close>
setup \<open>add_resolve_prfstep @{thm Set.Un_upper1}\<close>
setup \<open>add_resolve_prfstep @{thm Set.Un_upper2}\<close>
lemma union_is_subset [forward]: "A \<union> B \<subseteq> C \<Longrightarrow> A \<subseteq> C \<and> B \<subseteq> C" by simp
setup \<open>add_backward1_prfstep @{thm Set.Un_least}\<close>
setup \<open>add_backward2_prfstep @{thm Set.Un_least}\<close>
lemma subset_union_same1 [backward]: "B \<subseteq> C \<Longrightarrow> A \<union> B \<subseteq> A \<union> C" by auto
lemma subset_union_same2 [backward]: "A \<subseteq> B \<Longrightarrow> A \<union> C \<subseteq> B \<union> C" by auto

subsubsection \<open>Diff\<close>

setup \<open>add_forward_prfstep (equiv_forward_th @{thm Set.Diff_iff})\<close>
setup \<open>add_backward_prfstep_cond (equiv_backward_th @{thm Set.Diff_iff}) [with_score 500]\<close>

setup \<open>add_rewrite_rule @{thm Set.empty_Diff}\<close>
lemma mem_diff [rewrite]: "x \<in> A - B \<longleftrightarrow> x \<in> A \<and> x \<notin> B" by simp
lemma set_union_minus_same1 [rewrite]: "(A \<union> B) - B = A - B" by auto
lemma set_union_minus_same2 [rewrite]: "(B \<union> A) - B = A - B" by auto
lemma set_union_minus_distinct [rewrite]: "a \<noteq> c \<Longrightarrow> {a} \<union> (B - {c}) = {a} \<union> B - {c}" by auto
setup \<open>add_forward_prfstep_cond @{thm Set.Diff_subset} [with_term "?A - ?B"]\<close>
lemma union_subtract_elt1 [rewrite]: "x \<notin> B \<Longrightarrow> ({x} \<union> B) - {x} = B" by simp
lemma union_subtract_elt2 [rewrite]: "x \<notin> B \<Longrightarrow> (B \<union> {x}) - {x} = B" by simp
lemma subset_sub1 [backward]: "x \<in> A \<Longrightarrow> A - {x} \<subset> A" by auto
lemma member_notin [forward]: "x \<in> S - {y} \<Longrightarrow> x \<noteq> y" by simp
lemma member_notin_contra: "x \<in> S \<Longrightarrow> x \<noteq> y \<Longrightarrow> x \<in> S - {y}" by simp
setup \<open>add_forward_prfstep_cond @{thm member_notin_contra} [with_term "?S - {?y}"]\<close>

subsubsection \<open>Results on finite sets\<close>

setup \<open>add_resolve_prfstep @{thm Finite_Set.finite.emptyI}\<close>
lemma set_finite_single [resolve]: "finite {x}" by simp
setup \<open>add_rewrite_rule @{thm Finite_Set.finite_Un}\<close>
lemma Max_ge' [forward]: "finite A \<Longrightarrow> x > Max A \<Longrightarrow> \<not>(x \<in> A)" using Max_ge leD by auto
setup \<open>add_backward_prfstep @{thm finite_image_set}\<close>
setup \<open>add_forward_prfstep @{thm finite_atLeastAtMost}\<close>
setup \<open>add_forward_prfstep @{thm rev_finite_subset}\<close>
setup \<open>add_backward1_prfstep @{thm rev_finite_subset}\<close>

subsubsection \<open>Cardinality\<close>

setup \<open>add_rewrite_rule @{thm card.empty}\<close>
lemma card_emptyD [rewrite]: "finite S \<Longrightarrow> card S = 0 \<Longrightarrow> S = {}" by simp
lemma card_minus1 [rewrite]: "x \<in> S \<Longrightarrow> card (S - {x}) = card S - 1" by (simp add: card_Diff_subset)
setup \<open>add_forward_prfstep @{thm finite_Diff}\<close>
setup \<open>add_resolve_prfstep @{thm card_mono}\<close>

subsubsection \<open>Image set\<close>

setup \<open>add_rewrite_rule @{thm Set.image_Un}\<close>
setup \<open>add_rewrite_rule @{thm image_set_diff}\<close>

subsection \<open>Multiset\<close>

subsubsection \<open>Basic properties\<close>

lemma mset_member_empty [resolve]: "\<not>p \<in># {#}" by simp
lemma mem_multiset_single [rewrite]: "x \<in># {#y#} \<longleftrightarrow> x = y" by simp
setup \<open>add_backward2_prfstep @{thm subset_mset.antisym}\<close>
setup \<open>add_resolve_prfstep @{thm Multiset.empty_le}\<close>
setup \<open>add_forward_prfstep @{thm mset_subsetD}\<close>

lemma multi_contain_add_self1 [resolve]: "A \<subset># {#x#} + A" by simp
lemma multi_contain_add_self2 [resolve]: "A \<subset># A + {#x#}" by simp
setup \<open>add_forward_prfstep_cond @{thm Multiset.multi_member_this} [with_term "{#?x#} + ?XS"]\<close>
lemma multi_member_this2: "x \<in># XS + {#x#}" by simp
setup \<open>add_forward_prfstep_cond @{thm multi_member_this2} [with_term "?XS + {#?x#}"]\<close>
setup \<open>add_backward_prfstep @{thm Multiset.subset_mset.add_left_mono}\<close>
setup \<open>add_backward_prfstep @{thm Multiset.subset_mset.add_right_mono}\<close>

subsubsection \<open>Case checking and induction\<close>

lemma multi_nonempty_split' [resolve]: "M \<noteq> {#} \<Longrightarrow> \<exists>M' m. M = M' + {#m#}"
  using multi_nonempty_split by auto

lemma multi_member_split' [backward]: "x \<in># M \<Longrightarrow> \<exists>M'. M = M' + {#x#}"
  by (metis insert_DiffM2)

setup \<open>add_strong_induct_rule @{thm full_multiset_induct}\<close>

subsubsection \<open>Results on mset\<close>

setup \<open>add_rewrite_rule @{thm set_mset_empty}\<close>
setup \<open>add_rewrite_rule @{thm set_mset_single}\<close>
setup \<open>add_rewrite_rule @{thm set_mset_union}\<close>

setup \<open>add_rewrite_rule @{thm image_mset_empty}\<close>
setup \<open>add_rewrite_rule @{thm image_mset_single}\<close>
setup \<open>add_rewrite_rule @{thm image_mset_union}\<close>

setup \<open>add_rewrite_rule @{thm prod_mset_empty}\<close>
setup \<open>add_rewrite_rule @{thm prod_mset_singleton}\<close>
setup \<open>add_rewrite_rule @{thm prod_mset_Un}\<close>

subsubsection \<open>Set interval\<close>

setup \<open>add_rewrite_rule @{thm Set_Interval.ord_class.lessThan_iff}\<close>
setup \<open>add_rewrite_rule @{thm Set_Interval.ord_class.atLeastAtMost_iff}\<close>

end