(*
    Author:      Salomon Sickert
    License:     BSD
*)

section \<open>Logical Characterization Theorems\<close>

theory Logical_Characterization
  imports Main af "Auxiliary/Preliminaries2"
begin

subsection \<open>Eventually True G-Subformulae\<close>

fun \<G>\<^sub>F\<^sub>G :: "'a ltl \<Rightarrow> 'a set word \<Rightarrow> 'a ltl set"
where
  "\<G>\<^sub>F\<^sub>G true w = {}"
| "\<G>\<^sub>F\<^sub>G (false) w = {}"
| "\<G>\<^sub>F\<^sub>G (p(a)) w = {}"
| "\<G>\<^sub>F\<^sub>G (np(a)) w = {}"
| "\<G>\<^sub>F\<^sub>G (\<phi>\<^sub>1 and \<phi>\<^sub>2) w = \<G>\<^sub>F\<^sub>G \<phi>\<^sub>1 w \<union> \<G>\<^sub>F\<^sub>G \<phi>\<^sub>2 w"
| "\<G>\<^sub>F\<^sub>G (\<phi>\<^sub>1 or \<phi>\<^sub>2) w = \<G>\<^sub>F\<^sub>G \<phi>\<^sub>1 w \<union> \<G>\<^sub>F\<^sub>G \<phi>\<^sub>2 w"
| "\<G>\<^sub>F\<^sub>G (F \<phi>) w = \<G>\<^sub>F\<^sub>G \<phi> w"
| "\<G>\<^sub>F\<^sub>G (G \<phi>) w = (if w \<Turnstile> F G \<phi> then {G \<phi>} \<union> \<G>\<^sub>F\<^sub>G \<phi> w else \<G>\<^sub>F\<^sub>G \<phi> w)"
| "\<G>\<^sub>F\<^sub>G (X \<phi>) w = \<G>\<^sub>F\<^sub>G \<phi> w"
| "\<G>\<^sub>F\<^sub>G (\<phi> U \<psi>) w = \<G>\<^sub>F\<^sub>G \<phi> w \<union> \<G>\<^sub>F\<^sub>G \<psi> w"

lemma \<G>\<^sub>F\<^sub>G_alt_def:
  "\<G>\<^sub>F\<^sub>G \<phi> w = {G \<psi> | \<psi>. G \<psi> \<in> \<^bold>G \<phi> \<and> w \<Turnstile> F (G \<psi>)}"
  by (induction \<phi> arbitrary: w) (simp; blast)+

lemma \<G>\<^sub>F\<^sub>G_Only_G:
  "Only_G (\<G>\<^sub>F\<^sub>G \<phi> w)"
   by (induction \<phi>) auto

lemma \<G>\<^sub>F\<^sub>G_suffix[simp]:
  "\<G>\<^sub>F\<^sub>G \<phi> (suffix i w) = \<G>\<^sub>F\<^sub>G \<phi> w"
  unfolding \<G>\<^sub>F\<^sub>G_alt_def LTL_FG_suffix ..

subsection \<open>Eventually Provable and Almost All Eventually Provable\<close>

abbreviation \<PP>
where
  "\<PP> \<phi> \<G> w i \<equiv> \<exists>j. \<G> \<Turnstile>\<^sub>P af\<^sub>G \<phi> (w [i \<rightarrow> j])"

definition almost_all_eventually_provable :: "'a ltl \<Rightarrow> 'a ltl set \<Rightarrow> 'a set word \<Rightarrow> bool" ("\<PP>\<^sub>\<infinity>")
where
  "\<PP>\<^sub>\<infinity> \<phi> \<G> w \<equiv> \<forall>\<^sub>\<infinity>i. \<PP> \<phi> \<G> w i"

subsubsection \<open>Proof Rules\<close>

lemma almost_all_eventually_provable_monotonI[intro]:
  "\<PP>\<^sub>\<infinity> \<phi> \<G> w \<Longrightarrow> \<G> \<subseteq> \<G>' \<Longrightarrow> \<PP>\<^sub>\<infinity> \<phi> \<G>' w"
  unfolding almost_all_eventually_provable_def MOST_nat_le by blast

lemma almost_all_eventually_provable_restrict_to_G:
  "\<PP>\<^sub>\<infinity> \<phi> \<G> w \<Longrightarrow> Only_G \<G> \<Longrightarrow> \<PP>\<^sub>\<infinity> \<phi> (\<G> \<inter> \<^bold>G \<phi>) w"
proof -
  assume "Only_G \<G>" and "\<PP>\<^sub>\<infinity> \<phi> \<G> w"
  moreover
  hence "\<And>\<phi>. \<G> \<Turnstile>\<^sub>P \<phi> = (\<G> \<inter> \<^bold>G \<phi>) \<Turnstile>\<^sub>P \<phi>"
    using LTL_prop_entailment_restrict_to_propos propos_subset
    unfolding G_nested_propos_alt_def by blast
  ultimately
  show ?thesis
    unfolding almost_all_eventually_provable_def by force
qed

fun G_depth :: "'a ltl \<Rightarrow> nat"
where
  "G_depth (\<phi> and \<psi>) = max (G_depth \<phi>) (G_depth \<psi>)"
| "G_depth (\<phi> or \<psi>) = max (G_depth \<phi>) (G_depth \<psi>)"
| "G_depth (F \<phi>) = G_depth \<phi>"
| "G_depth (G \<phi>) = G_depth \<phi> + 1"
| "G_depth (X \<phi>) = G_depth \<phi>"
| "G_depth (\<phi> U \<psi>) = max (G_depth \<phi>) (G_depth \<psi>)"
| "G_depth \<phi> = 0"

lemma almost_all_eventually_provable_restrict_to_G_depth:
  assumes "\<PP>\<^sub>\<infinity> \<phi> \<G> w"
  assumes "Only_G \<G>"
  shows "\<PP>\<^sub>\<infinity> \<phi> (\<G> \<inter> {\<psi>. G_depth \<psi> \<le> G_depth \<phi>}) w"
proof -
  {
    fix \<phi>
    have "\<G> \<Turnstile>\<^sub>P \<phi> = (\<G> \<inter> {\<psi>. G_depth \<psi> \<le> G_depth \<phi>}) \<Turnstile>\<^sub>P \<phi>"
      by (induction \<phi>) (insert \<open>Only_G \<G>\<close>, auto)
  }
  note Unfold1 = this

  {
    fix w
    {
      fix \<phi> \<nu>
      have "{\<psi>. G_depth \<psi> \<le> G_depth (af_G_letter \<phi> \<nu>)} = {\<psi>. G_depth \<psi> \<le> G_depth \<phi>}"
        by (induction \<phi>) (unfold af_G_letter.simps G_depth.simps, simp_all, (metis le_max_iff_disj mem_Collect_eq)+)
    }
    hence "{\<psi>. G_depth \<psi> \<le> G_depth (af\<^sub>G \<phi> w)} = {\<psi>. G_depth \<psi> \<le> G_depth \<phi>}"
      by (induction w arbitrary: \<phi> rule: rev_induct) fastforce+
  }
  note Unfold2 = this

  from assms(1) show ?thesis
    unfolding almost_all_eventually_provable_def Unfold1 Unfold2 .
qed

lemma almost_all_eventually_provable_suffix:
  "\<PP>\<^sub>\<infinity> \<phi> \<G>' w \<Longrightarrow> \<PP>\<^sub>\<infinity> \<phi> \<G>' (suffix i w)"
  unfolding almost_all_eventually_provable_def MOST_nat_le
  by (metis Nat.add_0_right subsequence_shift subsequence_prefix_suffix suffix_0 add.assoc diff_zero trans_le_add2)

subsubsection \<open>Threshold\<close>

text \<open>The first index, such that the formula is eventually provable from this time on\<close>

fun threshold :: "'a ltl \<Rightarrow> 'a set  word \<Rightarrow> 'a ltl set \<Rightarrow> nat option"
where
  "threshold \<phi> w \<G> = index (\<lambda>j. \<PP> \<phi> \<G> w j)"

lemma threshold_properties:
  "threshold \<phi> w \<G> = Some i \<Longrightarrow> 0 < i \<Longrightarrow> \<not> \<G> \<Turnstile>\<^sub>P af\<^sub>G \<phi> (w [(i - 1) \<rightarrow> k])"
  "threshold \<phi> w \<G> = Some i \<Longrightarrow> j \<ge> i \<Longrightarrow> \<exists>k. \<G> \<Turnstile>\<^sub>P af\<^sub>G \<phi> (w [j \<rightarrow> k])"
  using index_properties unfolding threshold.simps by blast+

lemma threshold_suffix:
  assumes "threshold \<phi> w \<G> = Some k"
  assumes "threshold \<phi> (suffix i w) \<G> = Some k'"
  shows "k \<le> k' + i"
proof (rule ccontr)
  assume "\<not>k \<le> k' + i"
  hence "k > k' + i"
    by arith
  then obtain j where "k = k' + i + Suc j"
    by (metis Suc_diff_Suc le_Suc_eq le_add1 le_add_diff_inverse less_imp_Suc_add)
  hence "0 < k" and "k' + i + Suc j - 1 = i + (k' + j)"
    using \<open>k > k' + i\<close> by arith+
  show False
    using threshold_properties(1)[OF assms(1) \<open>0 < k\<close>] threshold_properties(2)[OF assms(2), of "k' + j", OF le_add1]
    unfolding subsequence_shift \<open>k = k' + i + Suc j\<close> \<open>k' + i + Suc j - 1 = i + (k' + j)\<close> by blast
qed

subsubsection \<open>Relation to LTL semantics\<close>

lemma ltl_implies_provable:
  "w \<Turnstile> \<phi> \<Longrightarrow> \<PP> \<phi> (\<G>\<^sub>F\<^sub>G \<phi> w) w 0"
proof (induction \<phi> arbitrary: w)
  case (LTLProp a)
    hence "{} \<Turnstile>\<^sub>P af\<^sub>G (p(a)) (w [0 \<rightarrow> 1])"
      by (simp add: subsequence_def)
    thus ?case
      by blast
next
  case (LTLPropNeg a)
    hence "{} \<Turnstile>\<^sub>P af\<^sub>G (np(a)) (w [0 \<rightarrow> 1])"
      by (simp add: subsequence_def)
    thus ?case
      by blast
next
  case (LTLAnd \<phi>\<^sub>1 \<phi>\<^sub>2)
    obtain i\<^sub>1 i\<^sub>2 where "(\<G>\<^sub>F\<^sub>G \<phi>\<^sub>1 w) \<Turnstile>\<^sub>P af\<^sub>G \<phi>\<^sub>1 (w [0 \<rightarrow> i\<^sub>1])" and "(\<G>\<^sub>F\<^sub>G \<phi>\<^sub>2 w) \<Turnstile>\<^sub>P af\<^sub>G \<phi>\<^sub>2 (w [0 \<rightarrow> i\<^sub>2])"
      using LTLAnd unfolding ltl_semantics.simps by blast
    have "(\<G>\<^sub>F\<^sub>G \<phi>\<^sub>1 w) \<Turnstile>\<^sub>P af\<^sub>G \<phi>\<^sub>1 (w [0 \<rightarrow> i\<^sub>1 + i\<^sub>2])" and "(\<G>\<^sub>F\<^sub>G \<phi>\<^sub>2 w) \<Turnstile>\<^sub>P af\<^sub>G \<phi>\<^sub>2 (w [0 \<rightarrow> i\<^sub>2 + i\<^sub>1])"
      using af\<^sub>G_sat_core_generalized[OF \<G>\<^sub>F\<^sub>G_Only_G _ \<open>(\<G>\<^sub>F\<^sub>G \<phi>\<^sub>1 w) \<Turnstile>\<^sub>P af\<^sub>G \<phi>\<^sub>1 (w [0 \<rightarrow> i\<^sub>1])\<close>]
      using af\<^sub>G_sat_core_generalized[OF \<G>\<^sub>F\<^sub>G_Only_G _ \<open>(\<G>\<^sub>F\<^sub>G \<phi>\<^sub>2 w) \<Turnstile>\<^sub>P af\<^sub>G \<phi>\<^sub>2 (w [0 \<rightarrow> i\<^sub>2])\<close>]
      by simp+
    thus ?case
      by (simp only: af\<^sub>G_decompose add.commute) auto
next
  case (LTLOr \<phi>\<^sub>1 \<phi>\<^sub>2)
    thus ?case
      unfolding af\<^sub>G_decompose by (cases "w \<Turnstile> \<phi>\<^sub>1") force+
next
  case (LTLNext \<phi>)
    obtain i where "(\<G>\<^sub>F\<^sub>G \<phi> w) \<Turnstile>\<^sub>P af\<^sub>G \<phi> (suffix 1 w [0 \<rightarrow> i])"
      using LTLNext(1)[OF LTLNext(2)[unfolded ltl_semantics.simps]]
      unfolding \<G>\<^sub>F\<^sub>G_suffix by blast
    hence "(\<G>\<^sub>F\<^sub>G (X \<phi>) w) \<Turnstile>\<^sub>P af\<^sub>G (X \<phi>) (w [0 \<rightarrow> 1 + i])"
      unfolding subsequence_shift subsequence_append by (simp add: subsequence_def)
    thus ?case
      by blast
next
  case (LTLFinal \<phi>)
    then obtain i where "suffix i w \<Turnstile> \<phi>"
      by auto
    then obtain j where "\<G>\<^sub>F\<^sub>G \<phi> w \<Turnstile>\<^sub>P af\<^sub>G \<phi> (suffix i w [0 \<rightarrow> j])"
      using LTLFinal \<G>\<^sub>F\<^sub>G_suffix by blast
    hence A: "\<G>\<^sub>F\<^sub>G \<phi> w \<Turnstile>\<^sub>P af\<^sub>G \<phi> (suffix i w [0 \<rightarrow> Suc j])"
      using af\<^sub>G_sat_core_generalized[OF \<G>\<^sub>F\<^sub>G_Only_G, of j "Suc j", OF le_SucI] by blast
    from af\<^sub>G_keeps_F_and_S[OF _ A] have "\<G>\<^sub>F\<^sub>G \<phi> w \<Turnstile>\<^sub>P af\<^sub>G (F \<phi>) (w [0 \<rightarrow> Suc (i + j)])"
      unfolding subsequence_shift subsequence_append Suc_eq_plus1 by simp
    thus ?case
      using \<G>\<^sub>F\<^sub>G.simps(7) by blast
next
  case (LTLUntil \<phi> \<psi>)
    then obtain k where "suffix k w \<Turnstile> \<psi>" and "\<forall>j < k. suffix j w \<Turnstile> \<phi>"
      by auto
    thus ?case
    proof (induction k arbitrary: w)
      case 0
        then obtain i where "\<G>\<^sub>F\<^sub>G \<psi> w \<Turnstile>\<^sub>P af\<^sub>G \<psi> (w [0 \<rightarrow> i])"
          using LTLUntil by (metis suffix_0)
        hence "\<G>\<^sub>F\<^sub>G \<psi> w \<Turnstile>\<^sub>P af\<^sub>G \<psi> (w [0 \<rightarrow> Suc i])"
          using af\<^sub>G_sat_core_generalized[OF \<G>\<^sub>F\<^sub>G_Only_G, of i "Suc i", OF  le_SucI] by auto
        hence "\<G>\<^sub>F\<^sub>G (\<phi> U \<psi>) w \<Turnstile>\<^sub>P af\<^sub>G (\<phi> U \<psi>) (w [0 \<rightarrow> Suc i])"
          unfolding af\<^sub>G_subsequence_U ltl_prop_entailment.simps \<G>\<^sub>F\<^sub>G.simps by blast
        thus ?case
          by blast
    next
      case (Suc k)
        hence "w \<Turnstile> \<phi>" and "suffix k (suffix 1 w) \<Turnstile> \<psi>" and "\<forall>j<k. suffix j (suffix 1 w) \<Turnstile> \<phi>"
          unfolding suffix_0 suffix_suffix by (auto, metis Suc_less_eq)+
        then obtain i where i_def: "\<G>\<^sub>F\<^sub>G (\<phi> U \<psi>) w \<Turnstile>\<^sub>P af\<^sub>G (\<phi> U \<psi>) (suffix 1 w [0 \<rightarrow> i])"
          using Suc(1)[of "suffix 1 w"] unfolding LTL_FG_suffix \<G>\<^sub>F\<^sub>G_alt_def by blast
        obtain j where j_def: "\<G>\<^sub>F\<^sub>G \<phi> w \<Turnstile>\<^sub>P af\<^sub>G \<phi> (w [0 \<rightarrow> j])"
          using LTLUntil(1)[OF \<open>w \<Turnstile> \<phi>\<close>] by auto
        hence "\<G>\<^sub>F\<^sub>G (\<phi> U \<psi>) w \<Turnstile>\<^sub>P af\<^sub>G \<phi> (w [0 \<rightarrow> j])"
          by auto

        hence "\<G>\<^sub>F\<^sub>G (\<phi> U \<psi>) w \<Turnstile>\<^sub>P af\<^sub>G \<phi> (w [0 \<rightarrow> j + (i + 1)])"
          by (blast intro: af\<^sub>G_sat_core_generalized[OF \<G>\<^sub>F\<^sub>G_Only_G le_add1])
        moreover
        have "1 + (i + j) = j + (i + 1)"
          by arith
        have "\<G>\<^sub>F\<^sub>G (\<phi> U \<psi>) w \<Turnstile>\<^sub>P af\<^sub>G (\<phi> U \<psi>) (w [1 \<rightarrow> j + (i + 1)])"
          using af\<^sub>G_sat_core_generalized[OF \<G>\<^sub>F\<^sub>G_Only_G le_add1 i_def, of j]
          unfolding subsequence_shift \<G>\<^sub>F\<^sub>G_suffix \<open>1 + (i + j) = j + (i + 1)\<close> by simp
        ultimately
        have "\<G>\<^sub>F\<^sub>G (\<phi> U \<psi>) w \<Turnstile>\<^sub>P af\<^sub>G (\<phi> U \<psi>) (w [1 \<rightarrow> Suc (j + i)]) and af\<^sub>G \<phi> (w [0 \<rightarrow> Suc (j + i)])"
          by simp
        hence "\<G>\<^sub>F\<^sub>G (\<phi> U \<psi>) w \<Turnstile>\<^sub>P af\<^sub>G (\<phi> U \<psi>) (w [0 \<rightarrow> Suc (j + i)])"
          unfolding af\<^sub>G_subsequence_U ltl_prop_entailment.simps by blast
        thus ?case
          using af\<^sub>G_subsequence_U ltl_prop_entailment.simps by blast
    qed
qed simp+

lemma ltl_implies_provable_almost_all:
  "w \<Turnstile> \<phi> \<Longrightarrow> \<forall>\<^sub>\<infinity>i. \<G>\<^sub>F\<^sub>G \<phi> w \<Turnstile>\<^sub>P af\<^sub>G \<phi> (w [0 \<rightarrow> i])"
  using ltl_implies_provable af\<^sub>G_sat_core_generalized[OF \<G>\<^sub>F\<^sub>G_Only_G]
  unfolding MOST_nat_le by metis

subsubsection \<open>Closed Sets\<close>

abbreviation closed
where
  "closed \<G> w \<equiv> finite \<G> \<and> Only_G \<G> \<and> (\<forall>\<psi>. G \<psi> \<in> \<G> \<longrightarrow> \<PP>\<^sub>\<infinity> \<psi> \<G> w)"

lemma closed_FG:
  assumes "closed \<G> w"
  assumes "G \<psi> \<in> \<G>"
  shows "w \<Turnstile> F G \<psi>"
proof -
  have "finite \<G>" and "Only_G \<G>" and "(\<And>\<psi>. G \<psi> \<in> \<G> \<Longrightarrow> \<PP>\<^sub>\<infinity> \<psi> \<G> w)"
    using assms by simp+
  moreover
  note \<open>G \<psi> \<in> \<G>\<close>
  ultimately
  show "w \<Turnstile> F G \<psi>"
  proof (induction arbitrary: \<psi> rule: finite_ranking_induct[where f = G_depth])
    case (insert x \<G>)
      (* Split \<psi>' out *)
      then obtain \<psi>' where "x = G \<psi>'"
        by auto
      {
        fix \<psi> assume "G \<psi> \<in> insert x \<G>" (is "_ \<in> ?\<G>'")
        hence "\<PP>\<^sub>\<infinity> \<psi> (?\<G>' \<inter> {\<psi>'. G_depth \<psi>' \<le> G_depth \<psi>}) w"
          using insert(4-5) by (blast dest: almost_all_eventually_provable_restrict_to_G_depth)
        moreover
        have "G_depth \<psi> < G_depth x"
          using insert(2) \<open>G \<psi> \<in> insert x \<G>\<close> \<open>x = G \<psi>'\<close> by force
        ultimately
        have "\<PP>\<^sub>\<infinity> \<psi> \<G> w"
          by auto
      }
      hence "\<PP>\<^sub>\<infinity> \<psi>' \<G> w" and "closed \<G> w"
        using insert \<open>x = G \<psi>'\<close> by simp+

      (* Wait until all G-subformulae are "stable" *)
      have "Only_G \<G>" and "Only_G (\<G> \<union> \<^bold>G \<psi>')" and "finite (\<G> \<union> \<^bold>G \<psi>')"
        using G_nested_finite G_nested_propos_Only_G insert by blast+
      then obtain k\<^sub>1 where k1_def: "\<And>\<psi> i. \<psi> \<in> \<G> \<union> \<^bold>G \<psi>' \<Longrightarrow> suffix k\<^sub>1 w \<Turnstile> \<psi> = suffix (k\<^sub>1 + i) w \<Turnstile> \<psi>"
        by (blast intro: ltl_G_stabilize)

      (* Wait until the formula is provable for all suffixes *)
      hence "\<And>\<psi>. G \<psi> \<in> \<G> \<Longrightarrow> w \<Turnstile> F (G \<psi>)"
        using insert \<open>closed \<G> w\<close> by simp
      then obtain k\<^sub>2 where k2_def: "\<forall>i \<ge> k\<^sub>2. \<exists>j. \<PP> \<psi>' \<G> w i"
        using \<open>\<PP>\<^sub>\<infinity> \<psi>' \<G> w\<close> unfolding almost_all_eventually_provable_def MOST_nat_le by blast

      {
        fix i
        assume "i \<ge> max k\<^sub>1 k\<^sub>2"
        hence "i \<ge> k\<^sub>1" and "i \<ge> k\<^sub>2"
          by simp+
        then obtain j' where "\<G> \<Turnstile>\<^sub>P af\<^sub>G \<psi>' (w [i \<rightarrow> j'])"
          using k2_def by blast
        then obtain j where "\<G> \<Turnstile>\<^sub>P af\<^sub>G \<psi>' (w [i \<rightarrow> i + j])"
          by (cases "i \<le> j'") (blast dest: le_Suc_ex, metis subsequence_empty le_add_diff_inverse nat_le_linear)
        moreover
        have "\<And>\<psi>. G \<psi> \<in> \<G>  \<Longrightarrow> suffix k\<^sub>1 w \<Turnstile> G \<psi>"
          using ltl_G_stabilize_property[OF \<open>finite (\<G> \<union> \<^bold>G \<psi>')\<close> \<open>Only_G (\<G> \<union> \<^bold>G \<psi>')\<close> k1_def]
          using \<open>\<And>\<psi>. G \<psi> \<in> \<G> \<Longrightarrow> w \<Turnstile> F (G \<psi>)\<close> by blast
        hence "\<And>\<psi>. G \<psi> \<in> \<G> \<Longrightarrow> suffix (i + j) w \<Turnstile> G \<psi>"
          by (metis \<open>i \<ge> max k\<^sub>1 k\<^sub>2\<close> LTL_suffix_G suffix_suffix le_Suc_ex max.cobounded1)
        hence "\<And>\<psi>. \<psi> \<in> \<G> \<Longrightarrow> suffix (i + j) w \<Turnstile> \<psi>"
          using \<open>Only_G \<G>\<close> by fast
        ultimately
        have Suffix: "suffix (i + j) w \<Turnstile> af\<^sub>G \<psi>' (w [i \<rightarrow> i + j])"
          using ltl_models_equiv_prop_entailment by blast

        obtain c where "i = k\<^sub>1 + c"
          using \<open>i \<ge> k\<^sub>1\<close> unfolding le_iff_add by blast
        hence Stable: "\<forall>\<psi> \<in> \<^bold>G \<psi>'. suffix i w \<Turnstile> \<psi> = suffix j (suffix i w) \<Turnstile> \<psi>"
          using k1_def k1_def[of _ "c + j"] unfolding suffix_suffix add.assoc[symmetric] by blast
        from Suffix have "suffix i w \<Turnstile> \<psi>'"
          unfolding suffix_suffix subsequence_shift af\<^sub>G_ltl_continuation_suffix[OF Stable] by simp
      }
      hence "w \<Turnstile> F G \<psi>'"
        unfolding MOST_nat_le LTL_FG_almost_all_suffixes by blast
      thus ?case
        using insert using \<open>\<And>\<psi>. G \<psi> \<in> \<G> \<Longrightarrow> w \<Turnstile> F G \<psi>\<close> \<open>x = G \<psi>'\<close> by auto
  qed blast
qed

lemma closed_\<G>\<^sub>F\<^sub>G:
  "closed (\<G>\<^sub>F\<^sub>G \<phi> w) w"
proof (induction \<phi>)
  case (LTLGlobal \<phi>)
    thus ?case
    proof (cases "w \<Turnstile> F G \<phi>")
      case True
        hence "\<forall>\<^sub>\<infinity>i. suffix i w \<Turnstile> \<phi>"
          using LTL_FG_almost_all_suffixes by blast
        then obtain i where "\<forall>j \<ge> i. suffix j w \<Turnstile> \<phi>"
          unfolding MOST_nat_le by blast
        {
          fix k
          assume "k \<ge> i"
          hence "suffix k w \<Turnstile> \<phi>"
            using \<open>\<forall>j\<ge>i. suffix j w \<Turnstile> \<phi>\<close> by blast
          hence "\<PP> \<phi> {G \<psi> |\<psi>. w \<Turnstile> F G \<psi>} (suffix k w) 0"
            using LTL_FG_suffix
            by (blast dest: ltl_implies_provable[unfolded \<G>\<^sub>F\<^sub>G_alt_def])
          hence "\<PP> \<phi> {G \<psi> |\<psi>. w \<Turnstile> F G \<psi>} w k"
            unfolding subsequence_shift by auto
        }
        hence "\<PP>\<^sub>\<infinity> \<phi> {G \<psi> | \<psi>. w \<Turnstile> F G \<psi>} w"
          using almost_all_eventually_provable_def[of \<phi> _ w]
          unfolding MOST_nat_le by auto
        hence "\<PP>\<^sub>\<infinity> \<phi> (\<G>\<^sub>F\<^sub>G \<phi> w) w"
          unfolding \<G>\<^sub>F\<^sub>G_alt_def
          using almost_all_eventually_provable_restrict_to_G by blast
        thus ?thesis
          using LTLGlobal insert by auto
    qed auto
qed auto

subsubsection \<open>Conjunction of Eventually Provable Formulas\<close>

definition \<F>
where
  "\<F> \<phi> w \<G> j = And (map (\<lambda>i. af\<^sub>G \<phi> (w [i \<rightarrow> j])) [the (threshold \<phi> w \<G>) ..< Suc j])"

lemma almost_all_suffixes_model_\<F>:
  assumes "closed \<G> w"
  assumes "G \<phi> \<in> \<G>"
  shows "\<forall>\<^sub>\<infinity>j. suffix j w \<Turnstile> eval\<^sub>G \<G> (\<F> \<phi> w \<G> j)"
proof -
  have "Only_G \<G>"
    using assms(1) by simp
  hence "\<G> \<subseteq> {\<chi>. w \<Turnstile> F \<chi>}" and "\<PP>\<^sub>\<infinity> \<phi> \<G> w"
    using closed_FG[OF assms(1)] assms by auto
  then obtain k where "threshold \<phi> w \<G> = Some k"
    by (simp add: almost_all_eventually_provable_def)
  hence k_def: "k = the (threshold \<phi> w \<G>)"
    by simp
  moreover
  have "finite (\<^bold>G \<phi> \<union> \<G>)" and "Only_G (\<^bold>G \<phi> \<union> \<G>)"
    using assms(1) G_nested_finite unfolding G_nested_propos_alt_def by auto
  then obtain l where S: "\<And>j \<psi>. \<psi> \<in> \<^bold>G \<phi> \<union> \<G> \<Longrightarrow> suffix l w \<Turnstile> \<psi> = suffix (l + j) w \<Turnstile> \<psi>"
    using ltl_G_stabilize by metis
  hence \<G>_sat:"\<And>j \<psi>. G \<psi> \<in> \<G> \<Longrightarrow> suffix (l + j) w \<Turnstile> G \<psi>"
    using ltl_G_stabilize_property \<open>\<G> \<subseteq> {\<chi>. w \<Turnstile> F \<chi>}\<close> by blast
  {
    fix j
    assume "l \<le> j"
    {
      fix i
      assume "k \<le> i" "i \<le> j"
      then obtain j' where "j = i + j'"
        by (blast dest: le_Suc_ex)
      hence "\<exists>j \<ge> i. \<G> \<Turnstile>\<^sub>P af\<^sub>G \<phi> (w [i \<rightarrow> j])"
        using \<open>\<PP>\<^sub>\<infinity> \<phi> \<G> w\<close> unfolding almost_all_eventually_provable_def MOST_nat_le
        by (metis \<open>k \<le> i\<close> \<open>threshold \<phi> w \<G> = Some k\<close> threshold_properties(2) linear subsequence_empty)
      then obtain j'' where "\<G> \<Turnstile>\<^sub>P af\<^sub>G \<phi> (w [i \<rightarrow> j''])" and "i \<le> j''"
        by (blast )
      have "suffix j w \<Turnstile> eval\<^sub>G \<G> (af\<^sub>G \<phi> (w [i \<rightarrow> j]))"
      proof (cases "j'' \<le> j")
        case True
          hence "\<G> \<Turnstile>\<^sub>P af\<^sub>G \<phi> (w [i \<rightarrow> j])"
            using af\<^sub>G_sat_core_generalized[OF \<open>Only_G \<G>\<close>, of _ j' \<phi> "suffix i w"] le_Suc_ex[OF \<open>i \<le> j''\<close>] le_Suc_ex[OF \<open>j'' \<le> j\<close>]
            by (metis add.right_neutral subsequence_shift \<open>j = i + j'\<close> \<open>\<G> \<Turnstile>\<^sub>P af\<^sub>G \<phi> (w [i \<rightarrow> j''])\<close> nat_add_left_cancel_le )
          hence "\<G> \<Turnstile>\<^sub>P eval\<^sub>G \<G> (af\<^sub>G \<phi> (w [i \<rightarrow> j]))"
            unfolding eval\<^sub>G_prop_entailment .
          moreover
          have "\<G> \<subseteq> {\<chi>. suffix j w \<Turnstile> \<chi>}"
            using \<G>_sat \<open>l \<le> j\<close> \<open>Only_G \<G>\<close> by (fast dest: le_Suc_ex)
          ultimately
          have "{\<chi>. suffix j w \<Turnstile> \<chi>} \<Turnstile>\<^sub>P eval\<^sub>G \<G> (af\<^sub>G \<phi> (w [i \<rightarrow> j]))"
            by blast
          thus ?thesis
            unfolding ltl_models_equiv_prop_entailment[symmetric] by simp
      next
        case False
          hence "\<G> \<Turnstile>\<^sub>P eval\<^sub>G \<G> (af\<^sub>G (af\<^sub>G \<phi> (w [i \<rightarrow> j])) (w [j \<rightarrow> j'']))"
            unfolding foldl_append[symmetric] eval\<^sub>G_prop_entailment
            by (metis le_iff_add \<open>i \<le> j\<close> map_append upt_add_eq_append nat_le_linear subsequence_def \<open>\<G> \<Turnstile>\<^sub>P af\<^sub>G \<phi> (w [i \<rightarrow> j''])\<close>)
          hence "\<G> \<Turnstile>\<^sub>P af\<^sub>G (eval\<^sub>G \<G> (af\<^sub>G \<phi> (w [i \<rightarrow> j]))) (w [j \<rightarrow> j''])" (is "\<G> \<Turnstile>\<^sub>P ?af\<^sub>G")
            using af\<^sub>G_eval\<^sub>G[OF \<open>Only_G \<G>\<close>] by blast
          moreover
          have "l \<le> j''"
            using False \<open>l \<le> j\<close> by linarith
          hence "\<G> \<subseteq> {\<chi>. suffix j'' w \<Turnstile> \<chi>}"
            using \<G>_sat \<open>Only_G \<G>\<close> by (fast dest: le_Suc_ex)
          ultimately
          have "suffix j'' w \<Turnstile> ?af\<^sub>G"
            using ltl_models_equiv_prop_entailment[symmetric] by blast
          moreover
          {
            have "\<And>\<psi>. \<psi> \<in> \<^bold>G \<phi> \<union> \<G> \<Longrightarrow> suffix j w \<Turnstile> \<psi> = suffix j'' w \<Turnstile> \<psi>"
              using S \<open>l \<le> j\<close> \<open>l \<le> j''\<close> by (metis le_add_diff_inverse)
            moreover
            have "\<^bold>G (eval\<^sub>G \<G> (af\<^sub>G \<phi> (w [i \<rightarrow> j]))) \<subseteq> \<^bold>G \<phi>" (is "?G \<subseteq> _")
              using eval\<^sub>G_G_nested by force
            ultimately
            have "\<And>\<psi>. \<psi> \<in> ?G \<Longrightarrow> suffix j w \<Turnstile> \<psi> = suffix j'' w \<Turnstile> \<psi>"
              by auto
          }
          ultimately
          show ?thesis
            using af\<^sub>G_ltl_continuation_suffix[of "eval\<^sub>G \<G> (af\<^sub>G \<phi> (w [i \<rightarrow> j]))" "suffix j w", unfolded suffix_suffix]
            by (metis False le_Suc_ex nat_le_linear add_diff_cancel_left' subsequence_prefix_suffix)
      qed
    }
    hence "suffix j w \<Turnstile> And (map (\<lambda>i. eval\<^sub>G \<G> (af\<^sub>G \<phi> (w [i \<rightarrow> j]))) [k..<Suc j])"
      unfolding And_semantics set_map set_upt image_def by force
    hence "suffix j w \<Turnstile> eval\<^sub>G \<G> (And (map (\<lambda>i. af\<^sub>G \<phi> (w [i \<rightarrow> j])) [k..<Suc j]))"
      unfolding eval\<^sub>G_And_map map_map comp_def .
  }
  thus ?thesis
    unfolding \<F>_def And_semantics MOST_nat_le k_def[symmetric] by meson
qed

lemma almost_all_commutative'':
  assumes "finite S"
  assumes "Only_G S"
  assumes "\<And>x. G x \<in> S \<Longrightarrow> \<forall>\<^sub>\<infinity>i. P x (i::nat)"
  shows "\<forall>\<^sub>\<infinity>i. \<forall>x. G x \<in> S \<longrightarrow> P x i"
proof -
  from assms have "(\<And>x. x \<in> S \<Longrightarrow> \<forall>\<^sub>\<infinity>i. P (theG x) (i::nat))"
    by fastforce
  with assms(1) have "\<forall>\<^sub>\<infinity>i. \<forall>x \<in> S. P (theG x) i"
    using almost_all_commutative' by force
  thus ?thesis
    using assms(2) unfolding MOST_nat_le by force
qed

lemma almost_all_suffixes_model_\<F>_generalized:
  assumes "closed \<G> w"
  shows "\<forall>\<^sub>\<infinity>j. \<forall>\<psi>. G \<psi> \<in> \<G> \<longrightarrow> suffix j w \<Turnstile> eval\<^sub>G \<G> (\<F> \<psi> w \<G> j)"
  using almost_all_suffixes_model_\<F>[OF assms] almost_all_commutative''[of \<G>] assms by fast

subsection \<open>Technical Lemmas\<close>

lemma threshold_suffix_2:
  assumes "threshold \<psi> w \<G>' = Some k"
  assumes "k \<le> l"
  shows "threshold \<psi> (suffix l w) \<G>' = Some 0"
proof -
  have "\<PP>\<^sub>\<infinity> \<psi> \<G>' w"
    using \<open>threshold \<psi> w \<G>' = Some k\<close>  option.distinct(1)
    unfolding threshold.simps index.simps almost_all_eventually_provable_def by metis
  hence "\<PP>\<^sub>\<infinity> \<psi> \<G>' (suffix l w)"
    using almost_all_eventually_provable_suffix by blast
  moreover
  have "\<forall>i \<ge> k. \<exists>j. \<G>' \<Turnstile>\<^sub>P af\<^sub>G \<psi> (w [i \<rightarrow> j])"
    using threshold_properties(2)[OF assms(1)] by blast
  hence "\<forall>m. \<exists>j. \<G>' \<Turnstile>\<^sub>P af\<^sub>G \<psi> ((suffix l w) [m \<rightarrow> j])"
    unfolding subsequence_shift using \<open>k \<le> l\<close> \<open>\<forall>i \<ge> k. \<exists>j. \<G>' \<Turnstile>\<^sub>P af\<^sub>G \<psi> (w [i \<rightarrow> j])\<close>
    by (metis (mono_tags, hide_lams) leI less_imp_add_positive order_refl subsequence_empty trans_le_add1)
  ultimately
  show ?thesis
    by simp
qed

lemma threshold_closed:
  assumes "closed \<G> w"
  shows "\<exists>k. \<forall>\<psi>. G \<psi> \<in> \<G> \<longrightarrow> threshold \<psi> (suffix k w) \<G> = Some 0"
proof -
  define k where "k = Max {the (threshold \<psi> w \<G>) | \<psi>. G \<psi> \<in> \<G>}" (is "_ = Max ?S")

  have "finite \<G>" and "Only_G \<G>" and "\<And>\<psi>. G \<psi> \<in> \<G> \<Longrightarrow> \<PP>\<^sub>\<infinity> \<psi> \<G> w"
    using assms by blast+
  hence "\<And>\<psi>. G \<psi> \<in> \<G> \<Longrightarrow> \<exists>k. threshold \<psi> w \<G> = Some k"
    unfolding almost_all_eventually_provable_def by simp
  moreover
  have "?S = (\<lambda>x. the (threshold (theG x) w \<G>)) ` \<G>"
    unfolding image_def using \<open>Only_G \<G>\<close> ltl.sel(8) by metis
  hence "finite ?S"
    using \<open>finite \<G>\<close> finite_imageI by simp
  hence "\<And>\<psi> k'. G \<psi> \<in> \<G> \<Longrightarrow> threshold \<psi> w \<G> = Some k' \<Longrightarrow> k' \<le> k"
    by (metis (mono_tags, lifting) CollectI Max_ge k_def option.sel)
  ultimately
  have "\<And>\<psi>. G \<psi> \<in> \<G> \<Longrightarrow> threshold \<psi> (suffix k w) \<G> = Some 0"
    using threshold_suffix[of _ w \<G> _ k 0] threshold_suffix_2 by blast
  thus ?thesis
    by blast
qed

lemma \<F>_drop:
  assumes "\<PP>\<^sub>\<infinity> \<phi> \<G>' w"
  assumes "S \<Turnstile>\<^sub>P \<F> \<phi> w \<G>' (i + j)"
  shows "S \<Turnstile>\<^sub>P \<F> \<phi> (suffix i w) \<G>' j"
proof -
  obtain k k' where k_def: "threshold \<phi> w \<G>' = Some k" and k'_def: "threshold \<phi> (suffix i w) \<G>' = Some k'"
    using assms almost_all_eventually_provable_suffix
    unfolding threshold.simps index.simps almost_all_eventually_provable_def by fastforce
  hence k_def_2: "the (threshold \<phi> w \<G>') = k" and k'_def_2: "the (threshold \<phi> (suffix i w) \<G>') = k'"
    by simp+
  moreover
  hence "k \<le> i + j \<Longrightarrow> S \<Turnstile>\<^sub>P \<phi>"
    using \<open>S \<Turnstile>\<^sub>P \<F> \<phi> w \<G>' (i + j)\<close> unfolding \<F>_def And_semantics And_prop_entailment by (simp add: subsequence_def)
  moreover
  have "k' \<le> j \<Longrightarrow> k \<le> i + j"
    using k_def k'_def threshold_suffix by fastforce
  ultimately
  have "the (threshold \<phi> (suffix i w) \<G>') \<le> j \<Longrightarrow> S \<Turnstile>\<^sub>P \<phi>"
    by blast
  moreover
  {
    fix pos
    assume "k' \<le> pos" and "pos \<le> j"
    have "k \<le> i + pos"
      by (metis threshold_suffix k_def k'_def \<open>k' \<le> pos\<close> add.commute add_le_cancel_right order.trans)
    hence "(i + pos) \<in> set [k..<Suc (i + j)]"
      using \<open>pos \<le> j\<close> by auto
    hence "af\<^sub>G \<phi> ((suffix i w) [pos \<rightarrow> j]) \<in> set (map (\<lambda>ia. af\<^sub>G \<phi> (subsequence w ia (i + j))) [k..<Suc (i + j)])"
      unfolding subsequence_shift set_map by blast
    hence "S \<Turnstile>\<^sub>P af\<^sub>G \<phi> ((suffix i w) [pos \<rightarrow> j])"
      using assms(2) unfolding \<F>_def And_prop_entailment k_def_2 by (cases "k \<le> i + j") auto
  }
  ultimately
  show ?thesis
     unfolding \<F>_def And_prop_entailment k'_def_2 by auto
qed

subsection \<open>Main Results\<close>

definition accept\<^sub>M
where
  "accept\<^sub>M \<phi> \<G> w \<equiv> (\<forall>\<^sub>\<infinity>j. \<forall>S. (\<forall>\<psi>. G \<psi> \<in> \<G> \<longrightarrow> S \<Turnstile>\<^sub>P G \<psi> \<and> S \<Turnstile>\<^sub>P eval\<^sub>G \<G> (\<F> \<psi> w \<G> j)) \<longrightarrow> S \<Turnstile>\<^sub>P af \<phi> (w [0 \<rightarrow> j]))"

lemma lemmaD:
  assumes "w \<Turnstile> \<phi>"
  assumes "\<And>\<psi>. G \<psi> \<in> \<G>\<^sub>F\<^sub>G \<phi> w \<Longrightarrow> threshold \<psi> w (\<G>\<^sub>F\<^sub>G \<phi> w) = Some 0"
  shows "accept\<^sub>M \<phi> (\<G>\<^sub>F\<^sub>G \<phi> w) w"
proof -
  obtain i where "\<G>\<^sub>F\<^sub>G \<phi> w \<Turnstile>\<^sub>P af\<^sub>G \<phi> (w [0 \<rightarrow> i])"
    using ltl_implies_provable[OF \<open>w \<Turnstile> \<phi>\<close>] by metis
  {
    fix S j
    assume assm1: "j \<ge> i"
    assume assm2: "\<And>\<psi>. G \<psi> \<in> \<G>\<^sub>F\<^sub>G \<phi> w \<Longrightarrow> S \<Turnstile>\<^sub>P G \<psi> \<and> S \<Turnstile>\<^sub>P eval\<^sub>G (\<G>\<^sub>F\<^sub>G \<phi> w) (\<F> \<psi> w (\<G>\<^sub>F\<^sub>G \<phi> w) j)"
    moreover
    {
      have "\<G>\<^sub>F\<^sub>G \<phi> w \<Turnstile>\<^sub>P af\<^sub>G \<phi> (w [0 \<rightarrow> j])"
        using \<open>\<G>\<^sub>F\<^sub>G \<phi> w \<Turnstile>\<^sub>P af\<^sub>G \<phi> (w [0 \<rightarrow> i])\<close> \<open>j \<ge> i\<close>
        by (metis af\<^sub>G_sat_core_generalized \<G>\<^sub>F\<^sub>G_Only_G)
      moreover
      have "\<G>\<^sub>F\<^sub>G \<phi> w \<subseteq> S"
        using assm2 unfolding \<G>\<^sub>F\<^sub>G_alt_def by auto
      ultimately
      have "S \<Turnstile>\<^sub>P eval\<^sub>G (\<G>\<^sub>F\<^sub>G \<phi> w) (af\<^sub>G \<phi> (w [0 \<rightarrow> j]))"
        using eval\<^sub>G_prop_entailment by blast
    }
    moreover
    {
      fix \<psi> assume "G \<psi> \<in> \<G>\<^sub>F\<^sub>G \<phi> w"
      hence "the (threshold \<psi> w (\<G>\<^sub>F\<^sub>G \<phi> w)) = 0" and "S \<Turnstile>\<^sub>P eval\<^sub>G (\<G>\<^sub>F\<^sub>G \<phi> w) (\<F> \<psi> w (\<G>\<^sub>F\<^sub>G \<phi> w) j)"
        using assms assm2 option.sel by metis+
      hence "\<And>i. i \<le> j \<Longrightarrow> S \<Turnstile>\<^sub>P eval\<^sub>G (\<G>\<^sub>F\<^sub>G \<phi> w) (af\<^sub>G \<psi> (w[i \<rightarrow> j]))"
        unfolding \<F>_def And_prop_entailment eval\<^sub>G_And_map by auto
    }
    ultimately
    have "S \<Turnstile>\<^sub>P af \<phi> (w [0 \<rightarrow> j])"
      using af\<^sub>G_implies_af_eval\<^sub>G[of _ _ \<phi>] by presburger
  }
  thus ?thesis
     unfolding accept\<^sub>M_def MOST_nat_le by meson
qed

theorem ltl_FG_logical_characterization:
  "w \<Turnstile> F G \<phi> \<longleftrightarrow> (\<exists>\<G> \<subseteq> \<^bold>G (F G \<phi>). G \<phi> \<in> \<G> \<and> closed \<G> w)"
  (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?lhs
  hence "G \<phi> \<in> \<G>\<^sub>F\<^sub>G (F G \<phi>) w" and "\<G>\<^sub>F\<^sub>G (F G \<phi>) w \<subseteq> \<^bold>G (F G \<phi>)"
    unfolding \<G>\<^sub>F\<^sub>G_alt_def by auto
  thus ?rhs
    using closed_\<G>\<^sub>F\<^sub>G by metis
qed (blast intro: closed_FG)

theorem ltl_logical_characterization:
  "w \<Turnstile> \<phi> \<longleftrightarrow> (\<exists>\<G> \<subseteq> \<^bold>G \<phi>. accept\<^sub>M \<phi> \<G> w \<and> closed \<G> w)"
  (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?lhs

  obtain k where k_def: "\<And>\<psi>. G \<psi> \<in> \<G>\<^sub>F\<^sub>G \<phi> w \<Longrightarrow> threshold \<psi> (suffix k w) (\<G>\<^sub>F\<^sub>G \<phi> w) = Some 0"
    using threshold_closed[OF closed_\<G>\<^sub>F\<^sub>G] by blast

  (* Define new constants *)
  define w' where "w' = suffix k w"
  define \<phi>' where "\<phi>' = af \<phi> (w[0 \<rightarrow> k])"

  (* Facts about w' and \<phi>' *)
  from \<open>?lhs\<close> have "w' \<Turnstile> \<phi>'"
    unfolding af_ltl_continuation_suffix[of w \<phi> k] w'_def \<phi>'_def .
  have G_eq: "\<^bold>G \<phi>' = \<^bold>G \<phi>"
    unfolding \<phi>'_def G_af_simp ..
  have \<G>_eq: "\<G>\<^sub>F\<^sub>G \<phi>' w' = \<G>\<^sub>F\<^sub>G \<phi> w"
    unfolding \<G>\<^sub>F\<^sub>G_alt_def w'_def \<phi>'_def G_af_simp LTL_FG_suffix ..
  have \<phi>'_eq: "\<And>j. af \<phi>' (w' [0 \<rightarrow>j]) = af \<phi> (w [0 \<rightarrow> k + j])"
    unfolding \<phi>'_def w'_def foldl_append[symmetric] subsequence_shift
    unfolding Nat.add_0_right by (metis subsequence_append)

  (* Apply helper lemma *)
  have "accept\<^sub>M \<phi>' (\<G>\<^sub>F\<^sub>G \<phi>' w') w'"
    using lemmaD[OF \<open>w' \<Turnstile> \<phi>'\<close>] k_def
    unfolding \<G>_eq w'_def[symmetric] by blast

  then obtain j' where j'_def: "\<And>j S. j \<ge> j' \<Longrightarrow>
    (\<forall>\<psi>. G \<psi> \<in> \<G>\<^sub>F\<^sub>G \<phi>' w' \<longrightarrow> S \<Turnstile>\<^sub>P G \<psi> \<and> S \<Turnstile>\<^sub>P eval\<^sub>G (\<G>\<^sub>F\<^sub>G \<phi>' w') (\<F> \<psi> w' (\<G>\<^sub>F\<^sub>G \<phi>' w') j)) \<Longrightarrow> S \<Turnstile>\<^sub>P af \<phi>' (w' [0 \<rightarrow> j])"
    unfolding accept\<^sub>M_def MOST_nat_le by blast

  (* Change formula, s.t. it matches ?lhs *)
  {
    fix j S
    let ?af = "af \<phi> (w[0 \<rightarrow> k + j' + j])"
    assume "(\<forall>\<psi>. G \<psi> \<in> (\<G>\<^sub>F\<^sub>G \<phi>' w') \<longrightarrow> S \<Turnstile>\<^sub>P G \<psi> \<and> S \<Turnstile>\<^sub>P eval\<^sub>G (\<G>\<^sub>F\<^sub>G \<phi>' w') (\<F> \<psi> w (\<G>\<^sub>F\<^sub>G \<phi>' w') (k + j' + j)))"
    moreover
    {
      fix \<psi>
      assume "G \<psi> \<in> \<G>\<^sub>F\<^sub>G \<phi>' w'" (is "_ \<in> ?\<G>")
      hence "\<PP>\<^sub>\<infinity> \<psi> ?\<G> w"
        unfolding \<G>_eq using closed_\<G>\<^sub>F\<^sub>G by blast
      have "\<And>S. S \<Turnstile>\<^sub>P eval\<^sub>G ?\<G> (\<F> \<psi> w ?\<G> (k + j' + j)) \<Longrightarrow> S \<Turnstile>\<^sub>P eval\<^sub>G ?\<G> (\<F> \<psi> w' ?\<G> (j' + j))"
        using \<F>_drop[OF \<open>\<PP>\<^sub>\<infinity> \<psi> (\<G>\<^sub>F\<^sub>G \<phi>' w') w\<close>, of _ k "j' + j"] eval\<^sub>G_respectfulness(1)[unfolded ltl_prop_implies_def]
        unfolding add.assoc w'_def by metis
      moreover
      assume "S \<Turnstile>\<^sub>P eval\<^sub>G ?\<G> (\<F> \<psi> w ?\<G> (k + j' + j))"
      ultimately
      have "S \<Turnstile>\<^sub>P eval\<^sub>G ?\<G> (\<F> \<psi> w' ?\<G> (j' + j))"
         by simp
    }
    ultimately
    have "S \<Turnstile>\<^sub>P ?af"
      using j'_def unfolding \<phi>'_eq add.assoc by simp
  }
  hence "accept\<^sub>M \<phi> (\<G>\<^sub>F\<^sub>G \<phi> w) w"
    unfolding accept\<^sub>M_def MOST_nat_le \<G>_eq by (metis le_Suc_ex)
  moreover
  have "\<G>\<^sub>F\<^sub>G \<phi> w \<subseteq> \<^bold>G \<phi>"
    unfolding \<G>\<^sub>F\<^sub>G_alt_def by auto
  ultimately
  show ?rhs
    by (metis closed_\<G>\<^sub>F\<^sub>G)
next
  assume ?rhs

  then obtain \<G> where \<G>_prop: "\<G> \<subseteq> \<^bold>G \<phi>" "finite \<G>" "Only_G \<G>" "accept\<^sub>M \<phi> \<G> w" "closed \<G> w"
    using \<G>_elements \<G>_finite by blast
  then obtain i where "\<And>\<chi> j. \<chi> \<in> \<G> \<Longrightarrow> suffix i w \<Turnstile> \<chi> = suffix (i + j) w \<Turnstile> \<chi>"
    using ltl_G_stabilize by blast
  hence i_def: "\<And>\<psi>. G \<psi> \<in> \<G> \<Longrightarrow> suffix i w \<Turnstile> G \<psi>"
    using ltl_G_stabilize_property[OF \<open>finite \<G>\<close> \<open>Only_G \<G>\<close>] \<G>_prop closed_FG[of \<G>] by blast
  obtain j where j_def: "\<And>j' S. j' \<ge> j \<Longrightarrow>
    (\<forall>\<psi>. G \<psi> \<in> \<G> \<longrightarrow> S \<Turnstile>\<^sub>P G \<psi> \<and> S \<Turnstile>\<^sub>P eval\<^sub>G \<G> (\<F> \<psi> w \<G> j')) \<longrightarrow> S \<Turnstile>\<^sub>P af \<phi> (w [0 \<rightarrow> j'])"
    using \<open>accept\<^sub>M \<phi> \<G> w\<close> unfolding accept\<^sub>M_def MOST_nat_le by presburger
  obtain j' where lemma19: "\<And>j \<psi>. j \<ge> j' \<Longrightarrow> G \<psi> \<in> \<G> \<Longrightarrow> suffix j w \<Turnstile> eval\<^sub>G \<G> (\<F> \<psi> w \<G> j)"
    using almost_all_suffixes_model_\<F>_generalized[OF \<open>closed \<G> w\<close>] unfolding MOST_nat_le by blast

  (* Define new constants *)
  define k where "k = max (max i j) j'"
  define w' where "w' = suffix k w"
  define \<phi>' where "\<phi>' = af \<phi> (w[0 \<rightarrow> k])"
  define S where "S = {\<chi>. w' \<Turnstile> \<chi>}"

  have "(\<And>\<psi>. G \<psi> \<in> \<G> \<Longrightarrow> S \<Turnstile>\<^sub>P G \<psi> \<and> S \<Turnstile>\<^sub>P eval\<^sub>G \<G> (\<F> \<psi> w \<G> k)) \<Longrightarrow> S \<Turnstile>\<^sub>P \<phi>'"
    using j_def[of k S] unfolding \<phi>'_def k_def by fastforce
  moreover
  {
    fix \<psi>
    assume "G \<psi> \<in> \<G>"
    have "\<And>j. i \<le> j \<Longrightarrow> suffix i w \<Turnstile> G \<psi> \<Longrightarrow> suffix j w \<Turnstile> G \<psi>"
      by (metis LTL_suffix_G le_Suc_ex suffix_suffix)
    hence "w' \<Turnstile> G \<psi>"
      unfolding w'_def k_def max_def
      using i_def[OF \<open>G \<psi> \<in> \<G>\<close>] by simp
    moreover
    have "w' \<Turnstile> eval\<^sub>G \<G> (\<F> \<psi> w \<G> k)"
      using lemma19[OF _ \<open>G \<psi> \<in> \<G>\<close>, of k]
      unfolding w'_def k_def by fastforce
    ultimately
    have "S \<Turnstile>\<^sub>P G \<psi>" and "S \<Turnstile>\<^sub>P eval\<^sub>G \<G> (\<F> \<psi> w \<G> k)"
      unfolding S_def ltl_models_equiv_prop_entailment[symmetric] by blast+
  }
  ultimately
  have "S \<Turnstile>\<^sub>P \<phi>'"
    by simp
  hence "w' \<Turnstile> \<phi>'"
    using S_def ltl_models_equiv_prop_entailment by blast
  thus ?lhs
    using w'_def \<phi>'_def af_ltl_continuation_suffix by blast
qed

end


header {* Constant definitions *}

theory Consts imports Utils begin

fun Umn :: "nat \<Rightarrow> nat \<Rightarrow> lam"
where
  [simp del]: "Umn 0 n = \<integral>(cn 0). Var (cn n)"
| [simp del]: "Umn (Suc m) n = \<integral>(cn (Suc m)). Umn m n"

lemma split_lemma:
  "(a = b \<and> X) \<or> (a \<noteq> b \<and> Y) \<longleftrightarrow> (a = b \<longrightarrow> X) \<and> (a \<noteq> b \<longrightarrow> Y)"
  by blast

lemma Lam_U:
  assumes "x \<noteq> y" "y \<noteq> z" "x \<noteq> z"
  shows "Umn 2 0 = \<integral>x. \<integral>y. \<integral>z. Var z"
        "Umn 2 1 = \<integral>x. \<integral>y. \<integral>z. Var y"
        "Umn 2 2 = \<integral>x. \<integral>y. \<integral>z. Var x"
  apply (simp_all add: Umn.simps Abs1_eq_iff lam.fresh fresh_at_base flip_def[symmetric] Umn.simps cnd permute_flip_at assms assms[symmetric] split_lemma)
  apply (intro impI conjI)
  apply (metis assms)+
  done

lemma supp_U1: "n \<le> m \<Longrightarrow> atom (cn n) \<notin> supp (Umn m n)"
  by (induct m)
     (auto simp add: lam.supp supp_at_base Umn.simps le_Suc_eq)

lemma supp_U2: "supp (Umn m n) \<subseteq> {atom (cn n)}"
  by (induct m) (auto simp add: lam.supp supp_at_base Umn.simps)

lemma supp_U[simp]: "n \<le> m \<Longrightarrow> supp (Umn m n) = {}"
  using supp_U1 supp_U2
  by blast

lemma U_eqvt:
  "n \<le> m \<Longrightarrow> p \<bullet> (Umn m n) = Umn m n"
  by (rule_tac [!] perm_supp_eq) (simp_all add: fresh_star_def fresh_def)

definition VAR where "VAR \<equiv> \<integral>cx. \<integral>cy. (Var cy \<cdot> (Umn 2 2) \<cdot> Var cx \<cdot> Var cy)"
definition "APP \<equiv> \<integral>cx. \<integral>cy. \<integral>cz. (Var cz \<cdot> Umn 2 1 \<cdot> Var cx \<cdot> Var cy \<cdot> Var cz)"
definition "Abs \<equiv> \<integral>cx. \<integral>cy. (Var cy \<cdot> Umn 2 0 \<cdot> Var cx \<cdot> Var cy)"

lemma VAR_APP_Abs:
  "x \<noteq> e \<Longrightarrow> VAR = \<integral>x. \<integral>e. (Var e \<cdot> Umn 2 2 \<cdot> Var x \<cdot> Var e)"
  "e \<noteq> x \<Longrightarrow> e \<noteq> y \<Longrightarrow> x \<noteq> y \<Longrightarrow> APP = \<integral>x. \<integral>y. \<integral>e. (Var e \<cdot> Umn 2 1 \<cdot> Var x \<cdot> Var y \<cdot> Var e)"
  "x \<noteq> e \<Longrightarrow> Abs = \<integral>x. \<integral>e. (Var e \<cdot> Umn 2 0 \<cdot> Var x \<cdot> Var e)"
  unfolding VAR_def APP_def Abs_def
  by (simp_all add: Abs1_eq_iff lam.fresh flip_def[symmetric] U_eqvt fresh_def lam.supp supp_at_base split_lemma permute_flip_at)
     (auto simp only: cx_cy_cz cx_cy_cz[symmetric])

lemma VAR_app:
  "VAR \<cdot> x \<cdot> e \<approx> e \<cdot> Umn 2 2 \<cdot> x \<cdot> e"
  by (rule lam2_fast_app[OF VAR_APP_Abs(1)]) simp_all

lemma APP_app:
  "APP \<cdot> x \<cdot> y \<cdot> e \<approx> e \<cdot> Umn 2 1 \<cdot> x \<cdot> y \<cdot> e"
  by (rule lam3_fast_app[OF VAR_APP_Abs(2)]) (simp_all)

lemma Abs_app:
  "Abs \<cdot> x \<cdot> e \<approx> e \<cdot> Umn 2 0 \<cdot> x \<cdot> e"
  by (rule lam2_fast_app[OF VAR_APP_Abs(3)]) simp_all

lemma supp_VAR_APP_Abs[simp]:
  "supp VAR = {}" "supp APP = {}" "supp Abs = {}"
  by (simp_all add: VAR_def APP_def Abs_def lam.supp supp_at_base) blast+

lemma VAR_APP_Abs_eqvt[eqvt]:
  "p \<bullet> VAR = VAR" "p \<bullet> APP = APP" "p \<bullet> Abs = Abs"
  by (rule_tac [!] perm_supp_eq) (simp_all add: fresh_star_def fresh_def)

nominal_function
  Numeral :: "lam \<Rightarrow> lam" ("\<lbrace>_\<rbrace>" 1000)
where
  "\<lbrace>Var x\<rbrace> = VAR \<cdot> (Var x)"
| Ap: "\<lbrace>M \<cdot> N\<rbrace> = APP \<cdot> \<lbrace>M\<rbrace> \<cdot> \<lbrace>N\<rbrace>"
| "\<lbrace>\<integral>x. M\<rbrace> = Abs \<cdot> (\<integral>x. \<lbrace>M\<rbrace>)"
proof auto
  fix x :: lam and P
  assume "\<And>xa. x = Var xa \<Longrightarrow> P" "\<And>M N. x = M \<cdot> N \<Longrightarrow> P" "\<And>xa M. x = \<integral> xa. M \<Longrightarrow> P"
  then show "P"
    by (rule_tac y="x" and c="0 :: perm" in lam.strong_exhaust)
       (auto simp add: Abs1_eq_iff fresh_star_def)[3]
next
  fix x :: name and M and xa :: name and Ma
  assume "[[atom x]]lst. M = [[atom xa]]lst. Ma"
    "eqvt_at Numeral_sumC M"
  then show "[[atom x]]lst. Numeral_sumC M = [[atom xa]]lst. Numeral_sumC Ma"
    apply -
    apply (erule Abs_lst1_fcb)
    apply (simp_all add: Abs_fresh_iff)
    apply (erule fresh_eqvt_at)
    apply (simp_all add: finite_supp Abs1_eq_iff eqvt_at_def)
    done
next
  show "eqvt Numeral_graph" unfolding eqvt_def Numeral_graph_def
    by (rule, perm_simp, rule)
qed

nominal_termination (eqvt) by lexicographic_order

lemma supp_numeral[simp]:
  "supp \<lbrace>x\<rbrace> = supp x"
  by (induct x rule: lam.induct)
     (simp_all add: lam.supp)

lemma fresh_numeral[simp]:
  "x \<sharp> \<lbrace>y\<rbrace> = x \<sharp> y"
  unfolding fresh_def by simp

fun app_lst :: "name \<Rightarrow> lam list \<Rightarrow> lam" where
  "app_lst n [] = Var n"
| "app_lst n (h # t) = (app_lst n t) \<cdot> h"

lemma app_lst_eqvt[eqvt]: "p \<bullet> (app_lst t ts) = app_lst (p \<bullet> t) (p \<bullet> ts)"
  by (induct ts arbitrary: t p) (simp_all add: eqvts)

lemma supp_app_lst: "supp (app_lst x l) = {atom x} \<union> supp l"
  apply (induct l)
  apply (simp_all add: supp_Nil lam.supp supp_at_base supp_Cons)
  by blast

lemma app_lst_eq_iff: "app_lst n M = app_lst n N \<Longrightarrow> M = N"
  by (induct M N rule: list_induct2') simp_all

lemma app_lst_rev_eq_iff: "app_lst n (rev M) = app_lst n (rev N) \<Longrightarrow> M = N"
  by (drule app_lst_eq_iff) simp

nominal_function
  Ltgt :: "lam list \<Rightarrow> lam" ("\<guillemotleft>_\<guillemotright>" 1000)
where
  [simp del]: "atom x \<sharp> l \<Longrightarrow> \<guillemotleft>l\<guillemotright> = \<integral>x. (app_lst x (rev l))"
  unfolding eqvt_def Ltgt_graph_def
  apply (rule, perm_simp, rule, rule)
  apply (rule_tac x="x" and ?'a="name" in obtain_fresh)
  apply (simp_all add: Abs1_eq_iff lam.fresh swap_fresh_fresh fresh_at_base)
  apply (simp add: eqvts swap_fresh_fresh)
  apply (case_tac "x = xa")
  apply simp_all
  apply (subgoal_tac "eqvt app_lst")
  apply (erule fresh_fun_eqvt_app2)
  apply (simp_all add: fresh_at_base lam.fresh eqvt_def eqvts_raw fresh_rev)
  done

nominal_termination (eqvt) by lexicographic_order

lemma ltgt_eq_iff[simp]:
  "\<guillemotleft>M\<guillemotright> = \<guillemotleft>N\<guillemotright> \<longleftrightarrow> M = N"
proof auto
  obtain x :: name where "atom x \<sharp> (M, N)" using obtain_fresh by auto
  then have *: "atom x \<sharp> M" "atom x \<sharp> N" using fresh_Pair by simp_all
  then show "(\<guillemotleft>M\<guillemotright> = \<guillemotleft>N\<guillemotright>) \<Longrightarrow> (M = N)" by (simp add: Abs1_eq_iff app_lst_rev_eq_iff Ltgt.simps)
qed

lemma Ltgt1_app: "\<guillemotleft>[M]\<guillemotright> \<cdot> N \<approx> N \<cdot> M"
proof -
  obtain x :: name where "atom x \<sharp> (M, N)" using obtain_fresh by auto
  then have "atom x \<sharp> M" "atom x \<sharp> N" using fresh_Pair by simp_all
  then show ?thesis
  apply (subst Ltgt.simps)
  apply (simp add: fresh_Cons fresh_Nil)
  apply (rule b3, rule bI, simp add: b1)
  done
qed

lemma Ltgt3_app: "\<guillemotleft>[M,N,P]\<guillemotright> \<cdot> R \<approx> R \<cdot> M \<cdot> N \<cdot> P"
proof -
  obtain x :: name where "atom x \<sharp> (M, N, P, R)" using obtain_fresh by auto
  then have *: "atom x \<sharp> (M,N,P)" "atom x \<sharp> R" using fresh_Pair by simp_all
  then have s: "Var x \<cdot> M \<cdot> N \<cdot> P [x ::= R] \<approx> R \<cdot> M \<cdot> N \<cdot> P" using b1 by simp
  show ?thesis using *
    apply (subst Ltgt.simps)
  apply (simp add: fresh_Cons fresh_Nil fresh_Pair_elim)
  apply auto[1]
  apply (rule b3, rule bI, simp add: b1)
  done
qed

lemma supp_ltgt[simp]:
  "supp \<guillemotleft>t\<guillemotright> = supp t"
proof -
  obtain x :: name where *:"atom x \<sharp> t" using obtain_fresh by auto
  show ?thesis using *
  by (simp_all add: Ltgt.simps lam.supp supp_at_base supp_Nil supp_app_lst supp_rev fresh_def)
qed

lemma fresh_ltgt[simp]:
  "x \<sharp> \<guillemotleft>[y]\<guillemotright> = x \<sharp> y"
  "x \<sharp> \<guillemotleft>[t,r,s]\<guillemotright> = x \<sharp> (t,r,s)"
  by (simp_all add: fresh_def supp_Cons supp_Nil supp_Pair)

lemma Ltgt1_subst[simp]:
  "\<guillemotleft>[M]\<guillemotright> [y ::= A] = \<guillemotleft>[M [y ::= A]]\<guillemotright>"
proof -
  obtain x :: name where a: "atom x \<sharp> (M, A, y, M [y ::= A])" using obtain_fresh by blast
  have "x \<noteq> y" using a[simplified fresh_Pair fresh_at_base] by simp
  then show ?thesis
    apply (subst Ltgt.simps)
    using a apply (simp add: fresh_Nil fresh_Cons fresh_Pair_elim)
    apply (subst Ltgt.simps)
    using a apply (simp add: fresh_Pair_elim fresh_Nil fresh_Cons)
    apply (simp add: a)
    done
qed

lemma U_app:
  "\<guillemotleft>[A,B,C]\<guillemotright> \<cdot> Umn 2 2 \<approx> A" "\<guillemotleft>[A,B,C]\<guillemotright> \<cdot> Umn 2 1 \<approx> B" "\<guillemotleft>[A,B,C]\<guillemotright> \<cdot> Umn 2 0 \<approx> C"
  by (rule b3, rule Ltgt3_app, rule lam3_fast_app, rule Lam_U, simp_all)
     (rule b3, rule Ltgt3_app, rule lam3_fast_app, rule Lam_U[simplified], simp_all)+

definition "F1 \<equiv> \<integral>cx. (APP \<cdot> \<lbrace>VAR\<rbrace> \<cdot> (VAR \<cdot> Var cx))"
definition "F2 \<equiv> \<integral>cx. \<integral>cy. \<integral>cz. ((APP \<cdot> (APP \<cdot> \<lbrace>APP\<rbrace> \<cdot> (Var cz \<cdot> Var cx))) \<cdot> (Var cz \<cdot> Var cy))"
definition "F3 \<equiv> \<integral>cx. \<integral>cy. (APP \<cdot> \<lbrace>Abs\<rbrace> \<cdot> (Abs \<cdot> (\<integral>cz. (Var cy \<cdot> (Var cx \<cdot> Var cz)))))"

lemma Lam_F:
  "F1 = \<integral>x. (APP \<cdot> \<lbrace>VAR\<rbrace> \<cdot> (VAR \<cdot> Var x))"
  "a \<noteq> b \<Longrightarrow> a \<noteq> c \<Longrightarrow> c \<noteq> b \<Longrightarrow> F2 = \<integral>a. \<integral>b. \<integral>c. ((APP \<cdot> (APP \<cdot> \<lbrace>APP\<rbrace> \<cdot> (Var c \<cdot> Var a))) \<cdot> (Var c \<cdot> Var b))"
  "a \<noteq> b \<Longrightarrow> a \<noteq> x \<Longrightarrow> x \<noteq> b \<Longrightarrow> F3 = \<integral>a. \<integral>b. (APP \<cdot> \<lbrace>Abs\<rbrace> \<cdot> (Abs \<cdot> (\<integral>x. (Var b \<cdot> (Var a \<cdot> Var x)))))"
  by (simp_all add: F1_def F2_def F3_def Abs1_eq_iff lam.fresh supp_at_base VAR_APP_Abs_eqvt Numeral.eqvt flip_def[symmetric] fresh_at_base split_lemma permute_flip_at)
     (auto simp add: cx_cy_cz cx_cy_cz[symmetric])

lemma supp_F[simp]:
  "supp F1 = {}" "supp F2 = {}" "supp F3 = {}"
  by (simp_all add: F1_def F2_def F3_def lam.supp supp_at_base)
     blast+

lemma F_eqvt[eqvt]:
  "p \<bullet> F1 = F1" "p \<bullet> F2 = F2" "p \<bullet> F3 = F3"
  by (rule_tac [!] perm_supp_eq)
     (simp_all add: fresh_star_def fresh_def)

lemma F_app:
  "F1 \<cdot> A \<approx> APP \<cdot> \<lbrace>VAR\<rbrace> \<cdot> (VAR \<cdot> A)"
  "F2 \<cdot> A \<cdot> B \<cdot> C \<approx> (APP \<cdot> (APP \<cdot> \<lbrace>APP\<rbrace> \<cdot> (C \<cdot> A))) \<cdot> (C \<cdot> B)"
  by (rule lam1_fast_app, rule Lam_F, simp_all)
     (rule lam3_fast_app, rule Lam_F, simp_all)

lemma F3_app:
  assumes f: "atom x \<sharp> A" "atom x \<sharp> B" (* or A and B have empty support *)
  shows "F3 \<cdot> A \<cdot> B \<approx> APP \<cdot> \<lbrace>Abs\<rbrace> \<cdot> (Abs \<cdot> (\<integral>x. (B \<cdot> (A \<cdot> Var x))))"
proof -
  obtain y :: name where b: "atom y \<sharp> (x, A, B)" using obtain_fresh by blast
  obtain z :: name where c: "atom z \<sharp> (x, y, A, B)" using obtain_fresh by blast
  have *: "x \<noteq> z" "x \<noteq> y" "y \<noteq> z"
    using b c by (simp_all add: fresh_Pair fresh_at_base) blast+
  have **:
    "atom y \<sharp> z" "atom x \<sharp> z" "atom y \<sharp> x"
    "atom z \<sharp> y" "atom z \<sharp> x" "atom x \<sharp> y"
    "atom x \<sharp> A" "atom y \<sharp> A" "atom z \<sharp> A"
    "atom x \<sharp> B" "atom y \<sharp> B" "atom z \<sharp> B"
    using b c f by (simp_all add: fresh_Pair fresh_at_base) blast+
  show ?thesis
    apply (simp add: Lam_F(3)[of y z x] * *[symmetric])
    apply (rule b3) apply (rule b5) apply (rule bI)
    apply (simp add: ** fresh_Pair * *[symmetric])
    apply (rule b3) apply (rule bI)
    apply (simp add: ** fresh_Pair * *[symmetric])
    apply (rule b1)
    done
qed

definition Lam_A1_pre : "A1 \<equiv> \<integral>cx. \<integral>cy. (F1 \<cdot> Var cx)"
definition Lam_A2_pre : "A2 \<equiv> \<integral>cx. \<integral>cy. \<integral>cz. (F2 \<cdot> Var cx \<cdot> Var cy \<cdot> \<guillemotleft>[Var cz]\<guillemotright>)"
definition Lam_A3_pre : "A3 \<equiv> \<integral>cx. \<integral>cy. (F3 \<cdot> Var cx \<cdot> \<guillemotleft>[Var cy]\<guillemotright>)"
lemma Lam_A:
  "x \<noteq> y \<Longrightarrow> A1 = \<integral>x. \<integral>y. (F1 \<cdot> Var x)"
  "a \<noteq> b \<Longrightarrow> a \<noteq> c \<Longrightarrow> c \<noteq> b \<Longrightarrow> A2 = \<integral>a. \<integral>b. \<integral>c. (F2 \<cdot> Var a \<cdot> Var b \<cdot> \<guillemotleft>[Var c]\<guillemotright>)"
  "a \<noteq> b \<Longrightarrow> A3 = \<integral>a. \<integral>b. (F3 \<cdot> Var a \<cdot> \<guillemotleft>[Var b]\<guillemotright>)"
  by (simp_all add: Lam_A1_pre Lam_A2_pre Lam_A3_pre Abs1_eq_iff lam.fresh supp_at_base VAR_APP_Abs_eqvt Numeral.eqvt flip_def[symmetric] fresh_at_base F_eqvt Ltgt.eqvt split_lemma permute_flip_at cx_cy_cz cx_cy_cz[symmetric])
     auto

lemma supp_A[simp]:
  "supp A1 = {}" "supp A2 = {}" "supp A3 = {}"
  by (auto simp add: Lam_A1_pre Lam_A2_pre Lam_A3_pre lam.supp supp_at_base supp_Cons supp_Nil)

lemma A_app:
  "A1 \<cdot> A \<cdot> B \<approx> F1 \<cdot> A"
  "A2 \<cdot> A \<cdot> B \<cdot> C \<approx> F2 \<cdot> A \<cdot> B \<cdot> \<guillemotleft>[C]\<guillemotright>"
  "A3 \<cdot> A \<cdot> B \<approx> F3 \<cdot> A \<cdot> \<guillemotleft>[B]\<guillemotright>"
  apply (rule lam2_fast_app, rule Lam_A, simp_all)
  apply (rule lam3_fast_app, rule Lam_A, simp_all)
  apply (rule lam2_fast_app, rule Lam_A, simp_all)
  done

definition "NUM \<equiv> \<guillemotleft>[\<guillemotleft>[A1,A2,A3]\<guillemotright>]\<guillemotright>"

lemma supp_NUM[simp]:
  "supp NUM = {}"
  by (auto simp only: NUM_def supp_ltgt supp_Pair supp_A supp_Cons supp_Nil)

end


(*  Title:      HOL/Quotient_Examples/DList.thy
    Author:     Cezary Kaliszyk, University of Tsukuba

Based on typedef version "Library/Dlist" by Florian Haftmann
and theory morphism version by Maksym Bortin
*)

section \<open>Lists with distinct elements\<close>

theory DList
imports "~~/src/HOL/Library/Quotient_List"
begin

text \<open>Some facts about lists\<close>

lemma remdups_removeAll_commute[simp]:
  "remdups (removeAll x l) = removeAll x (remdups l)"
  by (induct l) auto

lemma removeAll_distinct[simp]:
  assumes "distinct l"
  shows "distinct (removeAll x l)"
  using assms by (induct l) simp_all

lemma removeAll_commute:
  "removeAll x (removeAll y l) = removeAll y (removeAll x l)"
  by (induct l) auto

lemma remdups_hd_notin_tl:
  "remdups dl = h # t \<Longrightarrow> h \<notin> set t"
proof (induct dl arbitrary: h t)
  case Nil
  then show ?case by simp
next
  case (Cons a dl)
  then show ?case by (cases "a \<in> set dl") auto
qed

lemma remdups_repeat:
  "remdups dl = h # t \<Longrightarrow> t = remdups t"
proof (induct dl arbitrary: h t)
  case Nil
  then show ?case by simp
next
  case (Cons a dl)
  then show ?case by (cases "a \<in> set dl") (auto simp: remdups_remdups)
qed

lemma remdups_nil_noteq_cons:
  "remdups (h # t) \<noteq> remdups []"
  "remdups [] \<noteq> remdups (h # t)"
  by auto

lemma remdups_eq_map_eq:
  assumes "remdups xa = remdups ya"
    shows "remdups (map f xa) = remdups (map f ya)"
  using assms
  by (induct xa ya rule: list_induct2')
     (metis (full_types) remdups_nil_noteq_cons(2) remdups_map_remdups)+

lemma remdups_eq_member_eq:
  assumes "remdups xa = remdups ya"
    shows "List.member xa = List.member ya"
  using assms
  unfolding fun_eq_iff List.member_def
  by (induct xa ya rule: list_induct2')
     (metis remdups_nil_noteq_cons set_remdups)+

text \<open>Setting up the quotient type\<close>

definition
  dlist_eq :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
where
  [simp]: "dlist_eq xs ys \<longleftrightarrow> remdups xs = remdups ys"

lemma dlist_eq_reflp:
  "reflp dlist_eq"
  by (auto intro: reflpI)

lemma dlist_eq_symp:
  "symp dlist_eq"
  by (auto intro: sympI)

lemma dlist_eq_transp:
  "transp dlist_eq"
  by (auto intro: transpI)

lemma dlist_eq_equivp:
  "equivp dlist_eq"
  by (auto intro: equivpI dlist_eq_reflp dlist_eq_symp dlist_eq_transp)

quotient_type
  'a dlist = "'a list" / "dlist_eq"
  by (rule dlist_eq_equivp)

text \<open>respectfulness and constant definitions\<close>

definition [simp]: "card_remdups = length \<circ> remdups"
definition [simp]: "foldr_remdups f xs e = foldr f (remdups xs) e"

quotient_definition empty where "empty :: 'a dlist"
  is "Nil" .

quotient_definition insert where "insert :: 'a \<Rightarrow> 'a dlist \<Rightarrow> 'a dlist"
  is "Cons" by (metis (mono_tags) List.insert_def dlist_eq_def remdups.simps(2) set_remdups)

quotient_definition "member :: 'a dlist \<Rightarrow> 'a \<Rightarrow> bool"
  is "List.member" by (metis dlist_eq_def remdups_eq_member_eq)

quotient_definition foldr where "foldr :: ('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a dlist \<Rightarrow> 'b \<Rightarrow> 'b"
  is "foldr_remdups" by auto

quotient_definition "remove :: 'a \<Rightarrow> 'a dlist \<Rightarrow> 'a dlist"
  is "removeAll" by force

quotient_definition card where "card :: 'a dlist \<Rightarrow> nat"
  is "card_remdups" by fastforce

quotient_definition map where "map :: ('a \<Rightarrow> 'b) \<Rightarrow> 'a dlist \<Rightarrow> 'b dlist"
  is "List.map :: ('a \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b list" by (metis dlist_eq_def remdups_eq_map_eq)

quotient_definition filter where "filter :: ('a \<Rightarrow> bool) \<Rightarrow> 'a dlist \<Rightarrow> 'a dlist"
  is "List.filter" by (metis dlist_eq_def remdups_filter)

quotient_definition "list_of_dlist :: 'a dlist \<Rightarrow> 'a list"
  is "remdups" by simp

text \<open>lifted theorems\<close>

lemma dlist_member_insert:
  "member dl x \<Longrightarrow> insert x dl = dl"
  by descending (simp add: List.member_def)

lemma dlist_member_insert_eq:
  "member (insert y dl) x = (x = y \<or> member dl x)"
  by descending (simp add: List.member_def)

lemma dlist_insert_idem:
  "insert x (insert x dl) = insert x dl"
  by descending simp

lemma dlist_insert_not_empty:
  "insert x dl \<noteq> empty"
  by descending auto

lemma not_dlist_member_empty:
  "\<not> member empty x"
  by descending (simp add: List.member_def)

lemma not_dlist_member_remove:
  "\<not> member (remove x dl) x"
  by descending (simp add: List.member_def)

lemma dlist_in_remove:
  "a \<noteq> b \<Longrightarrow> member (remove b dl) a = member dl a"
  by descending (simp add: List.member_def)

lemma dlist_not_memb_remove:
  "\<not> member dl x \<Longrightarrow> remove x dl = dl"
  by descending (simp add: List.member_def)

lemma dlist_no_memb_remove_insert:
  "\<not> member dl x \<Longrightarrow> remove x (insert x dl) = dl"
  by descending (simp add: List.member_def)

lemma dlist_remove_empty:
  "remove x empty = empty"
  by descending simp

lemma dlist_remove_insert_commute:
  "a \<noteq> b \<Longrightarrow> remove a (insert b dl) = insert b (remove a dl)"
  by descending simp

lemma dlist_remove_commute:
"remove a (remove b dl) = remove b (remove a dl)"
  by (lifting removeAll_commute)

lemma dlist_foldr_empty:
  "foldr f empty e = e"
  by descending simp

lemma dlist_no_memb_foldr:
  assumes "\<not> member dl x"
  shows "foldr f (insert x dl) e = f x (foldr f dl e)"
  using assms by descending (simp add: List.member_def)

lemma dlist_foldr_insert_not_memb:
  assumes "\<not>member t h"
  shows "foldr f (insert h t) e = f h (foldr f t e)"
  using assms by descending (simp add: List.member_def)

lemma list_of_dlist_empty[simp]:
  "list_of_dlist empty = []"
  by descending simp

lemma list_of_dlist_insert[simp]:
  "list_of_dlist (insert x xs) =
    (if member xs x then (remdups (list_of_dlist xs))
    else x # (remdups (list_of_dlist xs)))"
  by descending (simp add: List.member_def remdups_remdups)

lemma list_of_dlist_remove[simp]:
  "list_of_dlist (remove x dxs) = remove1 x (list_of_dlist dxs)"
  by descending (simp add: distinct_remove1_removeAll)

lemma list_of_dlist_map[simp]:
  "list_of_dlist (map f dxs) = remdups (List.map f (list_of_dlist dxs))"
  by descending (simp add: remdups_map_remdups)

lemma list_of_dlist_filter [simp]:
  "list_of_dlist (filter P dxs) = List.filter P (list_of_dlist dxs)"
  by descending (simp add: remdups_filter)

lemma dlist_map_empty:
  "map f empty = empty"
  by descending simp

lemma dlist_map_insert:
  "map f (insert x xs) = insert (f x) (map f xs)"
  by descending simp

lemma dlist_eq_iff:
  "dxs = dys \<longleftrightarrow> list_of_dlist dxs = list_of_dlist dys"
  by descending simp

lemma dlist_eqI:
  "list_of_dlist dxs = list_of_dlist dys \<Longrightarrow> dxs = dys"
  by (simp add: dlist_eq_iff)

abbreviation
  "dlist xs \<equiv> abs_dlist xs"

lemma distinct_list_of_dlist [simp, intro]:
  "distinct (list_of_dlist dxs)"
  by descending simp

lemma list_of_dlist_dlist [simp]:
  "list_of_dlist (dlist xs) = remdups xs"
  unfolding list_of_dlist_def map_fun_apply id_def
  by (metis Quotient3_rep_abs[OF Quotient3_dlist] dlist_eq_def)

lemma remdups_list_of_dlist [simp]:
  "remdups (list_of_dlist dxs) = list_of_dlist dxs"
  by simp

lemma dlist_list_of_dlist [simp, code abstype]:
  "dlist (list_of_dlist dxs) = dxs"
  by (simp add: list_of_dlist_def)
  (metis Quotient3_def Quotient3_dlist dlist_eqI list_of_dlist_dlist remdups_list_of_dlist)

lemma dlist_filter_simps:
  "filter P empty = empty"
  "filter P (insert x xs) = (if P x then insert x (filter P xs) else filter P xs)"
  by (lifting filter.simps)

lemma dlist_induct:
  assumes "P empty"
      and "\<And>a dl. P dl \<Longrightarrow> P (insert a dl)"
    shows "P dl"
  using assms by descending (drule list.induct, simp)

lemma dlist_induct_stronger:
  assumes a1: "P empty"
  and     a2: "\<And>x dl. \<lbrakk>\<not>member dl x; P dl\<rbrakk> \<Longrightarrow> P (insert x dl)"
  shows "P dl"
proof(induct dl rule: dlist_induct)
  show "P empty" using a1 by simp
next
  fix x dl
  assume "P dl"
  then show "P (insert x dl)" using a2
    by (cases "member dl x") (simp_all add: dlist_member_insert)
qed

lemma dlist_card_induct:
  assumes "\<And>xs. (\<And>ys. card ys < card xs \<Longrightarrow> P ys) \<Longrightarrow> P xs"
    shows "P xs"
  using assms
  by descending (rule measure_induct [of card_remdups], blast)

lemma dlist_cases:
  "dl = empty \<or> (\<exists>h t. dl = insert h t \<and> \<not> member t h)"
  by descending
    (metis List.member_def dlist_eq_def hd_Cons_tl list_of_dlist_dlist remdups_hd_notin_tl remdups_list_of_dlist)

lemma dlist_exhaust:
  obtains "y = empty" | a dl where "y = insert a dl"
  by (lifting list.exhaust)

lemma dlist_exhaust_stronger:
  obtains "y = empty" | a dl where "y = insert a dl" "\<not> member dl a"
  by (metis dlist_cases)

end


theory cubevariant
imports Main

begin

typedecl i (*Possible worlds.*)
type_synonym \<sigma> = "(i\<Rightarrow>bool)"
type_synonym \<alpha> = "i\<Rightarrow>\<sigma>" (*Type of betterness relation between worlds.*)
type_synonym \<tau> = "\<sigma>\<Rightarrow>\<sigma>"

consts aw::i (*Actual world.*)
abbreviation etrue  :: "\<sigma>" ("\<^bold>\<top>") where "\<^bold>\<top> \<equiv> \<lambda>w. True"
abbreviation efalse :: "\<sigma>" ("\<^bold>\<bottom>")  where "\<^bold>\<bottom> \<equiv> \<lambda>w. False"
abbreviation enot :: "\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>\<not>_"[52]53)  where "\<^bold>\<not>\<phi> \<equiv> \<lambda>w. \<not>\<phi>(w)"
abbreviation eand :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<and>"51) where "\<phi>\<^bold>\<and>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<and>\<psi>(w)"
abbreviation eor  :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<or>"50) where "\<phi>\<^bold>\<or>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<or>\<psi>(w)"
abbreviation eimp :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<rightarrow>"49) where "\<phi>\<^bold>\<rightarrow>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<longrightarrow>\<psi>(w)"
abbreviation eequ :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<leftrightarrow>"48) where "\<phi>\<^bold>\<leftrightarrow>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<longleftrightarrow>\<psi>(w)"

abbreviation ebox :: "\<sigma>\<Rightarrow>\<sigma>" ("\<box>") where "\<box> \<equiv> \<lambda>\<phi> w.  \<forall>v. \<phi>(v)"
definition ddediomond  :: "\<sigma>\<Rightarrow>\<sigma>" ("\<diamond>") where "\<diamond>\<phi> \<equiv> \<lambda>w. \<exists>v. \<phi>(v)"

abbreviation evalid :: "\<sigma>\<Rightarrow>bool" ("\<lfloor>_\<rfloor>"[8]109)  (*Global validity.*)
  where "\<lfloor>p\<rfloor> \<equiv> \<forall>w. p w"
abbreviation ecjactual :: "\<sigma>\<Rightarrow>bool" ("\<lfloor>_\<rfloor>\<^sub>l"[7]105) (*Local validity — in world aw.*)
  where "\<lfloor>p\<rfloor>\<^sub>l \<equiv> p(aw)"

consts r :: "\<alpha>" (infixr "r" 70) (*Betterness relation*)

abbreviation esubset :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>bool" (infix "\<^bold>\<subseteq>" 53)
  where "\<phi> \<^bold>\<subseteq> \<psi> \<equiv> \<forall>x. \<phi> x \<longrightarrow> \<psi> x"

abbreviation eopt  :: "\<sigma>\<Rightarrow>\<sigma>" ("opt<_>")  (* opt rule*)
  where "opt<\<phi>> \<equiv> (\<lambda>v. ( (\<phi>)(v) \<and> (\<forall>x. ((\<phi>)(x) \<longrightarrow> v r x) )) )"
abbreviation econdopt :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" ("\<odot><_|_>")
  where "\<odot><\<psi>|\<phi>> \<equiv>  \<lambda>w. opt<\<phi>> \<^bold>\<subseteq> \<psi>"
abbreviation eperm :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" ("\
<_|_>")
  where "\
<\<psi>|\<phi>> \<equiv> \<^bold>\<not>\<odot><\<^bold>\<not>\<psi>|\<phi>>"

abbreviation emax  :: "\<sigma>\<Rightarrow>\<sigma>" ("max<_>")      (*Max rule *)
  where "max<\<phi>> \<equiv> (\<lambda>v. ( (\<phi>)(v) \<and> (\<forall>x. ((\<phi>)(x) \<longrightarrow> (x r v \<longrightarrow>  v r x)) )) )"
abbreviation econd  :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" ("\<circle><_|_>")
  where "\<circle><\<psi>|\<phi>> \<equiv>  \<lambda>w. max<\<phi>> \<^bold>\<subseteq> \<psi>"
abbreviation euncobl :: "\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>\<circle><_>")
  where "\<^bold>\<circle><\<phi>> \<equiv> \<circle><\<phi>|\<^bold>\<top>>"
abbreviation ddeperm :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" ("P<_|_>")
  where "P<\<psi>|\<phi>> \<equiv>\<^bold>\<not>\<circle><\<^bold>\<not>\<psi>|\<phi>>"

lemma True nitpick [satisfy,user_axioms,expect=genuine] oops

lemma "\<odot><\<psi>|\<phi>> \<equiv> \<circle><\<psi>|\<phi>>" nitpick [show_all] (*countermodel found*)

abbreviation lewcond  :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" ("\<otimes><_|_>")  (*David Lewis's evaluation rule for the conditional*)
  where "\<otimes><\<psi>|\<phi>> \<equiv> (\<lambda>v. (\<not>(\<exists>x. (\<phi>)(x))\<or>
                      (\<exists>x. ((\<phi>)(x)\<and>(\<psi>)(x) \<and> (\<forall>y. ((y r x) \<longrightarrow> (\<phi>)(y)\<longrightarrow>(\<psi>)(y)))))))"
definition lewperm :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" ("\<pi><_|_>")
  where "\<pi><\<psi>|\<phi>> \<equiv>\<^bold>\<not>\<otimes><\<^bold>\<not>\<psi>|\<phi>>"

subsection \<open>Properties\<close>

text \<open>We have the following constraints on the betterness relation\<close>

(*The standard properties*)
abbreviation reflexivity  where "reflexivity  \<equiv> (\<forall>x. x r x)"
abbreviation transitivity
  where "transitivity \<equiv> (\<forall>x y z. (x r y \<and> y r z) \<longrightarrow> x r z)"
abbreviation totalness
  where "totalness \<equiv> (\<forall>x y. (x r y \<or> y r x))"

(*4 versions of Lewis's limit assumption*)
abbreviation mlimitedness
  where "mlimitedness \<equiv> (\<forall>\<phi>. (\<exists>x. (\<phi>)x) \<longrightarrow> (\<exists>x. max<\<phi>>x))"
abbreviation msmoothness
  where "msmoothness \<equiv> (\<forall>\<phi> x. ((\<phi>)x \<longrightarrow>
                     (max<\<phi>>x \<or> (\<exists>y. (y r x \<and> \<not>(x r y) \<and> max<\<phi>>y)))))"
abbreviation olimitedness
  where "olimitedness \<equiv> (\<forall>\<phi>. (\<exists>x. (\<phi>)x) \<longrightarrow> (\<exists>x. opt<\<phi>>x))"
abbreviation osmoothness  where
   "osmoothness \<equiv> (\<forall>\<phi> x. ((\<phi>)x \<longrightarrow>
                      (opt<\<phi>>x \<or> (\<exists>y. (y r x \<and> \<not>(x r y) \<and> opt<\<phi>>y)))))"

definition transitive :: "\<alpha>\<Rightarrow>bool" where "transitive R \<equiv> \<forall>x y z. R x y \<and>  R y z \<longrightarrow> R x z"
definition sub_rel :: "\<alpha>\<Rightarrow>\<alpha>\<Rightarrow>bool" where "sub_rel R Q \<equiv> \<forall>u v. R u v \<longrightarrow> Q u v"
definition assfactor::"\<alpha>\<Rightarrow>\<alpha>" where "assfactor R \<equiv> \<lambda>u v. R u v \<and> \<not> R v u "

(*In HOL the transitive closure of a relation can be defined in a single line.*)
definition tc :: "\<alpha>\<Rightarrow>\<alpha>" where "tc R \<equiv> \<lambda>x y.\<forall>Q. transitive Q \<longrightarrow> (sub_rel R Q \<longrightarrow> Q x y)"

(* this is a first form of a-cyclicity. Cycles with one non-strict betterness are ruled out*)
abbreviation Suzumura
  where "Suzumura R \<equiv> \<forall>x y. (tc R x y \<longrightarrow> ( R y x \<longrightarrow> R x y))"

(* this is a second form of a-cyclicity. Cycles of non-strict betterness are ruled out*)
abbreviation loopfree
  where "loopfree R \<equiv> \<forall>x y. (tc (assfactor R) x y \<longrightarrow> ( R y x \<longrightarrow> R x y))"

(*Interval order condition is totalness plus Ferrers*)
abbreviation Ferrers
  where "Ferrers \<equiv> (\<forall>x y z u. ((x r u) \<and> (y r z)) \<longrightarrow> (x r z) \<or> (y r u))"

lemma assumes Ferrers reflexivity  (*fact overlooked in the literature*)
  shows totalness
  sledgehammer  (*proof found*)

(* Some useful relations for constraining the betterness relations*)

subsection \<open>Correspondance under the max rule\<close>

text \<open>We go through the known correspondances, and verify them \<close>

(*max-Limitedness corresponds to D*)
lemma assumes "mlimitedness"
  shows  D: "\<lfloor>\<diamond>\<phi> \<^bold>\<rightarrow> \<circle><\<psi>|\<phi>> \<^bold>\<rightarrow> P<\<psi>|\<phi>>\<rfloor>" sledgehammer oops (*proof found*)

lemma assumes D: "\<lfloor>\<diamond>\<phi> \<^bold>\<rightarrow> \<circle><\<psi>|\<phi>> \<^bold>\<rightarrow> P<\<psi>|\<phi>>\<rfloor>"
  shows "mlimitedness"
  sledgehammer (*all timed out*)
  nitpick (* counterexample found *)
  oops

(*smoothness corresponds to cautious monotony *)
lemma assumes "msmoothness"
  shows  CM: "\<lfloor>(\<circle><\<psi>|\<phi>>\<^bold>\<and>\<circle><\<chi>|\<phi>>)\<^bold>\<rightarrow> \<circle><\<chi>|\<phi>\<^bold>\<and>\<psi>>\<rfloor>" sledgehammer  oops (*proof found*)

lemma assumes CM: "\<lfloor>(\<circle><\<psi>|\<phi>>\<^bold>\<and>\<circle><\<chi>|\<phi>>)\<^bold>\<rightarrow> \<circle><\<chi>|\<phi>\<^bold>\<and>\<psi>>\<rfloor>"
  shows  "msmoothness"
  sledgehammer (* timed out*)
  nitpick [show_all] (* counterexample found *)
  oops

(*interval order (reflexivity plus Ferrers) corresponds to disjunctive rationality*)
lemma assumes "reflexivity"
     (* assumes "Ferrers"*)
  shows  DR: "\<lfloor>\<circle><\<chi>|(\<phi>\<^bold>\<or>\<psi>)>\<^bold>\<rightarrow>((\<circle><\<chi>|\<phi>>)\<^bold>\<or>(\<circle><\<chi>|\<psi>>))\<rfloor>"
  sledgehammer (* timed out*)
  nitpick (* counterexample found *)
  oops

lemma assumes "reflexivity" "Ferrers"
  shows  DR: "\<lfloor>\<circle><\<chi>|(\<phi>\<^bold>\<or>\<psi>)>\<^bold>\<rightarrow>((\<circle><\<chi>|\<phi>>)\<^bold>\<or>(\<circle><\<chi>|\<psi>>))\<rfloor>"
  sledgehammer (* proof found *)
  nitpick (* no counterexample found *)
  oops

lemma assumes DR: "\<lfloor>\<circle><\<chi>|\<phi>\<^bold>\<or>\<psi>>\<^bold>\<rightarrow>(\<circle><\<chi>|\<phi>>\<^bold>\<or>\<circle><\<chi>|\<psi>>)\<rfloor>"
   shows "reflexivity"
   sledgehammer (* timed out*)
   nitpick (* counterexample found *)
   oops

lemma assumes DR: "\<lfloor>\<circle><\<chi>|\<phi>\<^bold>\<or>\<psi>>\<^bold>\<rightarrow>(\<circle><\<chi>|\<phi>>\<^bold>\<or>\<circle><\<chi>|\<psi>>)\<rfloor>"
  shows "Ferrers"
  sledgehammer (* timed out*)
  nitpick (* counterexample found *)
  oops

text \<open>Transitivity and totalness corresponds to the Spohn axiom (Sp)\<close>

lemma assumes "transitivity"
  shows  Sp: "\<lfloor>( P<\<psi>|\<phi>> \<^bold>\<and> \<circle><(\<psi>\<^bold>\<rightarrow>\<chi>)|\<phi>>) \<^bold>\<rightarrow> \<circle><\<chi>|(\<phi>\<^bold>\<and>\<psi>)>\<rfloor>"
  sledgehammer (* timed out *)
  nitpick (* counterexample*)
  oops

lemma assumes "totalness"
  shows  Sp: "\<lfloor>( P<\<psi>|\<phi>> \<^bold>\<and> \<circle><(\<psi>\<^bold>\<rightarrow>\<chi>)|\<phi>>) \<^bold>\<rightarrow> \<circle><\<chi>|(\<phi>\<^bold>\<and>\<psi>)>\<rfloor>"
  sledgehammer (* timed out*)
  nitpick (* counterexample*)
  oops

lemma assumes "transitivity" "totalness"
  shows  Sp: "\<lfloor>( P<\<psi>|\<phi>> \<^bold>\<and> \<circle><(\<psi>\<^bold>\<rightarrow>\<chi>)|\<phi>>) \<^bold>\<rightarrow> \<circle><\<chi>|(\<phi>\<^bold>\<and>\<psi>)>\<rfloor>"
  sledgehammer (* proof found *)
  nitpick (* no counterexample found *)
  oops

lemma assumes  Sp: "\<lfloor>( P<\<psi>|\<phi>> \<^bold>\<and> \<circle><(\<psi>\<^bold>\<rightarrow>\<chi>)|\<phi>>) \<^bold>\<rightarrow> \<circle><\<chi>|(\<phi>\<^bold>\<and>\<psi>)>\<rfloor>"
  shows "totalness"
  sledgehammer (* timed out*)
  nitpick (* counterexample found *)
  oops

lemma assumes  Sp: "\<lfloor>( P<\<psi>|\<phi>> \<^bold>\<and> \<circle><(\<psi>\<^bold>\<rightarrow>\<chi>)|\<phi>>) \<^bold>\<rightarrow> \<circle><\<chi>|(\<phi>\<^bold>\<and>\<psi>)>\<rfloor>"
      shows "transitivity"
  sledgehammer (* timed out*)
  nitpick (* counterexample found *)
  oops

  subsection \<open>Correspondance under the opt rule\<close>

text \<open>We move to the opt rule, and associate with it two news modal operators\<close>

text \<open>Here we redefine Lewis's limit assumption accordingly\<close>

text \<open>Correspondance\<close>

text \<open>max-Limitedness corresponds to D\<close>

lemma assumes "mlimitedness"
  shows  D: "\<lfloor>\<diamond>\<phi> \<^bold>\<rightarrow> \<odot><\<psi>|\<phi>> \<^bold>\<rightarrow> \
<\<psi>|\<phi>>\<rfloor>"
  sledgehammer (* timed out*)
  nitpick (* counterexample found *)
  oops
lemma assumes D: "\<lfloor>\<diamond>\<phi> \<^bold>\<rightarrow> \<odot><\<psi>|\<phi>> \<^bold>\<rightarrow> \
<\<psi>|\<phi>>\<rfloor>"
  shows "mlimitedness"
  sledgehammer (* timed out*)
  nitpick (* counterexample found *)
  oops

text \<open>Smoothness corresponds to CM\<close>

lemma assumes "msmoothness"
  shows  CM: "\<lfloor>(\<odot><\<psi>|\<phi>>\<^bold>\<and>\<odot><\<chi>|\<phi>>)\<^bold>\<rightarrow> \<odot><\<chi>|\<phi>\<^bold>\<and>\<psi>>\<rfloor>"
  sledgehammer (* timed out*)
  nitpick (* counterexample found *)
  oops

lemma assumes CM: "\<lfloor>(\<odot><\<psi>|\<phi>>\<^bold>\<and>\<odot><\<chi>|\<phi>>)\<^bold>\<rightarrow> \<odot><\<chi>|\<phi>\<^bold>\<and>\<psi>>\<rfloor>"
  shows  "msmoothness"
  sledgehammer (* timed out*)
  nitpick (* counterexample found *)
  oops

lemma assumes "totalness"
     (* assumes "Ferrers"*)
  shows  DR: "\<lfloor>\<odot><\<chi>|\<phi>\<^bold>\<or>\<psi>>\<^bold>\<rightarrow>(\<odot><\<chi>|\<phi>>\<^bold>\<or>\<odot><\<chi>|\<psi>>)\<rfloor>"
  sledgehammer (* timed out*)
  nitpick (* counterexample found *)
  oops

 lemma assumes DR: "\<lfloor>\<odot><\<chi>|\<phi>\<^bold>\<or>\<psi>>\<^bold>\<rightarrow>(\<odot><\<chi>|\<phi>>\<^bold>\<or>\<odot><\<chi>|\<psi>>)\<rfloor>"
   shows "totalness"
   sledgehammer (* timed out*)
   nitpick (* counterexample found *)
   oops

lemma assumes DR: "\<lfloor>\<odot><\<chi>|\<phi>\<^bold>\<or>\<psi>>\<^bold>\<rightarrow>(\<odot><\<chi>|\<phi>>\<^bold>\<or>\<odot><\<chi>|\<psi>>)\<rfloor>"
  shows "Ferrers"
  sledgehammer (* timed out*)
  nitpick (* counterexample found *)
  oops

(*transitivity*)

lemma assumes "transitivity"
  shows  Sp: "\<lfloor>( \
<\<psi>|\<phi>> \<^bold>\<and> \<odot><(\<psi>\<^bold>\<rightarrow>\<chi>)|\<phi>>) \<^bold>\<rightarrow> \<odot><\<chi>|(\<phi>\<^bold>\<and>\<psi>)>\<rfloor>"
  sledgehammer (* proof found *)
  nitpick (* no counterexample found *)
  oops

lemma assumes "transitivity"
  shows  Trans: "\<lfloor>(\
<\<phi>|\<phi>\<^bold>\<or>\<psi>> \<^bold>\<and> \
<\<xi>|\<psi>\<^bold>\<or>\<xi>>)\<^bold>\<rightarrow>\
<\<xi>|\<phi>\<^bold>\<or>\<xi>>\<rfloor>"
  sledgehammer (* proof found *)
  nitpick (* no counterexample found *)
  oops

lemma assumes Sp: "\<lfloor>( \
<\<psi>|\<phi>> \<^bold>\<and> \<odot><(\<psi>\<^bold>\<rightarrow>\<chi>)|\<phi>>) \<^bold>\<rightarrow> \<odot><\<chi>|(\<phi>\<^bold>\<and>\<psi>)>\<rfloor>"
      assumes Trans: "\<lfloor>(\
<\<phi>|\<phi>\<^bold>\<or>\<psi>> \<^bold>\<and> \
<\<xi>|\<psi>\<^bold>\<or>\<xi>>)\<^bold>\<rightarrow>\
<\<xi>|\<phi>\<^bold>\<or>\<xi>>\<rfloor>"
      shows "transitivity"
  sledgehammer (* timed out*)
  nitpick (* counterexample found *)
  oops

subsection \<open>Closure maximality and Lewis rule\<close>

(*ToDO*)

 text \<open>Under the Lewis rule, totalness corresponds to D \<close>

lemma
 assumes "totalness"
 shows D : "\<lfloor>\<diamond>\<phi> \<^bold>\<rightarrow> (\<otimes><\<psi>|\<phi>> \<^bold>\<rightarrow>\<pi><\<psi>|\<phi>>)\<rfloor>"
  sledgehammer (* proof found *)
  nitpick (* no counterexample found *)
  oops

lemma
  assumes  D : "\<lfloor>\<diamond>\<phi> \<^bold>\<rightarrow> (\<otimes><\<psi>|\<phi>> \<^bold>\<rightarrow>\<pi><\<psi>|\<phi>>)\<rfloor>"
  shows "totalness"
  sledgehammer (* timed out*)
  nitpick (* counterexample found *)
  oops

section \<open>Negative results\<close>

text \<open>Under the max and opt rules there is no formula corresponding to reflexivity\<close>

(*ToDO not sure how to do it--something like there is no A such that "reflexivity <\<Rightarrow> A"*)

text \<open>Under the max and opt rules there is no formula corresponding to totalness\<close>

(*ToDO*)

text \<open>Under the max rule there is no formula corresponding to transitivity\<close>

(*ToDO*)

text \<open>Under the max rule there is no formula corresponding to a-cyclicity\<close>

(*ToDO*)

text \<open>Under the max rule there is no formula corresponding to Suzumura consistency\<close>

(*ToDO*)

text \<open>Under the Lewis rule there is no formula corresponding to limitedness/smoothness\<close>

section \<open>Some open problems\<close>

text \<open>Under the opt rule transitivity alone is equivalent to Sp and Trans\<close>

lemma assumes "transitivity"
  shows  Sp: "\<lfloor>( \
<\<psi>|\<phi>> \<^bold>\<and> \<odot><(\<psi>\<^bold>\<rightarrow>\<chi>)|\<phi>>) \<^bold>\<rightarrow> \<odot><\<chi>|(\<phi>\<^bold>\<and>\<psi>)>\<rfloor>"
  sledgehammer (* proof found *)
  nitpick (* no counterexample found *)
  oops

lemma assumes "transitivity"
  shows  Trans: "\<lfloor>(\
<\<phi>|\<phi>\<^bold>\<or>\<psi>> \<^bold>\<and> \
<\<xi>|\<psi>\<^bold>\<or>\<xi>>)\<^bold>\<rightarrow>\
<\<xi>|\<phi>\<^bold>\<or>\<xi>>\<rfloor>"
  sledgehammer (* proof found *)
  nitpick (* no counterexample found *)
  oops

lemma assumes Sp: "\<lfloor>( \
<\<psi>|\<phi>> \<^bold>\<and> \<odot><(\<psi>\<^bold>\<rightarrow>\<chi>)|\<phi>>) \<^bold>\<rightarrow> \<odot><\<chi>|(\<phi>\<^bold>\<and>\<psi>)>\<rfloor>"
      assumes Trans: "\<lfloor>(\
<\<phi>|\<phi>\<^bold>\<or>\<psi>> \<^bold>\<and> \
<\<xi>|\<psi>\<^bold>\<or>\<xi>>)\<^bold>\<rightarrow>\
<\<xi>|\<phi>\<^bold>\<or>\<xi>>\<rfloor>"
      shows "transitivity"
  sledgehammer (* timed out*)
  nitpick (* counterexample found *)
  oops

  text \<open>Under the opt rule quasi-transitivity, a-cyclicity and Suzumura consistent do not correspond to
any formula\<close>

(*to do*)

text \<open>Under the opt rule transitivity alone is equivalent to Sp and Trans\<close>


theory RealNumbersAndSequences
  imports Main Natural Order
begin

chapter "I. Principles of the theory of real numbers"

section "1. The system of rational numbers and its gaps"

typedecl rational

datatype sign = pos | neg

axiomatization
      zero :: rational
  and quotient :: "sign \<Rightarrow> natural \<Rightarrow> natural \<Rightarrow> rational"
  where quotient_neq_zero: "zero \<noteq> quotient s a b"
    and quotient_eq: "(quotient s a b = quotient t c d) =
                      (s = t \<or> mul_nat a d = mul_nat b c)"
    and rational_exhaust: "(x = zero \<Longrightarrow> P) \<Longrightarrow> (x = quotient s a b \<Longrightarrow> P) \<Longrightarrow> P"

definition "quotient_simple s a b =
  (let c = gcd_nat a b in quotient s (div_nat a c) (div_nat b c))"

lemma quotient_eq_quotient_simple [simp]: "quotient s a b = quotient_simple s a b"
  by (metis quotient_simple_def rational_exhaust)

free_constructors case_rational for zero | quotient_simple s a b
proof -
  show "\<And>P y. (y = zero \<Longrightarrow> P) \<Longrightarrow> (\<And>s a b. y = quotient_simple s a b \<Longrightarrow> P) \<Longrightarrow> P"
    using rational_exhaust quotient_eq_quotient_simple by metis
  show "\<And>a b c x y z. (quotient_simple a b c = quotient_simple x y z) = (a = x \<and> b = y \<and> c = z)"
    apply (simp only: quotient_eq Let_def quotient_simple_def)
    apply standard

value "case quotient True 1 2 of (quotient a b c) \<Rightarrow> a"

-- "Fundamental Laws of Order"

theorem 1:
  "a = a"
  "a = b \<Longrightarrow> b = a"
  "a = b \<Longrightarrow> b = c \<Longrightarrow> a = c"
  "(a \<le> b \<and> b < c) \<or> (a < b \<and> b \<le> c) \<Longrightarrow> a < c"
  using order_class.trans by auto

class number = order +
  fixes add :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "+" 65)
  fixes sub :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "-" 65)
  fixes mul :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "*" 70)
  fixes div :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "'/" 70)
  fixes zero :: "'a"
  assumes addition:
    "\<exists> c. a + b = c"
    "a = a' \<Longrightarrow> b = b' \<Longrightarrow> a + b = a' + b'"
    "a + b = b + a"
    "(a + b) + c = a + (b + c)"
    "a < b \<Longrightarrow> a + c < b + c"
  assumes subtraction:
    "\<exists> c. a + c = b"
    "a + c = b \<Longrightarrow> b - a = c"
  assumes multiplication:
    "\<exists> c. a * b = c"
    "a = a' \<Longrightarrow> b = b' \<Longrightarrow> a * b = a' * b'"
    "a * b = b * a"
    "(a * b) * c = a * (b * c)"
    "a < b \<Longrightarrow> c > zero \<Longrightarrow> a * c < b * c"
  assumes division:
    "a \<noteq> zero \<Longrightarrow> \<exists> c. a * c = b"
    "a \<noteq> zero \<Longrightarrow> a * c = b \<Longrightarrow> b / a = c"

instantiation rational :: order
begin

definition lt_rational :: "rational \<Rightarrow> rational \<Rightarrow> bool" where
  "lt_rational a b = (case a of _ \<Rightarrow> _)"


(*  Title:      triangular.thy
    Author:     1f604
    Date:   6 June 2017

Triangular numbers.
*)

theory triangular imports Hoare_Logic  begin

lemma test:"k * (-1::int) = -k"
    apply auto
  done

lemma diff_mult_distrib2: "k * (m - n) = (k * m) - (k * n)"
  for k m n :: int
  by (fact right_diff_distrib')

lemma obvious: "a = b ⟹ b = a"
  apply auto
  done

lemma diff_mult_distrib5: "k * (k + n) = (k * k) + (k * n) ⟹ (k * k) + (k * n) = k * (k + n)"
  for k m n :: nat
  by (fact obvious)

lemma obvious3: "k * (k-  (1::int)) = (k *k) - (k *  (1::int))"
  for k n :: int
  apply (rule diff_mult_distrib2)
  done

lemma obvious4: " (k *k) - (k *  (1::int)) = k * k - k"
  apply auto
  done

lemma power: "a = b ⟹ a div 2 = b div 2 "
  apply auto
  done

lemma obvious6: "k * (k-  (1::int)) = k * k - k"
  for k :: int
  apply (simp add: obvious3 obvious4)
    done

lemma obvious7: "k * (k-  (1::int)) div 2 = (k * k - k) div 2"
  apply (rule power)
    apply (rule obvious6)
  done

lemma t0: "a div (2::int) + c = (a + (2::int) * c) div  (2::int)"
  apply (rule obvious)
    apply auto
done

lemma l1: " (k * k - k) div  (2::int) + k = (k *k - k + (2::int) * k) div (2::int) "
  apply auto
  done

lemma t1: " (k *k - k + (2::int) * k) = (k*k + k)"
  apply auto
  done

lemma l2: " (k *k - k + (2::int) * k) div  (2::int) = (k*k + k) div  (2::int)"
  apply auto
  done

lemma l3: " (k * k - k) div (2::int) + k = (k*k + k) div (2::int)"
  for k :: int
  apply (simp add: l1 l2)
  done

lemma l4: "k * (k-  (1::int)) div (2::int) + k = (k*k + k) div (2::int)"
  apply (simp add: obvious6)
  done

lemma t2: "(k * k + k) = (k + 1) * k"
  for k::int
  apply (rule  Semiring_Normalization.comm_semiring_1_class.semiring_normalization_rules(2))
    done

lemma l5: " (k * k + k) div 2 = (k + 1) * k div 2"
  for k::int
  apply (rule power)
    apply (rule t2)
    done

lemma triangular: "VARS s k n
 {n > 0}
s := (0::int);
k := (1::int);
 WHILE k < n
 INV {s = k * (k- (1::int)) div (2::int) & k ≤ n}
 DO s := s + k; k := k + (1::int) OD
 {s = n * (n- (1::int)) div (2::int)}"
  for k::int
  apply vcg_simp
    apply auto
    apply (simp add: l4 l5)
  done

end