(*
    Author:      Salomon Sickert
    License:     BSD
*)

section \<open>Executable Translation from LTL to Rabin Automata\<close>

theory LTL_Rabin_Impl
  imports Main "../Auxiliary/Map2" "../LTL_Rabin" "../LTL_Rabin_Unfold_Opt" af_Impl Mojmir_Rabin_Impl
begin

subsection \<open>Template\<close>

subsubsection \<open>Definition\<close>

locale ltl_to_rabin_base_code_def = ltl_to_rabin_base_def +
  fixes
    M_fin\<^sub>C :: "'a ltl \<Rightarrow> ('a ltl, nat) mapping \<Rightarrow> ('a ltl\<^sub>P \<times> ('a ltl, 'a ltl\<^sub>P list) mapping, 'a set) transition \<Rightarrow> bool"
begin

\<comment> \<open>Transition Function and Initial State\<close>

fun delta\<^sub>C
where
  "delta\<^sub>C \<Sigma> = \<delta> \<times> \<up>\<Delta>\<^sub>\<times> (nxt \<Sigma> \<delta>\<^sub>M o q\<^sub>0\<^sub>M o theG)"

fun initial\<^sub>C
where
  "initial\<^sub>C \<phi> = (q\<^sub>0 \<phi>, Mapping.tabulate (G_list \<phi>) (init o q\<^sub>0\<^sub>M o theG))"

\<comment> \<open>Acceptance Condition\<close>

definition max_rank_of\<^sub>C
where
  "max_rank_of\<^sub>C \<Sigma> \<psi> = card (Set.filter (Not o semi_mojmir_def.sink (set \<Sigma>) \<delta>\<^sub>M (q\<^sub>0\<^sub>M (theG \<psi>))) (Q\<^sub>L \<Sigma> \<delta>\<^sub>M (q\<^sub>0\<^sub>M (theG \<psi>))))"

fun Acc_fin\<^sub>C
where
  "Acc_fin\<^sub>C \<Sigma> \<pi> \<chi> ((_, m'), \<nu>, _) = (
    let
      t = (the (Mapping.lookup m' \<chi>), \<nu>, []); \<comment> \<open>Third element is unused. Hence it is safe to pass a dummy value.\<close>
      \<G> = Mapping.keys \<pi>
    in
      fail_filt \<Sigma> \<delta>\<^sub>M (q\<^sub>0\<^sub>M (theG \<chi>)) (ltl_prop_entails_abs \<G>) t
    \<or> merge_filt \<delta>\<^sub>M (q\<^sub>0\<^sub>M (theG \<chi>)) (ltl_prop_entails_abs \<G>) (the (Mapping.lookup \<pi> \<chi>)) t)"

fun Acc_inf\<^sub>C
where
  "Acc_inf\<^sub>C \<pi> \<chi> ((_, m'), \<nu>, _) = (
    let
      t = (the (Mapping.lookup m' \<chi>), \<nu>, []); \<comment> \<open>Third element is unused. Hence it is safe to pass a dummy value.\<close>
      \<G> = Mapping.keys \<pi>
    in
      succeed_filt \<delta>\<^sub>M (q\<^sub>0\<^sub>M (theG \<chi>)) (ltl_prop_entails_abs \<G>) (the (Mapping.lookup \<pi> \<chi>)) t)"

definition mappings\<^sub>C :: "'a set list \<Rightarrow> 'a ltl \<Rightarrow> ('a ltl, nat) mapping set"
where
  "mappings\<^sub>C \<Sigma> \<phi> \<equiv> {\<pi>. Mapping.keys \<pi> \<subseteq> \<^bold>G \<phi> \<and> (\<forall>\<chi> \<in> (Mapping.keys \<pi>). the (Mapping.lookup \<pi> \<chi>) < max_rank_of\<^sub>C \<Sigma> \<chi>)}"

definition reachable_transitions\<^sub>C
where
  "reachable_transitions\<^sub>C \<Sigma> \<phi> \<equiv> \<delta>\<^sub>L \<Sigma> (delta\<^sub>C (set \<Sigma>)) (initial\<^sub>C \<phi>)"

fun ltl_to_generalized_rabin\<^sub>C
where
  "ltl_to_generalized_rabin\<^sub>C \<Sigma> \<phi> = (
    let
      \<delta>_LTS = reachable_transitions\<^sub>C \<Sigma> \<phi>;
      \<alpha>_fin_filter = \<lambda>\<pi> t. M_fin\<^sub>C \<phi> \<pi> t \<or> (\<exists>\<chi> \<in> Mapping.keys \<pi>. Acc_fin\<^sub>C (set \<Sigma>) \<pi> \<chi> t);
      to_pair = \<lambda>\<pi>. (Set.filter (\<alpha>_fin_filter \<pi>) \<delta>_LTS, (\<lambda>\<chi>. Set.filter (Acc_inf\<^sub>C \<pi> \<chi>) \<delta>_LTS) ` Mapping.keys \<pi>);
      \<alpha> = to_pair ` (mappings\<^sub>C \<Sigma> \<phi>) \<comment> \<open>Multi-thread here!, prove \<open>mappings (set \<dots>)\<close> equation\<close>
    in
      (\<delta>_LTS, initial\<^sub>C \<phi>, \<alpha>))"

lemma mappings\<^sub>C_code:
  "mappings\<^sub>C \<Sigma> \<phi> = (
    let
      Gs = G_list \<phi>;
      max_rank = Mapping.lookup (Mapping.tabulate Gs (max_rank_of\<^sub>C \<Sigma>))
    in
      set (concat (map (mapping_generator_list (\<lambda>x. [0 ..< the (max_rank x)])) (subseqs Gs))))"
  (is "?lhs = ?rhs")
proof -
  {
    fix xs :: "'a ltl list"
    have subset_G: "\<And>x. x \<in> set (subseqs (xs)) \<Longrightarrow> set x \<subseteq> set xs"
      apply (induction xs)
      apply (simp)
      by (insert subseqs_powset; blast)
  }
  hence subset_G: "\<And>x. x \<in> set (subseqs (G_list \<phi>)) \<Longrightarrow> set x \<subseteq> \<^bold>G \<phi>"
    unfolding G_eq_G_list by auto

  have "?lhs = \<Union>{{\<pi>. Mapping.keys \<pi> = xs \<and> (\<forall>\<chi>\<in>Mapping.keys \<pi>. the (Mapping.lookup \<pi> \<chi>) < max_rank_of\<^sub>C \<Sigma> \<chi>)} | xs. xs \<in> set ` (set (subseqs (G_list \<phi>)))}"
    unfolding mappings\<^sub>C_def G_eq_G_list subseqs_powset by auto
  also
  have "\<dots> = \<Union>{{\<pi>. Mapping.keys \<pi> = set xs \<and> (\<forall>\<chi> \<in> set xs. the (Mapping.lookup \<pi> \<chi>) < max_rank_of\<^sub>C \<Sigma> \<chi>)} |
       xs. xs \<in> set (subseqs (G_list \<phi>))}"
    by auto
  also
  have "\<dots> = ?rhs"
    using subset_G
      by (auto simp add: Let_def mapping_generator_code [symmetric]
        lookup_tabulate G_eq_G_list [symmetric] mapping_generator_set_eq
        cong del: SUP_cong_simp; blast)
  finally
  show ?thesis
    by simp
qed

lemma reach_delta_initial:
  assumes "(x, y) \<in> reach \<Sigma> (delta\<^sub>C \<Sigma>) (initial\<^sub>C \<phi>)"
  assumes "\<chi> \<in> \<^bold>G \<phi>"
  shows "Mapping.lookup y \<chi> \<noteq> None" (is ?t1)
    and "distinct (the (Mapping.lookup y \<chi>))" (is ?t2)
proof -
  from assms(1) obtain w i where y_def: "y = run (\<up>\<Delta>\<^sub>\<times> (nxt \<Sigma> \<delta>\<^sub>M o q\<^sub>0\<^sub>M o theG)) (Mapping.tabulate (G_list \<phi>) (init o q\<^sub>0\<^sub>M o theG)) w i"
    unfolding reach_def delta\<^sub>C.simps initial\<^sub>C.simps simple_product_run by fast
  from assms(2) nxt_run_distinct show ?t1
    unfolding y_def using product_abs_run_Some[of "Mapping.tabulate (G_list \<phi>) (init o q\<^sub>0\<^sub>M o theG)" \<chi>] unfolding G_eq_G_list
    unfolding lookup_tabulate by fastforce
  with nxt_run_distinct show ?t2
    unfolding y_def using lookup_tabulate
    by (metis (no_types) G_eq_G_list assms(2) comp_eq_dest_lhs option.sel product_abs_run_Some)
qed

end

subsubsection \<open>Correctness\<close>

fun abstract_state :: "'x \<times> ('y, 'z list) mapping \<Rightarrow> 'x \<times> ('y \<rightharpoonup> 'z \<rightharpoonup> nat)"
where
  "abstract_state (a, b) = (a, (map_option rk) o (Mapping.lookup b))"

fun abstract_transition
where
  "abstract_transition (q, \<nu>, q') = (abstract_state q, \<nu>, abstract_state q')"

locale ltl_to_rabin_base_code = ltl_to_rabin_base + ltl_to_rabin_base_code_def +
  assumes
    M_fin\<^sub>C_correct: "\<lbrakk>t \<in> reach\<^sub>t \<Sigma> (delta\<^sub>C \<Sigma>) (initial\<^sub>C \<phi>); dom \<pi> \<subseteq> \<^bold>G \<phi>\<rbrakk> \<Longrightarrow>
      abstract_transition t \<in> M_fin \<pi> = M_fin\<^sub>C \<phi> (Mapping.Mapping \<pi>) t"
begin

lemma finite_reach\<^sub>C:
  "finite (reach\<^sub>t \<Sigma> (delta\<^sub>C \<Sigma>) (initial\<^sub>C \<phi>))"
proof -
  note finite_reach'
  moreover
  have "(\<And>x. x \<in> \<^bold>G \<phi> \<Longrightarrow> finite (reach \<Sigma> ((nxt \<Sigma> \<delta>\<^sub>M o q\<^sub>0\<^sub>M o theG) x) ((init o q\<^sub>0\<^sub>M o theG) x)))"
    using semi_mojmir.finite_Q[OF semi_mojmir] unfolding G_eq_G_list semi_mojmir_def.Q\<^sub>E_def by simp
  hence "finite (reach \<Sigma> (\<up>\<Delta>\<^sub>\<times> (nxt \<Sigma> \<delta>\<^sub>M o q\<^sub>0\<^sub>M o theG)) (Mapping.tabulate (G_list \<phi>) (init o q\<^sub>0\<^sub>M o theG)))"
    by (metis (no_types) finite_reach_product_abs[OF finite_keys_tabulate] G_eq_G_list  keys_tabulate lookup_tabulate_Some)
  ultimately
  have "finite (reach \<Sigma> (delta\<^sub>C \<Sigma>) (initial\<^sub>C \<phi>))"
    using finite_reach_simple_product by fastforce
  thus ?thesis
    using finite_\<Sigma> by (simp add: finite_reach\<^sub>t)
qed

lemma max_rank_of\<^sub>C_eq:
  assumes "\<Sigma> = set \<Sigma>'"
  shows "max_rank_of\<^sub>C \<Sigma>' \<psi> = max_rank_of \<Sigma> \<psi>"
proof -
  interpret \<MM>: semi_mojmir "set \<Sigma>'" \<delta>\<^sub>M "q\<^sub>0\<^sub>M (theG \<psi>)" w
    using semi_mojmir assms by force
  show ?thesis
    unfolding max_rank_of_def max_rank_of\<^sub>C_def Q\<^sub>L_reach[OF \<MM>.finite_reach] semi_mojmir_def.max_rank_def
    by (simp add: Set.filter_def set_diff_eq assms)
qed

lemma reachable_transitions\<^sub>C_eq:
  assumes "\<Sigma> = set \<Sigma>'"
  shows "reachable_transitions\<^sub>C \<Sigma>' \<phi> = reach\<^sub>t \<Sigma> (delta\<^sub>C \<Sigma>) (initial\<^sub>C \<phi>)"
  by (simp only: reachable_transitions\<^sub>C_def \<delta>\<^sub>L_reach[OF finite_reach\<^sub>C[unfolded assms]] assms)

lemma run_abstraction_correct:
  "run (delta \<Sigma>) (initial \<phi>) w = abstract_state o (run (delta\<^sub>C \<Sigma>) (initial\<^sub>C \<phi>) w)"
proof -
  {
    fix i

    let ?\<delta>\<^sub>2 = "\<Delta>\<^sub>\<times> (\<lambda>\<chi>. semi_mojmir_def.step \<Sigma> \<delta>\<^sub>M (q\<^sub>0\<^sub>M (theG \<chi>)))"
    let ?q\<^sub>2 = "\<iota>\<^sub>\<times> (\<^bold>G \<phi>) (\<lambda>\<chi>. semi_mojmir_def.initial (q\<^sub>0\<^sub>M (theG \<chi>)))"

    let ?\<delta>\<^sub>2' = "\<up>\<Delta>\<^sub>\<times> (nxt \<Sigma> \<delta>\<^sub>M o q\<^sub>0\<^sub>M o theG)"
    let ?q\<^sub>2' = "Mapping.tabulate (G_list \<phi>) (init o q\<^sub>0\<^sub>M o theG)"

    {
      fix q
      assume "q \<notin> \<^bold>G \<phi>"
      hence "?q\<^sub>2 q = None" and "Mapping.lookup (run ?\<delta>\<^sub>2' ?q\<^sub>2' w i) q = None"
        using G_eq_G_list product_abs_run_None by (simp, metis domIff keys_dom_lookup keys_tabulate)
      hence "run ?\<delta>\<^sub>2 ?q\<^sub>2 w i q = (\<lambda>m. (map_option rk) o (Mapping.lookup m)) (run ?\<delta>\<^sub>2' ?q\<^sub>2' w i) q"
        using product_run_None by (simp del: nxt.simps rk.simps)
    }

    moreover

    {
      fix q j
      assume "q \<in> \<^bold>G \<phi>"
      hence init: "?q\<^sub>2 q = Some (semi_mojmir_def.initial (q\<^sub>0\<^sub>M (theG q)))"
        and "Mapping.lookup (run ?\<delta>\<^sub>2' ?q\<^sub>2' w i) q = Some (run ((nxt \<Sigma> \<delta>\<^sub>M \<circ> q\<^sub>0\<^sub>M \<circ> theG) q) ((init \<circ> q\<^sub>0\<^sub>M \<circ> theG) q) w i)"
        apply (simp del: nxt.simps)
        apply (metis G_eq_G_list \<open>q \<in> \<^bold>G \<phi>\<close> lookup_tabulate product_abs_run_Some)
        done
      hence "run ?\<delta>\<^sub>2 ?q\<^sub>2 w i q = (\<lambda>m. (map_option rk) o (Mapping.lookup m)) (run ?\<delta>\<^sub>2' ?q\<^sub>2' w i) q"
        unfolding product_run_Some[of "\<iota>\<^sub>\<times> (\<^bold>G \<phi>) (\<lambda>\<chi>. semi_mojmir_def.initial (q\<^sub>0\<^sub>M (theG \<chi>)))" q, OF init]
        by (simp del: product.simps nxt.simps rk.simps; unfold map_of_map semi_mojmir.nxt_run_step_run[OF semi_mojmir]; simp)
    }

    ultimately

    have "run ?\<delta>\<^sub>2 ?q\<^sub>2 w i = (\<lambda>m. (map_option rk) o (Mapping.lookup m)) (run ?\<delta>\<^sub>2' ?q\<^sub>2' w i)"
      by blast
  }
  hence "\<And>i. run (delta \<Sigma>) (initial \<phi>) w i = abstract_state (run (delta\<^sub>C \<Sigma>) (initial\<^sub>C \<phi>) w i)"
    using finite_\<Sigma> bounded_w by (simp add: simple_product_run comp_def del: simple_product.simps)
  thus ?thesis
    by auto
qed

lemma
  assumes "t \<in> reach\<^sub>t \<Sigma> (delta\<^sub>C \<Sigma>) (initial\<^sub>C \<phi>)"
  assumes "\<chi> \<in> \<^bold>G \<phi>"
  shows Acc_fin\<^sub>C_correct:
    "abstract_transition t \<in> Acc_fin \<Sigma> \<pi> \<chi> \<longleftrightarrow> Acc_fin\<^sub>C \<Sigma> (Mapping.Mapping \<pi>) \<chi> t" (is ?t1)
    and Acc_inf\<^sub>C_correct:
    "abstract_transition t \<in> Acc_inf \<pi> \<chi> \<longleftrightarrow> Acc_inf\<^sub>C (Mapping.Mapping \<pi>) \<chi> t" (is ?t2)
proof -
  obtain x y \<nu> z z' where t_def [simp]: "t = ((x, y), \<nu>, (z, z'))"
    by (metis prod.collapse)
  have "(x, y) \<in> reach \<Sigma> (delta\<^sub>C \<Sigma>) (initial\<^sub>C \<phi>)"
    and "(z, z') \<in> reach \<Sigma> (delta\<^sub>C \<Sigma>) (initial\<^sub>C \<phi>)"
    using assms(1) unfolding reach\<^sub>t_def reach_def run\<^sub>t.simps t_def by blast+
  then obtain m m' where [simp]: "Mapping.lookup y \<chi> = Some m"
    and "Mapping.lookup y \<chi> \<noteq> None"
    and [simp]: "Mapping.lookup z' \<chi> = Some m'"
    using assms(2) by (blast dest: reach_delta_initial)+

  have FF [simp]: "fail_filt \<Sigma> \<delta>\<^sub>M (q\<^sub>0\<^sub>M (theG \<chi>)) (ltl_prop_entails_abs (dom \<pi>)) (the (Mapping.lookup y \<chi>), \<nu>, [])
    = ((the (map_option rk (Mapping.lookup y \<chi>)), \<nu>, (\<lambda>x. Some 0)) \<in> mojmir_to_rabin_def.fail\<^sub>R \<Sigma> \<delta>\<^sub>M (q\<^sub>0\<^sub>M (theG \<chi>)) {q. dom \<pi> \<up>\<Turnstile>\<^sub>P q})"
    unfolding option.map_sel[OF \<open>Mapping.lookup y \<chi> \<noteq> None\<close>] fail_filt_eq[where y = "[]", symmetric] by simp

  have MF [simp]: "\<And>i. merge_filt \<delta>\<^sub>M (q\<^sub>0\<^sub>M (theG \<chi>)) (ltl_prop_entails_abs (dom \<pi>)) i (the (Mapping.lookup y \<chi>), \<nu>, [])
    = ((the (map_option rk (Mapping.lookup y \<chi>)), \<nu>, (\<lambda>x. Some 0)) \<in> mojmir_to_rabin_def.merge\<^sub>R \<delta>\<^sub>M (q\<^sub>0\<^sub>M (theG \<chi>)) {q. dom \<pi> \<up>\<Turnstile>\<^sub>P q} i)"
    unfolding option.map_sel[OF \<open>Mapping.lookup y \<chi> \<noteq> None\<close>] merge_filt_eq[where y = "[]", symmetric] by simp

  have SF [simp]: "\<And>i. succeed_filt \<delta>\<^sub>M (q\<^sub>0\<^sub>M (theG \<chi>)) (ltl_prop_entails_abs (dom \<pi>)) i (the (Mapping.lookup y \<chi>), \<nu>, [])
    = ((the (map_option rk (Mapping.lookup y \<chi>)), \<nu>, (\<lambda>x. Some 0)) \<in> mojmir_to_rabin_def.succeed\<^sub>R \<delta>\<^sub>M (q\<^sub>0\<^sub>M (theG \<chi>)) {q. dom \<pi> \<up>\<Turnstile>\<^sub>P q} i)"
    unfolding option.map_sel[OF \<open>Mapping.lookup y \<chi> \<noteq> None\<close>] succeed_filt_eq[where y = "[]", symmetric] by simp

  note mojmir_to_rabin_def.fail\<^sub>R_def [simp]
  note mojmir_to_rabin_def.merge\<^sub>R_def [simp]
  note mojmir_to_rabin_def.succeed\<^sub>R_def [simp]

  show ?t1 and ?t2
    by (simp_all add: Let_def keys.abs_eq lookup.abs_eq del: rk.simps)
       (rule; metis option.distinct(1) option.sel option.collapse rk_facts(1))+
qed

theorem ltl_to_generalized_rabin\<^sub>C_correct:
  assumes "\<Sigma> = set \<Sigma>'"
  shows "accept\<^sub>G\<^sub>R (ltl_to_generalized_rabin \<Sigma> \<phi>) w \<longleftrightarrow> accept\<^sub>G\<^sub>R_LTS (ltl_to_generalized_rabin\<^sub>C \<Sigma>' \<phi>) w"
  (is "?lhs \<longleftrightarrow> ?rhs")
proof
  let ?\<delta> = "delta \<Sigma>"
  let ?q\<^sub>0 = "initial \<phi>"

  let ?\<delta>\<^sub>C = "delta\<^sub>C \<Sigma>"
  let ?q\<^sub>0\<^sub>C = "initial\<^sub>C \<phi>"
  let ?reach\<^sub>C = "reach\<^sub>t \<Sigma> (delta\<^sub>C \<Sigma>) (initial\<^sub>C \<phi>)"

  note reachable_transitions\<^sub>C_simp[simp] = reachable_transitions\<^sub>C_eq[OF assms]
  note max_rank_of\<^sub>C_simp[simp] = max_rank_of\<^sub>C_eq[OF assms]

  {
    fix \<pi> :: "'a ltl \<Rightarrow> nat option"
    assume \<pi>_wellformed: "dom \<pi> \<subseteq> \<^bold>G \<phi>"

    let ?F = "(M_fin \<pi> \<union> \<Union>{Acc_fin \<Sigma> \<pi> \<chi> | \<chi>. \<chi> \<in> dom \<pi>}, {Acc_inf \<pi> \<chi> | \<chi>. \<chi> \<in> dom \<pi>})"
    let ?fin = "{t. M_fin\<^sub>C \<phi> (Mapping.Mapping \<pi>) t} \<union> {t. \<exists>\<chi> \<in> dom \<pi>. Acc_fin\<^sub>C \<Sigma> (Mapping.Mapping \<pi>) \<chi> t}"
    let ?inf = "{{t. Acc_inf\<^sub>C (Mapping.Mapping \<pi>) \<chi> t} | \<chi>. \<chi> \<in> dom \<pi>}"

    have finite_reach': "finite (reach\<^sub>t \<Sigma> (delta \<Sigma>) (initial \<phi>))"
      by (meson finite_reach finite_\<Sigma> finite_reach\<^sub>t)

    have run_abstraction_correct':
      "run\<^sub>t (delta \<Sigma>) (initial \<phi>) w = abstract_transition o (run\<^sub>t (delta\<^sub>C \<Sigma>) (initial\<^sub>C \<phi>) w)"
      using run_abstraction_correct comp_def by auto

    have "accepting_pair\<^sub>G\<^sub>R ?\<delta> ?q\<^sub>0 ?F w \<longleftrightarrow> accepting_pair\<^sub>G\<^sub>R ?\<delta>\<^sub>C  ?q\<^sub>0\<^sub>C (?fin, ?inf) w" (is "?l \<longleftrightarrow> _")
      by (rule accepting_pair\<^sub>G\<^sub>R_abstract[OF finite_reach' finite_reach\<^sub>C bounded_w];
          insert \<open>dom \<pi> \<subseteq> \<^bold>G \<phi>\<close> M_fin\<^sub>C_correct Acc_fin\<^sub>C_correct Acc_inf\<^sub>C_correct run_abstraction_correct'; blast)
    also
    have "\<dots> \<longleftrightarrow> accepting_pair\<^sub>G\<^sub>R_LTS ?reach\<^sub>C ?q\<^sub>0\<^sub>C (?fin \<inter> ?reach\<^sub>C, (\<lambda>I. I \<inter> ?reach\<^sub>C) ` ?inf) w" (is "_ \<longleftrightarrow> ?r")
      using bounded_w by (simp only: accepting_pair\<^sub>G\<^sub>R_LTS[symmetric] accepting_pair\<^sub>G\<^sub>R_restrict[symmetric])
    finally
    have "?l \<longleftrightarrow> ?r" .
  }

  note X = this

  {
    assume ?lhs
    then obtain \<pi> where 1: "dom \<pi> \<subseteq> \<^bold>G \<phi>"
      and 2: "\<And>\<chi>. \<chi> \<in> dom \<pi> \<Longrightarrow> the (\<pi> \<chi>) < max_rank_of \<Sigma> \<chi>"
      and 3: "accepting_pair\<^sub>G\<^sub>R (delta \<Sigma>) (initial \<phi>) (M_fin \<pi> \<union> \<Union>{Acc_fin \<Sigma> \<pi> \<chi> |\<chi>. \<chi> \<in> dom \<pi>}, {Acc_inf \<pi> \<chi> |\<chi>. \<chi> \<in> dom \<pi>}) w"
      by auto

    define \<pi>' where "\<pi>' = Mapping.Mapping \<pi>"

    have "dom \<pi> = Mapping.keys \<pi>'" and "\<pi> = Mapping.lookup \<pi>'"
      by (simp_all add: keys.abs_eq lookup.abs_eq \<pi>'_def)

    have acc_pair_LTS: "accepting_pair\<^sub>G\<^sub>R_LTS ?reach\<^sub>C ?q\<^sub>0\<^sub>C (({t. M_fin\<^sub>C \<phi> \<pi>' t} \<union> {t. \<exists>\<chi> \<in> Mapping.keys \<pi>'. Acc_fin\<^sub>C \<Sigma> \<pi>' \<chi> t}) \<inter> ?reach\<^sub>C,
        (\<lambda>I. I \<inter> ?reach\<^sub>C) ` {{t. Acc_inf\<^sub>C \<pi>' \<chi> t} | \<chi>. \<chi> \<in> Mapping.keys \<pi>'}) w"
      using 3 unfolding X[OF 1] unfolding \<open>dom \<pi> = Mapping.keys \<pi>'\<close> \<pi>'_def[symmetric] by simp

    show ?rhs
      apply (unfold ltl_to_generalized_rabin\<^sub>C.simps Let_def)
      apply (intro accept\<^sub>G\<^sub>R_LTS_I)
      apply (insert acc_pair_LTS; auto simp add: assms[symmetric] mappings\<^sub>C_def)
      apply (insert 1 2; unfold  \<open>dom \<pi> = Mapping.keys \<pi>'\<close>; unfold \<open>\<pi> = Mapping.lookup \<pi>'\<close>)
      by (auto simp add: assms[symmetric] Set.filter_def image_def mappings\<^sub>C_def)
  }

  moreover

  {
    assume ?rhs
    obtain Fin Inf where "(Fin, Inf) \<in> snd (snd (ltl_to_generalized_rabin\<^sub>C \<Sigma>' \<phi>))"
      and 4: "accepting_pair\<^sub>G\<^sub>R_LTS ?reach\<^sub>C (initial\<^sub>C \<phi>) (Fin, Inf) w"
       using accept\<^sub>G\<^sub>R_LTS_E[OF \<open>?rhs\<close>] apply (simp add: Let_def assms del: accept\<^sub>G\<^sub>R_LTS.simps) by auto

    then obtain \<pi> where Y: "(Fin, Inf) = (Set.filter (\<lambda>t. M_fin\<^sub>C \<phi> \<pi> t \<or> (\<exists>\<chi> \<in> Mapping.keys \<pi>. Acc_fin\<^sub>C \<Sigma> \<pi> \<chi> t)) ?reach\<^sub>C,
        (\<lambda>\<chi>. Set.filter (Acc_inf\<^sub>C \<pi> \<chi>) ?reach\<^sub>C) ` (Mapping.keys \<pi>))"
        and 1: "Mapping.keys \<pi> \<subseteq> \<^bold>G \<phi>" and 2: "\<And>\<chi>. \<chi> \<in> Mapping.keys \<pi> \<Longrightarrow> the (Mapping.lookup \<pi> \<chi>) < max_rank_of \<Sigma> \<chi>"
      unfolding ltl_to_generalized_rabin\<^sub>C.simps Let_def fst_conv snd_conv mappings\<^sub>C_def assms reachable_transitions\<^sub>C_simp max_rank_of\<^sub>C_simp by auto
    define \<pi>' where "\<pi>' = Mapping.rep \<pi>"
    have "dom \<pi>' = Mapping.keys \<pi>" and "Mapping.Mapping \<pi>' = \<pi>"
      by (simp_all add: \<pi>'_def mapping.rep_inverse keys.rep_eq)
    have 1: "dom \<pi>' \<subseteq> \<^bold>G \<phi>" and 2: "\<And>\<chi>. \<chi> \<in> dom \<pi>' \<Longrightarrow> the (\<pi>' \<chi>) < max_rank_of \<Sigma> \<chi>"
      using 1 2 unfolding  \<pi>'_def Mapping.keys.rep_eq Mapping.mapping.rep_inverse by (simp add: lookup.rep_eq)+
    moreover
    have "({a \<in> reach\<^sub>t \<Sigma> (delta\<^sub>C \<Sigma>) (initial\<^sub>C \<phi>). M_fin\<^sub>C \<phi> \<pi> a \<or> (\<exists>\<chi>\<in>Mapping.keys \<pi>. Acc_fin\<^sub>C \<Sigma> \<pi> \<chi> a)}, {y. \<exists>x\<in>Mapping.keys \<pi>. y = {a \<in> reach\<^sub>t \<Sigma> (delta\<^sub>C \<Sigma>) (initial\<^sub>C \<phi>). Acc_inf\<^sub>C \<pi> x a}})
      = ((Collect (M_fin\<^sub>C \<phi> \<pi>) \<union> {t. \<exists>\<chi>\<in>Mapping.keys \<pi>. Acc_fin\<^sub>C \<Sigma> \<pi> \<chi> t}) \<inter> reach\<^sub>t \<Sigma> (delta\<^sub>C \<Sigma>) (initial\<^sub>C \<phi>), {y. \<exists>x\<in>{Collect (Acc_inf\<^sub>C \<pi> \<chi>) |\<chi>. \<chi> \<in> Mapping.keys \<pi>}. y = x \<inter> reach\<^sub>t \<Sigma> (delta\<^sub>C \<Sigma>) (initial\<^sub>C \<phi>)})"
      by auto
    hence "accepting_pair\<^sub>G\<^sub>R (delta \<Sigma>) (initial \<phi>) (M_fin \<pi>' \<union> \<Union>{Acc_fin \<Sigma> \<pi>' \<chi> | \<chi>. \<chi> \<in> dom \<pi>'}, {Acc_inf \<pi>' \<chi> | \<chi>. \<chi> \<in> dom \<pi>'}) w"
      unfolding X[OF 1] using 4 unfolding Y Set.filter_def unfolding \<open>dom \<pi>' = Mapping.keys \<pi>\<close> \<open>Mapping.Mapping \<pi>' = \<pi>\<close> image_def by simp
    ultimately
    show ?lhs
      unfolding ltl_to_generalized_rabin.simps
      by (intro Rabin.accept\<^sub>G\<^sub>R_I, blast; auto)
  }
qed

end

subsection \<open>Generalized Deterministic Rabin Automaton (af)\<close>

definition M_fin\<^sub>C_af_lhs :: "'a ltl \<Rightarrow> ('a ltl, nat) mapping \<Rightarrow> ('a ltl, ('a ltl\<^sub>P list)) mapping \<Rightarrow> 'a ltl\<^sub>P"
where
  "M_fin\<^sub>C_af_lhs \<phi> \<pi> m' \<equiv>
    let
      \<G> = Mapping.keys \<pi>;
      \<G>\<^sub>L = filter (\<lambda>x. x \<in> \<G>) (G_list \<phi>);
      mk_conj = \<lambda>\<chi>. foldl and_abs (Abs \<chi>) (map (\<up>eval\<^sub>G \<G>) (drop (the (Mapping.lookup \<pi> \<chi>)) (the (Mapping.lookup m' \<chi>))))
    in
      \<up>And (map mk_conj \<G>\<^sub>L)"

fun M_fin\<^sub>C_af :: "'a ltl \<Rightarrow> ('a ltl, nat) mapping \<Rightarrow> ('a ltl\<^sub>P \<times> (('a ltl, ('a ltl\<^sub>P list)) mapping), 'a set) transition \<Rightarrow> bool"
where
  "M_fin\<^sub>C_af \<phi> \<pi> ((\<phi>', m'), _) = Not ((M_fin\<^sub>C_af_lhs \<phi> \<pi> m') \<up>\<longrightarrow>\<^sub>P  \<phi>')"

lemma M_fin\<^sub>C_af_correct:
  assumes "t \<in> reach\<^sub>t \<Sigma> (ltl_to_rabin_base_code_def.delta\<^sub>C \<up>af \<up>af\<^sub>G Abs \<Sigma>) (ltl_to_rabin_base_code_def.initial\<^sub>C Abs Abs \<phi>)"
  assumes "dom \<pi> \<subseteq> \<^bold>G \<phi>"
  shows "abstract_transition t \<in> M_fin \<pi> = M_fin\<^sub>C_af \<phi> (Mapping.Mapping \<pi>) t"
proof -
  let ?delta = "ltl_to_rabin_base_code_def.delta\<^sub>C \<up>af \<up>af\<^sub>G Abs \<Sigma>"
  let ?initial = "ltl_to_rabin_base_code_def.initial\<^sub>C Abs Abs \<phi>"

  obtain x y \<nu> z z' where t_def [simp]: "t = ((x, y), \<nu>, (z, z'))"
    by (metis prod.collapse)
  have "(x, y) \<in> reach \<Sigma> ?delta ?initial"
    using assms(1) by (simp add: reach\<^sub>t_def reach_def; blast)
  hence N1: "\<And>\<chi>. \<chi> \<in> dom \<pi> \<Longrightarrow> Mapping.lookup y \<chi> \<noteq> None"
    and D1: "\<And>\<chi>. \<chi> \<in> dom \<pi> \<Longrightarrow> distinct (the (Mapping.lookup y \<chi>))"
    using assms(2) by (blast dest: ltl_to_rabin_base_code_def.reach_delta_initial)+

  {
    fix S
    let ?m' = "\<lambda>\<chi>. map_option rk (Mapping.lookup y \<chi>)"

    {
      fix \<chi>
      assume "\<chi> \<in> dom \<pi>"
      hence "S \<up>\<Turnstile>\<^sub>P (foldl and_abs (Abs \<chi>) (map (\<up>eval\<^sub>G (dom \<pi>)) (drop (the (\<pi> \<chi>)) (the (Mapping.lookup y \<chi>)))))
         \<longleftrightarrow> S \<up>\<Turnstile>\<^sub>P (Abs \<chi>) \<and> (\<forall>q. (\<exists>j \<ge> the (\<pi> \<chi>). the (?m' \<chi>) q = Some j) \<longrightarrow> S \<up>\<Turnstile>\<^sub>P \<up>eval\<^sub>G (dom \<pi>) q)"
        using D1[THEN drop_rk, of _ "the (\<pi> \<chi>)"] N1[THEN option.map_sel, of _ rk]
        by (auto simp add: foldl_LTLAnd_prop_entailment_abs)
    }

    hence "S \<up>\<Turnstile>\<^sub>P (M_fin\<^sub>C_af_lhs \<phi> (Mapping.Mapping \<pi>) y)
      \<longleftrightarrow> (\<forall>\<chi> \<in> dom \<pi>. S \<up>\<Turnstile>\<^sub>P (Abs \<chi>) \<and> (\<forall>q. (\<exists>j \<ge> the (\<pi> \<chi>). the (?m' \<chi>) q = Some j) \<longrightarrow> S \<up>\<Turnstile>\<^sub>P \<up>eval\<^sub>G (dom \<pi>) q))"
      unfolding M_fin\<^sub>C_af_lhs_def Let_def And_prop_entailment_abs set_map Ball_def keys.abs_eq lookup.abs_eq
      using assms(2) by (simp add: image_def inter_set_filter[symmetric] G_eq_G_list[symmetric]; blast)
  }
  thus ?thesis
    by (simp add: ltl_prop_implies_def ltl_prop_implies_abs_def ltl_prop_entails_abs_def)
qed

definition
  "ltl_to_generalized_rabin\<^sub>C_af \<equiv> ltl_to_rabin_base_code_def.ltl_to_generalized_rabin\<^sub>C \<up>af \<up>af\<^sub>G Abs Abs M_fin\<^sub>C_af"

theorem ltl_to_generalized_rabin\<^sub>C_af_correct:
  assumes "range w \<subseteq> set \<Sigma>"
  shows "w \<Turnstile> \<phi> \<longleftrightarrow> accept\<^sub>G\<^sub>R_LTS (ltl_to_generalized_rabin\<^sub>C_af \<Sigma> \<phi>) w"
  (is "?lhs \<longleftrightarrow> ?rhs")
proof -
  have X: "ltl_to_rabin_base_code \<up>af \<up>af\<^sub>G Abs Abs M_fin (set \<Sigma>) w M_fin\<^sub>C_af"
    using ltl_to_generalized_rabin_af_wellformed[OF finite_set assms] M_fin\<^sub>C_af_correct assms
    unfolding ltl_to_rabin_af_def ltl_to_rabin_base_code_def ltl_to_rabin_base_code_axioms_def by blast
  have "?lhs \<longleftrightarrow> accept\<^sub>G\<^sub>R (ltl_to_generalized_rabin_af (set \<Sigma>) \<phi>) w"
    using assms ltl_to_generalized_rabin_af_correct by auto
  also
  have "\<dots> \<longleftrightarrow> ?rhs"
    using ltl_to_rabin_base_code.ltl_to_generalized_rabin\<^sub>C_correct[OF X]
    unfolding ltl_to_generalized_rabin\<^sub>C_af_def by simp
  finally
  show ?thesis .
qed

subsection \<open>Generalized Deterministic Rabin Automaton (eager af)\<close>

definition M_fin\<^sub>C_af\<^sub>\<UU>_lhs :: "'a ltl \<Rightarrow> ('a ltl, nat) mapping \<Rightarrow> ('a ltl, ('a ltl\<^sub>P list)) mapping \<Rightarrow> 'a set \<Rightarrow> 'a ltl\<^sub>P"
where
  "M_fin\<^sub>C_af\<^sub>\<UU>_lhs \<phi> \<pi> m' \<nu> \<equiv>
    let
      \<G> = Mapping.keys \<pi>;
      \<G>\<^sub>L = filter (\<lambda>x. x \<in> \<G>) (G_list \<phi>);
      mk_conj = \<lambda>\<chi>. foldl and_abs (and_abs (Abs \<chi>) (\<up>eval\<^sub>G \<G> (Abs (theG \<chi>)))) (map (\<up>eval\<^sub>G \<G> o (\<lambda>q. \<up>step q \<nu>)) (drop (the (Mapping.lookup \<pi> \<chi>)) (the (Mapping.lookup m' \<chi>))))
    in
      \<up>And (map mk_conj \<G>\<^sub>L)"

fun M_fin\<^sub>C_af\<^sub>\<UU> :: "'a ltl \<Rightarrow> ('a ltl, nat) mapping \<Rightarrow> ('a ltl\<^sub>P \<times> (('a ltl, ('a ltl\<^sub>P list)) mapping), 'a set) transition \<Rightarrow> bool"
where
  "M_fin\<^sub>C_af\<^sub>\<UU> \<phi> \<pi> ((\<phi>', m'), \<nu>, _) = Not ((M_fin\<^sub>C_af\<^sub>\<UU>_lhs \<phi> \<pi> m' \<nu>) \<up>\<longrightarrow>\<^sub>P (\<up>step \<phi>' \<nu>))"

lemma M_fin\<^sub>C_af\<^sub>\<UU>_correct:
  assumes "t \<in> reach\<^sub>t \<Sigma> (ltl_to_rabin_base_code_def.delta\<^sub>C \<up>af\<^sub>\<UU> \<up>af\<^sub>G\<^sub>\<UU> (Abs \<circ> Unf\<^sub>G) \<Sigma>) (ltl_to_rabin_base_code_def.initial\<^sub>C (Abs \<circ> Unf) (Abs \<circ> Unf\<^sub>G) \<phi>)"
  assumes "dom \<pi> \<subseteq> \<^bold>G \<phi>"
  shows "abstract_transition t \<in> M\<^sub>\<UU>_fin \<pi> = M_fin\<^sub>C_af\<^sub>\<UU> \<phi> (Mapping.Mapping \<pi>) t"
proof -
  let ?delta = "ltl_to_rabin_base_code_def.delta\<^sub>C \<up>af\<^sub>\<UU> \<up>af\<^sub>G\<^sub>\<UU> (Abs \<circ> Unf\<^sub>G) \<Sigma>"
  let ?initial = "ltl_to_rabin_base_code_def.initial\<^sub>C (Abs \<circ> Unf) (Abs \<circ> Unf\<^sub>G) \<phi>"

  obtain x y \<nu> z z' where t_def [simp]: "t = ((x, y), \<nu>, (z, z'))"
    by (metis prod.collapse)
  have "(x, y) \<in> reach \<Sigma> ?delta ?initial"
    using assms(1) by (simp add: reach\<^sub>t_def reach_def; blast)
  hence N1: "\<And>\<chi>. \<chi> \<in> dom \<pi> \<Longrightarrow> Mapping.lookup y \<chi> \<noteq> None"
    and D1: "\<And>\<chi>. \<chi> \<in> dom \<pi> \<Longrightarrow> distinct (the (Mapping.lookup y \<chi>))"
    using assms(2) by (blast dest: ltl_to_rabin_base_code_def.reach_delta_initial)+

  {
    fix S
    let ?m' = "\<lambda>\<chi>. map_option rk (Mapping.lookup y \<chi>)"

    {
      fix \<chi>
      assume "\<chi> \<in> dom \<pi>"
      hence "S \<up>\<Turnstile>\<^sub>P (foldl and_abs (and_abs (Abs \<chi>) (\<up>eval\<^sub>G (dom \<pi>) (Abs (theG \<chi>)))) (map (\<up>eval\<^sub>G (dom \<pi>) o (\<lambda>q. \<up>step q \<nu>)) (drop (the (\<pi> \<chi>)) (the (Mapping.lookup y \<chi>)))))
         \<longleftrightarrow> S \<up>\<Turnstile>\<^sub>P Abs \<chi> \<and> S \<up>\<Turnstile>\<^sub>P \<up>eval\<^sub>G (dom \<pi>) (Abs (theG \<chi>)) \<and> (\<forall>q. (\<exists>j \<ge> the (\<pi> \<chi>). the (?m' \<chi>) q = Some j) \<longrightarrow> S \<up>\<Turnstile>\<^sub>P \<up>eval\<^sub>G (dom \<pi>) (\<up>step q \<nu>))"
        using D1[THEN drop_rk, of _ "the (\<pi> \<chi>)"] N1[THEN option.map_sel, of _ rk]
        by (auto simp add: foldl_LTLAnd_prop_entailment_abs and_abs_conjunction simp del: rk.simps)
    }

    hence "S \<up>\<Turnstile>\<^sub>P (M_fin\<^sub>C_af\<^sub>\<UU>_lhs \<phi> (Mapping.Mapping \<pi>) y \<nu>)
      \<longleftrightarrow> ((\<forall>\<chi> \<in> dom \<pi>. (S \<up>\<Turnstile>\<^sub>P Abs \<chi> \<and> S \<up>\<Turnstile>\<^sub>P \<up>eval\<^sub>G (dom \<pi>) (Abs (theG \<chi>)) \<and> (\<forall>q. (\<exists>j \<ge> the (\<pi> \<chi>). the (?m' \<chi>) q = Some j) \<longrightarrow> S \<up>\<Turnstile>\<^sub>P \<up>eval\<^sub>G (dom \<pi>) (\<up>step q \<nu>)))))"
      unfolding M_fin\<^sub>C_af\<^sub>\<UU>_lhs_def Let_def And_prop_entailment_abs set_map Ball_def keys.abs_eq lookup.abs_eq
      using assms(2) by (simp add: image_def inter_set_filter[symmetric] G_eq_G_list[symmetric]; blast)
  }
  thus ?thesis
    by (simp add: ltl_prop_implies_def ltl_prop_implies_abs_def ltl_prop_entails_abs_def)
qed

definition
  "ltl_to_generalized_rabin\<^sub>C_af\<^sub>\<UU> \<equiv> ltl_to_rabin_base_code_def.ltl_to_generalized_rabin\<^sub>C \<up>af\<^sub>\<UU> \<up>af\<^sub>G\<^sub>\<UU> (Abs \<circ> Unf) (Abs \<circ> Unf\<^sub>G) M_fin\<^sub>C_af\<^sub>\<UU>"

theorem ltl_to_generalized_rabin\<^sub>C_af\<^sub>\<UU>_correct:
  assumes "range w \<subseteq> set \<Sigma>"
  shows "w \<Turnstile> \<phi> \<longleftrightarrow> accept\<^sub>G\<^sub>R_LTS (ltl_to_generalized_rabin\<^sub>C_af\<^sub>\<UU> \<Sigma> \<phi>) w"
  (is "?lhs \<longleftrightarrow> ?rhs")
proof -
  have X: "ltl_to_rabin_base_code \<up>af\<^sub>\<UU> \<up>af\<^sub>G\<^sub>\<UU> (Abs \<circ> Unf) (Abs \<circ> Unf\<^sub>G) M\<^sub>\<UU>_fin (set \<Sigma>) w M_fin\<^sub>C_af\<^sub>\<UU>"
    using ltl_to_generalized_rabin_af\<^sub>\<UU>_wellformed[OF finite_set assms] M_fin\<^sub>C_af\<^sub>\<UU>_correct assms
    unfolding ltl_to_rabin_af_unf_def ltl_to_rabin_base_code_def ltl_to_rabin_base_code_axioms_def by blast
  have "?lhs \<longleftrightarrow> accept\<^sub>G\<^sub>R (ltl_to_generalized_rabin_af\<^sub>\<UU> (set \<Sigma>) \<phi>) w"
    using assms ltl_to_generalized_rabin_af\<^sub>\<UU>_correct by auto
  also
  have "\<dots> \<longleftrightarrow> ?rhs"
    using ltl_to_rabin_base_code.ltl_to_generalized_rabin\<^sub>C_correct[OF X]
    unfolding ltl_to_generalized_rabin\<^sub>C_af\<^sub>\<UU>_def by simp
  finally
  show ?thesis .
qed

end


section \<open>Confluence related rewriting properties\<close>
theory Rewriting_Properties
  imports Rewriting
    "Abstract-Rewriting.Abstract_Rewriting"
begin

subsection \<open>Confluence related ARS properties\<close>
definition "SCR_on r A \<equiv> (\<forall>a \<in> A. \<forall> b c. (a, b) \<in> r \<and> (a, c) \<in> r \<longrightarrow>
  (\<exists> d. (b, d) \<in> r\<^sup>= \<and>  (c, d) \<in> r\<^sup>*))"

abbreviation SCR :: "'a rel \<Rightarrow> bool" where "SCR r \<equiv> SCR_on r UNIV"

definition NFP_on :: "'a rel \<Rightarrow> 'a set \<Rightarrow> bool" where
  "NFP_on r A \<longleftrightarrow> (\<forall>a\<in>A. \<forall>b c. (a, b) \<in> r\<^sup>* \<and> (a, c) \<in> r\<^sup>! \<longrightarrow> (b, c) \<in> r\<^sup>*)"

abbreviation NFP :: "'a rel \<Rightarrow> bool" where "NFP r \<equiv> NFP_on r UNIV"

definition CE_on :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a set \<Rightarrow> bool" where
  "CE_on r s A \<longleftrightarrow> (\<forall>a\<in>A. \<forall>b. (a, b) \<in> r\<^sup>\<leftrightarrow>\<^sup>* \<longleftrightarrow> (a, b) \<in> s\<^sup>\<leftrightarrow>\<^sup>*)"

abbreviation CE :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> bool" where "CE r s \<equiv> CE_on r s UNIV"

definition NE_on :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a set \<Rightarrow> bool" where
  "NE_on r s A \<longleftrightarrow> (\<forall>a\<in>A. \<forall>b. (a, b) \<in> r\<^sup>! \<longleftrightarrow> (a, b) \<in> s\<^sup>!)"

abbreviation NE :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> bool" where "NE r s \<equiv> NE_on r s UNIV"

subsection \<open>Signature closure of relation to model multihole context closure\<close>

(* AUX lemmas *)

lemma all_ctxt_closed_sig_rsteps [intro]:
  fixes \<R> :: "('f,'v) term rel"
  shows "all_ctxt_closed \<F> ((srstep \<F> \<R>)\<^sup>*)" (is "all_ctxt_closed _ (?R\<^sup>*)")
proof (rule trans_ctxt_sig_imp_all_ctxt_closed)
  fix C :: "('f,'v) ctxt" and s t :: "('f,'v)term"
  assume C: "funas_ctxt C \<subseteq> \<F>"
  and s: "funas_term s \<subseteq> \<F>"
  and t: "funas_term t \<subseteq> \<F>"
  and steps: "(s,t) \<in> ?R\<^sup>*"
  from steps
  show "(C \<langle> s \<rangle>, C \<langle> t \<rangle>) \<in> ?R\<^sup>*"
  proof (induct)
    case (step t u)
    from step(2) have tu: "(t,u) \<in> rstep \<R>" and t: "funas_term t \<subseteq> \<F>" and u: "funas_term u \<subseteq> \<F>"
      by (auto dest: srstepD)
    have "(C \<langle> t \<rangle>, C \<langle> u \<rangle>) \<in> ?R" by (rule sig_stepI[OF _ _ rstep_ctxtI[OF tu]], insert C t u, auto)
    with step(3) show ?case by auto
  qed auto
qed (auto intro: trans_rtrancl)

lemma sigstep_trancl_funas:
  "(s, t) \<in> (srstep \<F> \<S>)\<^sup>* \<Longrightarrow> s \<noteq> t \<Longrightarrow> funas_term s \<subseteq> \<F>"
  "(s, t) \<in> (srstep \<F> \<S>)\<^sup>* \<Longrightarrow> s \<noteq> t \<Longrightarrow> funas_term t \<subseteq> \<F>"
  by (auto simp: rtrancl_eq_or_trancl dest: srstepsD)

lemma srrstep_to_srestep:
  "(s, t) \<in> srrstep \<F> \<R> \<Longrightarrow> (s, t) \<in> srstep \<F> \<R>"
  by (meson in_mono rrstep_rstep_mono sig_step_mono2)

lemma srsteps_with_root_step_srstepsD:
  "(s, t) \<in> srsteps_with_root_step \<F> \<R> \<Longrightarrow> (s, t) \<in> (srstep \<F> \<R>)\<^sup>+"
  by (auto dest: srrstep_to_srestep simp: srsteps_with_root_step_def)

lemma srsteps_with_root_step_sresteps_eqD:
  "(s, t) \<in> srsteps_with_root_step \<F> \<R> \<Longrightarrow> (s, t) \<in> (srstep \<F> \<R>)\<^sup>*"
  by (auto dest: srrstep_to_srestep simp: srsteps_with_root_step_def)

lemma symcl_srstep_conversion:
  "(s, t) \<in> srstep \<F> (\<R>\<^sup>\<leftrightarrow>) \<Longrightarrow> (s, t) \<in> (srstep \<F> \<R>)\<^sup>\<leftrightarrow>\<^sup>*"
  by (simp add: conversion_def rstep_converse_dist srstep_symcl_dist)

lemma symcl_srsteps_conversion:
  "(s, t) \<in> (srstep \<F> (\<R>\<^sup>\<leftrightarrow>))\<^sup>* \<Longrightarrow> (s, t) \<in> (srstep \<F> \<R>)\<^sup>\<leftrightarrow>\<^sup>*"
  by (simp add: conversion_def rstep_converse_dist srstep_symcl_dist)

lemma NF_srstep_args:
  assumes "Fun f ss \<in> NF (srstep \<F> \<R>)" "funas_term (Fun f ss) \<subseteq> \<F>" "i < length ss"
  shows "ss ! i \<in> NF (srstep \<F> \<R>)"
proof (rule ccontr)
  assume "ss ! i \<notin> NF (srstep \<F> \<R>)"
  then obtain t where step: "(ss ! i, t) \<in> rstep \<R>" "funas_term t \<subseteq> \<F>"
    by (auto simp: NF_def sig_step_def)
  from assms(3) have [simp]: "Suc (length ss - Suc 0) = length ss" by auto
  from rstep_ctxtI[OF step(1), where ?C = "ctxt_at_pos (Fun f ss)[i]"]
  have "(Fun f ss, Fun f (ss[i := t])) \<in> srstep \<F> \<R>" using step(2) assms(2, 3)
    by (auto simp: sig_step_def upd_conv_take_nth_drop min_def UN_subset_iff
             dest: in_set_takeD in_set_dropD simp flip: id_take_nth_drop)
  then show False using assms(1)
    by (auto simp: NF_def)
qed

lemma all_ctxt_closed_srstep_conversions [simp]:
  "all_ctxt_closed \<F> ((srstep \<F> \<R>)\<^sup>\<leftrightarrow>\<^sup>*)"
  by (simp add: all_ctxt_closed_sig_rsteps sig_step_conversion_dist)

(* END AUX *)

lemma NFP_stepD:
  "NFP r \<Longrightarrow> (a, b) \<in> r\<^sup>* \<Longrightarrow> (a, c) \<in> r\<^sup>* \<Longrightarrow> c \<in> NF r \<Longrightarrow> (b, c) \<in> r\<^sup>*"
  by (auto simp: NFP_on_def)

lemma NE_symmetric: "NE r s \<Longrightarrow> NE s r"
  unfolding NE_on_def by auto

lemma CE_symmetric: "CE r s \<Longrightarrow> CE s r"
  unfolding CE_on_def by auto

text \<open>Reducing the quantification over rewrite sequences for properties @{const CR} ... to
rewrite sequences containing at least one root step\<close>
lemma all_ctxt_closed_sig_reflE:
  "all_ctxt_closed \<F> \<R> \<Longrightarrow> funas_term t \<subseteq> \<F> \<Longrightarrow> (t, t) \<in> \<R>"
proof (induct t)
  case (Fun f ts)
  from Fun(1)[OF nth_mem  Fun(2)] Fun(3)
  have "i < length ts \<Longrightarrow> funas_term (ts ! i) \<subseteq> \<F>" "i < length ts \<Longrightarrow> (ts ! i, ts ! i) \<in> \<R>" for i
    by (auto simp: SUP_le_iff)
  then show ?case using all_ctxt_closedD[OF Fun(2)] Fun(3)
    by simp
qed (simp add: all_ctxt_closed_def)

lemma all_ctxt_closed_relcomp [intro]:
  "(\<And> s t. (s, t) \<in> \<R> \<Longrightarrow> s \<noteq> t \<Longrightarrow> funas_term s \<subseteq> \<F> \<and> funas_term t \<subseteq> \<F>) \<Longrightarrow>
   (\<And> s t. (s, t) \<in> \<S> \<Longrightarrow> s \<noteq> t \<Longrightarrow> funas_term s \<subseteq> \<F> \<and> funas_term t \<subseteq> \<F>) \<Longrightarrow>
   all_ctxt_closed \<F> \<R> \<Longrightarrow> all_ctxt_closed \<F> \<S> \<Longrightarrow> all_ctxt_closed \<F> (\<R> O \<S>)"
proof -
  assume funas:"(\<And> s t. (s, t) \<in> \<R> \<Longrightarrow> s \<noteq> t \<Longrightarrow> funas_term s \<subseteq> \<F> \<and> funas_term t \<subseteq> \<F>)"
    "(\<And> s t. (s, t) \<in> \<S> \<Longrightarrow> s \<noteq> t \<Longrightarrow> funas_term s \<subseteq> \<F> \<and> funas_term t \<subseteq> \<F>)"
    and ctxt_cl: "all_ctxt_closed \<F> \<R>" "all_ctxt_closed \<F> \<S>"
  {fix f ss ts assume ass: "(f, length ss) \<in> \<F>" "length ss = length ts" "\<And> i. i < length ts \<Longrightarrow> (ss ! i, ts ! i) \<in> (\<R> O \<S>)"
    "\<And> i . i < length ts \<Longrightarrow> funas_term (ts ! i) \<subseteq> \<F>" "\<And>i. i < length ts \<Longrightarrow> funas_term (ss ! i) \<subseteq> \<F>"
    from ass(2, 3) obtain us where us: "length us = length ts" "\<And> i. i < length ts \<Longrightarrow> (ss ! i, us ! i) \<in> \<R>"
      "\<And> i. i < length ts \<Longrightarrow> (us ! i, ts ! i) \<in> \<S>"
      using Ex_list_of_length_P[of "length ts" "\<lambda> x i. (ss ! i, x) \<in> \<R> \<and> (x, ts ! i) \<in> \<S>"]
      by auto
    from funas have fu: "\<And> i . i < length us \<Longrightarrow> funas_term (us ! i) \<subseteq> \<F>" using us ass(4, 5)
      by (auto simp: funas_rel_def) (metis in_mono)
    have "(Fun f ss, Fun f us) \<in> \<R>" using ass(1, 2, 5) us(1, 2) fu
      by (intro all_ctxt_closedD[OF ctxt_cl(1), of f]) auto
    moreover have "(Fun f us, Fun f ts) \<in> \<S>"  using ass(1, 2, 4) us(1, 3) fu
      by (intro all_ctxt_closedD[OF ctxt_cl(2), of f]) auto
    ultimately have "(Fun f ss, Fun f ts) \<in> \<R> O \<S>" by auto}
  moreover
  {fix x have "(Var x, Var x) \<in> \<R>" "(Var x, Var x) \<in> \<S>" using ctxt_cl
      by (auto simp: all_ctxt_closed_def)
    then have "(Var x, Var x) \<in> \<R> O \<S>" by auto}
  ultimately show ?thesis by (auto simp: all_ctxt_closed_def)
qed

abbreviation "prop_to_rel P \<equiv> {(s, t)| s t. P s t}"

abbreviation "prop_mctxt_cl \<F> P \<equiv> all_ctxt_closed \<F> (prop_to_rel P)"

lemma prop_mctxt_cl_Var:
  "prop_mctxt_cl \<F> P \<Longrightarrow> P (Var x) (Var x)"
  by (simp add: all_ctxt_closed_def)

lemma prop_mctxt_cl_refl_on:
  "prop_mctxt_cl \<F> P \<Longrightarrow> funas_term t \<subseteq> \<F> \<Longrightarrow> P t t"
  using all_ctxt_closed_sig_reflE by blast

lemma prop_mctxt_cl_reflcl_on:
  "prop_mctxt_cl \<F> P \<Longrightarrow> funas_term s \<subseteq> \<F> \<Longrightarrow> P s s"
  using all_ctxt_closed_sig_reflE by blast

lemma reduction_relations_to_root_step:
  assumes "\<And> s t. (s, t) \<in> srsteps_with_root_step \<F> \<R> \<Longrightarrow> P s t"
    and cl: "prop_mctxt_cl \<F> P"
    and well: "funas_term s \<subseteq> \<F>" "funas_term t \<subseteq> \<F>"
    and steps: "(s, t) \<in> (srstep \<F> \<R>)\<^sup>*"
  shows "P s t" using steps well
proof (induct s arbitrary: t)
  case (Var x)
  have "(Var x, t) \<in> (srstep \<F> \<R>)\<^sup>+ \<Longrightarrow> (Var x, t) \<in> srsteps_with_root_step \<F> \<R>"
    using nsrsteps_with_root_step_step_on_args by blast
  from assms(1)[OF this] show ?case using Var cl
    by (auto simp: rtrancl_eq_or_trancl dest: all_ctxt_closed_sig_reflE)
next
  case (Fun f ss) note IH = this show ?case
  proof (cases "Fun f ss = t")
    case True show ?thesis using IH(2, 4) unfolding True
      by (intro prop_mctxt_cl_reflcl_on[OF cl]) auto
  next
    case False
    then have step: "(Fun f ss, t) \<in> (srstep \<F> \<R>)\<^sup>+" using IH(2)
      by (auto simp: refl rtrancl_eq_or_trancl)
    show ?thesis
    proof (cases "(Fun f ss, t) \<in> srsteps_with_root_step \<F> \<R>")
      case False
      from nsrsteps_with_root_step_step_on_args[OF step this] obtain ts
        where *[simp]: "t = Fun f ts" and inv: "length ss = length ts"
          "\<forall> i < length ts. (ss ! i, ts ! i) \<in> (srstep \<F> \<R>)\<^sup>*"
        by auto
      have funas: "(f, length ts) \<in> \<F>" "\<forall>i<length ts. funas_term (ss ! i) \<subseteq> \<F> \<and> funas_term (ts ! i) \<subseteq> \<F>"
        using IH(3, 4) step inv(1) by (auto simp: UN_subset_iff)
      then have t: "\<forall> i < length ts. P (ss ! i) (ts ! i)"
        using prop_mctxt_cl_reflcl_on[OF cl]  IH(1) inv
        by (auto simp: rtrancl_eq_or_trancl)
      then show ?thesis unfolding * using funas inv(1) all_ctxt_closedD[OF cl]
        by auto
    qed (auto simp add: assms(1))
  qed
qed

abbreviation "comp_rrstep_rel \<F> \<R> \<S> \<equiv> srsteps_with_root_step \<F> \<R> O (srstep \<F> \<S>)\<^sup>* \<union>
  (srstep \<F> \<R>)\<^sup>* O srsteps_with_root_step \<F> \<S>"

abbreviation "comp_rrstep_rel' \<F> \<R> \<S> \<equiv> srsteps_with_root_step \<F> \<R> O (srstep \<F> \<S>)\<^sup>+ \<union>
  (srstep \<F> \<R>)\<^sup>+ O srsteps_with_root_step \<F> \<S>"

lemma reduction_join_relations_to_root_step:
  assumes "\<And> s t. (s, t) \<in> comp_rrstep_rel \<F> \<R> \<S> \<Longrightarrow> P s t"
    and cl: "prop_mctxt_cl \<F> P"
    and well: "funas_term s \<subseteq> \<F>" "funas_term t \<subseteq> \<F>"
    and steps: "(s, t) \<in> (srstep \<F> \<R>)\<^sup>* O (srstep \<F> \<S>)\<^sup>*"
  shows "P s t" using steps well
proof (induct s arbitrary: t)
  case (Var x)
  have f: "(Var x, t) \<in> (srstep \<F> \<R>)\<^sup>+ \<Longrightarrow> (Var x, t) \<in> comp_rrstep_rel \<F> \<R> \<S>"
    using nsrsteps_with_root_step_step_on_args[of "Var x" _ \<F> \<R>] unfolding srsteps_with_root_step_def
    by (metis (no_types, lifting) Term.term.simps(4) UnI1 relcomp.relcompI rtrancl_eq_or_trancl)
  have s: "(Var x, t) \<in> (srstep \<F> \<S>)\<^sup>+ \<Longrightarrow> (Var x, t) \<in> comp_rrstep_rel \<F> \<R> \<S>"
    using nsrsteps_with_root_step_step_on_args[of "Var x" _ \<F> \<S>] unfolding srsteps_with_root_step_def
    by (metis (no_types, lifting) Term.term.simps(4) UnI2 relcomp.simps rtrancl.simps)
  have t: "(Var x, u) \<in> (srstep \<F> \<R>)\<^sup>+ \<Longrightarrow> (u, t) \<in> (srstep \<F> \<S>)\<^sup>+ \<Longrightarrow> (Var x, t) \<in> comp_rrstep_rel \<F> \<R> \<S>" for u
    using nsrsteps_with_root_step_step_on_args[of "Var x" u \<F> \<R>] unfolding srsteps_with_root_step_def
    by auto (meson relcomp.simps trancl_into_rtrancl)
  show ?case using Var f[THEN assms(1)] s[THEN assms(1)] t[THEN assms(1)] cl
    by (auto simp: rtrancl_eq_or_trancl prop_mctxt_cl_Var)
next
  case (Fun f ss) note IH = this show ?case
  proof (cases "Fun f ss = t")
    case True show ?thesis using IH(2, 3, 4) cl
      by (auto simp: True prop_mctxt_cl_refl_on)
  next
    case False
    obtain u where u: "(Fun f ss, u) \<in> (srstep \<F> \<R>)\<^sup>*" "(u, t) \<in> (srstep \<F> \<S>)\<^sup>*" using IH(2) by auto
    show ?thesis
    proof (cases "(Fun f ss, u) \<in> srsteps_with_root_step \<F> \<R>")
      case True
      then have "(Fun f ss, t) \<in> comp_rrstep_rel \<F> \<R> \<S>" using u
        by (auto simp: srsteps_with_root_step_def)
      from assms(1)[OF this] show ?thesis by simp
    next
      case False note nt_fst = this show ?thesis
      proof (cases "(u, t) \<in> srsteps_with_root_step \<F> \<S>")
        case True
        then have "(Fun f ss, t) \<in> comp_rrstep_rel \<F> \<R> \<S>" using u unfolding srsteps_with_root_step_def
          by blast
        from assms(1)[OF this] show ?thesis by simp
      next
        case False note no_root = False nt_fst
        show ?thesis
        proof (cases "Fun f ss = u \<or> u = t")
          case True
          from assms(1) have f: "\<And> s t. (s, t) \<in> srsteps_with_root_step \<F> \<R> \<Longrightarrow> P s t"
            and s: "\<And> s t. (s, t) \<in> srsteps_with_root_step \<F> \<S> \<Longrightarrow> P s t" unfolding srsteps_with_root_step_def
            by blast+
          have "u = t \<Longrightarrow> ?thesis" using u cl IH(3, 4)
            by (intro reduction_relations_to_root_step[OF f]) auto
          moreover have "Fun f ss = u \<Longrightarrow> ?thesis" using u cl IH(3, 4)
            by (intro reduction_relations_to_root_step[OF s]) auto
          ultimately show ?thesis using True by auto
        next
          case False
          then have steps: "(Fun f ss, u) \<in> (srstep \<F> \<R>)\<^sup>+" "(u, t) \<in> (srstep \<F> \<S>)\<^sup>+" using u
            by (auto simp: rtrancl_eq_or_trancl)
          obtain ts us
            where [simp]: "u = Fun f us" and inv_u: "length ss = length us" "\<forall> i < length ts. (ss ! i, us ! i) \<in> (srstep \<F> \<R>)\<^sup>*"
              and [simp]: "t = Fun f ts" and inv_t: "length us = length ts" "\<forall> i < length ts. (us ! i, ts ! i) \<in> (srstep \<F> \<S>)\<^sup>*"
            using nsrsteps_with_root_step_step_on_args[OF steps(1) no_root(2)]
            using nsrsteps_with_root_step_step_on_args[OF steps(2) no_root(1)]
            by auto
          from inv_u inv_t cl IH(3, 4) have t: "\<forall> i < length ts. P (ss ! i) (ts ! i)"
            by (auto simp: UN_subset_iff intro!: IH(1)[OF nth_mem, of i "ts ! i" for i])
          moreover have "(f, length ts) \<in> \<F>" using IH(4) by auto
          ultimately show ?thesis using IH(3, 4) inv_u inv_t all_ctxt_closedD[OF cl]
            by (auto simp: UN_subset_iff)
        qed
      qed
    qed
  qed
qed

\<comment> \<open>Reducing search space for @{const commute} to conversions involving root steps\<close>

definition "commute_redp \<F> \<R> \<S> s t \<longleftrightarrow> (s, t) \<in> ((srstep \<F> \<S>)\<^sup>* O ((srstep \<F> \<R>)\<inverse>)\<^sup>*)"

declare subsetI[rule del]
lemma commute_redp_mctxt_cl:
  "prop_mctxt_cl \<F> (commute_redp \<F> \<R> \<S>)"
  by (auto simp: commute_redp_def rew_converse_inwards
    dest: sigstep_trancl_funas intro!: all_ctxt_closed_relcomp)
declare subsetI[intro!]

lemma commute_rrstep_intro:
  assumes "\<And> s t. (s, t) \<in> comp_rrstep_rel' \<F> (\<R>\<inverse>) \<S> \<Longrightarrow> commute_redp \<F> \<R> \<S> s t"
  shows "commute (srstep \<F> \<R>) (srstep \<F> \<S>)"
proof -
  have [simp]: "x \<in> srsteps_with_root_step \<F> \<U> \<Longrightarrow> x \<in> (srstep \<F> \<U>)\<^sup>* O \<L>\<^sup>*" for x \<U> \<L>
    by (cases x) (auto dest!: srsteps_with_root_step_sresteps_eqD)
  have [simp]: "x \<in> srsteps_with_root_step \<F> \<U> \<Longrightarrow> x \<in> \<L>\<^sup>* O (srstep \<F> \<U>)\<^sup>*" for x \<U> \<L>
    by (cases x) (auto dest!: srsteps_with_root_step_sresteps_eqD)
  have red: "\<And> s t. (s, t) \<in> comp_rrstep_rel \<F> (\<R>\<inverse>) \<S> \<Longrightarrow> commute_redp \<F> \<R> \<S> s t" using assms
    unfolding commute_redp_def srstep_converse_dist
    by (auto simp: rtrancl_eq_or_trancl) blast+
  have comI: "(\<And> s t. (s, t) \<in> ((srstep \<F> (\<R>\<inverse>))\<^sup>*) O (srstep \<F> \<S>)\<^sup>* \<Longrightarrow> commute_redp \<F> \<R> \<S> s t) \<Longrightarrow>
    commute (srstep \<F> \<R>) (srstep \<F> \<S>)"
    by (auto simp: commute_redp_def commute_def subsetD rew_converse_inwards)
  show ?thesis
    using reduction_join_relations_to_root_step[OF red commute_redp_mctxt_cl, of "\<R>\<inverse>" \<S>]
    by (intro comI, auto) (metis (no_types, lifting) commute_redp_def relcompI rew_converse_inwards sigstep_trancl_funas srstep_converse_dist)
qed

lemma commute_to_rrstep:
  assumes "commute (srstep \<F> \<R>) (srstep \<F> \<S>)"
  shows "\<And> s t. (s, t) \<in> comp_rrstep_rel \<F> (\<R>\<inverse>) \<S> \<Longrightarrow> commute_redp \<F> \<R> \<S> s t" using assms
  unfolding commute_def commute_redp_def srstep_converse_dist
  by (auto simp: srstep_converse_dist dest: srsteps_with_root_step_sresteps_eqD)

\<comment> \<open>Reducing search space for @{const CR} to conversions involving root steps\<close>

lemma CR_Aux:
  assumes "\<And> s t. (s, t) \<in> (srstep \<F> (\<R>\<inverse>))\<^sup>* O srsteps_with_root_step \<F> \<R> \<Longrightarrow> commute_redp \<F> \<R> \<R> s t"
  shows "\<And> s t. (s, t) \<in> comp_rrstep_rel \<F> (\<R>\<inverse>) \<R> \<Longrightarrow> commute_redp \<F> \<R> \<R> s t"
proof -
  have sym: "commute_redp \<F> \<R> \<R> s t \<Longrightarrow> commute_redp \<F> \<R> \<R> t s" for s t
    by (auto simp: commute_redp_def) (metis converseI relcomp.relcompI rtrancl_converse rtrancl_converseD)
  {fix s t assume "(s, t) \<in> (srstep \<F> \<R>)\<^sup>* O srsteps_with_root_step \<F> (\<R>\<inverse>)"
    then have "commute_redp \<F> \<R> \<R> s t"  unfolding commute_redp_def
      by (auto simp: srsteps_with_root_step_def rew_converse_inwards dest!: srrstep_to_srestep)}
  note * = this
  {fix s t assume ass: "(s, t) \<in> srsteps_with_root_step \<F> (\<R>\<inverse>) O (srstep \<F> \<R>)\<^sup>*"
    have [dest!]: "(u, t) \<in> (srstep \<F> \<R>)\<^sup>* \<Longrightarrow> (t, u) \<in> (sig_step \<F> ((rstep \<R>)\<inverse>))\<^sup>*" for u
      by (metis rew_converse_outwards rtrancl_converseI srstep_converse_dist)
    from ass have "(t, s) \<in> (srstep \<F> (\<R>\<inverse>))\<^sup>* O srsteps_with_root_step \<F> \<R>"
      unfolding srsteps_with_root_step_def rstep_converse_dist
      by (metis (mono_tags, lifting) O_assoc converse.simps converse_converse converse_inward(1) converse_relcomp rew_converse_outwards(1, 2) sig_step_converse_rstep)
  from assms[OF this] have "commute_redp \<F> \<R> \<R> s t" using sym by blast}
  then show "\<And> s t. (s, t) \<in> comp_rrstep_rel \<F> (\<R>\<inverse>) \<R> \<Longrightarrow> commute_redp \<F> \<R> \<R> s t" unfolding srsteps_with_root_step_def
    by (metis UnE assms srsteps_with_root_step_def)
qed

lemma CR_rrstep_intro:
  assumes "\<And> s t. (s, t) \<in> (srstep \<F> (\<R>\<inverse>))\<^sup>+ O srsteps_with_root_step \<F> \<R> \<Longrightarrow> commute_redp \<F> \<R> \<R> s t"
  shows "CR (srstep \<F> \<R>)"
proof -
  {fix s u assume "(s, u) \<in> (srstep \<F> (\<R>\<inverse>))\<^sup>* O srsteps_with_root_step \<F> \<R>"
    then obtain t where a: "(s, t) \<in> (srstep \<F> (\<R>\<inverse>))\<^sup>*" "(t, u) \<in> srsteps_with_root_step \<F> \<R>" by blast
    have "commute_redp \<F> \<R> \<R> s u"
    proof (cases "s = t")
      case [simp]: True
      from srsteps_with_root_step_srstepsD[OF a(2)] show ?thesis
        by (auto simp: commute_redp_def)
    next
      case False
      then have "(s, t) \<in> (srstep \<F> (\<R>\<inverse>))\<^sup>+" using a(1) unfolding rtrancl_eq_or_trancl
        by simp
      then show ?thesis using assms a(2) by blast
    qed}
  from commute_rrstep_intro[OF CR_Aux[OF this]]
  show ?thesis unfolding CR_iff_self_commute
    by (metis Un_iff reflcl_trancl relcomp_distrib relcomp_distrib2)
qed

lemma CR_to_rrstep:
  assumes "CR (srstep \<F> \<R>)"
  shows "\<And> s t. (s, t) \<in> comp_rrstep_rel \<F> (\<R>\<inverse>) \<R> \<Longrightarrow> commute_redp \<F> \<R> \<R> s t" using assms
  using commute_to_rrstep[OF assms[unfolded CR_iff_self_commute]]
  by simp

\<comment> \<open>Reducing search space for @{const NFP} to conversions involving root steps\<close>

definition NFP_redp where
  "NFP_redp \<F> \<R> s t \<longleftrightarrow> t \<in> NF (srstep \<F> \<R>) \<longrightarrow> (s, t) \<in> (srstep \<F> \<R>)\<^sup>*"

lemma prop_mctxt_cl_NFP_redp:
  "prop_mctxt_cl \<F> (NFP_redp \<F> \<R>)"
proof -
  {fix f ts ss assume sig: "(f, length ss) \<in> \<F>" "length ts = length ss"
      and steps: "\<forall> i < length ss. ss ! i \<in> NF (srstep \<F> \<R>) \<longrightarrow> (ts ! i, ss ! i) \<in> (srstep \<F> \<R>)\<^sup>*"
      and funas: "\<forall> i < length ss. funas_term (ts ! i) \<subseteq> \<F> \<and> funas_term (ss ! i) \<subseteq> \<F>"
      and NF: "Fun f ss \<in> NF (srstep \<F> \<R>)"
    from steps have steps:  "i < length ss \<Longrightarrow> (ts ! i, ss ! i) \<in> (srstep \<F> \<R>)\<^sup>*" for i
      using sig funas NF_srstep_args[OF NF]
      by (auto simp: UN_subset_iff) (metis in_set_idx)
    then have "(Fun f ts, Fun f ss) \<in> (srstep \<F> \<R>)\<^sup>*" using sig
      by (metis all_ctxt_closed_def all_ctxt_closed_sig_rsteps funas le_sup_iff)}
  then show ?thesis
    by (auto simp: NFP_redp_def all_ctxt_closed_def)
qed

lemma NFP_rrstep_intro:
  assumes "\<And> s t. (s, t) \<in> comp_rrstep_rel' \<F> (\<R>\<inverse>) \<R>\<Longrightarrow> NFP_redp \<F> \<R> s t"
  shows "NFP (srstep \<F> \<R>)"
proof -
  from assms have red: "\<And> t u. (t, u) \<in> comp_rrstep_rel \<F> (\<R>\<inverse>) \<R> \<Longrightarrow> NFP_redp \<F> \<R> t u"
    apply (auto simp: NFP_redp_def rtrancl_eq_or_trancl)
    apply (metis NF_no_trancl_step converseD srstep_converse_dist srsteps_with_root_step_srstepsD trancl_converse)
    apply blast
    apply (meson NF_no_trancl_step srsteps_with_root_step_srstepsD)
    by blast
  have "\<And> s t. (s, t) \<in> (sig_step \<F> ((rstep \<R>)\<inverse>))\<^sup>* O (srstep \<F> \<R>)\<^sup>* \<Longrightarrow> NFP_redp \<F> \<R> s t"
    using reduction_join_relations_to_root_step[OF red prop_mctxt_cl_NFP_redp, of "\<R>\<inverse>" \<R>]
    by (auto simp: NFP_redp_def) (metis (no_types, lifting) relcomp.relcompI rstep_converse_dist rtranclD srstepsD)
  then show ?thesis unfolding NFP_on_def NFP_redp_def
    by (auto simp: normalizability_def) (metis meetI meet_def rstep_converse_dist srstep_converse_dist)
qed

lemma NFP_lift_to_conversion:
  assumes "NFP r" "(s, t) \<in> (r\<^sup>\<leftrightarrow>)\<^sup>*" and "t \<in> NF r"
  shows "(s, t) \<in> r\<^sup>*" using assms(2, 3)
proof (induct rule: converse_rtrancl_induct)
  case (step s u)
  then have "(u, t) \<in> r\<^sup>!" by auto
  then show ?case using assms(1) step(1) unfolding NFP_on_def
    by auto
qed simp

lemma NFP_to_rrstep:
  assumes "NFP (srstep \<F> \<R>)"
  shows "\<And> s t. (s, t) \<in> srsteps_with_root_step \<F> (\<R>\<^sup>\<leftrightarrow>) \<Longrightarrow> NFP_redp \<F> \<R> s t" using assms
  using NFP_lift_to_conversion[OF assms] unfolding NFP_redp_def srsteps_with_root_step_def
  by auto (metis (no_types, lifting) r_into_rtrancl rstep_converse_dist rtrancl_trans srrstep_to_srestep srstep_symcl_dist)

\<comment> \<open>Reducing search space for @{const UNC} to conversions involving root steps\<close>

definition "UN_redp \<F> \<R> s t \<longleftrightarrow> s \<in> NF (srstep \<F> \<R>) \<and> t \<in> NF (srstep \<F> \<R>) \<longrightarrow> s = t"

lemma prop_mctxt_cl_UN_redp:
  "prop_mctxt_cl \<F> (UN_redp \<F> \<R>)"
proof -
  {fix f ts ss assume sig: "(f, length ss) \<in> \<F>" "length ts = length ss"
      and steps: "\<forall> i < length ss. ts ! i \<in> NF (srstep \<F> \<R>) \<and> ss ! i \<in> NF (srstep \<F> \<R>) \<longrightarrow> ts ! i = ss ! i"
      and funas: "\<forall> i < length ss. funas_term (ts ! i) \<subseteq> \<F> \<and> funas_term (ss ! i) \<subseteq> \<F>"
      and NF: "Fun f ts \<in> NF (srstep \<F> \<R>)" "Fun f ss \<in> NF (srstep \<F> \<R>)"
    from steps have steps: "i < length ss \<Longrightarrow> ts ! i = ss ! i" for i
      using sig funas NF_srstep_args[OF NF(1)] NF_srstep_args[OF NF(2)]
      by (auto simp: UN_subset_iff) (metis in_set_idx)
    then have "Fun f ts = Fun f ss" using sig(2)
      by (simp add: nth_equalityI)}
  then show ?thesis
    by (auto simp: UN_redp_def all_ctxt_closed_def)
qed

lemma UNC_rrstep_intro:
  assumes"\<And> s t. (s, t) \<in> srsteps_with_root_step \<F> (\<R>\<^sup>\<leftrightarrow>) \<Longrightarrow> UN_redp \<F> \<R> s t"
  shows "UNC (srstep \<F> \<R>)"
proof -
  have "\<And> s t. (s, t) \<in> (srstep \<F> (\<R>\<^sup>\<leftrightarrow>))\<^sup>* \<Longrightarrow> UN_redp \<F> \<R> s t"
    using reduction_relations_to_root_step[OF assms(1) prop_mctxt_cl_UN_redp, of "\<R>\<^sup>\<leftrightarrow>"]
    by (auto simp: UN_redp_def) (meson rtranclD srstepsD)
  then show ?thesis unfolding UNC_def UN_redp_def
    by (auto simp: sig_step_conversion_dist)
qed

lemma UNC_to_rrstep:
  assumes "UNC (srstep \<F> \<R>)"
  shows "\<And> s t. (s, t) \<in> srsteps_with_root_step \<F> (\<R>\<^sup>\<leftrightarrow>) \<Longrightarrow> UN_redp \<F> \<R> s t"
  using assms unfolding UNC_def UN_redp_def srsteps_with_root_step_def
  by (auto dest!: srrstep_to_srestep symcl_srstep_conversion symcl_srsteps_conversion)
     (metis (no_types, opaque_lifting) conversion_def rtrancl_trans)

\<comment> \<open>Reducing search space for @{const UNF} to conversions involving root steps\<close>

lemma UNF_rrstep_intro:
  assumes "\<And> t u. (t, u) \<in> comp_rrstep_rel' \<F> (\<R>\<inverse>) \<R> \<Longrightarrow> UN_redp \<F> \<R> t u"
  shows "UNF (srstep \<F> \<R>)"
proof -
  from assms have red: "\<And> t u. (t, u) \<in> comp_rrstep_rel \<F> (\<R>\<inverse>) \<R> \<Longrightarrow> UN_redp \<F> \<R> t u"
    apply (auto simp: UN_redp_def rtrancl_eq_or_trancl)
    apply (metis NF_no_trancl_step converseD srstep_converse_dist srsteps_with_root_step_srstepsD trancl_converse)
    apply blast
    apply (meson NF_no_trancl_step srsteps_with_root_step_srstepsD)
    by blast
  have "\<And> s t. (s, t) \<in> (sig_step \<F> ((rstep \<R>)\<inverse>))\<^sup>* O (srstep \<F> \<R>)\<^sup>* \<Longrightarrow> UN_redp \<F> \<R> s t"
    using reduction_join_relations_to_root_step[OF red prop_mctxt_cl_UN_redp, of "\<R>\<inverse>" \<R>]
    by (auto simp: UN_redp_def) (metis (no_types, lifting) relcomp.relcompI rstep_converse_dist rtranclD srstepsD)
  then show ?thesis unfolding UNF_on_def UN_redp_def
    by (auto simp: normalizability_def) (metis meetI meet_def rstep_converse_dist srstep_converse_dist)
qed

lemma UNF_to_rrstep:
  assumes "UNF (srstep \<F> \<R>)"
  shows "\<And> s t. (s, t) \<in> comp_rrstep_rel \<F> (\<R>\<inverse>) \<R> \<Longrightarrow> UN_redp \<F> \<R> s t"
  using assms unfolding UNF_on_def UN_redp_def normalizability_def srsteps_with_root_step_def
  by (auto simp flip: srstep_converse_dist dest!: srrstep_to_srestep)
   (metis (no_types, lifting) rstep_converse_dist rtrancl.rtrancl_into_rtrancl rtrancl_converseD rtrancl_idemp srstep_converse_dist)+

\<comment> \<open>Reducing search space for @{const CE} to conversions involving root steps\<close>

lemma CE_rrstep_intro:
  assumes "\<And> s t. (s, t) \<in> srsteps_with_root_step \<F> (\<R>\<^sup>\<leftrightarrow>) \<Longrightarrow> (s, t) \<in> (srstep \<F> \<S>)\<^sup>\<leftrightarrow>\<^sup>*"
    and "\<And> s t. (s, t) \<in> srsteps_with_root_step \<F> (\<S>\<^sup>\<leftrightarrow>) \<Longrightarrow> (s, t) \<in> (srstep \<F> \<R>)\<^sup>\<leftrightarrow>\<^sup>*"
  shows "CE (srstep \<F> \<R>) (srstep \<F> \<S>)"
  using reduction_relations_to_root_step[OF assms(1), where ?s1 = "\<lambda> s t. s" and ?t1 = "\<lambda> s t. t", of \<F> "\<R>\<^sup>\<leftrightarrow>"]
  using reduction_relations_to_root_step[OF assms(2), where ?s1 = "\<lambda> s t. s" and ?t1 = "\<lambda> s t. t", of \<F> "\<S>\<^sup>\<leftrightarrow>"]
  by (auto simp: CE_on_def)
     (metis converseI conversion_converse rtrancl_eq_or_trancl sig_step_conversion_dist sigstep_trancl_funas(1, 2))+

lemma CE_to_rrstep:
  assumes "CE (srstep \<F> \<R>) (srstep \<F> \<S>)"
  shows "\<And> s t. (s, t) \<in> srsteps_with_root_step \<F> (\<R>\<^sup>\<leftrightarrow>) \<Longrightarrow> (s, t) \<in> (srstep \<F> \<S>)\<^sup>\<leftrightarrow>\<^sup>*"
        "\<And> s t. (s, t) \<in> srsteps_with_root_step \<F> (\<S>\<^sup>\<leftrightarrow>) \<Longrightarrow> (s, t) \<in> (srstep \<F> \<R>)\<^sup>\<leftrightarrow>\<^sup>*"
  using assms unfolding CE_on_def srsteps_with_root_step_def
  by (auto simp flip: srstep_converse_dist dest!: srrstep_to_srestep symcl_srsteps_conversion symcl_srstep_conversion)
     (metis converse_rtrancl_into_rtrancl conversion_rtrancl)+

\<comment> \<open>Reducing search space for @{const NE} to conversions involving root steps\<close>

definition NE_redp where
  "NE_redp \<F> \<R> \<S> s t \<longleftrightarrow> t \<in> NF (srstep \<F> \<R>) \<longrightarrow> t \<in> NF (srstep \<F> \<R>) \<longrightarrow> (s, t) \<in> (srstep \<F> \<S>)\<^sup>*"

lemma prop_mctxt_cl_NE_redp:
  "prop_mctxt_cl \<F> (NE_redp \<F> \<R> \<S>)"
proof -
  {fix f ts ss assume sig: "(f, length ss) \<in> \<F>" "length ts = length ss"
      and steps: "\<forall> i < length ss. ss ! i \<in> NF (srstep \<F> \<R>) \<longrightarrow> (ts ! i, ss ! i) \<in> (srstep \<F> \<S>)\<^sup>*"
      and funas: "\<forall> i < length ss. funas_term (ts ! i) \<subseteq> \<F> \<and> funas_term (ss ! i) \<subseteq> \<F>"
      and NF: "Fun f ss \<in> NF (srstep \<F> \<R>)"
    from steps have steps:  "i < length ss \<Longrightarrow> (ts ! i, ss ! i) \<in> (srstep \<F> \<S>)\<^sup>*" for i
      using sig funas NF_srstep_args[OF NF]
      by (auto simp: UN_subset_iff) (metis in_set_idx)
    then have "(Fun f ts, Fun f ss) \<in> (srstep \<F> \<S>)\<^sup>*" using sig
      by (metis all_ctxt_closed_def all_ctxt_closed_sig_rsteps funas le_sup_iff)}
  then show ?thesis
    by (auto simp: all_ctxt_closed_def NE_redp_def)
qed

lemma NE_rrstep_intro:
  assumes "\<And> s t. (s, t) \<in> srsteps_with_root_step \<F> \<R> \<Longrightarrow> NE_redp \<F> \<R> \<S> s t"
    and "\<And> s t. (s, t) \<in> srsteps_with_root_step \<F> \<S> \<Longrightarrow> NE_redp \<F> \<S> \<R> s t"
    and "NF (srstep \<F> \<R>) = NF (srstep \<F> \<S>)"
  shows "NE (srstep \<F> \<R>) (srstep \<F> \<S>)"
  using assms(3)
  using reduction_relations_to_root_step[OF assms(1) prop_mctxt_cl_NE_redp, of \<R>]
  using reduction_relations_to_root_step[OF assms(2) prop_mctxt_cl_NE_redp, of \<S>]
  by (auto simp: NE_on_def NE_redp_def normalizability_def)
     (metis rtrancl.rtrancl_refl sigstep_trancl_funas)+

lemma NE_to_rrstep:
  assumes "NE (srstep \<F> \<R>) (srstep \<F> \<S>)"
  shows  "\<And> s t. (s, t) \<in> srsteps_with_root_step \<F> \<R> \<Longrightarrow> NE_redp \<F> \<R> \<S> s t"
         "\<And> s t. (s, t) \<in> srsteps_with_root_step \<F> \<S> \<Longrightarrow> NE_redp \<F> \<S> \<R> s t"
  using assms unfolding NE_on_def NE_redp_def srsteps_with_root_step_def
  by (auto simp: normalizability_def simp flip: srstep_converse_dist
     dest!: srrstep_to_srestep) (meson converse_rtrancl_into_rtrancl rtrancl_trans)+

lemma NE_NF_eq:
  "NE \<R> \<S> \<Longrightarrow> NF \<R> = NF \<S>"
  by (auto simp: NE_on_def NF_def normalizability_def)

\<comment> \<open>Reducing search space for @{const SCR} and @{const WCR} involving root steps\<close>
(*Brute forced proofs could be done nicer with more lemmas related to positions *)

abbreviation "SCRp \<F> \<R> t u \<equiv> \<exists>v. (t, v) \<in> (srstep \<F> \<R>)\<^sup>= \<and> (u, v) \<in> (srstep \<F> \<R>)\<^sup>*"
lemma SCR_rrstep_intro:
  assumes "\<And> s t u. (s, t) \<in> sig_step \<F> (rrstep \<R>) \<Longrightarrow> (s, u) \<in> srstep \<F> \<R> \<Longrightarrow> SCRp \<F> \<R> t u"
    and "\<And> s t u. (s, t) \<in> srstep \<F> \<R> \<Longrightarrow> (s, u) \<in> sig_step \<F> (rrstep \<R>) \<Longrightarrow> SCRp \<F> \<R> t u"
  shows "SCR (srstep \<F> \<R>)"
proof -
  {fix s t u assume step: "(s, t) \<in> srstep \<F> \<R>" "(s, u) \<in> srstep \<F> \<R>"
    from step(1) obtain p l r \<sigma> where st: "p \<in> poss s" "(l, r) \<in> \<R>" "s |_ p = l \<cdot> \<sigma>" "t = s[p \<leftarrow> r \<cdot> \<sigma>]"
      using rstep_to_pos_replace[of s t \<R>] unfolding sig_step_def by blast
    from step(2) obtain q l2 r2 \<sigma>2 where su: "q \<in> poss s" "(l2, r2) \<in> \<R>" "s |_ q = l2 \<cdot> \<sigma>2" "u = s[q \<leftarrow> r2 \<cdot> \<sigma>2]"
      using rstep_to_pos_replace[of s u \<R>] unfolding sig_step_def by blast
    from step st su have funas: "funas_term s \<subseteq> \<F>" "funas_term t \<subseteq> \<F>" "funas_term u \<subseteq> \<F>"
      by (auto dest: srstepD)
    have funas2 :"funas_term (r2 \<cdot> \<sigma>2) \<subseteq> \<F>" using funas_term_replace_at_lower[OF su(1)]
      using funas(3) unfolding su(4) by blast
    consider (a) "p \<le>\<^sub>p q" | (b) "q \<le>\<^sub>p p" | (c) "p \<bottom> q"
      using position_par_def by blast
    then have "SCRp \<F> \<R> t u"
    proof cases
      case a
      from a have up: "p \<in> poss u" using st(1) su(1) unfolding st(4) su(4)
        by (metis pos_replace_at_pres position_less_eq_def poss_append_poss)
      let ?C = "ctxt_at_pos s p" have fc: "funas_ctxt ?C \<subseteq> \<F>" using funas(1) st(1)
        by (metis ctxt_at_pos_subt_at_id funas_ctxt_apply le_sup_iff)
      from funas have funas: "funas_term (s |_ p) \<subseteq> \<F>" "funas_term (t |_ p) \<subseteq> \<F>" "funas_term (u |_ p) \<subseteq> \<F>"
        using a st(1) pos_replace_at_pres[OF st(1)] up unfolding st(4) su(4)
        by (intro funas_term_subterm_atI, blast+)+
      have "(s |_ p, t |_ p) \<in> sig_step \<F> (rrstep \<R>)" unfolding st(4) su(4) using st(1 - 3) su(1 - 3) funas
        by (metis poss_of_termE poss_of_term_replace_term_at rrstep.intros sig_stepI st(4))
      moreover have "(s |_ p, u |_ p) \<in> srstep \<F> \<R>" unfolding st(4) su(4) using st(1 - 3) su(1 - 3) funas
        by (smt (verit, best) a ctxt_at_pos_subt_at_pos ctxt_of_pos_term_apply_replace_at_ident position_less_eq_def
            poss_append_poss replace_subterm_at_itself replace_term_at_subt_at_id rstepI sig_stepI su(4))
      ultimately obtain v where "(t |_ p, v) \<in> (srstep \<F> \<R>)\<^sup>=" "(u |_ p, v) \<in> (srstep \<F> \<R>)\<^sup>*"
        using assms(1) by blast
      from this(1) srsteps_eq_ctxt_closed[OF fc this(2)]
      show ?thesis using a st(1) su(1) srsteps_eq_ctxt_closed[OF fc] unfolding st(4) su(4)
        apply (intro exI[of _ "?C\<langle>v\<rangle>"])
        apply (auto simp: ctxt_of_pos_term_apply_replace_at_ident less_eq_subt_at_replace)
        apply (metis ctxt_of_pos_term_apply_replace_at_ident fc srstep_ctxt_closed)
        done
    next
      case b
      then have up: "q \<in> poss t" using st(1) su(1) unfolding st(4) su(4)
        by (metis pos_replace_at_pres position_less_eq_def poss_append_poss)
      let ?C = "ctxt_at_pos s q" have fc: "funas_ctxt ?C \<subseteq> \<F>" using funas(1) su(1)
        by (metis Un_subset_iff ctxt_at_pos_subt_at_id funas_ctxt_apply)
      from funas have funas: "funas_term (s |_ q) \<subseteq> \<F>" "funas_term (t |_ q) \<subseteq> \<F>" "funas_term (u |_ q) \<subseteq> \<F>"
        using su(1) pos_replace_at_pres[OF su(1)] up unfolding st(4) su(4)
        by (intro funas_term_subterm_atI, blast+)+
      have "(s |_ q, t |_ q) \<in> srstep \<F> \<R>" unfolding st(4) su(4) using st(1 - 3) su(1 - 3) funas
        by (smt (verit, del_insts) b ctxt_at_pos_subt_at_pos ctxt_of_pos_term_apply_replace_at_ident
            position_less_eq_def poss_append_poss replace_subterm_at_itself replace_term_at_subt_at_id rstepI sig_stepI st(4))
      moreover have "(s |_ q, u |_ q) \<in> sig_step \<F> (rrstep \<R>)" unfolding st(4) su(4) using st(1 - 3) su(1 - 3) funas
        by (metis poss_of_termE poss_of_term_replace_term_at rrstep.intros sig_stepI su(4))
      ultimately obtain v where "(t |_ q, v) \<in> (srstep \<F> \<R>)\<^sup>=" "(u |_ q, v) \<in> (srstep \<F> \<R>)\<^sup>*"
        using assms(2) by blast
      from this(1) srsteps_eq_ctxt_closed[OF fc this(2)]
      show ?thesis using b st(1) su(1) srsteps_eq_ctxt_closed[OF fc] unfolding st(4) su(4)
        apply (intro exI[of _ "?C\<langle>v\<rangle>"])
        apply (auto simp: ctxt_of_pos_term_apply_replace_at_ident less_eq_subt_at_replace)
        apply (smt (verit, best) ctxt_of_pos_term_apply_replace_at_ident fc less_eq_subt_at_replace replace_term_at_above replace_term_at_subt_at_id srstep_ctxt_closed)
        done
    next
      case c
      define v where "v = t[q \<leftarrow> r2 \<cdot> \<sigma>2]"
      have funasv: "funas_term v \<subseteq> \<F>" using funas su(1) unfolding v_def su(4)
        using funas_term_replace_at_upper funas2 by blast
      from c have *: "v = u[p \<leftarrow> r \<cdot> \<sigma>]" unfolding v_def st(4) su(4) using st(1) su(1)
        using parallel_replace_term_commute by blast
      from c have "(t, v) \<in> rstep \<R>" unfolding st(4) v_def
        using su(1 - 3) par_pos_replace_pres[OF su(1)]
        by (metis par_pos_replace_term_at pos_replace_to_rstep position_par_def)
      moreover from c have "(u, v) \<in> rstep \<R>" unfolding su(4) *
        using st(1 - 3) par_pos_replace_pres[OF st(1)]
        by (intro pos_replace_to_rstep[of _ _ l]) (auto simp: par_pos_replace_term_at)
      ultimately show ?thesis using funas(2-) funasv
        by auto
    qed}
  then show ?thesis unfolding SCR_on_def
    by blast
qed

lemma SCE_to_rrstep:
  assumes "SCR (srstep \<F> \<R>)"
  shows "\<And> s t u. (s, t) \<in> sig_step \<F> (rrstep \<R>) \<Longrightarrow> (s, u) \<in> srstep \<F> \<R> \<Longrightarrow> SCRp \<F> \<R> t u"
        "\<And> s t u. (s, t) \<in> srstep \<F> \<R> \<Longrightarrow> (s, u) \<in> sig_step \<F> (rrstep \<R>) \<Longrightarrow> SCRp \<F> \<R> t u"
  using assms unfolding SCR_on_def srsteps_with_root_step_def
  by (auto simp flip: srstep_converse_dist dest!: srrstep_to_srestep symcl_srsteps_conversion symcl_srstep_conversion)

lemma WCR_rrstep_intro:
  assumes "\<And> s t u. (s, t) \<in> sig_step \<F> (rrstep \<R>) \<Longrightarrow> (s, u) \<in> srstep \<F> \<R> \<Longrightarrow> (t, u) \<in> (srstep \<F> \<R>)\<^sup>\<down>"
  shows "WCR (srstep \<F> \<R>)"
proof -
  {fix s t u assume step: "(s, t) \<in> srstep \<F> \<R>" "(s, u) \<in> srstep \<F> \<R>"
    from step(1) obtain p l r \<sigma> where st: "p \<in> poss s" "(l, r) \<in> \<R>" "s |_ p = l \<cdot> \<sigma>" "t = s[p \<leftarrow> r \<cdot> \<sigma>]"
      using rstep_to_pos_replace[of s t \<R>] unfolding sig_step_def by blast
    from step(2) obtain q l2 r2 \<sigma>2 where su: "q \<in> poss s" "(l2, r2) \<in> \<R>" "s |_ q = l2 \<cdot> \<sigma>2" "u = s[q \<leftarrow> r2 \<cdot> \<sigma>2]"
      using rstep_to_pos_replace[of s u \<R>] unfolding sig_step_def by blast
    from step st su have funas: "funas_term s \<subseteq> \<F>" "funas_term t \<subseteq> \<F>" "funas_term u \<subseteq> \<F>"
      by (auto dest: srstepD)
    have funas2 :"funas_term (r2 \<cdot> \<sigma>2) \<subseteq> \<F>" using funas_term_replace_at_lower[OF su(1)]
      using funas(3) unfolding su(4) by blast
    consider (a) "p \<le>\<^sub>p q" | (b) "q \<le>\<^sub>p p" | (c) "p \<bottom> q"
      using position_par_def by blast
    then have "(t, u) \<in> (srstep \<F> \<R>)\<^sup>\<down>"
    proof cases
      case a
      then have up: "p \<in> poss u" using st(1) su(1) unfolding st(4) su(4)
        by (metis pos_replace_at_pres position_less_eq_def poss_append_poss)
      let ?C = "ctxt_at_pos s p" have fc: "funas_ctxt ?C \<subseteq> \<F>" using funas(1) st(1)
        by (metis Un_subset_iff ctxt_at_pos_subt_at_id funas_ctxt_apply)
      from funas have funas: "funas_term (s |_ p) \<subseteq> \<F>" "funas_term (t |_ p) \<subseteq> \<F>" "funas_term (u |_ p) \<subseteq> \<F>"
        using a st(1) pos_replace_at_pres[OF st(1)] up unfolding st(4) su(4)
        by (intro funas_term_subterm_atI, blast+)+
      have "(s |_ p, t |_ p) \<in> sig_step \<F> (rrstep \<R>)" unfolding st(4) su(4) using st(1 - 3) su(1 - 3) funas
        by (metis poss_of_termE poss_of_term_replace_term_at rrstep.intros sig_stepI st(4))
      moreover have "(s |_ p, u |_ p) \<in> srstep \<F> \<R>" unfolding st(4) su(4) using st(1 - 3) su(1 - 3) funas
        by (smt (verit, ccfv_threshold) a greater_eq_subt_at_replace less_eq_subt_at_replace pos_diff_append_itself
            pos_replace_to_rstep position_less_eq_def poss_append_poss replace_term_at_subt_at_id sig_stepI su(4))
      ultimately have "(t |_ p, u |_ p) \<in> (srstep \<F> \<R>)\<^sup>\<down>"
        using assms(1) by blast
      from sig_steps_join_ctxt_closed[OF fc this(1)]
      show ?thesis using a st(1) su(1) srstep_ctxt_closed[OF fc] unfolding st(4) su(4)
        by (auto simp: ctxt_of_pos_term_apply_replace_at_ident less_eq_subt_at_replace)
    next
      case b
      then have up: "q \<in> poss t" using st(1) su(1) unfolding st(4) su(4)
        by (metis pos_les_eq_append_diff pos_replace_at_pres poss_append_poss)
      let ?C = "ctxt_at_pos s q" have fc: "funas_ctxt ?C \<subseteq> \<F>" using funas(1) su(1)
        by (metis Un_subset_iff ctxt_at_pos_subt_at_id funas_ctxt_apply)
      from funas have funas: "funas_term (s |_ q) \<subseteq> \<F>" "funas_term (t |_ q) \<subseteq> \<F>" "funas_term (u |_ q) \<subseteq> \<F>"
        using su(1) pos_replace_at_pres[OF su(1)] up unfolding st(4) su(4)
        by (intro funas_term_subterm_atI, blast+)+
      have "(s |_ q, t |_ q) \<in> srstep \<F> \<R>" unfolding st(4) su(4) using st(1 - 3) su(1 - 3) funas
        by (smt (verit, ccfv_SIG) b greater_eq_subt_at_replace less_eq_subt_at_replace pos_diff_append_itself
            pos_replace_to_rstep position_less_eq_def poss_append_poss replace_term_at_subt_at_id sig_stepI st(4))
      moreover have "(s |_ q, u |_ q) \<in> sig_step \<F> (rrstep \<R>)" unfolding st(4) su(4) using st(1 - 3) su(1 - 3) funas
        by (metis poss_of_termE poss_of_term_replace_term_at rrstep.intros sig_stepI su(4))
      ultimately have "(t |_ q, u |_ q) \<in> (srstep \<F> \<R>)\<^sup>\<down>"
        using assms(1) by blast
      from sig_steps_join_ctxt_closed[OF fc this(1)]
      show ?thesis using b st(1) su(1) srstep_ctxt_closed[OF fc] unfolding st(4) su(4)
        by (auto simp: ctxt_of_pos_term_apply_replace_at_ident less_eq_subt_at_replace)
    next
      case c
      define v where "v = t[q \<leftarrow> r2 \<cdot> \<sigma>2]"
      have funasv: "funas_term v \<subseteq> \<F>" using funas su(1) unfolding v_def su(4)
        using funas_term_replace_at_upper funas2 by blast
      from c have *: "v = u[p \<leftarrow> r \<cdot> \<sigma>]" unfolding v_def st(4) su(4) using st(1) su(1)
        using parallel_replace_term_commute by blast
      from c have "(t, v) \<in> rstep \<R>" unfolding st(4) v_def
        using su(1 - 3) par_pos_replace_pres[OF su(1)]
        by (metis par_pos_replace_term_at pos_replace_to_rstep position_par_def)
      moreover from c have "(u, v) \<in> rstep \<R>" unfolding su(4) *
        using st(1 - 3) par_pos_replace_pres[OF st(1)]
        by (metis par_pos_replace_term_at pos_replace_to_rstep)
      ultimately show ?thesis using funas(2-) funasv
        by auto
    qed}
  then show ?thesis unfolding WCR_on_def
    by blast
qed

end


(*  Title:       Conflict analysis/Acquisition histories
    Author:      Peter Lammich <peter.lammich@uni-muenster.de>
    Maintainer:  Peter Lammich <peter.lammich@uni-muenster.de>
*)
section "Acquisition Histories"
theory AcquisitionHistory
imports ConsInterleave
begin
text_raw \<open>\label{thy:AcquisitionHistory}\<close>

text \<open>The concept of {\em acquisition histories} was introduced by Kahlon, Ivancic, and Gupta \<^cite>\<open>"KIG05"\<close> as a bounded size abstraction of executions that acquire and release locks that contains enough information
  to decide consistent interleavability. In this work, we use this concept for reentrant monitors.
  As in Section~\ref{thy:ConsInterleave}, we encode monitor usage information in pairs of sets of monitors, and regard lists of such pairs as (abstract) executions.
  An item @{term "(E,U)"} of such a list describes a sequence of steps of the concrete execution that first enters the monitors in @{term E} and then passes through the monitors in @{term U}. The monitors in @{term E} are
  never left by the execution. Note that due to the syntactic binding of monitors to the program structure, any execution of a single thread can be abstracted to a sequence of @{term "(E,U)"}-pairs.
  Restricting the possible schedules (see Section \ref{thy:Normalization}) will allow us to also abstract executions reaching a single program point to a sequence of such pairs.

  We want to decide whether two executions are interleavable. The key observation of \<^cite>\<open>"KIG05"\<close> is, that two executions @{term "e"} and @{term "e'"} are {\em not} interleavable if and only if
  there is a conflicting pair @{term "(m,m')"} of monitors, such that @{term e} enters (and never leaves) @{term m} and then uses @{term m'} and @{term e'} enters (and never leaves) @{term m'} and then uses @{term m}.

  An acquisition history is a map from monitors to set of monitors. The acquisition history of an execution maps a monitor @{term m} that is allocated at the end of the execution to all monitors that are used after or in the
  same step that finally enters @{term m}. Monitors that are not allocated at the end of an execution are mapped to the empty set. Though originally used for a setting without reentrant monitors, acquisition histories also work
  for our setting with reentrant monitors.

  This theory contains the definition of acquisition histories and acquisition history interleavability, an ordering on acquisition histories that reflects the blocking potential of acquisition histories,
  and a mapping function from paths to acquisition histories that is shown to be compatible with monitor consistent interleaving.\<close>

subsection "Definitions"
text \<open>Acquisition histories are modeled as functions from monitors to sets of monitors. Intuitively @{term "m'\<in>h m"} models that an execution finally is in @{term m}, and monitor @{term m'} has been used (i.e. passed or entered)
  after or at the same time @{term m} has been finally entered. By convention, we have @{term "m\<in>h m"} or @{term "h m = {}"}.
\<close>

  (* TODO: Make acquisition histories an own type, with access and update operator of sort order  *)
definition "ah == { (h::'m \<Rightarrow> 'm set) . \<forall> m. h m = {} \<or> m\<in>h m }"

lemma ah_cases[cases set]: "\<lbrakk>h\<in>ah; h m = {} \<Longrightarrow> P ; m \<in> h m \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (unfold ah_def) blast

subsection "Interleavability"
text \<open>Two acquisition histories @{term h1} and @{term h2} are considered interleavable, iff there is no conflicting pair of monitors @{term m1} and @{term m2},
  where a pair of monitors @{term m1} and @{term m2} is called {\em conflicting} iff @{term m1} is used in @{term h2} after entering @{term m2} and, vice versa, @{term m2} is used in @{term h1} after entering @{term m1}.\<close>
definition
  ah_il :: "('m \<Rightarrow> 'm set) \<Rightarrow> ('m \<Rightarrow> 'm set) \<Rightarrow> bool" (infix "[*]" 65)
  where
  "h1 [*] h2 == \<not>(\<exists>m1 m2. m1\<in>h2 m2 \<and> m2 \<in> h1 m1)"

text \<open>From our convention, it follows (as expected) that the sets of entered monitors (lock-sets) of two interleavable acquisition histories are disjoint\<close>
lemma ah_il_lockset_disjoint:
  "\<lbrakk> h1\<in>ah; h2\<in>ah; h1 [*] h2 \<rbrakk> \<Longrightarrow> h1 m = {} \<or> h2 m = {}"
  by (unfold ah_il_def) (auto elim: ah_cases)

text \<open>Of course, acquisition history interleavability is commutative\<close>
lemma ah_il_commute: "h1 [*] h2 \<Longrightarrow> h2 [*] h1"
  by (unfold ah_il_def) auto

subsection "Used monitors"
text \<open>Let's define the monitors of an acquisition history, as all monitors that occur in the acquisition history\<close>
definition
  mon_ah :: "('m \<Rightarrow> 'm set) \<Rightarrow> 'm set"
  where
  "mon_ah h == \<Union>{ h(m) | m. True}"

subsection "Ordering"
text \<open>The element-wise subset-ordering on acquisition histories intuitively reflects the blocking potential: The bigger the acquisition history, the fewer acquisition histories are interleavable with it.\<close>
text \<open>Note that the Isabelle standard library automatically lifts the subset ordering to functions, so we need no explicit definition here.\<close>

\<comment> \<open>The ordering is compatible with interleavability, i.e.\ smaller acquisition histories are more likely to be interleavable.\<close>
lemma ah_leq_il: "\<lbrakk> h1 [*] h2; h1' \<le> h1; h2' \<le> h2 \<rbrakk> \<Longrightarrow> h1' [*] h2'"
  by (unfold ah_il_def le_fun_def [where 'b="'a set"]) blast+
lemma ah_leq_il_left: "\<lbrakk> h1 [*] h2; h1' \<le> h1 \<rbrakk> \<Longrightarrow> h1' [*] h2" and
      ah_leq_il_right: "\<lbrakk> h1 [*] h2; h2' \<le> h2 \<rbrakk> \<Longrightarrow> h1 [*] h2'"
  by (unfold ah_il_def le_fun_def [where 'b="'a set"]) blast+

subsection "Acquisition histories of executions"
text \<open>Next we define a function that abstracts from executions (lists of enter/use pairs) to acquisition histories\<close>
primrec \<alpha>ah :: "('m set \<times> 'm set) list \<Rightarrow> 'm \<Rightarrow> 'm set" where
  "\<alpha>ah [] m = {}"
| "\<alpha>ah (e#w) m = (if m\<in>fst e then fst e \<union> snd e \<union> mon_pl w else \<alpha>ah w m)"

\<comment> \<open>@{term \<alpha>ah} generates valid acquisition histories\<close>
lemma \<alpha>ah_ah: "\<alpha>ah w \<in> ah"
  apply (induct w)
  apply (unfold ah_def)
  apply simp
  apply (fastforce split: if_split_asm)
  done

lemma \<alpha>ah_hd: "\<lbrakk>m\<in>fst e; x\<in>fst e \<union> snd e \<union> mon_pl w\<rbrakk> \<Longrightarrow> x\<in>\<alpha>ah (e#w) m"
  by auto
lemma \<alpha>ah_tl: "\<lbrakk>m\<notin>fst e; x\<in>\<alpha>ah w m\<rbrakk> \<Longrightarrow> x\<in>\<alpha>ah (e#w) m"
  by auto

lemma \<alpha>ah_cases[cases set, case_names hd tl]: "\<lbrakk>
    x\<in>\<alpha>ah w m;
    !!e w'. \<lbrakk>w=e#w'; m\<in>fst e; x\<in>fst e \<union> snd e \<union> mon_pl w'\<rbrakk> \<Longrightarrow> P;
    !!e w'. \<lbrakk>w=e#w'; m\<notin>fst e; x\<in>\<alpha>ah w' m\<rbrakk> \<Longrightarrow> P
  \<rbrakk> \<Longrightarrow> P"
  by (cases w) (simp_all split: if_split_asm)

lemma \<alpha>ah_cons_cases[cases set, case_names hd tl]: "\<lbrakk>
    x\<in>\<alpha>ah (e#w') m;
    \<lbrakk>m\<in>fst e; x\<in>fst e \<union> snd e \<union> mon_pl w'\<rbrakk> \<Longrightarrow> P;
    \<lbrakk>m\<notin>fst e; x\<in>\<alpha>ah w' m\<rbrakk> \<Longrightarrow> P
  \<rbrakk> \<Longrightarrow> P"
  by (simp_all split: if_split_asm)

lemma mon_ah_subset: "mon_ah (\<alpha>ah w) \<subseteq> mon_pl w"
  by (induct w) (auto simp add: mon_ah_def)

\<comment> \<open>Subwords generate smaller acquisition histories\<close>
lemma \<alpha>ah_ileq: "w1\<preceq>w2 \<Longrightarrow> \<alpha>ah w1 \<le> \<alpha>ah w2"
proof (induct rule: less_eq_list_induct)
  case empty thus ?case by (unfold le_fun_def [where 'b="'a set"], simp)
next
  case (drop l' l a) show ?case
  proof (unfold le_fun_def  [where 'b="'a set"], intro allI subsetI)
    fix m x
    assume A: "x \<in> \<alpha>ah l' m"
    with drop(2) have "x\<in>\<alpha>ah l m" by (unfold le_fun_def  [where 'b="'a set"], auto)
    moreover hence "x\<in>mon_pl l" using mon_ah_subset[unfolded mon_ah_def] by fast
    ultimately show "x\<in>\<alpha>ah (a # l) m" by auto
  qed
next
  case (take a b l' l) show ?case
  proof (unfold le_fun_def [where 'b="'a set"], intro allI subsetI)
    fix m x
    assume A: "x\<in>\<alpha>ah (a#l') m"
    thus "x \<in> \<alpha>ah (b # l) m"
    proof (cases rule: \<alpha>ah_cons_cases)
      case hd
      with mon_pl_ileq[OF take.hyps(2)] and \<open>a = b\<close>
      show ?thesis by auto
    next
      case tl
      with take.hyps(3)[unfolded le_fun_def [where 'b="'a set"]] and \<open>a = b\<close>
      show ?thesis by auto
    qed
  qed
qed

text \<open>We can now prove the relation of monitor consistent interleavability and interleavability of the acquisition histories.\<close>
lemma ah_interleavable1:
  "w \<in> w1 \<otimes>\<^bsub>\<alpha>\<^esub> w2 \<Longrightarrow> \<alpha>ah (map \<alpha> w1) [*] \<alpha>ah (map \<alpha> w2)"
  \<comment> \<open>The lemma is shown by induction on the structure of the monitor consistent interleaving operator\<close>
proof (induct w \<alpha> w1 w2 rule: cil_set_induct_fix\<alpha>)
  case empty show ?case by (simp add: ah_il_def) \<comment> \<open>The base case is trivial by the definition of @{term "([*])"}\<close>
next
  \<comment> \<open>Case: First step comes from the left word\<close>
  case (left e w' w1' w2) show ?case
  proof (rule ccontr) \<comment> \<open>We do a proof by contradiction\<close>
    \<comment> \<open>Assume there is a conflicting pair in the acquisition histories\<close>
    assume "\<not> \<alpha>ah (map \<alpha> (e # w1')) [*] \<alpha>ah (map \<alpha> w2)"
    then obtain m1 m2 where CPAIR: "m1 \<in> \<alpha>ah (map \<alpha> (e#w1')) m2" "m2 \<in> \<alpha>ah (map \<alpha> w2) m1" by (unfold ah_il_def, blast)
    \<comment> \<open>It comes either from the first step or not\<close>
    from CPAIR(1) have "(m2\<in>fst (\<alpha> e) \<and> m1 \<in> fst (\<alpha> e) \<union> snd (\<alpha> e) \<union> mon_pl (map \<alpha> w1')) \<or> (m2\<notin>fst (\<alpha> e) \<and> m1 \<in> \<alpha>ah (map \<alpha> w1') m2)" (is "?CASE1 \<or> ?CASE2")
      by (auto split: if_split_asm)
    moreover {
      \<comment> \<open>Case: One monitor of the conflicting pair is entered in the first step of the left path\<close>
      assume ?CASE1 hence C: "m2\<in>fst (\<alpha> e)" ..
      \<comment> \<open>Because the paths are consistently interleavable, the monitors entered in the first step must not occur in the other path\<close>
      from left(2) mon_ah_subset[of "map \<alpha> w2"] have "fst (\<alpha> e) \<inter> mon_ah (\<alpha>ah (map \<alpha> w2)) = {}" by auto
      \<comment> \<open>But this is a contradiction to being a conflicting pair\<close>
      with C CPAIR(2) have False by (unfold mon_ah_def, blast)
    } moreover {
      \<comment> \<open>Case: The first monitor of the conflicting pair is entered after the first step of the left path\<close>
      assume ?CASE2 hence C: "m1 \<in> \<alpha>ah (map \<alpha> w1') m2" ..
      \<comment> \<open>But this is a contradiction to the induction hypothesis, that says that the acquisition histories of the tail of the left path and the
        right path are interleavable\<close>
      with left(3) CPAIR(2) have False by (unfold ah_il_def, blast)
    } ultimately show False ..
  qed
next
  \<comment> \<open>Case: First step comes from the right word. This case is shown completely analogous\<close>
  case (right e w' w2' w1) show ?case
  proof (rule ccontr)
    assume "\<not> \<alpha>ah (map \<alpha> w1) [*] \<alpha>ah (map \<alpha> (e#w2'))"
    then obtain m1 m2 where CPAIR: "m1 \<in> \<alpha>ah (map \<alpha> w1) m2" "m2 \<in> \<alpha>ah (map \<alpha> (e#w2')) m1" by (unfold ah_il_def, blast)
    from CPAIR(2) have "(m1\<in>fst (\<alpha> e) \<and> m2 \<in> fst (\<alpha> e) \<union> snd (\<alpha> e) \<union> mon_pl (map \<alpha> w2')) \<or> (m1\<notin>fst (\<alpha> e) \<and> m2 \<in> \<alpha>ah (map \<alpha> w2') m1)" (is "?CASE1 \<or> ?CASE2")
      by (auto split: if_split_asm)
    moreover {
      assume ?CASE1 hence C: "m1\<in>fst (\<alpha> e)" ..
      from right(2) mon_ah_subset[of "map \<alpha> w1"] have "fst (\<alpha> e) \<inter> mon_ah (\<alpha>ah (map \<alpha> w1)) = {}" by auto
      with C CPAIR(1) have False by (unfold mon_ah_def, blast)
    } moreover {
      assume ?CASE2 hence C: "m2 \<in> \<alpha>ah (map \<alpha> w2') m1" ..
      with right(3) CPAIR(1) have False by (unfold ah_il_def, blast)
    } ultimately show False ..
  qed
qed

lemma ah_interleavable2:
  assumes A: "\<alpha>ah (map \<alpha> w1) [*] \<alpha>ah (map \<alpha> w2)"
  shows "w1 \<otimes>\<^bsub>\<alpha>\<^esub> w2 \<noteq> {}"
  \<comment> \<open>This lemma is shown by induction on the sum of the word lengths\<close>
proof -
  \<comment> \<open>To apply this induction in Isabelle, we have to rewrite the lemma a bit\<close>
  { fix n
    have "!!w1 w2. \<lbrakk>\<alpha>ah (map \<alpha> w1) [*] \<alpha>ah (map \<alpha> w2); n=length w1 + length w2\<rbrakk> \<Longrightarrow> w1 \<otimes>\<^bsub>\<alpha>\<^esub> w2 \<noteq> {}"
    proof (induct n rule: nat_less_induct[case_names I])
      \<comment> \<open>We first rule out the cases that one of the words is empty\<close>
      case (I n w1 w2) show ?case proof (cases w1)
        \<comment> \<open>If the first word is empty, the lemma is trivial\<close>
        case Nil with I.prems show ?thesis by simp
      next
        case (Cons e1 w1') note CONS1=this show ?thesis proof (cases w2)
          \<comment> \<open>If the second word is empty, the lemma is also trivial\<close>
          case Nil with I.prems show ?thesis by simp
        next
          \<comment> \<open>The interesting case is if both words are not empty\<close>
          case (Cons e2 w2') note CONS2=this
          \<comment> \<open>In this case, we check whether the first step of one of the words can safely be executed without blocking any steps of the other word\<close>
          show ?thesis proof (cases "fst (\<alpha> e1) \<inter> mon_pl (map \<alpha> w2) = {}")
            case True \<comment> \<open>The first step of the first word can safely be executed\<close>
            \<comment> \<open>From the induction hypothesis, we get that there is a consistent interleaving of the rest of the first word and the second word\<close>
            have "w1'\<otimes>\<^bsub>\<alpha>\<^esub>w2 \<noteq> {}" proof -
              from I.prems(1) CONS1 ah_leq_il_left[OF _ \<alpha>ah_ileq[OF le_list_map, OF less_eq_list_drop[OF order_refl]]] have "\<alpha>ah (map \<alpha> w1') [*] \<alpha>ah (map \<alpha> w2)" by fast
              moreover from CONS1 I.prems(2) have "length w1'+length w2 < n" by simp
              ultimately show ?thesis using I.hyps by blast
            qed
            \<comment> \<open>And because the first step of the first word can be safely executed, we can prepend it to that consistent interleaving\<close>
            with cil_cons1[OF _ True] CONS1 show ?thesis by blast
          next
            case False note C1=this
            show ?thesis proof (cases "fst (\<alpha> e2) \<inter> mon_pl (map \<alpha> w1) = {}")
              case True \<comment> \<open>The first step of the second word can safely be executed\<close>
              \<comment> \<open>This case is shown analogously to the latter one\<close>
              have "w1\<otimes>\<^bsub>\<alpha>\<^esub>w2' \<noteq> {}" proof -
                from I.prems(1) CONS2 ah_leq_il_right[OF _ \<alpha>ah_ileq[OF le_list_map, OF less_eq_list_drop[OF order_refl]]] have "\<alpha>ah (map \<alpha> w1) [*] \<alpha>ah (map \<alpha> w2')" by fast
                moreover from CONS2 I.prems(2) have "length w1+length w2' < n" by simp
                ultimately show ?thesis using I.hyps by blast
              qed
              with cil_cons2[OF _ True] CONS2 show ?thesis by blast
            next
              case False note C2=this \<comment> \<open>Neither first step can safely be executed. This is exactly the situation from that we can extract a conflicting pair\<close>
              from C1 C2 obtain m1 m2 where "m1\<in>fst (\<alpha> e1)" "m1\<in>mon_pl (map \<alpha> w2)" "m2\<in>fst (\<alpha> e2)" "m2\<in>mon_pl (map \<alpha> w1)" by blast
              with CONS1 CONS2 have "m2 \<in> \<alpha>ah (map \<alpha> w1) m1" "m1 \<in> \<alpha>ah (map \<alpha> w2) m2" by auto
              \<comment> \<open>But by assumption, there are no conflicting pairs, thus we get a contradiction\<close>
              with I.prems(1) have False by (unfold ah_il_def) blast
              thus ?thesis ..
            qed
          qed
        qed
      qed
    qed
  } with A show ?thesis by blast
qed

text \<open>Finally, we can state the relationship between monitor consistent interleaving and interleaving of acquisition histories\<close>
theorem ah_interleavable:
  "(\<alpha>ah (map \<alpha> w1) [*] \<alpha>ah (map \<alpha> w2)) \<longleftrightarrow> (w1\<otimes>\<^bsub>\<alpha>\<^esub>w2\<noteq>{})"
  using ah_interleavable1 ah_interleavable2 by blast

subsection "Acquisition history backward update"
text \<open>We define a function to update an acquisition history backwards. This function is useful for constructing acquisition histories in backward constraint systems.\<close>
definition
  ah_update :: "('m \<Rightarrow> 'm set) \<Rightarrow> ('m set * 'm set) \<Rightarrow> 'm set \<Rightarrow> ('m \<Rightarrow> 'm set)"
  where
  "ah_update h F M m == if m\<in>fst F then fst F \<union> snd F \<union> M else h m"

text \<open>
  Intuitively, @{term "ah_update h (E,U) M m"} means to prepend a step @{term "(E,U)"} to the acquisition history @{term h} of a path that uses monitors @{term M}. Note that we need the extra parameter @{term M}, since
  an acquisition history does not contain information about the monitors that are used on a path before the first monitor that will not be left has been entered.
\<close>
lemma ah_update_cons: "\<alpha>ah (e#w) = ah_update (\<alpha>ah w) e (mon_pl w)"
  by (auto intro!: ext simp add: ah_update_def)

text \<open>The backward-update function is monotonic in the first and third argument as well as in the used monitors of the second argument.
  Note that it is, in general, not monotonic in the entered monitors of the second argument.\<close>
lemma ah_update_mono: "\<lbrakk>h \<le> h'; F=F'; M\<subseteq>M'\<rbrakk>
  \<Longrightarrow> ah_update h F M \<le> ah_update h' F' M'"
  by (auto simp add: ah_update_def le_fun_def [where 'b="'a set"])
lemma ah_update_mono2: "\<lbrakk>h \<le> h'; U\<subseteq>U'; M\<subseteq>M'\<rbrakk>
  \<Longrightarrow> ah_update h (E,U) M \<le> ah_update h' (E,U') M'"
  by (auto simp add: ah_update_def le_fun_def [where 'b="'a set"])

end