(*  Title:       A Definitional Encoding of TLA in Isabelle/HOL
    Authors:     Gudmund Grov <ggrov at inf.ed.ac.uk>
                 Stephan Merz <Stephan.Merz at loria.fr>
    Year:        2011
    Maintainer:  Gudmund Grov <ggrov at inf.ed.ac.uk>
*)

section "Liveness"

theory Liveness
imports Rules
begin

text\<open>This theory derives proof rules for liveness properties.\<close>

definition enabled :: "'a formula \<Rightarrow> 'a formula"
where "enabled F \<equiv> \<lambda> s. \<exists> t. ((first s) ## t) \<Turnstile> F"

syntax "_Enabled" :: "lift \<Rightarrow> lift" ("(Enabled _)" [90] 90)

translations "_Enabled" \<rightleftharpoons> "CONST enabled"

definition WeakF :: "('a::world) formula \<Rightarrow> ('a,'b) stfun \<Rightarrow> 'a formula"
where "WeakF F v \<equiv> TEMP \<diamond>\<box>Enabled \<langle>F\<rangle>_v \<longrightarrow> \<box>\<diamond>\<langle>F\<rangle>_v"

definition StrongF :: "('a::world) formula \<Rightarrow> ('a,'b) stfun \<Rightarrow> 'a formula"
where "StrongF F v \<equiv> TEMP \<box>\<diamond>Enabled \<langle>F\<rangle>_v \<longrightarrow> \<box>\<diamond>\<langle>F\<rangle>_v"

text\<open>
  Lamport's TLA defines the above notions for actions.
  In \tlastar{}, (pre-)formulas generalise TLA's actions and the above
  definition is the natural generalisation of enabledness to pre-formulas.
  In particular, we have chosen to define \<open>enabled\<close> such that it
  yields itself a temporal formula, although its value really just depends
  on the first state of the sequence it is evaluated over.
  Then, the definitions of weak and strong fairness are exactly as in TLA.
\<close>

syntax
 "_WF" :: "[lift,lift] \<Rightarrow> lift" ("(WF'(_')'_(_))"  [20,1000] 90)
 "_SF" :: "[lift,lift] \<Rightarrow> lift" ("(SF'(_')'_(_))"  [20,1000] 90)
 "_WFsp" :: "[lift,lift] \<Rightarrow> lift" ("(WF '(_')'_(_))"  [20,1000] 90)
 "_SFsp" :: "[lift,lift] \<Rightarrow> lift" ("(SF '(_')'_(_))"  [20,1000] 90)

translations
 "_WF" \<rightleftharpoons> "CONST WeakF"
 "_SF" \<rightleftharpoons> "CONST StrongF"
 "_WFsp" \<rightharpoonup> "CONST WeakF"
 "_SFsp" \<rightharpoonup> "CONST StrongF"

subsection "Properties of @{term enabled}"

theorem enabledI: "\<turnstile> F \<longrightarrow> Enabled F"
proof (clarsimp)
  fix w
  assume "w \<Turnstile> F"
  with seq_app_first_tail[of w] have "((first w) ## tail w) \<Turnstile> F" by simp
  thus "w \<Turnstile> Enabled F" by (auto simp: enabled_def)
qed

theorem enabledE:
  assumes "s \<Turnstile> Enabled F" and "\<And>u. (first s ## u) \<Turnstile> F \<Longrightarrow> Q"
  shows "Q"
  using assms unfolding enabled_def by blast

lemma enabled_mono:
  assumes "w \<Turnstile> Enabled F" and "\<turnstile> F \<longrightarrow> G"
  shows "w \<Turnstile> Enabled G"
  using assms[unlifted] unfolding enabled_def by blast

lemma Enabled_disj1: "\<turnstile> Enabled F \<longrightarrow> Enabled (F \<or> G)"
  by (auto simp: enabled_def)

lemma  Enabled_disj2: "\<turnstile> Enabled F \<longrightarrow> Enabled (G \<or> F)"
  by (auto simp: enabled_def)

lemma  Enabled_conj1: "\<turnstile> Enabled (F \<and> G) \<longrightarrow> Enabled F"
  by (auto simp: enabled_def)

lemma  Enabled_conj2: "\<turnstile> Enabled (G \<and> F) \<longrightarrow> Enabled F"
  by (auto simp: enabled_def)

lemma Enabled_disjD: "\<turnstile> Enabled (F \<or> G) \<longrightarrow> Enabled F \<or> Enabled G"
  by (auto simp: enabled_def)

lemma Enabled_disj: "\<turnstile> Enabled (F \<or> G) = (Enabled F \<or> Enabled G)"
  by (auto simp: enabled_def)

lemmas enabled_disj_rew = Enabled_disj[int_rewrite]

lemma Enabled_ex: "\<turnstile> Enabled (\<exists> x. F x) = (\<exists> x. Enabled (F x))"
  by (force simp: enabled_def)

subsection "Fairness Properties"

lemma WF_alt: "\<turnstile> WF(A)_v = (\<box>\<diamond>\<not>Enabled \<langle>A\<rangle>_v \<or> \<box>\<diamond>\<langle>A\<rangle>_v)"
proof -
  have "\<turnstile> WF(A)_v = (\<not>\<diamond>\<box> Enabled \<langle>A\<rangle>_v \<or> \<box>\<diamond>\<langle>A\<rangle>_v)" by (auto simp: WeakF_def)
  thus ?thesis by (simp add: dualization_rew)
qed

lemma SF_alt: "\<turnstile> SF(A)_v = (\<diamond>\<box>\<not>Enabled \<langle>A\<rangle>_v \<or> \<box>\<diamond>\<langle>A\<rangle>_v)"
proof -
  have "\<turnstile> SF(A)_v = (\<not>\<box>\<diamond> Enabled \<langle>A\<rangle>_v \<or> \<box>\<diamond>\<langle>A\<rangle>_v)" by (auto simp: StrongF_def)
  thus ?thesis by (simp add: dualization_rew)
qed

lemma alwaysWFI: "\<turnstile> WF(A)_v \<longrightarrow> \<box>WF(A)_v"
  unfolding WF_alt[int_rewrite] by (rule MM6)

theorem WF_always[simp_unl]: "\<turnstile> \<box>WF(A)_v = WF(A)_v"
  by (rule int_iffI[OF ax1 alwaysWFI])

theorem WF_eventually[simp_unl]: "\<turnstile> \<diamond>WF(A)_v = WF(A)_v"
proof -
  have 1: "\<turnstile> \<not>WF(A)_v = (\<diamond>\<box>Enabled \<langle>A\<rangle>_v \<and> \<not> \<box>\<diamond>\<langle>A\<rangle>_v)"
    by (auto simp: WeakF_def)
  have "\<turnstile> \<box>\<not>WF(A)_v = \<not>WF(A)_v"
    by (simp add: 1[int_rewrite] STL5[int_rewrite] dualization_rew)
  thus ?thesis
    by (auto simp: eventually_def)
qed

lemma alwaysSFI: "\<turnstile> SF(A)_v \<longrightarrow> \<box>SF(A)_v"
proof -
  have "\<turnstile> \<box>\<diamond>\<box>\<not>Enabled \<langle>A\<rangle>_v \<or> \<box>\<diamond>\<langle>A\<rangle>_v \<longrightarrow> \<box>(\<box>\<diamond>\<box>\<not>Enabled \<langle>A\<rangle>_v \<or> \<box>\<diamond>\<langle>A\<rangle>_v)"
    by (rule MM6)
  thus ?thesis unfolding SF_alt[int_rewrite] by simp
qed

theorem SF_always[simp_unl]: "\<turnstile> \<box>SF(A)_v = SF(A)_v"
  by (rule int_iffI[OF ax1 alwaysSFI])

theorem SF_eventually[simp_unl]: "\<turnstile> \<diamond>SF(A)_v = SF(A)_v"
proof -
  have 1: "\<turnstile> \<not>SF(A)_v = (\<box>\<diamond>Enabled \<langle>A\<rangle>_v \<and> \<not> \<box>\<diamond>\<langle>A\<rangle>_v)"
    by (auto simp: StrongF_def)
  have "\<turnstile> \<box>\<not>SF(A)_v = \<not>SF(A)_v"
    by (simp add: 1[int_rewrite] STL5[int_rewrite] dualization_rew)
  thus ?thesis
    by (auto simp: eventually_def)
qed

theorem SF_imp_WF: "\<turnstile> SF (A)_v \<longrightarrow> WF (A)_v"
  unfolding WeakF_def StrongF_def by (auto dest: E20[unlift_rule])

theorem WF1_general:
  assumes h1: "|~ P \<and> N \<longrightarrow> \<circle>P \<or> \<circle>Q"
      and h2: "|~ P \<and> N \<and> \<langle>A\<rangle>_v \<longrightarrow> \<circle>Q"
      and h3: "\<turnstile> P \<and> N \<longrightarrow> Enabled \<langle>A\<rangle>_v"
      and h4: "|~ P \<and> Unchanged w \<longrightarrow> \<circle>P"
  shows "\<turnstile> \<box>N \<and> WF(A)_v \<longrightarrow> (P \<leadsto> Q)"
proof -
  have "\<turnstile> \<box>(\<box>N \<and> WF(A)_v) \<longrightarrow> \<box>(\<box>P \<longrightarrow> \<diamond>\<langle>A\<rangle>_v)"
  proof (rule STL4)
    have "\<turnstile> \<box>(P \<and> N) \<longrightarrow> \<diamond>\<box>Enabled \<langle>A\<rangle>_v" by (rule lift_imp_trans[OF h3[THEN STL4] E3])
    hence "\<turnstile> \<box>P \<and> \<box>N \<and> WF(A)_v \<longrightarrow> \<box>\<diamond>\<langle>A\<rangle>_v" by (auto simp: WeakF_def STL5[int_rewrite])
    with ax1[of "TEMP \<diamond>\<langle>A\<rangle>_v"] show "\<turnstile> \<box>N \<and> WF(A)_v \<longrightarrow> \<box>P \<longrightarrow> \<diamond>\<langle>A\<rangle>_v" by force
  qed
  hence "\<turnstile> \<box>N \<and> WF(A)_v \<longrightarrow> \<box>(\<box>P \<longrightarrow> \<diamond>\<langle>A\<rangle>_v)"
    by (simp add: STL5[int_rewrite])
  with AA22[OF h1 h2 h4] show ?thesis by force
qed

text \<open>Lamport's version of the rule is derived as a special case.\<close>

theorem WF1:
  assumes h1: "|~ P \<and> [N]_v \<longrightarrow> \<circle>P \<or> \<circle>Q"
      and h2: "|~ P \<and> \<langle>N \<and> A\<rangle>_v \<longrightarrow> \<circle>Q"
      and h3: "\<turnstile> P \<longrightarrow> Enabled \<langle>A\<rangle>_v"
      and h4: "|~ P \<and> Unchanged v \<longrightarrow> \<circle>P"
  shows "\<turnstile> \<box>[N]_v \<and> WF(A)_v \<longrightarrow> (P \<leadsto> Q)"
proof -
  have "\<turnstile> \<box>\<box>[N]_v \<and> WF(A)_v \<longrightarrow> (P \<leadsto> Q)"
  proof (rule WF1_general)
    from h1 T9[of N v] show "|~ P \<and> \<box>[N]_v \<longrightarrow> \<circle>P \<or> \<circle>Q" by force
  next
    from T9[of N v] have "|~ P \<and> \<box>[N]_v \<and> \<langle>A\<rangle>_v \<longrightarrow> P \<and> \<langle>N \<and> A\<rangle>_v"
      by (auto simp: actrans_def angle_actrans_def)
    from this h2 show "|~ P \<and> \<box>[N]_v \<and> \<langle>A\<rangle>_v \<longrightarrow> \<circle>Q" by (rule pref_imp_trans)
  next
    from h3 T9[of N v] show "\<turnstile> P \<and> \<box>[N]_v \<longrightarrow> Enabled \<langle>A\<rangle>_v" by force
  qed (rule h4)
  thus ?thesis by simp
qed

text \<open>
  The corresponding rule for strong fairness has an additional hypothesis
  \<open>\<box>F\<close>, which is typically a conjunction of other fairness properties
  used to prove that the helpful action eventually becomes enabled.
\<close>

theorem SF1_general:
  assumes h1: "|~ P \<and> N \<longrightarrow> \<circle>P \<or> \<circle>Q"
      and h2: "|~ P \<and> N \<and> \<langle>A\<rangle>_v \<longrightarrow> \<circle>Q"
      and h3: "\<turnstile> \<box>P \<and> \<box>N \<and> \<box>F \<longrightarrow> \<diamond>Enabled \<langle>A\<rangle>_v"
      and h4: "|~ P \<and> Unchanged w \<longrightarrow> \<circle>P"
  shows "\<turnstile> \<box>N \<and> SF(A)_v \<and> \<box>F \<longrightarrow> (P \<leadsto> Q)"
proof -
  have "\<turnstile> \<box>(\<box>N \<and> SF(A)_v \<and> \<box>F) \<longrightarrow> \<box>(\<box>P \<longrightarrow> \<diamond>\<langle>A\<rangle>_v)"
  proof (rule STL4)
    have "\<turnstile> \<box>(\<box>P \<and> \<box>N \<and> \<box>F) \<longrightarrow> \<box>\<diamond>Enabled \<langle>A\<rangle>_v" by (rule STL4[OF h3])
    hence "\<turnstile> \<box>P \<and> \<box>N \<and> \<box>F \<and> SF(A)_v \<longrightarrow> \<box>\<diamond>\<langle>A\<rangle>_v" by (auto simp: StrongF_def STL5[int_rewrite])
    with ax1[of "TEMP \<diamond>\<langle>A\<rangle>_v"] show "\<turnstile> \<box>N \<and> SF(A)_v \<and> \<box>F \<longrightarrow> \<box>P \<longrightarrow> \<diamond>\<langle>A\<rangle>_v" by force
  qed
  hence "\<turnstile> \<box>N \<and> SF(A)_v \<and> \<box>F \<longrightarrow> \<box>(\<box>P \<longrightarrow> \<diamond>\<langle>A\<rangle>_v)"
    by (simp add: STL5[int_rewrite])
  with AA22[OF h1 h2 h4] show ?thesis by force
qed

theorem SF1:
  assumes h1: "|~ P \<and> [N]_v \<longrightarrow> \<circle>P \<or> \<circle>Q"
      and h2: "|~ P \<and> \<langle>N \<and> A\<rangle>_v \<longrightarrow> \<circle>Q"
      and h3: "\<turnstile> \<box>P \<and> \<box>[N]_v \<and> \<box>F \<longrightarrow> \<diamond>Enabled \<langle>A\<rangle>_v"
      and h4: "|~ P \<and> Unchanged v \<longrightarrow> \<circle>P"
  shows "\<turnstile> \<box>[N]_v \<and> SF(A)_v \<and> \<box>F \<longrightarrow> (P \<leadsto> Q)"
proof -
  have "\<turnstile> \<box>\<box>[N]_v \<and> SF(A)_v \<and> \<box>F \<longrightarrow> (P \<leadsto> Q)"
  proof (rule SF1_general)
    from h1 T9[of N v] show "|~ P \<and> \<box>[N]_v \<longrightarrow> \<circle>P \<or> \<circle>Q" by force
  next
    from T9[of N v] have "|~ P \<and> \<box>[N]_v \<and> \<langle>A\<rangle>_v \<longrightarrow> P \<and> \<langle>N \<and> A\<rangle>_v"
      by (auto simp: actrans_def angle_actrans_def)
    from this h2 show "|~ P \<and> \<box>[N]_v \<and> \<langle>A\<rangle>_v \<longrightarrow> \<circle>Q" by (rule pref_imp_trans)
  next
    from h3 show "\<turnstile> \<box>P \<and> \<box>\<box>[N]_v \<and> \<box>F \<longrightarrow> \<diamond>Enabled \<langle>A\<rangle>_v" by simp
  qed (rule h4)
  thus ?thesis by simp
qed

text \<open>
  Lamport proposes the following rule as an introduction rule for \<open>WF\<close> formulas.
\<close>

theorem WF2:
  assumes h1: "|~ \<langle>N \<and> B\<rangle>_f \<longrightarrow> \<langle>M\<rangle>_g"
      and h2: "|~ P \<and> \<circle>P \<and> \<langle>N \<and> A\<rangle>_f \<longrightarrow> B"
      and h3: "\<turnstile> P \<and> Enabled \<langle>M\<rangle>_g \<longrightarrow> Enabled \<langle>A\<rangle>_f"
      and h4: "\<turnstile> \<box>[N \<and> \<not>B]_f \<and> WF(A)_f \<and> \<box>F \<and> \<diamond>\<box>Enabled \<langle>M\<rangle>_g \<longrightarrow> \<diamond>\<box>P"
  shows "\<turnstile> \<box>[N]_f \<and> WF(A)_f \<and> \<box>F \<longrightarrow> WF(M)_g"
proof -
  have "\<turnstile> \<box>[N]_f \<and> WF(A)_f \<and> \<box>F \<and> \<diamond>\<box>Enabled \<langle>M\<rangle>_g \<and> \<not>\<box>\<diamond>\<langle>M\<rangle>_g \<longrightarrow> \<box>\<diamond>\<langle>M\<rangle>_g"
  proof -
    have 1: "\<turnstile> \<box>[N]_f \<and> WF(A)_f \<and> \<box>F \<and> \<diamond>\<box>Enabled \<langle>M\<rangle>_g \<and> \<not>\<box>\<diamond>\<langle>M\<rangle>_g \<longrightarrow> \<diamond>\<box>P"
    proof -
      have A: "\<turnstile> \<box>[N]_f \<and> WF(A)_f \<and> \<box>F \<and> \<diamond>\<box>Enabled \<langle>M\<rangle>_g \<and> \<not>\<box>\<diamond>\<langle>M\<rangle>_g \<longrightarrow>
                 \<box>(\<box>[N]_f \<and> WF(A)_f \<and> \<box>F) \<and> \<diamond>\<box>(\<diamond>\<box>Enabled \<langle>M\<rangle>_g \<and> \<box>[\<not>M]_g)"
        unfolding STL6[int_rewrite] (* important to do this before STL5 is applied *)
        by (auto simp: STL5[int_rewrite] dualization_rew)
      have B: "\<turnstile> \<box>(\<box>[N]_f \<and> WF(A)_f \<and> \<box>F) \<and> \<diamond>\<box>(\<diamond>\<box>Enabled \<langle>M\<rangle>_g \<and> \<box>[\<not>M]_g) \<longrightarrow>
                 \<diamond>((\<box>[N]_f \<and> WF(A)_f \<and> \<box>F) \<and> \<box>(\<diamond>\<box>Enabled \<langle>M\<rangle>_g \<and> \<box>[\<not>M]_g))"
        by (rule SE2)
      from lift_imp_trans[OF A B]
      have "\<turnstile> \<box>[N]_f \<and> WF(A)_f \<and> \<box>F \<and> \<diamond>\<box>Enabled \<langle>M\<rangle>_g \<and> \<not>\<box>\<diamond>\<langle>M\<rangle>_g \<longrightarrow>
              \<diamond>((\<box>[N]_f \<and> WF(A)_f \<and> \<box>F) \<and> (\<diamond>\<box>Enabled \<langle>M\<rangle>_g \<and> \<box>[\<not>M]_g))"
        by (simp add: STL5[int_rewrite])
      moreover
      from h1 have "|~ [N]_f \<longrightarrow> [\<not>M]_g \<longrightarrow> [N \<and> \<not>B]_f" by (auto simp: actrans_def angle_actrans_def)
      hence "\<turnstile> \<box>[[N]_f]_f \<longrightarrow> \<box>[[\<not>M]_g \<longrightarrow> [N \<and> \<not>B]_f]_f" by (rule M2)
      from lift_imp_trans[OF this ax4] have "\<turnstile> \<box>[N]_f \<and> \<box>[\<not>M]_g \<longrightarrow> \<box>[N \<and> \<not>B]_f"
        by (force intro: T4[unlift_rule])
      with h4 have "\<turnstile> (\<box>[N]_f \<and> WF(A)_f \<and> \<box>F) \<and> (\<diamond>\<box>Enabled \<langle>M\<rangle>_g \<and> \<box>[\<not>M]_g) \<longrightarrow> \<diamond>\<box>P"
        by force
      from STL4_eve[OF this]
      have "\<turnstile> \<diamond>((\<box>[N]_f \<and> WF(A)_f \<and> \<box>F) \<and> (\<diamond>\<box>Enabled \<langle>M\<rangle>_g \<and> \<box>[\<not>M]_g)) \<longrightarrow> \<diamond>\<box>P" by simp
      ultimately
      show ?thesis by (rule lift_imp_trans)
    qed
    have 2: "\<turnstile> \<box>[N]_f \<and> WF(A)_f \<and> \<diamond>\<box>Enabled \<langle>M\<rangle>_g \<and> \<diamond>\<box>P \<longrightarrow> \<box>\<diamond>\<langle>M\<rangle>_g"
    proof -
      have A: "\<turnstile> \<diamond>\<box>P \<and> \<diamond>\<box>Enabled \<langle>M\<rangle>_g \<and> WF(A)_f \<longrightarrow> \<box>\<diamond>\<langle>A\<rangle>_f"
        using h3[THEN STL4, THEN STL4_eve] by (auto simp: STL6[int_rewrite] WeakF_def)
      have B: "\<turnstile> \<box>[N]_f \<and> \<diamond>\<box>P \<and>  \<box>\<diamond>\<langle>A\<rangle>_f \<longrightarrow> \<box>\<diamond>\<langle>M\<rangle>_g"
      proof -
        from M1[of P f] have "\<turnstile> \<box>P \<and> \<box>\<diamond>\<langle>N \<and> A\<rangle>_f \<longrightarrow> \<box>\<diamond>\<langle>(P \<and> \<circle>P) \<and> (N \<and> A)\<rangle>_f"
          by (force intro: AA29[unlift_rule])
        hence "\<turnstile> \<diamond>\<box>(\<box>P \<and> \<box>\<diamond>\<langle>N \<and> A\<rangle>_f) \<longrightarrow> \<diamond>\<box>\<box>\<diamond>\<langle>(P \<and> \<circle>P) \<and> (N \<and> A)\<rangle>_f"
          by (rule STL4_eve[OF STL4])
        hence "\<turnstile> \<diamond>\<box>P \<and> \<box>\<diamond>\<langle>N \<and> A\<rangle>_f \<longrightarrow> \<box>\<diamond>\<langle>(P \<and> \<circle>P) \<and> (N \<and> A)\<rangle>_f"
          by (simp add: STL6[int_rewrite])
        with AA29[of N f A]
        have B1: "\<turnstile> \<box>[N]_f \<and> \<diamond>\<box>P \<and>  \<box>\<diamond>\<langle>A\<rangle>_f \<longrightarrow> \<box>\<diamond>\<langle>(P \<and> \<circle>P) \<and> (N \<and> A)\<rangle>_f" by force
        from h2 have "|~ \<langle>(P \<and> \<circle>P) \<and> (N \<and> A)\<rangle>_f \<longrightarrow> \<langle>N \<and> B\<rangle>_f"
          by (auto simp: angle_actrans_sem[unlifted])
        from B1 this[THEN AA25, THEN STL4] have "\<turnstile> \<box>[N]_f \<and> \<diamond>\<box>P \<and>  \<box>\<diamond>\<langle>A\<rangle>_f \<longrightarrow> \<box>\<diamond>\<langle>N \<and> B\<rangle>_f"
          by (rule lift_imp_trans)
        moreover
        have "\<turnstile> \<box>\<diamond>\<langle>N \<and> B\<rangle>_f \<longrightarrow> \<box>\<diamond>\<langle>M\<rangle>_g" by (rule h1[THEN AA25, THEN STL4])
        ultimately show ?thesis by (rule lift_imp_trans)
      qed
      from A B show ?thesis by force
    qed
    from 1 2 show ?thesis by force
  qed
  thus ?thesis by (auto simp: WeakF_def)
qed

text \<open>
  Lamport proposes an analogous theorem for introducing strong fairness, and its
  proof is very similar, in fact, it was obtained by copy and paste, with minimal
  modifications.
\<close>

theorem SF2:
  assumes h1: "|~ \<langle>N \<and> B\<rangle>_f \<longrightarrow> \<langle>M\<rangle>_g"
      and h2: "|~ P \<and> \<circle>P \<and> \<langle>N \<and> A\<rangle>_f \<longrightarrow> B"
      and h3: "\<turnstile> P \<and> Enabled \<langle>M\<rangle>_g \<longrightarrow> Enabled \<langle>A\<rangle>_f"
      and h4: "\<turnstile> \<box>[N \<and> \<not>B]_f \<and> SF(A)_f \<and> \<box>F \<and> \<box>\<diamond>Enabled \<langle>M\<rangle>_g \<longrightarrow> \<diamond>\<box>P"
  shows "\<turnstile> \<box>[N]_f \<and> SF(A)_f \<and> \<box>F \<longrightarrow> SF(M)_g"
proof -
  have "\<turnstile> \<box>[N]_f \<and> SF(A)_f \<and> \<box>F \<and> \<box>\<diamond>Enabled \<langle>M\<rangle>_g \<and> \<not>\<box>\<diamond>\<langle>M\<rangle>_g \<longrightarrow> \<box>\<diamond>\<langle>M\<rangle>_g"
  proof -
    have 1: "\<turnstile> \<box>[N]_f \<and> SF(A)_f \<and> \<box>F \<and> \<box>\<diamond>Enabled \<langle>M\<rangle>_g \<and> \<not>\<box>\<diamond>\<langle>M\<rangle>_g \<longrightarrow> \<diamond>\<box>P"
    proof -
      have A: "\<turnstile> \<box>[N]_f \<and> SF(A)_f \<and> \<box>F \<and> \<box>\<diamond>Enabled \<langle>M\<rangle>_g \<and> \<not>\<box>\<diamond>\<langle>M\<rangle>_g \<longrightarrow>
                 \<box>(\<box>[N]_f \<and> SF(A)_f \<and> \<box>F) \<and> \<diamond>\<box>(\<box>\<diamond>Enabled \<langle>M\<rangle>_g \<and> \<box>[\<not>M]_g)"
        unfolding STL6[int_rewrite] (* important to do this before STL5 is applied *)
        by (auto simp: STL5[int_rewrite] dualization_rew)
      have B: "\<turnstile> \<box>(\<box>[N]_f \<and> SF(A)_f \<and> \<box>F) \<and> \<diamond>\<box>(\<box>\<diamond>Enabled \<langle>M\<rangle>_g \<and> \<box>[\<not>M]_g) \<longrightarrow>
                 \<diamond>((\<box>[N]_f \<and> SF(A)_f \<and> \<box>F) \<and> \<box>(\<box>\<diamond>Enabled \<langle>M\<rangle>_g \<and> \<box>[\<not>M]_g))"
        by (rule SE2)
      from lift_imp_trans[OF A B]
      have "\<turnstile> \<box>[N]_f \<and> SF(A)_f \<and> \<box>F \<and> \<box>\<diamond>Enabled \<langle>M\<rangle>_g \<and> \<not>\<box>\<diamond>\<langle>M\<rangle>_g \<longrightarrow>
              \<diamond>((\<box>[N]_f \<and> SF(A)_f \<and> \<box>F) \<and> (\<box>\<diamond>Enabled \<langle>M\<rangle>_g \<and> \<box>[\<not>M]_g))"
        by (simp add: STL5[int_rewrite])
      moreover
      from h1 have "|~ [N]_f \<longrightarrow> [\<not>M]_g \<longrightarrow> [N \<and> \<not>B]_f" by (auto simp: actrans_def angle_actrans_def)
      hence "\<turnstile> \<box>[[N]_f]_f \<longrightarrow> \<box>[[\<not>M]_g \<longrightarrow> [N \<and> \<not>B]_f]_f" by (rule M2)
      from lift_imp_trans[OF this ax4] have "\<turnstile> \<box>[N]_f \<and> \<box>[\<not>M]_g \<longrightarrow> \<box>[N \<and> \<not>B]_f"
        by (force intro: T4[unlift_rule])
      with h4 have "\<turnstile> (\<box>[N]_f \<and> SF(A)_f \<and> \<box>F) \<and> (\<box>\<diamond>Enabled \<langle>M\<rangle>_g \<and> \<box>[\<not>M]_g) \<longrightarrow> \<diamond>\<box>P"
        by force
      from STL4_eve[OF this]
      have "\<turnstile> \<diamond>((\<box>[N]_f \<and> SF(A)_f \<and> \<box>F) \<and> (\<box>\<diamond>Enabled \<langle>M\<rangle>_g \<and> \<box>[\<not>M]_g)) \<longrightarrow> \<diamond>\<box>P" by simp
      ultimately
      show ?thesis by (rule lift_imp_trans)
    qed
    have 2: "\<turnstile> \<box>[N]_f \<and> SF(A)_f \<and> \<box>\<diamond>Enabled \<langle>M\<rangle>_g \<and> \<diamond>\<box>P \<longrightarrow> \<box>\<diamond>\<langle>M\<rangle>_g"
    proof -
      have "\<turnstile> \<box>\<diamond>(P \<and> Enabled \<langle>M\<rangle>_g) \<and> SF(A)_f \<longrightarrow> \<box>\<diamond>\<langle>A\<rangle>_f"
        using h3[THEN STL4_eve, THEN STL4] by (auto simp: StrongF_def)
      with E28 have A: "\<turnstile> \<diamond>\<box>P \<and> \<box>\<diamond>Enabled \<langle>M\<rangle>_g \<and> SF(A)_f \<longrightarrow> \<box>\<diamond>\<langle>A\<rangle>_f"
        by force
      have B: "\<turnstile> \<box>[N]_f \<and> \<diamond>\<box>P \<and>  \<box>\<diamond>\<langle>A\<rangle>_f \<longrightarrow> \<box>\<diamond>\<langle>M\<rangle>_g"
      proof -
        from M1[of P f] have "\<turnstile> \<box>P \<and> \<box>\<diamond>\<langle>N \<and> A\<rangle>_f \<longrightarrow> \<box>\<diamond>\<langle>(P \<and> \<circle>P) \<and> (N \<and> A)\<rangle>_f"
          by (force intro: AA29[unlift_rule])
        hence "\<turnstile> \<diamond>\<box>(\<box>P \<and> \<box>\<diamond>\<langle>N \<and> A\<rangle>_f) \<longrightarrow> \<diamond>\<box>\<box>\<diamond>\<langle>(P \<and> \<circle>P) \<and> (N \<and> A)\<rangle>_f"
          by (rule STL4_eve[OF STL4])
        hence "\<turnstile> \<diamond>\<box>P \<and> \<box>\<diamond>\<langle>N \<and> A\<rangle>_f \<longrightarrow> \<box>\<diamond>\<langle>(P \<and> \<circle>P) \<and> (N \<and> A)\<rangle>_f"
          by (simp add: STL6[int_rewrite])
        with AA29[of N f A]
        have B1: "\<turnstile> \<box>[N]_f \<and> \<diamond>\<box>P \<and>  \<box>\<diamond>\<langle>A\<rangle>_f \<longrightarrow> \<box>\<diamond>\<langle>(P \<and> \<circle>P) \<and> (N \<and> A)\<rangle>_f" by force
        from h2 have "|~ \<langle>(P \<and> \<circle>P) \<and> (N \<and> A)\<rangle>_f \<longrightarrow> \<langle>N \<and> B\<rangle>_f"
          by (auto simp: angle_actrans_sem[unlifted])
        from B1 this[THEN AA25, THEN STL4] have "\<turnstile> \<box>[N]_f \<and> \<diamond>\<box>P \<and>  \<box>\<diamond>\<langle>A\<rangle>_f \<longrightarrow> \<box>\<diamond>\<langle>N \<and> B\<rangle>_f"
          by (rule lift_imp_trans)
        moreover
        have "\<turnstile> \<box>\<diamond>\<langle>N \<and> B\<rangle>_f \<longrightarrow> \<box>\<diamond>\<langle>M\<rangle>_g" by (rule h1[THEN AA25, THEN STL4])
        ultimately show ?thesis by (rule lift_imp_trans)
      qed
      from A B show ?thesis by force
    qed
    from 1 2 show ?thesis by force
  qed
  thus ?thesis by (auto simp: StrongF_def)
qed

text \<open>This is the lattice rule from TLA\<close>

theorem wf_leadsto:
  assumes h1: "wf r"
      and h2: "\<And>x. \<turnstile> F x \<leadsto> (G \<or> (\<exists>y. #((y,x) \<in> r) \<and> F y))"
  shows       "\<turnstile> F x \<leadsto> G"
using h1
proof (rule wf_induct)
  fix x
  assume ih: "\<forall>y. (y, x) \<in> r \<longrightarrow> (\<turnstile> F y \<leadsto> G)"
  show "\<turnstile> F x \<leadsto> G"
  proof -
    from ih have "\<turnstile> (\<exists>y. #((y,x) \<in> r) \<and> F y) \<leadsto> G"
      by (force simp: LT21[int_rewrite] LT33[int_rewrite])
    with h2 show ?thesis by (force intro: LT19[unlift_rule])
  qed
qed

subsection "Stuttering Invariance"

theorem stut_Enabled: "STUTINV Enabled \<langle>F\<rangle>_v"
  by (auto simp: enabled_def stutinv_def dest!: sim_first)

theorem stut_WF: "NSTUTINV F \<Longrightarrow> STUTINV WF(F)_v"
  by (auto simp: WeakF_def stut_Enabled bothstutinvs)

theorem stut_SF: "NSTUTINV F \<Longrightarrow> STUTINV SF(F)_v"
  by (auto simp: StrongF_def stut_Enabled bothstutinvs)

lemmas livestutinv = stut_WF stut_SF stut_Enabled

end


theory Undirected_Graph_Impl
imports
  Undirected_Graph
  "../../sepref/IICF/IICF"
  "../../sepref/IICF/Impl/IICF_Array_of_Array_List"
begin

(* TODO: Move *)
lemma distinct_bounded_list_add_bound:
  assumes D: "distinct xs"
  assumes SS: "set xs \<subseteq> {0..<N}"
  assumes NI: "x<N" "x\<notin>set xs"
  shows "length xs < N"
proof -
  from SS NI have "set xs \<subseteq> {0..<N} - {x}" by auto
  from card_mono[OF _ this] have "card (set xs) < N" using NI by auto
  with distinct_card[OF D] show ?thesis by simp
qed

  (* TODO: Move *)
  lemma card2_eq: "card e = 2 \<longleftrightarrow> (\<exists>u v. u\<noteq>v \<and> e={u,v})"
    by (auto simp: eval_nat_numeral card_Suc_eq)

(* TODO: Move *)
subsection \<open>Doubleton Set to Pair\<close>
definition "epair e = (if card e = 2 then Some (SOME (u,v). e={u,v}) else None)"

lemma epair_eqD: "epair e = Some (x,y) \<Longrightarrow> (x\<noteq>y \<and> e={x,y})"
  apply (cases "card e = 2")
  unfolding epair_def
  apply simp_all
  apply (clarsimp simp: card_Suc_eq eval_nat_numeral doubleton_eq_iff)
  by (smt case_prodD case_prodI someI)

lemma epair_not_sng[simp]: "epair e \<noteq> Some (x,x)"
  by (auto dest: epair_eqD)

lemma epair_None[simp]: "epair {a,b} = None \<longleftrightarrow> a=b"
  unfolding epair_def by (auto simp: card2_eq)

lemma epair_cases:
  obtains (edge) u v where "e={u,v}" "u\<noteq>v" "epair e = Some (u,v)"
        | (no_edge) "card e \<noteq> 2" "epair e = None"
  by (metis card2_eq epair_None epair_eqD not_Some_eq2)

definition "mop_wgraph_adjs g w u \<equiv> SPEC (\<lambda>adjs. set adjs = {(v,d). (u,v)\<in>edges g \<and> w {u,v} = d})"

type_synonym ('v,'w) wugraph1 = "'v \<Rightarrow> ('v\<rightharpoonup>'w)"

definition wu1_invar :: "('v,'w) wugraph1 \<Rightarrow> bool"
  where "wu1_invar g1 \<equiv>
      (\<forall>u. g1 u u = None)
    \<and> (\<forall>u v w. g1 u v = Some w \<longrightarrow> g1 v u = Some w)
    \<and> finite { (u,v). g1 u v \<noteq> None }"
definition wu1_\<alpha>E :: "('v,'w) wugraph1 \<Rightarrow> ('v\<times>'v) set" where "wu1_\<alpha>E g1 \<equiv> { (u,v). g1 u v \<noteq> None }"
definition wu1_\<alpha>g :: "('v,'w) wugraph1 \<Rightarrow> 'v ugraph" where "wu1_\<alpha>g g1 \<equiv> graph {} (wu1_\<alpha>E g1)"

definition wu1_\<alpha>w :: "('v,'w::zero) wugraph1 \<Rightarrow> 'v set \<Rightarrow> 'w" where
  "wu1_\<alpha>w g1 e \<equiv> case epair e of Some (u,v) \<Rightarrow> the_default 0 (g1 u v) | None \<Rightarrow> 0"

lemma wu1_invar_alt: "wu1_invar g1 \<equiv>
      (\<forall>u. g1 u u = None)
    \<and> (\<forall>u v w. g1 u v = Some w \<longrightarrow> g1 v u = Some w)
    \<and> finite (wu1_\<alpha>E g1)"
  unfolding wu1_invar_def wu1_\<alpha>E_def by simp

definition wu1_empty :: "('v,'w) wugraph1" where "wu1_empty \<equiv> \<lambda>_ _. None"
definition wu1_ins_edge :: "'v\<times>'v \<Rightarrow> 'w \<Rightarrow> ('v,'w) wugraph1 \<Rightarrow> ('v,'w) wugraph1 nres"
  where "wu1_ins_edge \<equiv> \<lambda>(u,v) w g. doN {
    ASSERT (v \<notin> dom (g u));
    gu \<leftarrow> mop_map_update v w (g u);
    let g = g(u:=gu);
    ASSERT (u \<notin> dom (g v));
    gv \<leftarrow> mop_map_update u w (g v);
    let g = g(v:=gv);
    RETURN g
  }"
definition wu1_adjs :: "'v \<Rightarrow> ('v,'w) wugraph1 \<Rightarrow> ('v\<times>'w) list nres"
  where "wu1_adjs u g1 \<equiv> SPEC (\<lambda>xs. distinct xs \<and> set xs = {(v,w). g1 u v = Some w})"

lemma wu1_empty_refine[simp]:
  "wu1_invar wu1_empty"
  "wu1_\<alpha>g wu1_empty = graph_empty"
  "wu1_\<alpha>w wu1_empty = (\<lambda>_. 0)"
  by (auto
    simp: wu1_invar_def wu1_empty_def wu1_\<alpha>g_def wu1_\<alpha>E_def wu1_\<alpha>w_def[abs_def]
    simp: fun_eq_iff split: option.splits
    )

lemma wu1_irrefl[simp]: "wu1_invar g \<Longrightarrow> g u u = None" by (auto simp: wu1_invar_def)
lemma wu1_sym: "wu1_invar g \<Longrightarrow> g u v = g v u"
  apply (cases "g u v"; cases "g v u"; simp)
  unfolding wu1_invar_def
  apply (metis option.simps(3))
  apply (metis option.simps(3))
  apply (metis option.simps(1))
  done

lemma wu1_finite[simp, intro]: "wu1_invar g \<Longrightarrow> finite (wu1_\<alpha>E g)"
  unfolding wu1_invar_alt by auto

lemma wu1_edges_aux: "wu1_invar g \<Longrightarrow> edges (graph {} (wu1_\<alpha>E g)) = wu1_\<alpha>E g"
  apply (simp add: edges_graph)
  apply (auto simp: wu1_\<alpha>E_def wu1_sym)
  done

lemma wu1_edges_aux2: "wu1_invar g \<Longrightarrow> edges (wu1_\<alpha>g g) = wu1_\<alpha>E g"
  unfolding wu1_\<alpha>g_def by (simp add: wu1_edges_aux)

lemma wu1_\<alpha>E_ins_aux:
  assumes "wu1_invar g" "(u,v)\<notin>edges (wu1_\<alpha>g g)" "u\<noteq>v"
  shows "wu1_\<alpha>E (g(u := g u(v \<mapsto> w), v := g v(u \<mapsto> w))) = {(u,v),(v,u)} \<union> wu1_\<alpha>E g"
  using assms
  unfolding wu1_\<alpha>g_def
  apply (simp add: wu1_edges_aux)
  unfolding wu1_\<alpha>E_def
  by (auto split!: if_splits)

lemma wu1_ins_edge_refine[simp]:
  assumes "wu1_invar g" "(u,v)\<notin>edges (wu1_\<alpha>g g)" "u\<noteq>v"
  shows "wu1_ins_edge (u,v) w g \<le> SPEC (\<lambda>g'.
      wu1_invar g'
    \<and> wu1_\<alpha>g g' = ins_edge (u,v) (wu1_\<alpha>g g)
    \<and> wu1_\<alpha>w g' = (wu1_\<alpha>w g)({u,v}:=w)
  )"
  unfolding wu1_ins_edge_def
  apply (refine_vcg)
  apply (simp_all add: \<open>u\<noteq>v\<close>[symmetric] split: if_splits)
  apply (all \<open>(elim conjE)?;(hypsubst)?\<close>)

  subgoal
    using assms(2)
    apply (auto simp: \<open>wu1_invar g\<close> wu1_edges_aux2)
    by (auto simp: wu1_\<alpha>E_def)
  subgoal
    using assms(1) assms(3) wu1_sym by fastforce
  subgoal
    using \<open>u\<noteq>v\<close>
    unfolding wu1_invar_alt wu1_ins_edge_def
    by (auto simp: \<open>wu1_invar g\<close> wu1_sym wu1_\<alpha>E_ins_aux[OF assms(1-3)])
  subgoal
    unfolding wu1_\<alpha>g_def wu1_ins_edge_def
    apply (simp add: wu1_\<alpha>E_ins_aux[OF assms(1-3)])
    apply (rewrite graph_eq_iff; simp add: nodes_graph edges_graph edges_ins_edge \<open>wu1_invar g\<close>)
    by auto
  subgoal
    unfolding wu1_\<alpha>w_def wu1_ins_edge_def
    apply (rule ext)
    subgoal for e by (cases e rule: epair_cases) auto
    done
  done

lemma wu1_adjs_refine:
  assumes "wu1_invar g"
  shows "wu1_adjs u g \<le> mop_wgraph_adjs (wu1_\<alpha>g g) (wu1_\<alpha>w g) u"
  apply (simp add: wu1_edges_aux2[OF assms] wu1_adjs_def mop_wgraph_adjs_def)
  apply (auto simp: wu1_\<alpha>w_def wu1_\<alpha>E_def)
  apply (auto
    split: option.split
    simp: doubleton_eq_iff wu1_irrefl[OF assms] wu1_sym[OF assms]
    dest!: epair_eqD)
  done

(*
lemma wu1_adjs_refine[simp]:
  assumes "wu1_invar g"
  shows "wu1_adjs u g = {(v,wu1_\<alpha>w g {u,v}) | v. (u,v)\<in>edges (wu1_\<alpha>g g)}"
  apply (simp add: wu1_edges_aux2[OF assms] wu1_adjs_def)
  apply (auto simp: wu1_\<alpha>w_def wu1_\<alpha>E_def)
  apply (auto
    split: option.split
    simp: doubleton_eq_iff wu1_irrefl[OF assms] wu1_sym[OF assms]
    dest!: epair_eqD)
  done
*)

type_synonym 'w wugraph2 = "(nat\<times>'w) list list"

definition wu2_invar :: "'w wugraph2 \<Rightarrow> bool"
  where "wu2_invar xss \<equiv>
    let N=length xss in
      \<forall>xs\<in>set xss. distinct (map fst xs) \<and> fst`set xs \<subseteq> {0..<N}"

definition wu2_\<alpha> :: "'w wugraph2 \<Rightarrow> (nat,'w) wugraph1"
  where "wu2_\<alpha> xss \<equiv> \<lambda>u. if u<length xss then map_of (xss!u) else Map.empty"

definition wu2_empty :: "nat \<Rightarrow> 'w wugraph2" where "wu2_empty N \<equiv> replicate N []"
definition wu2_ins_edge :: "nat \<times> nat \<Rightarrow> 'w \<Rightarrow> 'w wugraph2 \<Rightarrow> 'w wugraph2 nres" where
  "wu2_ins_edge \<equiv> \<lambda>(u,v) w xss. doN {
    ASSERT (u<length xss \<and> length (xss!u) < length xss);
    xss \<leftarrow> mop_list_list_push_back xss u (v,w);
    ASSERT (v<length xss \<and> length (xss!v) < length xss);
    xss \<leftarrow> mop_list_list_push_back xss v (u,w);
    RETURN xss
  }"

definition wu2_adjs :: "nat \<Rightarrow> 'w wugraph2 \<Rightarrow> (nat\<times>'w) list nres" where
  "wu2_adjs u xss \<equiv> doN { ASSERT (u<length xss); RETURN (xss!u) }"

definition wu2_max :: "'w wugraph2 \<Rightarrow> nat" where [simp]: "wu2_max xss \<equiv> length xss"

lemma wu2_empty_refine[simp]:
  "wu2_invar (wu2_empty N)"
  "wu2_\<alpha> (wu2_empty N) = wu1_empty"
  unfolding wu2_invar_def wu2_empty_def wu2_\<alpha>_def wu1_empty_def
  by auto

lemma wu2_ins_edge_bound_aux:
  assumes "wu2_invar xss" "u<length xss" "v<length xss" "wu2_\<alpha> xss u v = None"
  shows "length (xss!u) < length xss"
proof -
  have "length (map fst (xss!u)) < length xss"
    apply (rule distinct_bounded_list_add_bound[OF _ _ \<open>v<length xss\<close>])
    using assms
    unfolding wu2_invar_def wu2_\<alpha>_def
    by auto
  thus ?thesis by auto
qed

lemma wu2_ins_edge_refine:
  "\<lbrakk>(xss,g)\<in>br wu2_\<alpha> wu2_invar; u<length xss; v<length xss\<rbrakk> \<Longrightarrow> wu2_ins_edge (u,v) w xss \<le>\<Down>(br wu2_\<alpha> wu2_invar) (wu1_ins_edge (u,v) w g)"
  unfolding wu2_ins_edge_def wu1_ins_edge_def
  apply (auto simp: pw_le_iff refine_pw_simps in_br_conv intro: wu2_ins_edge_bound_aux)
  apply (auto
    elim!: in_set_upd_cases
    simp: map_add_find_left wu2_invar_def wu2_\<alpha>_def fun_eq_iff
    split!: if_splits)
  subgoal
    by (meson atLeastLessThan_iff img_fst nth_mem subsetD)
  subgoal
    by (meson atLeastLessThan_iff img_fst nth_mem subsetD)
  subgoal
    using atLeastLessThan_iff by blast
  done

lemma wu2_adjs_refine:
  "\<lbrakk>(xss,g)\<in>br wu2_\<alpha> wu2_invar; u<length xss\<rbrakk> \<Longrightarrow> wu2_adjs u xss \<le> wu1_adjs u g"
  unfolding wu2_adjs_def wu1_adjs_def
  apply refine_vcg
  apply (clarsimp_all simp: pw_le_iff refine_pw_simps in_br_conv)
  apply (auto simp: wu2_invar_def wu1_adjs_def wu2_\<alpha>_def)
  using distinct_mapI nth_mem by blast

definition wu2_adjs_len :: "nat \<Rightarrow> 'w wugraph2 \<Rightarrow> nat nres" where
  "wu2_adjs_len u xss \<equiv> mop_list_list_llen xss u"

definition wu2_adjs_nth :: "nat \<Rightarrow> nat \<Rightarrow> 'w wugraph2 \<Rightarrow> (nat\<times>'w) nres" where
  "wu2_adjs_nth u i xss \<equiv> ASSERT (wu2_invar xss) \<then> mop_list_list_idx xss u i"

definition "wu_rel N \<equiv> {(g2,(g,w)). let g1 = (wu2_\<alpha> g2) in g = wu1_\<alpha>g g1 \<and> w = wu1_\<alpha>w g1 \<and> wu1_invar g1 \<and> wu2_invar g2 \<and> length g2=N }"

lemma wu_empty_refine: "(wu2_empty N, (graph_empty, \<lambda>_. 0)) \<in> wu_rel N"
  apply (auto simp: wu_rel_def)
  by (simp add: wu2_empty_def)

lemma wu_ins_edge_refine:
  assumes "(ui,u)\<in>Id" "(vi,v)\<in>Id" "(di,d)\<in>Id" "u<N" "v<N" "(g2,(g,w))\<in>wu_rel N"
  assumes "(u,v)\<notin>edges g" "u\<noteq>v"
  shows "wu2_ins_edge (ui,vi) di g2 \<le> \<Down>(wu_rel N) (RETURN (ins_edge (u,v) g, w({u,v}:=d)))"
  using assms
  using wu2_ins_edge_refine[of "g2" "wu2_\<alpha> g2" u v d]
  using wu1_ins_edge_refine[of "wu2_\<alpha> g2" u v d]
  apply (auto simp: wu_rel_def pw_le_iff refine_pw_simps Let_def in_br_conv)
  apply (auto simp: wu2_ins_edge_def refine_pw_simps)
  done

lemma iterate_adjs_refine_aux:
  assumes REL: "(g2,(g,w))\<in>wu_rel N"
  assumes PRE2: "u<N"
  shows "
  doN { num_adjs \<leftarrow> wu2_adjs_len u g2; nfoldli [0..<num_adjs] c (\<lambda>i s. doN { vd \<leftarrow> wu2_adjs_nth u i g2; f vd s }) s}
  \<le>
  doN { xs \<leftarrow> mop_wgraph_adjs g w u; nfoldli xs c f s }"
  (is "?LHS \<le> ?RHS")
proof -
  from REL have [simp]: "g=wu1_\<alpha>g (wu2_\<alpha> g2)" "w=wu1_\<alpha>w (wu2_\<alpha> g2)" "N=length g2" "wu2_invar g2"
    by (auto simp: wu_rel_def Let_def)
  from wu1_adjs_refine[of "wu2_\<alpha> g2" u]
    and wu2_adjs_refine[of g2 "wu2_\<alpha> g2" u]
  have "RETURN (g2!u) \<le> mop_wgraph_adjs (wu1_\<alpha>g (wu2_\<alpha> g2)) (wu1_\<alpha>w (wu2_\<alpha> g2)) u"
    using REL PRE2
    by (auto
      simp: in_br_conv wu2_adjs_len_def wu2_adjs_def
      simp: wu_rel_def Let_def
      simp: pw_le_iff refine_pw_simps
      )
  hence "nfoldli [0..<length (g2!u)] c (\<lambda>i s. do {
                                    _ \<leftarrow> ASSERT (i < length (g2!u));
                                    let x = g2!u!i;
                                    f x s
                                  }) s \<le> ?RHS" (is "?INT1 \<le> _")
    apply (rewrite in "_ \<le> \<hole>" nfoldli_by_idx)
    by (auto simp: pw_le_iff refine_pw_simps)
  moreover have "?LHS \<le> ?INT1" using PRE2
    by (auto simp: wu2_adjs_len_def wu2_adjs_nth_def)
  ultimately show ?thesis by simp
qed

thm nfoldli_refine[of l l Id for l, simplified]

lemma iterate_adjs_refine:
  assumes REL: "(g2,(g,w))\<in>wu_rel N"
  assumes PRE2: "u<N"
  assumes REL2: "(si,s)\<in>R" "(ci,c)\<in>R \<rightarrow> bool_rel"
      and RELF: "\<And>u si s. \<lbrakk> (si,s)\<in>R; c s \<rbrakk> \<Longrightarrow> fi u si \<le>\<Down>R (f u s)"
  shows "
  doN { num_adjs \<leftarrow> wu2_adjs_len u g2; nfoldli [0..<num_adjs] ci (\<lambda>i s. doN { vd \<leftarrow> wu2_adjs_nth u i g2; fi vd s }) si}
  \<le>\<Down>R (
  doN { xs \<leftarrow> mop_wgraph_adjs g w u; nfoldli xs c f s })"
proof -
  note R = nfoldli_refine[of l l Id for l, simplified, OF REL2, of fi f]

  show ?thesis
    apply (rule order_trans[OF _ bind_refine[OF Id_refine], rotated])
    apply simp
    apply (rule R)
    subgoal using RELF by blast
    subgoal by (rule iterate_adjs_refine_aux[OF REL PRE2])
    done

qed

type_synonym ('vl,'wl) wu3 = "('vl,'vl word \<times> 'wl word,'vl) array_array_list"

definition "wu_constrain_len_rel N \<equiv> b_rel Id (\<lambda>xss. length xss=N)"

lemma wu2_empty_clen_refine: "(wu2_empty, wu2_empty)\<in>nat_rel \<rightarrow>\<^sub>f\<^sub>d wu_constrain_len_rel"
  apply rule
  by (auto simp: wu_constrain_len_rel_def wu2_empty_def)

lemma wu2_ins_edge_clen_refine:
  "(wu2_ins_edge, wu2_ins_edge) \<in> nat_rel \<times>\<^sub>r nat_rel \<rightarrow> Id \<rightarrow> wu_constrain_len_rel N \<rightarrow> \<langle>wu_constrain_len_rel N\<rangle>nres_rel"
  unfolding wu2_ins_edge_def wu_constrain_len_rel_def
  by (auto simp: pw_nres_rel_iff refine_pw_simps)

lemma wu2_adjs_len_clen_refine: "(wu2_adjs_len, wu2_adjs_len) \<in> nat_rel \<rightarrow> wu_constrain_len_rel N \<rightarrow> \<langle>nat_rel\<rangle>nres_rel"
  unfolding wu_constrain_len_rel_def
  by (auto intro!: nres_relI)

lemma wu2_adjs_nth_clen_refine: "(wu2_adjs_nth,wu2_adjs_nth) \<in> nat_rel \<rightarrow> nat_rel \<rightarrow> wu_constrain_len_rel N \<rightarrow> \<langle>nat_rel \<times>\<^sub>r Id\<rangle>nres_rel"
  unfolding wu_constrain_len_rel_def
  by (auto intro!: nres_relI)

lemma wu2_max_clen_refine: "(wu2_max, wu2_max)\<in>wu_constrain_len_rel N \<rightarrow> nat_rel"
  unfolding wu_constrain_len_rel_def
  by (auto intro!: nres_relI)

context
  fixes VL :: "'vl::len2 itself"
  fixes WL :: "'wl::len2 itself"
begin

  private abbreviation (input) "V_assn \<equiv> snat_assn' TYPE('vl)"
  private abbreviation (input) "W_assn \<equiv> snat_assn' TYPE('wl)"
  definition wu3_assn :: "_ \<Rightarrow> ('vl,'wl) wu3 \<Rightarrow> assn"
    where "wu3_assn \<equiv> aal_assn' TYPE('vl) TYPE('vl) (V_assn \<times>\<^sub>a W_assn)"

  definition "wu_assn N = hr_comp local.wu3_assn (wu_constrain_len_rel N)"

  sepref_register wu2_empty wu2_ins_edge wu2_adjs_len wu2_adjs_nth

  context
    notes [fcomp_norm_unfold] = wu_assn_def[symmetric]
  begin

    sepref_definition wu3_empty [llvm_code,llvm_inline] is "RETURN o wu2_empty"
      :: "[\<lambda>_. 4<LENGTH('vl)]\<^sub>a (snat_assn' TYPE('vl))\<^sup>k \<rightarrow> wu3_assn"
      unfolding wu2_empty_def wu3_assn_def
      apply (rewrite aal_fold_custom_empty)
      by sepref

    lemmas [sepref_fr_rules] = wu3_empty.refine[FCOMP wu2_empty_clen_refine]

    sepref_definition wu3_ins_edge [llvm_code,llvm_inline] is "uncurry2 wu2_ins_edge"
      :: "(V_assn \<times>\<^sub>a V_assn)\<^sup>k *\<^sub>a W_assn\<^sup>k *\<^sub>a wu3_assn\<^sup>d \<rightarrow>\<^sub>a wu3_assn"
      unfolding wu2_ins_edge_def wu3_assn_def
      by sepref

    lemmas [sepref_fr_rules] = wu3_ins_edge.refine[FCOMP wu2_ins_edge_clen_refine]

    sepref_definition wu3_max [llvm_code,llvm_inline] is "RETURN o wu2_max" :: "wu3_assn\<^sup>k \<rightarrow>\<^sub>a V_assn"
      unfolding wu2_max_def wu3_assn_def
      apply (rewrite op_list_list_len_def[symmetric]) (* TODO: list_list is a proper subtype of list. So share operations! *)
      by sepref
    lemmas [sepref_fr_rules] = wu3_max.refine[FCOMP wu2_max_clen_refine]

    sepref_definition wu3_adjs_len [llvm_code,llvm_inline] is "uncurry wu2_adjs_len"
      :: "V_assn\<^sup>k *\<^sub>a wu3_assn\<^sup>k \<rightarrow>\<^sub>a V_assn"
      unfolding wu2_adjs_len_def wu3_assn_def
      by sepref
    lemmas [sepref_fr_rules] = wu3_adjs_len.refine[FCOMP wu2_adjs_len_clen_refine]

    sepref_definition wu3_adjs_nth [llvm_code,llvm_inline] is "uncurry2 wu2_adjs_nth"
      :: "V_assn\<^sup>k *\<^sub>a V_assn\<^sup>k *\<^sub>a wu3_assn\<^sup>k \<rightarrow>\<^sub>a V_assn\<times>\<^sub>aW_assn"
      unfolding wu2_adjs_nth_def wu3_assn_def
      by sepref
    lemmas [sepref_fr_rules] = wu3_adjs_nth.refine[FCOMP wu2_adjs_nth_clen_refine]
  end
end

abbreviation wu_assn' :: "'vl::len2 itself \<Rightarrow> 'wl::len2 itself \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> ('vl,'wl) wu3 \<Rightarrow> assn"
  where "wu_assn' _ _ \<equiv> wu_assn"

lemma wu_assn_boundsD[sepref_bounds_dest]:
  "rdomp (wu_assn' TYPE('vl::len2) TYPE(_) N) g \<Longrightarrow> length g = N \<and> N < max_snat LENGTH('vl)"
  unfolding wu_assn_def wu3_assn_def wu_constrain_len_rel_def
  by sepref_bounds

end


section\<open>A poset of successions\<close>
theory Succession_Poset
  imports
    Arities Proper_Extension Synthetic_Definition
    Names
begin

subsection\<open>The set of finite binary sequences\<close>

text\<open>We implement the poset for adding one Cohen real, the set
$2^{<\omega}$ of of finite binary sequences.\<close>

definition
  seqspace :: "i \<Rightarrow> i" ("_^<\<omega>" [100]100) where
  "seqspace(B) \<equiv> \<Union>n\<in>nat. (n\<rightarrow>B)"

lemma seqspaceI[intro]: "n\<in>nat \<Longrightarrow> f:n\<rightarrow>B \<Longrightarrow> f\<in>seqspace(B)"
  unfolding seqspace_def by blast

lemma seqspaceD[dest]: "f\<in>seqspace(B) \<Longrightarrow> \<exists>n\<in>nat. f:n\<rightarrow>B"
  unfolding seqspace_def by blast

lemma seqspace_type:
  "f \<in> B^<\<omega> \<Longrightarrow> \<exists>n\<in>nat. f:n\<rightarrow>B"
  unfolding seqspace_def by auto

schematic_goal seqspace_fm_auto:
  assumes
    "nth(i,env) = n" "nth(j,env) = z"  "nth(h,env) = B"
    "i \<in> nat" "j \<in> nat" "h\<in>nat" "env \<in> list(A)"
  shows
    "(\<exists>om\<in>A. omega(##A,om) \<and> n \<in> om \<and> is_funspace(##A, n, B, z)) \<longleftrightarrow> (A, env \<Turnstile> (?sqsprp(i,j,h)))"
  unfolding is_funspace_def
  by (insert assms ; (rule sep_rules | simp)+)

synthesize "seqspace_rep_fm" from_schematic seqspace_fm_auto

locale M_seqspace =  M_trancl +
  assumes
    seqspace_replacement: "M(B) \<Longrightarrow> strong_replacement(M,\<lambda>n z. n\<in>nat \<and> is_funspace(M,n,B,z))"
begin

lemma seqspace_closed:
  "M(B) \<Longrightarrow> M(B^<\<omega>)"
  unfolding seqspace_def using seqspace_replacement[of B] RepFun_closed2
  by simp

end (* M_seqspace *)

sublocale M_ctm \<subseteq> M_seqspace "##M"
proof (unfold_locales, simp)
  fix B
  have "arity(seqspace_rep_fm(0,1,2)) \<le> 3" "seqspace_rep_fm(0,1,2)\<in>formula"
    unfolding seqspace_rep_fm_def
    using arity_pair_fm arity_omega_fm arity_typed_function_fm nat_simp_union
    by auto
  moreover
  assume "B\<in>M"
  ultimately
  have "strong_replacement(##M, \<lambda>x y. M, [x, y, B] \<Turnstile> seqspace_rep_fm(0, 1, 2))"
    using replacement_ax[of "seqspace_rep_fm(0,1,2)"]
    by simp
  moreover
  note \<open>B\<in>M\<close>
  moreover from this
  have "univalent(##M, A, \<lambda>x y. M, [x, y, B] \<Turnstile> seqspace_rep_fm(0, 1, 2))"
    if "A\<in>M" for A
    using that unfolding univalent_def seqspace_rep_fm_def
    by (auto, blast dest:transitivity)
  ultimately
  have "strong_replacement(##M, \<lambda>n z. \<exists>om[##M]. omega(##M,om) \<and> n \<in> om \<and> is_funspace(##M, n, B, z))"
    using seqspace_fm_auto[of 0 "[_,_,B]" _ 1 _ 2 B M] unfolding seqspace_rep_fm_def strong_replacement_def
    by simp
  with \<open>B\<in>M\<close>
  show "strong_replacement(##M, \<lambda>n z. n \<in> nat \<and> is_funspace(##M, n, B, z))"
    using M_nat by simp
qed

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^<\<omega>" "a\<in>A"
  shows "seq_upd(f,a) \<in> A^<\<omega>"
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^<\<omega>"
  unfolding seqspace_def
  by force

definition
  seqleR :: "i \<Rightarrow> i \<Rightarrow> o" where
  "seqleR(f,g) \<equiv> g \<subseteq> f"

definition
  seqlerel :: "i \<Rightarrow> i" where
  "seqlerel(A) \<equiv> Rrel(\<lambda>x y. y \<subseteq> x,A^<\<omega>)"

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

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

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

lemma upd_leI :
  assumes "f\<in>2^<\<omega>" "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^<\<omega> \<times> 2^<\<omega>"
    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^<\<omega>\<close>
    obtain n where  "n\<in>nat" "f : n \<rightarrow> 2"
      using seqspace_type 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^<\<omega>,seqle)"
  unfolding preorder_on_def refl_def trans_on_def by blast

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

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

abbreviation SEQle :: "[i, i] \<Rightarrow> o"  (infixl "\<preceq>s" 50)
  where "x \<preceq>s y \<equiv> Leq(x,y)"

abbreviation SEQIncompatible :: "[i, i] \<Rightarrow> o"  (infixl "\<bottom>s" 50)
  where "x \<bottom>s y \<equiv> Incompatible(x,y)"

lemma seqspace_separative:
  assumes "f\<in>2^<\<omega>"
  shows "seq_upd(f,0) \<bottom>s seq_upd(f,1)" (is "?f \<bottom>s ?g")
proof
  assume "compat(?f, ?g)"
  then
  obtain h where "h \<in> 2^<\<omega>" "?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^<\<omega>\<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 is_seqleR :: "[i\<Rightarrow>o,i,i] \<Rightarrow> o" where
  "is_seqleR(Q,f,g) \<equiv> g \<subseteq> f"

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

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

lemma arity_seqleR_fm :
  "fg \<in> nat \<Longrightarrow> arity(seqleR_fm(fg)) = succ(fg)"
  unfolding seqleR_fm_def
  using arity_pair_fm arity_subset_fm nat_simp_union by simp

lemma (in M_basic) seqleR_abs:
  assumes "M(f)" "M(g)"
  shows "seqleR(f,g) \<longleftrightarrow> is_seqleR(M,f,g)"
  unfolding seqleR_def is_seqleR_def
  using assms apply_abs domain_abs domain_closed[OF \<open>M(f)\<close>]  domain_closed[OF \<open>M(g)\<close>]
  by auto

definition
  relP :: "[i\<Rightarrow>o,[i\<Rightarrow>o,i,i]\<Rightarrow>o,i] \<Rightarrow> o" where
  "relP(M,r,xy) \<equiv> (\<exists>x[M]. \<exists>y[M]. pair(M,x,y,xy) \<and> r(M,x,y))"

lemma (in M_ctm) seqleR_fm_sats :
  assumes "fg\<in>nat" "env\<in>list(M)"
  shows "sats(M,seqleR_fm(fg),env) \<longleftrightarrow> relP(##M,is_seqleR,nth(fg, env))"
  unfolding seqleR_fm_def is_seqleR_def relP_def
  using assms trans_M sats_subset_fm pair_iff_sats
  by auto

lemma (in M_basic) is_related_abs :
  assumes "\<And> f g . M(f) \<Longrightarrow> M(g) \<Longrightarrow> rel(f,g) \<longleftrightarrow> is_rel(M,f,g)"
  shows "\<And>z . M(z) \<Longrightarrow> relP(M,is_rel,z) \<longleftrightarrow> (\<exists>x y. z = \<langle>x,y\<rangle> \<and> rel(x,y))"
  unfolding relP_def using pair_in_M_iff assms by auto

definition
  is_RRel :: "[i\<Rightarrow>o,[i\<Rightarrow>o,i,i]\<Rightarrow>o,i,i] \<Rightarrow> o" where
  "is_RRel(M,is_r,A,r) \<equiv> \<exists>A2[M]. cartprod(M,A,A,A2) \<and> is_Collect(M,A2, relP(M,is_r),r)"

lemma (in M_basic) is_Rrel_abs :
  assumes "M(A)"  "M(r)"
    "\<And> f g . M(f) \<Longrightarrow> M(g) \<Longrightarrow> rel(f,g) \<longleftrightarrow> is_rel(M,f,g)"
  shows "is_RRel(M,is_rel,A,r) \<longleftrightarrow>  r = Rrel(rel,A)"
proof -
  from \<open>M(A)\<close>
  have "M(z)" if "z\<in>A\<times>A" for z
    using cartprod_closed transM[of z "A\<times>A"] that by simp
  then
  have A:"relP(M, is_rel, z) \<longleftrightarrow> (\<exists>x y. z = \<langle>x, y\<rangle> \<and> rel(x, y))" "M(z)" if "z\<in>A\<times>A" for z
    using that is_related_abs[of rel is_rel,OF assms(3)] by auto
  then
  have "Collect(A\<times>A,relP(M,is_rel)) = Collect(A\<times>A,\<lambda>z. (\<exists>x y. z = \<langle>x,y\<rangle> \<and> rel(x,y)))"
    using Collect_cong[of "A\<times>A" "A\<times>A" "relP(M,is_rel)",OF _ A(1)] assms(1) assms(2)
    by auto
  with assms
  show ?thesis unfolding is_RRel_def Rrel_def using cartprod_closed
    by auto
qed

definition
  is_seqlerel :: "[i\<Rightarrow>o,i,i] \<Rightarrow> o" where
  "is_seqlerel(M,A,r) \<equiv> is_RRel(M,is_seqleR,A,r)"

lemma (in M_basic) seqlerel_abs :
  assumes "M(A)"  "M(r)"
  shows "is_seqlerel(M,A,r) \<longleftrightarrow> r = Rrel(seqleR,A)"
  unfolding is_seqlerel_def
  using is_Rrel_abs[OF \<open>M(A)\<close> \<open>M(r)\<close>,of seqleR is_seqleR] seqleR_abs
  by auto

definition RrelP :: "[i\<Rightarrow>i\<Rightarrow>o,i] \<Rightarrow> i" where
  "RrelP(R,A) \<equiv> {z\<in>A\<times>A. \<exists>x y. z = \<langle>x, y\<rangle> \<and> R(x,y)}"

lemma Rrel_eq : "RrelP(R,A) = Rrel(R,A)"
  unfolding Rrel_def RrelP_def by auto

context M_ctm
begin

lemma Rrel_closed:
  assumes "A\<in>M"
    "\<And> a. a \<in> nat \<Longrightarrow> rel_fm(a)\<in>formula"
    "\<And> f g . (##M)(f) \<Longrightarrow> (##M)(g) \<Longrightarrow> rel(f,g) \<longleftrightarrow> is_rel(##M,f,g)"
    "arity(rel_fm(0)) = 1"
    "\<And> a . a \<in> M \<Longrightarrow> sats(M,rel_fm(0),[a]) \<longleftrightarrow> relP(##M,is_rel,a)"
  shows "(##M)(Rrel(rel,A))"
proof -
  have "z\<in> M \<Longrightarrow> relP(##M, is_rel, z) \<longleftrightarrow> (\<exists>x y. z = \<langle>x, y\<rangle> \<and> rel(x, y))" for z
    using assms(3) is_related_abs[of rel is_rel]
    by auto
  with assms
  have "Collect(A\<times>A,\<lambda>z. (\<exists>x y. z = \<langle>x,y\<rangle> \<and> rel(x,y))) \<in> M"
    using Collect_in_M_0p[of "rel_fm(0)" "\<lambda> A z . relP(A,is_rel,z)" "\<lambda> z.\<exists>x y. z = \<langle>x, y\<rangle> \<and> rel(x, y)" ]
        cartprod_closed
    by simp
  then show ?thesis
  unfolding Rrel_def by simp
qed

lemma seqle_in_M: "seqle \<in> M"
  using Rrel_closed seqspace_closed
    transitivity[OF _ nat_in_M] type_seqleR_fm[of 0] arity_seqleR_fm[of 0]
    seqleR_fm_sats[of 0] seqleR_abs seqlerel_abs
  unfolding seqle_def seqlerel_def seqleR_def
  by auto

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

interpretation ctm_separative "2^<\<omega>" seqle 0
proof (unfold_locales)
  fix f
  let ?q="seq_upd(f,0)" and ?r="seq_upd(f,1)"
  assume "f \<in> 2^<\<omega>"
  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^<\<omega>"  "?r \<in> 2^<\<omega>"
    using seq_upd_type[of f 2] by auto
  ultimately
  show "\<exists>q\<in>2^<\<omega>. \<exists>r\<in>2^<\<omega>. 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^<\<omega> \<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> GenExt(G)"
  using proper_extension generic_filter_existence zero_in_seqspace
  by force

end (* M_ctm *)

end