theory TheoremD14
imports TheoremD13
begin

context LocalLexing begin

lemma empty_tokens_of_empty[simp]: "empty_tokens {} = {}"
  using empty_tokens_is_filter by blast

lemma items_le_split_via_eq: "items_le (Suc k) J = items_le k J \<union> items_eq (Suc k) J"
  by (auto simp add: items_le_def items_eq_def)

lemma paths_le_split_via_eq: "paths_le (Suc k) P = paths_le k P \<union> paths_eq (Suc k) P"
  by (auto simp add: paths_le_def paths_eq_def)

lemma natUnion_superset:
  shows "g i \<subseteq> natUnion g"
by (meson natUnion_elem subset_eq)

definition indexle :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
  "indexle k' u' k u = ((indexlt k' u' k u) \<or> (k' = k \<and> u' = u))"

definition produced_by_scan_step :: "('a, 'b) item \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
  "produced_by_scan_step x k u = (\<exists> k' u' y X. indexle k' u' k u \<and> y \<in> \<J> k' u' \<and>
   item_end y = k' \<and> X \<in> (\<T> k' u') \<and> x = inc_item y (k' + length (chars_of_token X)) \<and>
   next_symbol y = Some (terminal_of_token X))"

lemma indexle_trans: "indexle k'' u'' k' u' \<Longrightarrow> indexle k' u' k u \<Longrightarrow> indexle k'' u'' k u"
  using indexle_def indexlt_trans
proof -
  assume a1: "indexle k'' u'' k' u'"
  assume a2: "indexle k' u' k u"
  then have f3: "\<And>n na. u' = u \<or> indexlt n na k u \<or> \<not> indexlt n na k' u'"
    by (meson indexle_def indexlt_trans)
  have "\<And>n na. k' = k \<or> indexlt n na k u \<or> \<not> indexlt n na k' u'"
    using a2 by (meson indexle_def indexlt_trans)
  then show ?thesis
    using f3 a2 a1 indexle_def by auto
qed

lemma produced_by_scan_step_trans:
  assumes "indexle k' u' k u"
  assumes "produced_by_scan_step x k' u'"
  shows "produced_by_scan_step x k u"
proof -
  from iffD1[OF produced_by_scan_step_def assms(2)] obtain k'a u'a y X where produced_k'_u':
    "indexle k'a u'a k' u' \<and>
     y \<in> \<J> k'a u'a \<and>
     item_end y = k'a \<and>
     X \<in> \<T> k'a u'a \<and>
     x = inc_item y (k'a + length (chars_of_token X)) \<and> next_symbol y = Some (terminal_of_token X)"
     by blast
  then show ?thesis using indexle_trans assms(1) produced_by_scan_step_def by blast
qed

lemma \<J>_induct[consumes 1, case_names Induct]:
  assumes "x \<in> \<J> k u"
  assumes induct: "\<And> x k u . (\<And> x' k' u'. x' \<in> \<J> k' u' \<Longrightarrow> indexlt k' u' k u \<Longrightarrow> P x' k' u')
                     \<Longrightarrow> x \<in> \<J> k u \<Longrightarrow> P x k u"
  shows "P x k u"
proof -
  let ?R = "indexlt_rel <*lex*> {}"
  have wf_R: "wf ?R" by (auto simp add: wf_indexlt_rel)
  let ?P = "\<lambda> a. snd a \<in> \<J> (fst (fst a)) (snd (fst a)) \<longrightarrow> P (snd a) (fst (fst a)) (snd (fst a))"
  have "x \<in> \<J> k u \<longrightarrow> P x k u"
    apply (rule wf_induct[OF wf_R, where P = ?P and a = "((k, u), x)", simplified])
    apply (auto simp add: indexlt_def[symmetric])
    apply (rule_tac x=ba and k=a and u=b in induct)
    by auto
  thus ?thesis using assms by auto
qed

lemma \<pi>_no_tokens_item_end:
  assumes x_in_\<pi>: "x \<in> \<pi> k {} I"
  shows "item_end x = k \<or> x \<in> I"
proof -
  have x_in_limit: "x \<in> limit (\<lambda>I. Complete k (Predict k I)) I"
    using x_in_\<pi> \<pi>_no_tokens by auto
  then show ?thesis
  proof (induct rule: limit_induct)
    case (Init x) then show ?case by auto
  next
    case (Iterate x J)
      from Iterate(2) have "item_end x = k \<or> x \<in> Predict k J"
        using Complete_item_end by auto
      then show ?case
      proof (induct rule: disjCases2)
        case 1 then show ?case by blast
      next
        case 2
          then have "item_end x = k \<or> x \<in> J"
            using Predict_item_end by auto
          then show ?case
          proof (induct rule: disjCases2)
            case 1 then show ?case by blast
          next
            case 2 then show ?case using Iterate(1)[OF 2] by blast
          qed
      qed
  qed
qed

lemma natUnion_ex: "x \<in> natUnion f \<Longrightarrow> \<exists> i. x \<in> f i"
  by (metis (no_types, hide_lams) mk_disjoint_insert natUnion_superset natUnion_upperbound
    subsetCE subset_insert)

lemma locate_in_limit:
  assumes x_in_limit: "x \<in> limit f X"
  assumes x_notin_X: "x \<notin> X"
  shows "\<exists> n. x \<in> funpower f (Suc n) X \<and> x \<notin> funpower f n X"
proof -
  have "\<exists> N. x \<in> funpower f N X" using x_in_limit limit_def natUnion_ex by fastforce
  then obtain N where N: "x \<in> funpower f N X" by blast
  {
    fix n :: nat
    have "x \<in> funpower f n X \<Longrightarrow> \<exists> m < n. x \<in> funpower f (Suc m) X \<and> x \<notin> funpower f m X"
    proof (induct n)
      case 0
        with x_notin_X show ?case by auto
    next
      case (Suc n)
        have "x \<notin> funpower f n X \<or> x \<in> funpower f n X" by blast
        then show ?case
        proof (induct rule: disjCases2)
          case 1
            then show ?case using Suc by fastforce
        next
          case 2
            from Suc(1)[OF 2] show ?case using less_SucI by blast
        qed
    qed
  }
  with N show ?thesis by auto
qed

lemma produced_by_scan_step:
  "x \<in> \<J> k u \<Longrightarrow> item_end x > k \<Longrightarrow> produced_by_scan_step x k u"
proof (induct rule: \<J>_induct)
  case (Induct x k u)
    have "(k = 0 \<and> u = 0) \<or> (k > 0 \<and> u = 0) \<or> (u > 0)" by arith
    then show ?case
    proof (induct rule: disjCases3)
      case 1
        with Induct have "item_end x = 0" using \<J>_0_0_item_end by blast
        with Induct have "False" by arith
        then show ?case by  blast
    next
      case 2
        then obtain k' where k': "k = Suc k'" using Suc_pred' by blast
        with Induct 2 have "x \<in> \<J> (Suc k') 0" by auto
        then have "x \<in> \<pi> k {} (\<I> k')" by (simp add: k')
        then have "item_end x = k \<or> x \<in> \<I> k'" using \<pi>_no_tokens_item_end by blast
        then show ?case
        proof (induct rule: disjCases2)
          case 1
            with Induct have "False" by auto
            then show ?case by blast
        next
          case 2
            then have "\<exists> u'. x \<in> \<J> k' u'" using \<I>.simps natUnion_ex by fastforce
            then obtain u' where u': "x \<in> \<J> k' u'" by blast
            have k'_bound: "k' < item_end x" using k' Induct by arith
            have indexlt: "indexlt k' u' k u" by (simp add: indexlt_simp k')
            from Induct(1)[OF u' this k'_bound]
            have pred_produced: "produced_by_scan_step x k' u'" .
            then show ?case using indexlt produced_by_scan_step_trans indexle_def by blast
        qed
    next
      case 3
        then have ex_u': "\<exists> u'. u = Suc u'" by arith
        then obtain u' where u': "u = Suc u'" by blast
        with Induct have "x \<in> \<J> k (Suc u')" by metis
        then have x_in_\<pi>: "x \<in> \<pi> k (\<T> k u) (\<J> k u')" using u' \<J>.simps by metis
        have "x \<in> \<J> k u' \<or> x \<notin> \<J> k u'" by blast
        then show ?case
        proof (induct rule: disjCases2)
          case 1
            have indexlt: "indexlt k u' k u" by (simp add: indexlt_simp u')
            with Induct(1)[OF 1 indexlt Induct(3)] show ?case
              using indexle_def produced_by_scan_step_trans by blast
        next
          case 2
            have item_end_x: "k < item_end x" using Induct by auto
            obtain f where f: "f = Scan (\<T> k u) k \<circ> Complete k \<circ> Predict k" by blast
            have "x \<in> limit f (\<J> k u')"
              using x_in_\<pi> \<pi>_functional f by simp
            from locate_in_limit[OF this 2] obtain n where n:
              "x \<in> funpower f (Suc n) (\<J> k u') \<and>
               x \<notin> funpower f n (\<J> k u')" by blast
            obtain Y where Y: "Y = funpower f n (\<J> k u')"
              by blast
            have x_f_Y: "x \<in> f Y \<and> x \<notin> Y" using Y n by auto
            then have "x \<in> Scan (\<T> k u) k (Complete k (Predict k Y))" using comp_apply f by simp
            then have "x \<in> (Complete k (Predict k Y)) \<or>
              x \<in> { inc_item x' (k + length c) | x' t c. x' \<in> bin (Complete k (Predict k Y)) k \<and>
                    (t, c) \<in> (\<T> k u) \<and> next_symbol x' = Some t }" using Scan_def by simp
            then show ?case
            proof (induct rule: disjCases2)
              case 1
                then have "False" using item_end_x x_f_Y Complete_item_end Predict_item_end
                  using less_not_refl3 by blast
                then show ?case by auto
            next
              case 2
                have "Y \<subseteq> limit f (\<J> k u')" using Y limit_def natUnion_superset by fastforce
                then have "Y \<subseteq> \<pi> k (\<T> k u) (\<J> k u')" using f by (simp add: \<pi>_functional)
                then have Y_in_\<J>: "Y \<subseteq> \<J> k u" using u' by simp
                then have in_\<J>: "Complete k (Predict k Y) \<subseteq> \<J> k u"
                proof - (* automatically generated *)
                  have f1: "\<forall>f I Ia i. (\<not> mono f \<or> \<not> (I::('a, 'b)item set) \<subseteq> Ia \<or> (i::('a, 'b)item) \<notin> f I) \<or> i \<in> f Ia"
                    by (meson mono_subset_elem)
                  obtain ii :: "('a, 'b) item set \<Rightarrow> ('a, 'b) item set \<Rightarrow> ('a, 'b)item" where
                    "\<forall>x0 x1. (\<exists>v2. v2 \<in> x1 \<and> v2 \<notin> x0) = (ii x0 x1 \<in> x1 \<and> ii x0 x1 \<notin> x0)"
                    by moura
                  then have f2: "\<forall>I Ia. ii Ia I \<in> I \<and> ii Ia I \<notin> Ia \<or> I \<subseteq> Ia"
                    by blast
                  obtain nn :: nat where
                    f3: "u = Suc nn"
                    using ex_u' by presburger
                  moreover
                  { assume "ii (\<J> k u) (Complete k (Predict k Y)) \<in> Complete k (\<pi> k (\<T> k (Suc nn)) (\<J> k nn))"
                    then have ?thesis
                      using f3 f2 Complete_\<pi>_fix by auto }
                  ultimately show ?thesis
                    using f2 f1 by (metis (full_types) Complete_regular Predict_\<pi>_fix Predict_regular
                      \<J>.simps(2) Y_in_\<J> regular_implies_mono)
                qed
                from 2 obtain  x' t c where x'_t_c:
                  "x = inc_item x' (k + length c) \<and> x' \<in> bin (Complete k (Predict k Y)) k \<and>
                    (t, c) \<in> \<T> k u \<and> next_symbol x' = Some t" by blast
                show ?case
                  apply (simp add: produced_by_scan_step_def)
                  apply (rule_tac x=k in exI)
                  apply (rule_tac x=u in exI)
                  apply (simp add: indexle_def)
                  apply (rule_tac x=x' in exI)
                  apply auto
                  using x'_t_c bin_def in_\<J> apply auto[1]
                  using x'_t_c bin_def apply blast
                  apply (rule_tac x=t in exI)
                  apply (rule_tac x=c in exI)
                  using x'_t_c by auto
            qed
        qed
    qed
qed

lemma limit_single_step:
  assumes "x \<in> f X"
  shows "x \<in> limit f X"
by (metis assms elem_limit_simp funpower.simps(1) funpower.simps(2))

lemma Gen_union: "Gen (A \<union> B) = Gen A \<union> Gen B"
  by (simp add: Gen_def, blast)

lemma is_prefix_Prefixes_subset:
  assumes "is_prefix q p"
  shows "Prefixes q \<subseteq> Prefixes p"
proof -
  show ?thesis
    apply (auto simp add: Prefixes_def)
    using assms by (metis is_prefix_append is_prefix_def)
qed

lemma Prefixes_subset_\<P>:
  assumes "p \<in> \<P> k u"
  shows "Prefixes p \<subseteq> \<P> k u"
using Prefixes_is_prefix assms prefixes_are_paths by blast

lemma Prefixes_subset_paths_le:
  assumes "Prefixes p \<subseteq> P"
  shows "Prefixes p \<subseteq> paths_le (charslength p) P"
using Prefixes_is_prefix assms charslength_of_prefix paths_le_def by auto

lemma Scan_\<J>_subset_\<J>:
  "Scan (\<T> k (Suc u)) k (\<J> k u) \<subseteq> \<J> k (Suc u)"
by (metis (no_types, lifting) Scan_\<pi>_fix \<J>.simps(2) \<J>_subset_Suc_u monoD mono_Scan)

lemma subset_\<J>k: "u \<le> v \<Longrightarrow> \<J> k u \<subseteq> \<J> k v"
  thm \<J>_subset_Suc_u
  by (rule subset_fSuc, rule \<J>_subset_Suc_u)

lemma subset_\<J>\<I>k: "\<J> k u \<subseteq> \<I> k" by (auto simp add: natUnion_def)

lemma subset_\<I>\<J>Suc: "\<I> k \<subseteq> \<J> (Suc k) u"
proof -
  have a: "\<I> k \<subseteq> \<J> (Suc k) 0"
    apply (simp only: \<J>.simps)
    using \<pi>_apply_setmonotone by blast
  show ?thesis
    apply (case_tac "u = 0")
    apply (simp only: a)
    apply (rule subset_trans[OF a subset_\<J>k])
    by auto
qed

lemma subset_\<I>Suc: "\<I> k \<subseteq> \<I> (Suc k)"
  by (rule subset_trans[OF subset_\<I>\<J>Suc subset_\<J>\<I>k])

lemma subset_\<I>: "i \<le> j \<Longrightarrow> \<I> i \<subseteq> \<I> j"
  by (rule subset_fSuc[where u=i and v=j and f = \<I>, OF subset_\<I>Suc])

lemma subset_\<J> :
  assumes leq: "k' < k \<or> (k' = k \<and> u' \<le> u)"
  shows "\<J> k' u' \<subseteq> \<J> k u"
proof -
  from leq show ?thesis
  proof (induct rule: disjCases2)
    case 1
    have s1: "\<J> k' u' \<subseteq> \<I> k'" by (rule_tac subset_\<J>\<I>k)
    have s2: "\<I> k' \<subseteq> \<I> (k - 1)"
      apply (rule_tac subset_\<I>)
      using 1 by arith
    from subset_\<I>\<J>Suc[where k="k - 1"] 1 have s3: "\<I> (k - 1) \<subseteq> \<J> k 0"
      by simp
    have s4: "\<J> k 0 \<subseteq> \<J> k u" by (rule_tac subset_\<J>k, simp)
    from s1 s2 s3 s4 subset_trans show ?case by blast
  next
    case 2 thus ?case by (simp add : subset_\<J>k)
  qed
qed

lemma \<J>_subset:
  assumes "indexle k' u' k u"
  shows "\<J> k' u' \<subseteq> \<J> k u"
using subset_\<J> indexle_def indexlt_simp
by (metis assms less_imp_le_nat order_refl)

lemma Scan_items_le:
  assumes bounded_T: "\<And> t . t \<in> T \<Longrightarrow> length (chars_of_token t) \<le> l"
  shows "Scan T k (items_le k P) \<subseteq> items_le (k + l) (Scan T k P)"
proof -
  {
    fix x :: "('a, 'b) item"
    assume x_dom: "x \<in> Scan T k (items_le k P)"
    then have x_dom': "x \<in> Scan T k P"
      by (meson items_le_is_filter mono_Scan mono_subset_elem)
    from x_dom have "x \<in> items_le k P \<or>
      (\<exists> y t c. x = inc_item y (k + length c) \<and> y \<in> bin (items_le k P) k \<and> (t, c) \<in> T
       \<and> next_symbol y = Some t)"
      using Scan_def using UnE mem_Collect_eq by auto
    then have "item_end x \<le> k + l"
    proof (induct rule: disjCases2)
      case 1 then show ?case
        by (meson items_le_fix_D items_le_idempotent trans_le_add1)
    next
      case 2
        then obtain y t c where y: "x = inc_item y (k + length c) \<and> y \<in> bin (items_le k P) k \<and>
          (t, c) \<in> T \<and> next_symbol y = Some t" by blast
        then have item_end_x: "item_end x = (k + length c)" by simp
        from bounded_T y have "length c \<le> l"
          using chars_of_token_simp by auto
        with item_end_x show ?case by arith
    qed
    with x_dom' have "x \<in> items_le (k + l) (Scan T k P)"
      using items_le_def mem_Collect_eq by blast
  }
  then show ?thesis by blast
qed

lemma Scan_mono_tokens:
  "P \<subseteq> Q \<Longrightarrow> Scan P k I \<subseteq> Scan Q k I"
by (auto simp add: Scan_def)

theorem thmD14: "k \<le> length Doc \<Longrightarrow> items_le k (\<J> k u) = Gen (paths_le k (\<P> k u)) \<and> \<T> k u = \<Z> k u
    \<and> items_le k (\<I> k) = Gen (paths_le k (\<Q> k))"
proof (induct k arbitrary: u rule: less_induct)
  case (less k)
    have "k = 0 \<or> k \<noteq> 0" by arith
    then show ?case
    proof (induct rule: disjCases2)
      case 1
        have \<J>_eq_\<P>: "items_le k (\<J> k 0) = Gen (paths_le k (\<P> k 0))"
          by (simp only: 1 thmD8 items_le_paths_le)
        show ?case using thmD13[OF \<J>_eq_\<P> less.prems] by blast
    next
      case 2
        have "\<exists> k'. k = Suc k'" using 2 by arith
        then obtain k' where k': "k = Suc k'" by blast
        have k'_less_k: "k' < k" using k' by arith
        have "items_le k (\<J> k 0) = Gen (paths_le k (\<P> k 0))"
        proof -
          have simp_left: "items_le k (\<J> k 0) = \<pi> k {} (items_le k (\<I> k'))"
            using items_le_\<pi>_swap k' wellformed_items_\<I> by auto
          have simp_right: "Gen (paths_le k (\<P> k 0)) = natUnion (\<lambda> v. Gen (paths_le k (\<P> k' v)))"
            by (simp add: k' paths_le_pointwise pointwise_Gen pointwise_natUnion_swap)
          {
            fix v :: nat
            have split_\<J>: "items_le k (\<J> k' v) = items_le k' (\<J> k' v) \<union> items_eq k (\<J> k' v)"
              using k'  items_le_split_via_eq by blast
            have sub1: "items_le k' (\<J> k' v) \<subseteq> natUnion (\<lambda> v. Gen (paths_le k (\<P> k' v)))"
            proof -
              have h: "items_le k' (\<J> k' v) \<subseteq> Gen (paths_le k (\<P> k' v))"
              proof - (* automatically generated *)
                have f1: "items_le k' (Gen (\<P> k' v)) \<union> items_eq (Suc k') (Gen (\<P> k' v)) =
                  Gen (paths_le k (\<P> k' v))"
                  using LocalLexing.items_le_split_via_eq LocalLexing_axioms items_le_paths_le k'
                  by blast
                have "k' \<le> length Doc"
                  by (metis (no_types) dual_order.trans k' less.prems lessI less_imp_le_nat)
                then have "items_le k' (\<J> k' v) = items_le k' (Gen (\<P> k' v))"
                  by (simp add: items_le_paths_le k' less.hyps)
                then show ?thesis
                  using f1 by blast
              qed
              have "Gen (paths_le k (\<P> k' v)) \<subseteq> natUnion (\<lambda> v. Gen (paths_le k (\<P> k' v)))"
                using natUnion_superset by fastforce
              then show ?thesis using h by blast
            qed
            {
              fix x :: "('a, 'b) item"
              assume x_dom: "x \<in> items_eq k (\<J> k' v)"
              have x_in_\<J>: "x \<in> \<J> k' v" using x_dom items_eq_def by auto
              have item_end_x: "item_end x = k" using x_dom items_eq_def by auto
              then have k'_bound: "k' < item_end x" using k' by arith
              from produced_by_scan_step[OF x_in_\<J> k'_bound]
              have "produced_by_scan_step x k' v" .
              from iffD1[OF produced_by_scan_step_def this] obtain k'' v'' y X where scan_step:
                "indexle k'' v'' k' v \<and> y \<in> \<J> k'' v'' \<and> item_end y = k'' \<and> X \<in> \<T> k'' v'' \<and>
                 x = inc_item y (k'' + length (chars_of_token X)) \<and>
                 next_symbol y = Some (terminal_of_token X)" by blast
              then have y_in_items_le: "y \<in> items_le k'' (\<J> k'' v'')"
                using items_le_def LocalLexing_axioms le_refl mem_Collect_eq by blast
              have y_in_Gen: "y \<in> Gen(paths_le k'' (\<P> k'' v''))"
              proof - (* automatically generated *)
                have f1: "\<And>n. k' < n \<or> \<not> k < n"
                  using Suc_lessD k' by blast
                have f2: "k'' = k' \<or> k'' < k'"
                  using indexle_def indexlt_simp scan_step by force
                have f3: "k' < k"
                  using k' by blast
                have f4: "k' \<le> length Doc"
                  using f1 by (meson less.prems less_Suc_eq_le)
                have "k'' \<le> length Doc \<or> k' = k''"
                  using f2 f1 by (meson Suc_lessD less.prems less_Suc_eq_le less_trans_Suc)
                then show ?thesis
                  using f4 f3 f2 Suc_lessD y_in_items_le less.hyps less_trans_Suc by blast
              qed
              then have "\<exists> p. p \<in> \<P> k'' v'' \<and> pvalid p y"
                by (meson Gen_implies_pvalid paths_le_is_filter rev_subsetD)
              then obtain p where p: "p \<in> \<P> k'' v'' \<and> pvalid p y" by blast
              then have charslength_p: "charslength p = k''" using pvalid_item_end scan_step by auto
              have pvalid_p_y: "pvalid p y" using p by blast
              have "admissible (p@[(fst X, snd X)])"
                apply (rule pvalid_next_terminal_admissible)
                apply (rule pvalid_p_y)
                using scan_step apply (simp add: terminal_of_token_def)
                using scan_step by (metis TokensAt_subset_\<X> \<T>_subset_TokensAt \<X>_are_terminals
                  rev_subsetD terminal_of_token_def)
              then have admissible_p_X: "admissible (p@[X])" by simp
              have X_in_\<Z>: "X \<in> \<Z> k'' (Suc v'')" by (metis (no_types, lifting) Suc_lessD \<Z>_subset_Suc
                k'_bound dual_order.trans indexle_def indexlt_simp item_end_of_inc_item item_end_x
                le_add1 le_neq_implies_less less.hyps less.prems not_less_eq scan_step subsetCE)
              have pX_in_\<P>_k''_v'': "p@[X] \<in> \<P> k'' (Suc v'')"
                apply (simp only: \<P>.simps)
                apply (rule limit_single_step)
                apply (auto simp only: Append_def)
                apply (rule_tac x=p in exI)
                apply (rule_tac x=X in exI)
                apply (simp only: admissible_p_X X_in_\<Z>)
                using charslength_p p by auto
              have "indexle k'' v'' k' v" using scan_step by simp
              then have "indexle k'' (Suc v'') k' (Suc v)"
                by (simp add: indexle_def indexlt_simp)
              then have "\<P> k'' (Suc v'') \<subseteq> \<P> k' (Suc v)"
                by (metis indexle_def indexlt_simp less_or_eq_imp_le subset_\<P>)
              with pX_in_\<P>_k''_v'' have pX_in_\<P>_k': "p@[X] \<in> \<P> k' (Suc v)" by blast
              have "charslength (p@[X]) = k'' +  length (chars_of_token X)"
                using charslength_p by auto
              then have "charslength (p@[X]) = item_end x" using scan_step by simp
              then have charslength_p_X: "charslength (p@[X]) = k" using item_end_x by simp
              then have pX_dom: "p@[X] \<in> paths_le k (\<P> k' (Suc v))"
                using lessI less_Suc_eq_le mem_Collect_eq pX_in_\<P>_k' paths_le_def by auto
              have wellformed_x: "wellformed_item x"
                using item_end_x less.prems scan_step wellformed_inc_item wellformed_items_\<J>
                  wellformed_items_def by auto
              have wellformed_p_X: "wellformed_tokens (p@[X])"
                using \<P>_wellformed pX_in_\<P>_k''_v'' by blast
              from iffD1[OF pvalid_def pvalid_p_y] obtain r \<gamma> where r_\<gamma>:
                "wellformed_tokens p \<and>
                 wellformed_item y \<and>
                 r \<le> length p \<and>
                 charslength p = item_end y \<and>
                 charslength (take r p) = item_origin y \<and>
                 is_derivation (terminals (take r p) @ [item_nonterminal y] @ \<gamma>) \<and>
                 derives (item_\<alpha> y) (terminals (drop r p))" by blast
              have r_le_p: "r \<le> length p" by (simp add: r_\<gamma>)
              have item_nonterminal_x: "item_nonterminal x = item_nonterminal y"
                by (simp add: scan_step)
              have item_\<alpha>_x: "item_\<alpha> x = (item_\<alpha> y) @ [terminal_of_token X]"
                by (simp add: item_\<alpha>_of_inc_item r_\<gamma> scan_step)
              have pvalid_x: "pvalid (p@[X]) x"
                apply (auto simp add: pvalid_def wellformed_x wellformed_p_X)
                apply (rule_tac x=r in exI)
                apply auto
                apply (simp add: le_SucI r_\<gamma>)
                using r_\<gamma> scan_step apply auto[1]
                using r_\<gamma> scan_step apply auto[1]
                apply (rule_tac x=\<gamma> in exI)
                apply (simp add: r_le_p item_nonterminal_x)
                using r_\<gamma> apply simp
                apply (simp add: r_le_p item_\<alpha>_x)
                by (metis terminals_singleton append_Nil2
                  derives_implies_leftderives derives_is_sentence is_sentence_concat
                  is_sentence_cons is_symbol_def is_word_append is_word_cons is_word_terminals
                  is_word_terminals_drop leftderives_implies_derives leftderives_padback
                  leftderives_refl r_\<gamma> terminals_append terminals_drop wellformed_p_X)
              then have "x \<in> Gen (paths_le k (\<P> k' (Suc v)))" using pX_dom Gen_def
                LocalLexing_axioms mem_Collect_eq by auto
            }
            then have sub2: "items_eq k (\<J> k' v) \<subseteq> natUnion (\<lambda> v. Gen (paths_le k (\<P> k' v)))"
              by (meson dual_order.trans natUnion_superset subsetI)
            have suffices3: "items_le k (\<J> k' v) \<subseteq> natUnion (\<lambda> v. Gen (paths_le k (\<P> k' v)))"
              using split_\<J> sub1 sub2 by blast
            have "items_le k (\<J> k' v) \<subseteq> Gen (paths_le k (\<P> k 0))"
              using suffices3 simp_right by blast
          }
          note suffices2 = this
          have items_le_natUnion_swap: "items_le k (\<I> k') = natUnion(\<lambda> v. items_le k (\<J> k' v))"
            by (simp add: items_le_pointwise pointwise_natUnion_swap)
          then have suffices1: "items_le k (\<I> k') \<subseteq> Gen (paths_le k (\<P> k 0))"
            using suffices2 natUnion_upperbound by metis
          have sub_lemma: "items_le k (\<J> k 0) \<subseteq> Gen (paths_le k (\<P> k 0))"
          proof -
            have "items_le k (\<J> k 0) \<subseteq> Gen (\<P> k 0)"
              apply (subst simp_left)
              apply (rule thmD5)
              apply (auto simp only: less)
              using suffices1 items_le_is_filter items_le_paths_le subsetCE by blast
            then show ?thesis
              by (simp add: items_le_idempotent remove_paths_le_in_subset_Gen)
          qed
          have eq1: "\<pi> k {} (items_le k (\<I> k')) = \<pi> k {} (items_le k (natUnion (\<J> k')))" by simp
          then have eq2: "\<pi> k {} (items_le k (natUnion (\<J> k'))) =
            \<pi> k {} (natUnion (\<lambda> v. items_le k (\<J> k' v)))"
            using items_le_natUnion_swap by auto
          from simp_left eq1 eq2
          have simp_left': "items_le k (\<J> k 0) = \<pi> k {} (natUnion (\<lambda> v. items_le k (\<J> k' v)))"
            by metis
          {
            fix v :: nat
            fix q :: "('a, 'b, 'c)token list"
            fix x :: "('a, 'b) item"
            assume q_dom: "q \<in> paths_eq k (\<P> k' v)"
            assume pvalid_q_x: "pvalid q x"
            have q_in_\<P>: "q \<in> \<P> k' v" using q_dom paths_eq_def by auto
            have charslength_q: "charslength q = k" using q_dom paths_eq_def by auto
            with k'_less_k have q_nonempty: "q \<noteq> []"
              using "2.hyps" chars.simps(1) charslength.simps list.size(3) by auto
            then have "\<exists> p X. q = p @ [X]" by (metis append_butlast_last_id)
            then obtain p X where pX: "q = p @ [X]" by blast
            from last_step_of_path[OF q_in_\<P> pX] obtain k'' v'' where k'':
              "indexlt k'' v'' k' v \<and> q \<in> \<P> k'' (Suc v'') \<and> charslength p = k'' \<and>
               X \<in> \<Z> k'' (Suc v'')" by blast
            have h1: "p \<in> \<PP>"
              by (metis (no_types, lifting) LocalLexing.\<PP>_covers_\<P> LocalLexing_axioms
                append_Nil2 is_prefix_cancel is_prefix_empty pX prefixes_are_paths q_in_\<P> subsetCE)
            have h2: "charslength p = k''" using k'' by blast
            obtain T where T: "T = {X}" by blast
            have h3: "X \<in> T" using T by blast
            have h4: "T \<subseteq> \<X> k''" using \<Z>_subset_\<X> T k'' by blast
            obtain N where N: "N = item_nonterminal x" by blast
            obtain \<alpha> where \<alpha>: "\<alpha> = item_\<alpha> x" by blast
            obtain \<beta> where \<beta>: "\<beta> = item_\<beta> x" by blast
            have wellformed_x: "wellformed_item x" using pvalid_def pvalid_q_x by blast
            then have h5: "(N, \<alpha> @ \<beta>) \<in> \<RR>"
              using N \<alpha> \<beta> item_nonterminal_def item_rhs_def item_rhs_split prod.collapse
                wellformed_item_def by metis
            have pvalid_left_q_x: "pvalid_left q x" using pvalid_q_x by (simp add: pvalid_left)
            from iffD1[OF pvalid_left_def pvalid_left_q_x] obtain r \<gamma> where r_\<gamma>:
              "wellformed_tokens q \<and>
               wellformed_item x \<and>
               r \<le> length q \<and>
               charslength q = item_end x \<and>
               charslength (take r q) = item_origin x \<and>
               is_leftderivation (terminals (take r q) @ [item_nonterminal x] @ \<gamma>) \<and>
               leftderives (item_\<alpha> x) (terminals (drop r q))" by blast
            have h6: "r \<le> length q" using r_\<gamma> by blast
            have h7: "leftderives [\<SS>] (terminals (take r q) @ [N] @ \<gamma>)"
              using r_\<gamma> N is_leftderivation_def by blast
            have h8: "leftderives \<alpha> (terminals (drop r q))" using r_\<gamma> \<alpha> by metis
            have h9: "k = k'' + length (chars_of_token X)" using r_\<gamma>
              using charslength_q h2 pX by auto
            have h10: "x = Item (N, \<alpha> @ \<beta>) (length \<alpha>) (charslength (take r q)) k"
              by (metis N \<alpha> \<beta> charslength_q item.collapse item_dot_is_\<alpha>_length item_nonterminal_def
                item_rhs_def item_rhs_split prod.collapse r_\<gamma>)
            from thmD11[OF h1 h2 h3 h4 pX h5 h6 h7 h8 h9 h10]
            have "x \<in> items_le k (\<pi> k {} (Scan T k'' (Gen (Prefixes p))))"
              by blast
            then have x_in: "x \<in> \<pi> k {} (Scan T k'' (Gen (Prefixes p)))"
              using items_le_is_filter by blast
            have subset1: "Prefixes p \<subseteq> Prefixes q"
              apply (rule is_prefix_Prefixes_subset)
              by (simp add: pX is_prefix_def)
            have subset2: "Prefixes q \<subseteq> \<P> k'' (Suc v'')"
              apply (rule Prefixes_subset_\<P>)
              using k'' by blast
            from subset1 subset2 have "Prefixes p \<subseteq> \<P> k'' (Suc v'')" by blast
            then have "Prefixes p \<subseteq> paths_le k'' (\<P> k'' (Suc v''))"
              using k'' Prefixes_subset_paths_le by blast
            then have subset3: "Gen (Prefixes p) \<subseteq> Gen (paths_le k'' (\<P> k'' (Suc v'')))"
              using Gen_def LocalLexing_axioms by auto
            have k''_less_k: "k'' < k" using k'' k' using indexlt_simp less_Suc_eq by auto
            then have k''_Doc_bound: "k'' \<le> length Doc" using less by auto
            from less(1)[OF k''_less_k k''_Doc_bound, of "Suc v''"]
            have induct1: "items_le k'' (\<J> k'' (Suc v'')) = Gen (paths_le k'' (\<P> k'' (Suc v'')))"
              by blast
            from less(1)[OF k''_less_k k''_Doc_bound, of "Suc(Suc v'')"]
            have induct2: "\<T> k'' (Suc (Suc v'')) = \<Z> k'' (Suc (Suc v''))" by blast
            have subset4: "Gen (Prefixes p) \<subseteq> items_le k'' (\<J> k'' (Suc v''))"
              using subset3 induct1 by auto
            from induct1 subset4
            have subset6: "Scan T k'' (Gen (Prefixes p)) \<subseteq>
              Scan T k'' (items_le k'' (\<J> k'' (Suc v'')))"
              apply (rule_tac monoD[OF mono_Scan])
              by blast
            have "k'' + length (chars_of_token X) = k"
              by (simp add: h9)
            have "\<And> t. t \<in> T \<Longrightarrow> length (chars_of_token t) \<le> length (chars_of_token X)"
              using T by auto
            from Scan_items_le[of T, OF this, simplified, of k'' "\<J> k'' (Suc v'')"] h9
            have subset7: "Scan T k'' (items_le k'' (\<J> k'' (Suc v'')))
              \<subseteq> items_le k (Scan T k'' (\<J> k'' (Suc v'')))" by simp
            have "T \<subseteq> \<Z> k'' (Suc (Suc v''))" using T k''
              using \<Z>_subset_Suc rev_subsetD singletonD subsetI by blast
            then have T_subset_\<T>: "T \<subseteq> \<T> k'' (Suc (Suc v''))" using induct2 by auto
            have subset8: "Scan T k'' (\<J> k'' (Suc v'')) \<subseteq>
              Scan (\<T> k'' (Suc (Suc v''))) k'' (\<J> k'' (Suc v''))"
              using T_subset_\<T> Scan_mono_tokens by blast
            have subset9: "Scan (\<T> k'' (Suc (Suc v''))) k'' (\<J> k'' (Suc v'')) \<subseteq> \<J> k'' (Suc (Suc v''))"
              by (rule Scan_\<J>_subset_\<J>)
            have subset10: "(Scan T k'' (\<J> k'' (Suc v''))) \<subseteq> \<J> k'' (Suc (Suc v''))"
              using subset8 subset9 by blast
            have "k'' \<le> k'" using k'' indexlt_simp by auto
            then have "indexle k'' (Suc (Suc v'')) k' (Suc (Suc v''))" using indexlt_simp
              using indexle_def le_neq_implies_less by auto
            then have subset11: "\<J> k'' (Suc (Suc v'')) \<subseteq> \<J> k' (Suc (Suc v''))"
              using \<J>_subset by blast
            have subset12: "Scan T k'' (\<J> k'' (Suc v'')) \<subseteq> \<J> k' (Suc (Suc v''))"
              using subset8 subset9 subset10 subset11 by blast
            then have subset13: "items_le k (Scan T k'' (\<J> k'' (Suc v''))) \<subseteq>
              items_le k (\<J> k' (Suc (Suc v'')))"
              using items_le_def mem_Collect_eq rev_subsetD subsetI by auto
            have subset14: "Scan T k'' (Gen (Prefixes p)) \<subseteq> items_le k (\<J> k' (Suc (Suc v'')))"
              using subset6 subset7 subset13 by blast
            then have x_in': "x \<in> \<pi> k {} (items_le k (\<J> k' (Suc (Suc v''))))"
              using x_in
              by (meson \<pi>_apply_setmonotone \<pi>_subset_elem_trans subsetCE subsetI)
            from x_in' have "x \<in> \<pi> k {} (natUnion (\<lambda> v. items_le k (\<J> k' v)))"
              by (meson k' mono_\<pi> mono_subset_elem natUnion_superset)
          }
          note suffices6 = this
          {
            fix v :: nat
            have "Gen (paths_eq k (\<P> k' v)) \<subseteq> \<pi> k {} (natUnion (\<lambda> v. items_le k (\<J> k' v)))"
              using suffices6 by (meson Gen_implies_pvalid subsetI)
          }
          note suffices5 = this
          {
            fix v :: nat
            have "paths_le k (\<P> k' v) = paths_le k' (\<P> k' v) \<union> paths_eq k (\<P> k' v)"
              using  paths_le_split_via_eq k' by metis
            then have Gen_split: "Gen (paths_le k (\<P> k' v)) =
              Gen (paths_le k' (\<P> k' v)) \<union> Gen(paths_eq k (\<P> k' v))" using Gen_union by metis
            have case_le: "Gen (paths_le k' (\<P> k' v)) \<subseteq>  \<pi> k {} (natUnion (\<lambda> v. items_le k (\<J> k' v)))"
            proof -
              from less k'_less_k have "k' \<le> length Doc" by arith
              from less(1)[OF k'_less_k this]
              have "items_le k' (\<J> k' v) = Gen (paths_le k' (\<P> k' v))" by blast
              then have "Gen (paths_le k' (\<P> k' v)) \<subseteq> natUnion (\<lambda> v. items_le k (\<J> k' v))"
                using items_le_def LocalLexing_axioms k'_less_k natUnion_superset by fastforce
              then show ?thesis using \<pi>_apply_setmonotone by blast
            qed
            have "Gen (paths_le k (\<P> k' v)) \<subseteq> \<pi> k {} (natUnion (\<lambda> v. items_le k (\<J> k' v)))"
              using Gen_split case_le suffices5 UnE rev_subsetD subsetI by blast
          }
          note suffices4 = this
          have super_lemma: "Gen (paths_le k (\<P> k 0)) \<subseteq> items_le k (\<J> k 0)"
            apply (subst simp_right)
            apply (subst simp_left')
            using suffices4 by (meson natUnion_ex rev_subsetD subsetI)
          from super_lemma sub_lemma show ?thesis by blast
        qed
        then show ?case using thmD13 less.prems by blast
    qed
qed

end

end


(*<*)
theory Ate_Proofs
imports "../Voting_Opt" Ate_Defs Heard_Of.Majorities
  "../HO_Transition_System"
begin
(*>*)

subsection \<open>Proofs\<close>
axiomatization where val_linorder:
  "OFCLASS(val, linorder_class)"

instance val :: linorder by (rule val_linorder)

context ate_parameters
begin

definition majs :: "(process set) set" where
  "majs \<equiv> {S. card S > E}"

interpretation majorities: quorum_process majs
proof
  fix Q Q' assume "Q \<in> majs" "Q' \<in> majs"
  hence "N < card Q + card Q'" using majE
    by(auto simp add: majs_def)
  thus "Q \<inter> Q' \<noteq> {}"
    apply (intro majorities_intersect)
    apply(auto)
    done
next
  from EltN
  show "\<exists>Q. Q \<in> majs"
    apply(rule_tac x=UNIV in exI)
    apply(auto simp add: majs_def intro!: div_less_dividend)
    done
qed

type_synonym p_TS_state = "(nat \<times> (process \<Rightarrow> (val pstate)))"

definition K where
  "K y \<equiv> \<lambda>x. y"

definition Ate_Alg where
  "Ate_Alg =
    \<lparr> CinitState =  (\<lambda> p st crd. Ate_initState p st),
     sendMsg =  Ate_sendMsg,
     CnextState = (\<lambda> r p st msgs crd st'. Ate_nextState r p st msgs st')
   \<rparr>"

definition Ate_TS ::
  "(round \<Rightarrow> process HO)
  \<Rightarrow> (round \<Rightarrow> process HO)
  \<Rightarrow> (round \<Rightarrow> process)
  \<Rightarrow> p_TS_state TS"
where
  "Ate_TS HOs SHOs crds = CHO_to_TS Ate_Alg HOs SHOs (K o crds)"

lemmas Ate_TS_defs = Ate_TS_def CHO_to_TS_def Ate_Alg_def CHOinitConfig_def
  Ate_initState_def

definition
  "Ate_trans_step HOs \<equiv> \<Union>r \<mu>.
   {((r, cfg), Suc r, cfg')|cfg cfg'.
    (\<forall>p. \<mu> p \<in> get_msgs (Ate_sendMsg r) cfg (HOs r) (HOs r) p) \<and>
    (\<forall>p. Ate_nextState r p (cfg p) (\<mu> p) (cfg' p))}"

definition CSHOnextConfig where
  "CSHOnextConfig A r cfg HO SHO coord cfg' \<equiv>
   \<forall>p. \<exists>\<mu> \<in> SHOmsgVectors A r p cfg (HO p) (SHO p).
          CnextState A r p (cfg p) \<mu> (coord p) (cfg' p)"

type_synonym rHO = "nat \<Rightarrow> process HO"

subsubsection \<open>Refinement\<close>
(******************************************************************************)

definition ate_ref_rel :: "(opt_v_state \<times> p_TS_state)set" where
  "ate_ref_rel =  {(sa, (r, sc)).
    r = next_round sa
    \<and> (\<forall>p. decisions sa p = Ate_Defs.decide (sc p))
    \<and> majorities.opt_no_defection sa (Some o x o sc)
  }"

lemma decide_origin:
  assumes
    send: "\<mu> p \<in> get_msgs (Ate_sendMsg r) sc (HOs r) (HOs r) p"
    and nxt: "Ate_nextState r p (sc p) (\<mu> p) (sc' p)"
    and new_dec: "decide (sc' p) \<noteq> decide (sc p)"
  shows
    "\<exists>v. decide (sc' p) = Some v \<and> {q. x (sc q) = v} \<in> majs" using assms
  by(auto simp add: get_msgs_benign Ate_sendMsg_def Ate_nextState_def
    majs_def restrict_map_def elim!: order.strict_trans2 intro!: card_mono)

lemma other_values_received:
  assumes nxt: "Ate_nextState  r q (sc q) \<mu>q ((sc') q)"
  and muq: "\<mu>q \<in> get_msgs (Ate_sendMsg r) sc (HOs r) (HOs r) q"
  and vsent: "card {qq. sendMsg Ate_M r qq q (sc qq) = v} > E - \<alpha>"
             (is "card ?vsent > _")
  shows "card ({qq. \<mu>q qq \<noteq> Some v} \<inter> HOs r q) \<le> N + 2*\<alpha> - E"
proof -
  from nxt muq
  have "({qq. \<mu>q qq \<noteq> Some v} \<inter> HOs r q) - (HOs r q - HOs r q)
        \<subseteq>  {qq. sendMsg Ate_M r qq q (sc qq) \<noteq> v}"
    (is "?notvrcvd - ?aho \<subseteq> ?notvsent")
    unfolding get_msgs_def SHOmsgVectors_def Ate_SHOMachine_def by auto
  hence "card ?notvsent \<ge> card (?notvrcvd - ?aho)"
    and "card (?notvrcvd - ?aho) \<ge> card ?notvrcvd - card ?aho"
    by (auto simp: card_mono diff_card_le_card_Diff)
  moreover
  have 1: "card ?notvsent + card ?vsent = card (?notvsent \<union> ?vsent)"
    by (subst card_Un_Int) auto
  have "?notvsent \<union> ?vsent = (UNIV::process set)" by auto
  hence "card (?notvsent \<union> ?vsent) = N" by simp
  with 1 vsent have "card ?notvsent \<le>  N - (E + 1 - \<alpha>)" by auto
  ultimately
  show ?thesis using EltN Egta by auto
qed

text \<open>
  If more than \<open>E - \<alpha>\<close> processes send a value \<open>v\<close> to some
  process \<open>q\<close> at some round \<open>r\<close>, and if \<open>q\<close> receives more than
  \<open>T\<close> messages in \<open>r\<close>, then \<open>v\<close> is the most frequently
  received value by \<open>q\<close> in \<open>r\<close>.
\<close>

lemma mostOftenRcvd_v:
  assumes nxt: "Ate_nextState  r q (sc q) \<mu>q ((sc') q)"
  and muq: "\<mu>q \<in> get_msgs (Ate_sendMsg r) sc (HOs r) (HOs r) q"
  and threshold_T: "card {qq. \<mu>q qq \<noteq> None} > T"
  and threshold_E: "card {qq. sendMsg Ate_M r qq q (sc qq) = v} > E - \<alpha>"
  shows "mostOftenRcvd \<mu>q = {v}"
proof -
  from muq have hodef:"HOs r q = {qq. \<mu>q qq \<noteq> None}"
    unfolding get_msgs_def SHOmsgVectors_def by auto

  from nxt muq threshold_E
  have "card ({qq. \<mu>q qq \<noteq> Some v} \<inter> HOs r q) \<le> N + 2*\<alpha> - E"
    (is "card ?heardnotv \<le> _")
    by (rule other_values_received)
  moreover
  have "card ?heardnotv \<ge> T + 1 - card {qq. \<mu>q qq = Some v}"
  proof -
    from muq
    have "?heardnotv = (HOs r q) - {qq. \<mu>q qq = Some v}"
      and "{qq. \<mu>q qq = Some v} \<subseteq> HOs r q"
      unfolding SHOmsgVectors_def get_msgs_def by auto
    hence "card ?heardnotv = card (HOs r q) - card {qq. \<mu>q qq = Some v}"
      by (auto simp: card_Diff_subset)
    with hodef threshold_T show ?thesis by auto
  qed
  ultimately
  have "card {qq. \<mu>q qq = Some v} > card ?heardnotv"
    using TNaE by auto
  moreover
  {
    fix w
    assume w: "w \<noteq> v"
    with hodef have "{qq. \<mu>q qq = Some w} \<subseteq> ?heardnotv" by auto
    hence "card {qq. \<mu>q qq = Some w} \<le> card ?heardnotv" by (auto simp: card_mono)
  }
  ultimately
  have "{w. card {qq. \<mu>q qq = Some w} \<ge> card {qq. \<mu>q qq = Some v}} = {v}"
    by force
  thus ?thesis unfolding mostOftenRcvd_def by auto
qed

lemma step_ref:
  "{ate_ref_rel}
      (\<Union>r v_f d_f. majorities.flv_round r v_f d_f),
      Ate_trans_step HOs
    {> ate_ref_rel}"
proof(simp add: PO_rhoare_defs Ate_trans_step_def, safe)
  fix sa r sc sc' \<mu>
  assume
    R: "(sa, r, sc) \<in> ate_ref_rel"
    and send: "\<forall>p. \<mu> p \<in> get_msgs (Ate_sendMsg r) sc (HOs r) (HOs r) p"
    and nxt: "\<forall>p. Ate_nextState r p (sc p) (\<mu> p) (sc' p)"
  note step=send nxt
  define d_f
    where "d_f p = (if decide (sc' p) \<noteq> decide (sc p) then decide (sc' p) else None)" for p

  define sa' where "sa' = \<lparr>
    opt_v_state.next_round = Suc r
    , opt_v_state.last_vote = opt_v_state.last_vote sa ++ (Some o x o sc)
    , opt_v_state.decisions = opt_v_state.decisions sa ++ d_f
    \<rparr>"

  have "majorities.d_guard d_f (Some o x o sc)"
  proof(clarsimp simp add: majorities.d_guard_def d_f_def)
    fix p v
    assume
      "Some v \<noteq> decide (sc p)"
      "decide (sc' p) = Some v"
    from this and
      decide_origin[where \<mu>=\<mu> and HOs=HOs and sc'=sc', OF send[THEN spec, of p] nxt[THEN spec, of p]]
    show "quorum_process.locked_in_vf majs (Some \<circ> x \<circ> sc) v"
      by(auto simp add: majorities.locked_in_vf_def majorities.quorum_for_def)
  qed
  hence
    "(sa, sa') \<in> majorities.flv_round r (Some o x o sc) d_f" using R
    by(auto simp add: majorities.flv_round_def ate_ref_rel_def sa'_def)
  moreover have "(sa', Suc r, sc') \<in> ate_ref_rel"
  proof(unfold ate_ref_rel_def, safe)
    fix p
    show "opt_v_state.decisions sa' p = decide (sc' p)" using R nxt[THEN spec, of p]
      by(auto simp add: ate_ref_rel_def sa'_def map_add_def d_f_def Ate_nextState_def
        split: option.split)
  next
    show "quorum_process.opt_no_defection majs sa' (Some \<circ> x \<circ> sc')"
    proof(clarsimp simp add: sa'_def majorities.opt_no_defection_def map_add_def majorities.quorum_for_def)
      fix Q p v
      assume Q: "Q \<in> majs" and Q_v: "\<forall>q \<in> Q. x (sc q) = v" and p_Q: "p \<in> Q"
      hence old: "x (sc p) = v" by simp

      have v_maj: "{q. x (sc q) = v} \<in> majs" using Q Q_v
        apply(simp add: majs_def)
        apply(erule less_le_trans, rule card_mono, auto)
        done
      show "x (sc' p) = v"
      proof(cases "T < card {qq. \<mu> p qq \<noteq> None}")
        case True
        have
          "E - \<alpha> < card {qq. sendMsg Ate_M r qq p (sc qq) = v}" using v_maj
          by(auto simp add: Ate_SHOMachine_def Ate_sendMsg_def majs_def)
        from mostOftenRcvd_v[where HOs=HOs and sc=sc and sc'=sc',
          OF nxt[THEN spec, of p] send[THEN spec, of p] True this]
        show ?thesis using nxt[THEN spec, of p] old
          by(clarsimp simp add: Ate_nextState_def)
      next
        case False
        thus ?thesis using nxt[THEN spec, of p] old
          by(clarsimp simp add: Ate_nextState_def)
      qed
    qed
  qed(auto simp add: sa'_def)

  ultimately show
    "\<exists>sa'. (\<exists>ra v_f d_f. (sa, sa') \<in> quorum_process.flv_round majs ra v_f d_f)
    \<and> (sa', Suc r, sc') \<in> ate_ref_rel"
    by blast
qed

lemma Ate_Refines_LV_VOting:
  "PO_refines (ate_ref_rel)
    majorities.flv_TS (Ate_TS HOs HOs crds)"
proof(rule refine_basic)
  show "init (Ate_TS HOs HOs crds) \<subseteq> ate_ref_rel `` init (quorum_process.flv_TS majs)"
    by(auto simp add: Ate_TS_def CHO_to_TS_def Ate_Alg_def CHOinitConfig_def Ate_initState_def
      majorities.flv_TS_def flv_init_def majorities.opt_no_defection_def majorities.quorum_for_def'
      ate_ref_rel_def)
next
  show
    "{ate_ref_rel} TS.trans (quorum_process.flv_TS majs), TS.trans (Ate_TS HOs HOs crds) {> ate_ref_rel}"
    using step_ref
    by(simp add: majorities.flv_TS_defs Ate_TS_def CHO_to_TS_def Ate_Alg_def
      CSHO_trans_alt_def CHO_trans_alt Ate_trans_step_def)
qed

end   \<comment> \<open>context @{text "ate_parameters"}\<close>

subsubsection \<open>Termination\<close>
(******************************************************************************)

text \<open>The termination proof for the algorithm is already given in the Heard-Of Model AFP
  entry, and we do not repeat it here.\<close>

end   (* theory AteProof *)


header {* The exact call cache is a map *}

theory ExCFSV
imports ExCF
begin

subsection {* Preparations *}

text {*
Before we state the main result of this section, we need to define
\begin{itemize}
\item the set of binding environments occurring in a semantic value (which exists only if it is a closure),
\item the set of binding environments in a variable environment, using the previous definition,
\item the set of contour counters occurring in a semantic value and
\item the set of contour counters occurring in a variable environment.
\end{itemize}
*}

fun benv_in_d :: "d \<Rightarrow> benv set"
  where "benv_in_d (DC (l,\<beta>)) = {\<beta>}"
      | "benv_in_d _ = {}"

definition benv_in_ve :: "venv \<Rightarrow> benv set"
  where "benv_in_ve ve = \<Union>{benv_in_d d | d . d \<in> ran ve}"

fun contours_in_d :: "d \<Rightarrow> contour set"
  where "contours_in_d (DC (l,\<beta>)) = ran \<beta>"
      | "contours_in_d _ = {}"

definition contours_in_ve :: "venv \<Rightarrow> contour set"
  where "contours_in_ve ve = \<Union>{contours_in_d d | d . d \<in> ran ve}"

text {*
The following 6 lemmas allow us to calculate the above definition, when applied to constructs used in our semantics function, e.g. map updates, empty maps etc.
*}

lemma benv_in_ve_upds:
  assumes eq_length: "length vs = length ds"
      and "\<forall>\<beta>\<in>benv_in_ve ve. Q \<beta>"
      and "\<forall>d'\<in>set ds. \<forall>\<beta>\<in>benv_in_d d'. Q \<beta>"
  shows   "\<forall>\<beta>\<in>benv_in_ve (ve(map (\<lambda>v. (v, b'')) vs [\<mapsto>] ds)). Q \<beta>"
proof
  fix \<beta>
  assume ass:"\<beta> \<in> benv_in_ve (ve(map (\<lambda>v. (v, b'')) vs [\<mapsto>] ds))"
  then obtain d where "\<beta>\<in>benv_in_d d" and "d \<in> ran (ve(map (\<lambda>v. (v, b'')) vs [\<mapsto>] ds))" unfolding benv_in_ve_def by auto
  moreover have "ran (ve(map (\<lambda>v. (v, b'')) vs [\<mapsto>] ds)) \<subseteq> ran ve \<union> set ds" using eq_length by(auto intro!:ran_upds)
  ultimately
  have "d \<in> ran ve \<or> d \<in> set ds" by auto
  thus "Q \<beta>" using assms(2,3) `\<beta>\<in>benv_in_d d` unfolding benv_in_ve_def by auto
qed

lemma benv_in_eval:
  assumes "\<forall>\<beta>'\<in>benv_in_ve ve. Q \<beta>'"
      and "Q \<beta>"
  shows "\<forall>\<beta>\<in>benv_in_d (\<A> v \<beta> ve). Q \<beta>"
proof(cases v)
  case (R _ var)
  thus ?thesis
  proof (cases "\<beta> (fst var)")
    case None with R show ?thesis by simp next
    case (Some cnt) show ?thesis
    proof (cases "ve (var,cnt)")
      case None with Some R show ?thesis by simp next
      case (Some d)
        hence "d \<in> ran ve" unfolding ran_def by blast
        thus ?thesis using Some `\<beta> (fst var) = Some cnt` R assms(1)
          unfolding benv_in_ve_def by auto
    qed
  qed next
  case (L l) thus ?thesis using assms(2) by simp next
  case C thus ?thesis by simp next
  case P thus ?thesis by simp
qed

lemma contours_in_ve_empty[simp]: "contours_in_ve empty = {}"
  unfolding contours_in_ve_def by auto

lemma contours_in_ve_upds:
  assumes eq_length: "length vs = length ds"
      and "\<forall>b'\<in>contours_in_ve ve. Q b'"
      and "\<forall>d'\<in>set ds. \<forall>b'\<in>contours_in_d d'. Q b'"
  shows   "\<forall>b'\<in>contours_in_ve (ve(map (\<lambda>v. (v, b'')) vs [\<mapsto>] ds)). Q b'"
proof-
  have "ran (ve(map (\<lambda>v. (v, b'')) vs [\<mapsto>] ds)) \<subseteq> ran ve \<union> set ds" using eq_length by(auto intro!:ran_upds)
  thus ?thesis using assms(2,3) unfolding contours_in_ve_def  by blast
qed

lemma contours_in_ve_upds_binds:
  assumes "\<forall>b'\<in>contours_in_ve ve. Q b'"
      and "\<forall>b'\<in>ran \<beta>'. Q b'"
  shows   "\<forall>b'\<in>contours_in_ve (ve ++ map_of (map (\<lambda>(v,l). ((v,b''), \<A> (L l) \<beta>' ve)) ls)). Q b'"
proof
  fix b' assume "b'\<in>contours_in_ve (ve ++ map_of (map (\<lambda>(v,l). ((v,b''), \<A> (L l) \<beta>' ve)) ls))"
  then obtain d where d:"d \<in> ran (ve ++ map_of (map (\<lambda>(v,l). ((v,b''), \<A> (L l) \<beta>' ve)) ls))" and b:"b' \<in> contours_in_d d" unfolding contours_in_ve_def by auto

  have "ran (ve ++ map_of (map (\<lambda>(v,l). ((v,b''), \<A> (L l) \<beta>' ve)) ls)) \<subseteq> ran ve \<union> ran (map_of (map (\<lambda>(v,l). ((v,b''), \<A> (L l) \<beta>' ve)) ls))"
    by(auto intro!:ran_concat)
  also
  have "\<dots> \<subseteq> ran ve \<union> snd ` set (map (\<lambda>(v,l). ((v,b''), \<A> (L l) \<beta>' ve)) ls)"
    by (rule Un_mono[of "ran ve" "ran ve", OF subset_refl ran_map_of])
  also
  have "\<dots> \<subseteq> ran ve \<union> set (map (\<lambda>(v,l). (\<A> (L l) \<beta>' ve)) ls)"
    by (rule Un_mono[of "ran ve" "ran ve", OF subset_refl ])auto
  finally
  have "d \<in>  ran ve \<union> set (map (\<lambda>(v,l). (\<A> (L l) \<beta>' ve)) ls)" using d by auto
  thus "Q b'"  using assms b unfolding contours_in_ve_def by auto
qed

lemma contours_in_eval:
  assumes "\<forall>b'\<in>contours_in_ve ve. Q b'"
      and "\<forall>b'\<in> ran \<beta>. Q b'"
  shows "\<forall>b'\<in>contours_in_d (\<A> f \<beta> ve). Q b'"
unfolding contours_in_ve_def
proof(cases f)
  case (R _ var)
  thus ?thesis
  proof (cases "\<beta> (fst var)")
    case None with R show ?thesis by simp next
    case (Some cnt) show ?thesis
    proof (cases "ve (var,cnt)")
      case None with Some R show ?thesis by simp next
      case (Some d)
        hence "d \<in> ran ve" unfolding ran_def by blast
        thus ?thesis using Some `\<beta> (fst var) = Some cnt` R `\<forall>b'\<in>contours_in_ve ve. Q b'`
          unfolding contours_in_ve_def
          by auto
    qed
  qed next
  case (L l) thus ?thesis using `\<forall>b'\<in> ran \<beta>. Q b'` by simp next
  case C thus ?thesis by simp next
  case P thus ?thesis by simp
qed

subsection {* The proof *}

text {*
The set returned by @{text \<F>} and @{text \<C>} is actually a partial map from callsite/binding environment pairs to called values. The corresponding predicate in Isabelle is @{text single_valued}.

We would like to show an auxiliary result about the contour counter passed to @{text \<F>} and @{text \<C>} (such that it is an unused counter when passed to @{text \<F>} and others) first. Unfortunately, this is not possible with induction proofs over fixed points: While proving the inductive case, one does not show results for the function in question, but for an information-theoretical approximation. Thus, any previously shown results are not available.
We therefore intertwine the two inductions in one large proof.

This is a proof by fixpoint induction, so we have are obliged to show that the predicate is admissible and that it holds for the base case, i.e. the empty set. For the proof of admissibiliy, @{theory HOLCF} provides a number of introduction lemmas that, together with some additions in @{theory HOLCFUtils} and the continuity lemmas, mechanically proove admissibiliy. The base case is trivial.

The remaining case is the preservation of the properties when applying the recursive equations to a function known to have have the desired property. Here, we break the proof into the various cases that occur in the definitions of @{text \<F>} and @{text \<C>} and use the induction hypothesises.
*}

lemma cc_single_valued':
      "\<lbrakk> \<forall>b' \<in> contours_in_ve ve. b' < b
       ; \<forall>b' \<in> contours_in_d d. b' < b
       ; \<forall>d' \<in> set ds. \<forall>b' \<in> contours_in_d d'. b' < b
       \<rbrakk>
       \<Longrightarrow>
       (   single_valued (\<F>\<cdot>(Discr (d,ds,ve,b)))
       \<and> (\<forall> ((lab,\<beta>),t) \<in> \<F>\<cdot>(Discr (d,ds,ve, b)). \<exists> b'. b' \<in> ran \<beta> \<and> b \<le> b')
       )"
  and "\<lbrakk> b \<in> ran \<beta>'
       ; \<forall>b'\<in>ran \<beta>'. b' \<le> b
       ; \<forall>b' \<in> contours_in_ve ve. b' \<le> b
       \<rbrakk>
       \<Longrightarrow>
       (   single_valued (\<C>\<cdot>(Discr (c,\<beta>',ve,b)))
       \<and> (\<forall> ((lab,\<beta>),t) \<in> \<C>\<cdot>(Discr (c,\<beta>',ve,b)). \<exists> b'. b' \<in> ran \<beta> \<and> b \<le> b')
       )"
proof(induct arbitrary:d ds ve b c \<beta>' rule:evalF_evalC_induct)
case Admissibility show ?case
  by (intro adm_lemmas adm_ball' adm_prod_split adm_not_conj adm_not_mem adm_single_valued cont2cont)
next
  case Bottom {
    case 1 thus ?case by auto next
    case 2 thus ?case by auto
  }
next
  case (Next evalF evalC)

  txt {* Nicer names for the hypothesises: *}
  note hyps_F_sv = Next.hyps(1)[THEN conjunct1]
  note hyps_F_b = Next.hyps(1)[THEN conjunct2, THEN bspec]
  note hyps_C_sv = Next.hyps(2)[THEN conjunct1]
  note hyps_C_b = Next.hyps(2)[THEN conjunct2, THEN bspec]
  {
  case (1 d ds ve b)
  thus ?case
  proof (cases "(d,ds,ve,b)" rule:fstate_case, auto simp del:Un_insert_left Un_insert_right)
  txt {* Case Closure *}
    fix lab' and vs :: "var list" and c and \<beta>' :: benv
    assume prem_d: "\<forall>b'\<in>ran \<beta>'. b' < b"
    assume eq_length: "length vs = length ds"
    have new: "b\<in>ran (\<beta>'(lab' \<mapsto> b))" by simp

    have b_dom_beta: "\<forall>b'\<in> ran (\<beta>'(lab' \<mapsto> b)). b' \<le> b"
    proof fix b' assume "b' \<in> ran (\<beta>'(lab' \<mapsto> b))"
      hence "b' \<in> ran \<beta>' \<or> b' \<le> b" by (auto dest:ran_upd[THEN subsetD])
      thus "b' \<le> b" using prem_d by auto
    qed
    from contours_in_ve_upds[OF eq_length Next.prems(1) Next.prems(3)]
    have b_dom_ve: "\<forall>b'\<in>contours_in_ve (ve(map (\<lambda>v. (v, b)) vs [\<mapsto>] ds)). b' \<le> b"
      by auto

    show "single_valued (evalC\<cdot>(Discr (c, \<beta>'(lab' \<mapsto> b), ve(map (\<lambda>v. (v, b)) vs [\<mapsto>] ds), b)))"
      by (rule hyps_C_sv[OF new b_dom_beta b_dom_ve, of c])

    fix lab and \<beta> and t
    assume "((lab, \<beta>), t)\<in> evalC\<cdot>(Discr(c, \<beta>'(lab' \<mapsto> b), ve(map (\<lambda>v. (v, b)) vs [\<mapsto>] ds),b))"
    thus "\<exists>b'. b' \<in> ran \<beta> \<and> b \<le> b'"
      by (auto dest: hyps_C_b[OF new b_dom_beta b_dom_ve])
  next
  txt {* Case Plus *}
    fix cp and i1 and i2 and cnt
    assume "\<forall>b'\<in>contours_in_d cnt. b' < b"
    hence b_dom_d: "\<forall>b'\<in>contours_in_d cnt. b' < nb b cp" by auto
    have b_dom_ds: "\<forall>d' \<in> set [DI (i1+i2)]. \<forall>b'\<in>contours_in_d d'. b' < nb b cp" by auto
    have b_dom_ve: "\<forall>b' \<in> contours_in_ve ve. b' < nb b cp" using Next.prems(1) by auto
    {
      fix t
      assume "((cp,[cp \<mapsto> b]), t) \<in> evalF\<cdot>(Discr (cnt, [DI (i1 + i2)], ve, nb b cp))"
      hence False by (auto dest:hyps_F_b[OF b_dom_ve b_dom_d b_dom_ds])
    }
    with hyps_F_sv[OF b_dom_ve b_dom_d b_dom_ds]
    show "single_valued ((evalF\<cdot>(Discr (cnt, [DI (i1 + i2)], ve, nb b cp)))
                      \<union> {((cp, [cp \<mapsto> b]), cnt)})"
      by (auto intro:single_valued_insert)

    fix lab \<beta> t
    assume "((lab, \<beta>), t) \<in> evalF\<cdot>(Discr (cnt, [DI (i1 + i2)], ve, nb b cp))"
    thus "\<exists>b'. b' \<in> ran \<beta> \<and> b \<le> b'"
      by (auto dest: hyps_F_b[OF b_dom_ve b_dom_d b_dom_ds])
  next
  txt {* Case If (true branch) *}
    fix cp1 cp2 i cntt cntf
    assume "\<forall>b'\<in>contours_in_d cntt. b' < b"
    hence b_dom_d: "\<forall>b'\<in>contours_in_d cntt. b' < nb b cp1" by auto
    have b_dom_ds: "\<forall>d' \<in> set []. \<forall>b'\<in>contours_in_d d'. b' < nb b cp1" by auto
    have b_dom_ve: "\<forall>b' \<in> contours_in_ve ve. b' < nb b cp1" using Next.prems(1) by auto
    {
      fix t
      assume "((cp1,[cp1 \<mapsto> b]), t) \<in> evalF\<cdot>(Discr (cntt, [], ve, nb b cp1))"
      hence False by (auto dest:hyps_F_b[OF b_dom_ve b_dom_d b_dom_ds])
    }
    with Next.hyps(1)[OF b_dom_ve b_dom_d b_dom_ds, THEN conjunct1]
    show "single_valued ((evalF\<cdot>(Discr (cntt, [], ve, nb b cp1)))
                       \<union> {((cp1, [cp1 \<mapsto> b]), cntt)})"
      by (auto intro:single_valued_insert)

    fix lab \<beta> t
    assume "((lab, \<beta>), t) \<in> evalF\<cdot>(Discr (cntt, [], ve, nb b cp1))"
    thus "\<exists>b'. b' \<in> ran \<beta> \<and> b \<le> b'"
      by (auto dest: hyps_F_b[OF b_dom_ve b_dom_d b_dom_ds])
  next
  txt {* Case If (false branch). Variable names swapped for easier code reuse. *}
    fix cp2 cp1 i cntf cntt
    assume "\<forall>b'\<in>contours_in_d cntt. b' < b"
    hence b_dom_d: "\<forall>b'\<in>contours_in_d cntt. b' < nb b cp1" by auto
    have b_dom_ds: "\<forall>d' \<in> set []. \<forall>b'\<in>contours_in_d d'. b' < nb b cp1" by auto
    have b_dom_ve: "\<forall>b' \<in> contours_in_ve ve. b' < nb b cp1" using Next.prems(1) by auto
    {
      fix t
      assume "((cp1,[cp1 \<mapsto> b]), t) \<in> evalF\<cdot>(Discr (cntt, [], ve, nb b cp1))"
      hence False by (auto dest:hyps_F_b[OF b_dom_ve b_dom_d b_dom_ds])
    }
    with Next.hyps(1)[OF b_dom_ve b_dom_d b_dom_ds, THEN conjunct1]
    show "single_valued ((evalF\<cdot>(Discr (cntt, [], ve, nb b cp1)))
                       \<union> {((cp1, [cp1 \<mapsto> b]), cntt)})"
      by (auto intro:single_valued_insert)

    fix lab \<beta> t
    assume "((lab, \<beta>), t) \<in> evalF\<cdot>(Discr (cntt, [], ve, nb b cp1))"
    thus "\<exists>b'. b' \<in> ran \<beta> \<and> b \<le> b'"
      by (auto dest: hyps_F_b[OF b_dom_ve b_dom_d b_dom_ds])
  qed
next
  case (2 ve b c \<beta>')
  thus ?case
  proof (cases c, auto simp add:HOL.Let_def simp del:Un_insert_left Un_insert_right evalV.simps)
  txt {* Case App *}
    fix lab' f vs

    have prem2': "\<forall>b'\<in>ran \<beta>'. b' < nb b lab'" using Next.prems(2) by auto
    have prem3': "\<forall>b'\<in>contours_in_ve ve. b' < nb b lab'" using Next.prems(3) by auto
    note c_in_e = contours_in_eval[OF prem3' prem2']

    have b_dom_d: "\<forall>b'\<in>contours_in_d (evalV f \<beta>' ve). b' < nb b lab'" by(rule c_in_e)
    have b_dom_ds: "\<forall>d' \<in> set (map (\<lambda>v. evalV v \<beta>' ve) vs). \<forall>b'\<in>contours_in_d d'. b' < nb b lab'"
      using c_in_e by auto
    have b_dom_ve: "\<forall>b' \<in> contours_in_ve ve. b' < nb b lab'" by (rule prem3')

    have "\<forall>y. ((lab', \<beta>'), y) \<notin> evalF\<cdot>(Discr (evalV f \<beta>' ve, map (\<lambda>v. evalV v \<beta>' ve) vs, ve, nb b lab'))"
    proof(rule allI, rule notI)
      fix y assume "((lab', \<beta>'), y) \<in> evalF\<cdot>(Discr (evalV f \<beta>' ve, map (\<lambda>v. evalV v \<beta>' ve) vs, ve, nb b lab'))"
      hence "\<exists>b'. b' \<in> ran \<beta>' \<and> nb b lab' \<le> b'"
        by (auto dest: hyps_F_b[OF b_dom_ve b_dom_d b_dom_ds])
      thus False using prem2' by (auto iff:less_le_not_le)
    qed

    with hyps_F_sv[OF b_dom_ve b_dom_d b_dom_ds]
    show "single_valued (evalF\<cdot>(Discr (evalV f \<beta>' ve, map (\<lambda>v. evalV v \<beta>' ve) vs, ve, nb b lab'))
                       \<union> {((lab', \<beta>'), evalV f \<beta>' ve)})"
      by(auto intro:single_valued_insert)

    fix lab \<beta> t
    assume "((lab, \<beta>), t) \<in> (evalF\<cdot>(Discr (evalV f \<beta>' ve, map (\<lambda>v. evalV v \<beta>' ve) vs, ve, nb b lab')))"
    thus "\<exists>b'. b' \<in> ran \<beta> \<and> b \<le> b'"
      by (auto dest: hyps_F_b[OF b_dom_ve b_dom_d b_dom_ds])
  next
  txt {* Case Let *}
    fix lab' ls c'
    have prem2': "\<forall>b'\<in>ran (\<beta>'(lab' \<mapsto> nb b lab')). b' \<le> nb b lab'"
    proof
      fix b' assume "b'\<in>ran (\<beta>'(lab' \<mapsto> nb b lab'))"
      hence "b' \<in> ran \<beta>' \<or> b' = nb b lab'" by (auto dest:ran_upd[THEN subsetD])
      thus "b' \<le> nb b lab'" using  Next.prems(2) by auto
    qed
    have prem3': "\<forall>b'\<in>contours_in_ve ve. b' \<le> nb b lab'" using Next.prems(3)
      by auto

    note c_in_e = contours_in_eval[OF prem3' prem2']
    note c_in_ve' = contours_in_ve_upds_binds[OF prem3' prem2']

    have b_dom_ve: "\<forall>b' \<in> contours_in_ve (ve ++ map_of (map (\<lambda>(v,l). ((v,nb b lab'), evalV (L l) ((\<beta>'(lab' \<mapsto> nb b lab'))) ve)) ls)). b' \<le> nb b lab'"
      by (rule c_in_ve')
    have b_dom_beta: "\<forall>b'\<in>ran (\<beta>'(lab' \<mapsto> nb b lab')). b' \<le> nb b lab'" by (rule prem2')
    have new: "nb b lab' \<in> ran (\<beta>'(lab' \<mapsto> nb b lab'))" by simp

    from hyps_C_sv[OF new b_dom_beta b_dom_ve, of c']
    show "single_valued (evalC\<cdot>(Discr (c', \<beta>'(lab' \<mapsto> nb b lab'),
       ve ++ map_of (map (\<lambda>(v, l).((v, nb b lab'), evalV (L l) (\<beta>'(lab' \<mapsto> nb b lab')) ve))ls),
       nb b lab')))".

    fix lab \<beta> t
    assume "((lab, \<beta>), t) \<in> evalC\<cdot>(Discr (c', \<beta>'(lab' \<mapsto> nb b lab'),
       ve ++ map_of (map (\<lambda>(v, l).((v, nb b lab'), \<A> (L l) (\<beta>'(lab' \<mapsto> nb b lab')) ve))ls),
       nb b lab'))"
    thus "\<exists>b'. b' \<in> ran \<beta> \<and> b \<le> b'"
      by -(drule hyps_C_b[OF new b_dom_beta b_dom_ve], auto)
  qed
 }
qed

lemma "single_valued (\<PR> prog)"
unfolding evalCPS_def
by ((subst HOL.Let_def)+, rule cc_single_valued'[THEN conjunct1], auto)
end


theory Rewriting_LLRG_LV_Mondaic
  imports Rewriting
    Replace_Constant
begin

subsection \<open>Specific results about rewriting under a linear variable-separated system\<close>
(***************** AUX ********************)

lemma card_varposs_ground:
  "card (varposs s) = 0 \<longleftrightarrow> ground s"
  by (simp add: finite_varposs varposs_empty_gound)

lemma poss_of_term_subst_apply_varposs:
  assumes "p \<in> poss_of_term (constT c) (s \<cdot> \<sigma>)" "(c, 0) \<notin> funas_term s"
  shows "\<exists> q. q \<in> varposs s \<and> q \<le>\<^sub>p p" using assms
proof (induct p arbitrary: s)
  case Nil
  then show ?case by (cases s) (auto simp: poss_of_term_def)
next
  case (Cons i p)
  show ?case using Cons(1)[of "args s ! i"] Cons(2-)
    apply (cases s)
      apply (auto simp: poss_of_term_def)
      apply (metis position_less_eq_Cons)+
    done
qed

lemma poss_of_term_hole_poss:
  assumes "p \<in> poss_of_term t C\<langle>s\<rangle>" and "hole_pos C \<le>\<^sub>p p"
  shows "p -\<^sub>p hole_pos C \<in> poss_of_term t s" using assms
proof (induct C arbitrary: p)
  case (More f ss C ts)
  from More(3) obtain ps where [simp]: "p = length ss # ps" and h: "hole_pos C \<le>\<^sub>p ps"
    by (metis append_Cons hole_pos.simps(2) less_eq_poss_append_itself pos_les_eq_append_diff)
  show ?case using More(1)[OF _ h] More(2)
    by (auto simp: poss_of_term_def)
qed auto

lemma remove_const_subst_from_match:
  assumes "s \<cdot> const_subst c = C\<langle>l \<cdot> \<sigma>\<rangle>" "(c, 0) \<notin> funas_term l" "linear_term l"
  shows "\<exists> D \<tau>. s = D\<langle>l \<cdot> \<tau>\<rangle>" using assms
proof (induct "card (varposs s)" arbitrary: s)
  case (Suc x)
  from Suc(2) obtain p ps where varposs: "varposs s = insert p ps" "p \<notin> ps"
    by (metis card_Suc_eq)
  let ?s = "s[p \<leftarrow> Fun c []]" have vp: "p \<in> varposs s" using varposs by auto
  then have *: "?s \<cdot> const_subst c = s \<cdot>  const_subst c"
    by (induct s arbitrary: p) (auto simp: nth_list_update map_update intro!: nth_equalityI)
  have "varposs ?s = ps" using varposs varposs_ground_replace_at[of p s "constT c"]
    by auto
  from Suc(1)[of ?s] Suc(2-) varposs obtain D \<tau> where split: "s[p \<leftarrow> constT c] = D\<langle>l \<cdot> \<tau>\<rangle>"
    by (metis "*" \<open>varposs s[p \<leftarrow> constT c] = ps\<close> card_insert_if diff_Suc_1 finite_varposs)
  have wit: "s =  D\<langle>l \<cdot> \<tau>\<rangle>[p \<leftarrow> s |_ p]" unfolding arg_cong[OF split, of "\<lambda> t. t[p \<leftarrow> s |_ p]", symmetric]
    using vp by simp
  from vp split have cases: "p \<bottom> hole_pos D \<or> hole_pos D \<le>\<^sub>p p"
    by auto (metis poss_of_term_const_ctxt_apply poss_of_term_replace_term_at varposs_imp_poss)
  show ?case
  proof (cases "p \<bottom> hole_pos D")
    case True then show ?thesis using wit
      by (auto simp: par_hole_pos_replace_term_context_at)
  next
    case False
    then have hole: "hole_pos D \<le>\<^sub>p p" using cases by auto
    from vp split have "p \<in> poss_of_term (constT c) s[p \<leftarrow> constT c]"
      using poss_of_term_replace_term_at varposs_imp_poss by blast
    from poss_of_term_hole_poss[OF this[unfolded split] hole]
    have "p -\<^sub>p hole_pos D \<in> poss_of_term (constT c) (l \<cdot> \<tau>)"
      by simp
    from poss_of_term_subst_apply_varposs[OF this Suc(4)] obtain q where
      q: "q \<in> varposs l" "q \<le>\<^sub>p (p -\<^sub>p (hole_pos D))" by blast
    show ?thesis using wit Suc(5) hole
      using linear_term_varposs_subst_replace_term[OF Suc(5) q, of \<tau> "s |_ p"]
      by auto
  qed
qed (auto simp: card_varposs_ground ground_subst_apply)

(***************** end AUX ********************)

definition "llrg \<R> \<longleftrightarrow> (\<forall> (l, r) \<in> \<R>. linear_term l \<and> ground r)"

definition "lv \<R> \<longleftrightarrow> (\<forall> (l, r) \<in> \<R>. linear_term l \<and> linear_term r \<and> vars_term l \<inter> vars_term r = {})"

definition "monadic \<F> \<longleftrightarrow> (\<forall> (f, n) \<in> \<F>. n \<le> Suc 0)"

\<comment> \<open>NF of ground terms\<close>

lemma ground_NF_srstep_gsrstep:
  "ground s \<Longrightarrow> s \<in> NF (srstep \<F> \<R>) \<Longrightarrow> s \<in> NF (gsrstep \<F> \<R>)"
  by blast

lemma NF_to_fresh_const_subst_NF:
  assumes lin: "linear_sys \<R>" and fresh_const: "(c, 0) \<notin> funas_rel \<R>" "funas_rel \<R> \<subseteq> \<F>"
    and nf_f: "funas_term s \<subseteq> \<F>" "s \<in> NF (srstep \<F> \<R>)"
  shows "s \<cdot> const_subst c \<in> NF (gsrstep \<H> \<R>)"
proof (rule ccontr)
  assume "s \<cdot> const_subst c \<notin> NF (Restr (srstep \<H> \<R>) (Collect ground))"
  then obtain C l r \<sigma> where step: "(l, r) \<in> \<R>" "s \<cdot> const_subst c = C\<langle>l \<cdot> \<sigma>\<rangle>" by fastforce
  from step(1) have l: "(c, 0) \<notin> funas_term l" "linear_term l" using lin fresh_const
    by (auto simp: funas_rel_def)
  obtain D \<tau> where "s = D\<langle>l \<cdot> \<tau>\<rangle>" using remove_const_subst_from_match[OF step(2) l] by blast
  then show False using step(1) nf_f
    by (meson NF_no_trancl_step fresh_const(2) r_into_trancl' rstepI rstep_trancl_sig_step_r)
qed

lemma fresh_const_subst_NF_pres:
  assumes fresh_const: "(c, 0) \<notin> funas_rel \<R>" "funas_rel \<R> \<subseteq> \<F>"
    and nf_f: "funas_term s \<subseteq> \<F>" "\<F> \<subseteq> \<H>" "(c, 0) \<in> \<H>" "s \<cdot> const_subst c \<in> NF (gsrstep \<H> \<R>)"
  shows "s \<in> NF (srstep \<F> \<R>)"
proof (rule ccontr)
  assume "s \<notin> NF (srstep \<F> \<R>)"
  then obtain C l r \<sigma> where step: "(l, r) \<in> \<R>" "s = C\<langle>l \<cdot> \<sigma>\<rangle>" by fastforce
  let ?\<tau> = "\<lambda> x. if x \<in> vars_term l then (\<sigma> x) \<cdot> const_subst c else Fun c []"
  define D where "D = (C \<cdot>\<^sub>c const_subst c)"
  have s: "s \<cdot> const_subst c = D\<langle>l \<cdot> ?\<tau>\<rangle>" unfolding D_def step(2)
    by (auto simp: subst_compose simp flip: subst_subst_compose intro!: term_subst_eq)
  have funas: "funas_ctxt D \<subseteq> \<H>" "funas_term (l \<cdot> ?\<tau>) \<subseteq> \<H>" "funas_term (r \<cdot> ?\<tau>) \<subseteq> \<H>"
    using step nf_f(1 - 3) fresh_const(2) unfolding D_def
    by (auto simp: funas_ctxt_subst_apply_ctxt funas_term_subst funas_rel_def split: if_splits)
  moreover have "ground_ctxt D" "ground (l \<cdot> ?\<tau>)" "ground (r \<cdot> ?\<tau>)" using arg_cong[OF s, of ground] unfolding D_def
    by (auto intro!: ground_substI)
  ultimately have "(D\<langle>l \<cdot> ?\<tau>\<rangle>, D\<langle>r \<cdot> ?\<tau>\<rangle>) \<in> gsrstep \<H> \<R>" using step(1)
    by (simp add: rstepI sig_stepI)
  then show False using nf_f(4) unfolding s[symmetric]
    by blast
qed

lemma linear_sys_gNF_eq_NF_eq:
  assumes lin: "linear_sys \<R>" "linear_sys \<S>"
   and well: "funas_rel \<R> \<subseteq> \<F>" "funas_rel \<S> \<subseteq> \<F>"
   and fresh: "(c, 0) \<notin> funas_rel \<R>" "(c, 0) \<notin> funas_rel \<S>"
   and lift: "\<F> \<subseteq> \<H>" "(c, 0) \<in> \<H>"
   and nf: "NF (gsrstep \<H> \<R>) = NF (gsrstep \<H> \<S>)"
 shows "NF (srstep \<F> \<R>) = NF (srstep \<F> \<S>)"
proof -
  have [simp]: "\<not> funas_term s \<subseteq> \<F> \<Longrightarrow> s \<in> NF (srstep \<F> \<U>)" for s \<U> by (meson NF_I sig_stepE(1))
  have d1: "s \<in> NF (gsrstep \<H> \<R>) \<Longrightarrow> s \<in> NF (gsrstep \<H> \<S>)" for s using nf by auto
  have d2: "s \<in> NF (gsrstep \<H> \<S>) \<Longrightarrow> s \<in> NF (gsrstep \<H> \<R>)" for s using nf by auto
  {fix s assume n: "s \<in> NF (srstep \<F> \<R>)" then have "s \<in> NF (srstep \<F> \<S>)"
      using NF_to_fresh_const_subst_NF[OF lin(1) fresh(1) well(1) _ n, THEN d1]
      using fresh_const_subst_NF_pres[OF fresh(2) well(2) _ lift, of s]
      by (cases "funas_term s \<subseteq> \<F>") simp_all}
  moreover
  {fix s assume n: "s \<in> NF (srstep \<F> \<S>)" then have "s \<in> NF (srstep \<F> \<R>)"
      using NF_to_fresh_const_subst_NF[OF lin(2) fresh(2) well(2) _ n, THEN d2]
      using fresh_const_subst_NF_pres[OF fresh(1) well(1) _ lift, of s]
      by (cases "funas_term s \<subseteq> \<F>") simp_all}
  ultimately show ?thesis by blast
qed

\<comment> \<open>Steps of ground\<close>
lemma gsrsteps_to_srsteps:
  "(s, t) \<in> (gsrstep \<F> \<R>)\<^sup>+ \<Longrightarrow> (s, t) \<in> (srstep \<F> \<R>)\<^sup>+"
  by (meson inf_le1 trancl_mono)

lemma gsrsteps_eq_to_srsteps_eq:
  "(s, t) \<in> (gsrstep \<F> \<R>)\<^sup>* \<Longrightarrow> (s, t) \<in> (srstep \<F> \<R>)\<^sup>*"
  by (metis gsrsteps_to_srsteps rtrancl_eq_or_trancl)

lemma gsrsteps_to_rsteps:
  "(s, t) \<in> (gsrstep \<F> \<R>)\<^sup>+ \<Longrightarrow> (s, t) \<in> (rstep \<R>)\<^sup>+"
  using gsrsteps_to_srsteps srstepsD by blast

lemma gsrsteps_eq_to_rsteps_eq:
  "(s, t) \<in> (gsrstep \<F> \<R>)\<^sup>* \<Longrightarrow> (s, t) \<in> (rstep \<R>)\<^sup>*"
  by (metis gsrsteps_eq_to_srsteps_eq rtrancl_eq_or_trancl srstepsD)

lemma gsrsteps_eq_relcomp_srsteps_relcompD:
  "(s, t) \<in> (gsrstep \<F> \<R>)\<^sup>* O (gsrstep \<F> \<S>)\<^sup>* \<Longrightarrow> (s, t) \<in> (srstep \<F> \<R>)\<^sup>* O (srstep \<F> \<S>)\<^sup>*"
  using gsrsteps_eq_to_srsteps_eq by blast

lemma gsrsteps_eq_relcomp_to_rsteps_relcomp:
  "(s, t) \<in> (gsrstep \<F> \<R>)\<^sup>* O (gsrstep \<F> \<S>)\<^sup>* \<Longrightarrow> (s, t) \<in> (rstep \<R>)\<^sup>* O (rstep \<S>)\<^sup>*"
  using gsrsteps_eq_relcomp_srsteps_relcompD
  using gsrsteps_eq_to_rsteps_eq by blast

lemma ground_srsteps_gsrsteps:
  assumes "ground s" "ground t"
    and "(s, t) \<in> (srstep \<F> \<R>)\<^sup>+"
  shows "(s, t) \<in> (gsrstep \<F> \<R>)\<^sup>+"
proof -
  let ?\<sigma> = "\<lambda> _. s"
  from assms(3) have f: "funas_term s \<subseteq> \<F>" using srstepsD by blast
  have "(s \<cdot> ?\<sigma>, t \<cdot> ?\<sigma>) \<in> (gsrstep \<F> \<R>)\<^sup>+" using assms(3, 1) f
  proof (induct)
    case (base t)
    then have "(s \<cdot> ?\<sigma>, t \<cdot> ?\<sigma>) \<in> gsrstep \<F> \<R>"
      by (auto intro: srstep_subst_closed)
    then show ?case by auto
  next
    case (step t u)
    from step(2, 4, 5) have "(t \<cdot> ?\<sigma>, u \<cdot> ?\<sigma>) \<in> gsrstep \<F> \<R>"
      by (auto intro: srstep_subst_closed)
    then show ?case using step(3 - 5)
      by (meson Transitive_Closure.trancl_into_trancl)
  qed
  then show ?thesis using assms(1, 2)
    by (simp add: ground_subst_apply)
qed

lemma ground_srsteps_eq_gsrsteps_eq:
  assumes "ground s" "ground t"
    and "(s, t) \<in> (srstep \<F> \<R>)\<^sup>*"
  shows "(s, t) \<in> (gsrstep \<F> \<R>)\<^sup>*"
  using ground_srsteps_gsrsteps
  by (metis assms rtrancl_eq_or_trancl)

lemma srsteps_eq_relcomp_gsrsteps_relcomp:
  assumes "(s, t) \<in> (srstep \<F> \<R>)\<^sup>* O (srstep \<F> \<S>)\<^sup>*"
    and "ground s" "ground t"
  shows "(s, t) \<in> (gsrstep \<F> \<R>)\<^sup>* O (gsrstep \<F> \<S>)\<^sup>*"
proof -
  from assms(1) obtain u where steps: "(s, u) \<in> (srstep \<F> \<R>)\<^sup>*" "(u, t) \<in> (srstep \<F> \<S>)\<^sup>*"
    by blast
  let ?\<sigma> = "\<lambda> x. s"
  have "(s \<cdot> ?\<sigma>, u \<cdot> ?\<sigma>) \<in> (srstep \<F> \<R>)\<^sup>*" "(u \<cdot> ?\<sigma>, t \<cdot> ?\<sigma>) \<in> (srstep \<F> \<S>)\<^sup>*" using steps
    using srsteps_eq_subst_closed[OF steps(1), of ?\<sigma>]
    using srsteps_eq_subst_closed[OF steps(2), of ?\<sigma>]
    by (metis rtrancl_eq_or_trancl srstepsD)+
  then have  "(s \<cdot> ?\<sigma>, u \<cdot> ?\<sigma>) \<in> (gsrstep \<F> \<R>)\<^sup>*" "(u \<cdot> ?\<sigma>, t \<cdot> ?\<sigma>) \<in> (gsrstep \<F> \<S>)\<^sup>*"
    using assms(2)
    by (auto intro: ground_srsteps_eq_gsrsteps_eq)
  then show ?thesis using assms(2, 3)
    by (auto simp: ground_subst_apply)
qed

\<comment> \<open>Steps of llrg systems\<close>

lemma llrg_ground_rhs:
  "llrg \<R> \<Longrightarrow> (l, r) \<in> \<R> \<Longrightarrow> ground r"
  unfolding llrg_def by auto

lemma llrg_rrsteps_groundness:
  assumes "llrg \<R>" and "(s, t) \<in> (srrstep \<F> \<R>)"
  shows "ground t" using assms(2) ground_vars_term_empty
  by (fastforce simp: llrg_def sig_step_def dest!: llrg_ground_rhs[OF assms(1)] split: prod.splits)

lemma llrg_rsteps_pres_groundness:
  assumes "llrg \<R>" "ground s"
   and "(s, t) \<in> (srstep \<F> \<R>)\<^sup>*"
 shows "ground t" using assms(3, 2)
proof (induct rule: rtrancl.induct)
  case (rtrancl_into_rtrancl s t u)
  then have "ground t" by auto
  then show ?case using rtrancl_into_rtrancl(3)
    by (auto simp: sig_step_def vars_term_ctxt_apply ground_vars_term_empty ground_subst_apply
      dest!: llrg_ground_rhs[OF assms(1)] rstep_imp_C_s_r split: prod.splits)
qed simp

lemma llrg_srsteps_with_root_step_ground:
  assumes "llrg \<R>" and "(s, t) \<in> srsteps_with_root_step \<F> \<R>"
  shows "ground t" using assms llrg_rrsteps_groundness llrg_rsteps_pres_groundness
  unfolding srsteps_with_root_step_def
  by blast

lemma llrg_srsteps_with_root_step_inv_ground:
  assumes "llrg \<R>" and "(s, t) \<in> srsteps_with_root_step \<F> (\<R>\<inverse>)"
  shows "ground s" using assms llrg_rrsteps_groundness llrg_rsteps_pres_groundness
  unfolding srsteps_with_root_step_def
  by (metis (no_types, lifting) converseD relcomp.cases rtrancl_converseD srrstep_converse_dist srstep_converse_dist)

lemma llrg_funas_term_step_pres:
  assumes "llrg \<R>" and "(s, t) \<in> (rstep \<R>)"
  shows "funas_term t \<subseteq> funas_rel \<R> \<union> funas_term s"
proof -
  have [simp]: "(l, r) \<in> \<R> \<Longrightarrow> r \<cdot> \<sigma> = r" for l r \<sigma>  using assms(1) unfolding llrg_def
    by(auto split: prod.splits intro: ground_subst_apply)
  show ?thesis using assms
    by (auto simp: llrg_def funas_rel_def dest!: rstep_imp_C_s_r)
qed

lemma llrg_funas_term_steps_pres:
  assumes "llrg \<R>" and "(s, t) \<in> (rstep \<R>)\<^sup>*"
  shows "funas_term t \<subseteq> funas_rel \<R> \<union> funas_term s"
  using assms(2) llrg_funas_term_step_pres[OF assms(1)]
  by (induct) auto

\<comment> \<open>Steps of monadic llrg systems\<close>

lemma monadic_ground_ctxt_apply:
  "monadic \<F> \<Longrightarrow> funas_ctxt C \<subseteq> \<F> \<Longrightarrow> ground r \<Longrightarrow> ground C\<langle>r\<rangle>"
  by (induct C) (auto simp: monadic_def)

lemma llrg_monadic_rstep_pres_groundness:
  assumes "llrg \<R>" "monadic \<F>"
   and "(s, t) \<in> srstep \<F> \<R>"
  shows "ground t" using assms(3)
proof -
  from assms(3) obtain C l r \<sigma> where r: "(l, r) \<in> \<R>" and t:"t = C\<langle>r \<cdot> \<sigma>\<rangle>"
    using rstep_imp_C_s_r unfolding sig_step_def by blast
  from assms(1, 3) have funas: "funas_term t \<subseteq> \<F>" "ground r"
    by (auto simp: llrg_ground_rhs[OF assms(1) r(1)] dest: srstepD)
  then have *: "r \<cdot> \<sigma> = r" by (simp add: ground_subst_apply)
  show ?thesis using funas assms(2) unfolding t *
    by (intro monadic_ground_ctxt_apply) auto
qed

lemma llrg_monadic_rsteps_groundness:
  assumes "llrg \<R>" "monadic \<F>"
   and "(s, t) \<in> (srstep \<F> \<R>)\<^sup>+"
  shows "ground t" using assms(3)
  using llrg_monadic_rstep_pres_groundness[OF assms(1 ,2)]
  by (induct rule: trancl.induct) auto

\<comment> \<open>Steps in monadic lv system\<close>

fun monadic_term where
  "monadic_term (Var x) = True"
| "monadic_term (Fun f []) = True"
| "monadic_term (Fun f ts) = (length ts = Suc 0 \<and> monadic_term (hd ts))"

fun monadic_get_leave where
  "monadic_get_leave (Var x) = (Var x)"
| "monadic_get_leave (Fun f []) = Fun f []"
| "monadic_get_leave (Fun f ts) = monadic_get_leave (hd ts)"

fun monadic_replace_leave where
  "monadic_replace_leave t (Var x) = t"
| "monadic_replace_leave t (Fun f []) = t"
| "monadic_replace_leave t (Fun f ts) = Fun f [monadic_replace_leave t (hd ts)]"

lemma monadic_replace_leave_undo_const_subst:
  assumes "monadic_term s"
  shows "monadic_replace_leave (monadic_get_leave s) (s \<cdot> const_subst c) = s" using assms
proof (induct s)
  case (Fun f ts) then show ?case
    by (cases ts) auto
qed auto

lemma monadic_replace_leave_context:
  assumes "monadic_term C\<langle>s\<rangle>"
  shows "monadic_replace_leave t C\<langle>s\<rangle> = C\<langle>monadic_replace_leave t s\<rangle>" using assms
proof (induct C)
  case (More f ss C ts) then show ?case
    by (cases ss; cases ts) auto
qed simp

lemma monadic_replace_leave_subst:
  assumes "monadic_term (s \<cdot> \<sigma>)" "\<not> ground s"
  shows "monadic_replace_leave t (s \<cdot> \<sigma>) = s \<cdot> (\<lambda> x. monadic_replace_leave t (\<sigma> x))" using assms
proof (induct s)
  case (Fun f ts) then show ?case
    by (cases ts) auto
qed auto

lemma monadic_sig:
  "monadic \<F> \<Longrightarrow> (f, length ts) \<in> \<F> \<Longrightarrow> length ts \<le> Suc 0"
  by (auto simp: monadic_def)

lemma monadic_sig_funas_term_mt:
  "monadic \<F> \<Longrightarrow> funas_term s \<subseteq> \<F> \<Longrightarrow> monadic_term s"
proof (induct s)
  case (Fun f ts) then show ?case unfolding monadic_def
    by (cases ts) auto
qed simp

lemma monadic_term_const_pres [intro]:
  "monadic_term s \<Longrightarrow> monadic_term (s \<cdot> const_subst c)"
proof (induct s)
  case (Fun f ts) then show ?case
    by (cases ts) auto
qed simp

lemma remove_const_lv_mondaic_step_lhs:
  assumes lv: "lv \<R>" and fresh: "(c, 0) \<notin> funas_rel \<R>"
   and mon: "monadic \<F>"
   and step: "(s \<cdot> const_subst c, t) \<in> (srstep \<F> \<R>)"
 shows "(s, t) \<in> (srstep \<F> \<R>)"
proof -
  from step obtain C l r \<sigma> where s: "(l, r) \<in> \<R>" "s \<cdot> const_subst c = C\<langle>l \<cdot> \<sigma>\<rangle>" "t = C\<langle>r \<cdot> \<sigma>\<rangle>"
    by fastforce
  have lv: "x \<in> vars_term l \<Longrightarrow> x \<notin> vars_term r" for x using s(1) lv
    by (auto simp: lv_def)
  from s(1) fresh have cl: "(c, 0) \<notin> funas_term l" by (auto simp: funas_rel_def)
  have funas: "funas_term s \<subseteq> \<F>" "(c, 0) \<notin> funas_term l" "funas_term t \<subseteq> \<F>" using s(1) fresh
    using step mon funas_term_subst unfolding funas_rel_def
    by (auto dest!: srstepD) blast
  then have mt: "monadic_term s" "monadic_term (s \<cdot> const_subst c)"
    using monadic_sig_funas_term_mt[OF mon] by auto
  then have ml: "monadic_term (l \<cdot> \<sigma>)" unfolding s(2)
    by (metis funas_ctxt_apply le_sup_iff step mon monadic_sig_funas_term_mt s(2) sig_stepE(1))
  show ?thesis
  proof (cases "ground s")
    case True then show ?thesis using step
      by (auto simp: ground_subst_apply)
  next
    case False note ng = this
    then have cs: "(c, 0) \<in> funas_term (s \<cdot> const_subst c)"
      by (auto simp: funas_term_subst vars_term_empty_ground)
    have ngrl: "\<not> ground l" using s(2) cs mt ng
    proof (induct s arbitrary: C)
      case (Var x) then show ?case using cl cs
        by (cases C) (auto simp: funas_rel_def ground_subst_apply)
    next
      case (Fun f ts)
      from Fun(5-) obtain t where [simp]: "ts = [t]" by (cases ts) auto
      show ?case
      proof (cases "C = Hole")
        case True then show ?thesis using Fun(2, 3) cl
          by (auto simp: ground_subst_apply)
      next
        case False
        from this Fun(2, 3) obtain D where [simp]: "C = More f [] D []"
          by (cases C) (auto simp: Cons_eq_append_conv)
        show ?thesis using Fun(1)[of t D] Fun(2-)
          by simp
      qed
    qed
    let ?\<tau> = "\<lambda> x. if x \<in> vars_term l then monadic_replace_leave (monadic_get_leave s) (\<sigma> x) else (\<sigma> x)"
    have "C\<langle>l \<cdot> (\<lambda> x. monadic_replace_leave (monadic_get_leave s) (\<sigma> x))\<rangle> = C\<langle>l \<cdot> ?\<tau>\<rangle>"
      by (auto intro: term_subst_eq)
    then have "s = C\<langle>l \<cdot> ?\<tau>\<rangle>" using arg_cong[OF s(2), of "monadic_replace_leave (monadic_get_leave s)",
      unfolded monadic_replace_leave_undo_const_subst[OF mt(1), of c],
      unfolded monadic_replace_leave_context[OF mt(2)[unfolded s(2)]],
      unfolded monadic_replace_leave_subst[OF ml ngrl]]
      by presburger
    moreover have "t = C\<langle>r \<cdot> ?\<tau>\<rangle>" using lv unfolding s(3)
      by (auto intro!: term_subst_eq)
    ultimately show ?thesis using s(1) funas(1, 3)
      by blast
  qed
qed

lemma remove_const_lv_mondaic_step_rhs:
  assumes lv: "lv \<R>" and fresh: "(c, 0) \<notin> funas_rel \<R>"
    and mon: "monadic \<F>"
    and step: "(s, t \<cdot> const_subst c) \<in> (srstep \<F> \<R>)"
  shows "(s, t) \<in> (srstep \<F> \<R>)"
proof -
  have inv_v: "lv (\<R>\<inverse>)""(c, 0) \<notin> funas_rel (\<R>\<inverse>)" using fresh lv
    by (auto simp: funas_rel_def lv_def)
  have "(t \<cdot> const_subst c, s) \<in> (srstep \<F> (\<R>\<inverse>))" using step
    by (auto simp: rew_converse_outwards)
  from remove_const_lv_mondaic_step_lhs[OF inv_v mon this]
  have "(t, s) \<in> (srstep \<F> (\<R>\<inverse>))" by simp
  then show ?thesis by (auto simp: rew_converse_outwards)
qed

lemma remove_const_lv_mondaic_steps_lhs:
  assumes lv: "lv \<R>" and fresh: "(c, 0) \<notin> funas_rel \<R>"
    and mon: "monadic \<F>"
    and steps: "(s \<cdot> const_subst c, t) \<in> (srstep \<F> \<R>)\<^sup>+"
  shows "(s, t) \<in> (srstep \<F> \<R>)\<^sup>+"
  using remove_const_lv_mondaic_step_lhs[OF lv fresh mon] steps
  by (meson converse_tranclE r_into_trancl trancl_into_trancl2)

lemma remove_const_lv_mondaic_steps_rhs:
  assumes lv: "lv \<R>" and fresh: "(c, 0) \<notin> funas_rel \<R>"
    and mon: "monadic \<F>"
    and steps: "(s, t \<cdot> const_subst c) \<in> (srstep \<F> \<R>)\<^sup>+"
  shows "(s, t) \<in> (srstep \<F> \<R>)\<^sup>+"
  using remove_const_lv_mondaic_step_rhs[OF lv fresh mon] steps
  by (meson trancl.simps)

lemma remove_const_lv_mondaic_steps:
  assumes lv: "lv \<R>" and fresh: "(c, 0) \<notin> funas_rel \<R>"
    and mon: "monadic \<F>"
    and steps: "(s \<cdot> const_subst c, t \<cdot> const_subst c) \<in> (srstep \<F> \<R>)\<^sup>+"
  shows "(s, t) \<in> (srstep \<F> \<R>)\<^sup>+"
  using remove_const_lv_mondaic_steps_rhs[OF lv fresh mon remove_const_lv_mondaic_steps_lhs[OF assms]]
  by simp

\<comment> \<open>Steps on lv trs\<close>

lemma lv_root_step_idep_subst:
  assumes "lv \<R>"
    and "(s, t) \<in> srrstep \<F> \<R>"
    and well: "\<And> x. funas_term (\<sigma> x) \<subseteq> \<F>" "\<And> x. funas_term (\<tau> x) \<subseteq> \<F>"
  shows "(s \<cdot> \<sigma>, t \<cdot> \<tau>) \<in>  srrstep \<F> \<R>"
proof -
  from assms(2) obtain l r \<gamma> where mid: "s = l \<cdot> \<gamma>" "t = r \<cdot> \<gamma>" "(l, r) \<in> \<R>"
    by (auto simp: sig_step_def)
  from mid(3) assms(1) have vs: "x \<in> vars_term l \<Longrightarrow> x \<notin> vars_term r" for x
    by (auto simp: lv_def)
  let ?\<sigma> = "\<lambda> x. if x \<in> vars_term l then (\<gamma> x) \<cdot> \<sigma> else (\<gamma> x) \<cdot> \<tau>"
  have subst: "s \<cdot> \<sigma> = l \<cdot> ?\<sigma>" "t \<cdot> \<tau> = r \<cdot> ?\<sigma>"
    unfolding mid subst_subst_compose[symmetric]
    unfolding term_subst_eq_conv
    by (auto simp: subst_compose_def vs)
  then show ?thesis unfolding subst
    using assms(2) mid(3) well unfolding mid(1, 2)
    by (auto simp: sig_step_def funas_term_subst)
qed

lemma lv_srsteps_with_root_step_idep_subst:
  assumes "lv \<R>"
    and "(s, t) \<in> srsteps_with_root_step \<F> \<R>"
    and well: "\<And> x. funas_term (\<sigma> x) \<subseteq> \<F>" "\<And> x. funas_term (\<tau> x) \<subseteq> \<F>"
  shows "(s \<cdot> \<sigma>, t \<cdot> \<tau>) \<in> srsteps_with_root_step \<F> \<R>" using assms(2)
  using lv_root_step_idep_subst[OF assms(1) _ well, where ?x1 = id and ?x2 = id]
  using srsteps_eq_subst_closed[OF _ well(1), where ?x1 = id and ?\<R> = \<R>]
  using srsteps_eq_subst_closed[OF _ well(2), where ?x1 = id and ?\<R> = \<R>]
  by (auto simp: srsteps_with_root_step_def) (metis (full_types) relcomp3_I)

end


(*  Title:      Demo.thy
    Author:     Yutaka Nagashima, Czech Technical University in Prague, the University of Innsbruck

Download PSL at https://github.com/data61/PSL/releases/tag/v0.1.2-alpha
*)
theory Demo
imports Main (*"PSL/PSL"*)
begin

lemma demo1: "A \<and> B \<longrightarrow> (C \<longrightarrow> A \<and> C)"
  oops

lemma demo2: "w \<and> x \<longrightarrow> y \<and> z \<longrightarrow> z"
  oops

fun sep::"'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "sep a [] = []" |
  "sep a [x] = [x]" |
  "sep a (x#y#zs) = x # a # sep a (y#zs)"

(*strategy DInd = Thens [Dynamic (Induct), Auto, IsSolved]*)

lemma "map f (sep x xs) = sep (f x) (map f xs)"
  find_theorems name:"map" name:"List.list" "map _ _ = _"
(*  find_proof DInd
    try_hard *)
  oops

primrec itrev:: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "itrev [] ys = ys" |
  "itrev (x#xs) ys = itrev xs (x#ys)"

lemma "itrev xs [] = rev xs"
  oops

end


theory PAC_Misc
  imports Main
begin

text "I believe this should be added to the simplifier by default..."
lemma Collect_eq_comp':
  "{(x, y). P x y} O {(c, a). c = f a} = {(x, a). P x (f a)}"
  by auto

lemma in_set_conv_iff:
  "x \<in> set (take n xs) \<longleftrightarrow> (\<exists>i<n. i < length xs \<and> xs ! i = x)"
  by (metis in_set_conv_nth length_take min_less_iff_conj nth_take)

lemma in_set_take_conv_nth:
  "x \<in> set (take n xs) \<longleftrightarrow> (\<exists>i<min n (length xs). xs ! i = x)"
  by (simp add: in_set_conv_iff)

end


theory Proofs_no_setVarAny
  imports HandDryer_no_setVarAny VCTheoryLemmas_no_setVarAny Extra_no_setVarAny
begin

theorem proof_1_1:
"VC1 inv1 s0"
  apply(simp only: VC1_def inv1_def R1_def
 extraInv_def waiting_def drying_def)
  by auto

theorem proof_2_1:
"VC1 inv2 s0"
  apply(simp only: VC1_def inv2_def R2_def
 extraInv_def waiting_def drying_def)
  by auto

theorem proof_3_1:
"VC1 inv3 s0"
  apply(simp only: VC1_def inv3_def R3_def
 extraInv_def waiting_def drying_def)
  by auto

theorem proof_4_1:
"VC1 inv4 s0"
  apply(simp only: VC1_def inv4_def R4_def
 extraInv_def waiting_def drying_def)
  by auto

theorem proof_2_2:
"VC2 inv2 s0 hands_value"
  apply(simp only: VC2_def inv2_def R2_def
dryer_def)
  apply(rule impI; rule conjI)
  apply(auto)
  using extra2 by (auto simp add: VC2_def dryer_def)

theorem proof_2_3:
"VC3 inv2 s0 hands_value"
 apply(simp only: VC3_def inv2_def R2_def
dryer_def)
  apply(rule impI; rule conjI)
   apply(auto)
  using extra3 by (auto simp add: VC3_def dryer_def)

theorem proof_2_4:
"VC4 inv2 s0 hands_value"
 apply(simp only: VC4_def R2_def
dryer_def)
  by auto

theorem proof_2_5:
"VC5 inv2 s0 hands_value"
 apply(simp only: VC5_def inv2_def R2_def
dryer_def)
  apply(rule impI; rule conjI)
  apply(auto)
  using extra5 by (auto simp add: VC5_def)

theorem proof_2_6:
"VC6 inv2 s0 hands_value"
 apply(simp only: VC6_def inv2_def R2_def
dryer_def)
  apply(rule impI; rule conjI)
   apply(rule conjI)
    apply simp
   apply((rule allI)+)
   apply(rule impI)
   apply(simp split: if_splits)
  using substate_toEnvNum_id apply blast
   apply auto[1]
  using extra6 by (auto simp add: VC6_def)

theorem proof_2_7:
"VC7 inv2 s0 hands_value"
 apply(simp only: VC7_def inv2_def R2_def
dryer_def)
  apply(rule impI; rule conjI)
  apply(auto)
  apply force
  using substate_toEnvNum_id apply blast
  using extra7 by (auto simp add: VC7_def)

theorem proof_4_2:
"VC2 inv4 s0 hands_value"
apply(simp only: VC2_def inv4_def R4_def
dryer_def)
  apply(rule impI; rule conjI)
   apply(auto)
  using extra2 by (auto simp add: VC2_def dryer_def)

theorem proof_4_3:
"VC3 inv4 s0 hands_value"
apply(simp only: VC3_def inv4_def R4_def
dryer_def)
  apply(rule impI; rule conjI)
   apply(auto)
  using extra3 by (auto simp add: VC3_def dryer_def)

theorem proof_4_4:
"VC4 inv4 s0 hands_value"
apply(simp only: VC4_def R4_def
dryer_def)
  by auto

theorem proof_4_5:
"VC5 inv4 s0 hands_value"
apply(simp only: VC5_def inv4_def R4_def
dryer_def)
  apply(rule impI; rule conjI)
  apply(auto)
   apply(force)
  using substate_toEnvNum_id apply(blast)
  using extra5 by (auto simp add: VC5_def)

theorem proof_4_6:
"VC6 inv4 s0 hands_value"
apply(simp only: VC6_def inv4_def R4_def
dryer_def)
  apply(rule impI; rule conjI)
   apply(auto)
  using extra6 by (auto simp add: VC6_def)

theorem proof_4_7:
"VC7 inv4 s0 hands_value"
apply(simp only: VC7_def inv4_def R4_def
dryer_def)
  apply(rule impI; rule conjI)
   apply(auto)
  using extra7 by (auto simp add: VC7_def)

theorem proof_1_4:
"VC4 inv1 s0 hands_value"
apply(simp only: VC4_def R1_def
dryer_def)
  by auto

theorem proof_3_4:
"VC4 inv3 s0 hands_value"
apply(simp only: VC4_def R3_def
dryer_def)
  by auto

end


theory PF_Optimize_Match_Exprs
  imports PF_Firewall_Common
"SemanticsTernary/PF_Predicates"
begin

text\<open>optimizing match expressions\<close> (* adapted from Iptables_Semantics.Firewall_Common *)

fun optimize_matches_option ::
"('a match_expr \<Rightarrow> 'a match_expr option) \<Rightarrow> 'a ruleset \<Rightarrow> 'a ruleset" where
"optimize_matches_option _ [] = []" |
"optimize_matches_option f (PfRule r#rs) =
  (case f (pf_rule.get_match r) of
    None \<Rightarrow> optimize_matches_option f rs
    | Some m \<Rightarrow> (PfRule (r\<lparr>pf_rule.get_match := m\<rparr>))#optimize_matches_option f rs)"

lemma optimize_matches_option_preserves:
  assumes simple_ruleset: "simple_ruleset rs"
      and f_Some: "(\<And> r m. (PfRule r) \<in> set rs \<and> f (pf_rule.get_match r) = Some m \<Longrightarrow> P m)"
    shows "(\<forall> r \<in> set (optimize_matches_option f rs). (case r of (PfRule r) \<Rightarrow> P (pf_rule.get_match r) | _ \<Rightarrow> True))"
  using assms
proof(induction rs rule: optimize_matches_option.induct)
  case (1 uu)
  then show ?case by simp
next
  case (2 f r rs)
  then show ?case
  proof(cases "f (pf_rule.get_match r)")
    case None
    then show ?thesis using None 2 by (auto simp add: simple_ruleset_def)
  next
    case (Some a)
    then show ?thesis using Some 2 by (auto simp add: simple_ruleset_def)
  qed
next
  case (3 a vb vc va)
  then show ?case by (auto simp add: simple_ruleset_def)
qed

lemma optimize_matches_option_append:
  assumes "simple_ruleset rs1"
      and "simple_ruleset rs2"
    shows "optimize_matches_option f (rs1@rs2) =
           optimize_matches_option f rs1 @ optimize_matches_option f rs2"
  using assms by (induction rs1 rule: optimize_matches_option.induct)
                 (auto simp: simple_ruleset_def split: option.split)

definition optimize_matches :: "('a match_expr \<Rightarrow> 'a match_expr) \<Rightarrow> 'a ruleset \<Rightarrow> 'a ruleset" where
  "optimize_matches f rs =
    optimize_matches_option (\<lambda>m. (if matcheq_matchNone (f m) then None else Some (f m))) rs"

lemma optimize_matches_empty[simp]:
"optimize_matches f [] = []"
  unfolding optimize_matches_def by simp

lemma optimize_matches_append:
  assumes "simple_ruleset rs1"
      and "simple_ruleset rs2"
    shows "optimize_matches f (rs1@rs2) = optimize_matches f rs1 @ optimize_matches f rs2"
  using assms by(simp add: optimize_matches_def optimize_matches_option_append)

lemma optimize_matches_preserves:
  assumes "simple_ruleset rs"
  shows  "(\<And> r. (PfRule r) \<in> set rs \<Longrightarrow> P (f (pf_rule.get_match r))) \<Longrightarrow>
    \<forall> r \<in> set (optimize_matches f rs). (case r of (PfRule r) \<Rightarrow> P (pf_rule.get_match r) | _ \<Rightarrow> True)"
  using assms
  unfolding optimize_matches_def
  apply(rule optimize_matches_option_preserves)
  by(auto split: if_split_asm)

lemma optimize_matches_simple_ruleset: "simple_ruleset rs \<Longrightarrow> simple_ruleset (optimize_matches f rs)"
  by(simp add: optimize_matches_def optimize_matches_option_simple_ruleset)

fun optimize_matches_a :: "(action \<Rightarrow> 'a match_expr \<Rightarrow> 'a match_expr) \<Rightarrow> 'a ruleset \<Rightarrow> 'a ruleset" where
"optimize_matches_a _ [] = []" |
"optimize_matches_a f (PfRule r#rs) =
(PfRule (r\<lparr>pf_rule.get_match := f (pf_rule.get_action r) (pf_rule.get_match r)\<rparr>))#optimize_matches_a f rs"

lemma optimize_matches_a_simple_ruleset:
"simple_ruleset rs \<Longrightarrow> simple_ruleset (optimize_matches_a f rs)"
proof(induction rs)
  case Nil
  then show ?case by simp
next
  case (Cons a rs)
  then show ?case
  proof(cases a)
    case (PfRule x1)
    then have "simple_ruleset rs" using Cons(2) by (simp add: simple_ruleset_def)
    then show ?thesis using Cons PfRule by (simp add:simple_ruleset_def)
  next
    case (Anchor x21 x22)
    then show ?thesis using Cons(2) by (auto simp add: simple_ruleset_def)
  qed
qed

lemma optimize_matches_a_simple_ruleset_eq:
  "simple_ruleset rs \<Longrightarrow> (\<And> m a. a = Pass \<or> a = Block \<Longrightarrow> f1 a m = f2 a m)
    \<Longrightarrow> optimize_matches_a f1 rs = optimize_matches_a f2 rs"
proof(induction rs)
  case Nil
  then show ?case by simp
next
  case (Cons a rs)
  then show ?case
  proof(cases a)
    case (PfRule x1)
    then show ?thesis using Cons by (auto simp add:simple_ruleset_def) (cases "get_action x1";auto)
  next
    case (Anchor x21 x22)
    then show ?thesis using Cons by (auto simp add:simple_ruleset_def)
  qed
qed

lemma optimize_matches_a_preserves:
  assumes "simple_ruleset rs"
  shows "(\<And> r. (PfRule r) \<in> set rs \<Longrightarrow> P (f (pf_rule.get_action r) (pf_rule.get_match r)))
    \<Longrightarrow> \<forall> r \<in> set (optimize_matches_a f rs). (case r of (PfRule r) \<Rightarrow> P (pf_rule.get_match r)
                                                        | _ \<Rightarrow> True)"
  using assms
proof(induction rs)
  case Nil
  then show ?case by simp
next
  case (Cons a rs)
  then show ?case using Cons by (cases a; auto simp add: simple_ruleset_def)
qed

lemma simple_ruleset_wf_ruleset:
  assumes "simple_ruleset rs"
      and "all_PfRules_P (\<lambda>r. good_match_expr ctx (pf_rule.get_match r)) rs"
    shows "wf_ruleset ctx rs"
proof(-)
  have "all_AnchorRules_P (\<lambda>r. good_match_expr ctx (anchor_rule.get_match r)) rs"
    using assms unfolding simple_ruleset_def
    by (simp add: line.case_eq_if)
  then show ?thesis using assms(2) by (simp add:wf_ruleset_def)
qed

lemma simple_ruleset_all_AnchorRules_P[simp,intro]:
  "simple_ruleset rs \<Longrightarrow> all_AnchorRules_P P rs = True"
proof(induction rs)
  case Nil
  then show ?case by simp
next
  case (Cons a rs)
  then show ?case by (cases a) (simp add:simple_ruleset_def)+
qed

lemma simple_ruleset_all_PfRules_P:
  assumes "simple_ruleset rs"
  shows "all_PfRules_P P rs \<longleftrightarrow> (\<forall> r. (PfRule r) \<in> set rs \<longrightarrow> P r)"
  using assms proof(induction rs)
  case Nil
  then show ?case by simp
next
  case (Cons a rs)
  then show ?case
  proof(cases a)
  case (PfRule r)
    then show ?thesis
    proof(cases "P r")
      case True
      then show ?thesis using Cons PfRule by (simp add:simple_ruleset_def)
    next
      case False
      then show ?thesis using PfRule apply simp by blast
    qed
  next
  case (Anchor x21 x22)
    then show ?thesis using Cons by (auto simp:simple_ruleset_def)
  qed
qed

lemma optimize_matches_preserves_all_PfRules_P:
  assumes "simple_ruleset rs"
  shows "all_PfRules_P (\<lambda>r. (P (f (pf_rule.get_match r)))) rs \<Longrightarrow>
         all_PfRules_P (\<lambda>r. P (pf_rule.get_match r)) (optimize_matches f rs)"
proof(-)
  assume "all_PfRules_P (\<lambda>r. (P (f (pf_rule.get_match r)))) rs"
  then have "\<And>r. (PfRule r) \<in> set rs \<Longrightarrow> P (f (pf_rule.get_match r))"
    using assms simple_ruleset_all_PfRules_P by auto
  then have "\<forall> r \<in> set (optimize_matches f rs). (case r of (PfRule r) \<Rightarrow> P (pf_rule.get_match r) | _ \<Rightarrow> True)"
    using optimize_matches_preserves assms by blast
  then show ?thesis using assms simple_ruleset_all_PfRules_P optimize_matches_simple_ruleset
    by(smt line.simps(5))
qed

lemma optimize_matches_preserves_all_PfRules_P':
  assumes "simple_ruleset rs"
    and "\<And>m. P (f m)"
  shows "all_PfRules_P (\<lambda>r. P (pf_rule.get_match r)) (optimize_matches f rs)"
proof(-)
  have "\<And>r. (PfRule r) \<in> set rs \<Longrightarrow> P (f (pf_rule.get_match r))" using assms by auto
  then have "\<forall> r \<in> set (optimize_matches f rs). (case r of (PfRule r) \<Rightarrow> P (pf_rule.get_match r) | _ \<Rightarrow> True)"
    using optimize_matches_preserves assms by blast
  then show ?thesis using assms simple_ruleset_all_PfRules_P optimize_matches_simple_ruleset
    by(smt line.simps(5))
qed

end